[uim-commit] r1044 - in branches/r5rs/sigscheme: . test
kzk at freedesktop.org
kzk at freedesktop.org
Wed Jul 27 17:25:07 EST 2005
Author: kzk
Date: 2005-07-27 00:25:03 -0700 (Wed, 27 Jul 2005)
New Revision: 1044
Modified:
branches/r5rs/sigscheme/eval.c
branches/r5rs/sigscheme/test/test-apply.scm
Log:
* implement "apply" procedure. but i think this procedure is not well tested.
So, please add many testcases for this proc.
* sigscheme/eval.c
- (ScmOp_apply): re-implemented correctly
* sigscheme/test/test-apply.scm
- add testcase
Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c 2005-07-27 06:41:32 UTC (rev 1043)
+++ branches/r5rs/sigscheme/eval.c 2005-07-27 07:25:03 UTC (rev 1044)
@@ -387,7 +387,124 @@
ScmObj ScmOp_apply(ScmObj args, ScmObj env)
{
- SigScm_Error("apply is now broken\n");
+ ScmObj proc = SCM_NIL;
+ ScmObj obj = SCM_NIL;
+
+ /* sanity check */
+ if CHECK_2_ARGS(args)
+ SigScm_Error("apply : Wrong number of arguments\n");
+
+ /* 1st elem of list is proc */
+ proc = SCM_CAR(args);
+
+ /* 2nd elem of list is obj */
+ obj = SCM_CAR(SCM_CDR(args));
+
+ /* apply proc */
+ switch (SCM_GETTYPE(proc)) {
+ case ScmFunc:
+ switch (SCM_FUNC_NUMARG(proc)) {
+ case ARGNUM_L:
+ {
+ return SCM_FUNC_EXEC_SUBRL(proc,
+ map_eval(obj, env),
+ env);
+ }
+ case ARGNUM_2N:
+ {
+ args = obj;
+ obj = SCM_CAR(args);
+ for (args = SCM_CDR(args); !SCM_NULLP(args); args = SCM_CDR(args)) {
+ obj = SCM_FUNC_EXEC_SUBR2N(proc,
+ obj,
+ ScmOp_eval(SCM_CAR(args), env));
+ }
+ return obj;
+ }
+ case ARGNUM_0:
+ {
+ return SCM_FUNC_EXEC_SUBR0(proc);
+ }
+ case ARGNUM_1:
+ {
+ return SCM_FUNC_EXEC_SUBR1(proc,
+ obj);
+ }
+ case ARGNUM_2:
+ {
+ return SCM_FUNC_EXEC_SUBR2(proc,
+ obj,
+ SCM_CAR(SCM_CDR(SCM_CDR(args))));
+ }
+ case ARGNUM_3:
+ {
+ return SCM_FUNC_EXEC_SUBR3(proc,
+ obj,
+ SCM_CAR(SCM_CDR(SCM_CDR(args))),
+ SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(args)))));
+ }
+ case ARGNUM_4:
+ {
+ return SCM_FUNC_EXEC_SUBR4(proc,
+ obj,
+ SCM_CAR(SCM_CDR(SCM_CDR(args))),
+ SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(args)))),
+ SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(SCM_CDR(args))))));
+ }
+ case ARGNUM_5:
+ {
+ return SCM_FUNC_EXEC_SUBR5(proc,
+ obj,
+ SCM_CAR(SCM_CDR(SCM_CDR(args))),
+ SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(args)))),
+ SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(SCM_CDR(args))))),
+ SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(SCM_CDR(SCM_CDR(args)))))));
+ }
+ default:
+ SigScm_ErrorObj("apply : invalid applycation ", args);
+ }
+ break;
+ case ScmClosure:
+ {
+ /*
+ * (lambda <formals> <body>)
+ *
+ * <formals> should have 3 forms.
+ *
+ * (1) : <variable>
+ * (2) : (<variable1> <variable2> ...)
+ * (3) : (<variable1> <variable2> ... <variable n-1> . <variable n>)
+ */
+ obj = SCM_CAR(SCM_CLOSURE_EXP(proc)); /* arg is <formals> */
+
+ if (SCM_SYMBOLP(obj)) {
+ /* (1) : <variable> */
+ env = extend_environment(Scm_NewCons(obj, SCM_NIL),
+ Scm_NewCons(SCM_CDR(args),
+ SCM_NIL),
+ SCM_CLOSURE_ENV(proc));
+ } else if (SCM_NULLP(obj) || SCM_CONSP(obj)) {
+ /*
+ * (2) : (<variable1> <variable2> ...)
+ * (3) : (<variable1> <variable2> ... <variable n-1> . <variable n>)
+ *
+ * - dot list is handled in lookup_frame().
+ */
+ env = extend_environment(obj,
+ SCM_CAR(SCM_CDR(args)),
+ SCM_CLOSURE_ENV(proc));
+ } else {
+ SigScm_ErrorObj("lambda : bad syntax with ", obj);
+ }
+
+ obj = ScmExp_begin(SCM_CDR(SCM_CLOSURE_EXP(proc)), &env);
+ return ScmOp_eval(obj, env);
+ }
+ default:
+ SigScm_ErrorObj("apply : invalid applycation ", args);
+ }
+
+ /* never reaches here */
return SCM_NIL;
}
Modified: branches/r5rs/sigscheme/test/test-apply.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-apply.scm 2005-07-27 06:41:32 UTC (rev 1043)
+++ branches/r5rs/sigscheme/test/test-apply.scm 2005-07-27 07:25:03 UTC (rev 1044)
@@ -1,8 +1,15 @@
(load "./test/unittest.scm")
;; check apply
-(assert-eq? "apply check" #t (apply = '(1 1 1)))
-(assert-eq? "apply check" 6 (apply + `(1 2 ,(+ 1 2))))
-(assert-eq? "apply check" 4 (apply (lambda (x y) (+ x y)) '(1 3)))
+(assert-eq? "apply check1" #t (apply = '(1 1 1)))
+(assert-eq? "apply check2" 6 (apply + `(1 2 ,(+ 1 2))))
+(assert-eq? "apply check3" 4 (apply (lambda (x y) (+ x y)) '(1 3)))
+(assert-eq? "apply check4" 4 (apply (lambda (x y) (+ x y)) '(1 3)))
+(define compose
+ (lambda (f g)
+ (lambda args
+ (f (apply g args)))))
+(assert-equal? "apply check5" "100" ((compose number->string *) 4 25))
+
(total-report)
More information about the uim-commit
mailing list