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

kzk at freedesktop.org kzk at freedesktop.org
Fri Jul 29 14:25:47 EST 2005


Author: kzk
Date: 2005-07-28 21:25:41 -0700 (Thu, 28 Jul 2005)
New Revision: 1058

Modified:
   branches/r5rs/sigscheme/eval.c
   branches/r5rs/sigscheme/io.c
   branches/r5rs/sigscheme/operations.c
   branches/r5rs/sigscheme/test/test-apply.scm
   branches/r5rs/sigscheme/test/test-map.scm
Log:
* fixed the behavior of "apply", "map" and procs around IO.

* sigscheme/eval.c
  - (ScmOp_apply): fixed argument handling
* sigscheme/operations.c
  - (ScmOp_cdr): fixed error message
  - (ScmOp_map): fixed argument handling
* sigscheme/operations.c
  - (ScmOp_cdr): fixed error message
* sigscheme/io.c
  - (ScmOp_read): fixed typo
  - (ScmOp_read_char): fixed typo
  - (ScmOp_write): fixed argument handling
  - (ScmOp_display): fixed argument handling
  - (ScmOp_newline): fixed argument handling
  - (ScmOp_write_char): fixed argnument handling

* sigscheme/test/test-map.scm
  - add test case for defined procedure
* sigscheme/test/test-apply.scm
  - add testcases for various ARGNUM type



Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c	2005-07-29 04:14:22 UTC (rev 1057)
+++ branches/r5rs/sigscheme/eval.c	2005-07-29 04:25:41 UTC (rev 1058)
@@ -501,40 +501,40 @@
 		case ARGNUM_1:
 		    {
 			return SCM_FUNC_EXEC_SUBR1(proc,
-						   obj);
+						   SCM_CAR(obj));
 		    }
 		case ARGNUM_2:
 		    {
 			return SCM_FUNC_EXEC_SUBR2(proc,
-						   obj,
-						   SCM_CAR(SCM_CDR(SCM_CDR(args))));
+						   SCM_CAR(obj),
+						   SCM_CAR(SCM_CDR(obj)));
 		    }
 		case ARGNUM_3:
 		    {
 			return SCM_FUNC_EXEC_SUBR3(proc,
-						   obj,
-						   SCM_CAR(SCM_CDR(SCM_CDR(args))),
-						   SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(args)))));
+						   SCM_CAR(obj),
+						   SCM_CAR(SCM_CDR(obj)),
+						   SCM_CAR(SCM_CDR(SCM_CDR(obj))));
 		    }
 		case ARGNUM_4:
 		    {
 			return SCM_FUNC_EXEC_SUBR4(proc,
-						   obj,
-						   SCM_CAR(SCM_CDR(SCM_CDR(args))),
-						   SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(args)))),
-						   SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(SCM_CDR(args))))));
+						   SCM_CAR(obj),
+						   SCM_CAR(SCM_CDR(obj)),
+						   SCM_CAR(SCM_CDR(SCM_CDR(obj))),
+						   SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(obj)))));
 		    }
 		case ARGNUM_5:
 		    {
 			return SCM_FUNC_EXEC_SUBR5(proc,
-						   obj,
-						   SCM_CAR(SCM_CDR(SCM_CDR(args))),
-						   SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(args)))),
-						   SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(SCM_CDR(args))))),
-						   SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(SCM_CDR(SCM_CDR(args)))))));
+						   SCM_CAR(obj),
+						   SCM_CAR(SCM_CDR(obj)),
+						   SCM_CAR(SCM_CDR(SCM_CDR(obj))),
+						   SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(obj)))),
+						   SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(SCM_CDR(obj))))));
 		    }
 		default:
-		    SigScm_ErrorObj("apply : invalid application ", args);
+		    SigScm_ErrorObj("apply : invalid application ", proc);
 	    }
 	    break;
 	case ScmClosure:
