[uim-commit] r1107 - in branches/r5rs/sigscheme: . test
kzk at freedesktop.org
kzk at freedesktop.org
Wed Aug 3 05:12:27 EST 2005
Author: kzk
Date: 2005-08-02 12:12:23 -0700 (Tue, 02 Aug 2005)
New Revision: 1107
Modified:
branches/r5rs/sigscheme/eval.c
branches/r5rs/sigscheme/test/test-exp.scm
Log:
* implement "Named let"
* sigscheme/eval.c
- (add_environment): create env correctly when env is SCM_NIL
- (ScmExp_let): implement named let
- (ScmExp_let_star): use add_environment correctly
* sigscheme/test/test-exp.scm
- add testcase for named let
Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c 2005-08-02 16:38:45 UTC (rev 1106)
+++ branches/r5rs/sigscheme/eval.c 2005-08-02 19:12:23 UTC (rev 1107)
@@ -119,7 +119,9 @@
/* add (var val) pair to the newest frame in env */
if (SCM_NULLP(env)) {
- env = Scm_NewCons(Scm_NewCons(var, val),
+ newest_frame = Scm_NewCons(Scm_NewCons(var, SCM_NIL),
+ Scm_NewCons(val, SCM_NIL));
+ env = Scm_NewCons(newest_frame,
SCM_NIL);
} else if (SCM_CONSP(env)) {
newest_frame = SCM_CAR(env);
@@ -232,7 +234,7 @@
/* QUOTE case */
break;
default:
- SigScm_ErrorObj("eval : invalid operation ", tmp);
+ SigScm_ErrorObj("eval : invalid operation ", obj);
break;
}
/*============================================================
@@ -986,6 +988,10 @@
if CHECK_2_ARGS(arg)
SigScm_Error("let : syntax error\n");
+ /* guess whether syntax is "Named let" */
+ if (SCM_SYMBOLP(SCM_CAR(arg)))
+ goto named_let;
+
/* get bindings and body */
bindings = SCM_CAR(arg);
body = SCM_CDR(arg);
@@ -1010,7 +1016,32 @@
return ScmExp_begin(body, &env);
}
- return SCM_UNDEF;
+named_let:
+ /*========================================================================
+ (let <variable> <bindings> <body>)
+ <bindings> == ((<variable1> <init1>)
+ (<variable2> <init2>)
+ ...)
+ ========================================================================*/
+ bindings = SCM_CAR(SCM_CDR(arg));
+ body = SCM_CDR(SCM_CDR(arg));
+ for (; !SCM_NULLP(bindings); bindings = SCM_CDR(bindings)) {
+ binding = SCM_CAR(bindings);
+ vars = Scm_NewCons(SCM_CAR(binding), vars);
+ vals = Scm_NewCons(SCM_CAR(SCM_CDR(binding)), vals);
+ }
+
+ vars = ScmOp_reverse(vars);
+ vals = ScmOp_reverse(vals);
+
+ /* (define (<variable> <variable1> <variable2> ...>) <body>) */
+ ScmExp_define(Scm_NewCons(Scm_NewCons(SCM_CAR(arg),
+ vars),
+ body),
+ &env);
+
+ /* (func <init1> <init2> ...) */
+ return Scm_NewCons(SCM_CAR(arg), vals);
}
ScmObj ScmExp_let_star(ScmObj arg, ScmObj *envp)
@@ -1288,7 +1319,7 @@
SCM_SETCAR(val, ScmOp_eval(body, env));
} else {
/* add to environment (not create new frame) */
- add_environment(var, ScmOp_eval(body, env), env);
+ env = add_environment(var, ScmOp_eval(body, env), env);
}
}
Modified: branches/r5rs/sigscheme/test/test-exp.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-exp.scm 2005-08-02 16:38:45 UTC (rev 1106)
+++ branches/r5rs/sigscheme/test/test-exp.scm 2005-08-02 19:12:23 UTC (rev 1107)
@@ -91,6 +91,19 @@
(assert-eq? "lexical scope test5" 1 a)))
(lexical-test)
+(assert-equal? "named let test" '((6 1 3) (-5 -2)) (let loop ((numbers '(3 -2 1 6 -5))
+ (nonneg '())
+ (neg '()))
+ (cond ((null? numbers) (list nonneg neg))
+ ((>= (car numbers) 0)
+ (loop (cdr numbers)
+ (cons (car numbers) nonneg)
+ neg))
+ ((< (car numbers) 0)
+ (loop (cdr numbers)
+ nonneg
+ (cons (car numbers) neg))))))
+
;; let*
(assert-eq? "basic let* test1" 70 (let ((x 2) (y 3))
(let* ((x 7)
More information about the uim-commit
mailing list