[uim-commit] r1611 - in branches/r5rs/sigscheme: . test
kzk at freedesktop.org
kzk at freedesktop.org
Tue Sep 27 09:11:38 PDT 2005
Author: kzk
Date: 2005-09-27 09:11:36 -0700 (Tue, 27 Sep 2005)
New Revision: 1611
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:
* add "length+" and "concatenate"
* sigscheme/sigscheme.h
- (ScmOp_SRFI1_lengthplus, ScmOp_SRFI1_concatenate): new func
- update indent
* sigscheme/sigscheme.c
- export "length+" and "concatenate"
* sigscheme/operations-srfi1.c
- (ScmOp_SRFI1_lengthplus, ScmOp_SRFI1_concatenate): new func
- (compare_list): fix build issue
* test/test-srfi1.scm
- add test cases for "split-at", "split-at!", "length+", "concatenate"
Modified: branches/r5rs/sigscheme/operations-srfi1.c
===================================================================
--- branches/r5rs/sigscheme/operations-srfi1.c 2005-09-27 07:32:16 UTC (rev 1610)
+++ branches/r5rs/sigscheme/operations-srfi1.c 2005-09-27 16:11:36 UTC (rev 1611)
@@ -342,10 +342,8 @@
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));
+ (Scm_call(eqproc, \
+ LIST_2(obj1, obj2)))
ScmObj ret_cmp = SCM_FALSE;
@@ -588,3 +586,23 @@
return lst;
}
+
+/*==============================================================================
+ SRFI1 : The procedures : Miscellaneous
+==============================================================================*/
+ScmObj ScmOp_SRFI1_lengthplus(ScmObj lst)
+{
+ /* FIXME!: remove expensive circular_listp */
+ if (NFALSEP(ScmOp_SRFI1_circular_listp(lst)))
+ return SCM_FALSE;
+
+ return ScmOp_length(lst);
+}
+
+ScmObj ScmOp_SRFI1_concatenate(ScmObj args, ScmObj env)
+{
+ ScmObj lsts_of_lst = CAR(args);
+
+ return Scm_call(ScmOp_eval(Scm_Intern("append"), env),
+ lsts_of_lst);
+}
Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c 2005-09-27 07:32:16 UTC (rev 1610)
+++ branches/r5rs/sigscheme/sigscheme.c 2005-09-27 16:11:36 UTC (rev 1611)
@@ -370,6 +370,8 @@
Scm_RegisterFunc2("split-at!" , ScmOp_SRFI1_split_at_d);
Scm_RegisterFunc1("last" , ScmOp_SRFI1_last);
Scm_RegisterFunc1("last-pair" , ScmOp_SRFI1_last_pair);
+ Scm_RegisterFunc1("length+" , ScmOp_SRFI1_lengthplus);
+ Scm_RegisterFuncEvaledList("concatenate" , ScmOp_SRFI1_concatenate);
#endif
#if SCM_USE_SRFI8
/*=======================================================================
Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h 2005-09-27 07:32:16 UTC (rev 1610)
+++ branches/r5rs/sigscheme/sigscheme.h 2005-09-27 16:11:36 UTC (rev 1611)
@@ -370,24 +370,24 @@
/* eval.c */
ScmObj ScmOp_eval(ScmObj obj, ScmObj env);
- ScmObj ScmOp_apply(ScmObj proc, ScmObj arg0, ScmObj rest, ScmEvalState *eval_state);
- ScmObj ScmOp_quote(ScmObj datum, ScmObj env);
+ScmObj ScmOp_apply(ScmObj proc, ScmObj arg0, ScmObj rest, ScmEvalState *eval_state);
+ScmObj ScmOp_quote(ScmObj datum, ScmObj env);
ScmObj ScmExp_lambda(ScmObj args, ScmObj env);
- ScmObj ScmExp_if(ScmObj test, ScmObj conseq, ScmObj rest, ScmEvalState *eval_state);
+ScmObj ScmExp_if(ScmObj test, ScmObj conseq, ScmObj rest, ScmEvalState *eval_state);
ScmObj ScmExp_set(ScmObj var, ScmObj val, ScmObj env);
- ScmObj ScmExp_cond(ScmObj arg, ScmEvalState *eval_state);
- ScmObj ScmExp_case(ScmObj arg, ScmEvalState *eval_state);
- ScmObj ScmExp_and(ScmObj arg, ScmEvalState *eval_state);
- ScmObj ScmExp_or(ScmObj arg, ScmEvalState *eval_state);
- ScmObj ScmExp_let(ScmObj arg, ScmEvalState *eval_state);
+ScmObj ScmExp_cond(ScmObj arg, ScmEvalState *eval_state);
+ScmObj ScmExp_case(ScmObj arg, ScmEvalState *eval_state);
+ScmObj ScmExp_and(ScmObj arg, ScmEvalState *eval_state);
+ScmObj ScmExp_or(ScmObj arg, ScmEvalState *eval_state);
+ScmObj ScmExp_let(ScmObj arg, ScmEvalState *eval_state);
ScmObj ScmExp_let_star(ScmObj arg, ScmEvalState *eval_state);
ScmObj ScmExp_letrec(ScmObj arg, ScmEvalState *eval_state);
ScmObj ScmExp_begin(ScmObj arg, ScmEvalState *eval_state);
ScmObj ScmExp_do(ScmObj arg, ScmEvalState *eval_state);
ScmObj ScmOp_delay(ScmObj expr, ScmObj env);
- ScmObj ScmOp_quasiquote(ScmObj datum, ScmObj env);
- ScmObj ScmOp_unquote(ScmObj dummy, ScmObj env);
- ScmObj ScmOp_unquote_splicing(ScmObj dummy, ScmObj env);
+ScmObj ScmOp_quasiquote(ScmObj datum, ScmObj env);
+ScmObj ScmOp_unquote(ScmObj dummy, ScmObj env);
+ScmObj ScmOp_unquote_splicing(ScmObj dummy, ScmObj env);
ScmObj ScmExp_define(ScmObj var, ScmObj rest, ScmObj env);
ScmObj ScmOp_scheme_report_environment(ScmObj version);
ScmObj ScmOp_null_environment(ScmObj version);
@@ -617,6 +617,8 @@
ScmObj ScmOp_SRFI1_split_at_d(ScmObj lst, ScmObj idx);
ScmObj ScmOp_SRFI1_last(ScmObj lst);
ScmObj ScmOp_SRFI1_last_pair(ScmObj lst);
+ScmObj ScmOp_SRFI1_lengthplus(ScmObj lst);
+ScmObj ScmOp_SRFI1_concatenate(ScmObj args, ScmObj env);
#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-27 07:32:16 UTC (rev 1610)
+++ branches/r5rs/sigscheme/test/test-srfi1.scm 2005-09-27 16:11:36 UTC (rev 1611)
@@ -124,18 +124,16 @@
(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))
+(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))
+(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)))
@@ -149,5 +147,18 @@
(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)))
+; length+
+(assert-false "length+ test 1" (length+ circular-lst))
+; concatenate
+(assert-equal? "concatenate test 1" '() (concatenate '(())))
+(assert-equal? "concatenate test 2" '() (concatenate '(() ())))
+(assert-equal? "concatenate test 3" '() (concatenate '(() () ())))
+(assert-equal? "concatenate test 4" '(a) (concatenate '((a))))
+(assert-equal? "concatenate test 5" '(a b) (concatenate '((a) (b))))
+(assert-equal? "concatenate test 6" '(a b c) (concatenate '((a) (b) (c))))
+(assert-equal? "concatenate test 7" '(a b) (concatenate '((a b))))
+(assert-equal? "concatenate test 8" '(a b c d) (concatenate '((a b) (c d))))
+(assert-equal? "concatenate test 9" '(a b c d e f) (concatenate '((a b) (c d) (e f))))
+
(total-report)
More information about the uim-commit
mailing list