[uim-commit] r1267 - in branches/r5rs/sigscheme: . test
kzk at freedesktop.org
kzk at freedesktop.org
Sun Aug 21 21:48:34 EST 2005
Author: kzk
Date: 2005-08-21 04:48:30 -0700 (Sun, 21 Aug 2005)
New Revision: 1267
Modified:
branches/r5rs/sigscheme/datas.c
branches/r5rs/sigscheme/operations.c
branches/r5rs/sigscheme/sigscheme.c
branches/r5rs/sigscheme/sigscheme.h
branches/r5rs/sigscheme/test/bigloo-list.scm
branches/r5rs/sigscheme/test/io.scm
branches/r5rs/sigscheme/test/test-apply.scm
branches/r5rs/sigscheme/test/test-continuation.scm
branches/r5rs/sigscheme/test/test-define.scm
branches/r5rs/sigscheme/test/test-delay-force.scm
branches/r5rs/sigscheme/test/test-equation.scm
branches/r5rs/sigscheme/test/test-eval.scm
branches/r5rs/sigscheme/test/test-exp.scm
branches/r5rs/sigscheme/test/test-list.scm
branches/r5rs/sigscheme/test/test-num.scm
branches/r5rs/sigscheme/test/test-string.scm
branches/r5rs/sigscheme/test/unittest-bigloo.scm
Log:
* Apply big patch from Jun Inoue<jun.lambda at gmail.com>. Thank you very much!
* Using assert-equal? instead of assert-eq? in test case
* test/test-eval.scm
* test/test-define.scm
* test/test-exp.scm
* test/test-string.scm
* test/test-equation.scm
* test/test-apply.scm
* test/test-delay-force.scm
* test/test-num.scm
* test/test-continuation.scm
* test/test-list.scm
- use assert-equal? instead of assert-eq? for value comparison
* test/unittest-bigloo.scm
- (test): fix mistake
* test/io.scm
- show message
* sigscheme/sigscheme.c
- (SigScm_Initialize)
: change "<", ">", "<=" and ">=" funcname.
: change "+", "*", "-", "/" type
: change "number->string" type
: move scm_return_value's declaration place
* sigscheme/sigscheme.h
- (ScmOp_less): renamed from ScmOp_bigger
- (ScmOp_greater): renamed from ScmOp_smaller
- (ScmOp_lessEq): renamed from ScmOp_biggerEq
- (ScmOp_greaterEq): renamed from ScmOp_smallerEq
- (ScmOp_plus2n, ScmOp_minus2n, ScmOp_multi2n, ScmOp_divide2n): removed
- (ScmOp_plus, ScmOp_minus, ScmOp_times, ScmOp_divide): new func
- (ScmOp_number_to_string): support radix
* sigscheme/operations.c
- (list_gettail, ScmOp_append_internal): removed
- (ScmOp_less): renamed from ScmOp_bigger
- (ScmOp_greater): renamed from ScmOp_smaller
- (ScmOp_lessEq): renamed from ScmOp_biggerEq
- (ScmOp_greaterEq): renamed from ScmOp_smallerEq
- (ScmOp_plus2n, ScmOp_minus2n, ScmOp_multi2n, ScmOp_divide2n): removed
- (ScmOp_plus, ScmOp_minus, ScmOp_times, ScmOp_divide): new func
- (ScmOp_number_to_string): support radix
- (ScmOp_equal): more proper arg len check
- (ScmOp_c_length): remove unnecessary check
- (ScmOp_append): not to destruct given list
- (ScmOp_listtail_internal): change to while loop from recursive call
- (ScmOp_list_ref): more informational error message
- (ScmOp_memq): remove unnecessary check
- (ScmOp_assq, ScmOp_assv, ScmOp_member): strict check when SCM_STRICT_R5RS is
defined
- (ScmOp_symbol_to_string): goto error when non-symbol is given as argument
- (ScmOp_string_to_symbol): use Scm_NewStringCopying
* sigscheme/datas.c
- (allocate_heap, add_heap): optimize
Modified: branches/r5rs/sigscheme/datas.c
===================================================================
--- branches/r5rs/sigscheme/datas.c 2005-08-21 11:15:38 UTC (rev 1266)
+++ branches/r5rs/sigscheme/datas.c 2005-08-21 11:48:30 UTC (rev 1267)
@@ -124,8 +124,8 @@
/*=======================================
Variable Declarations
=======================================*/
-static int SCM_HEAP_SIZE = 16384;
-static int scm_heap_num = 64;
+static int SCM_HEAP_SIZE = 10240;
+static int scm_heap_num = 8;
static ScmObjHeap *scm_heaps = NULL;
static ScmObj scm_freelist = NULL;
@@ -204,9 +204,7 @@
static void allocate_heap(ScmObjHeap **heaps, int num_heap, int HEAP_SIZE, ScmObj *freelist)
{
int i = 0;
- int j = 0;
- ScmObj prev = NULL;
- ScmObj next = NULL;
+ ScmObj heap, cell;
#if DEBUG_GC
printf("allocate_heap num:%d size:%d\n", num_heap, HEAP_SIZE);
@@ -219,27 +217,17 @@
/* fill with zero and construct free_list */
for (i = 0; i < num_heap; i++) {
/* Initialize Heap */
- (*heaps)[i] = (ScmObj)malloc_aligned(sizeof(ScmObjInternal) * HEAP_SIZE);
- memset((*heaps)[i], 0, sizeof(ScmObjInternal) * HEAP_SIZE);
+ heap = (ScmObj)malloc_aligned(sizeof(ScmObjInternal) * HEAP_SIZE);
+ (*heaps)[i] = heap;
/* link in order */
- prev = NULL;
- next = NULL;
- for (j = 0; j < HEAP_SIZE; j++) {
- next = &(*heaps)[i][j];
- SCM_SETFREECELL(next);
-
- /* prev's cdr is next */
- if (prev)
- SCM_SETFREECELL_CDR(prev, next);
-
- /* the last cons' cdr is freelist */
- if (j == HEAP_SIZE - 1)
- SCM_SETFREECELL_CDR(next, (*freelist));
-
- prev = next;
+ for (cell=heap; cell-heap < HEAP_SIZE; cell++) {
+ SCM_SETFREECELL(cell);
+ SCM_DO_UNMARK(cell);
+ SCM_SETFREECELL_CDR(cell, cell+1);
}
+ SCM_SETFREECELL_CDR(cell-1, (*freelist));
/* and freelist is head of the heap */
(*freelist) = (*heaps)[i];
}
@@ -247,10 +235,8 @@
static void add_heap(ScmObjHeap **heaps, int *orig_num_heap, int HEAP_SIZE, ScmObj *freelist)
{
- int i = 0;
int num_heap = 0;
- ScmObj prev = NULL;
- ScmObj next = NULL;
+ ScmObj heap, cell;
#if DEBUG_GC
printf("add_heap current num of heaps:%d\n", *orig_num_heap);
@@ -264,24 +250,17 @@
(*heaps) = (ScmObj*)realloc((*heaps), sizeof(ScmObj) * num_heap);
/* allocate heap */
- (*heaps)[num_heap - 1] = (ScmObj)malloc_aligned(sizeof(ScmObjInternal) * HEAP_SIZE);
- memset((*heaps)[num_heap - 1], 0, sizeof(ScmObjInternal) * HEAP_SIZE);
+ heap = (ScmObj)malloc_aligned(sizeof(ScmObjInternal) * HEAP_SIZE);
+ (*heaps)[num_heap - 1] = heap;
/* link in order */
- for (i = 0; i < HEAP_SIZE; i++) {
- next = &(*heaps)[num_heap - 1][i];
- SCM_SETFREECELL(next);
-
- if (prev)
- SCM_SETFREECELL_CDR(prev, next);
-
- /* the last cons' cdr is freelist */
- if (i == HEAP_SIZE - 1)
- SCM_SETFREECELL_CDR(next, (*freelist));
-
- prev = next;
+ for (cell=heap; cell-heap < HEAP_SIZE; cell++) {
+ SCM_SETFREECELL(cell);
+ SCM_DO_UNMARK(cell);
+ SCM_SETFREECELL_CDR(cell, cell+1);
}
+ SCM_SETFREECELL_CDR(cell-1, *freelist);
(*freelist) = (*heaps)[num_heap - 1];
}
Modified: branches/r5rs/sigscheme/operations.c
===================================================================
--- branches/r5rs/sigscheme/operations.c 2005-08-21 11:15:38 UTC (rev 1266)
+++ branches/r5rs/sigscheme/operations.c 2005-08-21 11:48:30 UTC (rev 1267)
@@ -36,6 +36,7 @@
=======================================*/
#include <string.h>
#include <stdlib.h>
+#include <limits.h>
/*=======================================
Local Include
@@ -49,6 +50,7 @@
/*=======================================
File Local Macro Declarations
=======================================*/
+#define SCM_INVALID NULL
/*=======================================
Variable Declarations
@@ -58,10 +60,8 @@
/*=======================================
File Local Function Declarations
=======================================*/
-static ScmObj list_gettail(ScmObj head);
static int ScmOp_c_length(ScmObj list);
static ScmObj ScmOp_listtail_internal(ScmObj obj, int k);
-static ScmObj ScmOp_append_internal(ScmObj head, ScmObj tail);
/*=======================================
Function Implementations
@@ -243,64 +243,94 @@
/*==============================================================================
R5RS : 6.2 Numbers : 6.2.5 Numerical Operations
==============================================================================*/
-ScmObj ScmOp_plus2n(ScmObj obj1, ScmObj obj2)
+/* Note: SigScheme supports only the integer part of the numerical tower. */
+
+ScmObj ScmOp_plus(ScmObj args, ScmObj env)
{
- if (SCM_NULLP(obj1) && SCM_NULLP(obj2))
- return Scm_NewInt(0);
+ int result = 0;
+ ScmObj ls;
+ ScmObj operand;
- if (!SCM_INTP(obj1))
- SigScm_ErrorObj("+ : integer required but got ", obj1);
+ for (ls = args; !SCM_NULLP(ls); ls = SCM_CDR(ls)) {
+ operand = SCM_CAR(ls);
+ if (!SCM_INTP(operand))
+ SigScm_ErrorObj("+ : integer required but got ", operand);
+ result += SCM_INT_VALUE(operand);
+ }
- if (SCM_NULLP(obj2))
- return Scm_NewInt(SCM_INT_VALUE(obj1));
+ return Scm_NewInt(result);
+}
- if (!SCM_INTP(obj2))
- SigScm_ErrorObj("+ : integer required but got ", obj2);
+ScmObj ScmOp_times(ScmObj args, ScmObj env)
+{
+ int result = 1;
+ ScmObj operand;
+ ScmObj ls;
- return Scm_NewInt(SCM_INT_VALUE(obj1) + SCM_INT_VALUE(obj2));
+ for (ls=args; !SCM_NULLP(ls); ls = SCM_CDR(ls)) {
+ operand = SCM_CAR(ls);
+ if (!SCM_INTP(operand))
+ SigScm_ErrorObj("* : integer required but got ", operand);
+ result *= SCM_INT_VALUE(operand);
+ }
+
+ return Scm_NewInt(result);
}
-ScmObj ScmOp_minus2n(ScmObj obj1, ScmObj obj2)
+ScmObj ScmOp_minus(ScmObj args, ScmObj env)
{
- if (!SCM_INTP(obj1))
- SigScm_ErrorObj("- : integer required but got ", obj1);
+ int result;
+ ScmObj operand;
+ ScmObj ls;
- if (SCM_NULLP(obj2))
- return Scm_NewInt(-(SCM_INT_VALUE(obj1)));
+ ls = args;
+ if (SCM_NULLP(ls))
+ SigScm_Error("- : at least 1 argument required");
- if (!SCM_INTP(obj2))
- SigScm_ErrorObj("- : integer required but got ", obj2);
+ result = SCM_INT_VALUE(SCM_CAR(ls));
+ ls = SCM_CDR(ls);
- return Scm_NewInt(SCM_INT_VALUE(obj1) - SCM_INT_VALUE(obj2));
+ /* single arg */
+ if (SCM_NULLP(ls))
+ return Scm_NewInt(-result);
+
+ for (; !SCM_NULLP(ls); ls = SCM_CDR(ls)) {
+ operand = SCM_CAR(ls);
+ if (!SCM_INTP(operand))
+ SigScm_ErrorObj("- : integer required but got ", operand);
+ result -= SCM_INT_VALUE(operand);
+ }
+
+ return Scm_NewInt(result);
}
-ScmObj ScmOp_multi2n(ScmObj obj1, ScmObj obj2)
+ScmObj ScmOp_divide(ScmObj args, ScmObj env)
{
- if (SCM_NULLP(obj1) && SCM_NULLP(obj2))
- return Scm_NewInt(1);
+ int result;
+ ScmObj operand;
+ ScmObj ls;
- if (!SCM_INTP(obj1))
- SigScm_ErrorObj("* : integer required but got ", obj1);
+ if (SCM_NULLP(args))
+ SigScm_Error("/ : at least 1 argument required");
- if (SCM_NULLP(obj2))
- return Scm_NewInt(SCM_INT_VALUE(obj1));
+ result = SCM_INT_VALUE(SCM_CAR(args));
+ ls = SCM_CDR(args);
- if (!SCM_INTP(obj2))
- SigScm_ErrorObj("* : integer required but got ", obj2);
+ /* single arg */
+ if (SCM_NULLP(ls))
+ return Scm_NewInt(1 / result);
- return Scm_NewInt(SCM_INT_VALUE(obj1) * SCM_INT_VALUE(obj2));
-}
+ for (; !SCM_NULLP(ls); ls = SCM_CDR(ls)) {
+ operand = SCM_CAR(ls);
+ if (!SCM_INTP(operand))
+ SigScm_ErrorObj("/ : integer required but got ", operand);
-ScmObj ScmOp_divide2n(ScmObj obj1, ScmObj obj2)
-{
- if (!SCM_INTP(obj1))
- SigScm_ErrorObj("/ : integer required but got ", obj1);
- if (!SCM_INTP(obj2))
- SigScm_ErrorObj("/ : integer required but got ", obj2);
- if (EQ(ScmOp_zerop(obj2), SCM_TRUE))
- SigScm_Error("/ : divide by zero\n");
+ if (SCM_INT_VALUE(operand) == 0)
+ SigScm_ErrorObj("/ : division by zero ", args);
+ result /= SCM_INT_VALUE(operand);
+ }
- return Scm_NewInt(SCM_INT_VALUE(obj1) / SCM_INT_VALUE(obj2));
+ return Scm_NewInt(result);
}
ScmObj ScmOp_numberp(ScmObj obj)
@@ -316,14 +346,14 @@
int val = 0;
ScmObj obj = SCM_NIL;
+ /* arglen check */
+ if CHECK_2_ARGS(args)
+ SigScm_Error("= : Wrong number of arguments\n");
+
/* type check */
if (EQ(ScmOp_numberp(SCM_CAR(args)), SCM_FALSE))
SigScm_ErrorObj("= : number required but got ", SCM_CAR(args));
- /* arglen check */
- if CHECK_2_ARGS(args)
- SigScm_Error("= : Wrong number of arguments\n");
-
/* Get first value */
val = SCM_INT_VALUE(SCM_CAR(args));
@@ -342,7 +372,7 @@
return SCM_TRUE;
}
-ScmObj ScmOp_bigger(ScmObj args, ScmObj env )
+ScmObj ScmOp_less(ScmObj args, ScmObj env )
{
int val = 0;
int car_val = 0;
@@ -374,7 +404,7 @@
return SCM_TRUE;
}
-ScmObj ScmOp_smaller(ScmObj args, ScmObj env )
+ScmObj ScmOp_greater(ScmObj args, ScmObj env )
{
int val = 0;
int car_val = 0;
@@ -407,7 +437,7 @@
return SCM_TRUE;
}
-ScmObj ScmOp_biggerEq(ScmObj args, ScmObj env )
+ScmObj ScmOp_lessEq(ScmObj args, ScmObj env )
{
int val = 0;
int car_val = 0;
@@ -441,7 +471,7 @@
return SCM_TRUE;
}
-ScmObj ScmOp_smallerEq(ScmObj args, ScmObj env )
+ScmObj ScmOp_greaterEq(ScmObj args, ScmObj env )
{
int val = 0;
int car_val = 0;
@@ -529,6 +559,7 @@
int max = 0;
int car_val = 0;
ScmObj car = SCM_NIL;
+ ScmObj maxobj = SCM_NIL;
if (SCM_NULLP(args))
SigScm_Error("max : at least 1 number required\n");
@@ -538,9 +569,11 @@
if (EQ(ScmOp_numberp(car), SCM_FALSE))
SigScm_ErrorObj("max : number required but got ", car);
- car_val = SCM_INT_VALUE(SCM_CAR(args));
- if (max < car_val)
+ car_val = SCM_INT_VALUE(car);
+ if (max < car_val) {
max = car_val;
+ maxobj = car;
+ }
}
return Scm_NewInt(max);
@@ -551,6 +584,7 @@
int min = 0;
int car_val = 0;
ScmObj car = SCM_NIL;
+ ScmObj minobj = SCM_NIL;
if (SCM_NULLP(args))
SigScm_Error("min : at least 1 number required\n");
@@ -560,12 +594,14 @@
if (EQ(ScmOp_numberp(car), SCM_FALSE))
SigScm_ErrorObj("min : number required but got ", car);
- car_val = SCM_INT_VALUE(SCM_CAR(args));
- if (car_val < min)
+ car_val = SCM_INT_VALUE(car);
+ if (car_val < min) {
min = car_val;
+ minobj = car;
+ }
}
- return Scm_NewInt(min);
+ return minobj;
}
@@ -648,36 +684,60 @@
/*==============================================================================
R5RS : 6.2 Numbers : 6.2.6 Numerical input and output
==============================================================================*/
-/* TODO : support radix */
-ScmObj ScmOp_number_to_string(ScmObj z)
+ScmObj ScmOp_number_to_string (ScmObj args, ScmObj env)
{
- int n = 0;
- int i = 0;
- int size = 0;
- char *str = NULL;
+ char buf[sizeof(int)*CHAR_BIT + 1];
+ char *p;
+ unsigned int n, r;
+ ScmObj number, radix;
- if (EQ(ScmOp_numberp(z), SCM_FALSE))
- SigScm_ErrorObj("number->string : number required but got ", z);
+ if (CHECK_1_ARG(args))
+ SigScm_ErrorObj("number->string: requires 1 or 2 arguments: ", args);
- /* get value */
- n = SCM_INT_VALUE(z);
+ number = SCM_CAR(args);
+ if (!SCM_INTP(number))
+ SigScm_ErrorObj("number->string: integer required but got ", number);
- /* get size */
- for (size = 1; (int)(n / 10) != 0; size++)
- n /= 10;
+ n = SCM_INT_VALUE(number);
- /* allocate str */
- str = (char *)malloc(sizeof(char) * size + 1);
+ /* r = radix */
+ if (SCM_NULLP(SCM_CDR(args)))
+ r = 10;
+ else {
+#ifdef SCM_STRICT_ARGCHECK
+ if (!SCM_NULLP(SCM_CDDR(args)))
+ SigScm_ErrorObj("number->string: too many arguments: ", args);
+#endif
+ radix = SCM_CADR(args);
+ if (!SCM_INTP(radix))
+ SigScm_ErrorObj("number->string: integer required but got ", radix);
+ r = SCM_INT_VALUE(radix);
- /* fill str */
- n = SCM_INT_VALUE(z);
- str[size] = '\0';
- for (i = size; 0 < i; i--) {
- str[i - 1] = '0' + (n % 10);
- n /= 10;
+ if (!(2 <= r && r <= 16))
+ SigScm_ErrorObj("number->string: invalid or unsupported radix: ",
+ radix);
+ }
+
+ /* no signs for nondecimals */
+ if (r != 10)
+ n = abs(n);
+
+ /* initialize buffer */
+ p = &buf[sizeof(buf)-1];
+ *p = 0;
+
+ do
+ {
+ if (n % r > 9)
+ *--p = 'A' + n % r - 10;
+ else
+ *--p = '0' + n % r;
}
+ while (n /= r);
+ if (r == 10 && SCM_INT_VALUE (number) < 0)
+ *--p = '-';
- return Scm_NewString(str);
+ return Scm_NewStringCopying(p);
}
/* TODO : support radix */
@@ -697,7 +757,7 @@
return SCM_FALSE;
}
- return Scm_NewInt((int)atof(SCM_STRING_STR(string)));
+ return Scm_NewInt((int)atoi(SCM_STRING_STR(string)));
}
/*===================================
@@ -944,34 +1004,16 @@
return SCM_TRUE;
}
-static ScmObj list_gettail(ScmObj head)
-{
- ScmObj tail = head;
-
- if (SCM_NULLP(head)) return SCM_NIL;
-
- while (1) {
- if (!SCM_CONSP(tail) || SCM_NULLP(SCM_CDR(tail)))
- return tail;
-
- tail = SCM_CDR(tail);
- }
-
- return SCM_NIL;
-}
-
/*
* Notice
*
* This function is ported from Gauche, by Shiro Kawai(shiro at acm.org)
*/
-int ScmOp_c_length(ScmObj obj)
+static int ScmOp_c_length(ScmObj obj)
{
ScmObj slow = obj;
int len = 0;
- if (SCM_NULLP(obj)) return 0;
-
for (;;) {
if (SCM_NULLP(obj)) break;
if (!SCM_CONSP(obj)) return -1;
@@ -996,91 +1038,85 @@
return Scm_NewInt(ScmOp_c_length(obj));
}
-ScmObj ScmOp_append_internal(ScmObj head, ScmObj tail)
+ScmObj ScmOp_append(ScmObj args, ScmObj env)
{
- ScmObj head_tail = SCM_NIL;
+ ScmObj ret_list = SCM_NIL;
+ ScmObj *ret_tail = &ret_list;
- /* TODO : need to rewrite using ScmOp_listp? */
- if (SCM_NULLP(head))
- return tail;
+ ScmObj ls;
+ ScmObj obj = SCM_NIL;
- if (!SCM_CONSP(head))
- SigScm_ErrorObj("append : list required but got ", head);
+ if (SCM_NULLP(args))
+ return SCM_NIL;
- head_tail = list_gettail(head);
- if (SCM_NULLP(head_tail)) {
- return tail;
- } else if (SCM_CONSP(head_tail)) {
- SCM_SETCDR(head_tail, tail);
- } else {
- SigScm_ErrorObj("append : list required but got ", head_tail);
+ /* duplicate and merge all but the last argument */
+ for (; !SCM_NULLP(SCM_CDR(args)); args = SCM_CDR(args)) {
+ for (ls = SCM_CAR(args); SCM_CONSP(ls); ls = SCM_CDR(ls)) {
+ obj = SCM_CAR(ls);
+ *ret_tail = Scm_NewCons(obj, SCM_NIL);
+ ret_tail = &SCM_CDR(*ret_tail);
+ }
+ if (!SCM_NULLP(ls))
+ SigScm_ErrorObj("append: proper list required but got: ",
+ SCM_CAR(args));
}
- return head;
-}
+ /* append the last argument */
+ *ret_tail = SCM_CAR(args);
-ScmObj ScmOp_append(ScmObj args, ScmObj env)
-{
- ScmObj ret = SCM_NIL;
- ScmObj obj = SCM_NIL;
- for (; !SCM_NULLP(args); args = SCM_CDR(args)) {
- obj = SCM_CAR(args);
- ret = ScmOp_append_internal(ret, obj);
- }
-
- return ret;
+ return ret_list;
}
ScmObj ScmOp_reverse(ScmObj list)
{
ScmObj ret_list = SCM_NIL;
- /* TODO : canbe optimized not to use ScmOp_listp */
- if (EQ(ScmOp_listp(list), SCM_FALSE))
- SigScm_ErrorObj("reverse : list required but got ", list);
-
- for (; !SCM_NULLP(list); list = SCM_CDR(list)) {
+ for (; SCM_CONSP(list); list = SCM_CDR(list))
ret_list = Scm_NewCons(SCM_CAR(list), ret_list);
- }
+ if (!SCM_NULLP(list))
+ SigScm_ErrorObj("reverse: got improper list: ", list);
+
return ret_list;
}
-/* TODO : not to use recursive call for avoiding stack overflow*/
-ScmObj ScmOp_listtail_internal(ScmObj obj, int k)
+static ScmObj ScmOp_listtail_internal(ScmObj list, int k)
{
- if (k == 0) {
- return obj;
+ while (k--) {
+ if (!SCM_CONSP(list))
+ return SCM_INVALID;
+ list = SCM_CDR(list);
}
- if (SCM_NULLP(obj))
- SigScm_Error("already reached tail\n");
-
- return ScmOp_listtail_internal(SCM_CDR(obj), k - 1);
+ return list;
}
ScmObj ScmOp_list_tail(ScmObj list, ScmObj scm_k)
{
- if (EQ(ScmOp_listp(list), SCM_FALSE))
- SigScm_ErrorObj("list-tail : list required but got ", list);
+ ScmObj ret;
+
if (EQ(ScmOp_numberp(scm_k), SCM_FALSE))
- SigScm_ErrorObj("list-tail : number required but got ", scm_k);
+ SigScm_ErrorObj("list-tail: number required but got ", scm_k);
- return ScmOp_listtail_internal(list, SCM_INT_VALUE(scm_k));
+ ret = ScmOp_listtail_internal(list, SCM_INT_VALUE(scm_k));
+
+ if (EQ(ret, SCM_INVALID))
+ SigScm_ErrorObj("list-tail: out of range or bad list, arglist is: ",
+ Scm_NewCons(list, scm_k));
+ return ret;
}
ScmObj ScmOp_list_ref(ScmObj list, ScmObj scm_k)
{
ScmObj list_tail = SCM_NIL;
- if (EQ(ScmOp_listp(list), SCM_FALSE))
- SigScm_ErrorObj("list-ref : list required but got ", list);
if (EQ(ScmOp_numberp(scm_k), SCM_FALSE))
SigScm_ErrorObj("list-ref : int required but got ", scm_k);
list_tail = ScmOp_listtail_internal(list, SCM_INT_VALUE(scm_k));
- if (SCM_NULLP(list_tail))
- SigScm_ErrorObj("list-ref : out of range ", scm_k);
+ if (EQ(list_tail, SCM_INVALID))
+ SigScm_ErrorObj("list-ref : out of range or bad list, arglist is: ",
+ Scm_NewCons(list, scm_k));
return SCM_CAR(list_tail);
}
@@ -1088,10 +1124,8 @@
ScmObj ScmOp_memq(ScmObj obj, ScmObj list)
{
ScmObj tmplist = SCM_NIL;
- ScmObj tmpobj = SCM_NIL;
for (tmplist = list; SCM_CONSP(tmplist); tmplist = SCM_CDR(tmplist)) {
- tmpobj = SCM_CAR(tmplist);
- if (EQ(ScmOp_eqp(obj, tmpobj), SCM_TRUE)) {
+ if (EQ(obj, SCM_CAR(tmplist))) {
return tmplist;
}
}
@@ -1131,10 +1165,20 @@
{
ScmObj tmplist = SCM_NIL;
ScmObj tmpobj = SCM_NIL;
+ ScmObj car;
+
for (tmplist = alist; SCM_CONSP(tmplist); tmplist = SCM_CDR(tmplist)) {
tmpobj = SCM_CAR(tmplist);
- if (SCM_CONSP(tmpobj) && EQ(ScmOp_eqp(SCM_CAR(tmpobj), obj), SCM_TRUE))
+ car = SCM_CAR(tmpobj);
+#if SCM_STRICT_R5RS
+ if (!SCM_CONSP(tmpobj))
+ SigScm_ErrorObj("assq: invalid alist: ", alist);
+ if (EQ(SCM_CAR(tmpobj), obj))
+ return tmpobj;
+#else
+ if (SCM_CONSP(tmpobj) && EQ(SCM_CAR(tmpobj), obj))
return tmpobj;
+#endif
}
return SCM_FALSE;
@@ -1144,10 +1188,20 @@
{
ScmObj tmplist = SCM_NIL;
ScmObj tmpobj = SCM_NIL;
+ ScmObj car;
+
for (tmplist = alist; SCM_CONSP(tmplist); tmplist = SCM_CDR(tmplist)) {
tmpobj = SCM_CAR(tmplist);
- if (SCM_CONSP(tmpobj) && EQ(ScmOp_eqvp(SCM_CAR(tmpobj), obj), SCM_TRUE))
+ car = SCM_CAR(tmpobj);
+#if SCM_STRICT_R5RS
+ if (!SCM_CONSP(tmpobj))
+ SigScm_ErrorObj("assv: invalid alist: ", alist);
+ if (EQ(ScmOp_eqvp(car, obj), SCM_TRUE))
+ return tmpobj;
+#else
+ if (SCM_CONSP(tmpobj) && EQ(ScmOp_eqvp(car, obj), SCM_TRUE))
return tmpobj;
+#endif
}
return SCM_FALSE;
@@ -1157,10 +1211,20 @@
{
ScmObj tmplist = SCM_NIL;
ScmObj tmpobj = SCM_NIL;
+ ScmObj car;
+
for (tmplist = alist; SCM_CONSP(tmplist); tmplist = SCM_CDR(tmplist)) {
tmpobj = SCM_CAR(tmplist);
- if (SCM_CONSP(tmpobj) && EQ(ScmOp_equalp(SCM_CAR(tmpobj), obj), SCM_TRUE))
+ car = SCM_CAR(tmpobj);
+#if SCM_STRICT_R5RS
+ if (!SCM_CONSP(tmpobj))
+ SigScm_ErrorObj("assoc: invalid alist: ", alist);
+ if (EQ(ScmOp_equalp(car, obj), SCM_TRUE))
+ return tmpobj;
+#else
+ if (SCM_CONSP(tmpobj) && EQ(ScmOp_equalp(car, obj), SCM_TRUE))
return tmpobj;
+#endif
}
return SCM_FALSE;
@@ -1181,22 +1245,17 @@
ScmObj ScmOp_symbol_to_string(ScmObj obj)
{
if (!SCM_SYMBOLP(obj))
- return SCM_FALSE;
+ SigScm_ErrorObj("symbol->string: symbol required, but got ", obj);
return Scm_NewStringCopying(SCM_SYMBOL_NAME(obj));
}
ScmObj ScmOp_string_to_symbol(ScmObj str)
{
- char *name = NULL;
-
if(!SCM_STRINGP(str))
- return SCM_FALSE;
+ SigScm_ErrorObj("string->symbol: string required, but got ", str);
- name = (char*)alloca(strlen(SCM_STRING_STR(str)) + 1);
- strcpy(name, SCM_STRING_STR(str));
-
- return Scm_Intern(name);
+ return Scm_Intern(SCM_STRING_STR(str));
}
/*==============================================================================
Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c 2005-08-21 11:15:38 UTC (rev 1266)
+++ branches/r5rs/sigscheme/sigscheme.c 2005-08-21 11:48:30 UTC (rev 1267)
@@ -66,6 +66,10 @@
extern ScmObj continuation_thrown_obj, letrec_env;
+#if SCM_COMPAT_SIOD
+extern ScmObj scm_return_value;
+#endif
+
/*=======================================
Function Implementations
=======================================*/
@@ -143,10 +147,10 @@
Scm_RegisterFunc1("number?" , ScmOp_numberp);
Scm_RegisterFunc1("integer?" , ScmOp_numberp);
Scm_RegisterFuncL("=" , ScmOp_equal);
- Scm_RegisterFuncL("<" , ScmOp_bigger);
- Scm_RegisterFuncL(">" , ScmOp_smaller);
- Scm_RegisterFuncL("<=" , ScmOp_biggerEq);
- Scm_RegisterFuncL(">=" , ScmOp_smallerEq);
+ Scm_RegisterFuncL("<" , ScmOp_less);
+ Scm_RegisterFuncL(">" , ScmOp_greater);
+ Scm_RegisterFuncL("<=" , ScmOp_lessEq);
+ Scm_RegisterFuncL(">=" , ScmOp_greaterEq);
Scm_RegisterFunc1("zero?" , ScmOp_zerop);
Scm_RegisterFunc1("positive?" , ScmOp_positivep);
Scm_RegisterFunc1("negative?" , ScmOp_negativep);
@@ -154,15 +158,15 @@
Scm_RegisterFunc1("even?" , ScmOp_evenp);
Scm_RegisterFuncL("max" , ScmOp_max);
Scm_RegisterFuncL("min" , ScmOp_min);
- Scm_RegisterFunc2N("+" , ScmOp_plus2n);
- Scm_RegisterFunc2N("*" , ScmOp_multi2n);
- Scm_RegisterFunc2N("-" , ScmOp_minus2n);
- Scm_RegisterFunc2N("/" , ScmOp_divide2n);
+ Scm_RegisterFuncL("+" , ScmOp_plus);
+ Scm_RegisterFuncL("*" , ScmOp_times);
+ Scm_RegisterFuncL("-" , ScmOp_minus);
+ Scm_RegisterFuncL("/" , ScmOp_divide);
Scm_RegisterFunc1("abs" , ScmOp_abs);
Scm_RegisterFunc2("quotient" , ScmOp_quotient);
Scm_RegisterFunc2("modulo" , ScmOp_modulo);
Scm_RegisterFunc2("remainder" , ScmOp_remainder);
- Scm_RegisterFunc1("number->string" , ScmOp_number_to_string);
+ Scm_RegisterFuncL("number->string" , ScmOp_number_to_string);
Scm_RegisterFunc1("string->number" , ScmOp_string_to_number);
Scm_RegisterFunc1("not" , ScmOp_not);
Scm_RegisterFunc1("boolean?" , ScmOp_booleanp);
@@ -330,7 +334,6 @@
Scm_RegisterFuncL("the-environment" , ScmOp_the_environment);
Scm_RegisterFunc1("%%closure-code" , ScmOp_closure_code);
/* datas.c */
- extern ScmObj scm_return_value;
scm_return_value = SCM_NIL;
#endif
Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h 2005-08-21 11:15:38 UTC (rev 1266)
+++ branches/r5rs/sigscheme/sigscheme.h 2005-08-21 11:48:30 UTC (rev 1267)
@@ -209,10 +209,10 @@
ScmObj ScmOp_equalp(ScmObj obj1, ScmObj obj2);
ScmObj ScmOp_numberp(ScmObj obj);
ScmObj ScmOp_equal(ScmObj list, ScmObj env);
-ScmObj ScmOp_bigger(ScmObj list, ScmObj env);
-ScmObj ScmOp_smaller(ScmObj list, ScmObj env);
-ScmObj ScmOp_biggerEq(ScmObj list, ScmObj env);
-ScmObj ScmOp_smallerEq(ScmObj list, ScmObj env);
+ScmObj ScmOp_less(ScmObj list, ScmObj env);
+ScmObj ScmOp_greater(ScmObj list, ScmObj env);
+ScmObj ScmOp_lessEq(ScmObj list, ScmObj env);
+ScmObj ScmOp_greaterEq(ScmObj list, ScmObj env);
ScmObj ScmOp_zerop(ScmObj num);
ScmObj ScmOp_positivep(ScmObj num);
ScmObj ScmOp_negativep(ScmObj num);
@@ -220,15 +220,15 @@
ScmObj ScmOp_evenp(ScmObj num);
ScmObj ScmOp_max(ScmObj list, ScmObj env);
ScmObj ScmOp_min(ScmObj list, ScmObj env);
-ScmObj ScmOp_plus2n(ScmObj obj1, ScmObj obj2);
-ScmObj ScmOp_minus2n(ScmObj obj1, ScmObj obj2);
-ScmObj ScmOp_multi2n(ScmObj obj1, ScmObj obj2);
-ScmObj ScmOp_divide2n(ScmObj obj1, ScmObj obj2);
+ScmObj ScmOp_plus(ScmObj args, ScmObj env);
+ScmObj ScmOp_minus(ScmObj args, ScmObj env);
+ScmObj ScmOp_times(ScmObj args, ScmObj env);
+ScmObj ScmOp_divide(ScmObj args, ScmObj env);
ScmObj ScmOp_abs(ScmObj num);
ScmObj ScmOp_quotient(ScmObj n1, ScmObj n2);
ScmObj ScmOp_modulo(ScmObj n1, ScmObj n2);
ScmObj ScmOp_remainder(ScmObj n1, ScmObj n2);
-ScmObj ScmOp_number_to_string(ScmObj z);
+ScmObj ScmOp_number_to_string(ScmObj args, ScmObj env);
ScmObj ScmOp_string_to_number(ScmObj string);
ScmObj ScmOp_not(ScmObj obj);
ScmObj ScmOp_booleanp(ScmObj obj);
Modified: branches/r5rs/sigscheme/test/bigloo-list.scm
===================================================================
--- branches/r5rs/sigscheme/test/bigloo-list.scm 2005-08-21 11:15:38 UTC (rev 1266)
+++ branches/r5rs/sigscheme/test/bigloo-list.scm 2005-08-21 11:48:30 UTC (rev 1267)
@@ -99,7 +99,11 @@
; (test "remq!" (let ((x '(1 2 3 4))) (remq! 2 x) x) '(1 3 4))
; (test "delete" (let ((x '(1 2 (3 4) 5))) (delete '(3 4) x)) '(1 2 5))
; (test "delete!" (let ((x '(1 2 (3 4) 5))) (delete! '(3 4) x) x) '(1 2 5))
- (test "memq.1" (memq 3 '(1 2 3 4 5)) '(3 4 5))
+
+; Changed expected value from '(3 4 5) to #f, since eq? on numbers
+; return #f. When we deploy tagged pointers, this may change.
+; (test "memq.1" (memq 3 '(1 2 3 4 5)) '(3 4 5))
+ (test "memq.1" (memq 3 '(1 2 3 4 5)) #f)
(test "memq.2" (memq #\a '(1 2 3 4 5)) #f)
(test "member.2" (member '(2 3) '((1 2) (2 3) (3 4) (4 5)))
'((2 3) (3 4) (4 5)))
Modified: branches/r5rs/sigscheme/test/io.scm
===================================================================
--- branches/r5rs/sigscheme/test/io.scm 2005-08-21 11:15:38 UTC (rev 1266)
+++ branches/r5rs/sigscheme/test/io.scm 2005-08-21 11:48:30 UTC (rev 1267)
@@ -1 +1,2 @@
+(display "type an sexp:")
(print (read-char))
Modified: branches/r5rs/sigscheme/test/test-apply.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-apply.scm 2005-08-21 11:15:38 UTC (rev 1266)
+++ branches/r5rs/sigscheme/test/test-apply.scm 2005-08-21 11:48:30 UTC (rev 1267)
@@ -1,14 +1,14 @@
(load "./test/unittest.scm")
;; check apply
-(assert-eq? "apply check1" #t (apply = '(1 1 1)))
-(assert-eq? "apply check2" 6 (apply + `(1 2 ,(+ 1 2))))
+(assert-equal? "apply check1" #t (apply = '(1 1 1)))
+(assert-equal? "apply check2" 6 (apply + `(1 2 ,(+ 1 2))))
(assert-equal? "apply check3" '(3) (apply cddr '((1 2 3))))
(assert-equal? "apply check4" #t (apply equal? '((1 2) (1 2))))
(assert-equal? "apply check5" "iu" (apply substring '("aiueo" 1 3)))
-(assert-eq? "apply check6" 4 (apply (lambda (x y) (+ x y)) '(1 3)))
-(assert-eq? "apply check7" 4 (apply (lambda (x y) (+ x y)) '(1 3)))
+(assert-equal? "apply check6" 4 (apply (lambda (x y) (+ x y)) '(1 3)))
+(assert-equal? "apply check7" 4 (apply (lambda (x y) (+ x y)) '(1 3)))
(assert-equal? "apply check8" '(1 2 3) (apply (lambda x x) '(1 2 3)))
(assert-equal? "apply check9" 1 (apply (lambda (x) x) '(1)))
(assert-equal? "apply check10" '(1) (apply (lambda x x) '(1)))
Modified: branches/r5rs/sigscheme/test/test-continuation.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-continuation.scm 2005-08-21 11:15:38 UTC (rev 1266)
+++ branches/r5rs/sigscheme/test/test-continuation.scm 2005-08-21 11:48:30 UTC (rev 1267)
@@ -1,6 +1,6 @@
(load "test/unittest.scm")
-(assert-eq? "call/cc test1" -3 (call-with-current-continuation
+(assert-equal? "call/cc test1" -3 (call-with-current-continuation
(lambda (exit)
(for-each (lambda (x)
(if (negative? x)
@@ -21,7 +21,7 @@
(return #f))))))
(re obj))))))
-(assert-eq? "call/cc test2" 4 (list-length '(1 2 3 4)))
-(assert-eq? "call/cc test3" #f (list-length '(a b . c)))
+(assert-equal? "call/cc test2" 4 (list-length '(1 2 3 4)))
+(assert-equal? "call/cc test3" #f (list-length '(a b . c)))
(total-report)
Modified: branches/r5rs/sigscheme/test/test-define.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-define.scm 2005-08-21 11:15:38 UTC (rev 1266)
+++ branches/r5rs/sigscheme/test/test-define.scm 2005-08-21 11:48:30 UTC (rev 1267)
@@ -2,21 +2,21 @@
; basic define
(define val1 3)
-(assert-eq? "basic define check" 3 val1)
+(assert-equal? "basic define check" 3 val1)
; redefine
(define val1 5)
-(assert-eq? "redefine check" 5 val1)
+(assert-equal? "redefine check" 5 val1)
; define lambda
(define (what? x)
"DEADBEEF" x)
-(assert-eq? "func define" 10 (what? 10))
+(assert-equal? "func define" 10 (what? 10))
(define what2?
(lambda (x)
"DEADBEEF" x))
-(assert-eq? "func define" 10 (what2? 10))
+(assert-equal? "func define" 10 (what2? 10))
(define (nullarg)
"nullarg")
@@ -24,7 +24,7 @@
(define (add x y)
(+ x y))
-(assert-eq? "func define" 10 (add 2 8))
+(assert-equal? "func define" 10 (add 2 8))
; tests for dot list arguments
(define (dotarg1 . a)
@@ -33,7 +33,7 @@
(define (dotarg2 a . b)
a)
-(assert-eq? "dot arg test 2" 1 (dotarg2 1 2))
+(assert-equal? "dot arg test 2" 1 (dotarg2 1 2))
(define (dotarg3 a . b)
b)
@@ -43,7 +43,7 @@
(define (dotarg4 a b . c)
b)
-(assert-eq? "dot arg test 5" 2 (dotarg4 1 2 3))
+(assert-equal? "dot arg test 5" 2 (dotarg4 1 2 3))
(define (dotarg5 a b . c)
c)
@@ -55,7 +55,7 @@
(+ c 3))
(idefine-i a))
-(assert-eq? "internal define1" 5 (idefine-o 2))
+(assert-equal? "internal define1" 5 (idefine-o 2))
(define (idefine0 a)
(define (idefine1 . args)
@@ -64,7 +64,7 @@
(+ c 2))
(+ (idefine1 1 2 3 4 5) (idefine2 a)))
-(assert-eq? "internal define2" 17 (idefine0 0))
+(assert-equal? "internal define2" 17 (idefine0 0))
(total-report)
Modified: branches/r5rs/sigscheme/test/test-delay-force.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-delay-force.scm 2005-08-21 11:15:38 UTC (rev 1266)
+++ branches/r5rs/sigscheme/test/test-delay-force.scm 2005-08-21 11:48:30 UTC (rev 1267)
@@ -1,10 +1,9 @@
(load "test/unittest.scm")
;; check delay and force
-(assert-eq? "delay-force check" 6 (begin
- (define foo (delay
- (+ 1 2 3)))
+(assert-equal? "delay-force check" 6 (begin
+ (define foo (delay
+ (+ 1 2 3)))
+ (force foo)))
- (force foo)))
-
(total-report)
Modified: branches/r5rs/sigscheme/test/test-equation.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-equation.scm 2005-08-21 11:15:38 UTC (rev 1266)
+++ branches/r5rs/sigscheme/test/test-equation.scm 2005-08-21 11:48:30 UTC (rev 1267)
@@ -31,17 +31,17 @@
)))
;; check eq?
-(assert-eq? "eq? check empty list" '() '())
+(assert-equal? "eq? check empty list" '() '())
(define pair1 (cons 'a 'b))
(define pair2 pair1)
-(assert-eq? "eq? check cons" pair1 pair2)
+(assert-equal? "eq? check cons" pair1 pair2)
(define str1 (string #\a))
(define str2 str1)
-(assert-eq? "eq? check cons" str1 str2)
+(assert-equal? "eq? check cons" str1 str2)
-(assert-eq? "eq? check func" + +)
+(assert-equal? "eq? check func" + +)
;; check equal?
(assert "basic equal? test1" (equal? 'a 'a))
Modified: branches/r5rs/sigscheme/test/test-eval.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-eval.scm 2005-08-21 11:15:38 UTC (rev 1266)
+++ branches/r5rs/sigscheme/test/test-eval.scm 2005-08-21 11:48:30 UTC (rev 1267)
@@ -1,8 +1,8 @@
(load "test/unittest.scm")
;; check eval
-(assert-eq? "eval check" 3 (eval '(+ 1 2) '()))
+(assert-equal? "eval check" 3 (eval '(+ 1 2) '()))
-(assert-eq? "eval check" 3 (eval '((lambda (x y) (+ x y)) 1 2) '()))
+(assert-equal? "eval check" 3 (eval '((lambda (x y) (+ x y)) 1 2) '()))
(total-report)
Modified: branches/r5rs/sigscheme/test/test-exp.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-exp.scm 2005-08-21 11:15:38 UTC (rev 1266)
+++ branches/r5rs/sigscheme/test/test-exp.scm 2005-08-21 11:48:30 UTC (rev 1267)
@@ -1,14 +1,14 @@
(load "./test/unittest.scm")
;; lambda
-(assert-eq? "basic lambda test1" 8 ((lambda (x) (+ x x)) 4))
+(assert-equal? "basic lambda test1" 8 ((lambda (x) (+ x x)) 4))
(define reverse-subtract
(lambda (x y) (- y x)))
-(assert-eq? "basic lambda test2" 3 (reverse-subtract 7 10))
+(assert-equal? "basic lambda test2" 3 (reverse-subtract 7 10))
(define add4
(let ((x 4))
(lambda (y) (+ x y))))
-(assert-eq? "basic lambda test3" 10 (add4 6))
+(assert-equal? "basic lambda test3" 10 (add4 6))
(assert-equal? "basic lambda test4" '(3 4 5 6) ((lambda x x) 3 4 5 6))
(assert-equal? "basic lambda test5" '(5) ((lambda (x y . z) z) 3 4 5))
(assert-equal? "basic lambda test6" '(5 6) ((lambda (x y . z) z) 3 4 5 6))
@@ -33,45 +33,45 @@
(else #f)))
;; case
-(assert-eq? "basic case check1" 'case1 (case 1
+(assert-equal? "basic case check1" 'case1 (case 1
((1) 'case1)
((2) 'case2)))
-(assert-eq? "basic case check2" 'case2 (case 2
+(assert-equal? "basic case check2" 'case2 (case 2
((1) 'case1)
((2) 'case2)))
-(assert-eq? "basic case check3" #t (case (* 2 3)
+(assert-equal? "basic case check3" #t (case (* 2 3)
((2 3 4 7) #f)
((1 4 6 8 9) #t)))
-(assert-eq? "basic case else" 'caseelse (case 3
+(assert-equal? "basic case else" 'caseelse (case 3
((1) 'case1)
((2) 'case2)
(else
'caseelse)))
;; and
-(assert-eq? "and test 1" #t (and (= 2 2) (> 2 1)))
-(assert-eq? "and test 2" #f (and (= 2 2) (< 2 1)))
+(assert-equal? "and test 1" #t (and (= 2 2) (> 2 1)))
+(assert-equal? "and test 2" #f (and (= 2 2) (< 2 1)))
(assert-equal? "and test 3" '(f g) (and 1 2 'c '(f g)))
(assert-equal? "and test 4" #t (and))
;; or
-(assert-eq? "or test1" #t (or (= 2 2) (> 2 1)))
-(assert-eq? "or test2" #t (or (= 2 2) (< 2 1)))
-(assert-eq? "or test3" #f (or #f #f #f))
+(assert-equal? "or test1" #t (or (= 2 2) (> 2 1)))
+(assert-equal? "or test2" #t (or (= 2 2) (< 2 1)))
+(assert-equal? "or test3" #f (or #f #f #f))
(assert-equal? "or test4" '(b c) (or (memq 'b '(a b c))
(/ 3 0)))
;; let
-(assert-eq? "basic let test1" 0 (let ((n 0))
+(assert-equal? "basic let test1" 0 (let ((n 0))
n))
-(assert-eq? "basic let test2" 1 (let ((n 0))
+(assert-equal? "basic let test2" 1 (let ((n 0))
(set! n 1)))
-(assert-eq? "basic let test3" 1 (let ((n 0))
+(assert-equal? "basic let test3" 1 (let ((n 0))
(set! n (+ n 1))))
-(assert-eq? "basic let test4" 3 (let ((n1 2)
+(assert-equal? "basic let test4" 3 (let ((n1 2)
(n2 1))
(+ n1 n2)))
(define count
@@ -79,16 +79,16 @@
(lambda ()
(set! n (+ n 1)))))
-(assert-eq? "lexical scope test1" 1 (count))
-(assert-eq? "lexical scope test2" 2 (count))
+(assert-equal? "lexical scope test1" 1 (count))
+(assert-equal? "lexical scope test2" 2 (count))
(define a 3)
(define (lexical-test)
(let ((a 1))
- (assert-eq? "lexical scope test3" 1 a)
+ (assert-equal? "lexical scope test3" 1 a)
(let* ((a 2))
- (assert-eq? "lexical scope test4" 2 a))
- (assert-eq? "lexical scope test5" 1 a)))
+ (assert-equal? "lexical scope test4" 2 a))
+ (assert-equal? "lexical scope test5" 1 a)))
(lexical-test)
(assert-equal? "named let test" '((6 1 3) (-5 -2)) (let loop ((numbers '(3 -2 1 6 -5))
@@ -105,13 +105,13 @@
(cons (car numbers) neg))))))
;; let*
-(assert-eq? "basic let* test1" 70 (let ((x 2) (y 3))
+(assert-equal? "basic let* test1" 70 (let ((x 2) (y 3))
(let* ((x 7)
(z (+ x y)))
(* z x))))
;; letrec
-(assert-eq? "basic letrec test1" #t (letrec ((even?
+(assert-equal? "basic letrec test1" #t (letrec ((even?
(lambda (n)
(if (zero? n)
#t
@@ -141,15 +141,15 @@
;; begin
(define x 0)
-(assert-eq? "basic begin test1" 6 (begin
+(assert-equal? "basic begin test1" 6 (begin
(set! x 5)
(+ x 1)))
-(assert-eq? "basic begin test2" 0 (begin
+(assert-equal? "basic begin test2" 0 (begin
0))
-(assert-eq? "basic begin test3" 1 (begin
+(assert-equal? "basic begin test3" 1 (begin
0
1))
-(assert-eq? "basic begin test4" 1 (begin
+(assert-equal? "basic begin test4" 1 (begin
(define n 0)
(set! n 1)))
;; do
@@ -167,7 +167,7 @@
(y 1))
((= i n) y)
(set! y (* x y))))
-(assert-eq? "do test3" 1024 (expt-do 2 10))
+(assert-equal? "do test3" 1024 (expt-do 2 10))
(define (nreverse rev-it)
(do ((reved '() rev-it)
Modified: branches/r5rs/sigscheme/test/test-list.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-list.scm 2005-08-21 11:15:38 UTC (rev 1266)
+++ branches/r5rs/sigscheme/test/test-list.scm 2005-08-21 11:48:30 UTC (rev 1267)
@@ -3,8 +3,8 @@
; pair?
(assert "pair? test1" (pair? '(a . b)))
(assert "pair? test2" (pair? '(a b c)))
-(assert-eq? "pair? test3" #f (pair? '()))
-(assert-eq? "pair? test4" #f (pair? '#(a b)))
+(assert-equal? "pair? test3" #f (pair? '()))
+(assert-equal? "pair? test4" #f (pair? '#(a b)))
; cons
(assert-equal? "cons test1" '(a) (cons 'a '()))
@@ -13,24 +13,24 @@
(assert-equal? "cons test4" '((a b) . c) (cons '(a b) 'c))
; car
-(assert-eq? "car test1" 'a (car '(a b c)))
+(assert-equal? "car test1" 'a (car '(a b c)))
(assert-equal? "car test2" '(a) (car '((a) b c)))
-(assert-eq? "car test3" 1 (car '(1 . 2)))
+(assert-equal? "car test3" 1 (car '(1 . 2)))
; cdr
(assert-equal? "cdr test1" '(b c d) (cdr '((a) b c d)))
-(assert-eq? "cdr test2" 2 (cdr '(1 . 2)))
+(assert-equal? "cdr test2" 2 (cdr '(1 . 2)))
; null?
(assert "null? test1" (null? '()))
-(assert-eq? "null? test2" #f (null? "aiueo"))
+(assert-equal? "null? test2" #f (null? "aiueo"))
; list?
(assert "list? test1" (list? '(a b c)))
(assert "list? test2" (list? '()))
-(assert-eq? "list? test3" #f (list? '(a . b)))
+(assert-equal? "list? test3" #f (list? '(a . b)))
; TODO : check finite length of the list!
-;(assert-eq? "list? test4" #f (let ((x (list 'a)))
+;(assert-equal? "list? test4" #f (let ((x (list 'a)))
; (set-cdr! x x)
; (list? x)))
@@ -39,14 +39,21 @@
(assert-equal? "list test2" '() (list))
; length
-(assert-eq? "length test1" 3 (length '(a b c)))
-(assert-eq? "length test2" 3 (length '(a (b) (c d e))))
-(assert-eq? "length test2" 0 (length '()))
+(assert-equal? "length test1" 3 (length '(a b c)))
+(assert-equal? "length test2" 3 (length '(a (b) (c d e))))
+(assert-equal? "length test2" 0 (length '()))
; append
(assert-equal? "append test1" '(x y) (append '(x) '(y)))
(assert-equal? "append test2" '(a b c d) (append '(a) '(b c d)))
(assert-equal? "append test3" '(a (b) (c)) (append '(a (b)) '((c))))
+(define w '(n o))
+(define x '(d o))
+(define y '(car))
+(define z '(why))
+(assert-equal? "append test4" '(n o d o car why . ta) (append w x y () z 'ta))
+(assert-equal? "append test5" '(n o) w) ; test non-destructiveness
+(assert-equal? "append test6" x (cdr (append '((Calpis hosi-)) x))) ; share last
; reverse
(assert-equal? "reverse test1" '(c b a) (reverse '(a b c)))
@@ -59,7 +66,7 @@
(assert-equal? "list-tail test4" '() (list-tail '(a b c) 3))
; list-ref
-(assert-eq? "list-ref test1" 'c (list-ref '(a b c d) 2))
+(assert-equal? "list-ref test1" 'c (list-ref '(a b c d) 2))
; memq
(assert-equal? "memq test1" '(a b c) (memq 'a '(a b c)))
Modified: branches/r5rs/sigscheme/test/test-num.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-num.scm 2005-08-21 11:15:38 UTC (rev 1266)
+++ branches/r5rs/sigscheme/test/test-num.scm 2005-08-21 11:48:30 UTC (rev 1267)
@@ -1,41 +1,41 @@
(load "test/unittest.scm")
-(assert-eq? "= test" #t (= 1 1))
-(assert-eq? "+ test1" 0 (+))
-(assert-eq? "+ test2" 3 (+ 3))
-(assert-eq? "+ test3" 3 (+ 1 2))
-(assert-eq? "+ test4" 6 (+ 1 2 3))
-(assert-eq? "- test1" -3 (- 3))
-(assert-eq? "- test2" -1 (- 1 2))
-(assert-eq? "- test3" -4 (- 1 2 3))
-(assert-eq? "* test1" 1 (*))
-(assert-eq? "* test2" 2 (* 2))
-(assert-eq? "* test3" 24 (* 2 3 4))
-(assert-eq? "/ test1" 0 (/ 1 2))
-(assert-eq? "/ test2" -1 (/ -2 2))
+(assert-equal? "= test" #t (= 1 1))
+(assert-equal? "+ test1" 0 (+))
+(assert-equal? "+ test2" 3 (+ 3))
+(assert-equal? "+ test3" 3 (+ 1 2))
+(assert-equal? "+ test4" 6 (+ 1 2 3))
+(assert-equal? "- test1" -3 (- 3))
+(assert-equal? "- test2" -1 (- 1 2))
+(assert-equal? "- test3" -4 (- 1 2 3))
+(assert-equal? "* test1" 1 (*))
+(assert-equal? "* test2" 2 (* 2))
+(assert-equal? "* test3" 24 (* 2 3 4))
+(assert-equal? "/ test1" 0 (/ 1 2))
+(assert-equal? "/ test2" -1 (/ -2 2))
-(assert-eq? "abs test1" 7 (abs -7))
-(assert-eq? "abs test2" 7 (abs 7))
+(assert-equal? "abs test1" 7 (abs -7))
+(assert-equal? "abs test2" 7 (abs 7))
-(assert-eq? "quotient test1" 0 (/ 1 2))
-(assert-eq? "quotient test2" -1 (/ -2 2))
+(assert-equal? "quotient test1" 0 (/ 1 2))
+(assert-equal? "quotient test2" -1 (/ -2 2))
-(assert-eq? "modulo test1" 1 (modulo 13 4))
-(assert-eq? "modulo test2" 3 (modulo -13 4))
-(assert-eq? "modulo test3" -3 (modulo 13 -4))
-(assert-eq? "modulo test4" -1 (modulo -13 -4))
+(assert-equal? "modulo test1" 1 (modulo 13 4))
+(assert-equal? "modulo test2" 3 (modulo -13 4))
+(assert-equal? "modulo test3" -3 (modulo 13 -4))
+(assert-equal? "modulo test4" -1 (modulo -13 -4))
-(assert-eq? "remainder test1" 1 (remainder 13 4))
-(assert-eq? "remainder test2" -1 (remainder -13 4))
-(assert-eq? "remainder test3" 1 (remainder 13 -4))
-(assert-eq? "remainder test4" -1 (remainder -13 -4))
+(assert-equal? "remainder test1" 1 (remainder 13 4))
+(assert-equal? "remainder test2" -1 (remainder -13 4))
+(assert-equal? "remainder test3" 1 (remainder 13 -4))
+(assert-equal? "remainder test4" -1 (remainder -13 -4))
(assert-equal? "number->string test1" "1" (number->string 1))
(assert-equal? "number->string test2" "10" (number->string 10))
(assert-equal? "number->string test3" "100" (number->string 100))
-(assert-eq? "string->number test1" 1 (string->number "1"))
-(assert-eq? "string->number test2" 10 (string->number "10"))
-(assert-eq? "string->number test2" 100 (string->number "100"))
+(assert-equal? "string->number test1" 1 (string->number "1"))
+(assert-equal? "string->number test2" 10 (string->number "10"))
+(assert-equal? "string->number test2" 100 (string->number "100"))
(total-report)
Modified: branches/r5rs/sigscheme/test/test-string.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-string.scm 2005-08-21 11:15:38 UTC (rev 1266)
+++ branches/r5rs/sigscheme/test/test-string.scm 2005-08-21 11:48:30 UTC (rev 1267)
@@ -9,11 +9,11 @@
(assert "hiragana make-string check" (string=? "¤¢¤¢¤¢" (make-string 3 #\¤¢)))
;; check string-ref
-(assert-eq? "alphabet string-ref check" #\o (string-ref "aiueo" 4))
-(assert-eq? "hiragena string-ref check" #\¤ª (string-ref "¤¢¤¤¤¦¤¨¤ª" 4))
-(assert-eq? "mixed string-ref check" #\¤ª (string-ref "¤¢iue¤ª" 4))
-(assert-eq? "alphabet string-ref 0 check" #\a (string-ref "aiueo" 0))
-(assert-eq? "hiragena string-ref 0 check" #\¤¢ (string-ref "¤¢¤¤¤¦¤¨¤ª" 0))
+(assert-equal? "alphabet string-ref check" #\o (string-ref "aiueo" 4))
+(assert-equal? "hiragena string-ref check" #\¤ª (string-ref "¤¢¤¤¤¦¤¨¤ª" 4))
+(assert-equal? "mixed string-ref check" #\¤ª (string-ref "¤¢iue¤ª" 4))
+(assert-equal? "alphabet string-ref 0 check" #\a (string-ref "aiueo" 0))
+(assert-equal? "hiragena string-ref 0 check" #\¤¢ (string-ref "¤¢¤¤¤¦¤¨¤ª" 0))
;; check string-set!
(assert "alphabet string-set! check" (string=? "aikeo"
@@ -33,13 +33,13 @@
str)))
;; check string-length
-(assert-eq? "alphabet string-length check" 5 (string-length "aiueo"))
-(assert-eq? "hiragana string-length check" 5 (string-length "¤¢¤¤¤¦¤¨¤ª"))
+(assert-equal? "alphabet string-length check" 5 (string-length "aiueo"))
+(assert-equal? "hiragana string-length check" 5 (string-length "¤¢¤¤¤¦¤¨¤ª"))
;; string=? check
-(assert-eq? "alphabet string=? check" #t (string=? "aiueo" "aiueo"))
-(assert-eq? "hiragana string=? check" #t (string=? "¤¢¤¤¤¦¤¨¤ª" "¤¢¤¤¤¦¤¨¤ª"))
-(assert-eq? "mixed string=? check" #t (string=? "a¤¤¤¦¤¨o" "a¤¤¤¦¤¨o"))
+(assert-equal? "alphabet string=? check" #t (string=? "aiueo" "aiueo"))
+(assert-equal? "hiragana string=? check" #t (string=? "¤¢¤¤¤¦¤¨¤ª" "¤¢¤¤¤¦¤¨¤ª"))
+(assert-equal? "mixed string=? check" #t (string=? "a¤¤¤¦¤¨o" "a¤¤¤¦¤¨o"))
;; substring check
Modified: branches/r5rs/sigscheme/test/unittest-bigloo.scm
===================================================================
--- branches/r5rs/sigscheme/test/unittest-bigloo.scm 2005-08-21 11:15:38 UTC (rev 1266)
+++ branches/r5rs/sigscheme/test/unittest-bigloo.scm 2005-08-21 11:48:30 UTC (rev 1267)
@@ -3,7 +3,8 @@
;*---------------------------------------------------------------------*/
;* For Bigloo Test */
;*---------------------------------------------------------------------*/
-(define test assert-equal?)
+(define (test name val expected-val)
+ (assert-equal? name expected-val val))
(define (foo1 x)
x)
(define (foo2 . x)
More information about the uim-commit
mailing list