[uim-commit] r977 - in branches/r5rs/sigscheme: . test

kzk at freedesktop.org kzk at freedesktop.org
Tue Jul 19 08:00:10 EST 2005


Author: kzk
Date: 2005-07-18 15:00:07 -0700 (Mon, 18 Jul 2005)
New Revision: 977

Added:
   branches/r5rs/sigscheme/test/test-list.scm
Modified:
   branches/r5rs/sigscheme/operations.c
   branches/r5rs/sigscheme/sigscheme.c
   branches/r5rs/sigscheme/sigscheme.h
   branches/r5rs/sigscheme/test/unittest.scm
Log:
* Add test-list.scm for testing list processing procedures.

* sigscheme/test/test-list.scm
  - new file
* sigscheme/test/unittest.scm
  - valid error message

* sigscheme/sigscheme.h
* sigscheme/operations.c
  - (ScmOp_member, ScmOp_assoc): new function

* sigscheme/sigscheme.c
  - fixed typo (pairp? -> pair?)
  - add "member" and "assoc"



Modified: branches/r5rs/sigscheme/operations.c
===================================================================
--- branches/r5rs/sigscheme/operations.c	2005-07-18 21:17:38 UTC (rev 976)
+++ branches/r5rs/sigscheme/operations.c	2005-07-18 22:00:07 UTC (rev 977)
@@ -945,7 +945,7 @@
 {
     if (EQ(ScmOp_listp(list), SCM_FALSE))
         SigScm_ErrorObj("list-tail : list required but got ", list);
-    if (SCM_INTP(scm_k))
+    if (EQ(ScmOp_numberp(scm_k), SCM_FALSE))
         SigScm_ErrorObj("list-tail : number required but got ", scm_k);
 
     return ScmOp_listtail_internal(list, SCM_INT_VALUE(scm_k));
@@ -957,7 +957,7 @@
 
     if (EQ(ScmOp_listp(list), SCM_FALSE))
         SigScm_ErrorObj("list-ref : list required but got ", list);
-    if (SCM_INTP(scm_k))
+    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));
@@ -996,6 +996,20 @@
     return SCM_FALSE;
 }
 
+ScmObj ScmOp_member(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_equalp(obj, tmpobj), SCM_TRUE)) {
+            return tmplist;
+        }
+    }
+
+    return SCM_FALSE;
+}
+
 ScmObj ScmOp_assq(ScmObj obj, ScmObj alist)
 {
     ScmObj tmplist = SCM_NIL;
@@ -1022,6 +1036,20 @@
     return SCM_FALSE;
 }
 
+ScmObj ScmOp_assoc(ScmObj obj, ScmObj alist)
+{
+    ScmObj tmplist = SCM_NIL;
+    ScmObj tmpobj  = SCM_NIL;
+    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))
+            return tmpobj;
+    }
+
+    return SCM_FALSE;
+}
+
+
 /*==============================================================================
   R5RS : 6.3 Other data types : 6.3.3 Symbols
 ==============================================================================*/

Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c	2005-07-18 21:17:38 UTC (rev 976)
+++ branches/r5rs/sigscheme/sigscheme.c	2005-07-18 22:00:07 UTC (rev 977)
@@ -147,7 +147,7 @@
     Scm_InitSubr2("remainder"            , ScmOp_remainder);
     Scm_InitSubr1("not"                  , ScmOp_not);
     Scm_InitSubr1("boolean?"             , ScmOp_booleanp);
-    Scm_InitSubr1("pairp?"               , ScmOp_pairp);
+    Scm_InitSubr1("pair?"                , ScmOp_pairp);
     Scm_InitSubr2("cons"                 , ScmOp_cons);
     Scm_InitSubr1("car"                  , ScmOp_car);
     Scm_InitSubr1("cdr"                  , ScmOp_cdr);
@@ -191,8 +191,10 @@
     Scm_InitSubr2("list-ref"             , ScmOp_listref);
     Scm_InitSubr2("memq"                 , ScmOp_memq);
     Scm_InitSubr2("memv"                 , ScmOp_memv);
+    Scm_InitSubr2("member"               , ScmOp_member);
     Scm_InitSubr2("assq"                 , ScmOp_assq);
     Scm_InitSubr2("assv"                 , ScmOp_assv);
+    Scm_InitSubr2("assoc"                , ScmOp_assoc);
     Scm_InitSubr1("symbol?"              , ScmOp_symbolp);
     Scm_InitSubr1("symbol->string"       , ScmOp_symbol_to_string);
     Scm_InitSubr1("string->symbol"       , ScmOp_string_to_symbol);

Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h	2005-07-18 21:17:38 UTC (rev 976)
+++ branches/r5rs/sigscheme/sigscheme.h	2005-07-18 22:00:07 UTC (rev 977)
@@ -213,8 +213,10 @@
 ScmObj ScmOp_listref(ScmObj list, ScmObj k);
 ScmObj ScmOp_memq(ScmObj obj, ScmObj list);
 ScmObj ScmOp_memv(ScmObj obj, ScmObj list);
