[uim-commit] r974 - in branches/r5rs/sigscheme: . test
kzk at freedesktop.org
kzk at freedesktop.org
Mon Jul 18 08:38:54 EST 2005
Author: kzk
Date: 2005-07-17 15:38:50 -0700 (Sun, 17 Jul 2005)
New Revision: 974
Added:
branches/r5rs/sigscheme/test/test-do.scm
Modified:
branches/r5rs/sigscheme/eval.c
branches/r5rs/sigscheme/operations.c
branches/r5rs/sigscheme/sigscheme.c
branches/r5rs/sigscheme/sigscheme.h
branches/r5rs/sigscheme/test/test-let.scm
Log:
* Now "append", "let*", "letrec", "do" is implemented.
* sigscheme/sigscheme.c
- (SigScm_Initialize) : init subr "let*", "letrec",
"do", "append".
* sigscheme/sigscheme.h
- (ScmExp_let_star) : new func
- (ScmExp_do) : new func
* sigscheme/operations.c
- (ScmOp_append_internal) : new func
- (ScmOp_append) : new func
* sigscheme/eval.c
- (ScmExp_let_star) : new func
- (ScmExp_do) : new func
* sigscheme/test/test-let.scm
- add some testcases for "let", "let*", "letrec"
* sigscheme/test/test-do.scm
- new file. test case for "do"
Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c 2005-07-17 21:10:29 UTC (rev 973)
+++ branches/r5rs/sigscheme/eval.c 2005-07-17 22:38:50 UTC (rev 974)
@@ -788,6 +788,44 @@
return SCM_UNDEF;
}
+ScmObj ScmExp_let_star(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);
+
+ /*========================================================================
+ (let <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);
+ vars = Scm_NewCons(SCM_CAR(binding), SCM_NIL);
+ vals = Scm_NewCons(ScmOp_eval(SCM_CAR(SCM_CDR(binding)), env), SCM_NIL);
+
+ /* add env to each time!*/
+ env = extend_environment(vars, vals, env);
+ }
+
+ return ScmExp_begin(body, env);
+ }
+
+ return SCM_UNDEF;
+}
+
/*===========================================================================
R5RS : 4.2 Derived expression types : 4.2.3 Sequencing
===========================================================================*/
@@ -822,51 +860,68 @@
ScmObj ScmExp_do(ScmObj arg, ScmObj env)
{
/*
+ * (do ((<variable1> <init1> <step1>)
+ * (<variable2> <init2> <step2>)
+ * ...)
+ * (<test> <expression> ...)
+ * <command> ...)
+ */
+
+ ScmObj bindings = SCM_CAR(arg);
+ ScmObj vars = SCM_NIL;
+ ScmObj vals = SCM_NIL;
+ ScmObj steps = SCM_NIL;
+ ScmObj binding = SCM_NIL;
+ ScmObj step = SCM_NIL;
+ ScmObj testframe = SCM_NIL;
+ ScmObj test = SCM_NIL;
+ ScmObj expression = SCM_NIL;
+ ScmObj commands = SCM_NIL;
+ ScmObj tmp_steps = SCM_NIL;
+
+ /* sanity check */
if (SCM_INT_VALUE(ScmOp_length(arg)) < 2)
SigScm_Error("do : syntax error\n");
- // (do ((<variable1> <init1> <step1>)
- // (<variable2> <init2> <step2>)
- // ...)
- // (<test> <expression> ...)
- // <command> ...)
-
- // Construct Environment and steps
- ScmObj steps = SCM_NIL;
- ScmObj bindings = SCM_CAR(arg);
+ /* construct Environment and steps */
for (; !SCM_NULLP(bindings); bindings = SCM_CDR(bindings)) {
- // TODO : creating new frame for each binding is heavy?
- // may be able to optimize this process.
- ScmObj binding = SCM_CAR(bindings);
- ScmObj vars = Scm_NewCons(SCM_CAR(binding), SCM_NIL);
- ScmObj vals = Scm_NewCons(ScmOp_eval(SCM_CAR(SCM_CDR(binding)), env), SCM_NIL);
- env = extend_environment(vars, vals, env);
+ binding = SCM_CAR(bindings);
+ vars = Scm_NewCons(SCM_CAR(binding), vars);
+ vals = Scm_NewCons(ScmOp_eval(SCM_CAR(SCM_CDR(binding)), env), vals);
- ScmObj step = SCM_CAR(SCM_CAR(SCM_CDR(binding)));
+ step = SCM_CDR(SCM_CDR(binding));
if (!SCM_NULLP(step)) {
- ScmOp_append(steps, step);
+ step = SCM_CAR(step);
+
+ /* append (<var> <step>) to steps */
+ steps = Scm_NewCons(Scm_NewCons(SCM_CAR(binding),
+ Scm_NewCons(step, SCM_NIL)),
+ steps);
}
}
- // Construct test
- ScmObj testframe = SCM_CAR(SCM_CDR(arg));
- ScmObj test = SCM_CAR(testframe);
- ScmObj expression = SCM_CAR(SCM_CDR(testframe));
+ /* now extend environment */
+ env = extend_environment(vars, vals, env);
- // Construct commands
- ScmObj commands = SCM_CDR(SCM_CDR(arg));
+ /* construct test */
+ testframe = SCM_CAR(SCM_CDR(arg));
+ test = SCM_CAR(testframe);
+ expression = SCM_CDR(testframe);
- SigScm_PrintScmObj(steps);
- SigScm_PrintScmObj(env);
- SigScm_PrintScmObj(test);
- SigScm_PrintScmObj(expression);
- SigScm_PrintScmObj(commands);
+ /* construct commands */
+ commands = SCM_CDR(SCM_CDR(arg));
+ /* now excution phase! */
+ while (!SCM_EQ(ScmOp_eval(test, env), SCM_TRUE)) {
+ ScmExp_begin(commands, env);
+
+ tmp_steps = steps;
+ for (; !SCM_NULLP(tmp_steps); tmp_steps = SCM_CDR(tmp_steps)) {
+ ScmExp_set(SCM_CAR(tmp_steps), env);
+ }
+ }
- return SCM_NIL;
- */
-
- return SCM_NIL;
+ return ScmExp_begin(expression, env);
}
/*===========================================================================
Modified: branches/r5rs/sigscheme/operations.c
===================================================================
--- branches/r5rs/sigscheme/operations.c 2005-07-17 21:10:29 UTC (rev 973)
+++ branches/r5rs/sigscheme/operations.c 2005-07-17 22:38:50 UTC (rev 974)
@@ -58,6 +58,7 @@
=======================================*/
static ScmObj list_gettail(ScmObj head);
static ScmObj ScmOp_listtail_internal(ScmObj obj, int k);
+static ScmObj ScmOp_append_internal(ScmObj head, ScmObj tail);
/*=======================================
Function Implementations
@@ -764,7 +765,7 @@
return Scm_NewInt(length);
}
-ScmObj ScmOp_append(ScmObj head, ScmObj tail)
+ScmObj ScmOp_append_internal(ScmObj head, ScmObj tail)
{
ScmObj head_tail = SCM_NIL;
@@ -787,6 +788,18 @@
return head;
}
+ScmObj ScmOp_append(ScmObj args, ScmObj env)
+{
+ ScmObj ret = SCM_NIL;
+ ScmObj obj = SCM_NIL;
+ for (; !SCM_NULLP(args); args = SCM_CDR(args)) {
+ obj = SCM_CAR(args);
+ ret = ScmOp_append_internal(ret, obj);
+ }
+
+ return ret;
+}
+
ScmObj ScmOp_reverse(ScmObj list)
{
ScmObj ret_list = SCM_NIL;
Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c 2005-07-17 21:10:29 UTC (rev 973)
+++ branches/r5rs/sigscheme/sigscheme.c 2005-07-17 22:38:50 UTC (rev 974)
@@ -111,8 +111,10 @@
Scm_InitSubrR("and" , ScmExp_and);
Scm_InitSubrR("or" , ScmExp_or);
Scm_InitSubrR("let" , ScmExp_let);
- Scm_InitSubrR("let*" , ScmExp_let);
+ Scm_InitSubrR("let*" , ScmExp_let_star);
+ Scm_InitSubrR("letrec" , ScmExp_let);
Scm_InitSubrR("begin" , ScmExp_begin);
+ Scm_InitSubrR("do" , ScmExp_do);
Scm_InitSubrR("delay" , ScmOp_delay);
Scm_InitSubrR("define" , ScmExp_define);
Scm_InitSubr1("scheme-report-environment", ScmOp_scheme_report_environment);
@@ -182,6 +184,7 @@
Scm_InitSubr1("list?" , ScmOp_listp);
Scm_InitSubrL("list" , ScmOp_list);
Scm_InitSubr1("length" , ScmOp_length);
+ Scm_InitSubrL("append" , ScmOp_append);
Scm_InitSubr1("reverse" , ScmOp_reverse);
Scm_InitSubr2("list-tail" , ScmOp_listtail);
Scm_InitSubr2("list-ref" , ScmOp_listref);
Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h 2005-07-17 21:10:29 UTC (rev 973)
+++ branches/r5rs/sigscheme/sigscheme.h 2005-07-17 22:38:50 UTC (rev 974)
@@ -130,7 +130,9 @@
ScmObj ScmExp_and(ScmObj arg, ScmObj env);
ScmObj ScmExp_or(ScmObj arg, ScmObj env);
ScmObj ScmExp_let(ScmObj arg, ScmObj env);
+ScmObj ScmExp_let_star(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);
ScmObj ScmOp_quasiquote(ScmObj temp);
ScmObj ScmOp_unquote(ScmObj exp);
@@ -139,7 +141,6 @@
ScmObj ScmOp_scheme_report_environment(ScmObj version);
ScmObj ScmOp_null_environment(ScmObj version);
-
/* operations.c */
ScmObj ScmOp_eqvp(ScmObj obj1, ScmObj obj2);
ScmObj ScmOp_eqp(ScmObj Obj1, ScmObj obj2);
Added: branches/r5rs/sigscheme/test/test-do.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-do.scm 2005-07-17 21:10:29 UTC (rev 973)
+++ branches/r5rs/sigscheme/test/test-do.scm 2005-07-17 22:38:50 UTC (rev 974)
@@ -0,0 +1,11 @@
+(load "test/unittest.scm")
+
+(define (expt-do x n)
+ (do ((i 0 (+ i 1))
+ (y 1))
+ ((= i n) y)
+ (set! y (* x y))))
+
+(assert-eq? "expt-do test" 1024 (expt-do 2 10))
+
+(total-report)
Modified: branches/r5rs/sigscheme/test/test-let.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-let.scm 2005-07-17 21:10:29 UTC (rev 973)
+++ branches/r5rs/sigscheme/test/test-let.scm 2005-07-17 22:38:50 UTC (rev 974)
@@ -6,6 +6,31 @@
(assert-eq? "basic let test2" 1 (let ((n 0))
(set! n 1)))
+(assert-eq? "basic let test3" 1 (let ((n 0))
+ (set! n (+ n 1))))
+
+(assert-eq? "basic let test4" 3 (let ((n1 2)
+ (n2 1))
+ (+ n1 n2)))
+
+(assert-eq? "basic let* test1" 70 (let ((x 2) (y 3))
+ (let* ((x 7)
+ (z (+ x y)))
+ (* z x))))
+
+(assert-eq? "basic letrec test1" #t (let ((even?
+ (lambda (n)
+ (if (zero? n)
+ #t
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (zero? n)
+ #f
+ (even? (- n 1))))))
+ (even? 88)))
+
+
(define count
(let ((n 0))
(lambda ()
More information about the uim-commit
mailing list