[uim-commit] r1530 - in branches/r5rs/sigscheme: . test
kzk at freedesktop.org
kzk at freedesktop.org
Tue Sep 20 19:25:09 PDT 2005
Author: kzk
Date: 2005-09-20 19:25:05 -0700 (Tue, 20 Sep 2005)
New Revision: 1530
Modified:
branches/r5rs/sigscheme/operations-srfi1.c
branches/r5rs/sigscheme/sigscheme.c
branches/r5rs/sigscheme/sigscheme.h
branches/r5rs/sigscheme/test/test-srfi1.scm
Log:
* implement SRFI-1 "Predicates" and "Selectors"
* sigscheme/sigscheme.c
- export "proper-list?", "circular-list?", "dotted-list?",
"not-pair", "null-list?", "list=", "first", "second", "third",
"fourth", "fifth", "sixth", "seventh", "eighth", "ninth", "tenth",
"take", "drop", "take-right", "drop-right", "take!", "drop-right!",
"split-at", "split-at!", "last", "last-pair"
* sigscheme/sigscheme.h
* sigscheme/operations-srfi1.c
- (ScmOp_SRFI1_proper_listp, ScmOp_SRFI1_circular_listp,
ScmOp_SRFI1_dotted_listp, ScmOp_SRFI1_not_pairp,
ScmOp_SRFI1_null_listp, ScmOp_SRFI1_listequal,
ScmOp_SRFI1_first, ScmOp_SRFI1_second, ScmOp_SRFI1_third,
ScmOp_SRFI1_fourth, ScmOp_SRFI1_fifth, ScmOp_SRFI1_sixth,
ScmOp_SRFI1_seventh, ScmOp_SRFI1_eighth, ScmOp_SRFI1_ninth,
ScmOp_SRFI1_tenth, ScmOp_SRFI1_carpluscdr, ScmOp_SRFI1_take,
ScmOp_SRFI1_drop, ScmOp_SRFI1_take_right, ScmOp_SRFI1_drop_right,
ScmOp_SRFI1_take_d, ScmOp_SRFI1_drop_right_d,
ScmOp_SRFI1_split_at, ScmOp_SRFI1_split_at_d,
ScmOp_SRFI1_last, ScmOp_SRFI1_last_pair): new func
* sigscheme/test/test-srfi1.scm
- add test cases for
"proper-list?", "circular-list?", "dotted-list?",
"not-pair", "null-list?", "list=", "first", "second", "third",
"fourth", "fifth", "sixth", "seventh", "eighth", "ninth", "tenth",
"take", "drop", "take-right", "drop-right", "take!", "drop-right!",
"split-at", "split-at!", "last", "last-pair"
Modified: branches/r5rs/sigscheme/operations-srfi1.c
===================================================================
--- branches/r5rs/sigscheme/operations-srfi1.c 2005-09-20 17:08:13 UTC (rev 1529)
+++ branches/r5rs/sigscheme/operations-srfi1.c 2005-09-21 02:25:05 UTC (rev 1530)
@@ -55,22 +55,8 @@
/*=======================================
File Local Function Declarations
=======================================*/
-static ScmObj list_gettailcons(ScmObj head)
-{
- if (NULLP(head))
- return SCM_NULL;
- if (NULLP(CDR(head)))
- return head;
+static ScmObj compare_list(ScmObj eqproc, ScmObj lst1, ScmObj lst2, ScmObj env);
- for (; !NULLP(head); head = CDR(head)) {
- if (NULLP(CDR(head)))
- return head;
- }
-
- SigScm_Error("list_gettailcons : cannot get tailcons?\n");
- return SCM_NULL;
-}
-
/*=======================================
Function Implementations
=======================================*/
@@ -121,13 +107,12 @@
/* get filler if available */
if (!NULLP(CDR(args)))
fill = CADR(args);
+ else
+ fill = SCM_FALSE;
/* then create list */
for (i = n; 0 < i; i--) {
- if (!NULLP(fill))
- head = CONS(fill, head);
- else
- head = CONS(Scm_NewInt(i), head);
+ head = CONS(fill, head);
}
return head;
@@ -170,17 +155,17 @@
return head;
}
-ScmObj ScmOp_SRFI1_list_copy(ScmObj list)
+ScmObj ScmOp_SRFI1_list_copy(ScmObj lst)
{
ScmObj head = SCM_NULL;
ScmObj tail = SCM_NULL;
ScmObj obj = SCM_NULL;
- if (FALSEP(ScmOp_listp(list)))
- SigScm_ErrorObj("list-copy : list required but got ", list);
+ if (FALSEP(ScmOp_listp(lst)))
+ SigScm_ErrorObj("list-copy : list required but got ", lst);
- for (; !NULLP(list); list = CDR(list)) {
- obj = CAR(list);
+ for (; !NULLP(lst); lst = CDR(lst)) {
+ obj = CAR(lst);
/* further copy */
if (CONSP(obj))
@@ -200,17 +185,17 @@
return head;
}
-ScmObj ScmOp_SRFI1_circular_list(ScmObj list, ScmObj env)
+ScmObj ScmOp_SRFI1_circular_list(ScmObj lst, ScmObj env)
{
ScmObj tailcons = SCM_NULL;
- if (FALSEP(ScmOp_listp(list)))
- SigScm_ErrorObj("circular-list : list required but got ", list);
+ if (FALSEP(ScmOp_listp(lst)))
+ SigScm_ErrorObj("circular-list : list required but got ", lst);
- tailcons = list_gettailcons(list);
- SET_CDR(tailcons, list);
+ tailcons = ScmOp_SRFI1_last_pair(lst);
+ SET_CDR(tailcons, lst);
- return list;
+ return lst;
}
ScmObj ScmOp_SRFI1_iota(ScmObj args, ScmObj env)
@@ -257,3 +242,349 @@
return head;
}
+
+/*==============================================================================
+ SRFI1 : The procedures : Predicates
+==============================================================================*/
+ScmObj ScmOp_SRFI1_proper_listp(ScmObj lst)
+{
+ return ScmOp_listp(lst);
+}
+
+ScmObj ScmOp_SRFI1_circular_listp(ScmObj obj)
+{
+ ScmObj slow = obj;
+ int len = 0;
+
+ for (;;) {
+ if (NULLP(obj)) break;
+ if (!CONSP(obj)) return SCM_FALSE;
+ if (len != 0 && obj == slow) return SCM_TRUE; /* circular */
+
+ obj = CDR(obj);
+ len++;
+ if (NULLP(obj)) break;
+ if (!CONSP(obj)) return SCM_FALSE;
+ if (obj == slow) return SCM_TRUE; /* circular */
+
+ obj = CDR(obj);
+ slow = CDR(slow);
+ len++;
+ }
+
+ return SCM_FALSE;
+}
+
+ScmObj ScmOp_SRFI1_dotted_listp(ScmObj obj)
+{
+ ScmObj slow = obj;
+ int len = 0;
+
+ for (;;) {
+ if (NULLP(obj)) break;
+ if (!CONSP(obj)) return SCM_TRUE;
+ if (len != 0 && obj == slow) return SCM_FALSE; /* circular */
+
+ obj = CDR(obj);
+ len++;
+ if (NULLP(obj)) break;
+ if (!CONSP(obj)) return SCM_TRUE;
+ if (obj == slow) return SCM_FALSE; /* circular */
+
+ obj = CDR(obj);
+ slow = CDR(slow);
+ len++;
+ }
+
+ return SCM_FALSE;
+}
+
+ScmObj ScmOp_SRFI1_not_pairp(ScmObj pair)
+{
+ return CONSP(pair) ? SCM_FALSE : SCM_TRUE;
+}
+
+ScmObj ScmOp_SRFI1_null_listp(ScmObj lst)
+{
+ /* TODO : check circular list */
+ return NULLP(lst) ? SCM_TRUE : SCM_FALSE;
+}
+
+ScmObj ScmOp_SRFI1_listequal(ScmObj args, ScmObj env)
+{
+ ScmObj eqproc = SCM_NULL;
+ ScmObj lsts = SCM_NULL;
+ ScmObj first_lst = SCM_NULL;
+
+ if CHECK_1_ARG(args)
+ SigScm_Error("list= : required at least 1 arg\n");
+
+ eqproc = CAR(args);
+ lsts = CDR(args);
+
+ if (NULLP(lsts))
+ return SCM_TRUE;
+
+ first_lst = CAR(lsts);
+ lsts = CDR(lsts);
+
+ if (NULLP(lsts))
+ return SCM_TRUE;
+
+ for (; !NULLP(lsts); lsts = CDR(lsts)) {
+ if (FALSEP(compare_list(eqproc, first_lst, CAR(lsts), env)))
+ return SCM_FALSE;
+ }
+
+ return SCM_TRUE;
+}
+
+static ScmObj compare_list(ScmObj eqproc, ScmObj lst1, ScmObj lst2, ScmObj env)
+{
+#define CHECK_LIST_EQUALITY_WITH_EQPROC(eqproc, obj1, obj2, env) \
+ (ScmOp_apply(SCM_LIST_2(eqproc, \
+ SCM_LIST_2(obj1, \
+ obj2)), \
+ env));
+
+ ScmObj ret_cmp = SCM_FALSE;
+
+ for (; !NULLP(lst1); lst1 = CDR(lst1), lst2 = CDR(lst2)) {
+ /* check contents */
+ ret_cmp = CHECK_LIST_EQUALITY_WITH_EQPROC(eqproc, CAR(lst1), CAR(lst2), env);
+ if (FALSEP(ret_cmp))
+ return SCM_FALSE;
+
+ /* check next cdr's type */
+ if (SCM_TYPE(CDR(lst1)) != SCM_TYPE(CDR(lst2)))
+ return SCM_FALSE;
+
+ /* check dot pair */
+ if (!CONSP(CDR(lst1))) {
+ return CHECK_LIST_EQUALITY_WITH_EQPROC(eqproc, CDR(lst1), CDR(lst2), env);
+ }
+ }
+ return SCM_TRUE;
+}
+
+ScmObj ScmOp_SRFI1_first(ScmObj lst)
+{
+ return ScmOp_car(lst);
+}
+
+ScmObj ScmOp_SRFI1_second(ScmObj lst)
+{
+ return ScmOp_cadr(lst);
+}
+
+ScmObj ScmOp_SRFI1_third(ScmObj lst)
+{
+ return ScmOp_caddr(lst);
+}
+
+ScmObj ScmOp_SRFI1_fourth(ScmObj lst)
+{
+ return ScmOp_cadddr(lst);
+}
+
+ScmObj ScmOp_SRFI1_fifth(ScmObj lst)
+{
+ return ScmOp_car(ScmOp_cddddr(lst));
+}
+
+ScmObj ScmOp_SRFI1_sixth(ScmObj lst)
+{
+ return ScmOp_cadr(ScmOp_cddddr(lst));
+}
+
+ScmObj ScmOp_SRFI1_seventh(ScmObj lst)
+{
+ return ScmOp_caddr(ScmOp_cddddr(lst));
+}
+
+ScmObj ScmOp_SRFI1_eighth(ScmObj lst)
+{
+ return ScmOp_cadddr(ScmOp_cddddr(lst));
+}
+
+ScmObj ScmOp_SRFI1_ninth(ScmObj lst)
+{
+ return ScmOp_car(ScmOp_cddddr(ScmOp_cddddr(lst)));
+}
+
+ScmObj ScmOp_SRFI1_tenth(ScmObj lst)
+{
+ return ScmOp_cadr(ScmOp_cddddr(ScmOp_cddddr(lst)));
+}
+
+ScmObj ScmOp_SRFI1_carpluscdr(ScmObj lst)
+{
+ return Scm_NewValuePacket(LIST_2(CAR(lst), CDR(lst)));
+}
+
+ScmObj ScmOp_SRFI1_take(ScmObj lst, ScmObj scm_idx)
+{
+ ScmObj tmp = lst;
+ ScmObj ret = SCM_NULL;
+ ScmObj ret_tail = SCM_NULL;
+ int idx = 0;
+ int i;
+
+ /* sanity check */
+ if (!INTP(scm_idx))
+ SigScm_ErrorObj("drop-right : number required but got ", scm_idx);
+
+ idx = SCM_INT_VALUE(scm_idx);
+
+ for (i = 0; i < idx; i++) {
+ if (SCM_NULLP(tmp))
+ SigScm_ErrorObj("take : illegal index is specified for ", lst);
+
+ if (i != 0) {
+ SET_CDR(ret_tail, CONS(CAR(tmp), SCM_NULL));
+ ret_tail = CDR(ret_tail);
+ } else {
+ ret = CONS(CAR(tmp), SCM_NULL);
+ ret_tail = ret;
+ }
+
+ tmp = CDR(tmp);
+ }
+
+ return ret;
+}
+
+ScmObj ScmOp_SRFI1_drop(ScmObj lst, ScmObj scm_idx)
+{
+ ScmObj ret = lst;
+ int idx = SCM_INT_VALUE(scm_idx);
+ int i;
+
+ /* sanity check */
+ if (!INTP(scm_idx))
+ SigScm_ErrorObj("drop-right : number required but got ", scm_idx);
+
+ for (i = 0; i < idx; i++) {
+ if (!CONSP(ret))
+ SigScm_ErrorObj("drop : illegal index is specified for ", lst);
+
+ ret = CDR(ret);
+ }
+
+ return ret;
+}
+
+ScmObj ScmOp_SRFI1_take_right(ScmObj lst, ScmObj scm_elem)
+{
+ ScmObj tmp = lst;
+ int len = 0;
+
+ /* sanity check */
+ if (!INTP(scm_elem))
+ SigScm_ErrorObj("drop-right : number required but got ", scm_elem);
+
+ for (; CONSP(tmp); tmp = CDR(tmp))
+ len++;
+
+ len -= SCM_INT_VALUE(scm_elem);
+
+ return ScmOp_SRFI1_drop(lst, Scm_NewInt(len));
+}
+
+ScmObj ScmOp_SRFI1_drop_right(ScmObj lst, ScmObj scm_elem)
+{
+ ScmObj tmp = lst;
+ int len = 0;
+
+ /* sanity check */
+ if (!INTP(scm_elem))
+ SigScm_ErrorObj("drop-right : number required but got ", scm_elem);
+
+ for (; CONSP(tmp); tmp = CDR(tmp))
+ len++;
+
+ len -= SCM_INT_VALUE(scm_elem);
+
+ return ScmOp_SRFI1_take(lst, Scm_NewInt(len));
+}
+
+ScmObj ScmOp_SRFI1_take_d(ScmObj lst, ScmObj scm_idx)
+{
+ ScmObj tmp = lst;
+ int idx = 0;
+ int i;
+
+ /* sanity check */
+ if (!INTP(scm_idx))
+ SigScm_ErrorObj("take! : number required but got ", scm_idx);
+
+ idx = SCM_INT_VALUE(scm_idx);
+
+ for (i = 0; i < idx - 1; i++) {
+ tmp = CDR(tmp);
+ }
+
+ SET_CDR(tmp, SCM_NULL);
+
+ return lst;
+}
+
+ScmObj ScmOp_SRFI1_drop_right_d(ScmObj lst, ScmObj scm_idx)
+{
+ ScmObj tmp = lst;
+ int len = 0;
+ int i;
+
+ /* sanity check */
+ if (!INTP(scm_idx))
+ SigScm_ErrorObj("drop-right! : number required but got ", scm_idx);
+
+ for (; CONSP(tmp); tmp = CDR(tmp))
+ len++;
+
+ len -= SCM_INT_VALUE(scm_idx);
+
+ tmp = lst;
+ for (i = 0; i < len - 1; i++) {
+ tmp = CDR(tmp);
+ }
+
+ SET_CDR(tmp, SCM_NULL);
+
+ return lst;
+}
+
+ScmObj ScmOp_SRFI1_split_at(ScmObj lst, ScmObj idx)
+{
+ return Scm_NewValuePacket(LIST_2(ScmOp_SRFI1_take(lst, idx),
+ ScmOp_SRFI1_drop(lst, idx)));
+}
+
+ScmObj ScmOp_SRFI1_split_at_d(ScmObj lst, ScmObj idx)
+{
+ ScmObj drop = ScmOp_SRFI1_drop(lst, idx);
+
+ return Scm_NewValuePacket(LIST_2(ScmOp_SRFI1_take_d(lst, idx),
+ drop));
+}
+
+ScmObj ScmOp_SRFI1_last(ScmObj lst)
+{
+ /* sanity check */
+ if (NULLP(lst))
+ SigScm_ErrorObj("last : non-empty, proper list is required but got ", lst);
+
+ return CAR(ScmOp_SRFI1_last_pair(lst));
+}
+
+ScmObj ScmOp_SRFI1_last_pair(ScmObj lst)
+{
+ /* sanity check */
+ if (NULLP(lst))
+ SigScm_ErrorObj("last-pair : non-empty, proper list is required but got ", lst);
+
+ for (; CONSP(CDR(lst)); lst = CDR(lst))
+ ;
+
+ return lst;
+}
Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c 2005-09-20 17:08:13 UTC (rev 1529)
+++ branches/r5rs/sigscheme/sigscheme.c 2005-09-21 02:25:05 UTC (rev 1530)
@@ -332,6 +332,32 @@
Scm_RegisterFuncEvaledList("cons*" , ScmOp_SRFI1_cons_star);
Scm_RegisterFuncEvaledList("make-list" , ScmOp_SRFI1_make_list);
Scm_RegisterFuncEvaledList("list-tabulate" , ScmOp_SRFI1_list_tabulate);
+ Scm_RegisterFunc1("proper-list?" , ScmOp_SRFI1_proper_listp);
+ Scm_RegisterFunc1("circular-list?" , ScmOp_SRFI1_circular_listp);
+ Scm_RegisterFunc1("dotted-list?" , ScmOp_SRFI1_dotted_listp);
+ Scm_RegisterFunc1("not-pair?" , ScmOp_SRFI1_not_pairp);
+ Scm_RegisterFunc1("null-list?" , ScmOp_SRFI1_null_listp);
+ Scm_RegisterFuncEvaledList("list=" , ScmOp_SRFI1_listequal);
+ Scm_RegisterFunc1("first" , ScmOp_SRFI1_first);
+ Scm_RegisterFunc1("second" , ScmOp_SRFI1_second);
+ Scm_RegisterFunc1("third" , ScmOp_SRFI1_third);
+ Scm_RegisterFunc1("fourth" , ScmOp_SRFI1_fourth);
+ Scm_RegisterFunc1("fifth" , ScmOp_SRFI1_fifth);
+ Scm_RegisterFunc1("sixth" , ScmOp_SRFI1_sixth);
+ Scm_RegisterFunc1("seventh" , ScmOp_SRFI1_seventh);
+ Scm_RegisterFunc1("eighth" , ScmOp_SRFI1_eighth);
+ Scm_RegisterFunc1("ninth" , ScmOp_SRFI1_ninth);
+ Scm_RegisterFunc1("tenth" , ScmOp_SRFI1_tenth);
+ Scm_RegisterFunc2("take" , ScmOp_SRFI1_take);
+ Scm_RegisterFunc2("drop" , ScmOp_SRFI1_drop);
+ Scm_RegisterFunc2("take-right" , ScmOp_SRFI1_take_right);
+ Scm_RegisterFunc2("drop-right" , ScmOp_SRFI1_drop_right);
+ Scm_RegisterFunc2("take!" , ScmOp_SRFI1_take_d);
+ Scm_RegisterFunc2("drop-right!" , ScmOp_SRFI1_drop_right_d);
+ Scm_RegisterFunc2("split-at" , ScmOp_SRFI1_split_at);
+ Scm_RegisterFunc2("split-at!" , ScmOp_SRFI1_split_at_d);
+ Scm_RegisterFunc1("last" , ScmOp_SRFI1_last);
+ Scm_RegisterFunc1("last-pair" , ScmOp_SRFI1_last_pair);
#endif
#if SCM_USE_SRFI8
/*=======================================================================
Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h 2005-09-20 17:08:13 UTC (rev 1529)
+++ branches/r5rs/sigscheme/sigscheme.h 2005-09-21 02:25:05 UTC (rev 1530)
@@ -438,6 +438,33 @@
ScmObj ScmOp_SRFI1_list_copy(ScmObj list);
ScmObj ScmOp_SRFI1_circular_list(ScmObj list, ScmObj env);
ScmObj ScmOp_SRFI1_iota(ScmObj args, ScmObj env);
+ScmObj ScmOp_SRFI1_proper_listp(ScmObj lst);
+ScmObj ScmOp_SRFI1_circular_listp(ScmObj lst);
+ScmObj ScmOp_SRFI1_dotted_listp(ScmObj lst);
+ScmObj ScmOp_SRFI1_not_pairp(ScmObj pair);
+ScmObj ScmOp_SRFI1_null_listp(ScmObj lst);
+ScmObj ScmOp_SRFI1_listequal(ScmObj args, ScmObj env);
+ScmObj ScmOp_SRFI1_first(ScmObj lst);
+ScmObj ScmOp_SRFI1_second(ScmObj lst);
+ScmObj ScmOp_SRFI1_third(ScmObj lst);
+ScmObj ScmOp_SRFI1_fourth(ScmObj lst);
+ScmObj ScmOp_SRFI1_fifth(ScmObj lst);
+ScmObj ScmOp_SRFI1_sixth(ScmObj lst);
+ScmObj ScmOp_SRFI1_seventh(ScmObj lst);
+ScmObj ScmOp_SRFI1_eighth(ScmObj lst);
+ScmObj ScmOp_SRFI1_ninth(ScmObj lst);
+ScmObj ScmOp_SRFI1_tenth(ScmObj lst);
+ScmObj ScmOp_SRFI1_carpluscdr(ScmObj lst);
+ScmObj ScmOp_SRFI1_take(ScmObj lst, ScmObj scm_idx);
+ScmObj ScmOp_SRFI1_drop(ScmObj lst, ScmObj scm_idx);
+ScmObj ScmOp_SRFI1_take_right(ScmObj lst, ScmObj scm_elem);
+ScmObj ScmOp_SRFI1_drop_right(ScmObj lst, ScmObj scm_elem);
+ScmObj ScmOp_SRFI1_take_d(ScmObj lst, ScmObj scm_idx);
+ScmObj ScmOp_SRFI1_drop_right_d(ScmObj lst, ScmObj scm_idx);
+ScmObj ScmOp_SRFI1_split_at(ScmObj lst, ScmObj idx);
+ScmObj ScmOp_SRFI1_split_at_d(ScmObj lst, ScmObj idx);
+ScmObj ScmOp_SRFI1_last(ScmObj lst);
+ScmObj ScmOp_SRFI1_last_pair(ScmObj lst);
#endif
#if SCM_USE_SRFI8
/* operations-srfi8.c */
Modified: branches/r5rs/sigscheme/test/test-srfi1.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-srfi1.scm 2005-09-20 17:08:13 UTC (rev 1529)
+++ branches/r5rs/sigscheme/test/test-srfi1.scm 2005-09-21 02:25:05 UTC (rev 1530)
@@ -1,4 +1,4 @@
-(load "test/unittest.scm")
+(load "./test/unittest.scm")
; xcons
(assert-equal? "xcons test1" '(a b c) (xcons '(b c) 'a))
@@ -9,22 +9,19 @@
; make-list
(assert-equal? "make-list test1" '(c c c c) (make-list 4 'c))
-(assert-equal? "make-list test2" '(1 2 3 4) (make-list 4))
(assert-equal? "make-list test2" '() (make-list 0 'c))
-(assert-equal? "make-list test2" '() (make-list 0))
+(assert-equal? "make-list test3" '() (make-list 0))
; list-tabulate
(assert-equal? "list-tabulate test1" '(0 1 2 3) (list-tabulate 4 (lambda (x) x)))
(assert-equal? "list-tabulate test2" '(1 2 3 4) (list-tabulate 4 (lambda (x) (+ x 1))))
-(assert-equal? "list-tabulate test2" '() (list-tabulate 0 (lambda (x) (+ x 1))))
+(assert-equal? "list-tabulate test3" '() (list-tabulate 0 (lambda (x) (+ x 1))))
; list-copy
(assert-equal? "list-copy test1" '(1 2 3 4) (list-copy (list 1 2 3 4)))
(assert-equal? "list-copy test2" '(1 2 (3 4)) (list-copy (list 1 2 (list 3 4))))
(assert-equal? "list-copy test3" '() (list-copy '()))
-;(display (circular-list '1 '2 '3 '4))
-
; iota
(assert-equal? "iota test1" '(0 1 2 3 4) (iota 5))
(assert-equal? "iota test2" '(1 2 3 4 5) (iota 5 1))
@@ -34,4 +31,123 @@
(assert-equal? "iota test6" '(-1 0 1) (iota 3 -1 1))
(assert-equal? "iota test7" '(-3 -1 1 3) (iota 4 -3 2))
+; list=
+(assert-true "list= test 1" (list= eq?))
+(assert-true "list= test 2" (list= eq? '(a)))
+(assert-true "list= test 3" (list= equal? '("a" "i" "u") '("a" "i" "u")))
+(assert-false "list= test 4" (list= equal? '("a" "i" "u") '("a" "i" "e")))
+(assert-false "list= test 5" (list= eqv? '("a" "i" "u") '("a" "i" "u")))
+(assert-true "list= test 6" (list= equal? '("a" "i" "u") '("a" "i" "u") '("a" "i" "u")))
+(assert-false "list= test 7" (list= equal? '("a" "i" "u") '("a" "i" "u") '("a" "i" "e")))
+
+(define proper-lst '(1 2 3 4 5))
+(define circular-lst (circular-list 1 2 3 4 5))
+(define dotted-lst '(1 2 3 4 . 5))
+(define null-lst '())
+; proper-list?
+(assert-true "proper-list? test 1" (proper-list? proper-lst))
+(assert-false "proper-list? test 2" (proper-list? circular-lst))
+(assert-false "proper-list? test 3" (proper-list? dotted-lst))
+(assert-true "proper-list? test 4" (proper-list? null-lst))
+; circular-list?
+(assert-false "circular-list? test 1" (circular-list? proper-lst))
+(assert-true "circular-list? test 2" (circular-list? circular-lst))
+(assert-false "circular-list? test 3" (circular-list? dotted-lst))
+(assert-false "circular-list? test 4" (circular-list? null-lst))
+; dotted-list?
+(assert-false "circular-list? test 1" (circular-list? proper-lst))
+(assert-true "circular-list? test 2" (circular-list? circular-lst))
+(assert-false "circular-list? test 3" (circular-list? dotted-lst))
+(assert-false "circular-list? test 4" (circular-list? null-lst))
+; not-pair?
+(assert-false "not-pair? test 1" (not-pair? proper-lst))
+(assert-false "not-pair? test 2" (not-pair? circular-lst))
+(assert-false "not-pair? test 3" (not-pair? dotted-lst))
+(assert-true "not-pair? test 4" (not-pair? null-lst))
+; null-list?
+(assert-false "null-list? test 1" (null-list? proper-lst))
+(assert-false "null-list? test 2" (null-list? circular-lst))
+(assert-false "null-list? test 3" (null-list? dotted-lst))
+(assert-true "null-list? test 4" (null-list? null-lst))
+
+(define num-lst (iota 10 1))
+; first
+(assert-equal? "first test" 1 (first num-lst))
+; second
+(assert-equal? "second test" 2 (second num-lst))
+; third
+(assert-equal? "third test" 3 (third num-lst))
+; fourth
+(assert-equal? "fourth test" 4 (fourth num-lst))
+; fifth
+(assert-equal? "fifth test" 5 (fifth num-lst))
+; sixth
+(assert-equal? "sixth test" 6 (sixth num-lst))
+; seventh
+(assert-equal? "seventh test" 7 (seventh num-lst))
+; eighth
+(assert-equal? "eighth test" 8 (eighth num-lst))
+; ninth
+(assert-equal? "ninth test" 9 (ninth num-lst))
+; tenth
+(assert-equal? "tenth test" 10 (tenth num-lst))
+
+; take
+(assert-equal? "take test 1" '(a b) (take '(a b c d e) 2))
+(assert-equal? "take test 2" '(1 2) (take '(1 2 3 . d) 2))
+(assert-equal? "take test 3" '(1 2 3) (take '(1 2 3 . d) 3))
+
+; drop
+(assert-equal? "drop test 1" '(c d e) (drop '(a b c d e) 2))
+(assert-equal? "drop test 2" '(3 . d) (drop '(1 2 3 . d) 2))
+(assert-equal? "drop test 3" 'd (drop '(1 2 3 . d) 3))
+
+; take-right
+(assert-equal? "take-right test 1" '(d e) (take-right '(a b c d e) 2) )
+(assert-equal? "take-right test 2" '(2 3 . d) (take-right '(1 2 3 . d) 2) )
+(assert-equal? "take-right test 3" 'd (take-right '(1 2 3 . d) 0) )
+
+; drop-right
+(assert-equal? "drop-right test 1" '(a b c) (drop-right '(a b c d e) 2))
+(assert-equal? "drop-right test 2" '(1) (drop-right '(1 2 3 . d) 2))
+(assert-equal? "drop-right test 3" '(1 2 3) (drop-right '(1 2 3 . d) 0))
+
+; take!
+(assert-equal? "take! test 1" '(a b) (take! '(a b c d e) 2))
+(assert-equal? "take! test 2" '(1 2) (take! '(1 2 3 . d) 2))
+(assert-equal? "take! test 3" '(1 2 3) (take! '(1 2 3 . d) 3))
+(assert-equal? "take! test 4" '(1 3) (take! (circular-list 1 3 5) 8))
+
+; drop-right!
+(assert-equal? "drop-right! test 1" '(a b c) (drop-right! '(a b c d e) 2))
+(assert-equal? "drop-right! test 2" '(1) (drop-right! '(1 2 3 . d) 2))
+(assert-equal? "drop-right! test 3" '(1 2 3) (drop-right! '(1 2 3 . d) 0))
+
+; split-at
+; TODO : fixme! current "receive" has the problem about evaluation order
+;(receive (former latter)
+; (split-at '(1 2 3 4 5 6 7) 3)
+; (assert-equal? "split-at test 1" '(1 2 3) former)
+; (assert-equal? "split-at test 2" '(4 5 6 7) latter))
+
+; split-at!
+; TODO : fixme! current "receive" has the problem about evaluation order
+;(receive (former latter)
+; (split-at! '(1 2 3 4 5 6 7) 3)
+; (assert-equal? "split-at! test 1" '(1 2 3) former)
+; (assert-equal? "split-at! test 2" '(4 5 6 7) latter))
+
+; last
+(assert-equal? "last test 1" 'a (last '(a)))
+(assert-equal? "last test 2" 'b (last '(a b)))
+(assert-equal? "last test 3" 'c (last '(a b c)))
+(assert-equal? "last test 4" 'c (last '(a b c . d)))
+
+; last-pair-pair
+(assert-equal? "last-pair test 1" '(a) (last-pair '(a)))
+(assert-equal? "last-pair test 2" '(b) (last-pair '(a b)))
+(assert-equal? "last-pair test 3" '(c) (last-pair '(a b c)))
+(assert-equal? "last-pair test 4" '(c . d) (last-pair '(a b c . d)))
+
+
(total-report)
More information about the uim-commit
mailing list