[uim-commit] r2183 - in branches/r5rs/sigscheme: . test
yamaken at freedesktop.org
yamaken at freedesktop.org
Sun Nov 20 07:01:18 PST 2005
Author: yamaken
Date: 2005-11-20 07:01:13 -0800 (Sun, 20 Nov 2005)
New Revision: 2183
Modified:
branches/r5rs/sigscheme/TODO
branches/r5rs/sigscheme/eval.c
branches/r5rs/sigscheme/operations-srfi34.c
branches/r5rs/sigscheme/test/test-srfi34.scm
Log:
* sigscheme/operations-srfi34.c
- (delay): New static function
- (guard_handler_body): Fix multiple values handling
- (guard_body): Simplify with the 'delay'
* sigscheme/eval.c
- (call): Change multiple value checking to SCM_STRICT_ARGCHECK
* sigscheme/test/test-srfi34.scm
- Add set of test for edge cases. All tests are passed
* sigscheme/TODO
- Update
Modified: branches/r5rs/sigscheme/TODO
===================================================================
--- branches/r5rs/sigscheme/TODO 2005-11-20 13:38:33 UTC (rev 2182)
+++ branches/r5rs/sigscheme/TODO 2005-11-20 15:01:13 UTC (rev 2183)
@@ -5,12 +5,9 @@
to find the issues, and make all tests in test-char.scm and test-string.scm
passed
-* Introduce Exception handling (probably should be based on SRFI-34)
- - Reimplement with dynamic-wind, and without direct setjmp/longjmp
- - Rename call/cc with call/ec? ([Anthy-dev 2216])
+* Add tests for proper tail recursion with 'apply' and 'guard' to
+ test-tail-rec.scm
-* Add tests for proper tail recursion with 'apply' to test-tail-rec.scm
-
*
- Provide a string escaping procedure. If a SRFI or another de facto standard
API for such purpose is existing, use it
Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c 2005-11-20 13:38:33 UTC (rev 2182)
+++ branches/r5rs/sigscheme/eval.c 2005-11-20 15:01:13 UTC (rev 2183)
@@ -412,9 +412,9 @@
argbuf[i] = MUST_POP_ARG(args);
if (!suppress_eval)
argbuf[i] = EVAL(argbuf[i], env);
-#if SCM_STRICT_R5RS
+#if SCM_STRICT_ARGCHECK
if (VALUEPACKETP((ScmObj)argbuf[i]))
- SigScm_Error("multiple values are not allowed here");
+ ERR_OBJ("multiple values are not allowed here", (ScmObj)argbuf[i]);
#endif
}
Modified: branches/r5rs/sigscheme/operations-srfi34.c
===================================================================
--- branches/r5rs/sigscheme/operations-srfi34.c 2005-11-20 13:38:33 UTC (rev 2182)
+++ branches/r5rs/sigscheme/operations-srfi34.c 2005-11-20 15:01:13 UTC (rev 2183)
@@ -112,6 +112,7 @@
static ScmObj with_exception_handlers(ScmObj new_handlers, ScmObj thunk);
static ScmObj guard_internal(ScmObj q_guard_k, ScmObj env);
static ScmObj guard_handler(ScmObj q_condition, ScmEvalState *eval_state);
+static ScmObj delay(ScmObj evaled_obj, ScmObj env);
static ScmObj guard_handler_body(ScmObj q_handler_k, ScmObj env);
static ScmObj guard_body(ScmEvalState *eval_state);
@@ -315,11 +316,26 @@
}
/* assumes that ScmExp_delay() returns a closure */
+static ScmObj delay(ScmObj evaled_obj, ScmObj env)
+{
+ ScmObj vals;
+
+ if (VALUEPACKETP(evaled_obj)) {
+ vals = SCM_VALUEPACKET_VALUES(evaled_obj);
+ return ScmExp_delay(LIST_3(syn_apply,
+ proc_values, LIST_2(SYM_QUOTE, vals)),
+ env);
+ } else {
+ return ScmExp_delay(LIST_2(SYM_QUOTE, evaled_obj), env);
+ }
+}
+
+/* assumes that ScmExp_delay() returns a closure */
static ScmObj guard_handler_body(ScmObj q_handler_k, ScmObj env)
{
ScmEvalState eval_state;
ScmObj lex_env, cond_env, condition, cond_catch, guard_k, handler_k;
- ScmObj sym_var, clauses, caught, reraise, ret;
+ ScmObj sym_var, clauses, caught, reraise;
DECLARE_PRIVATE_FUNCTION("guard", SyntaxFixed1);
lex_env = Scm_SymbolValue(sym_lex_env, env);
@@ -342,8 +358,7 @@
if (VALIDP(caught)) {
if (eval_state.ret_type == SCM_RETTYPE_NEED_EVAL)
caught = EVAL(caught, cond_env);
- ret = ScmExp_delay(LIST_2(SYM_QUOTE, caught), cond_env);
- Scm_CallContinuation(guard_k, ret);
+ Scm_CallContinuation(guard_k, delay(caught, cond_env));
} else {
reraise = ScmExp_delay(LIST_2(sym_raise, LIST_2(SYM_QUOTE, condition)),
cond_env);
@@ -353,11 +368,10 @@
return SCM_UNDEF;
}
-/* assumes that ScmExp_delay() returns a closure */
static ScmObj guard_body(ScmEvalState *eval_state)
{
ScmEvalState lex_eval_state;
- ScmObj lex_env, guard_k, body, result, vals, ret;
+ ScmObj lex_env, guard_k, body, result;
DECLARE_PRIVATE_FUNCTION("guard", SyntaxFixedTailRec0);
lex_env = Scm_SymbolValue(sym_lex_env, eval_state->env);
@@ -371,15 +385,7 @@
result = EVAL(result, lex_env);
eval_state->ret_type = SCM_RETTYPE_AS_IS;
- if (VALUEPACKETP(result)) {
- vals = SCM_VALUEPACKET_VALUES(result);
- ret = ScmExp_delay(LIST_3(syn_apply,
- proc_values, LIST_2(SYM_QUOTE, vals)),
- lex_env);
- } else {
- ret = ScmExp_delay(LIST_2(SYM_QUOTE, result), lex_env);
- }
- Scm_CallContinuation(guard_k, ret);
+ Scm_CallContinuation(guard_k, delay(result, lex_env));
/* NOTREACHED */
return SCM_UNDEF;
}
Modified: branches/r5rs/sigscheme/test/test-srfi34.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-srfi34.scm 2005-11-20 13:38:33 UTC (rev 2182)
+++ branches/r5rs/sigscheme/test/test-srfi34.scm 2005-11-20 15:01:13 UTC (rev 2183)
@@ -37,8 +37,10 @@
(use srfi-34))
(else #t))
-;; All tests in this file are passed against r2143 (new repository)
+(use srfi-8)
+;; All tests in this file are passed against r2181 (new repository)
+
;;(set! *test-track-progress* #t)
(define my-assert-error
@@ -275,6 +277,204 @@
(#t => delay))
(raise 'obj))))
+(assert-false "guard namespace taintlessness #1"
+ (guard (var
+ (#f var))
+ (symbol-bound? 'lex-env)))
+
+(assert-false "guard namespace taintlessness #2"
+ (guard (var
+ (#f var))
+ (symbol-bound? 'cond-catch)))
+
+(assert-false "guard namespace taintlessness #3"
+ (guard (var
+ (#f var))
+ (symbol-bound? 'body)))
+
+(assert-false "guard namespace taintlessness #4"
+ (guard (var
+ (#f var))
+ (symbol-bound? 'condition)))
+
+(assert-false "guard namespace taintlessness #5"
+ (guard (var
+ (#f var))
+ (symbol-bound? 'guard-k)))
+
+(assert-false "guard namespace taintlessness #6"
+ (guard (var
+ (#f var))
+ (symbol-bound? 'handler-k)))
+
+(assert-false "guard namespace taintlessness #7"
+ (guard (var
+ (#f var))
+ (symbol-bound? 'var)))
+
+(assert-false "guard handler namespace taintlessness #1"
+ (guard (var
+ (else
+ (symbol-bound? 'lex-env)))
+ (raise 'err)))
+
+(assert-false "guard handler namespace taintlessness #2"
+ (guard (var
+ (else
+ (symbol-bound? 'cond-catch)))
+ (raise 'err)))
+
+(assert-false "guard handler namespace taintlessness #3"
+ (guard (var
+ (else
+ (symbol-bound? 'body)))
+ (raise 'err)))
+
+(assert-false "guard handler namespace taintlessness #4"
+ (guard (var
+ (else
+ (symbol-bound? 'condition)))
+ (raise 'err)))
+
+(assert-false "guard handler namespace taintlessness #5"
+ (guard (var
+ (else
+ (symbol-bound? 'guard-k)))
+ (raise 'err)))
+
+(assert-false "guard handler namespace taintlessness #6"
+ (guard (var
+ (else
+ (symbol-bound? 'handler-k)))
+ (raise 'err)))
+
+(assert-equal? "guard handler condition variable #1"
+ 'err
+ (guard (var
+ (else var))
+ (raise 'err)))
+
+;; the variable can be modified
+(assert-equal? "guard handler condition variable #2"
+ 'ERR
+ (guard (var
+ (#t
+ (set! var 'ERR)
+ var))
+ (raise 'err)))
+
+;; the variable does not affect outer environment
+(define var 'global-var)
+(assert-equal? "guard handler condition variable #3"
+ 'outer
+ (let ((var 'outer))
+ (guard (var
+ (#t
+ (set! var 'ERR)))
+ (raise 'err))
+ var))
+
+;; the variable does not affect global one
+(define var 'global-var)
+(assert-equal? "guard handler condition variable #4"
+ 'global-var
+ (begin
+ (guard (var
+ (#t
+ (set! var 'ERR)))
+ (raise 'err))
+ var))
+
+(assert-equal? "guard evaluation count exactness #1"
+ 7
+ (guard (var
+ (else var))
+ (+ 3 4)))
+
+(assert-equal? "guard evaluation count exactness #2"
+ 7
+ (guard (var
+ (else var))
+ (raise (+ 3 4))))
+
+(assert-equal? "guard evaluation count exactness #3"
+ 7
+ (guard (var
+ (else (+ 3 4)))
+ (raise 'err)))
+
+(assert-equal? "guard evaluation count exactness #4"
+ 7
+ (let ((a 3)
+ (b 4))
+ (guard (var
+ (else var))
+ (+ a b))))
+
+(assert-equal? "guard evaluation count exactness #5"
+ 7
+ (let ((a 3)
+ (b 4))
+ (guard (var
+ (else var))
+ (raise (+ a b)))))
+
+(assert-equal? "guard evaluation count exactness #6"
+ 7
+ (let ((a 3)
+ (b 4))
+ (guard (var
+ (else (+ a b)))
+ (raise 'err))))
+
+(assert-equal? "guard evaluation count exactness #7"
+ (list + 3 4) ;; not 7
+ (let ((a 3)
+ (b 4))
+ (guard (var
+ (else var))
+ (list + a b))))
+
+(assert-equal? "guard evaluation count exactness #8"
+ (list + 3 4) ;; not 7
+ (let ((a 3)
+ (b 4))
+ (guard (var
+ (else var))
+ (raise (list + a b)))))
+
+(assert-equal? "guard evaluation count exactness #9"
+ (list + 3 4) ;; not 7
+ (let ((a 3)
+ (b 4))
+ (guard (var
+ (else (list + a b)))
+ (raise 'err))))
+
+(assert-equal? "guard with multiple values #1"
+ '(1 2)
+ (receive vals
+ (guard (var
+ (else var))
+ (values 1 2))
+ vals))
+
+(assert-equal? "guard with multiple values #2"
+ '(1 2)
+ (receive vals
+ (guard (var
+ (else (values 1 2)))
+ (raise 'err))
+ vals))
+
+(if (provided? "sigscheme")
+ (assert-error "guard with multiple values #3"
+ (lambda ()
+ (guard (var
+ ((not (%%error-object? var))
+ var))
+ (raise (values 1 2))))))
+
(assert-equal? "guard handler reraise #1"
'reraised
(guard (var
More information about the uim-commit
mailing list