[uim-commit] r987 - branches/r5rs/sigscheme

Wed Jul 20 11:30:48 EST 2005

Author: kzk
Date: 2005-07-19 18:30:45 -0700 (Tue, 19 Jul 2005)
New Revision: 987

Modified:
   branches/r5rs/sigscheme/eval.c
   branches/r5rs/sigscheme/sigscheme.c
   branches/r5rs/sigscheme/sigscheme.h
Log:
* implement proper "letrec"

* sigscheme.c
  - (SigScm_Initialize): export "letrec" as ScmOp_letrec

* sigscheme.h
* eval.c
  - (ScmOp_letrec): new func


Modified: branches/r5rs/sigscheme/eval.c
===================================================================

--- branches/r5rs/sigscheme/eval.c	2005-07-19 22:28:11 UTC (rev 986)
+++ branches/r5rs/sigscheme/eval.c	2005-07-20 01:30:45 UTC (rev 987)
@@ -802,7 +802,7 @@
     body     = SCM_CDR(arg);
 
     /*========================================================================
-      (let <bindings> <body>)
+      (let* <bindings> <body>)
       <bindings> == ((<variable1> <init1>)
                      (<variable2> <init2>)
                      ...)
@@ -826,6 +826,51 @@
     return SCM_UNDEF;
 }
 
+ScmObj ScmExp_letrec(ScmObj arg, ScmObj env)
+{
+    ScmObj bindings = SCM_NIL;
+    ScmObj body     = SCM_NIL;
+
+    /* sanity check */
+    if CHECK_2_ARGS(arg)
+	SigScm_Error("let : syntax error\n");
+
+    /* get bindings and body */
+    bindings = SCM_CAR(arg);
+    body     = SCM_CDR(arg);
+
+    /*========================================================================
+      (letrec <bindings> <body>)
+      <bindings> == ((<variable1> <init1>)
+                     (<variable2> <init2>)
+                     ...)
+    ========================================================================*/
+    if (SCM_CONSP(bindings)) {
+	ScmObj vars = SCM_NIL;
+	ScmObj vals = SCM_NIL;
+	ScmObj binding = SCM_NIL;
+	for (; !SCM_NULLP(bindings); bindings = SCM_CDR(bindings)) {
+	    binding = SCM_CAR(bindings);
+
+
+	    /* first, temporally add symbol to the env*/
+	    vars = Scm_NewCons(SCM_CAR(binding), SCM_NIL);
+	    vals = Scm_NewCons(SCM_NIL, SCM_NIL);
+	    env  = extend_environment(vars, vals, env);
+
+	    /* then, evaluate <init> val and (set! var val) */
+	    ScmExp_set(Scm_NewCons(SCM_CAR(binding),
+				   Scm_NewCons(ScmOp_eval(SCM_CAR(SCM_CDR(binding)), env), SCM_NIL)),
+		       env);
+	}
+
+	return ScmExp_begin(body, env);
+    }
+
+    return SCM_UNDEF;
+}
+
+
 /*===========================================================================
   R5RS : 4.2 Derived expression types : 4.2.3 Sequencing
 ===========================================================================*/

Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c	2005-07-19 22:28:11 UTC (rev 986)
+++ branches/r5rs/sigscheme/sigscheme.c	2005-07-20 01:30:45 UTC (rev 987)
@@ -112,7 +112,7 @@
     Scm_InitSubrR("or"                   , ScmExp_or);
     Scm_InitSubrR("let"                  , ScmExp_let);
     Scm_InitSubrR("let*"                 , ScmExp_let_star);
-    Scm_InitSubrR("letrec"               , ScmExp_let);
+    Scm_InitSubrR("letrec"               , ScmExp_letrec);
     Scm_InitSubrR("begin"                , ScmExp_begin);
     Scm_InitSubrR("do"                   , ScmExp_do);
     Scm_InitSubrR("delay"                , ScmOp_delay);

Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h	2005-07-19 22:28:11 UTC (rev 986)
+++ branches/r5rs/sigscheme/sigscheme.h	2005-07-20 01:30:45 UTC (rev 987)
@@ -134,6 +134,7 @@
 ScmObj ScmExp_or(ScmObj arg, ScmObj env);
 ScmObj ScmExp_let(ScmObj arg, ScmObj env);
 ScmObj ScmExp_let_star(ScmObj arg, ScmObj env);
+ScmObj ScmExp_letrec(ScmObj arg, ScmObj env);
 ScmObj ScmExp_begin(ScmObj arg, ScmObj env);
 ScmObj ScmExp_do(ScmObj arg, ScmObj env);
 ScmObj ScmOp_delay(ScmObj arg, ScmObj env);

