[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