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

kzk at freedesktop.org kzk at freedesktop.org
Wed Aug 3 02:28:17 EST 2005


Author: kzk
Date: 2005-08-02 09:28:13 -0700 (Tue, 02 Aug 2005)
New Revision: 1105

Modified:
   branches/r5rs/sigscheme/eval.c
   branches/r5rs/sigscheme/main.c
   branches/r5rs/sigscheme/sigscheme.c
   branches/r5rs/sigscheme/sigscheme.h
   branches/r5rs/sigscheme/test/test-exp.scm
Log:
* fix "letrec" behavior
* fix "repl" behavior

* sigscheme/eval.c
  - (letrec_env): new variable
  - (symbol_value): lookup letrec_env also
  - (ScmExp_letrec): use letrec_env and construct new environment
* sigscheme/sigscheme.c
  - (continuation_thrown_obj, letrec_env): new variable
  - (SigScm_Initialize): initialize continuation_thrown_obj,
    letrec_env
* sigscheme/sigscheme.h
  - disable SRFI1 feature now
* sigscheme/test/test-exp.scm
  - add testcases for letrec

* sigscheme/main.c
  - (repl): protect stack correctly



Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c	2005-08-02 14:48:29 UTC (rev 1104)
+++ branches/r5rs/sigscheme/eval.c	2005-08-02 16:28:13 UTC (rev 1105)
@@ -65,6 +65,7 @@
   Variable Declarations
 =======================================*/
 ScmObj continuation_thrown_obj = NULL;
+ScmObj letrec_env = NULL;
 
 /*=======================================
   File Local Function Declarations
@@ -610,14 +611,21 @@
     if (!SCM_SYMBOLP(var))
 	SigScm_ErrorObj("symbol_value : not symbol : ", var);
 
-    /* First, lookup the Environment */
+    /* first, lookup the environment */
     val = lookup_environment(var, env);
     if (!SCM_NULLP(val)) {
-        /* Variable is found in Environment, so returns its value */
+        /* variable is found in environment, so returns its value */
         return SCM_CAR(val);
     }
 
-    /* Next, look at the VCELL */
+    /* next, lookup the special environment for letrec */
+    val = lookup_environment(var, letrec_env);
+    if (!SCM_NULLP(val)) {
+        /* variable is found in letrec environment, so returns its value */
+        return SCM_CAR(val);
+    }
+
+    /* finally, look at the VCELL */
     val = SCM_SYMBOL_VCELL(var);
     if (EQ(val, SCM_UNBOUND)) {
         SigScm_ErrorObj("symbol_value : unbound variable ", var);
@@ -1049,14 +1057,15 @@
 
 ScmObj ScmExp_letrec(ScmObj arg, ScmObj *envp)
 {
-    ScmObj env      = *envp;
-    ScmObj bindings = SCM_NIL;
-    ScmObj body     = SCM_NIL;
-    ScmObj vars     = SCM_NIL;
-    ScmObj vals     = SCM_NIL;
-    ScmObj binding  = SCM_NIL;
-    ScmObj var      = SCM_NIL;
-    ScmObj val      = SCM_NIL;
+    ScmObj env       = *envp;
+    ScmObj bindings  = SCM_NIL;
+    ScmObj body      = SCM_NIL;
+    ScmObj vars      = SCM_NIL;
+    ScmObj vals      = SCM_NIL;
+    ScmObj binding   = SCM_NIL;
+    ScmObj var       = SCM_NIL;
+    ScmObj val       = SCM_NIL;
+    ScmObj frame     = SCM_NIL;
 
     /* sanity check */
     if CHECK_2_ARGS(arg)
@@ -1078,24 +1087,34 @@
 	    var = SCM_CAR(binding);
 	    val = SCM_CAR(SCM_CDR(binding));
 
-	    /* first, temporally add symbol to the env. Initial var is #<undef> */
-	    vars = Scm_NewCons(var,       SCM_NIL);
-	    vals = Scm_NewCons(SCM_UNDEF, SCM_NIL);
-	    env  = extend_environment(vars, vals, env);
-
-	    /* then, evaluate <init> val and (set! var val) */
-	    ScmExp_set(Scm_NewCons(var,
-				   Scm_NewCons(val,
-					       SCM_NIL)),
-		       &env);
+	    /* construct vars and vals list */
+	    vars = Scm_NewCons(var, vars);
+	    vals = Scm_NewCons(val, vals);
 	}
 
+	/* construct new frame for letrec_env */
+	frame = Scm_NewCons(vars, vals);
+	letrec_env = Scm_NewCons(frame, letrec_env);
+
+	/* extend environment by letrec_env */
+	env = extend_environment(SCM_CAR(frame), SCM_CDR(frame), env);
+
+	/* ok, vars of letrec is extended to env */
+	letrec_env = SCM_NIL;
+
 	/* set new env */
 	*envp = env;
 
+	/* evaluate vals */
+	for (; !SCM_NULLP(vals); vals = SCM_CDR(vals)) {
+	    SCM_SETCAR(vals, ScmOp_eval(SCM_CAR(vals), env));
+	}
+	
+	/* evaluate body */
 	return ScmExp_begin(body, &env);
     }
 
