[uim-commit] r2366 - in branches/r5rs/sigscheme: . test
yamaken at freedesktop.org
yamaken at freedesktop.org
Sun Dec 4 10:56:26 PST 2005
Author: yamaken
Date: 2005-12-04 10:56:22 -0800 (Sun, 04 Dec 2005)
New Revision: 2366
Modified:
branches/r5rs/sigscheme/TODO
branches/r5rs/sigscheme/eval.c
branches/r5rs/sigscheme/operations-srfi34.c
branches/r5rs/sigscheme/operations.c
branches/r5rs/sigscheme/sigscheme.c
branches/r5rs/sigscheme/sigschemeinternal.h
branches/r5rs/sigscheme/test/test-exp.scm
Log:
* sigscheme/sigschemeinternal.h
- (ScmExp_cond_internal): Add 'case_key' arg
* sigscheme/eval.c
- (ScmExp_cond_internal):
* Add 'case_key' arg
* Support 'case' syntax
* Fix invalid (else => proc) clause handling
- (ScmExp_cond): Follow the interface change of ScmExp_cond_internal()
- (ScmExp_case):
* Replace the implementation with ScmExp_cond_internal()
* Fix SEGVs
* Handle 'else' as pure syntactic keyword without #t value binding
* Support tested value as result (case 'key ((key))) => key
* Support procedure application (case 'key ((key) => symbol?)) => #t
* sigscheme/operations-srfi34.c
- (guard_handler_body): Follow the interface change of
ScmExp_cond_internal()
* sigscheme/operations.c
- (ScmOp_memq, ScmOp_memv, ScmOp_member): Add properness check for
the list argument
* sigscheme/sigscheme.c
- (SigScm_Initialize_internal): Remove 'else' -> #t binding
* sigscheme/test/test-exp.scm
- Add invalid (cond (else => values)) form
- Add tests for 'case'
* sigscheme/TODO
- Update
Modified: branches/r5rs/sigscheme/TODO
===================================================================
--- branches/r5rs/sigscheme/TODO 2005-12-04 16:36:44 UTC (rev 2365)
+++ branches/r5rs/sigscheme/TODO 2005-12-04 18:56:22 UTC (rev 2366)
@@ -84,8 +84,6 @@
Assigned to YamaKen:
-* Rewrite ScmExp_case() and obsolete 'else' value
-
* Revise fatal error handling
* Fix character and escape sequence related issues. grep Scm_special_char_table
Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c 2005-12-04 16:36:44 UTC (rev 2365)
+++ branches/r5rs/sigscheme/eval.c 2005-12-04 18:56:22 UTC (rev 2366)
@@ -776,8 +776,8 @@
/*===========================================================================
R5RS : 4.2 Derived expression types : 4.2.1 Conditionals
===========================================================================*/
-/* body of 'cond' and also invoked from 'guard' of SRFI-34 */
-ScmObj ScmExp_cond_internal(ScmObj args, ScmEvalState *eval_state)
+/* body of 'cond' and also invoked from 'case' and 'guard' of SRFI-34 */
+ScmObj ScmExp_cond_internal(ScmObj args, ScmObj case_key, ScmEvalState *eval_state)
{
/*
* (cond <clause1> <clause2> ...)
@@ -798,6 +798,10 @@
ScmObj proc = SCM_FALSE;
DECLARE_INTERNAL_FUNCTION("cond" /* , SyntaxVariadicTailRec0 */);
+ /* dirty hack to replace internal function name */
+ if (VALIDP(case_key))
+ SCM_MANGLE(name) = "case";
+
if (NO_MORE_ARG(args))
ERR("cond: syntax error: at least one clause required");
@@ -809,10 +813,14 @@
test = CAR(clause);
exps = CDR(clause);
- if (EQ(test, SYM_ELSE))
+ if (EQ(test, SYM_ELSE)) {
ASSERT_NO_MORE_ARG(args);
- else
- test = EVAL(test, env);
+ } else {
+ if (VALIDP(case_key))
+ test = (NFALSEP(ScmOp_memv(case_key, test))) ? case_key : SCM_FALSE;
+ else
+ test = EVAL(test, env);
+ }
if (NFALSEP(test)) {
/*
@@ -836,7 +844,9 @@
* of the <test> and the value returned by this procedure is
* returned by the cond expression.
*/
- if (EQ(SYM_YIELDS, CAR(exps)) && CONSP(CDR(exps))) {
+ if (EQ(SYM_YIELDS, CAR(exps)) && CONSP(CDR(exps))
+ && !EQ(test, SYM_ELSE))
+ {
if (!NULLP(CDDR(exps)))
ERR_OBJ("bad clause", clause);
proc = EVAL(CADR(exps), env);
@@ -863,43 +873,18 @@
ScmObj ret;
DECLARE_FUNCTION("cond", SyntaxVariadicTailRec0);
- ret = ScmExp_cond_internal(args, eval_state);
+ ret = ScmExp_cond_internal(args, SCM_INVALID, eval_state);
return (VALIDP(ret)) ? ret : SCM_UNDEF;
}
-/* FIXME: argument extraction */
-ScmObj ScmExp_case(ScmObj key, ScmObj args, ScmEvalState *eval_state)
+ScmObj ScmExp_case(ScmObj key, ScmObj clauses, ScmEvalState *eval_state)
{
- ScmObj env = eval_state->env;
- ScmObj clause = SCM_NULL;
- ScmObj data = SCM_NULL;
- ScmObj exps = SCM_NULL;
+ ScmObj ret;
DECLARE_FUNCTION("case", SyntaxVariadicTailRec1);
- /* get key */
- key = EVAL(key, env);
-
- /* looping in each clause */
- for (; !NULLP(args); args = CDR(args)) {
- clause = CAR(args);
- data = CAR(clause);
- exps = CDR(clause);
- if (NULLP(clause) || NULLP(data) || NULLP(exps))
- SigScm_Error("case : syntax error");
-
- /* check "else" symbol */
- if (NULLP(CDR(args)) && !CONSP(data) && NFALSEP(SCM_SYMBOL_VCELL(data)))
- return ScmExp_begin(exps, eval_state);
-
- /* evaluate data and compare to key by eqv? */
- for (; !NULLP(data); data = CDR(data)) {
- if (NFALSEP(ScmOp_eqvp(CAR(data), key))) {
- return ScmExp_begin(exps, eval_state);
- }
- }
- }
-
- return SCM_UNDEF;
+ key = EVAL(key, eval_state->env);
+ ret = ScmExp_cond_internal(clauses, key, eval_state);
+ return (VALIDP(ret)) ? ret : SCM_UNDEF;
}
ScmObj ScmExp_and(ScmObj args, ScmEvalState *eval_state)
Modified: branches/r5rs/sigscheme/operations-srfi34.c
===================================================================
--- branches/r5rs/sigscheme/operations-srfi34.c 2005-12-04 16:36:44 UTC (rev 2365)
+++ branches/r5rs/sigscheme/operations-srfi34.c 2005-12-04 18:56:22 UTC (rev 2366)
@@ -353,7 +353,7 @@
lex_env);
eval_state.env = cond_env;
eval_state.ret_type = SCM_RETTYPE_NEED_EVAL;
- caught = ScmExp_cond_internal(clauses, &eval_state);
+ caught = ScmExp_cond_internal(clauses, SCM_INVALID, &eval_state);
if (VALIDP(caught)) {
if (eval_state.ret_type == SCM_RETTYPE_NEED_EVAL)
Modified: branches/r5rs/sigscheme/operations.c
===================================================================
--- branches/r5rs/sigscheme/operations.c 2005-12-04 16:36:44 UTC (rev 2365)
+++ branches/r5rs/sigscheme/operations.c 2005-12-04 18:56:22 UTC (rev 2366)
@@ -852,6 +852,11 @@
if (EQ(obj, CAR(lst)))
return lst;
+#if SCM_STRICT_ARGCHECK
+ if (!NULLP(lst))
+ ERR_OBJ("invalid list", lst);
+#endif
+
return SCM_FALSE;
}
@@ -863,6 +868,11 @@
if (NFALSEP(ScmOp_eqvp(obj, CAR(lst))))
return lst;
+#if SCM_STRICT_ARGCHECK
+ if (!NULLP(lst))
+ ERR_OBJ("invalid list", lst);
+#endif
+
return SCM_FALSE;
}
@@ -874,6 +884,11 @@
if (NFALSEP(ScmOp_equalp(obj, CAR(lst))))
return lst;
+#if SCM_STRICT_ARGCHECK
+ if (!NULLP(lst))
+ ERR_OBJ("invalid list", lst);
+#endif
+
return SCM_FALSE;
}
Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c 2005-12-04 16:36:44 UTC (rev 2365)
+++ branches/r5rs/sigscheme/sigscheme.c 2005-12-04 18:56:22 UTC (rev 2366)
@@ -153,10 +153,6 @@
Scm_sym_unquote_splicing = Scm_Intern("unquote-splicing");
Scm_sym_else = Scm_Intern("else");
Scm_sym_yields = Scm_Intern("=>");
-#if 1
- /* FIXME: obsolete this. don't set SCM_TRUE and rely on the value */
- SCM_SYMBOL_SET_VCELL(Scm_Intern("else"), SCM_TRUE);
-#endif
features = SCM_NULL;
Modified: branches/r5rs/sigscheme/sigschemeinternal.h
===================================================================
--- branches/r5rs/sigscheme/sigschemeinternal.h 2005-12-04 16:36:44 UTC (rev 2365)
+++ branches/r5rs/sigscheme/sigschemeinternal.h 2005-12-04 18:56:22 UTC (rev 2366)
@@ -456,7 +456,7 @@
ScmObj Scm_eval(ScmObj obj, ScmObj env);
ScmObj Scm_tailcall(ScmObj proc, ScmObj args, ScmEvalState *eval_state);
-ScmObj ScmExp_cond_internal(ScmObj args, ScmEvalState *eval_state);
+ScmObj ScmExp_cond_internal(ScmObj args, ScmObj case_key, ScmEvalState *eval_state);
/* error.c */
void SigScm_InitError(void);
Modified: branches/r5rs/sigscheme/test/test-exp.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-exp.scm 2005-12-04 16:36:44 UTC (rev 2365)
+++ branches/r5rs/sigscheme/test/test-exp.scm 2005-12-04 18:56:22 UTC (rev 2366)
@@ -140,6 +140,11 @@
(lambda ()
(cond
(#t => delay))))
+;; '=>' is not applicable at 'else' clause
+(assert-error "cond invalid form #13"
+ (lambda ()
+ (cond
+ (else => values))))
;; not specified in R5RS, but SigScheme surely returns #<undef>
(if (provided? "sigscheme")
@@ -205,7 +210,179 @@
((> 3 2) 'greater0 'greater1)
(else #f)))
+;;
;; case
+;;
+(assert-error "case invalid form #1"
+ (lambda ()
+ (case)))
+(assert-error "case invalid form #2"
+ (lambda ()
+ (case 'key)))
+(assert-error "case invalid form #3"
+ (lambda ()
+ (case 'key
+ ())))
+(assert-error "case invalid form #4"
+ (lambda ()
+ (case 'key
+ (1))))
+(assert-error "case invalid form #5"
+ (lambda ()
+ (case 'key
+ ((1 . 2)))))
+
+(if (provided? "sigscheme")
+ (begin
+ ;; improper clause does not cause error if not evaled
+ (assert-equal? "case invalid form #6"
+ (undef)
+ (case 'key
+ ((1) . 2)))
+ (assert-equal? "case invalid form #7"
+ (undef)
+ (case 'key
+ ((1) #t . 2)))
+ ;; causes error when evaled
+ (assert-error "case invalid form #6"
+ (lambda ()
+ (case 1
+ ((1) . 2))))
+ (assert-error "case invalid form #7"
+ (lambda ()
+ (case 1
+ ((1) #t . 2))))))
+
+(assert-error "case invalid form #8"
+ (lambda ()
+ (case 'key
+ ()
+ (else #t))))
+;; 'else' followed by another caluse
+(assert-error "case invalid form #9"
+ (lambda ()
+ (case 'key
+ (else #t)
+ (#t))))
+;; not specified in R5RS, but SigScheme should cause error
+(if (provided? "sigscheme")
+ (assert-error "case invalid form #10"
+ (lambda ()
+ (case 'key
+ (else)))))
+(assert-error "case invalid form #11"
+ (lambda ()
+ (case 'key
+ (#t =>))))
+(assert-error "case invalid form #12"
+ (lambda ()
+ (case 'key
+ (#t =>)
+ (else #t))))
+(assert-error "case invalid form #13"
+ (lambda ()
+ (case 'key
+ (else =>))))
+(assert-error "case invalid form #14"
+ (lambda ()
+ (case 'key
+ (else => symbol?))))
+(assert-error "case invalid form #15"
+ (lambda ()
+ (case 'key
+ (else => #t))))
+;; not a procedure
+(assert-error "case invalid form #16"
+ (lambda ()
+ (case 'key
+ (#t => #t))))
+(assert-error "case invalid form #17"
+ (lambda ()
+ (case 'key
+ (#t => #f))))
+;; procedure but argument number mismatch
+(assert-error "case invalid form #18"
+ (lambda ()
+ (case 'key
+ (#t => eq?))))
+;; not a procedure but a syntax
+(assert-error "case invalid form #19"
+ (lambda ()
+ (case 'key
+ (#t => delay))))
+
+;; not specified in R5RS, but SigScheme surely returns #<undef>
+(if (provided? "sigscheme")
+ (assert-equal? "case unspecified behavior #1"
+ (undef)
+ (case 'key
+ ((#f)))))
+(if (provided? "sigscheme")
+ (assert-equal? "case unspecified behavior #2"
+ (undef)
+ (case 'key
+ ((foo) #f)
+ ((bar) #f))))
+
+;; R5RS: If the selected <clause> contains only the <test> and no
+;; <expression>s, then the value of the <test> is returned as the result.
+(assert-equal? "case"
+ 'key
+ (case 'key
+ ((key))))
+(assert-equal? "case"
+ 'key
+ (case 'key
+ ((#f))
+ ((key))))
+(assert-equal? "case"
+ 'key
+ (case 'key
+ ((#f))
+ ((key))
+ ((foo))))
+(assert-equal? "case"
+ 'odd
+ (case 3
+ ((1 3 5) 'odd)
+ ((2 4 6) 'even)))
+(assert-equal? "case"
+ 'unknown
+ (case 0
+ ((1 3 5) 'odd)
+ ((2 4 6) 'even)
+ (else 'unknown)))
+(assert-equal? "case"
+ 'odd
+ (case (+ 1 2)
+ ((1 3 5) 'odd)
+ ((2 4 6) 'even)
+ (else 'unknown)))
+(assert-equal? "case"
+ 3
+ (case 3
+ ((1 3 5))
+ ((2 4 6) 'even)
+ (else 'unknown)))
+(assert-equal? "case"
+ -3
+ (case 3
+ ((1 3 5) => -)
+ ((2 4 6) 'even)
+ (else 'unknown)))
+(assert-equal? "case"
+ 'unknown
+ (case 0
+ ((1 3 5) => -)
+ ((2 4 6) 'even)
+ (else 'unknown)))
+(assert-equal? "case"
+ 'second
+ (case 3
+ ((1 3 5) 'first 'second)
+ ((2 4 6) 'even)
+ (else 'unknown)))
+
(assert-equal? "basic case check1" 'case1 (case 1
((1) 'case1)
((2) 'case2)))
More information about the uim-commit
mailing list