diff --git a/docs/lang.rst b/docs/lang.rst index 3c3f463b..9ff59b5c 100644 --- a/docs/lang.rst +++ b/docs/lang.rst @@ -47,7 +47,7 @@ section status comments 4.2.4 Iteration yes 4.2.5 Delayed evaluation N/A 4.2.6 Dynamic bindings yes -4.2.7 Exception handling no ``guard`` syntax. +4.2.7 Exception handling yes ``guard`` syntax. 4.2.8 Quasiquotation yes can be safely nested. TODO: multiple argument for unquote 4.2.9 Case-lambda N/A 4.3.1 Bindings constructs for syntactic keywords incomplete [#]_ diff --git a/include/picrin.h b/include/picrin.h index fd3b4ca2..b4036cb5 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -57,18 +57,11 @@ typedef struct { struct pic_env *up; } pic_callinfo; -typedef struct pic_block { - struct pic_block *prev; - int depth; - struct pic_proc *in, *out; - unsigned refcnt; -} pic_block; - typedef struct { int argc; char **argv, **envp; - pic_block *blk; + struct pic_block *blk; pic_value *sp; pic_value *stbase, *stend; @@ -109,6 +102,7 @@ typedef struct { jmp_buf *jmp; struct pic_error *err; struct pic_jmpbuf *try_jmps; + size_t try_jmp_size, try_jmp_idx; struct pic_heap *heap; struct pic_object **arena; diff --git a/include/picrin/cont.h b/include/picrin/cont.h index 496454fd..0a0da9f1 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -9,11 +9,18 @@ extern "C" { #endif +struct pic_block { + PIC_OBJECT_HEADER + struct pic_block *prev; + int depth; + struct pic_proc *in, *out; +}; + struct pic_cont { PIC_OBJECT_HEADER jmp_buf jmp; - pic_block *blk; + struct pic_block *blk; char *stk_pos, *stk_ptr; ptrdiff_t stk_len; @@ -30,37 +37,12 @@ struct pic_cont { size_t arena_size; int arena_idx; + struct pic_jmpbuf *try_jmps; + size_t try_jmp_idx, try_jmp_size; + pic_value results; }; -#define PIC_BLK_INCREF(pic,blk) do { \ - (blk)->refcnt++; \ - } while (0) - -#define PIC_BLK_DECREF(pic,blk) do { \ - pic_block *_a = (blk), *_b; \ - while (_a) { \ - if (! --_a->refcnt) { \ - _b = _a->prev; \ - pic_free((pic), _a); \ - _a = _b; \ - } else { \ - break; \ - } \ - } \ - } while (0) - -#define PIC_BLK_EXIT(pic) do { \ - pic_block *_a; \ - while (pic->blk) { \ - if (pic->blk->out) \ - pic_apply0(pic, pic->blk->out); \ - _a = pic->blk->prev; \ - PIC_BLK_DECREF(pic, pic->blk); \ - pic->blk = _a; \ - } \ - } while (0) - pic_value pic_values0(pic_state *); pic_value pic_values1(pic_state *, pic_value); pic_value pic_values2(pic_state *, pic_value, pic_value); diff --git a/include/picrin/error.h b/include/picrin/error.h index 75361c1a..bea590e2 100644 --- a/include/picrin/error.h +++ b/include/picrin/error.h @@ -11,17 +11,19 @@ extern "C" { struct pic_jmpbuf { jmp_buf here; - pic_callinfo *ci; - pic_value *sp; + struct pic_proc *handler; + ptrdiff_t ci_offset; + ptrdiff_t sp_offset; pic_code *ip; jmp_buf *prev_jmp; - struct pic_jmpbuf *prev; }; /* do not return from try block! */ #define pic_try \ - pic_push_try(pic); \ + pic_try_with_handler(NULL) +#define pic_try_with_handler(handler) \ + pic_push_try(pic, handler); \ if (setjmp(*pic->jmp) == 0) \ do #define pic_catch \ @@ -29,7 +31,7 @@ struct pic_jmpbuf { else \ if (pic_pop_try(pic), 1) -void pic_push_try(pic_state *); +void pic_push_try(pic_state *, struct pic_proc *); void pic_pop_try(pic_state *); noreturn void pic_throw(pic_state *, short, const char *, pic_value); diff --git a/include/picrin/value.h b/include/picrin/value.h index 283bac28..023902a3 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -115,7 +115,8 @@ enum pic_tt { PIC_TT_VAR, PIC_TT_IREP, PIC_TT_DATA, - PIC_TT_DICT + PIC_TT_DICT, + PIC_TT_BLK, }; #define PIC_OBJECT_HEADER \ @@ -268,6 +269,8 @@ pic_type_repr(enum pic_tt tt) return "data"; case PIC_TT_DICT: return "dict"; + case PIC_TT_BLK: + return "block"; } UNREACHABLE(); } diff --git a/piclib/prelude.scm b/piclib/prelude.scm index 5a5008c0..feef5c0c 100644 --- a/piclib/prelude.scm +++ b/piclib/prelude.scm @@ -1014,3 +1014,62 @@ (import (picrin syntax-rules)) (export syntax-rules) +(define-syntax guard-aux + (syntax-rules (else =>) + ((guard-aux reraise (else result1 result2 ...)) + (begin result1 result2 ...)) + ((guard-aux reraise (test => result)) + (let ((temp test)) + (if temp + (result temp) + reraise))) + ((guard-aux reraise (test => result) + clause1 clause2 ...) + (let ((temp test)) + (if temp + (result temp) + (guard-aux reraise clause1 clause2 ...)))) + ((guard-aux reraise (test)) + (or test reraise)) + ((guard-aux reraise (test) clause1 clause2 ...) + (let ((temp test)) + (if temp + temp + (guard-aux reraise clause1 clause2 ...)))) + ((guard-aux reraise (test result1 result2 ...)) + (if test + (begin result1 result2 ...) + reraise)) + ((guard-aux reraise + (test result1 result2 ...) + clause1 clause2 ...) + (if test + (begin result1 result2 ...) + (guard-aux reraise clause1 clause2 ...))))) + +(define-syntax guard + (syntax-rules () + ((guard (var clause ...) e1 e2 ...) + ((call/cc + (lambda (guard-k) + (with-exception-handler + (lambda (condition) + ((call/cc + (lambda (handler-k) + (guard-k + (lambda () + (let ((var condition)) + (guard-aux + (handler-k + (lambda () + (raise-continuable condition))) + clause ...)))))))) + (lambda () + (call-with-values + (lambda () e1 e2 ...) + (lambda args + (guard-k + (lambda () + (apply values args))))))))))))) + +(export guard) diff --git a/src/codegen.c b/src/codegen.c index a5c35eb8..8f8d9aed 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -831,6 +831,7 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos) case PIC_TT_IREP: case PIC_TT_DATA: case PIC_TT_DICT: + case PIC_TT_BLK: pic_errorf(pic, "invalid expression given: ~s", obj); } UNREACHABLE(); diff --git a/src/cont.c b/src/cont.c index 11b5a3f6..30d26568 100644 --- a/src/cont.c +++ b/src/cont.c @@ -10,6 +10,7 @@ #include "picrin/proc.h" #include "picrin/cont.h" #include "picrin/pair.h" +#include "picrin/error.h" pic_value pic_values0(pic_state *pic) @@ -118,7 +119,6 @@ save_cont(pic_state *pic, struct pic_cont **c) cont = *c = (struct pic_cont *)pic_obj_alloc(pic, sizeof(struct pic_cont), PIC_TT_CONT); cont->blk = pic->blk; - PIC_BLK_INCREF(pic, cont->blk); cont->stk_len = native_stack_length(pic, &pos); cont->stk_pos = pos; @@ -143,6 +143,11 @@ save_cont(pic_state *pic, struct pic_cont **c) cont->arena = (struct pic_object **)pic_alloc(pic, sizeof(struct pic_object *) * pic->arena_size); memcpy(cont->arena, pic->arena, sizeof(struct pic_object *) * pic->arena_size); + cont->try_jmp_idx = pic->try_jmp_idx; + cont->try_jmp_size = pic->try_jmp_size; + cont->try_jmps = pic_alloc(pic, sizeof(struct pic_jmpbuf) * pic->try_jmp_size); + memcpy(cont->try_jmps, pic->try_jmps, sizeof(struct pic_jmpbuf) * pic->try_jmp_size); + cont->results = pic_undef_value(); } @@ -158,8 +163,12 @@ native_stack_extend(pic_state *pic, struct pic_cont *cont) noreturn static void restore_cont(pic_state *pic, struct pic_cont *cont) { + void pic_vm_tear_off(pic_state *); char v; struct pic_cont *tmp = cont; + struct pic_block *blk; + + pic_vm_tear_off(pic); /* tear off */ if (&v < pic->native_stack_start) { if (&v > cont->stk_pos) native_stack_extend(pic, cont); @@ -168,8 +177,7 @@ restore_cont(pic_state *pic, struct pic_cont *cont) if (&v > cont->stk_pos + cont->stk_len) native_stack_extend(pic, cont); } - PIC_BLK_DECREF(pic, pic->blk); - PIC_BLK_INCREF(pic, cont->blk); + blk = pic->blk; pic->blk = cont->blk; pic->stbase = (pic_value *)pic_realloc(pic, pic->stbase, sizeof(pic_value) * cont->st_len); @@ -189,13 +197,18 @@ restore_cont(pic_state *pic, struct pic_cont *cont) pic->arena_size = cont->arena_size; pic->arena_idx = cont->arena_idx; + pic->try_jmps = pic_realloc(pic, pic->try_jmps, sizeof(struct pic_jmpbuf) * cont->try_jmp_size); + memcpy(pic->try_jmps, cont->try_jmps, sizeof(struct pic_jmpbuf) * cont->try_jmp_size); + pic->try_jmp_size = cont->try_jmp_size; + pic->try_jmp_idx = cont->try_jmp_idx; + memcpy(cont->stk_pos, cont->stk_ptr, cont->stk_len); longjmp(tmp->jmp, 1); } static void -walk_to_block(pic_state *pic, pic_block *here, pic_block *there) +walk_to_block(pic_state *pic, struct pic_block *here, struct pic_block *there) { if (here == there) return; @@ -213,7 +226,7 @@ walk_to_block(pic_state *pic, pic_block *here, pic_block *there) static pic_value pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, struct pic_proc *out) { - pic_block *here; + struct pic_block *here; pic_value val; if (in != NULL) { @@ -221,17 +234,14 @@ pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, st } here = pic->blk; - pic->blk = (pic_block *)pic_alloc(pic, sizeof(pic_block)); + pic->blk = (struct pic_block *)pic_obj_alloc(pic, sizeof(struct pic_block), PIC_TT_BLK); pic->blk->prev = here; pic->blk->depth = here->depth + 1; pic->blk->in = in; pic->blk->out = out; - pic->blk->refcnt = 1; - PIC_BLK_INCREF(pic, here); val = pic_apply0(pic, thunk); - PIC_BLK_DECREF(pic, pic->blk); pic->blk = here; if (out != NULL) { diff --git a/src/error.c b/src/error.c index 21f6d487..971a0b47 100644 --- a/src/error.c +++ b/src/error.c @@ -34,39 +34,41 @@ pic_warnf(pic_state *pic, const char *fmt, ...) } void -pic_push_try(pic_state *pic) +pic_push_try(pic_state *pic, struct pic_proc *handler) { struct pic_jmpbuf *try_jmp; - try_jmp = pic_alloc(pic, sizeof(struct pic_jmpbuf)); + if (pic->try_jmp_idx >= pic->try_jmp_size) { + pic->try_jmp_size *= 2; + pic->try_jmps = pic_realloc(pic, pic->try_jmps, sizeof(struct pic_jmpbuf) * pic->try_jmp_size); + } - try_jmp->ci = pic->ci; - try_jmp->sp = pic->sp; + try_jmp = pic->try_jmps + pic->try_jmp_idx++; + + try_jmp->handler = handler; + + try_jmp->ci_offset = pic->ci - pic->cibase; + try_jmp->sp_offset = pic->sp - pic->stbase; try_jmp->ip = pic->ip; try_jmp->prev_jmp = pic->jmp; pic->jmp = &try_jmp->here; - - try_jmp->prev = pic->try_jmps; - pic->try_jmps = try_jmp; } void pic_pop_try(pic_state *pic) { - struct pic_jmpbuf *prev; + struct pic_jmpbuf *try_jmp; - assert(pic->jmp == &pic->try_jmps->here); + try_jmp = pic->try_jmps + --pic->try_jmp_idx; - pic->ci = pic->try_jmps->ci; - pic->sp = pic->try_jmps->sp; - pic->ip = pic->try_jmps->ip; + assert(pic->jmp == &try_jmp->here); - pic->jmp = pic->try_jmps->prev_jmp; + pic->ci = try_jmp->ci_offset + pic->cibase; + pic->sp = try_jmp->sp_offset + pic->stbase; + pic->ip = try_jmp->ip; - prev = pic->try_jmps->prev; - pic_free(pic, pic->try_jmps); - pic->try_jmps = prev; + pic->jmp = try_jmp->prev_jmp; } static struct pic_error * @@ -89,11 +91,16 @@ error_new(pic_state *pic, short type, pic_str *msg, pic_value irrs) noreturn void pic_throw_error(pic_state *pic, struct pic_error *e) { + void pic_vm_tear_off(pic_state *); + + pic_vm_tear_off(pic); /* tear off */ + pic->err = e; if (! pic->jmp) { puts(pic_errmsg(pic)); abort(); } + longjmp(*pic->jmp, 1); } @@ -140,14 +147,20 @@ pic_error_with_exception_handler(pic_state *pic) pic_get_args(pic, "ll", &handler, &thunk); - pic_try { + pic_try_with_handler(handler) { v = pic_apply0(pic, thunk); } pic_catch { struct pic_error *e = pic->err; pic->err = NULL; - v = pic_apply1(pic, handler, pic_obj_value(e)); + + if (e->type == PIC_ERROR_RAISED) { + v = pic_list_ref(pic, e->irrs, 0); + } else { + v = pic_obj_value(e); + } + v = pic_apply1(pic, handler, v); pic_errorf(pic, "error handler returned ~s, by error ~s", v, pic_obj_value(e)); } return v; @@ -163,6 +176,27 @@ pic_error_raise(pic_state *pic) pic_throw(pic, PIC_ERROR_RAISED, "object is raised", pic_list1(pic, v)); } +static pic_value +pic_error_raise_continuable(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic->try_jmp_idx == 0) { + pic_errorf(pic, "no exception handler registered"); + } + if (pic->try_jmps[pic->try_jmp_idx - 1].handler == NULL) { + pic_errorf(pic, "uncontinuable exception handler is on top"); + } + else { + pic->try_jmp_idx--; + v = pic_apply1(pic, pic->try_jmps[pic->try_jmp_idx].handler, v); + ++pic->try_jmp_idx; + } + return v; +} + noreturn static pic_value pic_error_error(pic_state *pic) { @@ -242,6 +276,7 @@ pic_init_error(pic_state *pic) { pic_defun(pic, "with-exception-handler", pic_error_with_exception_handler); pic_defun(pic, "raise", pic_error_raise); + pic_defun(pic, "raise-continuable", pic_error_raise_continuable); pic_defun(pic, "error", pic_error_error); pic_defun(pic, "error-object?", pic_error_error_object_p); pic_defun(pic, "error-object-message", pic_error_error_object_message); diff --git a/src/gc.c b/src/gc.c index 3d28aa96..bd907524 100644 --- a/src/gc.c +++ b/src/gc.c @@ -322,18 +322,6 @@ gc_free(pic_state *pic, union header *bp) static void gc_mark(pic_state *, pic_value); static void gc_mark_object(pic_state *pic, struct pic_object *obj); -static void -gc_mark_block(pic_state *pic, pic_block *blk) -{ - while (blk) { - if (blk->in) - gc_mark_object(pic, (struct pic_object *)blk->in); - if (blk->out) - gc_mark_object(pic, (struct pic_object *)blk->out); - blk = blk->prev; - } -} - static bool gc_is_marked(union header *p) { @@ -415,10 +403,10 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) struct pic_cont *cont = (struct pic_cont *)obj; pic_value *stack; pic_callinfo *ci; - int i; + size_t i; /* block */ - gc_mark_block(pic, cont->blk); + gc_mark_object(pic, (struct pic_object *)cont->blk); /* stack */ for (stack = cont->st_ptr; stack != cont->st_ptr + cont->sp_offset; ++stack) { @@ -433,10 +421,17 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) } /* arena */ - for (i = 0; i < cont->arena_idx; ++i) { + for (i = 0; i < (size_t)cont->arena_idx; ++i) { gc_mark_object(pic, cont->arena[i]); } + /* error handlers */ + for (i = 0; i < cont->try_jmp_idx; ++i) { + if (cont->try_jmps[i].handler) { + gc_mark_object(pic, (struct pic_object *)cont->try_jmps[i].handler); + } + } + /* result values */ gc_mark(pic, cont->results); break; @@ -506,6 +501,20 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) } break; } + case PIC_TT_BLK: { + struct pic_block *blk = (struct pic_block *)obj; + + if (blk->prev) { + gc_mark_object(pic, (struct pic_object *)blk->prev); + } + if (blk->in) { + gc_mark_object(pic, (struct pic_object *)blk->in); + } + if (blk->out) { + gc_mark_object(pic, (struct pic_object *)blk->out); + } + break; + } case PIC_TT_NIL: case PIC_TT_BOOL: case PIC_TT_FLOAT: @@ -539,7 +548,9 @@ gc_mark_phase(pic_state *pic) xh_iter it; /* block */ - gc_mark_block(pic, pic->blk); + if (pic->blk) { + gc_mark_object(pic, (struct pic_object *)pic->blk); + } /* stack */ for (stack = pic->stbase; stack != pic->sp; ++stack) { @@ -574,6 +585,13 @@ gc_mark_phase(pic_state *pic) gc_mark_object(pic, xh_val(it.e, struct pic_object *)); } + /* error handlers */ + for (i = 0; i < pic->try_jmp_idx; ++i) { + if (pic->try_jmps[i].handler) { + gc_mark_object(pic, (struct pic_object *)pic->try_jmps[i].handler); + } + } + /* library table */ gc_mark(pic, pic->lib_tbl); } @@ -621,7 +639,7 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) pic_free(pic, cont->st_ptr); pic_free(pic, cont->ci_ptr); pic_free(pic, cont->arena); - PIC_BLK_DECREF(pic, cont->blk); + pic_free(pic, cont->try_jmps); break; } case PIC_TT_SENV: { @@ -658,6 +676,9 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) xh_destroy(&dict->hash); break; } + case PIC_TT_BLK: { + break; + } case PIC_TT_NIL: case PIC_TT_BOOL: case PIC_TT_FLOAT: diff --git a/src/macro.c b/src/macro.c index 597eb57f..a31173de 100644 --- a/src/macro.c +++ b/src/macro.c @@ -416,6 +416,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv) case PIC_TT_IREP: case PIC_TT_DATA: case PIC_TT_DICT: + case PIC_TT_BLK: pic_errorf(pic, "unexpected value type: ~s", expr); } UNREACHABLE(); diff --git a/src/state.c b/src/state.c index 758bae9c..518d2ea4 100644 --- a/src/state.c +++ b/src/state.c @@ -9,6 +9,7 @@ #include "picrin/proc.h" #include "picrin/macro.h" #include "picrin/cont.h" +#include "picrin/error.h" void pic_init_core(pic_state *); @@ -22,18 +23,14 @@ pic_open(int argc, char *argv[], char **envp) pic = (pic_state *)malloc(sizeof(pic_state)); + /* root block */ + pic->blk = NULL; + /* command line */ pic->argc = argc; pic->argv = argv; pic->envp = envp; - /* root block */ - pic->blk = (pic_block *)malloc(sizeof(pic_block)); - pic->blk->prev = NULL; - pic->blk->depth = 0; - pic->blk->in = pic->blk->out = NULL; - pic->blk->refcnt = 1; - /* prepare VM stack */ pic->stbase = pic->sp = (pic_value *)calloc(PIC_STACK_SIZE, sizeof(pic_value)); pic->stend = pic->stbase + PIC_STACK_SIZE; @@ -70,7 +67,9 @@ pic_open(int argc, char *argv[], char **envp) /* error handling */ pic->jmp = NULL; pic->err = NULL; - pic->try_jmps = NULL; + pic->try_jmps = calloc(PIC_RESCUE_SIZE, sizeof(struct pic_jmpbuf)); + pic->try_jmp_idx = 0; + pic->try_jmp_size = PIC_RESCUE_SIZE; /* GC arena */ pic->arena = (struct pic_object **)calloc(PIC_ARENA_SIZE, sizeof(struct pic_object **)); @@ -132,6 +131,12 @@ pic_open(int argc, char *argv[], char **envp) register_renamed_symbol(pic, rEXPORT, "export"); pic_gc_arena_restore(pic, ai); + /* root block */ + pic->blk = (struct pic_block *)pic_obj_alloc(pic, sizeof(struct pic_block), PIC_TT_BLK); + pic->blk->prev = NULL; + pic->blk->depth = 0; + pic->blk->in = pic->blk->out = NULL; + pic_init_core(pic); /* set library */ @@ -147,7 +152,12 @@ pic_close(pic_state *pic) xh_iter it; /* invoke exit handlers */ - PIC_BLK_EXIT(pic); + while (pic->blk) { + if (pic->blk->out) { + pic_apply0(pic, pic->blk->out); + } + pic->blk = pic->blk->prev; + } /* clear out root objects */ pic->sp = pic->stbase; @@ -170,6 +180,7 @@ pic_close(pic_state *pic) /* free global stacks */ free(pic->globals); + free(pic->try_jmps); xh_destroy(&pic->syms); xh_destroy(&pic->global_tbl); xh_destroy(&pic->macros); diff --git a/src/system.c b/src/system.c index 73b27262..633d4a94 100644 --- a/src/system.c +++ b/src/system.c @@ -47,7 +47,7 @@ pic_system_exit(pic_state *pic) } } - PIC_BLK_EXIT(pic); + pic_close(pic); exit(status); } diff --git a/src/vm.c b/src/vm.c index 8e2ddb6c..2ab80a1e 100644 --- a/src/vm.c +++ b/src/vm.c @@ -51,6 +51,7 @@ pic_get_proc(pic_state *pic) * l lambda object * p port object * d dictionary object + * e error object * * | optional operator * * variable length operator @@ -346,8 +347,25 @@ pic_get_args(pic_state *pic, const char *format, ...) } break; } + case 'e': { + struct pic_error **e; + pic_value v; + + e = va_arg(ap, struct pic_error **); + if (i < argc) { + v = GET_OPERAND(pic,i); + if (pic_error_p(v)) { + *e = pic_error_ptr(v); + } + else { + pic_error(pic, "pic_get_args, expected error"); + } + i++; + } + break; + } default: - pic_error(pic, "pic_get_args: invalid argument specifier given"); + pic_errorf(pic, "pic_get_args: invalid argument specifier '%c' given", c); } } if ('*' == c) { @@ -485,12 +503,28 @@ vm_tear_off(pic_state *pic) assert(pic->ci->env != NULL); env = pic->ci->env; + + if (env->regs == env->storage) { + return; /* is torn off */ + } for (i = 0; i < env->regc; ++i) { env->storage[i] = env->regs[i]; } env->regs = env->storage; } +void +pic_vm_tear_off(pic_state *pic) +{ + pic_callinfo *ci; + + for (ci = pic->ci; ci > pic->cibase; ci--) { + if (pic->ci->env != NULL) { + vm_tear_off(pic); + } + } +} + pic_value pic_apply0(pic_state *pic, struct pic_proc *proc) { diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index c02b0c9d..9b3ce733 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -1596,7 +1596,6 @@ (test -1 (call-with-values * -)) -#; (test '(connect talk1 disconnect connect talk2 disconnect) (let ((path '()) @@ -1619,29 +1618,29 @@ (test-begin "6.11 Exceptions") -;; (test 65 -;; (with-exception-handler -;; (lambda (con) 42) -;; (lambda () -;; (+ (raise-continuable "should be a number") -;; 23)))) +(test 65 + (with-exception-handler + (lambda (con) 42) + (lambda () + (+ (raise-continuable "should be a number") + 23)))) -;; (test #t -;; (error-object? (guard (exn (else exn)) (error "BOOM!" 1 2 3)))) +(test #t + (error-object? (guard (exn (else exn)) (error "BOOM!" 1 2 3)))) ;; (test "BOOM!" ;; (error-object-message (guard (exn (else exn)) (error "BOOM!" 1 2 3)))) ;; (test '(1 2 3) ;; (error-object-irritants (guard (exn (else exn)) (error "BOOM!" 1 2 3)))) -;; (test #f -;; (file-error? (guard (exn (else exn)) (error "BOOM!")))) -;; (test #t -;; (file-error? (guard (exn (else exn)) (open-input-file " no such file ")))) +(test #f + (file-error? (guard (exn (else exn)) (error "BOOM!")))) +(test #t + (file-error? (guard (exn (else exn)) (open-input-file " no such file ")))) -;; (test #f -;; (read-error? (guard (exn (else exn)) (error "BOOM!")))) -;; (test #t -;; (read-error? (guard (exn (else exn)) (read (open-input-string ")"))))) +(test #f + (read-error? (guard (exn (else exn)) (error "BOOM!")))) +(test #t + (read-error? (guard (exn (else exn)) (read (open-input-string ")"))))) (define something-went-wrong #f) (define (test-exception-handler-1 v) @@ -1659,86 +1658,86 @@ (test '("condition: " an-error) something-went-wrong) (set! something-went-wrong #f) -;; (define (test-exception-handler-2 v) -;; (guard (ex (else 'caught-another-exception)) -;; (with-exception-handler -;; (lambda (x) -;; (set! something-went-wrong #t) -;; (list "exception:" x)) -;; (lambda () -;; (+ 1 (if (> v 0) (+ v 100) (raise 'an-error))))))) -;; (test 106 (test-exception-handler-2 5)) -;; (test #f something-went-wrong) -;; (test 'caught-another-exception (test-exception-handler-2 -1)) -;; (test #t something-went-wrong) +(define (test-exception-handler-2 v) + (guard (ex (else 'caught-another-exception)) + (with-exception-handler + (lambda (x) + (set! something-went-wrong #t) + (list "exception:" x)) + (lambda () + (+ 1 (if (> v 0) (+ v 100) (raise 'an-error))))))) +(test 106 (test-exception-handler-2 5)) +(test #f something-went-wrong) +(test 'caught-another-exception (test-exception-handler-2 -1)) +(test #t something-went-wrong) ;; Based on an example from R6RS-lib section 7.1 Exceptions. ;; R7RS section 6.11 Exceptions has a simplified version. -;; (let* ((out (open-output-string)) -;; (value (with-exception-handler -;; (lambda (con) -;; (cond -;; ((not (list? con)) -;; (raise con)) -;; ((list? con) -;; (display (car con) out)) -;; (else -;; (display "a warning has been issued" out))) -;; 42) -;; (lambda () -;; (+ (raise-continuable -;; (list "should be a number")) -;; 23))))) -;; (test "should be a number" (get-output-string out)) -;; (test 65 value)) +(let* ((out (open-output-string)) + (value (with-exception-handler + (lambda (con) + (cond + ((not (list? con)) + (raise con)) + ((list? con) + (display (car con) out)) + (else + (display "a warning has been issued" out))) + 42) + (lambda () + (+ (raise-continuable + (list "should be a number")) + 23))))) + (test "should be a number" (get-output-string out)) + (test 65 value)) ;; From SRFI-34 "Examples" section - #3 -;; (define (test-exception-handler-3 v out) -;; (guard (condition -;; (else -;; (display "condition: " out) -;; (write condition out) -;; (display #\! out) -;; 'exception)) -;; (+ 1 (if (= v 0) (raise 'an-error) (/ 10 v))))) -;; (let* ((out (open-output-string)) -;; (value (test-exception-handler-3 0 out))) -;; (test 'exception value) -;; (test "condition: an-error!" (get-output-string out))) +(define (test-exception-handler-3 v out) + (guard (condition + (else + (display "condition: " out) + (write condition out) + (display #\! out) + 'exception)) + (+ 1 (if (= v 0) (raise 'an-error) (/ 10 v))))) +(let* ((out (open-output-string)) + (value (test-exception-handler-3 0 out))) + (test 'exception value) + (test "condition: an-error!" (get-output-string out))) -;; (define (test-exception-handler-4 v out) -;; (call-with-current-continuation -;; (lambda (k) -;; (with-exception-handler -;; (lambda (x) -;; (display "reraised " out) -;; (write x out) (display #\! out) -;; (k 'zero)) -;; (lambda () -;; (guard (condition -;; ((positive? condition) -;; 'positive) -;; ((negative? condition) -;; 'negative)) -;; (raise v))))))) +(define (test-exception-handler-4 v out) + (call-with-current-continuation + (lambda (k) + (with-exception-handler + (lambda (x) + (display "reraised " out) + (write x out) (display #\! out) + (k 'zero)) + (lambda () + (guard (condition + ((positive? condition) + 'positive) + ((negative? condition) + 'negative)) + (raise v))))))) ;; From SRFI-34 "Examples" section - #5 -;; (let* ((out (open-output-string)) -;; (value (test-exception-handler-4 1 out))) -;; (test "" (get-output-string out)) -;; (test 'positive value)) -;; ;; From SRFI-34 "Examples" section - #6 -;; (let* ((out (open-output-string)) -;; (value (test-exception-handler-4 -1 out))) -;; (test "" (get-output-string out)) -;; (test 'negative value)) -;; ;; From SRFI-34 "Examples" section - #7 -;; (let* ((out (open-output-string)) -;; (value (test-exception-handler-4 0 out))) -;; (test "reraised 0!" (get-output-string out)) -;; (test 'zero value)) +(let* ((out (open-output-string)) + (value (test-exception-handler-4 1 out))) + (test "" (get-output-string out)) + (test 'positive value)) +;; From SRFI-34 "Examples" section - #6 +(let* ((out (open-output-string)) + (value (test-exception-handler-4 -1 out))) + (test "" (get-output-string out)) + (test 'negative value)) +;; From SRFI-34 "Examples" section - #7 +(let* ((out (open-output-string)) + (value (test-exception-handler-4 0 out))) + (test "reraised 0!" (get-output-string out)) + (test 'zero value)) -;; From SRFI-34 "Examples" section - #8 +;; ;; From SRFI-34 "Examples" section - #8 ;; (test 42 ;; (guard (condition ;; ((assq 'a condition) => cdr)