+    SigScm_Error("letrec : syntax error\n");
     return SCM_UNDEF;
 }
 

Modified: branches/r5rs/sigscheme/main.c
===================================================================
--- branches/r5rs/sigscheme/main.c	2005-08-02 14:48:29 UTC (rev 1104)
+++ branches/r5rs/sigscheme/main.c	2005-08-02 16:28:13 UTC (rev 1105)
@@ -55,10 +55,19 @@
 /* Very simple repl, please rewrite. */
 static void repl(void)
 {
-    ScmObj stdin_port  = Scm_NewFilePort(stdin,  "stdin",  PORT_INPUT);
-    ScmObj stdout_port = Scm_NewFilePort(stdout, "stdout", PORT_INPUT);
-    ScmObj s_exp, result;
+    ScmObj stack_start;
+    ScmObj stdin_port  = SCM_NIL;
+    ScmObj stdout_port = SCM_NIL;
+    ScmObj s_exp  = SCM_NIL;
+    ScmObj result = SCM_NIL;
 
+    /* start protecting stack */
+    SigScm_gc_protect_stack(&stack_start);
+
+    /* init variable */
+    stdin_port  = Scm_NewFilePort(stdin,  "stdin",  PORT_INPUT);
+    stdout_port = Scm_NewFilePort(stdout, "stdout", PORT_OUTPUT); 
+
     printf("sscm> ");
 
     for( s_exp = SigScm_Read(stdin_port);
@@ -72,6 +81,9 @@
     
     ScmOp_close_input_port(stdin_port);
     ScmOp_close_input_port(stdout_port);
+
+    /* now no need to protect stack */
+    SigScm_gc_unprotect_stack(&stack_start);
 }
 
 /*=======================================

Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c	2005-08-02 14:48:29 UTC (rev 1104)
+++ branches/r5rs/sigscheme/sigscheme.c	2005-08-02 16:28:13 UTC (rev 1105)
@@ -64,6 +64,8 @@
 ScmObjInternal SigScm_quote_impl, SigScm_quasiquote_impl, SigScm_unquote_impl, SigScm_unquote_splicing_impl;
 ScmObjInternal SigScm_unbound_impl, SigScm_unspecified_impl, SigScm_undef_impl;
 
+extern ScmObj continuation_thrown_obj, letrec_env;
+
 /*=======================================
   Function Implementations
 =======================================*/
@@ -87,6 +89,11 @@
     SCM_NEW_ETC(SigScm_unspecified,      SigScm_unspecified_impl,      10);
     SCM_NEW_ETC(SigScm_undef,            SigScm_undef_impl,            11);
     /*=======================================================================
+      Externed Variable Initialization
+    =======================================================================*/
+    continuation_thrown_obj = SCM_NIL;
+    letrec_env              = SCM_NIL;
+    /*=======================================================================
       Storage Initialization
     =======================================================================*/
     SigScm_InitStorage();
@@ -97,7 +104,6 @@
     SCM_SYMBOL_VCELL(Scm_Intern("#f"))   = SCM_FALSE;
     SCM_SYMBOL_VCELL(Scm_Intern("else")) = SCM_TRUE;
     SCM_SYMBOL_VCELL(Scm_Intern("=>"))   = SCM_TRUE;
-
     /*=======================================================================
       Export Scheme Functions
     =======================================================================*/
@@ -259,7 +265,6 @@
     Scm_InitSubr1("load"                 , ScmOp_load);
     Scm_InitSubr1("file-exists?"         , ScmOp_file_existsp);
     Scm_InitSubr1("delete-file"          , ScmOp_delete_file);
-
     /*=======================================================================
       Current Input & Output Initialization
     =======================================================================*/

Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h	2005-08-02 14:48:29 UTC (rev 1104)
+++ branches/r5rs/sigscheme/sigscheme.h	2005-08-02 16:28:13 UTC (rev 1105)
@@ -72,7 +72,7 @@
 #define DEBUG_PARSER  0
 #define DEBUG_GC      0
 #define USE_EUCJP     1
-#define USE_SRFI1     1
+#define USE_SRFI1     0
 
 #define CHECK_1_ARG(arg) \
     (SCM_NULLP(arg))

Modified: branches/r5rs/sigscheme/test/test-exp.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-exp.scm	2005-08-02 14:48:29 UTC (rev 1104)
+++ branches/r5rs/sigscheme/test/test-exp.scm	2005-08-02 16:28:13 UTC (rev 1105)
@@ -114,6 +114,18 @@
 						     (b "aiueo"))
 					      (a)))
 
+(define mularg-apply
+  (letrec ((apply-2 apply)
+	   (append-to-last
+	    (lambda (lst)
+	      (if (null? (cdr lst))
+		  (car lst)
+		  (cons (car lst) (append-to-last (cdr lst)))))))
+    (lambda args
+      (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))))
+
 ;; begin
 (define x 0)
 (assert-eq? "basic begin test1" 6 (begin



More information about the uim-commit mailing list