@@ -550,28 +550,26 @@
 		 *   (2) : (<variable1> <variable2> ...)
 		 *   (3) : (<variable1> <variable2> ... <variable n-1> . <variable n>)
 		 */
-		obj = SCM_CAR(SCM_CLOSURE_EXP(proc)); /* arg is <formals> */
+		args = SCM_CAR(SCM_CLOSURE_EXP(proc)); /* arg is <formals> */
 
-		if (SCM_SYMBOLP(obj)) {
+		if (SCM_SYMBOLP(args)) {
 		    /* (1) : <variable> */
-		    env = extend_environment(Scm_NewCons(obj, SCM_NIL),
-					     Scm_NewCons(SCM_CDR(args),
-							 SCM_NIL),
+		    env = extend_environment(Scm_NewCons(args, SCM_NIL),
+					     Scm_NewCons(obj, SCM_NIL),
 					     SCM_CLOSURE_ENV(proc));
-		} else if (SCM_NULLP(obj) || SCM_CONSP(obj)) {
+		} else if (SCM_NULLP(args) || SCM_CONSP(args)) {
 		    /*
 		     * (2) : (<variable1> <variable2> ...)
 		     * (3) : (<variable1> <variable2> ... <variable n-1> . <variable n>)
 		     *
 		     *  - dot list is handled in lookup_frame().
 		     */
-		    env = extend_environment(obj,
-					     SCM_CAR(SCM_CDR(args)),
+		    env = extend_environment(args,
+					     obj,
 					     SCM_CLOSURE_ENV(proc));
 		} else {
-		    SigScm_ErrorObj("lambda : bad syntax with ", obj);
+		    SigScm_ErrorObj("lambda : bad syntax with ", args);
 		}
-		
 
 		/*
 		 * Notice
@@ -853,7 +851,7 @@
 		    SigScm_Error("cond : the value of exp after => must be the procedure but got ", proc);
 		
 		return ScmOp_apply(Scm_NewCons(proc,
-					       Scm_NewCons(test,
+					       Scm_NewCons(Scm_NewCons(test, SCM_NIL),
 							   SCM_NIL)),
 				   env);
 	    }

Modified: branches/r5rs/sigscheme/io.c
===================================================================
--- branches/r5rs/sigscheme/io.c	2005-07-29 04:14:22 UTC (rev 1057)
+++ branches/r5rs/sigscheme/io.c	2005-07-29 04:25:41 UTC (rev 1058)
@@ -257,7 +257,7 @@
 	/* (read port) */
 	port = SCM_CAR(SCM_CDR(arg));
     } else {
-	SigScm_ErrorObj("read : invalid paramter", arg);
+	SigScm_ErrorObj("read : invalid parameter", arg);
     }
 
     return SigScm_Read(port);
@@ -273,7 +273,7 @@
 	/* (read-char port) */
 	port = SCM_CAR(SCM_CDR(arg));
     } else {
-	SigScm_ErrorObj("read-char : invalid paramter", arg);
+	SigScm_ErrorObj("read-char : invalid parameter", arg);
     }
 
     return SigScm_Read_Char(port);
@@ -310,23 +310,16 @@
     ScmObj port = SCM_NIL;
 
     if CHECK_1_ARG(arg)
-	SigScm_Error("write : invalid paramter\n");
+	SigScm_Error("write : invalid parameter\n");
 
     /* get obj */
     obj = SCM_CAR(arg);
     arg = SCM_CDR(arg);
 
     /* get port */
-    port = SCM_NIL;
-    if (SCM_NULLP(arg)) {
-	/* (write obj) */
-	port = current_input_port;
-    } else if (!SCM_NULLP(SCM_CDR(arg)) && SCM_PORTP(SCM_CAR(SCM_CDR(arg)))) {
-	/* (write obj port) */
-	port = SCM_CAR(SCM_CDR(arg));
-    } else {
-	SigScm_ErrorObj("write : invalid paramter ", arg);
-    }
+    port = current_input_port;
+    if (!SCM_NULLP(arg) && !SCM_NULLP(SCM_CAR(arg)) && SCM_PORTP(SCM_CAR(arg)))
+	port = SCM_CAR(arg);
 
     SigScm_DisplayToPort(port, obj);
     return SCM_UNDEF;
@@ -341,23 +334,18 @@
     ScmObj port = SCM_NIL;
 
     if CHECK_1_ARG(arg)
-	SigScm_Error("display : invalid paramter\n");
+	SigScm_Error("display : invalid parameter\n");
 
     /* get obj */
     obj = SCM_CAR(arg);
     arg = SCM_CDR(arg);
 
     /* get port */
-    port = SCM_NIL;
-    if (SCM_NULLP(arg)) {
-	/* (write obj) */
-	port = current_output_port;
-    } else if (!SCM_NULLP(SCM_CDR(arg)) && SCM_PORTP(SCM_CAR(SCM_CDR(arg)))) {
-	/* (write obj port) */
-	port = SCM_CAR(SCM_CDR(arg));
-    } else {
-	SigScm_ErrorObj("display : invalid paramter ", arg);
-    }
+    port = current_output_port;
+    
+    /* (display obj port) */
+    if (!SCM_NULLP(arg) && SCM_PORTP(SCM_CAR(arg)))
+	port = SCM_CAR(arg);
 
     SigScm_DisplayToPort(port, obj);
     return SCM_UNDEF;
@@ -366,18 +354,14 @@
 ScmObj ScmOp_newline(ScmObj arg, ScmObj env)
 {
     /* get port */
-    ScmObj port = SCM_NIL;
-    if (SCM_NULLP(arg)) {
-	/* (write obj) */
-	port = current_output_port;
-    } else if (!SCM_NULLP(SCM_CDR(arg)) && SCM_PORTP(SCM_CAR(SCM_CDR(arg)))) {
-	/* (write obj port) */
-	port = SCM_CAR(SCM_CDR(arg));
-    } else {
-	SigScm_ErrorObj("newline : invalid paramter ", arg);
+    ScmObj port = current_output_port;
+
+    /* (newline port) */
+    if (!SCM_NULLP(arg) && !SCM_NULLP(SCM_CAR(arg)) && SCM_PORTP(SCM_CAR(arg))) {
+	port = SCM_CAR(arg);
     }
 
-    fprintf(SCM_PORTINFO_FILE(port), "\n");
+    SigScm_DisplayToPort(port, Scm_NewString("\n"));
     return SCM_UNDEF;
 }
 
@@ -387,7 +371,7 @@
     ScmObj port = SCM_NIL;
 
     if CHECK_1_ARG(arg)
-	SigScm_Error("write-char : invalid paramter\n");
+	SigScm_Error("write-char : invalid parameter\n");
 
     /* get obj */
     obj = SCM_CAR(arg);
@@ -396,16 +380,11 @@
 	SigScm_ErrorObj("write-char : char required but got ", obj);
 
     /* get port */
-    port = SCM_NIL;
-    if (SCM_NULLP(arg)) {
-	/* (write obj) */
-	port = current_input_port;
-    } else if (!SCM_NULLP(SCM_CDR(arg)) && SCM_PORTP(SCM_CAR(SCM_CDR(arg)))) {
-	/* (write obj port) */
-	port = SCM_CAR(SCM_CDR(arg));
-    } else {
-	SigScm_ErrorObj("write : invalid paramter ", arg);
-    }
+    port = current_output_port;
+    
+    /* (write-char obj port) */
+    if (!SCM_NULLP(arg) && SCM_PORTP(SCM_CAR(arg)))
+	port = SCM_CAR(arg);
 
     SigScm_DisplayToPort(port, obj);
     return SCM_UNDEF;

Modified: branches/r5rs/sigscheme/operations.c
===================================================================
--- branches/r5rs/sigscheme/operations.c	2005-07-29 04:14:22 UTC (rev 1057)
+++ branches/r5rs/sigscheme/operations.c	2005-07-29 04:25:41 UTC (rev 1058)
@@ -757,9 +757,9 @@
 ScmObj ScmOp_cdr(ScmObj obj)
 {
     if (SCM_NULLP(obj))
-        SigScm_Error("car : empty list");
+        SigScm_Error("cdr : empty list\n");
     if (!SCM_CONSP(obj))
-        SigScm_ErrorObj("car : list required but got ", obj);
+        SigScm_ErrorObj("cdr : list required but got ", obj);
 
     return SCM_CDR(obj);
 }
@@ -1780,16 +1780,11 @@
         for (args = SCM_CAR(SCM_CDR(map_arg)); !SCM_NULLP(args); args = SCM_CDR(args)) {
             /* create proc's arg */
             tmp = SCM_CAR(args);
-            if (!SCM_CONSP(tmp)) {
-                /* arg must be the list */
-                tmp = Scm_NewCons(tmp, SCM_NIL);
-            }
 
             /* create list for "apply" op */
             tmp = Scm_NewCons(proc,
-                              Scm_NewCons(tmp,
+                              Scm_NewCons(Scm_NewCons(tmp, SCM_NIL),
                                           SCM_NIL));
-
             /* apply proc */
             ret = Scm_NewCons(ScmOp_apply(tmp, env), ret);
         }

Modified: branches/r5rs/sigscheme/test/test-apply.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-apply.scm	2005-07-29 04:14:22 UTC (rev 1057)
+++ branches/r5rs/sigscheme/test/test-apply.scm	2005-07-29 04:25:41 UTC (rev 1058)
@@ -3,9 +3,16 @@
 ;; check apply
 (assert-eq? "apply check1" #t (apply = '(1 1 1)))
 (assert-eq? "apply check2" 6  (apply + `(1 2 ,(+ 1 2))))
-(assert-eq? "apply check3" 4  (apply (lambda (x y) (+ x y)) '(1 3)))
-(assert-eq? "apply check4" 4  (apply (lambda (x y) (+ x y)) '(1 3)))
+(assert-equal? "apply check3" '(3) (apply cddr '((1 2 3))))
+(assert-equal? "apply check4" #t (apply equal? '((1 2) (1 2))))
+(assert-equal? "apply check5" "iue" (apply substring '("aiueo" 1 3)))
 
+(assert-eq? "apply check6" 4  (apply (lambda (x y) (+ x y)) '(1 3)))
+(assert-eq? "apply check7" 4  (apply (lambda (x y) (+ x y)) '(1 3)))
+(assert-equal? "apply check8" '(1 2 3) (apply (lambda x x) '(1 2 3)))
+(assert-equal? "apply check9" 1 (apply (lambda (x) x) '(1)))
+(assert-equal? "apply check10" '(1) (apply (lambda x x) '(1)))
+
 (define compose
   (lambda (f g)
     (lambda args

Modified: branches/r5rs/sigscheme/test/test-map.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-map.scm	2005-07-29 04:14:22 UTC (rev 1057)
+++ branches/r5rs/sigscheme/test/test-map.scm	2005-07-29 04:25:41 UTC (rev 1058)
@@ -1,8 +1,13 @@
-(load "test/unittest.scm")
+(load "./test/unittest.scm")
 
 (assert-equal? "basic map test1" '(2 2 2) (map cadr '((1 2) (1 2) (1 2))))
 (assert-equal? "basic map test2" '(2 4 6) (map + '(1 2 3) '(1 2 3)))
 (assert-equal? "basic map test3" '(2 4 6) (map (lambda (x y) (+ x y))
 						'(1 2 3) '(1 2 3)))
 
+(define (callee a)
+  (assert-equal? "basic map test4" '(1 2) a))
+
+(map callee '((1 2)))
+
 (total-report)



More information about the uim-commit mailing list