[uim-commit] r1442 - in branches/r5rs/sigscheme: . test
yamaken at freedesktop.org
yamaken at freedesktop.org
Tue Sep 6 11:25:57 PDT 2005
Author: yamaken
Date: 2005-09-06 11:25:54 -0700 (Tue, 06 Sep 2005)
New Revision: 1442
Modified:
branches/r5rs/sigscheme/eval.c
branches/r5rs/sigscheme/sigscheme.h
branches/r5rs/sigscheme/test/test-exp.scm
branches/r5rs/sigscheme/test/test-list.scm
branches/r5rs/sigscheme/test/unittest.scm
Log:
* sigscheme/eval.c
- (ScmOp_quote, ScmOp_delay):
* Simplify with SCM_SHIFT_*()
* Rename argument variable
- (ScmExp_lambda):
* Rename argument variable
* Modify error message
- (ScmExp_if):
* Simplify with SCM_SHIFT_*()
* Add syntax error check for (if p x y z)
* sigscheme/sigscheme.h
- (ScmOp_quote, ScmExp_lambda, ScmExp_if, ScmOp_delay): Rename
argument variable
* sigscheme/test/test-list.scm
- (assert-error): Move to unittest.scm
* sigscheme/test/unittest.scm
- (assert-error): Moved from test-list.scm
* sigscheme/test/test-exp.scm
- (test if): New test. All tests are passed (including assert-error
although test9 needs SCM_STRICT_R5RS)
Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c 2005-09-06 15:41:05 UTC (rev 1441)
+++ branches/r5rs/sigscheme/eval.c 2005-09-06 18:25:54 UTC (rev 1442)
@@ -892,53 +892,66 @@
/*===========================================================================
R5RS : 4.1 Primitive expression types : 4.1.2 Literal expressions
===========================================================================*/
-ScmObj ScmOp_quote(ScmObj arglist, ScmObj env)
+/* FIXME: rename to ScmExp_quote since quote is a syntax */
+ScmObj ScmOp_quote(ScmObj args, ScmObj env)
{
- if (!CONSP(arglist) || !NULLP(CDR(arglist)))
- SigScm_ErrorObj("quote: bad argument list: ", arglist);
- return CAR(arglist);
+ ScmObj datum;
+ ScmObj rest = args;
+
+ if (!NULLP(SCM_SHIFT_RAW_1(datum, rest)))
+ SigScm_ErrorObj("quote: syntax error : ", args);
+
+ return datum;
}
/*===========================================================================
R5RS : 4.1 Primitive expression types : 4.1.4 Procedures
===========================================================================*/
-ScmObj ScmExp_lambda(ScmObj exp, ScmObj env)
+ScmObj ScmExp_lambda(ScmObj args, ScmObj env)
{
- if CHECK_2_ARGS(exp)
- SigScm_ErrorObj("lambda : too few argument ", exp);
+ if (CHECK_2_ARGS(args))
+ SigScm_ErrorObj("lambda : bad form : ", args);
- return Scm_NewClosure(exp, env);
+ return Scm_NewClosure(args, env);
}
/*===========================================================================
R5RS : 4.1 Primitive expression types : 4.1.5 Conditionals
===========================================================================*/
-ScmObj ScmExp_if(ScmObj exp, ScmObj *envp)
+ScmObj ScmExp_if(ScmObj args, ScmObj *envp)
{
- ScmObj env = *envp;
- ScmObj pred = SCM_NULL;
- ScmObj false_exp = SCM_NULL;
+ ScmObj test, conseq, alt;
+ ScmObj rest = args;
+ ScmObj env = *envp;
- /* sanity check */
- if (NULLP(exp) || NULLP(CDR(exp)))
- SigScm_ErrorObj("if : syntax error : ", exp);
+ /*========================================================================
+ (if <test> <consequent>)
+ (if <test> <consequent> <alternate>)
+ ========================================================================*/
- /* eval predicates */
- pred = EVAL(CAR(exp), env);
+ if (!(SCM_SHIFT_RAW_2(test, conseq, rest)))
+ SigScm_ErrorObj("if : syntax error : ", args);
- /* if pred is true value */
- if (NFALSEP(pred)) {
+ if (NFALSEP(EVAL(test, env))) {
+#if SCM_STRICT_R5RS
+ /* excessive arguments */
+ if (!NULLP(rest) && !NULLP(CDR(rest)))
+ SigScm_ErrorObj("if : syntax error : ", args);
+#endif
+
/* doesn't evaluate now for tail-recursion. */
- return CADR(exp);
- }
+ return conseq;
+ } else {
+ if (NULLP(rest))
+ return SCM_UNDEF;
- /* if pred is SCM_FALSE */
- false_exp = CDDR(exp);
- if (NULLP(false_exp))
- return SCM_UNDEF;
+ /* excessive arguments */
+ if (!NULLP(SCM_SHIFT_RAW_1(alt, rest)))
+ SigScm_ErrorObj("if : syntax error : ", args);
- /* doesn't evaluate now for tail-recursion. */
- return CAR(false_exp);
+ /* doesn't evaluate now for tail-recursion. */
+ return alt;
+ }
}
/*===========================================================================
@@ -1498,13 +1511,17 @@
/*===========================================================================
R5RS : 4.2 Derived expression types : 4.2.5 Delayed evaluation
===========================================================================*/
-ScmObj ScmOp_delay(ScmObj arg, ScmObj env)
+/* FIXME: rename to ScmExp_delay since delay is a syntax */
+ScmObj ScmOp_delay(ScmObj args, ScmObj env)
{
- if (SCM_INT_VALUE(ScmOp_length(arg)) != 1)
- SigScm_Error("delay : Wrong number of arguments\n");
+ ScmObj exp;
+ ScmObj rest = args;
- /* closure exp = ( () CAR(arg) ) */
- return Scm_NewClosure(SCM_LIST_2(SCM_NULL, CAR(arg)), env);
+ if (!NULLP(SCM_SHIFT_RAW_1(exp, rest)))
+ SigScm_ErrorObj("delay : syntax error ", args);
+
+ /* (lambda () exp) */
+ return Scm_NewClosure(SCM_LIST_2(SCM_NULL, exp), env);
}
/*===========================================================================
Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h 2005-09-06 15:41:05 UTC (rev 1441)
+++ branches/r5rs/sigscheme/sigscheme.h 2005-09-06 18:25:54 UTC (rev 1442)
@@ -166,9 +166,9 @@
/* eval.c */
ScmObj ScmOp_eval(ScmObj obj, ScmObj env);
ScmObj ScmOp_apply(ScmObj args, ScmObj env);
-ScmObj ScmOp_quote(ScmObj arglist, ScmObj envp);
-ScmObj ScmExp_lambda(ScmObj exp, ScmObj env);
-ScmObj ScmExp_if(ScmObj exp, ScmObj *envp);
+ScmObj ScmOp_quote(ScmObj args, ScmObj envp);
+ScmObj ScmExp_lambda(ScmObj args, ScmObj env);
+ScmObj ScmExp_if(ScmObj args, ScmObj *envp);
ScmObj ScmExp_set(ScmObj args, ScmObj env);
ScmObj ScmExp_cond(ScmObj arg, ScmObj *envp);
ScmObj ScmExp_case(ScmObj arg, ScmObj *envp);
@@ -179,7 +179,7 @@
ScmObj ScmExp_letrec(ScmObj arg, ScmObj *envp);
ScmObj ScmExp_begin(ScmObj arg, ScmObj *envp);
ScmObj ScmExp_do(ScmObj arg, ScmObj *envp);
-ScmObj ScmOp_delay(ScmObj arg, ScmObj env);
+ScmObj ScmOp_delay(ScmObj args, ScmObj env);
ScmObj ScmOp_quasiquote(ScmObj obj, ScmObj env);
ScmObj ScmOp_unquote(ScmObj obj, ScmObj env);
ScmObj ScmOp_unquote_splicing(ScmObj obj, ScmObj env);
Modified: branches/r5rs/sigscheme/test/test-exp.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-exp.scm 2005-09-06 15:41:05 UTC (rev 1441)
+++ branches/r5rs/sigscheme/test/test-exp.scm 2005-09-06 18:25:54 UTC (rev 1442)
@@ -1,5 +1,10 @@
(load "./test/unittest.scm")
+
+(define tee #t)
+(define ef #f)
+
+
;; lambda
(assert-equal? "basic lambda test1" 8 ((lambda (x) (+ x x)) 4))
(define reverse-subtract
@@ -18,6 +23,21 @@
(assert-equal? "basic lambda test10" 2 ((lambda (x y . z) y) 1 2))
(assert-equal? "basic lambda test11" '() ((lambda (x y . z) z) 1 2))
+;;if
+(assert-equal? "if test1" 'true (if #t 'true 'false))
+(assert-equal? "if test2" 'true (if #t 'true))
+(assert-equal? "if test3" 'false (if #f 'true 'false))
+;; check that does not cause error
+(assert-equal? "if test4" (if #f 'true) (if #f 'true))
+;; check that <test> is evaluated
+(assert-equal? "if test5" 'true (if tee 'true 'false))
+(assert-equal? "if test6" 'false (if ef 'true 'false))
+;; invalid forms
+;;(assert-error "if test7" (if))
+;;(assert-error "if test8" (if #t))
+;;(assert-error "if test9" (if #t 'true 'false 'excessive))
+;;(assert-error "if test10" (if #f 'true 'false 'excessive))
+
;; cond
(assert-equal? "basic cond test1" 'greater (cond ((> 3 2) 'greater)
((< 3 2) 'less)))
Modified: branches/r5rs/sigscheme/test/test-list.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-list.scm 2005-09-06 15:41:05 UTC (rev 1441)
+++ branches/r5rs/sigscheme/test/test-list.scm 2005-09-06 18:25:54 UTC (rev 1442)
@@ -44,11 +44,6 @@
(define cdr0 (cons elm0 cdr1))
(define lst cdr0)
-;; dummy definition to eval args for assert-error. real implementation needed.
-(if (not (symbol-bound? 'assert-error))
- (define assert-error
- (lambda (msg exp)
- #f)))
; pair?
(assert "pair? test1" (pair? '(a . b)))
Modified: branches/r5rs/sigscheme/test/unittest.scm
===================================================================
--- branches/r5rs/sigscheme/test/unittest.scm 2005-09-06 15:41:05 UTC (rev 1441)
+++ branches/r5rs/sigscheme/test/unittest.scm 2005-09-06 18:25:54 UTC (rev 1442)
@@ -57,3 +57,8 @@
(display " but got ")
(write b)
(newline)))))
+
+;; dummy definition to eval args for assert-error. real implementation needed.
+(define assert-error
+ (lambda (msg exp)
+ #f))
More information about the uim-commit
mailing list