[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