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

[kzk at freedesktop.org]

Author: kzk
Date: 2005-07-27 06:43:00 -0700 (Wed, 27 Jul 2005)
New Revision: 1047

Modified:
   branches/r5rs/sigscheme/eval.c
   branches/r5rs/sigscheme/operations.c
   branches/r5rs/sigscheme/test/test-num.scm
Log:
* now support (+), (+ num), (- num), (*), (* num)

* sigscheme/operations.c
  - (ScmOp_plus2n):  support 0 and 1 arg
  - (ScmOp_minus2n): support 1 arg
  - (ScmOp_multi2n): support 0 and 1 arg
* sigscheme/eval.c
  - (ScmOp_eval, ScmOp_apply): handle 1st and 2nd argument
    of ARGNUM_2N function correctly.

* sigscheme/test/test-num.scm
  - add testcases for the use listed above


Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c	2005-07-27 10:43:26 UTC (rev 1046)
+++ branches/r5rs/sigscheme/eval.c	2005-07-27 13:43:00 UTC (rev 1047)
@@ -293,7 +293,19 @@
 			    case ARGNUM_2N:
 				{
 				    obj = SCM_CDR(obj);
+
+				    /* check 1st arg */
+				    if (SCM_NULLP(obj))
+					return SCM_FUNC_EXEC_SUBR2N(tmp, SCM_NIL, SCM_NIL);
+
+				    /* eval 1st arg */
 				    arg = ScmOp_eval(SCM_CAR(obj), env);
+
+				    /* check 2nd arg  */
+				    if (SCM_NULLP(SCM_CDR(obj)))
+					return SCM_FUNC_EXEC_SUBR2N(tmp, arg, SCM_NIL);
+
+				    /* call proc with each 2 objs */
 				    for (obj = SCM_CDR(obj); !SCM_NULLP(obj); obj = SCM_CDR(obj)) {
 					arg = SCM_FUNC_EXEC_SUBR2N(tmp,
 								   arg,
@@ -462,7 +474,19 @@
 		case ARGNUM_2N:
 		    {
 			args = obj;
+
+			/* check 1st arg */
+			if (SCM_NULLP(args))
+			    return SCM_FUNC_EXEC_SUBR2N(proc, SCM_NIL, SCM_NIL);
+
+			/* eval 1st arg */
 			obj  = SCM_CAR(args);
+
+			/* check 2nd arg */
+			if (SCM_NULLP(SCM_CDR(args)))
+			    return SCM_FUNC_EXEC_SUBR2N(proc, obj, SCM_NIL);
+
+			/* call proc with each 2 objs */
 			for (args = SCM_CDR(args); !SCM_NULLP(args); args = SCM_CDR(args)) {
 			    obj = SCM_FUNC_EXEC_SUBR2N(proc,
 						       obj,

Modified: branches/r5rs/sigscheme/operations.c
===================================================================
--- branches/r5rs/sigscheme/operations.c	2005-07-27 10:43:26 UTC (rev 1046)
+++ branches/r5rs/sigscheme/operations.c	2005-07-27 13:43:00 UTC (rev 1047)
@@ -269,8 +269,15 @@
 ==============================================================================*/
 ScmObj ScmOp_plus2n(ScmObj obj1, ScmObj obj2)
 {
+    if (SCM_NULLP(obj1) && SCM_NULLP(obj2))
+	return Scm_NewInt(0);
+
     if (!SCM_INTP(obj1))
         SigScm_ErrorObj("+ : integer required but got ", obj1);
+
+    if (SCM_NULLP(obj2))
+	return Scm_NewInt(SCM_INT_VALUE(obj1));
+
     if (!SCM_INTP(obj2))
 	SigScm_ErrorObj("+ : integer required but got ", obj2);
     
@@ -281,17 +288,27 @@
 {
     if (!SCM_INTP(obj1))
         SigScm_ErrorObj("- : integer required but got ", obj1);
+
+    if (SCM_NULLP(obj2))
+	return Scm_NewInt(-(SCM_INT_VALUE(obj1)));
+
     if (!SCM_INTP(obj2))
         SigScm_ErrorObj("- : integer required but got ", obj2);
 	
-
     return Scm_NewInt(SCM_INT_VALUE(obj1) - SCM_INT_VALUE(obj2));
 }
 
 ScmObj ScmOp_multi2n(ScmObj obj1, ScmObj obj2)
 {
+    if (SCM_NULLP(obj1) && SCM_NULLP(obj2))
+	return Scm_NewInt(1);
+
     if (!SCM_INTP(obj1))
         SigScm_ErrorObj("* : integer required but got ", obj1);
+
+    if (SCM_NULLP(obj2))
+	return Scm_NewInt(SCM_INT_VALUE(obj1));
+
     if (!SCM_INTP(obj2))
         SigScm_ErrorObj("* : integer required but got ", obj2);
 

Modified: branches/r5rs/sigscheme/test/test-num.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-num.scm	2005-07-27 10:43:26 UTC (rev 1046)
+++ branches/r5rs/sigscheme/test/test-num.scm	2005-07-27 13:43:00 UTC (rev 1047)
@@ -1,9 +1,16 @@
 (load "test/unittest.scm")
 
 (assert-eq? "= test" #t (= 1 1))
-(assert-eq? "+ test" 3  (+ 1 2))
-(assert-eq? "- test" -1 (- 1 2))
-(assert-eq? "* test" 2  (* 1 2))
+(assert-eq? "+ test1" 0  (+))
+(assert-eq? "+ test2" 3  (+ 3))
+(assert-eq? "+ test3" 3  (+ 1 2))
+(assert-eq? "+ test4" 6  (+ 1 2 3))
+(assert-eq? "- test1" -3 (- 3))
+(assert-eq? "- test2" -1 (- 1 2))
+(assert-eq? "- test3" -4 (- 1 2 3))
+(assert-eq? "* test1" 1  (*))
+(assert-eq? "* test2" 2  (* 2))
+(assert-eq? "* test3" 24 (* 2 3 4))
 (assert-eq? "/ test1" 0  (/ 1 2))
 (assert-eq? "/ test2" -1 (/ -2 2))