[uim-commit] r1107 - in branches/r5rs/sigscheme: . test

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)

