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

[tkng at freedesktop.org]

Author: tkng
Date: 2005-07-24 02:36:02 -0700 (Sun, 24 Jul 2005)
New Revision: 1018

Modified:
   branches/r5rs/sigscheme/eval.c
   branches/r5rs/sigscheme/test/test-define.scm
Log:
* sigscheme/eval.c: Support dot list as function argument.
 - (extend_environment): Support dot list argument binding.
 - (ScmExp_define): Implemented dot list argument.

* sigcheme/test/test-define.scm: Added tests for dot list argument.


Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c	2005-07-24 06:45:36 UTC (rev 1017)
+++ branches/r5rs/sigscheme/eval.c	2005-07-24 09:36:02 UTC (rev 1018)
@@ -83,6 +83,7 @@
 /*=======================================
   Function Implementations
 =======================================*/
+
 static ScmObj extend_environment(ScmObj vars, ScmObj vals, ScmObj env)
 {
     ScmObj frame = SCM_NIL;
@@ -91,6 +92,33 @@
     if (SCM_NULLP(vars) && SCM_NULLP(vals))
 	return env;
 
+
+    /* FIXME: Rewrite this arcane code. */
+    if (SCM_NULLP(SCM_CAR(vars))) {
+      vars = Scm_NewCons(SCM_CDR(vars), SCM_NIL);
+      vals = Scm_NewCons(vals, SCM_NIL);
+    } else if (!SCM_CONSP(ScmOp_last_pair(vars))) {
+
+      if(!SCM_CONSP(SCM_CDR(vars))) {
+	SCM_SETCDR(vars, Scm_NewCons(SCM_CDR(vars), SCM_NIL));
+	SCM_SETCDR(vals, Scm_NewCons(SCM_CDR(vals), SCM_NIL));
+      } else {
+	ScmObj vars_tmp, vals_tmp;
+	for(vars_tmp = vars, vals_tmp = vals;
+	    SCM_CONSP(SCM_CDR(vars_tmp)); 
+	    vars_tmp = SCM_CDR(vars_tmp), vals_tmp = SCM_CDR(vals_tmp)) {
+	}
+	SCM_SETCDR(vars_tmp, Scm_NewCons(SCM_CDR(vars_tmp), SCM_NIL));
+	SCM_SETCDR(vals_tmp, Scm_NewCons(SCM_CDR(vals_tmp), SCM_NIL));
+
+#if 0
+	printf("========\n");
+	SigScm_Display(vars);
+	printf("-------\n");
+	SigScm_Display(vals);
+#endif
+      }
+    }
     /* create new frame */
     frame   = Scm_NewCons(vars, vals);
 
@@ -1074,7 +1102,18 @@
       TODO : implement this
     ========================================================================*/
 
+    if (EQ(ScmOp_pairp(var), SCM_TRUE)) {
+	val     = SCM_CAR(var);
+	formals = SCM_CDR(var);
+	body    = SCM_CDR(arg);
+	if (!SCM_CONSP(formals))
+	  formals = Scm_NewCons(SCM_NIL, formals);
 
+	/* (val (lambda (formals) body))  */
+	return ScmExp_define(Scm_NewCons(val, Scm_NewCons(ScmExp_lambda(Scm_NewCons(formals, body), env),
+							  SCM_NIL)), env);
+       
+    }
     return SCM_NIL;
 }
 

Modified: branches/r5rs/sigscheme/test/test-define.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-define.scm	2005-07-24 06:45:36 UTC (rev 1017)
+++ branches/r5rs/sigscheme/test/test-define.scm	2005-07-24 09:36:02 UTC (rev 1018)
@@ -1,20 +1,49 @@
-(load "test/unittest.scm")
 
+(load "./test/unittest.scm")
+
 ; basic define
 (define val1 3)
-(assert-eq? "*basic define check*" 3 val1)
+(assert-eq? "basic define check" 3 val1)
 
 ; redefine
 (define val1 5)
-(assert-eq? "*redefine check*" 5 val1)
+(assert-eq? "redefine check" 5 val1)
 
 ; define lambda
 (define (what? x)
   "DEADBEEF" x)
 (assert-eq? "func define" 10 (what? 10))
 
+(define what2?
+  (lambda (x)
+    "DEADBEEF" x))
+(assert-eq? "func define" 10 (what2? 10))
+
 (define (add x y)
   (+ x y))
 (assert-eq? "func define" 10 (add 2 8))
 
+; tests for dot list arguments
+(define (dotarg1 . a)
+  a)
+(assert-equal? "dot arg test 1" '(1 2) (dotarg1 1 2))
+
+(define (dotarg2 a . b)
+  a)
+(assert-eq? "dot arg test 2" 1 (dotarg2 1 2))
+
+(define (dotarg3 a . b)
+  b)
+(assert-equal? "dot arg test 3" '(2) (dotarg3 1 2))
+(assert-equal? "dot arg test 4" '(2 3) (dotarg3 1 2 3))
+
+
+(define (dotarg4 a b . c)
+  b)
+(assert-eq? "dot arg test 5" 2 (dotarg4 1 2 3))
+
+(define (dotarg5 a b . c)
+  c)
+(assert-equal? "dot arg test 6" '(3 4) (dotarg5 1 2 3 4))
+
 (total-report)