[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