[uim-commit] r1681 - in branches/r5rs/sigscheme: . test
yamaken at freedesktop.org
yamaken at freedesktop.org
Fri Sep 30 03:48:07 PDT 2005
Author: yamaken
Date: 2005-09-30 03:48:04 -0700 (Fri, 30 Sep 2005)
New Revision: 1681
Modified:
branches/r5rs/sigscheme/error.c
branches/r5rs/sigscheme/eval.c
branches/r5rs/sigscheme/sigscheme.c
branches/r5rs/sigscheme/sigschemeinternal.h
branches/r5rs/sigscheme/test/test-exp.scm
Log:
* This commit fixes the invalid environment treatment for letrec. See
the paragraph starting with "One restriction on `letrec' is very
important: ..." in 4.2.2 Binding constructs of R5RS and [Anthy-dev
2214]
* sigscheme/sigschemeinternal.h
- (scm_letrec_env): Removed
* sigscheme/eval.c
- (scm_letrec_env): Removed
- (symbol_value): Remove unnecessary scm_letrec_env handling
- (ScmExp_letrec):
* Ditto
* Fix the invalid env treatment (letrec ((a 1) (b a)) b)
* sigscheme/sigscheme.c
- (SigScm_Initialize_internal): Remove unnecessary scm_letrec_env handling
* sigscheme/error.c
- (SigScm_ShowBacktrace): Ditto
* test/test-exp.scm
- Add a test for the invalid letrec form
Modified: branches/r5rs/sigscheme/error.c
===================================================================
--- branches/r5rs/sigscheme/error.c 2005-09-30 02:47:41 UTC (rev 1680)
+++ branches/r5rs/sigscheme/error.c 2005-09-30 10:48:04 UTC (rev 1681)
@@ -143,7 +143,6 @@
#define IS_UNBOUND(var, env) \
(NULLP(lookup_environment(var, env)) \
- && NULLP(lookup_environment(var, scm_letrec_env)) \
&& EQ(SCM_SYMBOL_VCELL(var), SCM_UNBOUND))
switch (SCM_TYPE(obj)) {
Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c 2005-09-30 02:47:41 UTC (rev 1680)
+++ branches/r5rs/sigscheme/eval.c 2005-09-30 10:48:04 UTC (rev 1681)
@@ -75,7 +75,6 @@
Variable Declarations
=======================================*/
ScmObj scm_continuation_thrown_obj = NULL; /* for storing continuation return object */
-ScmObj scm_letrec_env = NULL; /* for storing environment obj of letrec */
struct trace_frame *scm_trace_root = NULL;
@@ -544,13 +543,6 @@
return CAR(val);
}
- /* next, lookup the special environment for letrec */
- val = lookup_environment(var, scm_letrec_env);
- if (!NULLP(val)) {
- /* variable is found in letrec environment, so returns its value */
- return CAR(val);
- }
-
/* finally, look at the VCELL */
val = SCM_SYMBOL_VCELL(var);
if (EQ(val, SCM_UNBOUND)) {
@@ -1186,12 +1178,13 @@
ScmObj ScmExp_letrec(ScmObj bindings, ScmObj body, ScmEvalState *eval_state)
{
ScmObj env = eval_state->env;
+ ScmObj frame = SCM_FALSE;
ScmObj vars = SCM_NULL;
ScmObj vals = SCM_NULL;
+ ScmObj rest_vals = SCM_FALSE;
ScmObj binding = SCM_NULL;
ScmObj var = SCM_NULL;
ScmObj val = SCM_NULL;
- ScmObj frame = SCM_NULL;
/*========================================================================
(letrec <bindings> <body>)
@@ -1200,6 +1193,11 @@
...)
========================================================================*/
if (CONSP(bindings) || NULLP(bindings)) {
+ /* extend env by placeholder frame for subsequent lambda evaluations */
+ frame = CONS(SCM_NULL, SCM_NULL);
+ env = CONS(frame, env);
+ eval_state->env = env;
+
for (; !NULLP(bindings); bindings = CDR(bindings)) {
binding = CAR(bindings);
@@ -1212,29 +1210,16 @@
#endif
SCM_SHIFT_RAW_2(var, val, binding);
- /* construct vars and vals list */
+ /* construct vars and vals list: any <init> must not refer a
+ <variable> at this time */
vars = CONS(var, vars);
- vals = CONS(val, vals);
+ vals = CONS(EVAL(val, env), vals);
}
- /* construct new frame for scm_letrec_env */
- frame = CONS(vars, vals);
- scm_letrec_env = CONS(frame, scm_letrec_env);
+ /* fill placeholders */
+ SET_CAR(frame, vars);
+ SET_CDR(frame, vals);
- /* extend environment by scm_letrec_env */
- env = extend_environment(CAR(frame), CDR(frame), env);
-
- /* ok, vars of letrec is extended to env */
- scm_letrec_env = SCM_NULL;
-
- /* set new env */
- eval_state->env = env;
-
- /* evaluate vals */
- for (; !NULLP(vals); vals = CDR(vals)) {
- SET_CAR(vals, EVAL(CAR(vals), env));
- }
-
/* evaluate body */
return ScmExp_begin(body, eval_state);
}
Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c 2005-09-30 02:47:41 UTC (rev 1680)
+++ branches/r5rs/sigscheme/sigscheme.c 2005-09-30 10:48:04 UTC (rev 1681)
@@ -113,7 +113,6 @@
Externed Variable Initialization
=======================================================================*/
scm_continuation_thrown_obj = SCM_NULL;
- scm_letrec_env = SCM_NULL;
/*=======================================================================
Storage Initialization
=======================================================================*/
Modified: branches/r5rs/sigscheme/sigschemeinternal.h
===================================================================
--- branches/r5rs/sigscheme/sigschemeinternal.h 2005-09-30 02:47:41 UTC (rev 1680)
+++ branches/r5rs/sigscheme/sigschemeinternal.h 2005-09-30 10:48:04 UTC (rev 1681)
@@ -65,7 +65,6 @@
/* eval.c */
extern ScmObj scm_continuation_thrown_obj;
-extern ScmObj scm_letrec_env;
extern struct trace_frame *scm_trace_root;
/* error.c*/
Modified: branches/r5rs/sigscheme/test/test-exp.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-exp.scm 2005-09-30 02:47:41 UTC (rev 1680)
+++ branches/r5rs/sigscheme/test/test-exp.scm 2005-09-30 10:48:04 UTC (rev 1681)
@@ -161,6 +161,11 @@
(apply-2 (car args) (append-to-last (cdr args))))))
(assert-equal? "basic letrec test3" '((1) . 2) (mularg-apply cons '(1) '(2)))
(assert-equal? "basic letrec test4" '(1 2) (mularg-apply cons 1 '((2))))
+;; SigScheme dependent behavior
+(assert-error "basic letrec test5" (lambda ()
+ (letrec ((letrec-a 1)
+ (letrec-b letrec-a))
+ letrec-b))
;; begin
(define x 0)
More information about the uim-commit
mailing list