diff --git a/contrib/10.callcc/callcc.c b/contrib/10.callcc/callcc.c deleted file mode 100644 index 07bd8940..00000000 --- a/contrib/10.callcc/callcc.c +++ /dev/null @@ -1,256 +0,0 @@ -#include "picrin.h" -#include "object.h" -#include "state.h" - -struct fullcont { - jmp_buf jmp; - - struct cont *prev_jmp; - - struct checkpoint *cp; - - char *stk_pos, *stk_ptr; - ptrdiff_t stk_len; - - pic_value *st_ptr; - size_t sp_offset; - ptrdiff_t st_len; - - struct callinfo *ci_ptr; - size_t ci_offset; - ptrdiff_t ci_len; - - const struct code *ip; - - struct object **arena; - size_t arena_size, arena_idx; - - int retc; - pic_value *retv; -}; - -char *picrin_native_stack_start; - -static void -cont_dtor(pic_state *pic, void *data) -{ - struct fullcont *cont = data; - - pic_free(pic, cont->stk_ptr); - pic_free(pic, cont->st_ptr); - pic_free(pic, cont->ci_ptr); - pic_free(pic, cont->arena); - pic_free(pic, cont); -} - -static void -cont_mark(pic_state *pic, void *data, void (*mark)(pic_state *, pic_value)) -{ - struct fullcont *cont = data; - struct checkpoint *cp; - pic_value *stack; - struct callinfo *ci; - size_t i; - - /* checkpoint */ - for (cp = cont->cp; cp != NULL; cp = cp->prev) { - if (cp->in) { - mark(pic, obj_value(pic, cp->in)); - } - if (cp->out) { - mark(pic, obj_value(pic, cp->out)); - } - } - - /* stack */ - for (stack = cont->st_ptr; stack != cont->st_ptr + cont->sp_offset; ++stack) { - mark(pic, *stack); - } - - /* callinfo */ - for (ci = cont->ci_ptr + cont->ci_offset; ci != cont->ci_ptr; --ci) { - if (ci->cxt) { - mark(pic, obj_value(pic, ci->cxt)); - } - } - - /* arena */ - for (i = 0; i < cont->arena_idx; ++i) { - mark(pic, obj_value(pic, cont->arena[i])); - } -} - -static const pic_data_type cont_type = { "continuation", cont_dtor, cont_mark }; - -static void save_cont(pic_state *, struct fullcont *); -static void restore_cont(pic_state *, struct fullcont *); - -#if __GNUC__ -# define NOINLINE __attribute__ ((noinline)) -#else -# define NOINLINE -#endif - -static ptrdiff_t NOINLINE -native_stack_length(char **pos) -{ - char t; - - *pos = (picrin_native_stack_start > &t) - ? &t - : picrin_native_stack_start; - - return (picrin_native_stack_start > &t) - ? picrin_native_stack_start - &t - : &t - picrin_native_stack_start; -} - -static void NOINLINE -save_cont(pic_state *pic, struct fullcont *cont) -{ - void pic_vm_tear_off(pic_state *); - char *pos; - - pic_vm_tear_off(pic); /* tear off */ - - cont->prev_jmp = pic->cc; - - cont->cp = pic->cp; - - cont->stk_len = native_stack_length(&pos); - cont->stk_pos = pos; - assert(cont->stk_len > 0); - cont->stk_ptr = pic_malloc(pic, cont->stk_len); - memcpy(cont->stk_ptr, cont->stk_pos, cont->stk_len); - - cont->sp_offset = pic->sp - pic->stbase; - cont->st_len = pic->stend - pic->stbase; - cont->st_ptr = pic_malloc(pic, sizeof(pic_value) * cont->st_len); - memcpy(cont->st_ptr, pic->stbase, sizeof(pic_value) * cont->st_len); - - cont->ci_offset = pic->ci - pic->cibase; - cont->ci_len = pic->ciend - pic->cibase; - cont->ci_ptr = pic_malloc(pic, sizeof(struct callinfo) * cont->ci_len); - memcpy(cont->ci_ptr, pic->cibase, sizeof(struct callinfo) * cont->ci_len); - - cont->ip = pic->ip; - - cont->arena_idx = pic->arena_idx; - cont->arena_size = pic->arena_size; - cont->arena = pic_malloc(pic, sizeof(struct object *) * pic->arena_size); - memcpy(cont->arena, pic->arena, sizeof(struct object *) * pic->arena_size); - - cont->retc = 0; - cont->retv = NULL; -} - -static void NOINLINE -native_stack_extend(pic_state *pic, struct fullcont *cont) -{ - pic_value v[1024]; - - memset(v, 0, sizeof v); - - restore_cont(pic, cont); -} - -PIC_NORETURN static void -restore_cont(pic_state *pic, struct fullcont *cont) -{ - char v; - struct fullcont *tmp = cont; - - if (&v < picrin_native_stack_start) { - if (&v > cont->stk_pos) native_stack_extend(pic, cont); - } - else { - if (&v < cont->stk_pos + cont->stk_len) native_stack_extend(pic, cont); - } - - pic->cc = cont->prev_jmp; - pic->cp = cont->cp; - - assert(pic->stend - pic->stbase >= cont->st_len); - memcpy(pic->stbase, cont->st_ptr, sizeof(pic_value) * cont->st_len); - pic->sp = pic->stbase + cont->sp_offset; - pic->stend = pic->stbase + cont->st_len; - - assert(pic->ciend - pic->cibase >= cont->ci_len); - memcpy(pic->cibase, cont->ci_ptr, sizeof(struct callinfo) * cont->ci_len); - pic->ci = pic->cibase + cont->ci_offset; - pic->ciend = pic->cibase + cont->ci_len; - - pic->ip = cont->ip; - - assert(pic->arena_size >= cont->arena_size); - memcpy(pic->arena, cont->arena, sizeof(struct object *) * cont->arena_size); - pic->arena_size = cont->arena_size; - pic->arena_idx = cont->arena_idx; - - memcpy(cont->stk_pos, cont->stk_ptr, cont->stk_len); - - longjmp(tmp->jmp, 1); -} - -PIC_NORETURN static pic_value -cont_call(pic_state *pic) -{ - int argc, i; - pic_value *argv, *retv; - struct fullcont *cont; - - pic_get_args(pic, "*", &argc, &argv); - - retv = pic_alloca(pic, sizeof(pic_value) * argc); - for (i = 0; i < argc; ++i) { - retv[i] = argv[i]; - } - - cont = pic_data(pic, pic_closure_ref(pic, 0)); - cont->retc = argc; - cont->retv = retv; - - /* execute guard handlers */ - pic_wind(pic, pic->cp, cont->cp); - - restore_cont(pic, cont); -} - -static pic_value -pic_callcc(pic_state *pic, pic_value proc) -{ - struct fullcont *cont = pic_malloc(pic, sizeof(struct fullcont)); - - if (setjmp(cont->jmp) != 0) { - return pic_valuesk(pic, cont->retc, cont->retv); - } else { - pic_value c[1]; - - save_cont(pic, cont); - - /* save the continuation object in proc */ - c[0] = pic_lambda(pic, cont_call, 1, pic_data_value(pic, cont, &cont_type)); - - return pic_applyk(pic, proc, 1, c); - } -} - -static pic_value -pic_callcc_callcc(pic_state *pic) -{ - pic_value proc; - - pic_get_args(pic, "l", &proc); - - return pic_callcc(pic, proc); -} - -#define pic_redefun(pic, lib, name, func) \ - pic_set(pic, lib, name, pic_lambda(pic, func, 0)) - -void -pic_init_callcc(pic_state *pic) -{ - pic_redefun(pic, "picrin.base", "call-with-current-continuation", pic_callcc_callcc); - pic_redefun(pic, "picrin.base", "call/cc", pic_callcc_callcc); -} diff --git a/contrib/10.callcc/nitro.mk b/contrib/10.callcc/nitro.mk deleted file mode 100644 index 0779aa0f..00000000 --- a/contrib/10.callcc/nitro.mk +++ /dev/null @@ -1,2 +0,0 @@ -CONTRIB_INITS += callcc -CONTRIB_SRCS += $(wildcard contrib/10.callcc/*.c) diff --git a/contrib/30.regexp/src/regexp.c b/contrib/30.regexp/src/regexp.c index c428ad1c..5a9972be 100644 --- a/contrib/30.regexp/src/regexp.c +++ b/contrib/30.regexp/src/regexp.c @@ -18,7 +18,7 @@ regexp_dtor(pic_state *pic, void *data) pic_free(pic, data); } -static const pic_data_type regexp_type = { "regexp", regexp_dtor, NULL }; +static const pic_data_type regexp_type = { "regexp", regexp_dtor }; static pic_value pic_regexp_regexp(pic_state *pic) diff --git a/contrib/30.test/test.scm b/contrib/30.test/test.scm index 76455882..e88d6a70 100644 --- a/contrib/30.test/test.scm +++ b/contrib/30.test/test.scm @@ -38,33 +38,54 @@ ((test expected expr) (test expected expr equal?)) ((test expected expr =) - (let ((res expr)) + (begin (display "case ") (write counter) - (if (= res expected) - (begin - (display " PASS: ") - (write 'expr) - (display " equals ") - (write expected) - (display "") - (newline)) - (begin - (set! failure-counter (+ failure-counter 1)) - (let ((out (open-output-string))) - (display " FAIL: " out) - (write 'expr out) - (newline out) - (display " expected " out) - (write expected out) - (display " but got " out) - (write res out) - (display "" out) - (newline out) - (let ((str (get-output-string out))) - (set! fails (cons str fails)) - (display str))))) - (set! counter (+ counter 1)))))) + (let ((res (call/cc + (lambda (k) + (with-exception-handler + (lambda (e) (k (cons 'raised e))) + (lambda () + (cons #f expr))))))) + (if (eq? (car res) 'raised) + (let ((out (open-output-string))) + (display " ERROR: " out) + (write 'expr out) + (newline out) + (display " expected " out) + (write expected out) + (display " but got an error " out) + (write (cdr res) out) + (display "" out) + (newline out) + (let ((str (get-output-string out))) + (set! fails (cons str fails)) + (display str))) + (let ((res (cdr res))) + (if (= res expected) + (begin + (display " PASS: ") + (write 'expr) + (display " equals ") + (write expected) + (display "") + (newline)) + (begin + (set! failure-counter (+ failure-counter 1)) + (let ((out (open-output-string))) + (display " FAIL: " out) + (write 'expr out) + (newline out) + (display " expected " out) + (write expected out) + (display " but got " out) + (write res out) + (display "" out) + (newline out) + (let ((str (get-output-string out))) + (set! fails (cons str fails)) + (display str))))))) + (set! counter (+ counter 1))))))) (define-syntax test-values (syntax-rules () diff --git a/contrib/40.srfi/src/106.c b/contrib/40.srfi/src/106.c index d8334fc8..cda947c3 100644 --- a/contrib/40.srfi/src/106.c +++ b/contrib/40.srfi/src/106.c @@ -45,7 +45,7 @@ socket_dtor(pic_state *pic, void *data) pic_free(pic, data); } -static const pic_data_type socket_type = { "socket", socket_dtor, NULL }; +static const pic_data_type socket_type = { "socket", socket_dtor }; static pic_value pic_socket_socket_p(pic_state *pic) diff --git a/lib/cont.c b/lib/cont.c index 3bc4333c..cc11dfbd 100644 --- a/lib/cont.c +++ b/lib/cont.c @@ -21,7 +21,7 @@ struct cont { struct cont *prev; }; -static const pic_data_type cont_type = { "cont", NULL, NULL }; +static const pic_data_type cont_type = { "cont", NULL }; void pic_save_point(pic_state *pic, struct cont *cont, PIC_JMPBUF *jmp) diff --git a/lib/gc.c b/lib/gc.c index faf5e099..b455531e 100644 --- a/lib/gc.c +++ b/lib/gc.c @@ -191,7 +191,7 @@ pic_leave(pic_state *pic, size_t state) void * pic_alloca(pic_state *pic, size_t n) { - static const pic_data_type t = { "pic_alloca", pic_free, 0 }; + static const pic_data_type t = { "pic_alloca", pic_free }; return pic_data(pic, pic_data_value(pic, pic_malloc(pic, n), &t)); /* TODO optimize */ } @@ -399,9 +399,6 @@ gc_mark_object(pic_state *pic, struct object *obj) break; } case PIC_TYPE_DATA: { - if (obj->u.data.type->mark) { - obj->u.data.type->mark(pic, obj->u.data.data, gc_mark); - } break; } case PIC_TYPE_DICT: { diff --git a/lib/include/picrin.h b/lib/include/picrin.h index 6ca42b61..c2127de2 100644 --- a/lib/include/picrin.h +++ b/lib/include/picrin.h @@ -94,7 +94,6 @@ bool pic_equal_p(pic_state *, pic_value, pic_value); typedef struct { const char *type_name; void (*dtor)(pic_state *, void *); - void (*mark)(pic_state *, void *, void (*)(pic_state *, pic_value)); } pic_data_type; bool pic_undef_p(pic_state *, pic_value); /* deprecated */ diff --git a/src/main.c b/src/main.c index 9b6824d5..3733ba37 100644 --- a/src/main.c +++ b/src/main.c @@ -19,12 +19,9 @@ int picrin_argc; char **picrin_argv; char **picrin_envp; -extern char *picrin_native_stack_start; /* for call/cc */ - int main(int argc, char *argv[], char **envp) { - char t; pic_state *pic; pic_value e; int status; @@ -35,8 +32,6 @@ main(int argc, char *argv[], char **envp) picrin_argv = argv; picrin_envp = envp; - picrin_native_stack_start = &t; - pic_try { pic_init_picrin(pic);