[uim-commit] r1754 - in branches/r5rs/sigscheme: . test
kzk at freedesktop.org
kzk at freedesktop.org
Sun Oct 2 19:56:08 PDT 2005
Author: kzk
Date: 2005-10-02 19:56:06 -0700 (Sun, 02 Oct 2005)
New Revision: 1754
Added:
branches/r5rs/sigscheme/test/test-srfi34.scm
Modified:
branches/r5rs/sigscheme/operations-srfi34.c
branches/r5rs/sigscheme/sigscheme.c
branches/r5rs/sigscheme/sigscheme.h
Log:
* revise SRFI-34 procedures
* sigscheme/sigscheme.c
- (SigScm_initialize_internal): export "guard" as SyntaxVariadic1
* sigscheme/sigscheme.h
- (ScmOp_dynamic_wind): add missing declaration
- (ScmExp_SRFI34_guard): renamed from ScmOp_SRFI34_guard
* sigscheme/operations-srfi34.c
- (ScmExp_SRFI34_guard): renamed from ScmOp_SRFI34_guard.
insert DECLARE_FUNCTION and ASSERT_*P
- (guard_handle_clauses): change args
- (CONTINUATION_JMPENV, CONTINUATION_SET_JMPENV): new macro
- (ScmOp_SRFI34_with_exception_handler): insert DECLARE_FUNCTION
and ASSERT_*P
- (ScmOp_SRFI34_raise): insert DECLARE_FUNCTION
* sigscheme/test/test-srfi34.scm
- new file
Modified: branches/r5rs/sigscheme/operations-srfi34.c
===================================================================
--- branches/r5rs/sigscheme/operations-srfi34.c 2005-10-03 02:19:03 UTC (rev 1753)
+++ branches/r5rs/sigscheme/operations-srfi34.c 2005-10-03 02:56:06 UTC (rev 1754)
@@ -64,6 +64,9 @@
#define POP_EXCEPTION_CONTINUATION() \
(scm_exception_continuations = CDR(scm_exception_continuations))
+#define CONTINUATION_JMPENV SCM_CONTINUATION_OPAQUE0
+#define CONTINUATION_SET_JMPENV SCM_CONTINUATION_SET_OPAQUE0
+
/*=======================================
Variable Declarations
=======================================*/
@@ -75,20 +78,23 @@
/*=======================================
File Local Function Declarations
=======================================*/
-static ScmObj guard_handle_clauses(ScmObj clauses, ScmEvalState *eval_state);
+static ScmObj guard_handle_clauses(ScmObj clauses, ScmObj env);
/*=======================================
Function Implementations
=======================================*/
-/* FIXME:
- * - Insert new DECLARE_FUNCTION and ASSERT_*P macros
- */
ScmObj ScmOp_SRFI34_with_exception_handler(ScmObj handler, ScmObj thunk)
{
+ jmp_buf jmpenv;
ScmObj ret = SCM_FALSE;
ScmObj cont = Scm_NewContinuation();
+ DECLARE_FUNCTION("with-exception-handler", ProcedureFixed);
- if (setjmp(SCM_CONTINUATION_JMPENV(cont))) {
+ ASSERT_PROCEDUREP(handler);
+ ASSERT_PROCEDUREP(thunk);
+
+ CONTINUATION_SET_JMPENV(cont, &jmpenv);
+ if (setjmp(CONTINUATION_JMPENV(cont))) {
ret = Scm_call(CURRENT_EXCEPTION_HANDLER(), LIST_1(exception_thrown_obj));
POP_EXCEPTION_CONTINUATION();
POP_EXCEPTION_HANDLER();
@@ -106,48 +112,48 @@
}
/* FIXME:
- * - Change type to ProcedureVariadicTailRec1
- * - Simplify with new DECLARE_FUNCTION and POP_ARG macros
- * - Insert new ASSERT_*P macros
+ * - Simplify with POP_ARG macros
*/
-ScmObj ScmOp_SRFI34_guard(ScmObj args, ScmEvalState *eval_state)
+ScmObj ScmExp_SRFI34_guard(ScmObj var_and_clauses, ScmObj body, ScmObj env)
{
/* (guard (var clauses) body) */
- ScmObj env = eval_state->env;
- ScmObj var = CAAR(args);
- ScmObj clauses = CDAR(args);
- ScmObj body = CDR(args);
- ScmObj ret = SCM_FALSE;
+ jmp_buf jmpenv;
+ ScmObj var = CAR(var_and_clauses);
+ ScmObj clauses = CDR(var_and_clauses);
+ ScmObj expr = SCM_FALSE;
ScmObj cont = Scm_NewContinuation();
+ DECLARE_FUNCTION("guard", SyntaxVariadic1);
+ ASSERT_SYMBOLP(var);
+
/* check if return from "raise" */
- if (setjmp(SCM_CONTINUATION_JMPENV(cont))) {
+ CONTINUATION_SET_JMPENV(cont, &jmpenv);
+ if (setjmp(CONTINUATION_JMPENV(cont))) {
POP_EXCEPTION_CONTINUATION();
-
- eval_state->env = Scm_ExtendEnvironment(LIST_1(var), LIST_1(exception_thrown_obj), env);
- eval_state->ret_type = SCM_RETTYPE_AS_IS;
-
- return guard_handle_clauses(clauses, eval_state);
+ env = Scm_ExtendEnvironment(LIST_1(var), LIST_1(exception_thrown_obj), env);
+ return guard_handle_clauses(clauses, env);
}
PUSH_EXCEPTION_CONTINUATION(cont);
- ret = EVAL(ScmExp_begin(body, eval_state), env);
+ while (expr = POP_ARG(body), !NO_MORE_ARG(body))
+ EVAL(expr, env);
+ expr = EVAL(expr, env);
POP_EXCEPTION_CONTINUATION();
- return ret;
+ return expr;
}
/* FIXME:
* - Simplify with ScmExp_cond()
*/
-static ScmObj guard_handle_clauses(ScmObj clauses, ScmEvalState *eval_state)
+static ScmObj guard_handle_clauses(ScmObj clauses, ScmObj env)
{
- ScmObj env = eval_state->env;
ScmObj thrown = exception_thrown_obj;
ScmObj clause = SCM_FALSE;
ScmObj test = SCM_FALSE;
ScmObj exps = SCM_FALSE;
ScmObj proc = SCM_FALSE;
+ ScmObj ret = SCM_FALSE;
/* make sweepable */
exception_thrown_obj = SCM_FALSE;
@@ -157,13 +163,13 @@
clause = CAR(clauses);
if (!CONSP(clause))
SigScm_ErrorObj("guard : bad clause: ", clause);
-
+
test = CAR(clause);
exps = CDR(clause);
-
+
/* evaluate test */
test = EVAL(test, env);
-
+
if (NFALSEP(test)) {
/*
* if the selected <clause> contains only the <test> and no <expression>s,
@@ -171,7 +177,7 @@
*/
if (NULLP(exps))
return test;
-
+
/*
* If the selected <clause> uses the => alternate form, then the <expression>
* is evaluated. Its value must be a procedure that accepts one argument;
@@ -183,30 +189,32 @@
proc = EVAL(CADR(exps), env);
if (FALSEP(ScmOp_procedurep(proc)))
SigScm_ErrorObj("guard : the value of exp after => must be the procedure but got ", proc);
-
+
return Scm_call(proc, LIST_1(test));
}
-
- return EVAL(ScmExp_begin(exps, eval_state), env);
+
+ for (; !NULLP(exps); exps = CDR(exps))
+ ret = EVAL(CAR(exps), env);
+
+ return ret;
}
}
-
+
/* "reraise" exception */
if (NULLP(CURRENT_EXCEPTION_CONTINUATION()))
SigScm_Error("guard : cannot reraise exception");
ScmOp_SRFI34_raise(thrown);
/* never reaches here */
- return SCM_UNDEF;
+ return SCM_UNDEF;
}
-/* FIXME:
- * - Insert DECLARE_FUNCTION
- */
ScmObj ScmOp_SRFI34_raise(ScmObj obj)
{
+ DECLARE_FUNCTION("raise", ProcedureFixed1);
+
exception_thrown_obj = obj;
- longjmp(SCM_CONTINUATION_JMPENV(CURRENT_EXCEPTION_CONTINUATION()), 1);
+ longjmp(CONTINUATION_JMPENV(CURRENT_EXCEPTION_CONTINUATION()), 1);
/* never reaches here */
return SCM_UNDEF;
Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c 2005-10-03 02:19:03 UTC (rev 1753)
+++ branches/r5rs/sigscheme/sigscheme.c 2005-10-03 02:56:06 UTC (rev 1754)
@@ -384,7 +384,7 @@
SRFI-34 Procedure
=======================================================================*/
Scm_RegisterProcedureFixed2("with-exception-handler", ScmOp_SRFI34_with_exception_handler);
- Scm_RegisterSyntaxVariadicTailRec0("guard" , ScmOp_SRFI34_guard);
+ Scm_RegisterSyntaxVariadic1("guard" , ScmExp_SRFI34_guard);
Scm_RegisterProcedureFixed1("raise" , ScmOp_SRFI34_raise);
scm_exception_handlers = SCM_FALSE;
scm_exception_continuations = SCM_FALSE;
Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h 2005-10-03 02:19:03 UTC (rev 1753)
+++ branches/r5rs/sigscheme/sigscheme.h 2005-10-03 02:56:06 UTC (rev 1754)
@@ -509,6 +509,8 @@
ScmObj ScmOp_call_with_current_continuation(ScmObj proc, ScmEvalState *eval_state);
ScmObj ScmOp_values(ScmObj args);
ScmObj ScmOp_call_with_values(ScmObj producer, ScmObj consumer, ScmEvalState *eval_state);
+ScmObj ScmOp_dynamic_wind(ScmObj before, ScmObj thunk, ScmObj after,
+ ScmEvalState *eval_state);
/* io.c */
void SigScm_set_lib_path(const char *path);
@@ -633,7 +635,7 @@
#if SCM_USE_SRFI34
/* operations-srfi34.c */
ScmObj ScmOp_SRFI34_with_exception_handler(ScmObj handler, ScmObj thunk);
-ScmObj ScmOp_SRFI34_guard(ScmObj args, ScmEvalState *eval_state);
+ScmObj ScmExp_SRFI34_guard(ScmObj var_and_clauses, ScmObj body, ScmObj env);
ScmObj ScmOp_SRFI34_raise(ScmObj obj);
#endif
#if SCM_USE_SRFI38
Added: branches/r5rs/sigscheme/test/test-srfi34.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-srfi34.scm 2005-10-03 02:19:03 UTC (rev 1753)
+++ branches/r5rs/sigscheme/test/test-srfi34.scm 2005-10-03 02:56:06 UTC (rev 1754)
@@ -0,0 +1,123 @@
+(load "./test/unittest.scm")
+
+; with-exception-handler
+(with-exception-handler
+ (lambda (x)
+ (assert-equal? "with-exception-handler test #1" 'an-error x))
+ (lambda ()
+ (+ 1 (raise 'an-error))))
+
+(assert-equal? "with-exception-handler test #2" 6
+ (with-exception-handler
+ (lambda (x)
+ 'not-reaches-here)
+ (lambda ()
+ (+ 1 2 3))))
+
+(assert-equal? "with-exception-handler test #2" 'success
+ (with-exception-handler
+ (lambda (x)
+ 'not-reaches-here)
+ (lambda ()
+ 'success)))
+
+
+; guard
+(assert-equal? "guard test #1" 'exception
+ (guard (condition
+ (else
+ (assert-equal? "guard test #2" 'an-error condition)
+ 'exception))
+ (+ 1 (raise 'an-error))))
+
+(assert-equal? "guard test #3" 3
+ (guard (condition
+ (else
+ 'exception))
+ (+ 1 2)))
+
+(assert-equal? "guard test #4" 'success
+ (guard (condition
+ (else
+ 'exception))
+ 'success))
+
+(assert-equal? "guard test #5" 'exception
+ (guard (condition
+ (else
+ 'exception))
+ (+ 1 (raise 'error))))
+
+(assert-equal? "guard test #6" 42
+ (guard (condition
+ ((assq 'a condition) => cdr)
+ ((assq 'b condition))
+ (else
+ (display condition)
+ (newline)))
+ (raise (list (cons 'a 42)))))
+
+(assert-equal? "guard test #7" '(b . 23)
+ (guard (condition
+ ((assq 'a condition) => cdr)
+ ((assq 'b condition))
+ (else
+ (display condition)
+ (newline)))
+ (raise (list (cons 'b 23)))))
+
+
+; mixed use of with-exception-handler and guard
+(assert-equal? "mixed exception handling test #1" 'guard-ret
+ (with-exception-handler (lambda (x)
+ (k 'with-exception-ret))
+ (lambda ()
+ (guard (condition
+ (else
+ 'guard-ret))
+ (raise 1)))))
+
+(assert-equal? "mixed exception handling test #1" 'with-exception-ret
+ (with-exception-handler (lambda (x)
+ 'with-exception-ret)
+ (lambda ()
+ (guard (condition
+ ((negative? condition)
+ 'guard-ret))
+ (raise 1)))))
+
+;(assert-equal? "mixed exception handling test #1" 'positive
+; (call-with-current-continuation
+; (lambda (k)
+; (with-exception-handler (lambda (x)
+; (k 'zero))
+; (lambda ()
+; (guard (condition
+; ((positive? condition) 'positive)
+; ((negative? condition) 'negative))
+; (raise 1)))))))
+;
+;(assert-equal? "mixed exception handling test #2" 'negative
+; (call-with-current-continuation
+; (lambda (k)
+; (with-exception-handler (lambda (x)
+; (k 'zero))
+; (lambda ()
+; (guard (condition
+; ((positive? condition) 'positive)
+; ((negative? condition) 'negative))
+; (raise -1)))))))
+
+;(assert-equal? "mixed exception handling test #3" 'zero
+; (call-with-current-continuation
+; (lambda (k)
+; (with-exception-handler (lambda (x)
+; (k 'zero))
+; (lambda ()
+; (guard (condition
+; ((positive? condition) 'positive)
+; ((negative? condition) 'negative))
+; (raise 0)))))))
+
+
+(total-report)
More information about the uim-commit
mailing list