+ScmObj ScmOp_member(ScmObj obj, ScmObj list);
 ScmObj ScmOp_assq(ScmObj obj, ScmObj alist);
 ScmObj ScmOp_assv(ScmObj obj, ScmObj alist);
+ScmObj ScmOp_assoc(ScmObj obj, ScmObj alist);
 ScmObj ScmOp_symbolp(ScmObj obj);
 ScmObj ScmOp_boundp(ScmObj obj);
 ScmObj ScmOp_symbol_to_string(ScmObj obj);

Added: branches/r5rs/sigscheme/test/test-list.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-list.scm	2005-07-18 21:17:38 UTC (rev 976)
+++ branches/r5rs/sigscheme/test/test-list.scm	2005-07-18 22:00:07 UTC (rev 977)
@@ -0,0 +1,83 @@
+(load "test/unittest.scm")
+
+; 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)))
+
+; cons
+(assert-equal? "cons test1" '(a) (cons 'a '()))
+(assert-equal? "cons test2" '((a) b c d) (cons '(a) '(b c d)))
+(assert-equal? "cons test3" '(a . 3) (cons 'a 3))
+(assert-equal? "cons test4" '((a b) . c) (cons '(a b) 'c))
+
+; car
+(assert-eq? "car test1" 'a (car '(a b c)))
+(assert-equal? "car test2" '(a) (car '((a) b c)))
+(assert-eq? "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)))
+
+; null?
+(assert "null? test1" (null? '()))
+(assert-eq? "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)))
+; TODO : check finite length of the list!
+;(assert-eq? "list? test4" #f (let ((x (list 'a)))
+;			       (set-cdr! x x)
+;			       (list? x)))
+
+; list
+(assert-equal? "list test1" '(a 7 c) (list 'a (+ 3 4) 'c))
+(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 '()))
+
+; 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))))
+
+; reverse
+(assert-equal? "reverse test1" '(c b a) (reverse '(a b c)))
+(assert-equal? "reverse test2" '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))
+
+; list-tail
+(assert-equal? "list-tail test1" '(a b c) (list-tail '(a b c) 0))
+(assert-equal? "list-tail test2" '(b c) (list-tail '(a b c) 1))
+(assert-equal? "list-tail test3" '(c) (list-tail '(a b c) 2))
+(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))
+
+; memq
+(assert-equal? "memq test1" '(a b c) (memq 'a '(a b c)))
+(assert-equal? "memq test2" '(b c) (memq 'b '(a b c)))
+(assert-equal? "memq test3" #f (memq 'a '(b c d)))
+(assert-equal? "memq test4" #f (memq (list 'a) '(b (a) c)))
+
+; member
+(assert-equal? "member test1" '((a) c) (member (list 'a) '(b (a) c)))
+
+; assq
+(define e '((a 1) (b 2) (c 3)))
+(assert-equal? "assq test1" '(a 1) (assq 'a e))
+(assert-equal? "assq test2" '(b 2) (assq 'b e))
+(assert-equal? "assq test3" #f (assq 'd e))
+(assert-equal? "assq test4" #f (assq (list 'a) '(((a)) ((b)) ((c)))))
+
+; assoc
+(assert-equal? "assoc test1" '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))
+
+(total-report)

Modified: branches/r5rs/sigscheme/test/unittest.scm
===================================================================
--- branches/r5rs/sigscheme/test/unittest.scm	2005-07-18 21:17:38 UTC (rev 976)
+++ branches/r5rs/sigscheme/test/unittest.scm	2005-07-18 22:00:07 UTC (rev 977)
@@ -10,15 +10,16 @@
       (if (= total-err-num 0)
 	  (print "OK\n")
 	  (begin
-	    (print "[ ERROR !! ]\n")
+	    (print "[ ERROR NUM ]\n")
 	    (print total-err-num)
 	    (print "\n"))))))
 
 (define report-error
   (lambda (errmsg)
     (begin
-      (print "error")
-      (print errmsg))))
+      (print "error : ")
+      (print errmsg)
+      (print "\n"))))
 
 (define assert
   (lambda (msg exp)
@@ -34,3 +35,7 @@
 (define assert-eq?
   (lambda (msg a b)
     (assert msg (eq? a b))))
+
+(define assert-equal?
+  (lambda (msg a b)
+    (assert msg (equal? a b))))



More information about the uim-commit mailing list