Jun Inoue
jun.l****@gmail*****
2005年 8月 21日 (日) 19:30:41 JST
operations.c と datas.c で、TODO 潰しと、バグ潰し、ついでに「ここはこう した方がストレートなんじゃないか」という箇所の変更、をしています。 これで 2/3 ぐらい。おもな変更箇所は、 * datas.c - (add_heap, allocate_heap) memset の除去と条件判定のループからの追い 出し →観測できるほど速くなりませんでしたが… * operations.c - 四則演算の脱 FUNCTYPE_2N 化。意外かも知れませんがこれは現時点では速 度は *低下* しています。これは FUNCTYPE_L しかないためで、一つずつ eval してそのまま使えばいいのに、map_eval() がいちいち引数の数だけ cons して くれてるためだと思われます。これらの関数や append などは、多分 FUNCTYPE_RAW_LIST なり FUNCTYPE_RAW_ARGS なりを導入すれば速度は向上する はず。コードサイズは肥大化しますが。いずれにしても早いとこ FUNCTYPE 整理 してくれませんかねぇ… (と、プレッシャーをかけてみる - (ScmOp_equal) 演算子の引数チェックの順番が逆。 - 比較演算子の関数の名前が逆。普通 > が「大なり」でしょう…あと多分数値 の大小をいうときは "greater than", "less than" の方が一般的だと思いま す。*思います*。R5RS にあるとおりに [non]increasing, [non]decreasing で もいいかも知れませんが。 - max, min の中間生成物を排除。 - (ScmOp_number_to_string) radix を実装。っていうか前に uim-db のため に siod 用に書いたやつを引っ張ってきただけ。string->number も、strtol() で簡単に実装できそうなんですが、string オブジェクトのもってる文字列デー タは NUL-terminated と仮定して良いんでしょうか。copy-on-write shared string ができなくなりますが。 - (ScmOp_string_to_number) atof → atoi (多分こっちの方が速い) - (ScmOp_c_length) 多分最初の if 文は無駄。 - (ScmOp_append) append はもらったリストを破壊してはいけません。(テスト追加) - (ScmOp_reverse) listp 排除。 - (ScmOp_listtail_internal) なんて schemer なコードなんだ! と思ってし まいました。(笑) ループに変換。 - (ScmOp_memq) 冗長なテストを簡略化 - (ScmOp_assq, ScmOp_assv, ScmOp_assoc) STRICT_R5RS 時に非 alist の チェック - (ScmOp_symbol_to_string, ScmOp_string_to_symbol) エラー処理、コピー 処理の簡略化 * test/bigloo-list.scm ヤマケンさんの eq? hack で通らなくなったテストがあったので一時的に変更 * test/io.scm 前よりちょっと親切に。(笑) * test/test-list.scm append のテスト追加。 * test/unittest-bigloo 引数を xcons ちなみにヤマケンさんの比較関数周りの commit とかと一部競合するかもしれません。 -- Jun Inoue jun.l****@gmail***** -------------- next part -------------- diff -ur sigscheme/datas.c ../.r5rs/sigscheme/datas.c --- sigscheme/datas.c 2005-08-21 00:31:42.000000000 -0700 +++ ../.r5rs/sigscheme/datas.c 2005-08-21 02:32:55.000000000 -0700 @@ -200,9 +200,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); @@ -215,27 +213,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]; } @@ -243,10 +231,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); @@ -260,24 +246,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]; } diff -ur sigscheme/operations.c ../.r5rs/sigscheme/operations.c --- sigscheme/operations.c 2005-08-21 02:15:09.000000000 -0700 +++ ../.r5rs/sigscheme/operations.c 2005-08-21 02:20:25.000000000 -0700 @@ -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 @@ -266,64 +266,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); +} + +ScmObj ScmOp_times(ScmObj args, ScmObj env) +{ + int result = 1; + ScmObj operand; + ScmObj ls; - if (!SCM_INTP(obj2)) - SigScm_ErrorObj("+ : integer required but got ", 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(SCM_INT_VALUE(obj1) + SCM_INT_VALUE(obj2)); + 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; + + ls = args; + if (SCM_NULLP(ls)) + SigScm_Error("- : at least 1 argument required"); - if (SCM_NULLP(obj2)) - return Scm_NewInt(-(SCM_INT_VALUE(obj1))); + result = SCM_INT_VALUE(SCM_CAR(ls)); + ls = SCM_CDR(ls); - if (!SCM_INTP(obj2)) - SigScm_ErrorObj("- : integer required but got ", obj2); + /* single arg */ + if (SCM_NULLP(ls)) + return Scm_NewInt(-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); + 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) @@ -339,14 +369,14 @@ int val = 0; ScmObj obj = SCM_NIL; - /* 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"); + /* type check */ + if (EQ(ScmOp_numberp(SCM_CAR(args)), SCM_FALSE)) + SigScm_ErrorObj("= : number required but got ", SCM_CAR(args)); + /* Get first value */ val = SCM_INT_VALUE(SCM_CAR(args)); @@ -365,7 +395,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; @@ -397,7 +427,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; @@ -430,7 +460,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; @@ -464,7 +494,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; @@ -552,6 +582,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"); @@ -561,9 +592,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); @@ -574,6 +607,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"); @@ -583,12 +617,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; } @@ -671,36 +707,59 @@ /*============================================================================== 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; - - if (EQ(ScmOp_numberp(z), SCM_FALSE)) - SigScm_ErrorObj("number->string : number required but got ", z); - - /* get value */ - n = SCM_INT_VALUE(z); - - /* get size */ - for (size = 1; (int)(n / 10) != 0; size++) - n /= 10; - - /* allocate str */ - str = (char *)malloc(sizeof(char) * size + 1); - - /* fill str */ - n = SCM_INT_VALUE(z); - str[size] = '\0'; - for (i = size; 0 < i; i--) { - str[i - 1] = '0' + (n % 10); - n /= 10; - } - - return Scm_NewString(str); + char buf[sizeof(int)*CHAR_BIT + 1]; + char *p; + unsigned int n, r; + ScmObj number, radix; + + if (CHECK_1_ARG(args)) + SigScm_ErrorObj("number->string: requires 1 or 2 arguments: ", args); + + number = SCM_CAR(args); + if (!SCM_INTP(number)) + SigScm_ErrorObj("number->string: integer required but got ", number); + + n = SCM_INT_VALUE(number); + + /* 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); + + 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_NewStringCopying (p); } /* TODO : support radix */ @@ -720,7 +779,7 @@ return SCM_FALSE; } - return Scm_NewInt((int)atof(SCM_STRING_STR(string))); + return Scm_NewInt((int)atoi(SCM_STRING_STR(string))); } /*=================================== @@ -967,34 +1026,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****@acm*****) */ -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; @@ -1019,91 +1060,86 @@ 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; - - if (!SCM_CONSP(head)) - SigScm_ErrorObj("append : list required but got ", head); - - 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); - } + ScmObj ls; + ScmObj obj = SCM_NIL; - return head; -} + if (SCM_NULLP(args)) + return SCM_NIL; -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); + /* 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 ret; + /* append the last argument */ + *ret_tail = SCM_CAR(args); + + 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); + + ret = ScmOp_listtail_internal(list, SCM_INT_VALUE(scm_k)); - return 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); } @@ -1111,10 +1147,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; } } @@ -1154,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_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; @@ -1167,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_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; @@ -1180,10 +1234,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; @@ -1204,22 +1268,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; - - name = (char*)alloca(strlen(SCM_STRING_STR(str)) + 1); - strcpy(name, SCM_STRING_STR(str)); + SigScm_ErrorObj("string->symbol: string required, but got ", str); - return Scm_Intern(name); + return Scm_Intern(SCM_STRING_STR(str)); } /*============================================================================== diff -ur sigscheme/sigscheme.c ../.r5rs/sigscheme/sigscheme.c --- sigscheme/sigscheme.c 2005-08-19 11:04:31.000000000 -0700 +++ ../.r5rs/sigscheme/sigscheme.c 2005-08-20 23:12:39.000000000 -0700 @@ -149,10 +149,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); @@ -160,15 +160,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); diff -ur sigscheme/sigscheme.h ../.r5rs/sigscheme/sigscheme.h --- sigscheme/sigscheme.h 2005-08-21 02:15:48.000000000 -0700 +++ ../.r5rs/sigscheme/sigscheme.h 2005-08-20 23:14:58.000000000 -0700 @@ -194,10 +194,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); @@ -205,15 +205,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); diff -ur sigscheme/test/bigloo-list.scm ../.r5rs/sigscheme/test/bigloo-list.scm --- sigscheme/test/bigloo-list.scm 2005-08-17 10:42:57.000000000 -0700 +++ ../.r5rs/sigscheme/test/bigloo-list.scm 2005-08-20 23:14:10.000000000 -0700 @@ -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))) diff -ur sigscheme/test/io.scm ../.r5rs/sigscheme/test/io.scm --- sigscheme/test/io.scm 2005-07-17 14:10:29.000000000 -0700 +++ ../.r5rs/sigscheme/test/io.scm 2005-08-20 23:14:10.000000000 -0700 @@ -1 +1,2 @@ +(display "type an sexp:") (print (read-char)) diff -ur sigscheme/test/test-list.scm ../.r5rs/sigscheme/test/test-list.scm --- sigscheme/test/test-list.scm 2005-07-18 15:00:07.000000000 -0700 +++ ../.r5rs/sigscheme/test/test-list.scm 2005-08-20 23:49:24.000000000 -0700 @@ -47,6 +47,13 @@ (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-eq? "append test6" x (cdr (append '((Calpis hosi-)) x))) ; share last ; reverse (assert-equal? "reverse test1" '(c b a) (reverse '(a b c))) diff -ur sigscheme/test/unittest-bigloo.scm ../.r5rs/sigscheme/test/unittest-bigloo.scm --- sigscheme/test/unittest-bigloo.scm 2005-08-17 10:42:57.000000000 -0700 +++ ../.r5rs/sigscheme/test/unittest-bigloo.scm 2005-08-20 23:14:10.000000000 -0700 @@ -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)
