conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'fix-dynamic-wind'

This commit is contained in:
Yuichi Nishiwaki 2014-07-26 13:34:57 +09:00
parent 2f44145d3e a38ba15010
commit 382de8dc96
15 changed files with 339 additions and 187 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
docs/lang.rst
View File

@ -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 [#]_

10
include/picrin.h
View File

@ -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;

40
include/picrin/cont.h
View File

@ -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);

12
include/picrin/error.h
View File

@ -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);

5
include/picrin/value.h
View File

@ -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();
}

59
piclib/prelude.scm
View File

@ -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)

1
src/codegen.c
View File

@ -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();

28
src/cont.c
View File

@ -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) {

71
src/error.c
View File

@ -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);

55
src/gc.c
View File

@ -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:

1
src/macro.c
View File

@ -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();

29
src/state.c
View File

@ -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);

2
src/system.c
View File

@ -47,7 +47,7 @@ pic_system_exit(pic_state *pic)
}
}
PIC_BLK_EXIT(pic);
pic_close(pic);
exit(status);
}

36
src/vm.c
View File

@ -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)
{

175
t/r7rs-tests.scm
View File

@ -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)