diff --git a/Makefile b/Makefile index 58eadf39..e498d0fd 100644 --- a/Makefile +++ b/Makefile @@ -20,12 +20,12 @@ REPL_ISSUE_TESTS = $(wildcard t/issue/*.sh) TEST_RUNNER = bin/picrin -CFLAGS += -I./extlib/benz/include -Wall -Wextra $(CONTRIB_DEFS) +CFLAGS += -I./extlib/benz/include -Wall -Wextra LDFLAGS += -lm prefix ?= /usr/local -all: CFLAGS += -O2 -DNDEBUG=1 +all: CFLAGS += -O2 -flto -DNDEBUG=1 all: bin/picrin debug: CFLAGS += -O0 -g @@ -33,8 +33,9 @@ debug: bin/picrin include $(sort $(wildcard contrib/*/nitro.mk)) -bin/picrin: $(PICRIN_OBJS) $(CONTRIB_OBJS) lib/libbenz.a - $(CC) $(CFLAGS) -o $@ $(PICRIN_OBJS) $(CONTRIB_OBJS) lib/libbenz.a $(LDFLAGS) +bin/picrin: CFLAGS += $(CONTRIB_DEFS) +bin/picrin: $(PICRIN_OBJS) $(CONTRIB_OBJS) $(BENZ_OBJS) + $(CC) $(CFLAGS) -o $@ $(PICRIN_OBJS) $(CONTRIB_OBJS) $(BENZ_OBJS) $(LDFLAGS) src/load_piclib.c: $(CONTRIB_LIBS) perl etc/mkloader.pl $(CONTRIB_LIBS) > $@ @@ -42,8 +43,8 @@ src/load_piclib.c: $(CONTRIB_LIBS) src/init_contrib.c: perl etc/mkinit.pl $(CONTRIB_INITS) > $@ -lib/libbenz.a: $(BENZ_OBJS) - $(AR) $(ARFLAGS) $@ $(BENZ_OBJS) +lib/libbenz.so: $(BENZ_OBJS) + $(CC) -shared $(CFLAGS) -o $@ $(BENZ_OBJS) $(LDFLAGS) extlib/benz/boot.o: extlib/benz/boot.c cd extlib/benz; perl boot.c @@ -70,8 +71,10 @@ test: test-contribs test-nostdlib test-issue test-contribs: bin/picrin $(CONTRIB_TESTS) test-nostdlib: - $(CC) -I extlib/benz/include -D'PIC_ENABLE_LIBC=0' -D'PIC_ENABLE_FLOAT=0' -D'PIC_ENABLE_STDIO=0' -ffreestanding -nostdlib -fPIC -shared -std=c89 -pedantic -Wall -Wextra -Werror -o lib/libbenz.so $(BENZ_SRCS) etc/libc_polyfill.c -fno-stack-protector - rm -f lib/libbenz.so + $(CC) -I extlib/benz/include -D'PIC_USE_LIBC=0' -D'PIC_USE_STDIO=0' -D'PIC_USE_WRITE=0' -ffreestanding -nostdlib -Os -fPIC -shared -std=c89 -pedantic -Wall -Wextra -Werror -o lib/libbenz-tiny.so $(BENZ_SRCS) etc/libc_polyfill.c -fno-stack-protector + strip lib/libbenz-tiny.so + ls -lh lib/libbenz-tiny.so + rm -f lib/libbenz-tiny.so test-issue: test-picrin-issue test-repl-issue @@ -90,7 +93,7 @@ install: all clean: rm -f src/load_piclib.c src/init_contrib.c - rm -f lib/libbenz.a + rm -f lib/libbenz.so rm -f $(BENZ_OBJS) rm -f $(PICRIN_OBJS) rm -f $(CONTRIB_OBJS) diff --git a/contrib/10.callcc/callcc.c b/contrib/10.callcc/callcc.c index 49691a0c..8664354c 100644 --- a/contrib/10.callcc/callcc.c +++ b/contrib/10.callcc/callcc.c @@ -1,11 +1,13 @@ #include "picrin.h" +#include "picrin/private/object.h" +#include "picrin/private/state.h" -struct pic_fullcont { +struct fullcont { jmp_buf jmp; struct pic_cont *prev_jmp; - pic_checkpoint *cp; + struct checkpoint *cp; char *stk_pos, *stk_ptr; ptrdiff_t stk_len; @@ -14,28 +16,29 @@ struct pic_fullcont { size_t sp_offset; ptrdiff_t st_len; - pic_callinfo *ci_ptr; + struct callinfo *ci_ptr; size_t ci_offset; ptrdiff_t ci_len; - struct pic_proc **xp_ptr; + struct proc **xp_ptr; size_t xp_offset; ptrdiff_t xp_len; - pic_code *ip; + struct code *ip; pic_value ptable; - struct pic_object **arena; + struct object **arena; size_t arena_size, arena_idx; - pic_value results; + int retc; + pic_value *retv; }; static void cont_dtor(pic_state *pic, void *data) { - struct pic_fullcont *cont = data; + struct fullcont *cont = data; pic_free(pic, cont->stk_ptr); pic_free(pic, cont->st_ptr); @@ -48,11 +51,11 @@ cont_dtor(pic_state *pic, void *data) static void cont_mark(pic_state *pic, void *data, void (*mark)(pic_state *, pic_value)) { - struct pic_fullcont *cont = data; - pic_checkpoint *cp; + struct fullcont *cont = data; + struct checkpoint *cp; pic_value *stack; - pic_callinfo *ci; - struct pic_proc **xp; + struct callinfo *ci; + struct proc **xp; size_t i; /* checkpoint */ @@ -89,15 +92,12 @@ cont_mark(pic_state *pic, void *data, void (*mark)(pic_state *, pic_value)) /* parameter table */ mark(pic, cont->ptable); - - /* result values */ - mark(pic, cont->results); } static const pic_data_type cont_type = { "continuation", cont_dtor, cont_mark }; -static void save_cont(pic_state *, struct pic_fullcont **); -static void restore_cont(pic_state *, struct pic_fullcont *); +static void save_cont(pic_state *, struct fullcont **); +static void restore_cont(pic_state *, struct fullcont *); static ptrdiff_t native_stack_length(pic_state *pic, char **pos) @@ -114,15 +114,15 @@ native_stack_length(pic_state *pic, char **pos) } static void -save_cont(pic_state *pic, struct pic_fullcont **c) +save_cont(pic_state *pic, struct fullcont **c) { void pic_vm_tear_off(pic_state *); - struct pic_fullcont *cont; + struct fullcont *cont; char *pos; pic_vm_tear_off(pic); /* tear off */ - cont = *c = pic_malloc(pic, sizeof(struct pic_fullcont)); + cont = *c = pic_malloc(pic, sizeof(struct fullcont)); cont->prev_jmp = pic->cc; @@ -141,13 +141,13 @@ save_cont(pic_state *pic, struct pic_fullcont **c) cont->ci_offset = pic->ci - pic->cibase; cont->ci_len = pic->ciend - pic->cibase; - cont->ci_ptr = pic_malloc(pic, sizeof(pic_callinfo) * cont->ci_len); - memcpy(cont->ci_ptr, pic->cibase, sizeof(pic_callinfo) * cont->ci_len); + 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->xp_offset = pic->xp - pic->xpbase; cont->xp_len = pic->xpend - pic->xpbase; - cont->xp_ptr = pic_malloc(pic, sizeof(struct pic_proc *) * cont->xp_len); - memcpy(cont->xp_ptr, pic->xpbase, sizeof(struct pic_proc *) * cont->xp_len); + cont->xp_ptr = pic_malloc(pic, sizeof(struct proc *) * cont->xp_len); + memcpy(cont->xp_ptr, pic->xpbase, sizeof(struct proc *) * cont->xp_len); cont->ip = pic->ip; @@ -155,14 +155,15 @@ save_cont(pic_state *pic, struct pic_fullcont **c) cont->arena_idx = pic->arena_idx; cont->arena_size = pic->arena_size; - cont->arena = pic_malloc(pic, sizeof(struct pic_object *) * pic->arena_size); - memcpy(cont->arena, pic->arena, sizeof(struct pic_object *) * 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->results = pic_undef_value(); + cont->retc = 0; + cont->retv = NULL; } static void -native_stack_extend(pic_state *pic, struct pic_fullcont *cont) +native_stack_extend(pic_state *pic, struct fullcont *cont) { volatile pic_value v[1024]; @@ -171,10 +172,10 @@ native_stack_extend(pic_state *pic, struct pic_fullcont *cont) } PIC_NORETURN static void -restore_cont(pic_state *pic, struct pic_fullcont *cont) +restore_cont(pic_state *pic, struct fullcont *cont) { char v; - struct pic_fullcont *tmp = cont; + struct fullcont *tmp = cont; if (&v < pic->native_stack_start) { if (&v > cont->stk_pos) native_stack_extend(pic, cont); @@ -192,12 +193,12 @@ restore_cont(pic_state *pic, struct pic_fullcont *cont) pic->stend = pic->stbase + cont->st_len; assert(pic->ciend - pic->cibase >= cont->ci_len); - memcpy(pic->cibase, cont->ci_ptr, sizeof(pic_callinfo) * 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; assert(pic->xpend - pic->xpbase >= cont->xp_len); - memcpy(pic->xpbase, cont->xp_ptr, sizeof(struct pic_proc *) * cont->xp_len); + memcpy(pic->xpbase, cont->xp_ptr, sizeof(struct proc *) * cont->xp_len); pic->xp = pic->xpbase + cont->xp_offset; pic->xpend = pic->xpbase + cont->xp_len; @@ -206,7 +207,7 @@ restore_cont(pic_state *pic, struct pic_fullcont *cont) pic->ptable = cont->ptable; assert(pic->arena_size >= cont->arena_size); - memcpy(pic->arena, cont->arena, sizeof(struct pic_object *) * 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; @@ -218,15 +219,20 @@ restore_cont(pic_state *pic, struct pic_fullcont *cont) PIC_NORETURN static pic_value cont_call(pic_state *pic) { - struct pic_proc *self; - int argc; - pic_value *argv; - struct pic_fullcont *cont; + int argc, i; + pic_value *argv, *retv; + struct fullcont *cont; - pic_get_args(pic, "&*", &self, &argc, &argv); + pic_get_args(pic, "*", &argc, &argv); - cont = pic_data_ptr(pic_proc_env_ref(pic, self, "cont"))->data; - cont->results = pic_list_by_array(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); @@ -234,65 +240,42 @@ cont_call(pic_state *pic) restore_cont(pic, cont); } -pic_value -pic_callcc_full(pic_state *pic, struct pic_proc *proc) +static pic_value +pic_callcc(pic_state *pic, pic_value proc) { - struct pic_fullcont *cont; + struct fullcont *cont; save_cont(pic, &cont); if (setjmp(cont->jmp)) { - return pic_values_by_list(pic, cont->results); + return pic_valuesk(pic, cont->retc, cont->retv); } else { - struct pic_proc *c; - struct pic_data *dat; - - c = pic_make_proc(pic, cont_call); - - dat = pic_data_alloc(pic, &cont_type, cont); + pic_value c, args[1]; /* save the continuation object in proc */ - pic_proc_env_set(pic, c, "cont", pic_obj_value(dat)); + c = pic_lambda(pic, cont_call, 1, pic_data_value(pic, cont, &cont_type)); - return pic_apply1(pic, proc, pic_obj_value(c)); + args[0] = c; + return pic_applyk(pic, proc, 1, args); } } static pic_value pic_callcc_callcc(pic_state *pic) { - struct pic_proc *proc; - struct pic_fullcont *cont; + pic_value proc; pic_get_args(pic, "l", &proc); - save_cont(pic, &cont); - if (setjmp(cont->jmp)) { - return pic_values_by_list(pic, cont->results); - } - else { - struct pic_proc *c; - struct pic_data *dat; - - c = pic_make_proc(pic, cont_call); - - dat = pic_data_alloc(pic, &cont_type, cont); - - /* save the continuation object in proc */ - pic_proc_env_set(pic, c, "cont", pic_obj_value(dat)); - - return pic_apply_trampoline_list(pic, proc, pic_list1(pic, pic_obj_value(c))); - } + return pic_callcc(pic, proc); } -#define pic_redefun(pic, lib, name, func) \ - pic_set(pic, lib, name, pic_obj_value(pic_make_proc(pic, func))) +#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_deflibrary (pic, "(scheme base)") { - pic_redefun(pic, pic->PICRIN_BASE, "call-with-current-continuation", pic_callcc_callcc); - pic_redefun(pic, pic->PICRIN_BASE, "call/cc", pic_callcc_callcc); - } + 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.macro/macro.scm b/contrib/10.macro/macro.scm index b7c74388..759d410d 100644 --- a/contrib/10.macro/macro.scm +++ b/contrib/10.macro/macro.scm @@ -7,7 +7,7 @@ make-identifier identifier? identifier=? - identifier-variable + identifier-base identifier-environment) ;; simple macro @@ -74,7 +74,7 @@ (define (strip-syntax form) (letrec ((unwrap (lambda (var) - (identifier-variable var))) + (identifier-base var))) (walk (lambda (f form) (cond ((identifier? form) diff --git a/contrib/10.math/math.c b/contrib/10.math/math.c index f2b9d7f5..187941ad 100644 --- a/contrib/10.math/math.c +++ b/contrib/10.math/math.c @@ -1,4 +1,5 @@ #include "picrin.h" +#include "picrin/extra.h" #include @@ -17,13 +18,13 @@ pic_number_floor2(pic_state *pic) ? i / j : (i / j) - 1; - return pic_values2(pic, pic_int_value(k), pic_int_value(i - k * j)); + return pic_return(pic, 2, pic_int_value(pic, k), pic_int_value(pic, i - k * j)); } else { double q, r; q = floor((double)i/j); r = i - j * q; - return pic_values2(pic, pic_float_value(q), pic_float_value(r)); + return pic_return(pic, 2, pic_float_value(pic, q), pic_float_value(pic, r)); } } @@ -36,14 +37,14 @@ pic_number_trunc2(pic_state *pic) pic_get_args(pic, "II", &i, &e1, &j, &e2); if (e1 && e2) { - return pic_values2(pic, pic_int_value(i/j), pic_int_value(i - (i/j) * j)); + return pic_return(pic, 2, pic_int_value(pic, i/j), pic_int_value(pic, i - (i/j) * j)); } else { double q, r; q = trunc((double)i/j); r = i - j * q; - return pic_values2(pic, pic_float_value(q), pic_float_value(r)); + return pic_return(pic, 2, pic_float_value(pic, q), pic_float_value(pic, r)); } } @@ -56,9 +57,9 @@ pic_number_floor(pic_state *pic) pic_get_args(pic, "F", &f, &e); if (e) { - return pic_int_value((int)f); + return pic_int_value(pic, (int)f); } else { - return pic_float_value(floor(f)); + return pic_float_value(pic, floor(f)); } } @@ -71,9 +72,9 @@ pic_number_ceil(pic_state *pic) pic_get_args(pic, "F", &f, &e); if (e) { - return pic_int_value((int)f); + return pic_int_value(pic, (int)f); } else { - return pic_float_value(ceil(f)); + return pic_float_value(pic, ceil(f)); } } @@ -86,9 +87,9 @@ pic_number_trunc(pic_state *pic) pic_get_args(pic, "F", &f, &e); if (e) { - return pic_int_value((int)f); + return pic_int_value(pic, (int)f); } else { - return pic_float_value(trunc(f)); + return pic_float_value(pic, trunc(f)); } } @@ -101,9 +102,9 @@ pic_number_round(pic_state *pic) pic_get_args(pic, "F", &f, &e); if (e) { - return pic_int_value((int)f); + return pic_int_value(pic, (int)f); } else { - return pic_float_value(round(f)); + return pic_float_value(pic, round(f)); } } @@ -114,12 +115,12 @@ pic_number_finite_p(pic_state *pic) pic_get_args(pic, "o", &v); - if (pic_int_p(v)) - return pic_true_value(); - if (pic_float_p(v) && ! (isinf(pic_float(v)) || isnan(pic_float(v)))) - return pic_true_value(); + if (pic_int_p(pic, v)) + return pic_true_value(pic); + if (pic_float_p(pic, v) && ! (isinf(pic_float(pic, v)) || isnan(pic_float(pic, v)))) + return pic_true_value(pic); else - return pic_false_value(); + return pic_false_value(pic); } static pic_value @@ -129,10 +130,10 @@ pic_number_infinite_p(pic_state *pic) pic_get_args(pic, "o", &v); - if (pic_float_p(v) && isinf(pic_float(v))) - return pic_true_value(); + if (pic_float_p(pic, v) && isinf(pic_float(pic, v))) + return pic_true_value(pic); else - return pic_false_value(); + return pic_false_value(pic); } static pic_value @@ -142,10 +143,10 @@ pic_number_nan_p(pic_state *pic) pic_get_args(pic, "o", &v); - if (pic_float_p(v) && isnan(pic_float(v))) - return pic_true_value(); + if (pic_float_p(pic, v) && isnan(pic_float(pic, v))) + return pic_true_value(pic); else - return pic_false_value(); + return pic_false_value(pic); } static pic_value @@ -154,7 +155,7 @@ pic_number_exp(pic_state *pic) double f; pic_get_args(pic, "f", &f); - return pic_float_value(exp(f)); + return pic_float_value(pic, exp(f)); } static pic_value @@ -165,10 +166,10 @@ pic_number_log(pic_state *pic) argc = pic_get_args(pic, "f|f", &f, &g); if (argc == 1) { - return pic_float_value(log(f)); + return pic_float_value(pic, log(f)); } else { - return pic_float_value(log(f) / log(g)); + return pic_float_value(pic, log(f) / log(g)); } } @@ -179,7 +180,7 @@ pic_number_sin(pic_state *pic) pic_get_args(pic, "f", &f); f = sin(f); - return pic_float_value(f); + return pic_float_value(pic, f); } static pic_value @@ -189,7 +190,7 @@ pic_number_cos(pic_state *pic) pic_get_args(pic, "f", &f); f = cos(f); - return pic_float_value(f); + return pic_float_value(pic, f); } static pic_value @@ -199,7 +200,7 @@ pic_number_tan(pic_state *pic) pic_get_args(pic, "f", &f); f = tan(f); - return pic_float_value(f); + return pic_float_value(pic, f); } static pic_value @@ -209,7 +210,7 @@ pic_number_acos(pic_state *pic) pic_get_args(pic, "f", &f); f = acos(f); - return pic_float_value(f); + return pic_float_value(pic, f); } static pic_value @@ -219,7 +220,7 @@ pic_number_asin(pic_state *pic) pic_get_args(pic, "f", &f); f = asin(f); - return pic_float_value(f); + return pic_float_value(pic, f); } static pic_value @@ -231,10 +232,10 @@ pic_number_atan(pic_state *pic) argc = pic_get_args(pic, "f|f", &f, &g); if (argc == 1) { f = atan(f); - return pic_float_value(f); + return pic_float_value(pic, f); } else { - return pic_float_value(atan2(f,g)); + return pic_float_value(pic, atan2(f,g)); } } @@ -245,7 +246,7 @@ pic_number_sqrt(pic_state *pic) pic_get_args(pic, "f", &f); - return pic_float_value(sqrt(f)); + return pic_float_value(pic, sqrt(f)); } static pic_value @@ -257,10 +258,10 @@ pic_number_abs(pic_state *pic) pic_get_args(pic, "F", &f, &e); if (e) { - return pic_int_value(f < 0 ? -f : f); + return pic_int_value(pic, f < 0 ? -f : f); } else { - return pic_float_value(fabs(f)); + return pic_float_value(pic, fabs(f)); } } @@ -275,36 +276,36 @@ pic_number_expt(pic_state *pic) h = pow(f, g); if (e1 && e2) { if (h <= INT_MAX) { - return pic_int_value((int)h); + return pic_int_value(pic, (int)h); } } - return pic_float_value(h); + return pic_float_value(pic, h); } void pic_init_math(pic_state *pic) { - pic_deflibrary (pic, "(picrin math)") { - pic_defun(pic, "floor/", pic_number_floor2); - pic_defun(pic, "truncate/", pic_number_trunc2); - pic_defun(pic, "floor", pic_number_floor); - pic_defun(pic, "ceiling", pic_number_ceil); - pic_defun(pic, "truncate", pic_number_trunc); - pic_defun(pic, "round", pic_number_round); + pic_deflibrary(pic, "picrin.math"); - pic_defun(pic, "finite?", pic_number_finite_p); - pic_defun(pic, "infinite?", pic_number_infinite_p); - pic_defun(pic, "nan?", pic_number_nan_p); - pic_defun(pic, "sqrt", pic_number_sqrt); - pic_defun(pic, "exp", pic_number_exp); - pic_defun(pic, "log", pic_number_log); - pic_defun(pic, "sin", pic_number_sin); - pic_defun(pic, "cos", pic_number_cos); - pic_defun(pic, "tan", pic_number_tan); - pic_defun(pic, "acos", pic_number_acos); - pic_defun(pic, "asin", pic_number_asin); - pic_defun(pic, "atan", pic_number_atan); - pic_defun(pic, "abs", pic_number_abs); - pic_defun(pic, "expt", pic_number_expt); - } + pic_defun(pic, "floor/", pic_number_floor2); + pic_defun(pic, "truncate/", pic_number_trunc2); + pic_defun(pic, "floor", pic_number_floor); + pic_defun(pic, "ceiling", pic_number_ceil); + pic_defun(pic, "truncate", pic_number_trunc); + pic_defun(pic, "round", pic_number_round); + + pic_defun(pic, "finite?", pic_number_finite_p); + pic_defun(pic, "infinite?", pic_number_infinite_p); + pic_defun(pic, "nan?", pic_number_nan_p); + pic_defun(pic, "sqrt", pic_number_sqrt); + pic_defun(pic, "exp", pic_number_exp); + pic_defun(pic, "log", pic_number_log); + pic_defun(pic, "sin", pic_number_sin); + pic_defun(pic, "cos", pic_number_cos); + pic_defun(pic, "tan", pic_number_tan); + pic_defun(pic, "acos", pic_number_acos); + pic_defun(pic, "asin", pic_number_asin); + pic_defun(pic, "atan", pic_number_atan); + pic_defun(pic, "abs", pic_number_abs); + pic_defun(pic, "expt", pic_number_expt); } diff --git a/contrib/20.r7rs/nitro.mk b/contrib/20.r7rs/nitro.mk index 235a68c8..085da6e6 100644 --- a/contrib/20.r7rs/nitro.mk +++ b/contrib/20.r7rs/nitro.mk @@ -4,7 +4,6 @@ CONTRIB_SRCS += \ contrib/20.r7rs/src/r7rs.c\ contrib/20.r7rs/src/file.c\ contrib/20.r7rs/src/load.c\ - contrib/20.r7rs/src/mutable-string.c\ contrib/20.r7rs/src/system.c\ contrib/20.r7rs/src/time.c diff --git a/contrib/20.r7rs/scheme/base.scm b/contrib/20.r7rs/scheme/base.scm index 1d722289..162128f5 100644 --- a/contrib/20.r7rs/scheme/base.scm +++ b/contrib/20.r7rs/scheme/base.scm @@ -13,7 +13,6 @@ nan? infinite?) (picrin macro) - (picrin string) (scheme file)) ;; 4.1.2. Literal expressions @@ -776,6 +775,68 @@ ;; 6.13. Input and output + (define (input-port-open? port) + (and (input-port? port) (port-open? port))) + + (define (output-port-open? port) + (and (output-port? port) (port-open? port))) + + (define (call-with-port port handler) + (let ((res (handler port))) + (close-port port) + res)) + + (define (open-input-string str) + (open-input-bytevector (list->bytevector (map char->integer (string->list str))))) + + (define (open-output-string) + (open-output-bytevector)) + + (define (get-output-string port) + (list->string (map integer->char (bytevector->list (get-output-bytevector port))))) + + (define (read-char . opt) + (let ((b (apply read-u8 opt))) + (if (eof-object? b) + b + (integer->char b)))) + + (define (peek-char . opt) + (let ((b (apply peek-u8 opt))) + (if (eof-object? b) + b + (integer->char b)))) + + (define (char-ready? . opt) + (apply u8-ready? opt)) + + (define (newline . opt) + (apply write-u8 (char->integer #\newline) opt)) + + (define (write-char c . opt) + (apply write-u8 (char->integer c) opt)) + + (define (write-string s . opt) + (apply write-bytevector (list->bytevector (map char->integer (string->list s))) opt)) + + (define (read-line . opt) + (if (eof-object? (apply peek-char opt)) + (eof-object) + (let loop ((str "") (c (apply read-char opt))) + (if (or (eof-object? c) + (char=? c #\newline)) + str + (loop (string-append str (string c)) (apply read-char opt)))))) + + (define (read-string k . opt) + (if (eof-object? (apply peek-char opt)) + (eof-object) + (let loop ((k k) (str "") (c (apply read-char opt))) + (if (or (eof-object? c) + (zero? k)) + str + (loop (- k 1) (string-append str (string c)) (apply read-char opt)))))) + (export current-input-port current-output-port current-error-port @@ -785,11 +846,11 @@ port? input-port? output-port? - textual-port? - binary-port? + (rename port? textual-port?) + (rename port? binary-port?) - (rename port-open? input-port-open?) - (rename port-open? output-port-open?) + input-port-open? + output-port-open? close-port (rename close-port close-input-port) (rename close-port close-output-port) diff --git a/contrib/20.r7rs/scheme/eval.scm b/contrib/20.r7rs/scheme/eval.scm index c914ad7d..598d99b8 100644 --- a/contrib/20.r7rs/scheme/eval.scm +++ b/contrib/20.r7rs/scheme/eval.scm @@ -6,14 +6,11 @@ (define-syntax (inc! n) #`(set! #,n (+ #,n 1))) - (define (number->symbol n) - (string->symbol (number->string n))) - (define (environment . specs) - (let ((library-name `(picrin @@my-environment ,(number->symbol counter)))) + (let ((lib (string-append "picrin.@@my-environment." (number->string counter)))) (inc! counter) - (let ((lib (make-library library-name))) - (eval `(import ,@specs) lib) - lib))) + (make-library lib) + (eval `(import ,@specs) lib) + lib)) (export environment eval)) diff --git a/contrib/20.r7rs/scheme/r5rs.scm b/contrib/20.r7rs/scheme/r5rs.scm index 7d557027..a9f20eb2 100644 --- a/contrib/20.r7rs/scheme/r5rs.scm +++ b/contrib/20.r7rs/scheme/r5rs.scm @@ -28,12 +28,12 @@ (define (null-environment n) (if (not (= n 5)) (error "unsupported environment version" n) - (find-library '(scheme null)))) + "scheme.null")) (define (scheme-report-environment n) (if (not (= n 5)) (error "unsupported environment version" n) - (find-library '(scheme r5rs)))) + "scheme.r5rs")) (export * + - / < <= = > >= abs acos and diff --git a/contrib/20.r7rs/src/file.c b/contrib/20.r7rs/src/file.c index d13f77b2..60e23508 100644 --- a/contrib/20.r7rs/src/file.c +++ b/contrib/20.r7rs/src/file.c @@ -3,61 +3,45 @@ */ #include "picrin.h" +#include "picrin/extra.h" #include PIC_NORETURN static void file_error(pic_state *pic, const char *msg) { - struct pic_error *e; + pic_raise(pic, pic_make_error(pic, "file", msg, pic_nil_value(pic))); +} - e = pic_make_error(pic, pic_intern_lit(pic, "file"), msg, pic_nil_value()); +static pic_value +open_file(pic_state *pic, const char *fname, const char *mode) +{ + FILE *fp; - pic_raise(pic, pic_obj_value(e)); + if ((fp = fopen(fname, mode)) == NULL) { + file_error(pic, "could not open file..."); + } + return pic_open_port(pic, xfopen_file(pic, fp, mode)); } pic_value pic_file_open_input_file(pic_state *pic) { - static const short flags = PIC_PORT_IN | PIC_PORT_TEXT; char *fname; pic_get_args(pic, "z", &fname); - return pic_obj_value(pic_open_file(pic, fname, flags)); -} - -pic_value -pic_file_open_binary_input_file(pic_state *pic) -{ - static const short flags = PIC_PORT_IN | PIC_PORT_BINARY; - char *fname; - - pic_get_args(pic, "z", &fname); - - return pic_obj_value(pic_open_file(pic, fname, flags)); + return open_file(pic, fname, "r"); } pic_value pic_file_open_output_file(pic_state *pic) { - static const short flags = PIC_PORT_OUT | PIC_PORT_TEXT; char *fname; pic_get_args(pic, "z", &fname); - return pic_obj_value(pic_open_file(pic, fname, flags)); -} - -pic_value -pic_file_open_binary_output_file(pic_state *pic) -{ - static const short flags = PIC_PORT_OUT | PIC_PORT_BINARY; - char *fname; - - pic_get_args(pic, "z", &fname); - - return pic_obj_value(pic_open_file(pic, fname, flags)); + return open_file(pic, fname, "w"); } pic_value @@ -71,9 +55,9 @@ pic_file_exists_p(pic_state *pic) fp = fopen(fname, "r"); if (fp) { fclose(fp); - return pic_true_value(); + return pic_true_value(pic); } else { - return pic_false_value(); + return pic_false_value(pic); } } @@ -87,18 +71,18 @@ pic_file_delete(pic_state *pic) if (remove(fname) != 0) { file_error(pic, "file cannot be deleted"); } - return pic_undef_value(); + return pic_undef_value(pic); } void pic_init_file(pic_state *pic) { - pic_deflibrary (pic, "(scheme file)") { - pic_defun(pic, "open-input-file", pic_file_open_input_file); - pic_defun(pic, "open-binary-input-file", pic_file_open_binary_input_file); - pic_defun(pic, "open-output-file", pic_file_open_output_file); - pic_defun(pic, "open-binary-output-file", pic_file_open_binary_output_file); - pic_defun(pic, "file-exists?", pic_file_exists_p); - pic_defun(pic, "delete-file", pic_file_delete); - } + pic_deflibrary(pic, "scheme.file"); + + pic_defun(pic, "open-input-file", pic_file_open_input_file); + pic_defun(pic, "open-binary-input-file", pic_file_open_input_file); + pic_defun(pic, "open-output-file", pic_file_open_output_file); + pic_defun(pic, "open-binary-output-file", pic_file_open_output_file); + pic_defun(pic, "file-exists?", pic_file_exists_p); + pic_defun(pic, "delete-file", pic_file_delete); } diff --git a/contrib/20.r7rs/src/load.c b/contrib/20.r7rs/src/load.c index 15cc6cae..f6f68b63 100644 --- a/contrib/20.r7rs/src/load.c +++ b/contrib/20.r7rs/src/load.c @@ -3,29 +3,37 @@ */ #include "picrin.h" +#include "picrin/extra.h" + +#include static pic_value pic_load_load(pic_state *pic) { - pic_value envid; + pic_value envid, port; char *fn; - struct pic_port *port; + FILE *fp; pic_get_args(pic, "z|o", &fn, &envid); - port = pic_open_file(pic, fn, PIC_PORT_IN | PIC_PORT_TEXT); + fp = fopen(fn, "r"); + if (fp == NULL) { + pic_error(pic, "load: could not open file", 1, pic_cstr_value(pic, fn)); + } + + port = pic_open_port(pic, xfopen_file(pic, fp, "r")); pic_load(pic, port); pic_close_port(pic, port); - return pic_undef_value(); + return pic_undef_value(pic); } void pic_init_load(pic_state *pic) { - pic_deflibrary (pic, "(scheme load)") { - pic_defun(pic, "load", pic_load_load); - } + pic_deflibrary(pic, "scheme.load"); + + pic_defun(pic, "load", pic_load_load); } diff --git a/contrib/20.r7rs/src/mutable-string.c b/contrib/20.r7rs/src/mutable-string.c deleted file mode 100644 index 0f5817d7..00000000 --- a/contrib/20.r7rs/src/mutable-string.c +++ /dev/null @@ -1,93 +0,0 @@ -#include "picrin.h" - -void -pic_str_set(pic_state *pic, pic_str *str, int i, char c) -{ - pic_str *x, *y, *z, *tmp; - char buf[1]; - - if (pic_str_len(str) <= i) { - pic_errorf(pic, "index out of range %d", i); - } - - buf[0] = c; - - x = pic_str_sub(pic, str, 0, i); - y = pic_make_str(pic, buf, 1); - z = pic_str_sub(pic, str, i + 1, pic_str_len(str)); - - tmp = pic_str_cat(pic, x, pic_str_cat(pic, y, z)); - - pic_rope_incref(pic, tmp->rope); - pic_rope_decref(pic, str->rope); - str->rope = tmp->rope; -} - -static pic_value -pic_str_string_set(pic_state *pic) -{ - pic_str *str; - char c; - int k; - - pic_get_args(pic, "sic", &str, &k, &c); - - pic_str_set(pic, str, k, c); - return pic_undef_value(); -} - -static pic_value -pic_str_string_copy_ip(pic_state *pic) -{ - pic_str *to, *from; - int n, at, start, end; - - n = pic_get_args(pic, "sis|ii", &to, &at, &from, &start, &end); - - switch (n) { - case 3: - start = 0; - case 4: - end = pic_str_len(from); - } - if (to == from) { - from = pic_str_sub(pic, from, 0, end); - } - - while (start < end) { - pic_str_set(pic, to, at++, pic_str_ref(pic, from, start++)); - } - return pic_undef_value(); -} - -static pic_value -pic_str_string_fill_ip(pic_state *pic) -{ - pic_str *str; - char c; - int n, start, end; - - n = pic_get_args(pic, "sc|ii", &str, &c, &start, &end); - - switch (n) { - case 2: - start = 0; - case 3: - end = pic_str_len(str); - } - - while (start < end) { - pic_str_set(pic, str, start++, c); - } - return pic_undef_value(); -} - -void -pic_init_mutable_string(pic_state *pic) -{ - pic_deflibrary (pic, "(picrin string)") { - pic_defun(pic, "string-set!", pic_str_string_set); - pic_defun(pic, "string-copy!", pic_str_string_copy_ip); - pic_defun(pic, "string-fill!", pic_str_string_fill_ip); - } -} diff --git a/contrib/20.r7rs/src/r7rs.c b/contrib/20.r7rs/src/r7rs.c index ad3090aa..43f98ed4 100644 --- a/contrib/20.r7rs/src/r7rs.c +++ b/contrib/20.r7rs/src/r7rs.c @@ -6,7 +6,6 @@ void pic_init_file(pic_state *); void pic_init_load(pic_state *); -void pic_init_mutable_string(pic_state *); void pic_init_system(pic_state *); void pic_init_time(pic_state *); @@ -15,7 +14,8 @@ pic_init_r7rs(pic_state *pic) { pic_init_file(pic); pic_init_load(pic); - pic_init_mutable_string(pic); pic_init_system(pic); pic_init_time(pic); + + pic_add_feature(pic, "r7rs"); } diff --git a/contrib/20.r7rs/src/system.c b/contrib/20.r7rs/src/system.c index 7cda6527..4d0fdb15 100644 --- a/contrib/20.r7rs/src/system.c +++ b/contrib/20.r7rs/src/system.c @@ -5,6 +5,7 @@ #include #include "picrin.h" +#include "picrin/extra.h" extern int picrin_argc; extern char **picrin_argv; @@ -13,18 +14,14 @@ extern char **picrin_envp; static pic_value pic_system_cmdline(pic_state *pic) { - pic_value v = pic_nil_value(); + pic_value v = pic_nil_value(pic); int i; pic_get_args(pic, ""); for (i = 0; i < picrin_argc; ++i) { - size_t ai = pic_gc_arena_preserve(pic); - - v = pic_cons(pic, pic_obj_value(pic_make_cstr(pic, picrin_argv[i])), v); - pic_gc_arena_restore(pic, ai); + pic_push(pic, pic_cstr_value(pic, picrin_argv[i]), v); } - return pic_reverse(pic, v); } @@ -36,12 +33,12 @@ pic_system_exit(pic_state *pic) argc = pic_get_args(pic, "|o", &v); if (argc == 1) { - switch (pic_type(v)) { - case PIC_TT_FLOAT: - status = (int)pic_float(v); + switch (pic_type(pic, v)) { + case PIC_TYPE_FLOAT: + status = (int)pic_float(pic, v); break; - case PIC_TT_INT: - status = pic_int(v); + case PIC_TYPE_INT: + status = pic_int(pic, v); break; default: break; @@ -61,12 +58,12 @@ pic_system_emergency_exit(pic_state *pic) argc = pic_get_args(pic, "|o", &v); if (argc == 1) { - switch (pic_type(v)) { - case PIC_TT_FLOAT: - status = (int)pic_float(v); + switch (pic_type(pic, v)) { + case PIC_TYPE_FLOAT: + status = (int)pic_float(pic, v); break; - case PIC_TT_INT: - status = pic_int(v); + case PIC_TYPE_INT: + status = pic_int(pic, v); break; default: break; @@ -86,39 +83,39 @@ pic_system_getenv(pic_state *pic) val = getenv(str); if (val == NULL) - return pic_nil_value(); + return pic_nil_value(pic); else - return pic_obj_value(pic_make_cstr(pic, val)); + return pic_cstr_value(pic, val); } static pic_value pic_system_getenvs(pic_state *pic) { char **envp; - pic_value data = pic_nil_value(); - size_t ai = pic_gc_arena_preserve(pic); + pic_value data = pic_nil_value(pic); + size_t ai = pic_enter(pic); pic_get_args(pic, ""); if (! picrin_envp) { - return pic_nil_value(); + return pic_nil_value(pic); } for (envp = picrin_envp; *envp; ++envp) { - pic_str *key, *val; + pic_value key, val; int i; for (i = 0; (*envp)[i] != '='; ++i) ; - key = pic_make_str(pic, *envp, i); - val = pic_make_cstr(pic, getenv(pic_str_cstr(pic, key))); + key = pic_str_value(pic, *envp, i); + val = pic_cstr_value(pic, getenv(pic_str(pic, key))); /* push */ - data = pic_acons(pic, pic_obj_value(key), pic_obj_value(val), data); + data = pic_cons(pic, pic_cons(pic, key, val), data); - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, data); + pic_leave(pic, ai); + pic_protect(pic, data); } return data; @@ -127,11 +124,11 @@ pic_system_getenvs(pic_state *pic) void pic_init_system(pic_state *pic) { - pic_deflibrary (pic, "(scheme process-context)") { - pic_defun(pic, "command-line", pic_system_cmdline); - pic_defun(pic, "exit", pic_system_exit); - pic_defun(pic, "emergency-exit", pic_system_emergency_exit); - pic_defun(pic, "get-environment-variable", pic_system_getenv); - pic_defun(pic, "get-environment-variables", pic_system_getenvs); - } + pic_deflibrary(pic, "scheme.process-context"); + + pic_defun(pic, "command-line", pic_system_cmdline); + pic_defun(pic, "exit", pic_system_exit); + pic_defun(pic, "emergency-exit", pic_system_emergency_exit); + pic_defun(pic, "get-environment-variable", pic_system_getenv); + pic_defun(pic, "get-environment-variables", pic_system_getenvs); } diff --git a/contrib/20.r7rs/src/time.c b/contrib/20.r7rs/src/time.c index 6ed8420d..5c325bbd 100644 --- a/contrib/20.r7rs/src/time.c +++ b/contrib/20.r7rs/src/time.c @@ -5,6 +5,7 @@ #include #include "picrin.h" +#include "picrin/extra.h" #define UTC_TAI_DIFF 35 @@ -16,7 +17,7 @@ pic_current_second(pic_state *pic) pic_get_args(pic, ""); time(&t); - return pic_float_value((double)t + UTC_TAI_DIFF); + return pic_float_value(pic, (double)t + UTC_TAI_DIFF); } static pic_value @@ -27,7 +28,7 @@ pic_current_jiffy(pic_state *pic) pic_get_args(pic, ""); c = clock(); - return pic_int_value((int)c); /* The year 2038 problem :-| */ + return pic_int_value(pic, (int)c); /* The year 2038 problem :-| */ } static pic_value @@ -35,15 +36,15 @@ pic_jiffies_per_second(pic_state *pic) { pic_get_args(pic, ""); - return pic_int_value(CLOCKS_PER_SEC); + return pic_int_value(pic, CLOCKS_PER_SEC); } void pic_init_time(pic_state *pic) { - pic_deflibrary (pic, "(scheme time)") { - pic_defun(pic, "current-second", pic_current_second); - pic_defun(pic, "current-jiffy", pic_current_jiffy); - pic_defun(pic, "jiffies-per-second", pic_jiffies_per_second); - } + pic_deflibrary(pic, "scheme.time"); + + pic_defun(pic, "current-second", pic_current_second); + pic_defun(pic, "current-jiffy", pic_current_jiffy); + pic_defun(pic, "jiffies-per-second", pic_jiffies_per_second); } diff --git a/contrib/20.r7rs/t/r7rs.scm b/contrib/20.r7rs/t/r7rs.scm index 4185724d..f329d781 100644 --- a/contrib/20.r7rs/t/r7rs.scm +++ b/contrib/20.r7rs/t/r7rs.scm @@ -1766,6 +1766,8 @@ (test 'exception value) (test "condition: an-error!" (get-output-string out))) +(flush-output-port) + (define (test-exception-handler-4 v out) (call-with-current-continuation (lambda (k) diff --git a/contrib/30.random/src/random.c b/contrib/30.random/src/random.c index a750f92b..2c7f9d6f 100644 --- a/contrib/30.random/src/random.c +++ b/contrib/30.random/src/random.c @@ -1,4 +1,5 @@ #include "picrin.h" +#include "picrin/extra.h" double genrand_real3(void); @@ -7,13 +8,13 @@ pic_random_real(pic_state *pic) { pic_get_args(pic, ""); - return pic_float_value(genrand_real3()); + return pic_float_value(pic, genrand_real3()); } void pic_init_random(pic_state *pic) { - pic_deflibrary (pic, "(srfi 27)") { - pic_defun(pic, "random-real", pic_random_real); - } + pic_deflibrary(pic, "srfi.27"); + + pic_defun(pic, "random-real", pic_random_real); } diff --git a/contrib/30.readline/src/readline.c b/contrib/30.readline/src/readline.c index d6e71d6a..2a58b2c6 100644 --- a/contrib/30.readline/src/readline.c +++ b/contrib/30.readline/src/readline.c @@ -6,6 +6,7 @@ forget to use the C++ extern "C" to get it to compile. */ #include "picrin.h" +#include "picrin/extra.h" #include @@ -19,9 +20,9 @@ pic_rl_readline(pic_state *pic) result = readline(prompt); if(result) - return pic_obj_value(pic_make_cstr(pic, result)); + return pic_cstr_value(pic, result); else - return pic_eof_object(); + return pic_eof_object(pic); } static pic_value @@ -29,7 +30,7 @@ pic_rl_history_length(pic_state *pic) { pic_get_args(pic, ""); - return pic_int_value(history_get_history_state()->length); + return pic_int_value(pic, history_get_history_state()->length); } static pic_value @@ -41,7 +42,7 @@ pic_rl_add_history(pic_state *pic) add_history(line); - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value @@ -53,7 +54,7 @@ pic_rl_stifle_history(pic_state *pic) stifle_history(i); - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value @@ -63,7 +64,7 @@ pic_rl_unstifle_history(pic_state *pic) unstifle_history(); - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value @@ -71,7 +72,7 @@ pic_rl_history_is_stifled(pic_state *pic) { pic_get_args(pic, ""); - return pic_bool_value(history_is_stifled()); + return pic_bool_value(pic, history_is_stifled()); } static pic_value @@ -79,7 +80,7 @@ pic_rl_where_history(pic_state *pic) { pic_get_args(pic, ""); - return pic_int_value(where_history()); + return pic_int_value(pic, where_history()); } static pic_value @@ -87,7 +88,7 @@ pic_rl_current_history(pic_state *pic) { pic_get_args(pic, ""); - return pic_obj_value(pic_make_cstr(pic, current_history()->line)); + return pic_cstr_value(pic, current_history()->line); } static pic_value @@ -100,8 +101,7 @@ pic_rl_history_get(pic_state *pic) e = history_get(i); - return e ? pic_obj_value(pic_make_cstr(pic, e->line)) - : pic_false_value(); + return e ? pic_cstr_value(pic, e->line) : pic_false_value(pic); } static pic_value @@ -114,8 +114,7 @@ pic_rl_remove_history(pic_state *pic) e = remove_history(i); - return e ? pic_obj_value(pic_make_cstr(pic, e->line)) - : pic_false_value(); + return e ? pic_cstr_value(pic, e->line) : pic_false_value(pic); } static pic_value @@ -125,7 +124,7 @@ pic_rl_clear_history(pic_state *pic) clear_history(); - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value @@ -136,7 +135,7 @@ pic_rl_history_set_pos(pic_state *pic) pic_get_args(pic, "i", &i); - return pic_int_value(history_set_pos(i)); + return pic_int_value(pic, history_set_pos(i)); } static pic_value @@ -148,8 +147,7 @@ pic_rl_previous_history(pic_state *pic) e = previous_history(); - return e ? pic_obj_value(pic_make_cstr(pic, e->line)) - : pic_false_value(); + return e ? pic_cstr_value(pic, e->line) : pic_false_value(pic); } static pic_value @@ -161,8 +159,7 @@ pic_rl_next_history(pic_state *pic) e = next_history(); - return e ? pic_obj_value(pic_make_cstr(pic, e->line)) - : pic_false_value(); + return e ? pic_cstr_value(pic, e->line) : pic_false_value(pic); } static pic_value @@ -173,9 +170,9 @@ pic_rl_history_search(pic_state *pic) argc = pic_get_args(pic, "zi|i", &key, &direction, &pos); if(argc == 2) - return pic_int_value(history_search(key, direction)); + return pic_int_value(pic, history_search(key, direction)); else - return pic_int_value(history_search_pos(key, direction, pos)); + return pic_int_value(pic, history_search_pos(key, direction, pos)); } static pic_value @@ -186,7 +183,7 @@ pic_rl_history_search_prefix(pic_state *pic) pic_get_args(pic, "zi", &key, &direction); - return pic_int_value(history_search_prefix(key, direction)); + return pic_int_value(pic, history_search_prefix(key, direction)); } static pic_value @@ -197,9 +194,9 @@ pic_rl_read_history(pic_state *pic) pic_get_args(pic, "z", &filename); if(read_history(filename)) - pic_errorf(pic, "cannot read history file : %s", filename); + pic_error(pic, "cannot read history file", 1, pic_cstr_value(pic, filename)); - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value @@ -210,9 +207,9 @@ pic_rl_write_history(pic_state *pic) pic_get_args(pic, "z", &filename); if(write_history(filename)) - pic_errorf(pic, "cannot write history file: %s", filename); + pic_error(pic, "cannot write history file", 1, pic_cstr_value(pic, filename)); - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value @@ -225,7 +222,7 @@ pic_rl_truncate_file(pic_state *pic) history_truncate_file(filename, i); - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value @@ -238,37 +235,39 @@ pic_rl_history_expand(pic_state *pic) status = history_expand(input, &result); if(status == -1 || status == 2) - pic_errorf(pic, "%s\n", result); + pic_error(pic, result, 0); - return pic_obj_value(pic_make_cstr(pic, result)); + return pic_cstr_value(pic, result); } void pic_init_readline(pic_state *pic){ using_history(); - pic_deflibrary (pic, "(picrin readline)") { - pic_defun(pic, "readline", pic_rl_readline); - } - pic_deflibrary (pic, "(picrin readline history)") { - /* pic_defun(pic, "history-offset", pic_rl_history_offset); */ - pic_defun(pic, "history-length", pic_rl_history_length); - pic_defun(pic, "add-history", pic_rl_add_history); - pic_defun(pic, "stifle-history", pic_rl_stifle_history); - pic_defun(pic, "unstifle-history", pic_rl_unstifle_history); - pic_defun(pic, "history-stifled?", pic_rl_history_is_stifled); - pic_defun(pic, "where-history", pic_rl_where_history); - pic_defun(pic, "current-history", pic_rl_current_history); - pic_defun(pic, "history-get", pic_rl_history_get); - pic_defun(pic, "clear-history", pic_rl_clear_history); - pic_defun(pic, "remove-history", pic_rl_remove_history); - pic_defun(pic, "history-set-pos", pic_rl_history_set_pos); - pic_defun(pic, "previous-history", pic_rl_previous_history); - pic_defun(pic, "next-history", pic_rl_next_history); - pic_defun(pic, "history-search", pic_rl_history_search); - pic_defun(pic, "history-search-prefix", pic_rl_history_search_prefix); - pic_defun(pic, "read-history", pic_rl_read_history); - pic_defun(pic, "write-history", pic_rl_write_history); - pic_defun(pic, "truncate-file", pic_rl_truncate_file); - pic_defun(pic, "history-expand", pic_rl_history_expand); - } + + pic_deflibrary(pic, "picrin.readline"); + + pic_defun(pic, "readline", pic_rl_readline); + + pic_deflibrary(pic, "picrin.readline.history"); + + /* pic_defun(pic, "history-offset", pic_rl_history_offset); */ + pic_defun(pic, "history-length", pic_rl_history_length); + pic_defun(pic, "add-history", pic_rl_add_history); + pic_defun(pic, "stifle-history", pic_rl_stifle_history); + pic_defun(pic, "unstifle-history", pic_rl_unstifle_history); + pic_defun(pic, "history-stifled?", pic_rl_history_is_stifled); + pic_defun(pic, "where-history", pic_rl_where_history); + pic_defun(pic, "current-history", pic_rl_current_history); + pic_defun(pic, "history-get", pic_rl_history_get); + pic_defun(pic, "clear-history", pic_rl_clear_history); + pic_defun(pic, "remove-history", pic_rl_remove_history); + pic_defun(pic, "history-set-pos", pic_rl_history_set_pos); + pic_defun(pic, "previous-history", pic_rl_previous_history); + pic_defun(pic, "next-history", pic_rl_next_history); + pic_defun(pic, "history-search", pic_rl_history_search); + pic_defun(pic, "history-search-prefix", pic_rl_history_search_prefix); + pic_defun(pic, "read-history", pic_rl_read_history); + pic_defun(pic, "write-history", pic_rl_write_history); + pic_defun(pic, "truncate-file", pic_rl_truncate_file); + pic_defun(pic, "history-expand", pic_rl_history_expand); } diff --git a/contrib/30.regexp/src/regexp.c b/contrib/30.regexp/src/regexp.c index 2af663dd..c428ad1c 100644 --- a/contrib/30.regexp/src/regexp.c +++ b/contrib/30.regexp/src/regexp.c @@ -1,4 +1,5 @@ #include "picrin.h" +#include "picrin/extra.h" #include @@ -19,9 +20,6 @@ regexp_dtor(pic_state *pic, void *data) static const pic_data_type regexp_type = { "regexp", regexp_dtor, NULL }; -#define pic_regexp_p(o) (pic_data_type_p((o), ®exp_type)) -#define pic_regexp_data_ptr(o) ((struct pic_regexp_t *)pic_data_ptr(o)->data) - static pic_value pic_regexp_regexp(pic_state *pic) { @@ -59,10 +57,10 @@ pic_regexp_regexp(pic_state *pic) regerror(err, ®->reg, errbuf, sizeof errbuf); regexp_dtor(pic, ®->reg); - pic_errorf(pic, "regexp compilation error: %s", errbuf); + pic_error(pic, "regexp compilation error", 1, pic_cstr_value(pic, errbuf)); } - return pic_obj_value(pic_data_alloc(pic, ®exp_type, reg)); + return pic_data_value(pic, reg, ®exp_type); } static pic_value @@ -72,33 +70,30 @@ pic_regexp_regexp_p(pic_state *pic) pic_get_args(pic, "o", &obj); - return pic_bool_value(pic_regexp_p(obj)); + return pic_bool_value(pic, pic_data_p(pic, obj, ®exp_type)); } static pic_value pic_regexp_regexp_match(pic_state *pic) { - pic_value reg; + struct pic_regexp_t *reg; const char *input; regmatch_t match[100]; - pic_value matches, positions; - pic_str *str; + pic_value str, matches, positions; int i, offset; - pic_get_args(pic, "oz", ®, &input); + pic_get_args(pic, "uz", ®, ®exp_type, &input); - pic_assert_type(pic, reg, regexp); + matches = pic_nil_value(pic); + positions = pic_nil_value(pic); - matches = pic_nil_value(); - positions = pic_nil_value(); - - if (strchr(pic_regexp_data_ptr(reg)->flags, 'g') != NULL) { + if (strchr(reg->flags, 'g') != NULL) { /* global search */ offset = 0; - while (regexec(&pic_regexp_data_ptr(reg)->reg, input, 1, match, 0) != REG_NOMATCH) { - pic_push(pic, pic_obj_value(pic_make_str(pic, input, match[0].rm_eo - match[0].rm_so)), matches); - pic_push(pic, pic_int_value(offset), positions); + while (regexec(®->reg, input, 1, match, 0) != REG_NOMATCH) { + pic_push(pic, pic_str_value(pic, input, match[0].rm_eo - match[0].rm_so), matches); + pic_push(pic, pic_int_value(pic, offset), positions); offset += match[0].rm_eo; input += match[0].rm_eo; @@ -106,47 +101,45 @@ pic_regexp_regexp_match(pic_state *pic) } else { /* local search */ - if (regexec(&pic_regexp_data_ptr(reg)->reg, input, 100, match, 0) == 0) { + if (regexec(®->reg, input, 100, match, 0) == 0) { for (i = 0; i < 100; ++i) { if (match[i].rm_so == -1) { break; } - str = pic_make_str(pic, input + match[i].rm_so, match[i].rm_eo - match[i].rm_so); - pic_push(pic, pic_obj_value(str), matches); - pic_push(pic, pic_int_value(match[i].rm_so), positions); + str = pic_str_value(pic, input + match[i].rm_so, match[i].rm_eo - match[i].rm_so); + pic_push(pic, str, matches); + pic_push(pic, pic_int_value(pic, match[i].rm_so), positions); } } } - if (pic_nil_p(matches)) { - matches = pic_false_value(); - positions = pic_false_value(); + if (pic_nil_p(pic, matches)) { + matches = pic_false_value(pic); + positions = pic_false_value(pic); } else { matches = pic_reverse(pic, matches); positions = pic_reverse(pic, positions); } - return pic_values2(pic, matches, positions); + return pic_return(pic, 2, matches, positions); } static pic_value pic_regexp_regexp_split(pic_state *pic) { - pic_value reg; + struct pic_regexp_t *reg; const char *input; regmatch_t match; - pic_value output = pic_nil_value(); + pic_value output = pic_nil_value(pic); - pic_get_args(pic, "oz", ®, &input); + pic_get_args(pic, "uz", ®, ®exp_type, &input); - pic_assert_type(pic, reg, regexp); - - while (regexec(&pic_regexp_data_ptr(reg)->reg, input, 1, &match, 0) != REG_NOMATCH) { - pic_push(pic, pic_obj_value(pic_make_str(pic, input, match.rm_so)), output); + while (regexec(®->reg, input, 1, &match, 0) != REG_NOMATCH) { + pic_push(pic, pic_str_value(pic, input, match.rm_so), output); input += match.rm_eo; } - pic_push(pic, pic_obj_value(pic_make_cstr(pic, input)), output); + pic_push(pic, pic_cstr_value(pic, input), output); return pic_reverse(pic, output); } @@ -154,36 +147,32 @@ pic_regexp_regexp_split(pic_state *pic) static pic_value pic_regexp_regexp_replace(pic_state *pic) { - pic_value reg; + struct pic_regexp_t *reg; const char *input; regmatch_t match; - pic_str *txt, *output = pic_make_lit(pic, ""); + pic_value txt, output = pic_lit_value(pic, ""); - pic_get_args(pic, "ozs", ®, &input, &txt); + pic_get_args(pic, "uzs", ®, ®exp_type, &input, &txt); - pic_assert_type(pic, reg, regexp); - - while (regexec(&pic_regexp_data_ptr(reg)->reg, input, 1, &match, 0) != REG_NOMATCH) { - output = pic_str_cat(pic, output, pic_make_str(pic, input, match.rm_so)); + while (regexec(®->reg, input, 1, &match, 0) != REG_NOMATCH) { + output = pic_str_cat(pic, output, pic_str_value(pic, input, match.rm_so)); output = pic_str_cat(pic, output, txt); input += match.rm_eo; } - output = pic_str_cat(pic, output, pic_make_str(pic, input, strlen(input))); - - return pic_obj_value(output); + return pic_str_cat(pic, output, pic_str_value(pic, input, strlen(input))); } void pic_init_regexp(pic_state *pic) { - pic_deflibrary (pic, "(picrin regexp)") { - pic_defun(pic, "regexp", pic_regexp_regexp); - pic_defun(pic, "regexp?", pic_regexp_regexp_p); - pic_defun(pic, "regexp-match", pic_regexp_regexp_match); - /* pic_defun(pic, "regexp-search", pic_regexp_regexp_search); */ - pic_defun(pic, "regexp-split", pic_regexp_regexp_split); - pic_defun(pic, "regexp-replace", pic_regexp_regexp_replace); - } + pic_deflibrary(pic, "picrin.regexp"); + + pic_defun(pic, "regexp", pic_regexp_regexp); + pic_defun(pic, "regexp?", pic_regexp_regexp_p); + pic_defun(pic, "regexp-match", pic_regexp_regexp_match); + /* pic_defun(pic, "regexp-search", pic_regexp_regexp_search); */ + pic_defun(pic, "regexp-split", pic_regexp_regexp_split); + pic_defun(pic, "regexp-replace", pic_regexp_regexp_replace); } diff --git a/contrib/40.srfi/src/106.c b/contrib/40.srfi/src/106.c index b7328172..2ffec60a 100644 --- a/contrib/40.srfi/src/106.c +++ b/contrib/40.srfi/src/106.c @@ -1,4 +1,5 @@ #include "picrin.h" +#include "picrin/extra.h" #include #include @@ -30,7 +31,7 @@ PIC_INLINE void ensure_socket_is_open(pic_state *pic, struct pic_socket_t *sock) { if (sock != NULL && sock->fd == -1) { - pic_errorf(pic, "the socket is already closed"); + pic_error(pic, "the socket is already closed", 0); } } @@ -46,45 +47,29 @@ socket_dtor(pic_state *pic, void *data) static const pic_data_type socket_type = { "socket", socket_dtor, NULL }; -#define pic_socket_p(o) (pic_data_type_p((o), &socket_type)) -#define pic_socket_data_ptr(o) ((struct pic_socket_t *)pic_data_ptr(o)->data) - -PIC_INLINE void -validate_socket_object(pic_state *pic, pic_value v) -{ - if (! pic_socket_p(v)) { - pic_errorf(pic, "~s is not a socket object", v); - } -} - static pic_value pic_socket_socket_p(pic_state *pic) { pic_value obj; pic_get_args(pic, "o", &obj); - return pic_bool_value(pic_socket_p(obj)); + + return pic_bool_value(pic, pic_data_p(pic, obj, &socket_type)); } static pic_value pic_socket_make_socket(pic_state *pic) { - pic_value n, s; const char *node, *service; int family, socktype, flags, protocol; int result; struct addrinfo hints, *ai, *it; struct pic_socket_t *sock; - pic_get_args(pic, "ooiiii", &n, &s, &family, &socktype, &flags, &protocol); + pic_get_args(pic, "zziiii", &node, &service, &family, &socktype, &flags, &protocol); - node = service = NULL; - if (pic_str_p(n)) { - node = pic_str_cstr(pic, pic_str_ptr(n)); - } - if (pic_str_p(s)) { - service = pic_str_cstr(pic, pic_str_ptr(s)); - } + if (strlen(node) == 0) node = NULL; + if (strlen(service) == 0) service = NULL; sock = pic_malloc(pic, sizeof(struct pic_socket_t)); sock->fd = -1; @@ -102,9 +87,9 @@ pic_socket_make_socket(pic_state *pic) } while (result == EAI_AGAIN); if (result) { if (result == EAI_SYSTEM) { - pic_errorf(pic, "%s", strerror(errno)); + pic_error(pic, strerror(errno), 0); } - pic_errorf(pic, "%s", gai_strerror(result)); + pic_error(pic, gai_strerror(result), 0); } for (it = ai; it != NULL; it = it->ai_next) { @@ -144,23 +129,20 @@ pic_socket_make_socket(pic_state *pic) freeaddrinfo(ai); if (sock->fd == -1) { - pic_errorf(pic, "%s", strerror(errno)); + pic_error(pic, strerror(errno), 0); } - return pic_obj_value(pic_data_alloc(pic, &socket_type, sock)); + return pic_data_value(pic, sock, &socket_type); } static pic_value pic_socket_socket_accept(pic_state *pic) { - pic_value obj; int fd = -1; struct pic_socket_t *sock, *new_sock; - pic_get_args(pic, "o", &obj); - validate_socket_object(pic, obj); + pic_get_args(pic, "u", &sock, &socket_type); - sock = pic_socket_data_ptr(obj); ensure_socket_is_open(pic, sock); errno = 0; @@ -176,7 +158,7 @@ pic_socket_socket_accept(pic_state *pic) } else if (errno == EAGAIN || errno == EWOULDBLOCK) { continue; } else { - pic_errorf(pic, "%s", strerror(errno)); + pic_error(pic, strerror(errno), 0); } } else { break; @@ -185,27 +167,20 @@ pic_socket_socket_accept(pic_state *pic) new_sock = pic_malloc(pic, sizeof(struct pic_socket_t)); new_sock->fd = fd; - return pic_obj_value(pic_data_alloc(pic, &socket_type, new_sock)); + return pic_data_value(pic, new_sock, &socket_type); } static pic_value pic_socket_socket_send(pic_state *pic) { - pic_value obj; - struct pic_blob *bv; const unsigned char *cursor; - int flags = 0; - size_t remain, written; + int flags = 0, remain, written; struct pic_socket_t *sock; - pic_get_args(pic, "ob|i", &obj, &bv, &flags); - validate_socket_object(pic, obj); + pic_get_args(pic, "ub|i", &sock, &socket_type, &cursor, &remain, &flags); - sock = pic_socket_data_ptr(obj); ensure_socket_is_open(pic, sock); - cursor = bv->data; - remain = bv->len; written = 0; errno = 0; while (remain > 0) { @@ -216,7 +191,7 @@ pic_socket_socket_send(pic_state *pic) } else if (errno == EAGAIN || errno == EWOULDBLOCK) { break; } else { - pic_errorf(pic, "%s", strerror(errno)); + pic_error(pic, strerror(errno), 0); } } cursor += len; @@ -224,34 +199,27 @@ pic_socket_socket_send(pic_state *pic) written += len; } - return pic_int_value(written); + return pic_int_value(pic, written); } static pic_value pic_socket_socket_recv(pic_state *pic) { - pic_value obj; - struct pic_blob *bv; void *buf; int size; int flags = 0; ssize_t len; struct pic_socket_t *sock; - pic_get_args(pic, "oi|i", &obj, &size, &flags); - validate_socket_object(pic, obj); + pic_get_args(pic, "ui|i", &sock, &socket_type, &size, &flags); + if (size < 0) { - pic_errorf(pic, "size must not be negative"); + pic_error(pic, "size must not be negative", 0); } - sock = pic_socket_data_ptr(obj); ensure_socket_is_open(pic, sock); - buf = malloc(size); - if (buf == NULL && size > 0) { - /* XXX: Is it really OK? */ - pic_panic(pic, "memory exhausted"); - } + buf = pic_alloca(pic, size); errno = 0; do { @@ -259,51 +227,42 @@ pic_socket_socket_recv(pic_state *pic) } while (len < 0 && (errno == EINTR || errno == EAGAIN || errno == EWOULDBLOCK)); if (len < 0) { - free(buf); - pic_errorf(pic, "%s", strerror(errno)); + pic_error(pic, strerror(errno), 0); } - bv = pic_make_blob(pic, len); - memcpy(bv->data, buf, len); - free(buf); - - return pic_obj_value(bv); + return pic_blob_value(pic, buf, len); } static pic_value pic_socket_socket_shutdown(pic_state *pic) { - pic_value obj; int how; struct pic_socket_t *sock; - pic_get_args(pic, "oi", &obj, &how); - validate_socket_object(pic, obj); + pic_get_args(pic, "ui", &sock, &socket_type, &how); - sock = pic_socket_data_ptr(obj); if (sock->fd != -1) { shutdown(sock->fd, how); sock->fd = -1; } - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value pic_socket_socket_close(pic_state *pic) { - pic_value obj; + struct pic_socket_t *sock; - pic_get_args(pic, "o", &obj); - validate_socket_object(pic, obj); + pic_get_args(pic, "u", &sock, &socket_type); - socket_close(pic_socket_data_ptr(obj)); + socket_close(sock); - return pic_undef_value(); + return pic_undef_value(pic); } static int -xf_socket_read(pic_state PIC_UNUSED(*pic), void *cookie, char *ptr, int size) +xf_socket_read(pic_state *PIC_UNUSED(pic), void *cookie, char *ptr, int size) { struct pic_socket_t *sock; @@ -313,7 +272,7 @@ xf_socket_read(pic_state PIC_UNUSED(*pic), void *cookie, char *ptr, int size) } static int -xf_socket_write(pic_state PIC_UNUSED(*pic), void *cookie, const char *ptr, int size) +xf_socket_write(pic_state *PIC_UNUSED(pic), void *cookie, const char *ptr, int size) { struct pic_socket_t *sock; @@ -323,73 +282,67 @@ xf_socket_write(pic_state PIC_UNUSED(*pic), void *cookie, const char *ptr, int s } static long -xf_socket_seek(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie), long PIC_UNUSED(pos), int PIC_UNUSED(whence)) +xf_socket_seek(pic_state *PIC_UNUSED(pic), void *PIC_UNUSED(cookie), long PIC_UNUSED(pos), int PIC_UNUSED(whence)) { errno = EBADF; return -1; } static int -xf_socket_close(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie)) +xf_socket_close(pic_state *PIC_UNUSED(pic), void *PIC_UNUSED(cookie)) { return 0; } -static struct pic_port * -make_socket_port(pic_state *pic, struct pic_socket_t *sock, short dir) +static pic_value +make_socket_port(pic_state *pic, struct pic_socket_t *sock, const char *mode) { - struct pic_port *port; + xFILE *fp; - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); - port->file = xfunopen(pic, sock, xf_socket_read, xf_socket_write, xf_socket_seek, xf_socket_close); - port->flags = dir | PIC_PORT_BINARY | PIC_PORT_OPEN; - return port; + if (*mode == 'r') { + fp = xfunopen(pic, sock, xf_socket_read, 0, xf_socket_seek, xf_socket_close); + } else { + fp = xfunopen(pic, sock, 0, xf_socket_write, xf_socket_seek, xf_socket_close); + } + + return pic_open_port(pic, fp); } static pic_value pic_socket_socket_input_port(pic_state *pic) { - pic_value obj; struct pic_socket_t *sock; - pic_get_args(pic, "o", &obj); - validate_socket_object(pic, obj); + pic_get_args(pic, "u", &sock, &socket_type); - sock = pic_socket_data_ptr(obj); ensure_socket_is_open(pic, sock); - return pic_obj_value(make_socket_port(pic, sock, PIC_PORT_IN)); + return make_socket_port(pic, sock, "r"); } static pic_value pic_socket_socket_output_port(pic_state *pic) { - pic_value obj; struct pic_socket_t *sock; - pic_get_args(pic, "o", &obj); - validate_socket_object(pic, obj); + pic_get_args(pic, "u", &sock, &socket_type); - sock = pic_socket_data_ptr(obj); ensure_socket_is_open(pic, sock); - return pic_obj_value(make_socket_port(pic, sock, PIC_PORT_OUT)); + return make_socket_port(pic, sock, "w"); } static pic_value pic_socket_call_with_socket(pic_state *pic) { - pic_value obj, result; - struct pic_proc *proc; + pic_value obj, proc, result; struct pic_socket_t *sock; - pic_get_args(pic, "ol", &obj, &proc); - validate_socket_object(pic, obj); + pic_get_args(pic, "u+l", &sock, &socket_type, &obj, &proc); - sock = pic_socket_data_ptr(obj); ensure_socket_is_open(pic, sock); - result = pic_apply1(pic, proc, obj); + result = pic_call(pic, proc, 1, obj); socket_close(sock); @@ -399,123 +352,126 @@ pic_socket_call_with_socket(pic_state *pic) void pic_init_srfi_106(pic_state *pic) { - pic_deflibrary (pic, "(srfi 106)") { - pic_defun_(pic, "socket?", pic_socket_socket_p); - pic_defun_(pic, "make-socket", pic_socket_make_socket); - pic_defun_(pic, "socket-accept", pic_socket_socket_accept); - pic_defun_(pic, "socket-send", pic_socket_socket_send); - pic_defun_(pic, "socket-recv", pic_socket_socket_recv); - pic_defun_(pic, "socket-shutdown", pic_socket_socket_shutdown); - pic_defun_(pic, "socket-close", pic_socket_socket_close); - pic_defun_(pic, "socket-input-port", pic_socket_socket_input_port); - pic_defun_(pic, "socket-output-port", pic_socket_socket_output_port); - pic_defun_(pic, "call-with-socket", pic_socket_call_with_socket); + pic_deflibrary(pic, "srfi.106"); + +#define pic_defun_(pic, name, f) pic_define(pic, "srfi.106", name, pic_lambda(pic, f, 0)) +#define pic_define_(pic, name, v) pic_define(pic, "srfi.106", name, v) + + pic_defun_(pic, "socket?", pic_socket_socket_p); + pic_defun_(pic, "make-socket", pic_socket_make_socket); + pic_defun_(pic, "socket-accept", pic_socket_socket_accept); + pic_defun_(pic, "socket-send", pic_socket_socket_send); + pic_defun_(pic, "socket-recv", pic_socket_socket_recv); + pic_defun_(pic, "socket-shutdown", pic_socket_socket_shutdown); + pic_defun_(pic, "socket-close", pic_socket_socket_close); + pic_defun_(pic, "socket-input-port", pic_socket_socket_input_port); + pic_defun_(pic, "socket-output-port", pic_socket_socket_output_port); + pic_defun_(pic, "call-with-socket", pic_socket_call_with_socket); #ifdef AF_INET - pic_define_(pic, "*af-inet*", pic_int_value(AF_INET)); + pic_define_(pic, "*af-inet*", pic_int_value(pic, AF_INET)); #else - pic_define_(pic, "*af-inet*", pic_false_value()); + pic_define_(pic, "*af-inet*", pic_false_value(pic)); #endif #ifdef AF_INET6 - pic_define_(pic, "*af-inet6*", pic_int_value(AF_INET6)); + pic_define_(pic, "*af-inet6*", pic_int_value(pic, AF_INET6)); #else - pic_define_(pic, "*af-inet6*", pic_false_value()); + pic_define_(pic, "*af-inet6*", pic_false_value(pic)); #endif #ifdef AF_UNSPEC - pic_define_(pic, "*af-unspec*", pic_int_value(AF_UNSPEC)); + pic_define_(pic, "*af-unspec*", pic_int_value(pic, AF_UNSPEC)); #else - pic_define_(pic, "*af-unspec*", pic_false_value()); + pic_define_(pic, "*af-unspec*", pic_false_value(pic)); #endif #ifdef SOCK_STREAM - pic_define_(pic, "*sock-stream*", pic_int_value(SOCK_STREAM)); + pic_define_(pic, "*sock-stream*", pic_int_value(pic, SOCK_STREAM)); #else - pic_define_(pic, "*sock-stream*", pic_false_value()); + pic_define_(pic, "*sock-stream*", pic_false_value(pic)); #endif #ifdef SOCK_DGRAM - pic_define_(pic, "*sock-dgram*", pic_int_value(SOCK_DGRAM)); + pic_define_(pic, "*sock-dgram*", pic_int_value(pic, SOCK_DGRAM)); #else - pic_define_(pic, "*sock-dgram*", pic_false_value()); + pic_define_(pic, "*sock-dgram*", pic_false_value(pic)); #endif #ifdef AI_CANONNAME - pic_define_(pic, "*ai-canonname*", pic_int_value(AI_CANONNAME)); + pic_define_(pic, "*ai-canonname*", pic_int_value(pic, AI_CANONNAME)); #else - pic_define_(pic, "*ai-canonname*", pic_false_value()); + pic_define_(pic, "*ai-canonname*", pic_false_value(pic)); #endif #ifdef AI_NUMERICHOST - pic_define_(pic, "*ai-numerichost*", pic_int_value(AI_NUMERICHOST)); + pic_define_(pic, "*ai-numerichost*", pic_int_value(pic, AI_NUMERICHOST)); #else - pic_define_(pic, "*ai-numerichost*", pic_false_value()); + pic_define_(pic, "*ai-numerichost*", pic_false_value(pic)); #endif -/* AI_V4MAPPED and AI_ALL are not supported by *BSDs, even though they are defined in netdb.h. */ + /* AI_V4MAPPED and AI_ALL are not supported by *BSDs, even though they are defined in netdb.h. */ #if defined(AI_V4MAPPED) && !defined(BSD) - pic_define_(pic, "*ai-v4mapped*", pic_int_value(AI_V4MAPPED)); + pic_define_(pic, "*ai-v4mapped*", pic_int_value(pic, AI_V4MAPPED)); #else - pic_define_(pic, "*ai-v4mapped*", pic_false_value()); + pic_define_(pic, "*ai-v4mapped*", pic_false_value(pic)); #endif #if defined(AI_ALL) && !defined(BSD) - pic_define_(pic, "*ai-all*", pic_int_value(AI_ALL)); + pic_define_(pic, "*ai-all*", pic_int_value(pic, AI_ALL)); #else - pic_define_(pic, "*ai-all*", pic_false_value()); + pic_define_(pic, "*ai-all*", pic_false_value(pic)); #endif #ifdef AI_ADDRCONFIG - pic_define_(pic, "*ai-addrconfig*", pic_int_value(AI_ADDRCONFIG)); + pic_define_(pic, "*ai-addrconfig*", pic_int_value(pic, AI_ADDRCONFIG)); #else - pic_define_(pic, "*ai-addrconfig*", pic_false_value()); + pic_define_(pic, "*ai-addrconfig*", pic_false_value(pic)); #endif #ifdef AI_PASSIVE - pic_define_(pic, "*ai-passive*", pic_int_value(AI_PASSIVE)); + pic_define_(pic, "*ai-passive*", pic_int_value(pic, AI_PASSIVE)); #else - pic_define_(pic, "*ai-passive*", pic_false_value()); + pic_define_(pic, "*ai-passive*", pic_false_value(pic)); #endif #ifdef IPPROTO_IP - pic_define_(pic, "*ipproto-ip*", pic_int_value(IPPROTO_IP)); + pic_define_(pic, "*ipproto-ip*", pic_int_value(pic, IPPROTO_IP)); #else - pic_define_(pic, "*ipproto-ip*", pic_false_value()); + pic_define_(pic, "*ipproto-ip*", pic_false_value(pic)); #endif #ifdef IPPROTO_TCP - pic_define_(pic, "*ipproto-tcp*", pic_int_value(IPPROTO_TCP)); + pic_define_(pic, "*ipproto-tcp*", pic_int_value(pic, IPPROTO_TCP)); #else - pic_define_(pic, "*ipproto-tcp*", pic_false_value()); + pic_define_(pic, "*ipproto-tcp*", pic_false_value(pic)); #endif #ifdef IPPROTO_UDP - pic_define_(pic, "*ipproto-udp*", pic_int_value(IPPROTO_UDP)); + pic_define_(pic, "*ipproto-udp*", pic_int_value(pic, IPPROTO_UDP)); #else - pic_define_(pic, "*ipproto-udp*", pic_false_value()); + pic_define_(pic, "*ipproto-udp*", pic_false_value(pic)); #endif #ifdef MSG_PEEK - pic_define_(pic, "*msg-peek*", pic_int_value(MSG_PEEK)); + pic_define_(pic, "*msg-peek*", pic_int_value(pic, MSG_PEEK)); #else - pic_define_(pic, "*msg-peek*", pic_false_value()); + pic_define_(pic, "*msg-peek*", pic_false_value(pic)); #endif #ifdef MSG_OOB - pic_define_(pic, "*msg-oob*", pic_int_value(MSG_OOB)); + pic_define_(pic, "*msg-oob*", pic_int_value(pic, MSG_OOB)); #else - pic_define_(pic, "*msg-oob*", pic_false_value()); + pic_define_(pic, "*msg-oob*", pic_false_value(pic)); #endif #ifdef MSG_WAITALL - pic_define_(pic, "*msg-waitall*", pic_int_value(MSG_WAITALL)); + pic_define_(pic, "*msg-waitall*", pic_int_value(pic, MSG_WAITALL)); #else - pic_define_(pic, "*msg-waitall*", pic_false_value()); + pic_define_(pic, "*msg-waitall*", pic_false_value(pic)); #endif #ifdef SHUT_RD - pic_define_(pic, "*shut-rd*", pic_int_value(SHUT_RD)); + pic_define_(pic, "*shut-rd*", pic_int_value(pic, SHUT_RD)); #else - pic_define_(pic, "*shut-rd*", pic_false_value()); + pic_define_(pic, "*shut-rd*", pic_false_value(pic)); #endif #ifdef SHUT_WR - pic_define_(pic, "*shut-wr*", pic_int_value(SHUT_WR)); + pic_define_(pic, "*shut-wr*", pic_int_value(pic, SHUT_WR)); #else - pic_define_(pic, "*shut-wr*", pic_false_value()); + pic_define_(pic, "*shut-wr*", pic_false_value(pic)); #endif #ifdef SHUT_RDWR - pic_define_(pic, "*shut-rdwr*", pic_int_value(SHUT_RDWR)); + pic_define_(pic, "*shut-rdwr*", pic_int_value(pic, SHUT_RDWR)); #else - pic_define_(pic, "*shut-rdwr*", pic_false_value()); + pic_define_(pic, "*shut-rdwr*", pic_false_value(pic)); #endif - } } diff --git a/contrib/40.srfi/srfi/106.scm b/contrib/40.srfi/srfi/106.scm index e224b603..a9ac0408 100644 --- a/contrib/40.srfi/srfi/106.scm +++ b/contrib/40.srfi/srfi/106.scm @@ -34,7 +34,7 @@ (type *sock-stream*) (flags *ai-passive*) (protocol *ipproto-ip*)) - (make-socket #f service family type flags protocol))) + (make-socket "" service family type flags protocol))) (define %address-family `((inet . ,*af-inet*) (inet6 . ,*af-inet6*) diff --git a/contrib/60.repl/repl.c b/contrib/60.repl/repl.c index 1398a202..a4585e73 100644 --- a/contrib/60.repl/repl.c +++ b/contrib/60.repl/repl.c @@ -1,21 +1,20 @@ #include "picrin.h" +#include "picrin/extra.h" #include - static pic_value pic_repl_tty_p(pic_state *pic) { - pic_get_args(pic, ""); - return pic_bool_value((isatty(STDIN_FILENO))); + return pic_bool_value(pic, (isatty(STDIN_FILENO))); } void pic_init_repl(pic_state *pic) { - pic_deflibrary (pic, "(picrin repl)") { - pic_defun(pic, "tty?", pic_repl_tty_p); - } + pic_deflibrary(pic, "picrin.repl"); + + pic_defun(pic, "tty?", pic_repl_tty_p); } diff --git a/contrib/60.repl/repl.scm b/contrib/60.repl/repl.scm index 742bdaa7..b2b9323f 100644 --- a/contrib/60.repl/repl.scm +++ b/contrib/60.repl/repl.scm @@ -34,7 +34,39 @@ (scheme eval) (scheme r5rs) (picrin macro)) - (find-library '(picrin user)))) + "picrin.user")) + + (define (repeat x) + (let ((p (list x))) + (set-cdr! p p) + p)) + + (define (join xs delim) + (cdr (apply append (map list (repeat delim) xs)))) + + (define (string-join strings delim) + (apply string-append (join strings delim))) + + (define (->string x) + (call-with-port (open-output-string) + (lambda (port) + (write x port) + (get-output-string port)))) + + (define (print-error-object e) + (define type (error-object-type e)) + (unless (eq? type '||) + (display type) + (display "-")) + (display "error: ") + (display (error-object-message e)) + (display ".") + (define irritants (error-object-irritants e)) + (unless (null? irritants) + (display " (irritants: ") + (display (string-join (map ->string irritants) ", ")) + (display ")")) + (newline)) (define (repl) (init-env) @@ -50,12 +82,10 @@ (lambda (condition) (if (error-object? condition) (unless (equal? (error-object-message condition) "unexpected EOF") - (display "error: ") - (display (error-object-message condition)) - (newline) + (print-error-object condition) (set! str "")) (begin - (display "raised: ") + (display "raise: ") (write condition) (newline) (set! str ""))) @@ -65,7 +95,7 @@ (lambda (port) (let next ((expr (read port))) (unless (eof-object? expr) - (write (eval expr (find-library '(picrin user)))) + (write (eval expr "picrin.user")) (newline) (set! str "") (next (read port)))))))))) diff --git a/contrib/70.main/main.scm b/contrib/70.main/main.scm index f0e48e9c..27e800b3 100644 --- a/contrib/70.main/main.scm +++ b/contrib/70.main/main.scm @@ -41,7 +41,7 @@ (lambda (in) (let loop ((expr (read in))) (unless (eof-object? expr) - (eval expr (find-library '(picrin user))) + (eval expr (find-library "picrin.user")) (loop (read in))))))) (define (main) diff --git a/docs/capi.rst b/docs/capi.rst index 9297989b..03b5cc50 100644 --- a/docs/capi.rst +++ b/docs/capi.rst @@ -28,7 +28,7 @@ If you want to create a contribution library with C, the only thing you need to pic_get_args(pic, "ff", &a, &b); - return pic_float_value(a + b); + return pic_float_value(pic, a + b); } void @@ -83,15 +83,12 @@ When you use dynamic memory allocation inside C APIs, you must be caseful about pic_create_foo(pic_state *pic) { struct foo *f; - struct pic_data *dat; pic_get_args(pic, ""); // no args here f = create_foo(); - data = pic_data_alloc(pic, &foo_type, md); - - return pic_obj_value(data); + return pic_data_value(pic, md, &foo_type); } void diff --git a/etc/mkloader.pl b/etc/mkloader.pl index 527efd7a..f2c2566f 100755 --- a/etc/mkloader.pl +++ b/etc/mkloader.pl @@ -12,6 +12,7 @@ print <err); + pic_raise(pic, pic_err(pic)); } EOL } print < #include "picrin.h" +#include "picrin/extra.h" /* Simple REPL program */ @@ -26,11 +27,11 @@ main(int argc, char *argv[]) expr = pic_read(pic, pic_stdin(pic)); - if (pic_eof_p(expr)) { + if (pic_eof_p(pic, expr)) { break; } - pic_printf(pic, "~s\n", pic_eval(pic, expr, pic->lib)); + pic_printf(pic, "~s\n", pic_eval(pic, expr, "picrin.user")); } pic_close(pic); @@ -45,6 +46,7 @@ Function binding is also easy. `pic_defun` defines a scheme procedure converting ```c #include "picrin.h" +#include "picrin/extra.h" int fact(int i) { return i == 1 ? 1 : i * fact(i - 1); @@ -55,7 +57,7 @@ pic_value factorial(pic_state *pic) { pic_get_args(pic, "i", &i); - return pic_int_value(fact(i)); + return pic_int_value(pic, fact(i)); } int diff --git a/extlib/benz/blob.c b/extlib/benz/blob.c index b4acfc67..bff9d67b 100644 --- a/extlib/benz/blob.c +++ b/extlib/benz/blob.c @@ -3,16 +3,30 @@ */ #include "picrin.h" +#include "picrin/extra.h" +#include "picrin/private/object.h" -struct pic_blob * -pic_make_blob(pic_state *pic, int len) +pic_value +pic_blob_value(pic_state *pic, const unsigned char *buf, int len) { - struct pic_blob *bv; + struct blob *bv; - bv = (struct pic_blob *)pic_obj_alloc(pic, sizeof(struct pic_blob), PIC_TT_BLOB); + bv = (struct blob *)pic_obj_alloc(pic, sizeof(struct blob), PIC_TYPE_BLOB); bv->data = pic_malloc(pic, len); bv->len = len; - return bv; + if (buf) { + memcpy(bv->data, buf, len); + } + return pic_obj_value(bv); +} + +unsigned char * +pic_blob(pic_state *PIC_UNUSED(pic), pic_value blob, int *len) +{ + if (len) { + *len = pic_blob_ptr(pic, blob)->len; + } + return pic_blob_ptr(pic, blob)->data; } static pic_value @@ -22,221 +36,214 @@ pic_blob_bytevector_p(pic_state *pic) pic_get_args(pic, "o", &v); - return pic_bool_value(pic_blob_p(v)); + return pic_bool_value(pic, pic_blob_p(pic, v)); } static pic_value pic_blob_bytevector(pic_state *pic) { - pic_value *argv; + pic_value *argv, blob; int argc, i; - pic_blob *blob; unsigned char *data; pic_get_args(pic, "*", &argc, &argv); - blob = pic_make_blob(pic, argc); + blob = pic_blob_value(pic, 0, argc); - data = blob->data; + data = pic_blob(pic, blob, NULL); for (i = 0; i < argc; ++i) { pic_assert_type(pic, argv[i], int); - if (pic_int(argv[i]) < 0 || pic_int(argv[i]) > 255) { - pic_errorf(pic, "byte out of range"); + if (pic_int(pic, argv[i]) < 0 || pic_int(pic, argv[i]) > 255) { + pic_error(pic, "byte out of range", 0); } - *data++ = (unsigned char)pic_int(argv[i]); + *data++ = (unsigned char)pic_int(pic, argv[i]); } - return pic_obj_value(blob); + return blob; } static pic_value pic_blob_make_bytevector(pic_state *pic) { - pic_blob *blob; - int k, i, b = 0; + pic_value blob; + int k, b = 0; pic_get_args(pic, "i|i", &k, &b); if (b < 0 || b > 255) - pic_errorf(pic, "byte out of range"); + pic_error(pic, "byte out of range", 0); - blob = pic_make_blob(pic, k); - for (i = 0; i < k; ++i) { - blob->data[i] = (unsigned char)b; + if (k < 0) { + pic_error(pic, "make-bytevector: negative length given", 1, pic_int_value(pic, k)); } - return pic_obj_value(blob); + blob = pic_blob_value(pic, 0, k); + + memset(pic_blob(pic, blob, NULL), (unsigned char)b, k); + + return blob; } static pic_value pic_blob_bytevector_length(pic_state *pic) { - struct pic_blob *bv; + int len; - pic_get_args(pic, "b", &bv); + pic_get_args(pic, "b", NULL, &len); - return pic_int_value(bv->len); + return pic_int_value(pic, len); } static pic_value pic_blob_bytevector_u8_ref(pic_state *pic) { - struct pic_blob *bv; - int k; + unsigned char *buf; + int len, k; - pic_get_args(pic, "bi", &bv, &k); + pic_get_args(pic, "bi", &buf, &len, &k); - return pic_int_value(bv->data[k]); + VALID_INDEX(pic, len, k); + + return pic_int_value(pic, buf[k]); } static pic_value pic_blob_bytevector_u8_set(pic_state *pic) { - struct pic_blob *bv; - int k, v; + unsigned char *buf; + int len, k, v; - pic_get_args(pic, "bii", &bv, &k, &v); + pic_get_args(pic, "bii", &buf, &len, &k, &v); if (v < 0 || v > 255) - pic_errorf(pic, "byte out of range"); + pic_error(pic, "byte out of range", 0); - bv->data[k] = (unsigned char)v; - return pic_undef_value(); + VALID_INDEX(pic, len, k); + + buf[k] = (unsigned char)v; + + return pic_undef_value(pic); } static pic_value pic_blob_bytevector_copy_i(pic_state *pic) { - pic_blob *to, *from; - int n, at, start, end; + unsigned char *to, *from; + int n, at, start, end, tolen, fromlen; - n = pic_get_args(pic, "bib|ii", &to, &at, &from, &start, &end); + n = pic_get_args(pic, "bib|ii", &to, &tolen, &at, &from, &fromlen, &start, &end); switch (n) { case 3: start = 0; case 4: - end = from->len; + end = fromlen; } - if (to == from && (start <= at && at < end)) { - /* copy in reversed order */ - at += end - start; - while (start < end) { - to->data[--at] = from->data[--end]; - } - return pic_undef_value(); - } + VALID_ATRANGE(pic, tolen, at, fromlen, start, end); - while (start < end) { - to->data[at++] = from->data[start++]; - } + memmove(to + at, from + start, end - start); - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value pic_blob_bytevector_copy(pic_state *pic) { - pic_blob *from, *to; - int n, start, end, i = 0; + unsigned char *buf; + int n, start, end, len; - n = pic_get_args(pic, "b|ii", &from, &start, &end); + n = pic_get_args(pic, "b|ii", &buf, &len, &start, &end); switch (n) { case 1: start = 0; case 2: - end = from->len; + end = len; } - if (end < start) { - pic_errorf(pic, "make-bytevector: end index must not be less than start index"); - } + VALID_RANGE(pic, len, start, end); - to = pic_make_blob(pic, end - start); - while (start < end) { - to->data[i++] = from->data[start++]; - } - - return pic_obj_value(to); + return pic_blob_value(pic, buf + start, end - start); } static pic_value pic_blob_bytevector_append(pic_state *pic) { - int argc, i, j, len; - pic_value *argv; - pic_blob *blob; + int argc, i, l, len; + unsigned char *buf, *dst; + pic_value *argv, blob; pic_get_args(pic, "*", &argc, &argv); len = 0; for (i = 0; i < argc; ++i) { pic_assert_type(pic, argv[i], blob); - len += pic_blob_ptr(argv[i])->len; + pic_blob(pic, argv[i], &l); + len += l; } - blob = pic_make_blob(pic, len); + blob = pic_blob_value(pic, NULL, len); + dst = pic_blob(pic, blob, NULL); len = 0; for (i = 0; i < argc; ++i) { - for (j = 0; j < pic_blob_ptr(argv[i])->len; ++j) { - blob->data[len + j] = pic_blob_ptr(argv[i])->data[j]; - } - len += pic_blob_ptr(argv[i])->len; + buf = pic_blob(pic, argv[i], &l); + memcpy(dst + len, buf, l); + len += l; } - return pic_obj_value(blob); + return blob; } static pic_value pic_blob_list_to_bytevector(pic_state *pic) { - pic_blob *blob; + pic_value blob; unsigned char *data; pic_value list, e, it; pic_get_args(pic, "o", &list); - blob = pic_make_blob(pic, pic_length(pic, list)); + blob = pic_blob_value(pic, 0, pic_length(pic, list)); - data = blob->data; + data = pic_blob(pic, blob, NULL); pic_for_each (e, list, it) { pic_assert_type(pic, e, int); - if (pic_int(e) < 0 || pic_int(e) > 255) - pic_errorf(pic, "byte out of range"); + if (pic_int(pic, e) < 0 || pic_int(pic, e) > 255) + pic_error(pic, "byte out of range", 0); - *data++ = (unsigned char)pic_int(e); + *data++ = (unsigned char)pic_int(pic, e); } - return pic_obj_value(blob); + return blob; } static pic_value pic_blob_bytevector_to_list(pic_state *pic) { - pic_blob *blob; pic_value list; - int n, start, end, i; + unsigned char *buf; + int n, len, start, end, i; - n = pic_get_args(pic, "b|ii", &blob, &start, &end); + n = pic_get_args(pic, "b|ii", &buf, &len, &start, &end); switch (n) { case 1: start = 0; case 2: - end = blob->len; + end = len; } - list = pic_nil_value(); + VALID_RANGE(pic, len, start, end); + list = pic_nil_value(pic); for (i = start; i < end; ++i) { - pic_push(pic, pic_int_value(blob->data[i]), list); + pic_push(pic, pic_int_value(pic, buf[i]), list); } return pic_reverse(pic, list); } diff --git a/extlib/benz/bool.c b/extlib/benz/bool.c index 6e5a39b7..ee9c52a3 100644 --- a/extlib/benz/bool.c +++ b/extlib/benz/bool.c @@ -3,6 +3,61 @@ */ #include "picrin.h" +#include "picrin/private/object.h" + +#if PIC_NAN_BOXING + +bool +pic_eq_p(pic_state *PIC_UNUSED(pic), pic_value x, pic_value y) +{ + return x == y; +} + +bool +pic_eqv_p(pic_state *PIC_UNUSED(pic), pic_value x, pic_value y) +{ + return x == y; +} + +#else + +bool +pic_eq_p(pic_state *PIC_UNUSED(pic), pic_value x, pic_value y) +{ + if (pic_type(pic, x) != pic_type(pic, y)) + return false; + + switch (pic_type(pic, x)) { + case PIC_TYPE_NIL: + return true; + case PIC_TYPE_TRUE: case PIC_TYPE_FALSE: + return pic_type(pic, x) == pic_type(pic, y); + default: + return pic_obj_ptr(x) == pic_obj_ptr(y); + } +} + +bool +pic_eqv_p(pic_state *PIC_UNUSED(pic), pic_value x, pic_value y) +{ + if (pic_type(pic, x) != pic_type(pic, y)) + return false; + + switch (pic_type(pic, x)) { + case PIC_TYPE_NIL: + return true; + case PIC_TYPE_TRUE: case PIC_TYPE_FALSE: + return pic_type(pic, x) == pic_type(pic, y); + case PIC_TYPE_FLOAT: + return pic_float(pic, x) == pic_float(pic, y); + case PIC_TYPE_INT: + return pic_int(pic, x) == pic_int(pic, y); + default: + return pic_obj_ptr(x) == pic_obj_ptr(y); + } +} + +#endif KHASH_DECLARE(m, void *, int) KHASH_DEFINE2(m, void *, int, 0, kh_ptr_hash_func, kh_ptr_hash_equal) @@ -10,16 +65,16 @@ KHASH_DEFINE2(m, void *, int, 0, kh_ptr_hash_func, kh_ptr_hash_equal) static bool internal_equal_p(pic_state *pic, pic_value x, pic_value y, int depth, khash_t(m) *h) { - pic_value localx = pic_nil_value(); - pic_value localy = pic_nil_value(); + pic_value localx = pic_nil_value(pic); + pic_value localy = pic_nil_value(pic); int cx = 0; int cy = 0; if (depth > 10) { if (depth > 200) { - pic_errorf(pic, "Stack overflow in equal\n"); + pic_error(pic, "stack overflow in equal", 0); } - if (pic_pair_p(x) || pic_vec_p(x)) { + if (pic_pair_p(pic, x) || pic_vec_p(pic, x)) { int ret; kh_put(m, h, pic_obj_ptr(x), &ret); if (ret != 0) { @@ -30,56 +85,55 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, int depth, khash_t(m) LOOP: - if (pic_eqv_p(x, y)) { + if (pic_eqv_p(pic, x, y)) { return true; } - if (pic_type(x) != pic_type(y)) { + if (pic_type(pic, x) != pic_type(pic, y)) { return false; } - switch (pic_type(x)) { - case PIC_TT_ID: { - struct pic_id *id1, *id2; - pic_sym *s1, *s2; + switch (pic_type(pic, x)) { + case PIC_TYPE_ID: { + struct identifier *id1, *id2; + pic_value s1, s2; - id1 = pic_id_ptr(x); - id2 = pic_id_ptr(y); + id1 = pic_id_ptr(pic, x); + id2 = pic_id_ptr(pic, y); - s1 = pic_lookup_identifier(pic, id1->u.id.id, id1->u.id.env); - s2 = pic_lookup_identifier(pic, id2->u.id.id, id2->u.id.env); + s1 = pic_find_identifier(pic, pic_obj_value(id1->u.id), pic_obj_value(id1->env)); + s2 = pic_find_identifier(pic, pic_obj_value(id2->u.id), pic_obj_value(id2->env)); - return s1 == s2; + return pic_eq_p(pic, s1, s2); } - case PIC_TT_STRING: { - return pic_str_cmp(pic, pic_str_ptr(x), pic_str_ptr(y)) == 0; + case PIC_TYPE_STRING: { + return pic_str_cmp(pic, x, y) == 0; } - case PIC_TT_BLOB: { - pic_blob *blob1, *blob2; - int i; + case PIC_TYPE_BLOB: { + int xlen, ylen; + const unsigned char *xbuf, *ybuf; - blob1 = pic_blob_ptr(x); - blob2 = pic_blob_ptr(y); + xbuf = pic_blob(pic, x, &xlen); + ybuf = pic_blob(pic, y, &ylen); - if (blob1->len != blob2->len) { + if (xlen != ylen) { return false; } - for (i = 0; i < blob1->len; ++i) { - if (blob1->data[i] != blob2->data[i]) - return false; + if (memcmp(xbuf, ybuf, xlen) != 0) { + return false; } return true; } - case PIC_TT_PAIR: { + case PIC_TYPE_PAIR: { if (! internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, h)) return false; /* Floyd's cycle-finding algorithm */ - if (pic_nil_p(localx)) { + if (pic_nil_p(pic, localx)) { localx = x; } x = pic_cdr(pic, x); cx++; - if (pic_nil_p(localy)) { + if (pic_nil_p(pic, localy)) { localy = y; } y = pic_cdr(pic, y); @@ -87,7 +141,7 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, int depth, khash_t(m) if (cx == 2) { cx = 0; localx = pic_cdr(pic, localx); - if (pic_eq_p(localx, x)) { + if (pic_eq_p(pic, localx, x)) { if (cy < 0 ) return true; /* both lists circular */ cx = INT_MIN; /* found a cycle on x */ } @@ -95,31 +149,30 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, int depth, khash_t(m) if (cy == 2) { cy = 0; localy = pic_cdr(pic, localy); - if (pic_eq_p(localy, y)) { + if (pic_eq_p(pic, localy, y)) { if (cx < 0 ) return true; /* both lists circular */ cy = INT_MIN; /* found a cycle on y */ } } goto LOOP; /* tail-call optimization */ } - case PIC_TT_VECTOR: { - int i; - struct pic_vector *u, *v; + case PIC_TYPE_VECTOR: { + int i, xlen, ylen; - u = pic_vec_ptr(x); - v = pic_vec_ptr(y); + xlen = pic_vec_len(pic, x); + ylen = pic_vec_len(pic, y); - if (u->len != v->len) { + if (xlen != ylen) { return false; } - for (i = 0; i < u->len; ++i) { - if (! internal_equal_p(pic, u->data[i], v->data[i], depth + 1, h)) + for (i = 0; i < xlen; ++i) { + if (! internal_equal_p(pic, pic_vec_ref(pic, x, i), pic_vec_ref(pic, y, i), depth + 1, h)) return false; } return true; } - case PIC_TT_DATA: { - return pic_data_ptr(x)->data == pic_data_ptr(y)->data; + case PIC_TYPE_DATA: { + return pic_data(pic, x) == pic_data(pic, y); } default: return false; @@ -143,7 +196,7 @@ pic_bool_eq_p(pic_state *pic) pic_get_args(pic, "oo", &x, &y); - return pic_bool_value(pic_eq_p(x, y)); + return pic_bool_value(pic, pic_eq_p(pic, x, y)); } static pic_value @@ -153,7 +206,7 @@ pic_bool_eqv_p(pic_state *pic) pic_get_args(pic, "oo", &x, &y); - return pic_bool_value(pic_eqv_p(x, y)); + return pic_bool_value(pic, pic_eqv_p(pic, x, y)); } static pic_value @@ -163,7 +216,7 @@ pic_bool_equal_p(pic_state *pic) pic_get_args(pic, "oo", &x, &y); - return pic_bool_value(pic_equal_p(pic, x, y)); + return pic_bool_value(pic, pic_equal_p(pic, x, y)); } static pic_value @@ -173,7 +226,7 @@ pic_bool_not(pic_state *pic) pic_get_args(pic, "o", &v); - return pic_false_p(v) ? pic_true_value() : pic_false_value(); + return pic_false_p(pic, v) ? pic_true_value(pic) : pic_false_value(pic); } static pic_value @@ -183,7 +236,7 @@ pic_bool_boolean_p(pic_state *pic) pic_get_args(pic, "o", &v); - return (pic_true_p(v) || pic_false_p(v)) ? pic_true_value() : pic_false_value(); + return (pic_true_p(pic, v) || pic_false_p(pic, v)) ? pic_true_value(pic) : pic_false_value(pic); } static pic_value @@ -195,14 +248,14 @@ pic_bool_boolean_eq_p(pic_state *pic) pic_get_args(pic, "*", &argc, &argv); for (i = 0; i < argc; ++i) { - if (! (pic_true_p(argv[i]) || pic_false_p(argv[i]))) { - return pic_false_value(); + if (! (pic_true_p(pic, argv[i]) || pic_false_p(pic, argv[i]))) { + return pic_false_value(pic); } - if (! pic_eq_p(argv[i], argv[0])) { - return pic_false_value(); + if (! pic_eq_p(pic, argv[i], argv[0])) { + return pic_false_value(pic); } } - return pic_true_value(); + return pic_true_value(pic); } void diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index 8dff52fe..9ad798e3 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -542,12 +542,24 @@ my $src = <<'EOL'; ;;; library primitives +(define (mangle name) + (define (->string n) + (if (symbol? n) + (symbol->string n) + (number->string n))) + (define (join strs delim) + (let loop ((res (car strs)) (strs (cdr strs))) + (if (null? strs) + res + (loop (string-append res delim (car strs)) (cdr strs))))) + (join (map ->string name) ".")) + (define-macro define-library (lambda (form _) - (let ((name (cadr form)) + (let ((lib (mangle (cadr form))) (body (cddr form))) - (let ((new-library (or (find-library name) (make-library name)))) - (for-each (lambda (expr) (eval expr new-library)) body))))) + (or (find-library lib) (make-library lib)) + (for-each (lambda (expr) (eval expr lib)) body)))) (define-macro cond-expand (lambda (form _) @@ -559,7 +571,7 @@ my $src = <<'EOL'; (memq form (features))) (and (pair? form) (case (car form) - ((library) (find-library (cadr form))) + ((library) (find-library (mangle (cadr form)))) ((not) (not (test (cadr form)))) ((and) (let loop ((form (cdr form))) (or (null? form) @@ -584,7 +596,13 @@ my $src = <<'EOL'; (string->symbol (string-append (symbol->string prefix) - (symbol->string symbol)))))) + (symbol->string symbol))))) + (getlib + (lambda (name) + (let ((lib (mangle name))) + (if (find-library lib) + lib + (error "library not found" name)))))) (letrec ((extract (lambda (spec) @@ -592,7 +610,7 @@ my $src = <<'EOL'; ((only rename prefix except) (extract (cadr spec))) (else - (or (find-library spec) (error "library not found" spec)))))) + (getlib spec))))) (collect (lambda (spec) (case (car spec) @@ -615,8 +633,7 @@ my $src = <<'EOL'; (loop (cdr alist)) (cons (car alist) (loop (cdr alist)))))))) (else - (let ((lib (or (find-library spec) (error "library not found" spec)))) - (map (lambda (x) (cons x x)) (library-exports lib)))))))) + (map (lambda (x) (cons x x)) (library-exports (getlib spec)))))))) (letrec ((import (lambda (spec) @@ -948,31 +965,37 @@ const char pic_boot[][80] = { "rm))))\n `(let ()\n ,@(map (lambda (x)\n `(,(the 'def", "ine-syntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n\n(d", "efine-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@(cdr f", -"orm))))\n\n\n;;; library primitives\n\n(define-macro define-library\n (lambda (form _", -")\n (let ((name (cadr form))\n (body (cddr form)))\n (let ((new-li", -"brary (or (find-library name) (make-library name))))\n (for-each (lambda (", -"expr) (eval expr new-library)) body)))))\n\n(define-macro cond-expand\n (lambda (f", -"orm _)\n (letrec\n ((test (lambda (form)\n (or\n ", -" (eq? form 'else)\n (and (symbol? form)\n ", -" (memq form (features)))\n (and (pair? form)\n ", -" (case (car form)\n ((library) (find-library (cad", -"r form)))\n ((not) (not (test (cadr form))))\n ", -" ((and) (let loop ((form (cdr form)))\n ", -" (or (null? form)\n (and (test (car form)", -") (loop (cdr form))))))\n ((or) (let loop ((form (cdr for", -"m)))\n (and (pair? form)\n ", -" (or (test (car form)) (loop (cdr form))))))\n ", -" (else #f)))))))\n (let loop ((clauses (cdr form)))\n (if (null? cla", -"uses)\n #undefined\n (if (test (caar clauses))\n ", -" `(,the-begin ,@(cdar clauses))\n (loop (cdr clauses))))))))\n\n(d", -"efine-macro import\n (lambda (form _)\n (let ((caddr\n (lambda (x) (c", -"ar (cdr (cdr x)))))\n (prefix\n (lambda (prefix symbol)\n ", -" (string->symbol\n (string-append\n (symbol->strin", -"g prefix)\n (symbol->string symbol))))))\n (letrec\n ((", -"extract\n (lambda (spec)\n (case (car spec)\n ", -" ((only rename prefix except)\n (extract (cadr spec)))\n ", -" (else\n (or (find-library spec) (error \"library not found\"", -" spec))))))\n (collect\n (lambda (spec)\n (case (", +"orm))))\n\n\n;;; library primitives\n\n(define (mangle name)\n (define (->string n)\n ", +" (if (symbol? n)\n (symbol->string n)\n (number->string n)))\n (de", +"fine (join strs delim)\n (let loop ((res (car strs)) (strs (cdr strs)))\n ", +"(if (null? strs)\n res\n (loop (string-append res delim (car str", +"s)) (cdr strs)))))\n (join (map ->string name) \".\"))\n\n(define-macro define-libra", +"ry\n (lambda (form _)\n (let ((lib (mangle (cadr form)))\n (body (cddr", +" form)))\n (or (find-library lib) (make-library lib))\n (for-each (lambd", +"a (expr) (eval expr lib)) body))))\n\n(define-macro cond-expand\n (lambda (form _)", +"\n (letrec\n ((test (lambda (form)\n (or\n ", +" (eq? form 'else)\n (and (symbol? form)\n ", +"(memq form (features)))\n (and (pair? form)\n ", +" (case (car form)\n ((library) (find-library (mangle (c", +"adr form))))\n ((not) (not (test (cadr form))))\n ", +" ((and) (let loop ((form (cdr form)))\n ", +" (or (null? form)\n (and (test (car fo", +"rm)) (loop (cdr form))))))\n ((or) (let loop ((form (cdr ", +"form)))\n (and (pair? form)\n ", +" (or (test (car form)) (loop (cdr form))))))\n ", +" (else #f)))))))\n (let loop ((clauses (cdr form)))\n (if (null? ", +"clauses)\n #undefined\n (if (test (caar clauses))\n ", +" `(,the-begin ,@(cdar clauses))\n (loop (cdr clauses))))))))\n", +"\n(define-macro import\n (lambda (form _)\n (let ((caddr\n (lambda (x)", +" (car (cdr (cdr x)))))\n (prefix\n (lambda (prefix symbol)\n ", +" (string->symbol\n (string-append\n (symbol->st", +"ring prefix)\n (symbol->string symbol)))))\n (getlib\n ", +" (lambda (name)\n (let ((lib (mangle name)))\n (if (", +"find-library lib)\n lib\n (error \"library not ", +"found\" name))))))\n (letrec\n ((extract\n (lambda (spec)\n ", +" (case (car spec)\n ((only rename prefix except)\n ", +" (extract (cadr spec)))\n (else\n (getli", +"b spec)))))\n (collect\n (lambda (spec)\n (case (", "car spec)\n ((only)\n (let ((alist (collect (cadr s", "pec))))\n (map (lambda (var) (assq var alist)) (cddr spec))))\n ", " ((rename)\n (let ((alist (collect (cadr spec)))\n ", @@ -985,25 +1008,24 @@ const char pic_boot[][80] = { "f (null? alist)\n '()\n (if (memq ", "(caar alist) (cddr spec))\n (loop (cdr alist))\n ", " (cons (car alist) (loop (cdr alist))))))))\n ", -" (else\n (let ((lib (or (find-library spec) (error \"library not ", -"found\" spec))))\n (map (lambda (x) (cons x x)) (library-exports", -" lib))))))))\n (letrec\n ((import\n (lambda (spec)\n", -" (let ((lib (extract spec))\n (alist (colle", -"ct spec)))\n (for-each\n (lambda (slot)\n ", -" (library-import lib (cdr slot) (car slot)))\n ", -" alist)))))\n (for-each import (cdr form)))))))\n\n(define-macro export\n ", -"(lambda (form _)\n (letrec\n ((collect\n (lambda (spec)\n ", -" (cond\n ((symbol? spec)\n `(,spec . ,spec))\n ", -" ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))\n ", -" `(,(list-ref spec 1) . ,(list-ref spec 2)))\n (else\n ", -"(error \"malformed export\")))))\n (export\n (lambda (spec)\n ", -" (let ((slot (collect spec)))\n (library-export (car slot) (c", -"dr slot))))))\n (for-each export (cdr form)))))\n\n(export define lambda quote", -" set! if begin define-macro\n let let* letrec letrec*\n let-values l", -"et*-values define-values\n quasiquote unquote unquote-splicing\n and", -" or\n cond case else =>\n do when unless\n parameterize\n ", -" define-syntax\n syntax-quote syntax-unquote\n syntax-quasiquote sy", -"ntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-error)\n\n\n", +" (else\n (map (lambda (x) (cons x x)) (library-exports (getlib s", +"pec))))))))\n (letrec\n ((import\n (lambda (spec)\n ", +" (let ((lib (extract spec))\n (alist (collec", +"t spec)))\n (for-each\n (lambda (slot)\n ", +" (library-import lib (cdr slot) (car slot)))\n ", +"alist)))))\n (for-each import (cdr form)))))))\n\n(define-macro export\n (", +"lambda (form _)\n (letrec\n ((collect\n (lambda (spec)\n ", +" (cond\n ((symbol? spec)\n `(,spec . ,spec))\n ", +" ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))\n ", +" `(,(list-ref spec 1) . ,(list-ref spec 2)))\n (else\n (", +"error \"malformed export\")))))\n (export\n (lambda (spec)\n ", +" (let ((slot (collect spec)))\n (library-export (car slot) (cd", +"r slot))))))\n (for-each export (cdr form)))))\n\n(export define lambda quote ", +"set! if begin define-macro\n let let* letrec letrec*\n let-values le", +"t*-values define-values\n quasiquote unquote unquote-splicing\n and ", +"or\n cond case else =>\n do when unless\n parameterize\n ", +" define-syntax\n syntax-quote syntax-unquote\n syntax-quasiquote syn", +"tax-unquote-splicing\n let-syntax letrec-syntax\n syntax-error)\n\n\n", "", "" }; diff --git a/extlib/benz/char.c b/extlib/benz/char.c index 8db6f41a..7f9d7666 100644 --- a/extlib/benz/char.c +++ b/extlib/benz/char.c @@ -3,6 +3,7 @@ */ #include "picrin.h" +#include "picrin/extra.h" static pic_value pic_char_char_p(pic_state *pic) @@ -11,7 +12,7 @@ pic_char_char_p(pic_state *pic) pic_get_args(pic, "o", &v); - return pic_char_p(v) ? pic_true_value() : pic_false_value(); + return pic_char_p(pic, v) ? pic_true_value(pic) : pic_false_value(pic); } static pic_value @@ -21,7 +22,7 @@ pic_char_char_to_integer(pic_state *pic) pic_get_args(pic, "c", &c); - return pic_int_value(c); + return pic_int_value(pic, c); } static pic_value @@ -31,11 +32,11 @@ pic_char_integer_to_char(pic_state *pic) pic_get_args(pic, "i", &i); - if (i < 0 || i > 127) { - pic_errorf(pic, "integer->char: integer out of char range: %d", i); + if (i < 0 || i > 255) { + pic_error(pic, "integer->char: integer out of char range", 1, pic_int_value(pic, i)); } - return pic_char_value((char)i); + return pic_char_value(pic, (char)i); } #define DEFINE_CHAR_CMP(op, name) \ @@ -49,20 +50,18 @@ pic_char_integer_to_char(pic_state *pic) pic_get_args(pic, "cc*", &c, &d, &argc, &argv); \ \ if (! (c op d)) \ - return pic_false_value(); \ - \ - for (i = 0; i < argc; ++i) { \ + return pic_false_value(pic); \ + \ + for (i = 0; i < argc; ++i) { \ c = d; \ - if (pic_char_p(argv[i])) \ - d = pic_char(argv[i]); \ - else \ - pic_errorf(pic, #op ": char required"); \ - \ + pic_assert_type(pic, argv[i], char); \ + d = pic_char(pic, argv[i]); \ + \ if (! (c op d)) \ - return pic_false_value(); \ + return pic_false_value(pic); \ } \ \ - return pic_true_value(); \ + return pic_true_value(pic); \ } DEFINE_CHAR_CMP(==, eq) diff --git a/extlib/benz/cont.c b/extlib/benz/cont.c index b2984fb0..64f269a2 100644 --- a/extlib/benz/cont.c +++ b/extlib/benz/cont.c @@ -3,54 +3,35 @@ */ #include "picrin.h" +#include "picrin/private/object.h" +#include "picrin/private/state.h" + +struct pic_cont { + PIC_JMPBUF *jmp; + + int id; + + struct checkpoint *cp; + ptrdiff_t sp_offset; + ptrdiff_t ci_offset; + ptrdiff_t xp_offset; + size_t arena_idx; + pic_value ptable; + struct code *ip; + + int retc; + pic_value *retv; + + struct pic_cont *prev; +}; + +static const pic_data_type cont_type = { "pic_cont", NULL, NULL }; void -pic_wind(pic_state *pic, pic_checkpoint *here, pic_checkpoint *there) +pic_save_point(pic_state *pic, struct pic_cont *cont, PIC_JMPBUF *jmp) { - if (here == there) - return; + cont->jmp = jmp; - if (here->depth < there->depth) { - pic_wind(pic, here, there->prev); - pic_apply0(pic, there->in); - } - else { - pic_apply0(pic, there->out); - pic_wind(pic, here->prev, there); - } -} - -pic_value -pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, struct pic_proc *out) -{ - pic_checkpoint *here; - pic_value val; - - if (in != NULL) { - pic_apply0(pic, in); /* enter */ - } - - here = pic->cp; - pic->cp = (pic_checkpoint *)pic_obj_alloc(pic, sizeof(pic_checkpoint), PIC_TT_CP); - pic->cp->prev = here; - pic->cp->depth = here->depth + 1; - pic->cp->in = in; - pic->cp->out = out; - - val = pic_apply0(pic, thunk); - - pic->cp = here; - - if (out != NULL) { - pic_apply0(pic, out); /* exit */ - } - - return val; -} - -void -pic_save_point(pic_state *pic, struct pic_cont *cont) -{ /* save runtime context */ cont->cp = pic->cp; cont->sp_offset = pic->sp - pic->stbase; @@ -60,7 +41,8 @@ pic_save_point(pic_state *pic, struct pic_cont *cont) cont->ip = pic->ip; cont->ptable = pic->ptable; cont->prev = pic->cc; - cont->results = pic_undef_value(); + cont->retc = 0; + cont->retv = NULL; cont->id = pic->ccnt++; pic->cc = cont; @@ -82,18 +64,65 @@ pic_load_point(pic_state *pic, struct pic_cont *cont) pic->cc = cont->prev; } +void +pic_exit_point(pic_state *pic) +{ + pic->cc = pic->cc->prev; +} + +void +pic_wind(pic_state *pic, struct checkpoint *here, struct checkpoint *there) +{ + if (here == there) + return; + + if (here->depth < there->depth) { + pic_wind(pic, here, there->prev); + pic_call(pic, pic_obj_value(there->in), 0); + } + else { + pic_call(pic, pic_obj_value(there->out), 0); + pic_wind(pic, here->prev, there); + } +} + +static pic_value +pic_dynamic_wind(pic_state *pic, pic_value in, pic_value thunk, pic_value out) +{ + struct checkpoint *here; + pic_value val; + + pic_call(pic, in, 0); /* enter */ + + here = pic->cp; + pic->cp = (struct checkpoint *)pic_obj_alloc(pic, sizeof(struct checkpoint), PIC_TYPE_CP); + pic->cp->prev = here; + pic->cp->depth = here->depth + 1; + pic->cp->in = pic_proc_ptr(pic, in); + pic->cp->out = pic_proc_ptr(pic, out); + + val = pic_call(pic, thunk, 0); + + pic->cp = here; + + pic_call(pic, out, 0); /* exit */ + + return val; +} + static pic_value cont_call(pic_state *pic) { - struct pic_proc *self; int argc; pic_value *argv; int id; struct pic_cont *cc, *cont; - pic_get_args(pic, "&*", &self, &argc, &argv); + pic_get_args(pic, "*", &argc, &argv); - id = pic_int(pic_proc_env_ref(pic, self, "id")); + cont = pic_data(pic, pic_closure_ref(pic, 0)); + + id = cont->id; /* check if continuation is alive */ for (cc = pic->cc; cc != NULL; cc = cc->prev) { @@ -102,144 +131,94 @@ cont_call(pic_state *pic) } } if (cc == NULL) { - pic_errorf(pic, "calling dead escape continuation"); + pic_error(pic, "calling dead escape continuation", 0); } - cont = pic_data_ptr(pic_proc_env_ref(pic, self, "escape"))->data; - cont->results = pic_list_by_array(pic, argc, argv); + cont->retc = argc; + cont->retv = argv; pic_load_point(pic, cont); - PIC_LONGJMP(pic, cont->jmp, 1); + PIC_LONGJMP(pic, *cont->jmp, 1); PIC_UNREACHABLE(); } -struct pic_proc * +pic_value pic_make_cont(pic_state *pic, struct pic_cont *cont) { - static const pic_data_type cont_type = { "cont", NULL, NULL }; - struct pic_proc *c; - struct pic_data *e; - - c = pic_make_proc(pic, cont_call); - - e = pic_data_alloc(pic, &cont_type, cont); - - /* save the escape continuation in proc */ - pic_proc_env_set(pic, c, "escape", pic_obj_value(e)); - pic_proc_env_set(pic, c, "id", pic_int_value(cont->id)); - - return c; + return pic_lambda(pic, cont_call, 1, pic_data_value(pic, cont, &cont_type)); } -pic_value -pic_callcc(pic_state *pic, struct pic_proc *proc) +struct pic_cont * +pic_alloca_cont(pic_state *pic) { - struct pic_cont cont; + return pic_alloca(pic, sizeof(struct pic_cont)); +} - pic_save_point(pic, &cont); +static pic_value +pic_callcc(pic_state *pic, pic_value proc) +{ + PIC_JMPBUF jmp; + struct pic_cont *cont = pic_alloca_cont(pic); - if (PIC_SETJMP(pic, cont.jmp)) { - return pic_values_by_list(pic, cont.results); + if (PIC_SETJMP(pic, jmp)) { + return pic_valuesk(pic, cont->retc, cont->retv); } else { pic_value val; - val = pic_apply1(pic, proc, pic_obj_value(pic_make_cont(pic, &cont))); + pic_save_point(pic, cont, &jmp); - pic->cc = pic->cc->prev; + val = pic_call(pic, proc, 1, pic_make_cont(pic, cont)); + + pic_exit_point(pic); return val; } } -static pic_value -pic_va_values(pic_state *pic, int n, ...) +pic_value +pic_return(pic_state *pic, int n, ...) { - pic_vec *args = pic_make_vec(pic, n); va_list ap; - int i = 0; + pic_value ret; va_start(ap, n); - - while (i < n) { - args->data[i++] = va_arg(ap, pic_value); - } - + ret = pic_vreturn(pic, n, ap); va_end(ap); - - return pic_values(pic, n, args->data); + return ret; } pic_value -pic_values0(pic_state *pic) +pic_vreturn(pic_state *pic, int n, va_list ap) { - return pic_va_values(pic, 0); + pic_value *retv = pic_alloca(pic, sizeof(pic_value) * n); + int i; + + for (i = 0; i < n; ++i) { + retv[i] = va_arg(ap, pic_value); + } + return pic_valuesk(pic, n, retv); } pic_value -pic_values1(pic_state *pic, pic_value arg1) -{ - return pic_va_values(pic, 1, arg1); -} - -pic_value -pic_values2(pic_state *pic, pic_value arg1, pic_value arg2) -{ - return pic_va_values(pic, 2, arg1, arg2); -} - -pic_value -pic_values3(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3) -{ - return pic_va_values(pic, 3, arg1, arg2, arg3); -} - -pic_value -pic_values4(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4) -{ - return pic_va_values(pic, 4, arg1, arg2, arg3, arg4); -} - -pic_value -pic_values5(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4, pic_value arg5) -{ - return pic_va_values(pic, 5, arg1, arg2, arg3, arg4, arg5); -} - -pic_value -pic_values(pic_state *pic, int argc, pic_value *argv) +pic_valuesk(pic_state *pic, int argc, pic_value *argv) { int i; for (i = 0; i < argc; ++i) { pic->sp[i] = argv[i]; } - pic->ci->retc = (int)argc; + pic->ci->retc = argc; - return argc == 0 ? pic_undef_value() : pic->sp[0]; -} - -pic_value -pic_values_by_list(pic_state *pic, pic_value list) -{ - pic_value v, it; - int i; - - i = 0; - pic_for_each (v, list, it) { - pic->sp[i++] = v; - } - pic->ci->retc = i; - - return pic_nil_p(list) ? pic_undef_value() : pic->sp[0]; + return argc == 0 ? pic_undef_value(pic) : pic->sp[0]; } int pic_receive(pic_state *pic, int n, pic_value *argv) { - pic_callinfo *ci; + struct callinfo *ci; int i, retc; /* take info from discarded frame */ @@ -249,24 +228,23 @@ pic_receive(pic_state *pic, int n, pic_value *argv) for (i = 0; i < retc && i < n; ++i) { argv[i] = ci->fp[i]; } - return retc; } static pic_value pic_cont_callcc(pic_state *pic) { - struct pic_proc *cb; + pic_value f; - pic_get_args(pic, "l", &cb); + pic_get_args(pic, "l", &f); - return pic_callcc(pic, cb); + return pic_callcc(pic, f); } static pic_value pic_cont_dynamic_wind(pic_state *pic) { - struct pic_proc *in, *thunk, *out; + pic_value in, thunk, out; pic_get_args(pic, "lll", &in, &thunk, &out); @@ -281,26 +259,25 @@ pic_cont_values(pic_state *pic) pic_get_args(pic, "*", &argc, &argv); - return pic_values(pic, argc, argv); + return pic_valuesk(pic, argc, argv); } static pic_value pic_cont_call_with_values(pic_state *pic) { - struct pic_proc *producer, *consumer; - int argc; - pic_vec *args; + pic_value producer, consumer, *retv; + int retc; pic_get_args(pic, "ll", &producer, &consumer); - pic_apply0(pic, producer); + pic_call(pic, producer, 0); - argc = pic_receive(pic, 0, NULL); - args = pic_make_vec(pic, argc); + retc = pic_receive(pic, 0, NULL); + retv = pic_alloca(pic, sizeof(pic_value) * retc); - pic_receive(pic, argc, args->data); + pic_receive(pic, retc, retv); - return pic_apply_trampoline(pic, consumer, argc, args->data); + return pic_applyk(pic, consumer, retc, retv); } void diff --git a/extlib/benz/data.c b/extlib/benz/data.c index 0df3ab06..300bb162 100644 --- a/extlib/benz/data.c +++ b/extlib/benz/data.c @@ -1,13 +1,29 @@ #include "picrin.h" +#include "picrin/private/object.h" -struct pic_data * -pic_data_alloc(pic_state *pic, const pic_data_type *type, void *userdata) +bool +pic_data_p(pic_state *pic, pic_value obj, const pic_data_type *type) { - struct pic_data *data; + if (pic_type(pic, obj) != PIC_TYPE_DATA) { + return false; + } + return type == NULL || pic_data_ptr(pic, obj)->type == type; +} - data = (struct pic_data *)pic_obj_alloc(pic, sizeof(struct pic_data), PIC_TT_DATA); +void * +pic_data(pic_state *PIC_UNUSED(pic), pic_value data) +{ + return pic_data_ptr(pic, data)->data; +} + +pic_value +pic_data_value(pic_state *pic, void *userdata, const pic_data_type *type) +{ + struct data *data; + + data = (struct data *)pic_obj_alloc(pic, sizeof(struct data), PIC_TYPE_DATA); data->type = type; data->data = userdata; - return data; + return pic_obj_value(data); } diff --git a/extlib/benz/debug.c b/extlib/benz/debug.c index fb1cb197..d47ed186 100644 --- a/extlib/benz/debug.c +++ b/extlib/benz/debug.c @@ -3,61 +3,64 @@ */ #include "picrin.h" +#include "picrin/extra.h" +#include "picrin/private/object.h" +#include "picrin/private/state.h" -pic_str * +pic_value pic_get_backtrace(pic_state *pic) { - size_t ai = pic_gc_arena_preserve(pic); - pic_callinfo *ci; - pic_str *trace; + size_t ai = pic_enter(pic); + struct callinfo *ci; + pic_value trace; - trace = pic_make_lit(pic, ""); + trace = pic_lit_value(pic, ""); for (ci = pic->ci; ci != pic->cibase; --ci) { - struct pic_proc *proc = pic_proc_ptr(ci->fp[0]); + pic_value proc = ci->fp[0]; - trace = pic_str_cat(pic, trace, pic_make_lit(pic, " at ")); - trace = pic_str_cat(pic, trace, pic_make_lit(pic, "(anonymous lambda)")); + trace = pic_str_cat(pic, trace, pic_lit_value(pic, " at ")); + trace = pic_str_cat(pic, trace, pic_lit_value(pic, "(anonymous lambda)")); - if (pic_proc_func_p(proc)) { - trace = pic_str_cat(pic, trace, pic_make_lit(pic, " (native function)\n")); - } else if (pic_proc_irep_p(proc)) { - trace = pic_str_cat(pic, trace, pic_make_lit(pic, " (unknown location)\n")); /* TODO */ + if (pic_func_p(proc)) { + trace = pic_str_cat(pic, trace, pic_lit_value(pic, " (native function)\n")); + } else { + trace = pic_str_cat(pic, trace, pic_lit_value(pic, " (unknown location)\n")); /* TODO */ } } - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, pic_obj_value(trace)); + pic_leave(pic, ai); + pic_protect(pic, trace); return trace; } -void -pic_print_backtrace(pic_state *pic, xFILE *file) -{ - assert(! pic_invalid_p(pic->err)); +#if PIC_USE_WRITE - if (! pic_error_p(pic->err)) { - xfprintf(pic, file, "raise: "); - pic_fwrite(pic, pic->err, file); +void +pic_print_error(pic_state *pic, xFILE *file) +{ + pic_value err = pic_err(pic), port = pic_open_port(pic, file); + + assert(! pic_invalid_p(pic, err)); + + if (! pic_error_p(pic, err)) { + pic_fprintf(pic, port, "raise: ~s", err); } else { - struct pic_error *e; + struct error *e; pic_value elem, it; - e = pic_error_ptr(pic->err); - if (e->type != pic_intern_lit(pic, "")) { - pic_fwrite(pic, pic_obj_value(e->type), file); - xfprintf(pic, file, " "); + e = pic_error_ptr(pic, err); + if (! pic_eq_p(pic, pic_obj_value(e->type), pic_intern_lit(pic, ""))) { + pic_fprintf(pic, port, "~s-", pic_obj_value(e->type)); } - xfprintf(pic, file, "error: "); - pic_fwrite(pic, pic_obj_value(e->msg), file); + pic_fprintf(pic, port, "error: ~s", pic_obj_value(e->msg)); pic_for_each (elem, e->irrs, it) { /* print error irritants */ - xfprintf(pic, file, " "); - pic_fwrite(pic, elem, file); + pic_fprintf(pic, port, " ~s", elem); } - xfprintf(pic, file, "\n"); - - xfputs(pic, pic_str_cstr(pic, e->stack), file); + pic_fprintf(pic, port, "\n%s", pic_str(pic, pic_obj_value(e->stack))); } } + +#endif diff --git a/extlib/benz/dict.c b/extlib/benz/dict.c index 32af91f5..34f40de7 100644 --- a/extlib/benz/dict.c +++ b/extlib/benz/dict.c @@ -3,86 +3,101 @@ */ #include "picrin.h" +#include "picrin/extra.h" +#include "picrin/private/object.h" -KHASH_DEFINE(dict, pic_sym *, pic_value, kh_ptr_hash_func, kh_ptr_hash_equal) +KHASH_DEFINE(dict, symbol *, pic_value, kh_ptr_hash_func, kh_ptr_hash_equal) -struct pic_dict * +pic_value pic_make_dict(pic_state *pic) { - struct pic_dict *dict; + struct dict *dict; - dict = (struct pic_dict *)pic_obj_alloc(pic, sizeof(struct pic_dict), PIC_TT_DICT); + dict = (struct dict *)pic_obj_alloc(pic, sizeof(struct dict), PIC_TYPE_DICT); kh_init(dict, &dict->hash); - - return dict; + return pic_obj_value(dict); } pic_value -pic_dict_ref(pic_state *pic, struct pic_dict *dict, pic_sym *key) +pic_dict_ref(pic_state *pic, pic_value dict, pic_value key) { - khash_t(dict) *h = &dict->hash; - khiter_t it; + khash_t(dict) *h = &pic_dict_ptr(pic, dict)->hash; + int it; - it = kh_get(dict, h, key); + it = kh_get(dict, h, pic_sym_ptr(pic, key)); if (it == kh_end(h)) { - pic_errorf(pic, "element not found for a key: ~s", pic_obj_value(key)); + pic_error(pic, "element not found for given key", 1, key); } return kh_val(h, it); } void -pic_dict_set(pic_state PIC_UNUSED(*pic), struct pic_dict *dict, pic_sym *key, pic_value val) +pic_dict_set(pic_state *pic, pic_value dict, pic_value key, pic_value val) { - khash_t(dict) *h = &dict->hash; + khash_t(dict) *h = &pic_dict_ptr(pic, dict)->hash; int ret; - khiter_t it; + int it; - it = kh_put(dict, h, key, &ret); + it = kh_put(dict, h, pic_sym_ptr(pic, key), &ret); kh_val(h, it) = val; } int -pic_dict_size(pic_state PIC_UNUSED(*pic), struct pic_dict *dict) +pic_dict_size(pic_state *PIC_UNUSED(pic), pic_value dict) { - return kh_size(&dict->hash); + return kh_size(&pic_dict_ptr(pic, dict)->hash); } bool -pic_dict_has(pic_state PIC_UNUSED(*pic), struct pic_dict *dict, pic_sym *key) +pic_dict_has(pic_state *pic, pic_value dict, pic_value key) { - return kh_get(dict, &dict->hash, key) != kh_end(&dict->hash); + khash_t(dict) *h = &pic_dict_ptr(pic, dict)->hash; + + return kh_get(dict, h, pic_sym_ptr(pic, key)) != kh_end(h); } void -pic_dict_del(pic_state *pic, struct pic_dict *dict, pic_sym *key) +pic_dict_del(pic_state *pic, pic_value dict, pic_value key) { - khash_t(dict) *h = &dict->hash; - khiter_t it; + khash_t(dict) *h = &pic_dict_ptr(pic, dict)->hash; + int it; - it = kh_get(dict, h, key); + it = kh_get(dict, h, pic_sym_ptr(pic, key)); if (it == kh_end(h)) { - pic_errorf(pic, "no slot named ~s found in dictionary", pic_obj_value(key)); + pic_error(pic, "element not found for given key", 1, key); } kh_del(dict, h, it); } +bool +pic_dict_next(pic_state *PIC_UNUSED(pic), pic_value dict, int *iter, pic_value *key, pic_value *val) +{ + khash_t(dict) *h = &pic_dict_ptr(pic, dict)->hash; + int it = *iter; + + for (it = *iter; it != kh_end(h); ++it) { + if (kh_exist(h, it)) { + if (key) *key = pic_obj_value(kh_key(h, it)); + if (val) *val = kh_val(h, it); + *iter = ++it; + return true; + } + } + return false; +} + static pic_value pic_dict_make_dictionary(pic_state *pic) { - struct pic_dict *dict; - pic_get_args(pic, ""); - dict = pic_make_dict(pic); - - return pic_obj_value(dict); + return pic_make_dict(pic); } static pic_value pic_dict_dictionary(pic_state *pic) { - struct pic_dict *dict; - pic_value *argv; + pic_value dict, *argv; int argc, i; pic_get_args(pic, "*", &argc, &argv); @@ -91,10 +106,10 @@ pic_dict_dictionary(pic_state *pic) for (i = 0; i < argc; i += 2) { pic_assert_type(pic, argv[i], sym); - pic_dict_set(pic, dict, pic_sym_ptr(argv[i]), argv[i+1]); + pic_dict_set(pic, dict, argv[i], argv[i+1]); } - return pic_obj_value(dict); + return dict; } static pic_value @@ -104,33 +119,30 @@ pic_dict_dictionary_p(pic_state *pic) pic_get_args(pic, "o", &obj); - return pic_bool_value(pic_dict_p(obj)); + return pic_bool_value(pic, pic_dict_p(pic, obj)); } static pic_value pic_dict_dictionary_ref(pic_state *pic) { - struct pic_dict *dict; - pic_sym *key; + pic_value dict, key; pic_get_args(pic, "dm", &dict, &key); if (! pic_dict_has(pic, dict, key)) { - return pic_false_value(); + return pic_false_value(pic); } - return pic_cons(pic, pic_obj_value(key), pic_dict_ref(pic, dict, key)); + return pic_cons(pic, key, pic_dict_ref(pic, dict, key)); } static pic_value pic_dict_dictionary_set(pic_state *pic) { - struct pic_dict *dict; - pic_sym *key; - pic_value val; + pic_value dict, key, val; pic_get_args(pic, "dmo", &dict, &key, &val); - if (pic_undef_p(val)) { + if (pic_undef_p(pic, val)) { if (pic_dict_has(pic, dict, key)) { pic_dict_del(pic, dict, key); } @@ -138,75 +150,58 @@ pic_dict_dictionary_set(pic_state *pic) else { pic_dict_set(pic, dict, key, val); } - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value pic_dict_dictionary_size(pic_state *pic) { - struct pic_dict *dict; + pic_value dict; pic_get_args(pic, "d", &dict); - return pic_int_value(pic_dict_size(pic, dict)); + return pic_int_value(pic, pic_dict_size(pic, dict)); } static pic_value pic_dict_dictionary_map(pic_state *pic) { - struct pic_proc *proc; - struct pic_dict *dict; - khiter_t it; - khash_t(dict) *kh; - pic_value ret = pic_nil_value(); + pic_value dict, proc, key, ret = pic_nil_value(pic); + int it = 0; pic_get_args(pic, "ld", &proc, &dict); - kh = &dict->hash; - - for (it = kh_begin(kh); it != kh_end(kh); ++it) { - if (kh_exist(kh, it)) { - pic_push(pic, pic_apply1(pic, proc, pic_obj_value(kh_key(kh, it))), ret); - } + while (pic_dict_next(pic, dict, &it, &key, NULL)) { + pic_push(pic, pic_call(pic, proc, 1, key), ret); } - return pic_reverse(pic, ret); } static pic_value pic_dict_dictionary_for_each(pic_state *pic) { - struct pic_proc *proc; - struct pic_dict *dict; - khiter_t it; - khash_t(dict) *kh; + pic_value dict, proc, key; + int it; pic_get_args(pic, "ld", &proc, &dict); - kh = &dict->hash; - - for (it = kh_begin(kh); it != kh_end(kh); ++it) { - if (kh_exist(kh, it)) { - pic_apply1(pic, proc, pic_obj_value(kh_key(kh, it))); - } + while (pic_dict_next(pic, dict, &it, &key, NULL)) { + pic_call(pic, proc, 1, key); } - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value pic_dict_dictionary_to_alist(pic_state *pic) { - struct pic_dict *dict; - pic_value item, alist = pic_nil_value(); - pic_sym *sym; - khiter_t it; + pic_value dict, key, val, alist = pic_nil_value(pic); + int it = 0; pic_get_args(pic, "d", &dict); - pic_dict_for_each (sym, dict, it) { - item = pic_cons(pic, pic_obj_value(sym), pic_dict_ref(pic, dict, sym)); - pic_push(pic, item, alist); + while (pic_dict_next(pic, dict, &it, &key, &val)) { + pic_push(pic, pic_cons(pic, key, val), alist); } return alist; @@ -215,8 +210,7 @@ pic_dict_dictionary_to_alist(pic_state *pic) static pic_value pic_dict_alist_to_dictionary(pic_state *pic) { - struct pic_dict *dict; - pic_value alist, e, it; + pic_value dict, alist, e, it; pic_get_args(pic, "o", &alist); @@ -224,25 +218,23 @@ pic_dict_alist_to_dictionary(pic_state *pic) pic_for_each (e, pic_reverse(pic, alist), it) { pic_assert_type(pic, pic_car(pic, e), sym); - pic_dict_set(pic, dict, pic_sym_ptr(pic_car(pic, e)), pic_cdr(pic, e)); + pic_dict_set(pic, dict, pic_car(pic, e), pic_cdr(pic, e)); } - return pic_obj_value(dict); + return dict; } static pic_value pic_dict_dictionary_to_plist(pic_state *pic) { - struct pic_dict *dict; - pic_value plist = pic_nil_value(); - pic_sym *sym; - khiter_t it; + pic_value dict, key, val, plist = pic_nil_value(pic); + int it = 0; pic_get_args(pic, "d", &dict); - pic_dict_for_each (sym, dict, it) { - pic_push(pic, pic_dict_ref(pic, dict, sym), plist); - pic_push(pic, pic_obj_value(sym), plist); + while (pic_dict_next(pic, dict, &it, &key, &val)) { + pic_push(pic, val, plist); + pic_push(pic, key, plist); } return plist; @@ -251,19 +243,18 @@ pic_dict_dictionary_to_plist(pic_state *pic) static pic_value pic_dict_plist_to_dictionary(pic_state *pic) { - struct pic_dict *dict; - pic_value plist, e; + pic_value dict, plist, e; pic_get_args(pic, "o", &plist); dict = pic_make_dict(pic); - for (e = pic_reverse(pic, plist); ! pic_nil_p(e); e = pic_cddr(pic, e)) { + for (e = pic_reverse(pic, plist); ! pic_nil_p(pic, e); e = pic_cddr(pic, e)) { pic_assert_type(pic, pic_cadr(pic, e), sym); - pic_dict_set(pic, dict, pic_sym_ptr(pic_cadr(pic, e)), pic_car(pic, e)); + pic_dict_set(pic, dict, pic_cadr(pic, e), pic_car(pic, e)); } - return pic_obj_value(dict); + return dict; } void diff --git a/extlib/benz/error.c b/extlib/benz/error.c index e3427809..0105215f 100644 --- a/extlib/benz/error.c +++ b/extlib/benz/error.c @@ -3,68 +3,55 @@ */ #include "picrin.h" +#include "picrin/extra.h" +#include "picrin/private/object.h" +#include "picrin/private/state.h" void -pic_panic(pic_state PIC_UNUSED(*pic), const char *msg) +pic_panic(pic_state *pic, const char *msg) { - extern PIC_NORETURN void abort(); + if (pic->panicf) { + pic->panicf(pic, msg); + } -#if DEBUG - fprintf(stderr, "abort: %s\n", msg); -#else - (void)msg; +#if PIC_USE_STDIO + fprintf(stderr, "picrin panic!: %s\n", msg); #endif + PIC_ABORT(pic); -} - -void -pic_warnf(pic_state *pic, const char *fmt, ...) -{ - va_list ap; - pic_str *err; - - va_start(ap, fmt); - err = pic_vformat(pic, fmt, ap); - va_end(ap); - - xfprintf(pic, pic_stderr(pic)->file, "warn: %s\n", pic_str_cstr(pic, err)); -} - -void -pic_errorf(pic_state *pic, const char *fmt, ...) -{ - va_list ap; - const char *msg; - pic_str *err; - - va_start(ap, fmt); - err = pic_vformat(pic, fmt, ap); - va_end(ap); - - msg = pic_str_cstr(pic, err); - - pic_error(pic, msg, pic_nil_value()); -} - -pic_value -pic_native_exception_handler(pic_state *pic) -{ - pic_value err; - struct pic_proc *self, *cont; - - pic_get_args(pic, "&o", &self, &err); - - pic->err = err; - - cont = pic_proc_ptr(pic_proc_env_ref(pic, self, "cont")); - - pic_apply1(pic, cont, pic_false_value()); PIC_UNREACHABLE(); } void -pic_push_handler(pic_state *pic, struct pic_proc *handler) +pic_warnf(pic_state *pic, const char *fmt, ...) +{ + xFILE *file = pic_fileno(pic, pic_stderr(pic)); + va_list ap; + pic_value err; + + va_start(ap, fmt); + err = pic_vstrf_value(pic, fmt, ap); + va_end(ap); + + xfprintf(pic, file, "warn: %s\n", pic_str(pic, err)); +} + +void +pic_error(pic_state *pic, const char *msg, int n, ...) +{ + va_list ap; + pic_value irrs; + + va_start(ap, n); + irrs = pic_vlist(pic, n, ap); + va_end(ap); + + pic_raise(pic, pic_make_error(pic, "", msg, irrs)); +} + +void +pic_push_handler(pic_state *pic, pic_value handler) { size_t xp_len; ptrdiff_t xp_offset; @@ -72,52 +59,81 @@ pic_push_handler(pic_state *pic, struct pic_proc *handler) if (pic->xp >= pic->xpend) { xp_len = (size_t)(pic->xpend - pic->xpbase) * 2; xp_offset = pic->xp - pic->xpbase; - pic->xpbase = pic_realloc(pic, pic->xpbase, sizeof(struct pic_proc *) * xp_len); + pic->xpbase = pic_realloc(pic, pic->xpbase, sizeof(struct proc *) * xp_len); pic->xp = pic->xpbase + xp_offset; pic->xpend = pic->xpbase + xp_len; } - *pic->xp++ = handler; + *pic->xp++ = pic_proc_ptr(pic, handler); } -struct pic_proc * +pic_value pic_pop_handler(pic_state *pic) { if (pic->xp == pic->xpbase) { pic_panic(pic, "no exception handler registered"); } - return *--pic->xp; + return pic_obj_value(*--pic->xp); } -struct pic_error * -pic_make_error(pic_state *pic, pic_sym *type, const char *msg, pic_value irrs) +static pic_value +native_exception_handler(pic_state *pic) { - struct pic_error *e; - pic_str *stack; + pic_value err; + + pic_get_args(pic, "o", &err); + + pic->err = err; + + pic_call(pic, pic_closure_ref(pic, 0), 1, pic_false_value(pic)); + + PIC_UNREACHABLE(); +} + +void +pic_push_native_handler(pic_state *pic, struct pic_cont *cont) +{ + pic_value handler; + + handler = pic_lambda(pic, native_exception_handler, 1, pic_make_cont(pic, cont)); + + pic_push_handler(pic, handler); +} + +pic_value +pic_err(pic_state *pic) +{ + return pic->err; +} + +pic_value +pic_make_error(pic_state *pic, const char *type, const char *msg, pic_value irrs) +{ + struct error *e; + pic_value stack, ty = pic_intern_cstr(pic, type); stack = pic_get_backtrace(pic); - e = (struct pic_error *)pic_obj_alloc(pic, sizeof(struct pic_error), PIC_TT_ERROR); - e->type = type; - e->msg = pic_make_cstr(pic, msg); + e = (struct error *)pic_obj_alloc(pic, sizeof(struct error), PIC_TYPE_ERROR); + e->type = pic_sym_ptr(pic, ty); + e->msg = pic_str_ptr(pic, pic_cstr_value(pic, msg)); e->irrs = irrs; - e->stack = stack; + e->stack = pic_str_ptr(pic, stack); - return e; + return pic_obj_value(e); } pic_value pic_raise_continuable(pic_state *pic, pic_value err) { - struct pic_proc *handler; - pic_value v; + pic_value handler, v; handler = pic_pop_handler(pic); - pic_gc_protect(pic, pic_obj_value(handler)); + pic_protect(pic, handler); - v = pic_apply1(pic, handler, err); + v = pic_call(pic, handler, 1, err); pic_push_handler(pic, handler); @@ -133,30 +149,19 @@ pic_raise(pic_state *pic, pic_value err) pic_pop_handler(pic); - pic_errorf(pic, "error handler returned with ~s on error ~s", val, err); -} - -void -pic_error(pic_state *pic, const char *msg, pic_value irrs) -{ - struct pic_error *e; - - e = pic_make_error(pic, pic_intern_lit(pic, ""), msg, irrs); - - pic_raise(pic, pic_obj_value(e)); + pic_error(pic, "error handler returned", 2, val, err); } static pic_value pic_error_with_exception_handler(pic_state *pic) { - struct pic_proc *handler, *thunk; - pic_value val; + pic_value handler, thunk, val; pic_get_args(pic, "ll", &handler, &thunk); pic_push_handler(pic, handler); - val = pic_apply0(pic, thunk); + val = pic_call(pic, thunk, 0); pic_pop_handler(pic); @@ -192,7 +197,7 @@ pic_error_error(pic_state *pic) pic_get_args(pic, "z*", &str, &argc, &argv); - pic_error(pic, str, pic_list_by_array(pic, argc, argv)); + pic_raise(pic, pic_make_error(pic, "", str, pic_make_list(pic, argc, argv))); } static pic_value @@ -202,37 +207,43 @@ pic_error_error_object_p(pic_state *pic) pic_get_args(pic, "o", &v); - return pic_bool_value(pic_error_p(v)); + return pic_bool_value(pic, pic_error_p(pic, v)); } static pic_value pic_error_error_object_message(pic_state *pic) { - struct pic_error *e; + pic_value e; - pic_get_args(pic, "e", &e); + pic_get_args(pic, "o", &e); - return pic_obj_value(e->msg); + pic_assert_type(pic, e, error); + + return pic_obj_value(pic_error_ptr(pic, e)->msg); } static pic_value pic_error_error_object_irritants(pic_state *pic) { - struct pic_error *e; + pic_value e; - pic_get_args(pic, "e", &e); + pic_get_args(pic, "o", &e); - return e->irrs; + pic_assert_type(pic, e, error); + + return pic_error_ptr(pic, e)->irrs; } static pic_value pic_error_error_object_type(pic_state *pic) { - struct pic_error *e; + pic_value e; - pic_get_args(pic, "e", &e); + pic_get_args(pic, "o", &e); - return pic_obj_value(e->type); + pic_assert_type(pic, e, error); + + return pic_obj_value(pic_error_ptr(pic, e)->type); } void diff --git a/extlib/benz/eval.c b/extlib/benz/eval.c index ffbafd6c..2564f60c 100644 --- a/extlib/benz/eval.c +++ b/extlib/benz/eval.c @@ -3,61 +3,294 @@ */ #include "picrin.h" -#include "picrin/opcode.h" +#include "picrin/extra.h" +#include "picrin/private/object.h" +#include "picrin/private/vm.h" +#include "picrin/private/state.h" + +static pic_value pic_compile(pic_state *, pic_value); + +#define EQ(sym, lit) (strcmp(pic_sym(pic, sym), lit) == 0) +#define S(lit) (pic_intern_lit(pic, lit)) + +static void +define_macro(pic_state *pic, pic_value uid, pic_value mac) +{ + if (pic_weak_has(pic, pic->macros, uid)) { + pic_warnf(pic, "redefining syntax variable: %s", pic_sym(pic, uid)); + } + pic_weak_set(pic, pic->macros, uid, mac); +} + +static bool +find_macro(pic_state *pic, pic_value uid, pic_value *mac) +{ + if (! pic_weak_has(pic, pic->macros, uid)) { + return false; + } + *mac = pic_weak_ref(pic, pic->macros, uid); + return true; +} + +static void +shadow_macro(pic_state *pic, pic_value uid) +{ + if (pic_weak_has(pic, pic->macros, uid)) { + pic_weak_del(pic, pic->macros, uid); + } +} + +static pic_value expand(pic_state *, pic_value expr, pic_value env, pic_value deferred); +static pic_value expand_lambda(pic_state *, pic_value expr, pic_value env); + +static pic_value +expand_var(pic_state *pic, pic_value id, pic_value env, pic_value deferred) +{ + pic_value mac, functor; + + functor = pic_find_identifier(pic, id, env); + + if (find_macro(pic, functor, &mac)) { + return expand(pic, pic_call(pic, mac, 2, id, env), env, deferred); + } + return functor; +} + +static pic_value +expand_quote(pic_state *pic, pic_value expr) +{ + return pic_cons(pic, S("quote"), pic_cdr(pic, expr)); +} + +static pic_value +expand_list(pic_state *pic, pic_value obj, pic_value env, pic_value deferred) +{ + size_t ai = pic_enter(pic); + pic_value x, head, tail; + + if (pic_pair_p(pic, obj)) { + head = expand(pic, pic_car(pic, obj), env, deferred); + tail = expand_list(pic, pic_cdr(pic, obj), env, deferred); + x = pic_cons(pic, head, tail); + } else { + x = expand(pic, obj, env, deferred); + } + + pic_leave(pic, ai); + pic_protect(pic, x); + return x; +} + +static pic_value +expand_defer(pic_state *pic, pic_value expr, pic_value deferred) +{ + pic_value skel = pic_cons(pic, pic_invalid_value(pic), pic_invalid_value(pic)); + + pic_set_car(pic, deferred, pic_cons(pic, pic_cons(pic, expr, skel), pic_car(pic, deferred))); + + return skel; +} + +static void +expand_deferred(pic_state *pic, pic_value deferred, pic_value env) +{ + pic_value defer, val, src, dst, it; + + deferred = pic_car(pic, deferred); + + pic_for_each (defer, pic_reverse(pic, deferred), it) { + src = pic_car(pic, defer); + dst = pic_cdr(pic, defer); + + val = expand_lambda(pic, src, env); + + /* copy */ + pic_set_car(pic, dst, pic_car(pic, val)); + pic_set_cdr(pic, dst, pic_cdr(pic, val)); + } +} + +static pic_value +expand_lambda(pic_state *pic, pic_value expr, pic_value env) +{ + pic_value formal, body; + pic_value in; + pic_value a, deferred; + + in = pic_make_env(pic, env); + + for (a = pic_cadr(pic, expr); pic_pair_p(pic, a); a = pic_cdr(pic, a)) { + pic_add_identifier(pic, pic_car(pic, a), in); + } + if (pic_id_p(pic, a)) { + pic_add_identifier(pic, a, in); + } + + deferred = pic_list(pic, 1, pic_nil_value(pic)); + + formal = expand_list(pic, pic_list_ref(pic, expr, 1), in, deferred); + body = expand(pic, pic_list_ref(pic, expr, 2), in, deferred); + + expand_deferred(pic, deferred, in); + + return pic_list(pic, 3, S("lambda"), formal, body); +} + +static pic_value +expand_define(pic_state *pic, pic_value expr, pic_value env, pic_value deferred) +{ + pic_value uid, val; + + uid = pic_add_identifier(pic, pic_list_ref(pic, expr, 1), env); + + shadow_macro(pic, uid); + + val = expand(pic, pic_list_ref(pic, expr, 2), env, deferred); + + return pic_list(pic, 3, S("define"), uid, val); +} + +static pic_value +expand_defmacro(pic_state *pic, pic_value expr, pic_value env) +{ + pic_value uid, val; + + uid = pic_add_identifier(pic, pic_list_ref(pic, expr, 1), env); + + val = pic_call(pic, pic_compile(pic, pic_expand(pic, pic_list_ref(pic, expr, 2), env)), 0); + if (! pic_proc_p(pic, val)) { + pic_error(pic, "macro definition evaluates to non-procedure object", 1, pic_list_ref(pic, expr, 1)); + } + + define_macro(pic, uid, val); + + return pic_undef_value(pic); +} + +static pic_value +expand_node(pic_state *pic, pic_value expr, pic_value env, pic_value deferred) +{ + switch (pic_type(pic, expr)) { + case PIC_TYPE_ID: + case PIC_TYPE_SYMBOL: { + return expand_var(pic, expr, env, deferred); + } + case PIC_TYPE_PAIR: { + pic_value mac; + + if (! pic_list_p(pic, expr)) { + pic_error(pic, "cannot expand improper list", 1, expr); + } + + if (pic_id_p(pic, pic_car(pic, expr))) { + pic_value functor; + + functor = pic_find_identifier(pic, pic_car(pic, expr), env); + + if (EQ(functor, "define-macro")) { + return expand_defmacro(pic, expr, env); + } + else if (EQ(functor, "lambda")) { + return expand_defer(pic, expr, deferred); + } + else if (EQ(functor, "define")) { + return expand_define(pic, expr, env, deferred); + } + else if (EQ(functor, "quote")) { + return expand_quote(pic, expr); + } + + if (find_macro(pic, functor, &mac)) { + return expand(pic, pic_call(pic, mac, 2, expr, env), env, deferred); + } + } + return expand_list(pic, expr, env, deferred); + } + default: + return expr; + } +} + +static pic_value +expand(pic_state *pic, pic_value expr, pic_value env, pic_value deferred) +{ + size_t ai = pic_enter(pic); + pic_value v; + + v = expand_node(pic, expr, env, deferred); + + pic_leave(pic, ai); + pic_protect(pic, v); + return v; +} + +pic_value +pic_expand(pic_state *pic, pic_value expr, pic_value env) +{ + pic_value v, deferred; + + deferred = pic_list(pic, 1, pic_nil_value(pic)); + + v = expand(pic, expr, env, deferred); + + expand_deferred(pic, deferred, env); + + return v; +} static pic_value optimize_beta(pic_state *pic, pic_value expr) { - size_t ai = pic_gc_arena_preserve(pic); + size_t ai = pic_enter(pic); pic_value functor, formals, args, tmp, val, it, defs; - if (! pic_list_p(expr)) + if (! pic_list_p(pic, expr)) return expr; - if (pic_nil_p(expr)) + if (pic_nil_p(pic, expr)) return expr; - if (pic_sym_p(pic_list_ref(pic, expr, 0))) { - pic_sym *sym = pic_sym_ptr(pic_list_ref(pic, expr, 0)); + if (pic_sym_p(pic, pic_list_ref(pic, expr, 0))) { + pic_value sym = pic_list_ref(pic, expr, 0); - if (sym == pic->sQUOTE) { + if (EQ(sym, "quote")) { return expr; - } else if (sym == pic->sLAMBDA) { - return pic_list3(pic, pic_list_ref(pic, expr, 0), pic_list_ref(pic, expr, 1), optimize_beta(pic, pic_list_ref(pic, expr, 2))); + } else if (EQ(sym, "lambda")) { + return pic_list(pic, 3, S("lambda"), pic_list_ref(pic, expr, 1), optimize_beta(pic, pic_list_ref(pic, expr, 2))); } } - tmp = pic_nil_value(); + tmp = pic_nil_value(pic); pic_for_each (val, expr, it) { pic_push(pic, optimize_beta(pic, val), tmp); } expr = pic_reverse(pic, tmp); - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, expr); + pic_leave(pic, ai); + pic_protect(pic, expr); functor = pic_list_ref(pic, expr, 0); - if (pic_pair_p(functor) && pic_eq_p(pic_car(pic, functor), pic_obj_value(pic->sLAMBDA))) { + if (pic_pair_p(pic, functor) && EQ(pic_car(pic, functor), "lambda")) { formals = pic_list_ref(pic, functor, 1); - if (! pic_list_p(formals)) + if (! pic_list_p(pic, formals)) goto exit; /* TODO: support ((lambda args x) 1 2) */ args = pic_cdr(pic, expr); if (pic_length(pic, formals) != pic_length(pic, args)) goto exit; - defs = pic_nil_value(); + defs = pic_nil_value(pic); pic_for_each (val, args, it) { - pic_push(pic, pic_list3(pic, pic_obj_value(pic->sDEFINE), pic_car(pic, formals), val), defs); + pic_push(pic, pic_list(pic, 3, S("define"), pic_car(pic, formals), val), defs); formals = pic_cdr(pic, formals); } expr = pic_list_ref(pic, functor, 2); pic_for_each (val, defs, it) { - expr = pic_list3(pic, pic_obj_value(pic->sBEGIN), val, expr); + expr = pic_list(pic, 3, S("begin"), val, expr); } } exit: - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, expr); + pic_leave(pic, ai); + pic_protect(pic, expr); return expr; } @@ -67,17 +300,10 @@ pic_optimize(pic_state *pic, pic_value expr) return optimize_beta(pic, expr); } -KHASH_DECLARE(a, pic_sym *, int) -KHASH_DEFINE2(a, pic_sym *, int, 0, kh_ptr_hash_func, kh_ptr_hash_equal) - -/** - * TODO: don't use khash_t, use kvec_t instead - */ - typedef struct analyze_scope { int depth; - pic_sym *rest; /* Nullable */ - khash_t(a) args, locals, captures; /* rest args variable is counted as a local */ + pic_value rest; /* Nullable */ + pic_value args, locals, captures; /* rest args variable is counted as a local */ pic_value defer; struct analyze_scope *up; } analyze_scope; @@ -85,52 +311,48 @@ typedef struct analyze_scope { static void analyzer_scope_init(pic_state *pic, analyze_scope *scope, pic_value formal, analyze_scope *up) { - int ret; - - kh_init(a, &scope->args); - kh_init(a, &scope->locals); - kh_init(a, &scope->captures); + scope->args = pic_make_dict(pic); + scope->locals = pic_make_dict(pic); + scope->captures = pic_make_dict(pic); /* analyze formal */ - for (; pic_pair_p(formal); formal = pic_cdr(pic, formal)) { - kh_put(a, &scope->args, pic_sym_ptr(pic_car(pic, formal)), &ret); + for (; pic_pair_p(pic, formal); formal = pic_cdr(pic, formal)) { + pic_dict_set(pic, scope->args, pic_car(pic, formal), pic_true_value(pic)); } - if (pic_nil_p(formal)) { - scope->rest = NULL; + if (pic_nil_p(pic, formal)) { + scope->rest = pic_false_value(pic); } else { - scope->rest = pic_sym_ptr(formal); - kh_put(a, &scope->locals, pic_sym_ptr(formal), &ret); + scope->rest = formal; + pic_dict_set(pic, scope->locals, formal, pic_true_value(pic)); } scope->up = up; scope->depth = up ? up->depth + 1 : 0; - scope->defer = pic_list1(pic, pic_nil_value()); + scope->defer = pic_list(pic, 1, pic_nil_value(pic)); } static void -analyzer_scope_destroy(pic_state *pic, analyze_scope *scope) +analyzer_scope_destroy(pic_state *PIC_UNUSED(pic), analyze_scope *PIC_UNUSED(scope)) { - kh_destroy(a, &scope->args); - kh_destroy(a, &scope->locals); - kh_destroy(a, &scope->captures); + /* nothing here */ } static bool -search_scope(pic_state *pic, analyze_scope *scope, pic_sym *sym) +find_local_var(pic_state *pic, analyze_scope *scope, pic_value sym) { - return kh_get(a, &scope->args, sym) != kh_end(&scope->args) || kh_get(a, &scope->locals, sym) != kh_end(&scope->locals) || scope->depth == 0; + return pic_dict_has(pic, scope->args, sym) || pic_dict_has(pic, scope->locals, sym) || scope->depth == 0; } static int -find_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) +find_var(pic_state *pic, analyze_scope *scope, pic_value sym) { - int depth = 0, ret; + int depth = 0; while (scope) { - if (search_scope(pic, scope, sym)) { + if (find_local_var(pic, scope, sym)) { if (depth > 0) { - kh_put(a, &scope->captures, sym, &ret); /* capture! */ + pic_dict_set(pic, scope->captures, sym, pic_true_value(pic)); /* capture! */ } return depth; } @@ -141,52 +363,50 @@ find_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) } static void -define_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) +define_var(pic_state *pic, analyze_scope *scope, pic_value sym) { - int ret; - - if (search_scope(pic, scope, sym)) { - if (scope->depth > 0 || pic_weak_has(pic, pic->globals, sym)) { - pic_warnf(pic, "redefining variable: ~s", pic_obj_value(sym)); + if (scope->depth > 0) { + /* local */ + if (find_local_var(pic, scope, sym)) { + pic_warnf(pic, "redefining variable: %s", pic_sym(pic, sym)); + return; } - return; + pic_dict_set(pic, scope->locals, sym, pic_true_value(pic)); + } else { + /* global */ + if (pic_weak_has(pic, pic->globals, sym)) { + pic_warnf(pic, "redefining variable: %s", pic_sym(pic, sym)); + return; + } + pic_weak_set(pic, pic->globals, sym, pic_invalid_value(pic)); } - - pic_weak_set(pic, pic->globals, sym, pic_invalid_value()); - - kh_put(a, &scope->locals, sym, &ret); } static pic_value analyze(pic_state *, analyze_scope *, pic_value); static pic_value analyze_lambda(pic_state *, analyze_scope *, pic_value); -#define GREF pic_intern_lit(pic, "gref") -#define LREF pic_intern_lit(pic, "lref") -#define CREF pic_intern_lit(pic, "cref") -#define CALL pic_intern_lit(pic, "call") - static pic_value -analyze_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) +analyze_var(pic_state *pic, analyze_scope *scope, pic_value sym) { int depth; depth = find_var(pic, scope, sym); if (depth == scope->depth) { - return pic_list2(pic, pic_obj_value(GREF), pic_obj_value(sym)); + return pic_list(pic, 2, S("gref"), sym); } else if (depth == 0) { - return pic_list2(pic, pic_obj_value(LREF), pic_obj_value(sym)); + return pic_list(pic, 2, S("lref"), sym); } else { - return pic_list3(pic, pic_obj_value(CREF), pic_int_value(depth), pic_obj_value(sym)); + return pic_list(pic, 3, S("cref"), pic_int_value(pic, depth), sym); } } static pic_value analyze_defer(pic_state *pic, analyze_scope *scope, pic_value form) { - pic_value skel = pic_cons(pic, pic_invalid_value(), pic_invalid_value()); + pic_value skel = pic_cons(pic, pic_invalid_value(pic), pic_invalid_value(pic)); - pic_set_car(pic, scope->defer, pic_acons(pic, form, skel, pic_car(pic, scope->defer))); + pic_set_car(pic, scope->defer, pic_cons(pic, pic_cons(pic, form, skel), pic_car(pic, scope->defer))); return skel; } @@ -215,10 +435,9 @@ analyze_lambda(pic_state *pic, analyze_scope *up, pic_value form) { analyze_scope s, *scope = &s; pic_value formals, body; - pic_value rest = pic_undef_value(); - pic_vec *args, *locals, *captures; - int i, j; - khiter_t it; + pic_value rest; + pic_value args, locals, captures, key; + int i, j, it; formals = pic_list_ref(pic, form, 1); body = pic_list_ref(pic, form, 2); @@ -229,44 +448,41 @@ analyze_lambda(pic_state *pic, analyze_scope *up, pic_value form) body = analyze(pic, scope, body); analyze_deferred(pic, scope); - args = pic_make_vec(pic, kh_size(&scope->args)); - for (i = 0; pic_pair_p(formals); formals = pic_cdr(pic, formals), i++) { - args->data[i] = pic_car(pic, formals); + args = pic_make_vec(pic, pic_dict_size(pic, scope->args), NULL); + for (i = 0; pic_pair_p(pic, formals); formals = pic_cdr(pic, formals), i++) { + pic_vec_set(pic, args, i, pic_car(pic, formals)); } - if (scope->rest != NULL) { - rest = pic_obj_value(scope->rest); - } + rest = scope->rest; - locals = pic_make_vec(pic, kh_size(&scope->locals)); + locals = pic_make_vec(pic, pic_dict_size(pic, scope->locals), NULL); j = 0; - if (scope->rest != NULL) { - locals->data[j++] = pic_obj_value(scope->rest); + if (pic_sym_p(pic, scope->rest)) { + pic_vec_set(pic, locals, j++, scope->rest); } - for (it = kh_begin(&scope->locals); it < kh_end(&scope->locals); ++it) { - if (kh_exist(&scope->locals, it)) { - if (scope->rest != NULL && kh_key(&scope->locals, it) == scope->rest) - continue; - locals->data[j++] = pic_obj_value(kh_key(&scope->locals, it)); - } + it = 0; + while (pic_dict_next(pic, scope->locals, &it, &key, NULL)) { + if (pic_eq_p(pic, key, rest)) + continue; + pic_vec_set(pic, locals, j++, key); } - captures = pic_make_vec(pic, kh_size(&scope->captures)); - for (it = kh_begin(&scope->captures), j = 0; it < kh_end(&scope->captures); ++it) { - if (kh_exist(&scope->captures, it)) { - captures->data[j++] = pic_obj_value(kh_key(&scope->captures, it)); - } + captures = pic_make_vec(pic, pic_dict_size(pic, scope->captures), NULL); + it = 0; + j = 0; + while (pic_dict_next(pic, scope->captures, &it, &key, NULL)) { + pic_vec_set(pic, captures, j++, key); } analyzer_scope_destroy(pic, scope); - return pic_list6(pic, pic_obj_value(pic->sLAMBDA), rest, pic_obj_value(args), pic_obj_value(locals), pic_obj_value(captures), body); + return pic_list(pic, 6, S("lambda"), rest, args, locals, captures, body); } static pic_value analyze_list(pic_state *pic, analyze_scope *scope, pic_value obj) { - pic_value seq = pic_nil_value(), val, it; + pic_value seq = pic_nil_value(pic), val, it; pic_for_each (val, obj, it) { pic_push(pic, analyze(pic, scope, val), seq); @@ -278,7 +494,7 @@ analyze_list(pic_state *pic, analyze_scope *scope, pic_value obj) static pic_value analyze_define(pic_state *pic, analyze_scope *scope, pic_value obj) { - define_var(pic, scope, pic_sym_ptr(pic_list_ref(pic, obj, 1))); + define_var(pic, scope, pic_list_ref(pic, obj, 1)); return pic_cons(pic, pic_car(pic, obj), analyze_list(pic, scope, pic_cdr(pic, obj))); } @@ -286,37 +502,37 @@ analyze_define(pic_state *pic, analyze_scope *scope, pic_value obj) static pic_value analyze_call(pic_state *pic, analyze_scope *scope, pic_value obj) { - return pic_cons(pic, pic_obj_value(CALL), analyze_list(pic, scope, obj)); + return pic_cons(pic, S("call"), analyze_list(pic, scope, obj)); } static pic_value analyze_node(pic_state *pic, analyze_scope *scope, pic_value obj) { - switch (pic_type(obj)) { - case PIC_TT_SYMBOL: { - return analyze_var(pic, scope, pic_sym_ptr(obj)); + switch (pic_type(pic, obj)) { + case PIC_TYPE_SYMBOL: { + return analyze_var(pic, scope, obj); } - case PIC_TT_PAIR: { + case PIC_TYPE_PAIR: { pic_value proc; - if (! pic_list_p(obj)) { - pic_errorf(pic, "invalid expression given: ~s", obj); + if (! pic_list_p(pic, obj)) { + pic_error(pic, "invalid expression given", 1, obj); } proc = pic_list_ref(pic, obj, 0); - if (pic_sym_p(proc)) { - pic_sym *sym = pic_sym_ptr(proc); + if (pic_sym_p(pic, proc)) { + pic_value sym = proc; - if (sym == pic->sDEFINE) { + if (EQ(sym, "define")) { return analyze_define(pic, scope, obj); } - else if (sym == pic->sLAMBDA) { + else if (EQ(sym, "lambda")) { return analyze_defer(pic, scope, obj); } - else if (sym == pic->sQUOTE) { + else if (EQ(sym, "quote")) { return obj; } - else if (sym == pic->sBEGIN || sym == pic->sSETBANG || sym == pic->sIF) { + else if (EQ(sym, "begin") || EQ(sym, "set!") || EQ(sym, "if")) { return pic_cons(pic, pic_car(pic, obj), analyze_list(pic, scope, pic_cdr(pic, obj))); } } @@ -324,20 +540,20 @@ analyze_node(pic_state *pic, analyze_scope *scope, pic_value obj) return analyze_call(pic, scope, obj); } default: - return pic_list2(pic, pic_obj_value(pic->sQUOTE), obj); + return pic_list(pic, 2, S("quote"), obj); } } static pic_value analyze(pic_state *pic, analyze_scope *scope, pic_value obj) { - size_t ai = pic_gc_arena_preserve(pic); + size_t ai = pic_enter(pic); pic_value res; res = analyze_node(pic, scope, obj); - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, res); + pic_leave(pic, ai); + pic_protect(pic, res); return res; } @@ -346,7 +562,7 @@ pic_analyze(pic_state *pic, pic_value obj) { analyze_scope s, *scope = &s; - analyzer_scope_init(pic, scope, pic_nil_value(), NULL); + analyzer_scope_init(pic, scope, pic_nil_value(pic), NULL); obj = analyze(pic, scope, obj); @@ -358,20 +574,20 @@ pic_analyze(pic_state *pic, pic_value obj) typedef struct codegen_context { /* rest args variable is counted as a local */ - pic_sym *rest; - pic_vec *args, *locals, *captures; + pic_value rest; + pic_value args, locals, captures; /* actual bit code sequence */ - pic_code *code; + struct code *code; size_t clen, ccapa; /* child ireps */ - struct pic_irep **irep; + struct irep **irep; size_t ilen, icapa; /* constant object pool */ int *ints; size_t klen, kcapa; double *nums; size_t flen, fcapa; - struct pic_object **pool; + struct object **pool; size_t plen, pcapa; struct codegen_context *up; @@ -380,7 +596,7 @@ typedef struct codegen_context { static void create_activation(pic_state *, codegen_context *); static void -codegen_context_init(pic_state *pic, codegen_context *cxt, codegen_context *up, pic_sym *rest, pic_vec *args, pic_vec *locals, pic_vec *captures) +codegen_context_init(pic_state *pic, codegen_context *cxt, codegen_context *up, pic_value rest, pic_value args, pic_value locals, pic_value captures) { cxt->up = up; cxt->rest = rest; @@ -389,15 +605,15 @@ codegen_context_init(pic_state *pic, codegen_context *cxt, codegen_context *up, cxt->locals = locals; cxt->captures = captures; - cxt->code = pic_calloc(pic, PIC_ISEQ_SIZE, sizeof(pic_code)); + cxt->code = pic_calloc(pic, PIC_ISEQ_SIZE, sizeof(struct code)); cxt->clen = 0; cxt->ccapa = PIC_ISEQ_SIZE; - cxt->irep = pic_calloc(pic, PIC_IREP_SIZE, sizeof(struct pic_irep *)); + cxt->irep = pic_calloc(pic, PIC_IREP_SIZE, sizeof(struct irep *)); cxt->ilen = 0; cxt->icapa = PIC_IREP_SIZE; - cxt->pool = pic_calloc(pic, PIC_POOL_SIZE, sizeof(struct pic_object *)); + cxt->pool = pic_calloc(pic, PIC_POOL_SIZE, sizeof(struct object *)); cxt->plen = 0; cxt->pcapa = PIC_POOL_SIZE; @@ -412,23 +628,23 @@ codegen_context_init(pic_state *pic, codegen_context *cxt, codegen_context *up, create_activation(pic, cxt); } -static struct pic_irep * +static struct irep * codegen_context_destroy(pic_state *pic, codegen_context *cxt) { - struct pic_irep *irep; + struct irep *irep; /* create irep */ - irep = pic_malloc(pic, sizeof(struct pic_irep)); + irep = pic_malloc(pic, sizeof(struct irep)); irep->refc = 1; - irep->varg = cxt->rest != NULL; - irep->argc = (int)cxt->args->len + 1; - irep->localc = (int)cxt->locals->len; - irep->capturec = (int)cxt->captures->len; - irep->code = pic_realloc(pic, cxt->code, sizeof(pic_code) * cxt->clen); - irep->irep = pic_realloc(pic, cxt->irep, sizeof(struct pic_irep *) * cxt->ilen); + irep->varg = pic_sym_p(pic, cxt->rest); + irep->argc = pic_vec_len(pic, cxt->args) + 1; + irep->localc = pic_vec_len(pic, cxt->locals); + irep->capturec = pic_vec_len(pic, cxt->captures); + irep->code = pic_realloc(pic, cxt->code, sizeof(struct code) * cxt->clen); + irep->irep = pic_realloc(pic, cxt->irep, sizeof(struct irep *) * cxt->ilen); irep->ints = pic_realloc(pic, cxt->ints, sizeof(int) * cxt->klen); irep->nums = pic_realloc(pic, cxt->nums, sizeof(double) * cxt->flen); - irep->pool = pic_realloc(pic, cxt->pool, sizeof(struct pic_object *) * cxt->plen); + irep->pool = pic_realloc(pic, cxt->pool, sizeof(struct object *) * cxt->plen); irep->ncode = cxt->clen; irep->nirep = cxt->ilen; irep->nints = cxt->klen; @@ -450,9 +666,9 @@ codegen_context_destroy(pic_state *pic, codegen_context *cxt) } \ } while (0) -#define check_code_size(pic, cxt) check_size(pic, cxt, c, code, pic_code) -#define check_irep_size(pic, cxt) check_size(pic, cxt, i, irep, struct pic_irep *) -#define check_pool_size(pic, cxt) check_size(pic, cxt, p, pool, struct pic_object *) +#define check_code_size(pic, cxt) check_size(pic, cxt, c, code, struct code) +#define check_irep_size(pic, cxt) check_size(pic, cxt, i, irep, struct irep *) +#define check_pool_size(pic, cxt) check_size(pic, cxt, p, pool, struct object *) #define check_ints_size(pic, cxt) check_size(pic, cxt, k, ints, int) #define check_nums_size(pic, cxt) check_size(pic, cxt, f, nums, double) @@ -480,7 +696,7 @@ codegen_context_destroy(pic_state *pic, codegen_context *cxt) #define emit_ret(pic, cxt, tailpos) if (tailpos) emit_n(pic, cxt, OP_RET) static int -index_capture(codegen_context *cxt, pic_sym *sym, int depth) +index_capture(pic_state *pic, codegen_context *cxt, pic_value sym, int depth) { int i; @@ -488,39 +704,39 @@ index_capture(codegen_context *cxt, pic_sym *sym, int depth) cxt = cxt->up; } - for (i = 0; i < cxt->captures->len; ++i) { - if (pic_sym_ptr(cxt->captures->data[i]) == sym) + for (i = 0; i < pic_vec_len(pic, cxt->captures); ++i) { + if (pic_eq_p(pic, sym, pic_vec_ref(pic, cxt->captures, i))) return i; } return -1; } static int -index_local(codegen_context *cxt, pic_sym *sym) +index_local(pic_state *pic, codegen_context *cxt, pic_value sym) { int i, offset; offset = 1; - for (i = 0; i < cxt->args->len; ++i) { - if (pic_sym_ptr(cxt->args->data[i]) == sym) + for (i = 0; i < pic_vec_len(pic, cxt->args); ++i) { + if (pic_eq_p(pic, sym, pic_vec_ref(pic, cxt->args, i))) return i + offset; } offset += i; - for (i = 0; i < cxt->locals->len; ++i) { - if (pic_sym_ptr(cxt->locals->data[i]) == sym) + for (i = 0; i < pic_vec_len(pic, cxt->locals); ++i) { + if (pic_eq_p(pic, sym, pic_vec_ref(pic, cxt->locals, i))) return i + offset; } return -1; } static int -index_global(pic_state *pic, codegen_context *cxt, pic_sym *name) +index_global(pic_state *pic, codegen_context *cxt, pic_value name) { int pidx; check_pool_size(pic, cxt); pidx = (int)cxt->plen++; - cxt->pool[pidx] = (struct pic_object *)name; + cxt->pool[pidx] = (struct object *)pic_sym_ptr(pic, name); return pidx; } @@ -530,10 +746,11 @@ create_activation(pic_state *pic, codegen_context *cxt) { int i, n; - for (i = 0; i < cxt->captures->len; ++i) { - n = index_local(cxt, pic_sym_ptr(cxt->captures->data[i])); + for (i = 0; i < pic_vec_len(pic, cxt->captures); ++i) { + pic_value sym = pic_vec_ref(pic, cxt->captures, i); + n = index_local(pic, cxt, sym); assert(n != -1); - if (n <= cxt->args->len || cxt->rest == pic_sym_ptr(cxt->captures->data[i])) { + if (n <= pic_vec_len(pic, cxt->args) || pic_eq_p(pic, sym, cxt->rest)) { /* copy arguments to capture variable area */ emit_i(pic, cxt, OP_LREF, n); } else { @@ -548,35 +765,35 @@ static void codegen(pic_state *, codegen_context *, pic_value, bool); static void codegen_ref(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos) { - pic_sym *sym; + pic_value sym; - sym = pic_sym_ptr(pic_car(pic, obj)); - if (sym == GREF) { - pic_sym *name; + sym = pic_car(pic, obj); + if (EQ(sym, "gref")) { + pic_value name; - name = pic_sym_ptr(pic_list_ref(pic, obj, 1)); + name = pic_list_ref(pic, obj, 1); emit_i(pic, cxt, OP_GREF, index_global(pic, cxt, name)); emit_ret(pic, cxt, tailpos); } - else if (sym == CREF) { - pic_sym *name; + else if (EQ(sym, "cref")) { + pic_value name; int depth; - depth = pic_int(pic_list_ref(pic, obj, 1)); - name = pic_sym_ptr(pic_list_ref(pic, obj, 2)); - emit_r(pic, cxt, OP_CREF, depth, index_capture(cxt, name, depth)); + depth = pic_int(pic, pic_list_ref(pic, obj, 1)); + name = pic_list_ref(pic, obj, 2); + emit_r(pic, cxt, OP_CREF, depth, index_capture(pic, cxt, name, depth)); emit_ret(pic, cxt, tailpos); } - else if (sym == LREF) { - pic_sym *name; + else if (EQ(sym, "lref")) { + pic_value name; int i; - name = pic_sym_ptr(pic_list_ref(pic, obj, 1)); - if ((i = index_capture(cxt, name, 0)) != -1) { - emit_i(pic, cxt, OP_LREF, i + (int)cxt->args->len + (int)cxt->locals->len + 1); + name = pic_list_ref(pic, obj, 1); + if ((i = index_capture(pic, cxt, name, 0)) != -1) { + emit_i(pic, cxt, OP_LREF, i + pic_vec_len(pic, cxt->args) + pic_vec_len(pic, cxt->locals) + 1); emit_ret(pic, cxt, tailpos); } else { - emit_i(pic, cxt, OP_LREF, index_local(cxt, name)); + emit_i(pic, cxt, OP_LREF, index_local(pic, cxt, name)); emit_ret(pic, cxt, tailpos); } } @@ -586,39 +803,39 @@ static void codegen_set(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos) { pic_value var, val; - pic_sym *type; + pic_value type; val = pic_list_ref(pic, obj, 2); codegen(pic, cxt, val, false); var = pic_list_ref(pic, obj, 1); - type = pic_sym_ptr(pic_list_ref(pic, var, 0)); - if (type == GREF) { - pic_sym *name; + type = pic_list_ref(pic, var, 0); + if (EQ(type, "gref")) { + pic_value name; - name = pic_sym_ptr(pic_list_ref(pic, var, 1)); + name = pic_list_ref(pic, var, 1); emit_i(pic, cxt, OP_GSET, index_global(pic, cxt, name)); emit_ret(pic, cxt, tailpos); } - else if (type == CREF) { - pic_sym *name; + else if (EQ(type, "cref")) { + pic_value name; int depth; - depth = pic_int(pic_list_ref(pic, var, 1)); - name = pic_sym_ptr(pic_list_ref(pic, var, 2)); - emit_r(pic, cxt, OP_CSET, depth, index_capture(cxt, name, depth)); + depth = pic_int(pic, pic_list_ref(pic, var, 1)); + name = pic_list_ref(pic, var, 2); + emit_r(pic, cxt, OP_CSET, depth, index_capture(pic, cxt, name, depth)); emit_ret(pic, cxt, tailpos); } - else if (type == LREF) { - pic_sym *name; + else if (EQ(type, "lref")) { + pic_value name; int i; - name = pic_sym_ptr(pic_list_ref(pic, var, 1)); - if ((i = index_capture(cxt, name, 0)) != -1) { - emit_i(pic, cxt, OP_LSET, i + (int)cxt->args->len + (int)cxt->locals->len + 1); + name = pic_list_ref(pic, var, 1); + if ((i = index_capture(pic, cxt, name, 0)) != -1) { + emit_i(pic, cxt, OP_LSET, i + pic_vec_len(pic, cxt->args) + pic_vec_len(pic, cxt->locals) + 1); emit_ret(pic, cxt, tailpos); } else { - emit_i(pic, cxt, OP_LSET, index_local(cxt, name)); + emit_i(pic, cxt, OP_LSET, index_local(pic, cxt, name)); emit_ret(pic, cxt, tailpos); } } @@ -628,20 +845,16 @@ static void codegen_lambda(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos) { codegen_context c, *inner_cxt = &c; - pic_value rest_opt, body; - pic_sym *rest = NULL; - pic_vec *args, *locals, *captures; + pic_value rest, body; + pic_value args, locals, captures; check_irep_size(pic, cxt); /* extract arguments */ - rest_opt = pic_list_ref(pic, obj, 1); - if (pic_sym_p(rest_opt)) { - rest = pic_sym_ptr(rest_opt); - } - args = pic_vec_ptr(pic_list_ref(pic, obj, 2)); - locals = pic_vec_ptr(pic_list_ref(pic, obj, 3)); - captures = pic_vec_ptr(pic_list_ref(pic, obj, 4)); + rest = pic_list_ref(pic, obj, 1); + args = pic_list_ref(pic, obj, 2); + locals = pic_list_ref(pic, obj, 3); + captures = pic_list_ref(pic, obj, 4); body = pic_list_ref(pic, obj, 5); /* emit irep */ @@ -693,39 +906,42 @@ codegen_quote(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos) int pidx; obj = pic_list_ref(pic, obj, 1); - switch (pic_type(obj)) { - case PIC_TT_UNDEF: + switch (pic_type(pic, obj)) { + case PIC_TYPE_UNDEF: emit_n(pic, cxt, OP_PUSHUNDEF); break; - case PIC_TT_BOOL: - emit_n(pic, cxt, (pic_true_p(obj) ? OP_PUSHTRUE : OP_PUSHFALSE)); + case PIC_TYPE_TRUE: + emit_n(pic, cxt, OP_PUSHTRUE); break; - case PIC_TT_INT: + case PIC_TYPE_FALSE: + emit_n(pic, cxt, OP_PUSHFALSE); + break; + case PIC_TYPE_INT: check_ints_size(pic, cxt); pidx = (int)cxt->klen++; - cxt->ints[pidx] = pic_int(obj); + cxt->ints[pidx] = pic_int(pic, obj); emit_i(pic, cxt, OP_PUSHINT, pidx); break; - case PIC_TT_FLOAT: + case PIC_TYPE_FLOAT: check_nums_size(pic, cxt); pidx = (int)cxt->flen++; - cxt->nums[pidx] = pic_float(obj); + cxt->nums[pidx] = pic_float(pic, obj); emit_i(pic, cxt, OP_PUSHFLOAT, pidx); break; - case PIC_TT_NIL: + case PIC_TYPE_NIL: emit_n(pic, cxt, OP_PUSHNIL); break; - case PIC_TT_EOF: + case PIC_TYPE_EOF: emit_n(pic, cxt, OP_PUSHEOF); break; - case PIC_TT_CHAR: + case PIC_TYPE_CHAR: check_ints_size(pic, cxt); pidx = (int)cxt->klen++; - cxt->ints[pidx] = pic_char(obj); + cxt->ints[pidx] = pic_char(pic, obj); emit_i(pic, cxt, OP_PUSHCHAR, pidx); break; default: - assert(pic_obj_p(obj)); + assert(pic_obj_p(pic,obj)); check_pool_size(pic, cxt); pidx = (int)cxt->plen++; cxt->pool[pidx] = pic_obj_ptr(obj); @@ -735,12 +951,12 @@ codegen_quote(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos) emit_ret(pic, cxt, tailpos); } -#define VM(uid, op) \ - if (sym == uid) { \ - emit_i(pic, cxt, op, len - 1); \ - emit_ret(pic, cxt, tailpos); \ - return; \ - } +#define VM(name, op) \ + if (EQ(sym, name)) { \ + emit_i(pic, cxt, op, len - 1); \ + emit_ret(pic, cxt, tailpos); \ + return; \ + } static void codegen_call(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos) @@ -753,27 +969,27 @@ codegen_call(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos) } functor = pic_list_ref(pic, obj, 1); - if (pic_sym_ptr(pic_list_ref(pic, functor, 0)) == GREF) { - pic_sym *sym; + if (EQ(pic_list_ref(pic, functor, 0), "gref")) { + pic_value sym; - sym = pic_sym_ptr(pic_list_ref(pic, functor, 1)); + sym = pic_list_ref(pic, functor, 1); - VM(pic->sCONS, OP_CONS) - VM(pic->sCAR, OP_CAR) - VM(pic->sCDR, OP_CDR) - VM(pic->sNILP, OP_NILP) - VM(pic->sSYMBOLP, OP_SYMBOLP) - VM(pic->sPAIRP, OP_PAIRP) - VM(pic->sNOT, OP_NOT) - VM(pic->sEQ, OP_EQ) - VM(pic->sLT, OP_LT) - VM(pic->sLE, OP_LE) - VM(pic->sGT, OP_GT) - VM(pic->sGE, OP_GE) - VM(pic->sADD, OP_ADD) - VM(pic->sSUB, OP_SUB) - VM(pic->sMUL, OP_MUL) - VM(pic->sDIV, OP_DIV) + VM("cons", OP_CONS) + VM("car", OP_CAR) + VM("cdr", OP_CDR) + VM("null?", OP_NILP) + VM("symbol?", OP_SYMBOLP) + VM("pair?", OP_PAIRP) + VM("not", OP_NOT) + VM("=", OP_EQ) + VM("<", OP_LT) + VM("<=", OP_LE) + VM(">", OP_GT) + VM(">=", OP_GE) + VM("+", OP_ADD) + VM("-", OP_SUB) + VM("*", OP_MUL) + VM("/", OP_DIV) } emit_i(pic, cxt, (tailpos ? OP_TAILCALL : OP_CALL), len - 1); @@ -782,100 +998,91 @@ codegen_call(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos) static void codegen(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos) { - pic_sym *sym; + pic_value sym; - sym = pic_sym_ptr(pic_car(pic, obj)); - if (sym == GREF || sym == CREF || sym == LREF) { + sym = pic_car(pic, obj); + if (EQ(sym, "gref") || EQ(sym, "cref") || EQ(sym, "lref")) { codegen_ref(pic, cxt, obj, tailpos); } - else if (sym == pic->sSETBANG || sym == pic->sDEFINE) { + else if (EQ(sym, "set!") || EQ(sym, "define")) { codegen_set(pic, cxt, obj, tailpos); } - else if (sym == pic->sLAMBDA) { + else if (EQ(sym, "lambda")) { codegen_lambda(pic, cxt, obj, tailpos); } - else if (sym == pic->sIF) { + else if (EQ(sym, "if")) { codegen_if(pic, cxt, obj, tailpos); } - else if (sym == pic->sBEGIN) { + else if (EQ(sym, "begin")) { codegen_begin(pic, cxt, obj, tailpos); } - else if (sym == pic->sQUOTE) { + else if (EQ(sym, "quote")) { codegen_quote(pic, cxt, obj, tailpos); } - else if (sym == CALL) { + else if (EQ(sym, "call")) { codegen_call(pic, cxt, obj, tailpos); } else { - pic_errorf(pic, "codegen: unknown AST type ~s", obj); + pic_error(pic, "codegen: unknown AST type", 1, obj); } } -static struct pic_irep * +static struct irep * pic_codegen(pic_state *pic, pic_value obj) { - pic_vec *empty = pic_make_vec(pic, 0); + pic_value empty = pic_make_vec(pic, 0, NULL); codegen_context c, *cxt = &c; - codegen_context_init(pic, cxt, NULL, NULL, empty, empty, empty); + codegen_context_init(pic, cxt, NULL, pic_false_value(pic), empty, empty, empty); codegen(pic, cxt, obj, true); return codegen_context_destroy(pic, cxt); } -#define SAVE(pic, ai, obj) pic_gc_arena_restore(pic, ai); pic_gc_protect(pic, obj) +#define SAVE(pic, ai, obj) pic_leave(pic, ai); pic_protect(pic, obj) -struct pic_proc * +static pic_value pic_compile(pic_state *pic, pic_value obj) { - struct pic_irep *irep; - struct pic_proc *proc; - size_t ai = pic_gc_arena_preserve(pic); + struct irep *irep; + pic_value proc; + size_t ai = pic_enter(pic); -#if DEBUG - fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); +#if 0 + fprintf(stdout, "ai = %zu\n", pic_enter(pic)); fprintf(stdout, "# input expression\n"); pic_write(pic, obj); fprintf(stdout, "\n"); - fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); + fprintf(stdout, "ai = %zu\n", pic_enter(pic)); #endif /* optimize */ obj = pic_optimize(pic, obj); -#if DEBUG +#if 0 fprintf(stdout, "## optimize completed\n"); pic_write(pic, obj); fprintf(stdout, "\n"); - fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); + fprintf(stdout, "ai = %zu\n", pic_enter(pic)); #endif SAVE(pic, ai, obj); /* analyze */ obj = pic_analyze(pic, obj); -#if DEBUG +#if 0 fprintf(stdout, "## analyzer completed\n"); pic_write(pic, obj); fprintf(stdout, "\n"); - fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); + fprintf(stdout, "ai = %zu\n", pic_enter(pic)); #endif SAVE(pic, ai, obj); /* codegen */ irep = pic_codegen(pic, obj); -#if DEBUG - fprintf(stdout, "## codegen completed\n"); - pic_dump_irep(irep); -#endif - -#if DEBUG - fprintf(stdout, "# compilation finished\n"); - puts(""); -#endif proc = pic_make_proc_irep(pic, irep, NULL); @@ -885,20 +1092,22 @@ pic_compile(pic_state *pic, pic_value obj) } pic_value -pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib) +pic_eval(pic_state *pic, pic_value program, const char *lib) { - struct pic_lib *prev_lib = pic->lib; - pic_value r; + const char *prev_lib = pic_current_library(pic); + pic_value env, r; - pic->lib = lib; + env = pic_library_environment(pic, lib); + + pic_in_library(pic, lib); pic_try { - r = pic_apply0(pic, pic_compile(pic, pic_expand(pic, program, lib->env))); + r = pic_call(pic, pic_compile(pic, pic_expand(pic, program, env)), 0); } pic_catch { - pic->lib = prev_lib; - pic_raise(pic, pic->err); + pic_in_library(pic, prev_lib); + pic_raise(pic, pic_err(pic)); } - pic->lib = prev_lib; + pic_in_library(pic, prev_lib); return r; } @@ -906,13 +1115,12 @@ pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib) static pic_value pic_eval_eval(pic_state *pic) { - pic_value program, lib; + pic_value program; + const char *str; - pic_get_args(pic, "oo", &program, &lib); + pic_get_args(pic, "oz", &program, &str); - pic_assert_type(pic, lib, lib); - - return pic_eval(pic, program, pic_lib_ptr(lib)); + return pic_eval(pic, program, str); } void diff --git a/extlib/benz/file.c b/extlib/benz/file.c index 334a4315..7b846b00 100644 --- a/extlib/benz/file.c +++ b/extlib/benz/file.c @@ -1,4 +1,13 @@ +/** + * See Copyright Notice in picrin.h + */ + #include "picrin.h" +#include "picrin/private/state.h" + +#ifndef EOF +# define EOF (-1) +#endif xFILE *xfunopen(pic_state *pic, void *cookie, int (*read)(pic_state *, void *, char *, int), int (*write)(pic_state *, void *, const char *, int), long (*seek)(pic_state *, void *, long, int), int (*close)(pic_state *, void *)) { xFILE *fp; @@ -31,6 +40,18 @@ int xfclose(pic_state *pic, xFILE *fp) { return fp->vtable.close(pic, fp->vtable.cookie); } +void xclearerr(pic_state *PIC_UNUSED(pic), xFILE *fp) { + fp->flag &= ~(X_EOF | X_ERR); +} + +int xfeof(pic_state *PIC_UNUSED(pic), xFILE *fp) { + return (fp->flag & X_EOF) != 0; +} + +int xferror(pic_state *PIC_UNUSED(pic), xFILE *fp) { + return (fp->flag & X_ERR) != 0; +} + int x_fillbuf(pic_state *pic, xFILE *fp) { int bufsize; @@ -137,6 +158,15 @@ int xfflush(pic_state *pic, xFILE *f) { return retval; } +#define xgetc(pic, p) \ + ((--(p)->cnt >= 0) \ + ? (unsigned char) *(p)->ptr++ \ + : x_fillbuf((pic), p)) +#define xputc(pic, x, p) \ + ((--(p)->cnt >= 0 && !(((p)->flag & X_LNBUF) && (x) == '\n')) \ + ? *(p)->ptr++ = (x) \ + : x_flushbuf((pic), (x), (p))) + int xfputc(pic_state *pic, int x, xFILE *fp) { return xputc(pic, x, fp); } @@ -156,7 +186,7 @@ int xfputs(pic_state *pic, const char *s, xFILE *stream) { } char *xfgets(pic_state *pic, char *s, int size, xFILE *stream) { - int c; + int c = 0; char *buf; xfflush(pic, NULL); @@ -174,36 +204,7 @@ char *xfgets(pic_state *pic, char *s, int size, xFILE *stream) { return (c == EOF && buf == s) ? NULL : s; } -int xputs(pic_state *pic, const char *s) { - int i = 1; - - while(*s != '\0') { - if (xputchar(pic, *s++) == EOF) - return EOF; - i++; - } - if (xputchar(pic, '\n') == EOF) { - return EOF; - } - return i; -} - -char *xgets(pic_state *pic, char *s) { - int c; - char *buf; - - xfflush(pic, NULL); - - buf = s; - while ((c = xgetchar(pic)) != EOF && c != '\n') { - *buf++ = c; - } - *buf = '\0'; - - return (c == EOF && buf == s) ? NULL : s; -} - -int xungetc(int c, xFILE *fp) { +int xungetc(pic_state *PIC_UNUSED(pic), int c, xFILE *fp) { unsigned char uc = c; if (c == EOF || fp->base == fp->ptr) { @@ -227,7 +228,7 @@ size_t xfread(pic_state *pic, void *ptr, size_t size, size_t count, xFILE *fp) { if ((c = x_fillbuf(pic, fp)) == EOF) { return (size * count - nbytes) / size; } else { - xungetc(c, fp); + xungetc(pic, c, fp); } } memcpy(bptr, fp->ptr, nbytes); @@ -270,25 +271,6 @@ long xfseek(pic_state *pic, xFILE *fp, long offset, int whence) { return 0; } -long xftell(pic_state *pic, xFILE *fp) { - return xfseek(pic, fp, 0, XSEEK_CUR); -} - -void xrewind(pic_state *pic, xFILE *fp) { - xfseek(pic, fp, 0, XSEEK_SET); - xclearerr(fp); -} - -int xprintf(pic_state *pic, const char *fmt, ...) { - va_list ap; - int n; - - va_start(ap, fmt); - n = xvfprintf(pic, xstdout, fmt, ap); - va_end(ap); - return n; -} - int xfprintf(pic_state *pic, xFILE *stream, const char *fmt, ...) { va_list ap; int n; @@ -378,16 +360,199 @@ int xvfprintf(pic_state *pic, xFILE *stream, const char *fmt, va_list ap) { return cnt; } -#if 0 -int main() -{ - char buf[256]; +xFILE *xfile_xstdin(pic_state *pic) { return &pic->files[0]; } +xFILE *xfile_xstdout(pic_state *pic) { return &pic->files[1]; } +xFILE *xfile_xstderr(pic_state *pic) { return &pic->files[2]; } - xgets(buf); +#if PIC_USE_STDIO - xprintf("%s\n", buf); - xprintf("hello\n"); - xprintf("hello\n"); - // xfflush(0); +static int +file_read(pic_state *PIC_UNUSED(pic), void *cookie, char *ptr, int size) { + FILE *file = cookie; + int r; + + size = 1; /* override size */ + + r = (int)fread(ptr, 1, (size_t)size, file); + if (r < size && ferror(file)) { + return -1; + } + if (r == 0 && feof(file)) { + clearerr(file); + } + return r; } + +static int +file_write(pic_state *PIC_UNUSED(pic), void *cookie, const char *ptr, int size) { + FILE *file = cookie; + int r; + + r = (int)fwrite(ptr, 1, (size_t)size, file); + if (r < size) { + return -1; + } + fflush(cookie); + return r; +} + +static long +file_seek(pic_state *PIC_UNUSED(pic), void *cookie, long pos, int whence) { + switch (whence) { + case XSEEK_CUR: + whence = SEEK_CUR; + break; + case XSEEK_SET: + whence = SEEK_SET; + break; + case XSEEK_END: + whence = SEEK_END; + break; + } + if (fseek(cookie, pos, whence) == 0) { + return ftell(cookie); + } + return -1; +} + +static int +file_close(pic_state *PIC_UNUSED(pic), void *cookie) { + return fclose(cookie); +} + +xFILE *xfopen_file(pic_state *pic, FILE *fp, const char *mode) { + xFILE *f; + if (*mode == 'r') { + f = xfunopen(pic, fp, file_read, 0, file_seek, file_close); + } else { + f = xfunopen(pic, fp, 0, file_write, file_seek, file_close); + } + return f; +} + #endif + +typedef struct { char *buf; long pos, end, capa; } xbuf_t; + +static int +string_read(pic_state *PIC_UNUSED(pic), void *cookie, char *ptr, int size) +{ + xbuf_t *m = cookie; + + if (size > (int)(m->end - m->pos)) + size = (int)(m->end - m->pos); + memcpy(ptr, m->buf + m->pos, size); + m->pos += size; + return size; +} + +static int +string_write(pic_state *pic, void *cookie, const char *ptr, int size) +{ + xbuf_t *m = cookie; + + if (m->pos + size >= m->capa) { + m->capa = (m->pos + size) * 2; + m->buf = pic_realloc(pic, m->buf, m->capa); + } + memcpy(m->buf + m->pos, ptr, size); + m->pos += size; + if (m->end < m->pos) + m->end = m->pos; + return size; +} + +static long +string_seek(pic_state *PIC_UNUSED(pic), void *cookie, long pos, int whence) +{ + xbuf_t *m = cookie; + + switch (whence) { + case XSEEK_SET: + m->pos = pos; + break; + case XSEEK_CUR: + m->pos += pos; + break; + case XSEEK_END: + m->pos = m->end + pos; + break; + } + + return m->pos; +} + +static int +string_close(pic_state *pic, void *cookie) +{ + xbuf_t *m = cookie; + + pic_free(pic, m->buf); + pic_free(pic, m); + return 0; +} + +xFILE *xfopen_buf(pic_state *pic, const char *data, int size, const char *mode) { + xbuf_t *m; + xFILE *file; + + m = pic_malloc(pic, sizeof(xbuf_t)); + m->buf = pic_malloc(pic, size); + m->pos = 0; + m->end = size; + m->capa = size; + + if (*mode == 'r') { + memcpy(m->buf, data, size); + file = xfunopen(pic, m, string_read, NULL, string_seek, string_close); + } else { + file = xfunopen(pic, m, NULL, string_write, string_seek, string_close); + } + if (file == NULL) { + string_close(pic, m); + } + return file; +} + +int xfget_buf(pic_state *pic, xFILE *file, const char **buf, int *len) { + xbuf_t *s; + + xfflush(pic, file); + + if (file->vtable.write != string_write) { + return -1; + } + s = file->vtable.cookie; + *len = s->end; + *buf = s->buf; + return 0; +} + +static int +null_read(pic_state *PIC_UNUSED(pic), void *PIC_UNUSED(cookie), char *PIC_UNUSED(ptr), int PIC_UNUSED(size)) { + return 0; +} + +static int +null_write(pic_state *PIC_UNUSED(pic), void *PIC_UNUSED(cookie), const char *PIC_UNUSED(ptr), int size) { + return size; +} + +static long +null_seek(pic_state *PIC_UNUSED(pic), void *PIC_UNUSED(cookie), long PIC_UNUSED(pos), int PIC_UNUSED(whence)) { + return 0; +} + +static int +null_close(pic_state *PIC_UNUSED(pic), void *PIC_UNUSED(cookie)) { + return 0; +} + +xFILE *xfopen_null(pic_state *PIC_UNUSED(pic), const char *mode) { + switch (*mode) { + case 'r': + return xfunopen(pic, 0, null_read, 0, null_seek, null_close); + default: + return xfunopen(pic, 0, 0, null_write, null_seek, null_close); + } +} diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index c5cbe77c..23ddd5e0 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -3,6 +3,13 @@ */ #include "picrin.h" +#include "picrin/private/object.h" +#include "picrin/private/state.h" + +enum { + WHITE = 0, + BLACK = 1 +}; union header { struct { @@ -16,41 +23,39 @@ struct heap_page { struct heap_page *next; }; -struct pic_object { +struct object { union { - struct pic_basic basic; - struct pic_symbol sym; - struct pic_string str; - struct pic_blob blob; - struct pic_pair pair; - struct pic_vector vec; - struct pic_dict dict; - struct pic_weak weak; - struct pic_data data; - struct pic_record rec; - struct pic_id id; - struct pic_env env; - struct pic_proc proc; - struct pic_context cxt; - struct pic_port port; - struct pic_error err; - struct pic_lib lib; - struct pic_checkpoint cp; + struct basic basic; + struct identifier id; + struct string str; + struct blob blob; + struct pair pair; + struct vector vec; + struct dict dict; + struct weak weak; + struct data data; + struct record rec; + struct env env; + struct proc proc; + struct context cxt; + struct port port; + struct error err; + struct checkpoint cp; } u; }; -struct pic_heap { +struct heap { union header base, *freep; struct heap_page *pages; - struct pic_weak *weaks; /* weak map chain */ + struct weak *weaks; /* weak map chain */ }; -struct pic_heap * +struct heap * pic_heap_open(pic_state *pic) { - struct pic_heap *heap; + struct heap *heap; - heap = pic_malloc(pic, sizeof(struct pic_heap)); + heap = pic_malloc(pic, sizeof(struct heap)); heap->base.s.ptr = &heap->base; heap->base.s.size = 0; /* not 1, since it must never be used for allocation */ @@ -64,7 +69,7 @@ pic_heap_open(pic_state *pic) } void -pic_heap_close(pic_state *pic, struct pic_heap *heap) +pic_heap_close(pic_state *pic, struct heap *heap) { struct heap_page *page; @@ -77,9 +82,9 @@ pic_heap_close(pic_state *pic, struct pic_heap *heap) pic_free(pic, heap); } -#if PIC_ENABLE_LIBC +#if PIC_USE_LIBC void * -pic_default_allocf(void PIC_UNUSED(*userdata), void *ptr, size_t size) +pic_default_allocf(void *PIC_UNUSED(userdata), void *ptr, size_t size) { if (size != 0) { return realloc(ptr, size); @@ -132,19 +137,19 @@ pic_free(pic_state *pic, void *ptr) } static void -gc_protect(pic_state *pic, struct pic_object *obj) +gc_protect(pic_state *pic, struct object *obj) { if (pic->arena_idx >= pic->arena_size) { pic->arena_size = pic->arena_size * 2 + 1; - pic->arena = pic_realloc(pic, pic->arena, sizeof(struct pic_object *) * pic->arena_size); + pic->arena = pic_realloc(pic, pic->arena, sizeof(struct object *) * pic->arena_size); } pic->arena[pic->arena_idx++] = obj; } pic_value -pic_gc_protect(pic_state *pic, pic_value v) +pic_protect(pic_state *pic, pic_value v) { - if (! pic_obj_p(v)) + if (! pic_obj_p(pic, v)) return v; gc_protect(pic, pic_obj_ptr(v)); @@ -153,13 +158,13 @@ pic_gc_protect(pic_state *pic, pic_value v) } size_t -pic_gc_arena_preserve(pic_state *pic) +pic_enter(pic_state *pic) { return pic->arena_idx; } void -pic_gc_arena_restore(pic_state *pic, size_t state) +pic_leave(pic_state *pic, size_t state) { pic->arena_idx = state; } @@ -254,38 +259,38 @@ heap_morecore(pic_state *pic) /* MARK */ -static void gc_mark_object(pic_state *, struct pic_object *); +static void gc_mark_object(pic_state *, struct object *); static void gc_mark(pic_state *pic, pic_value v) { - if (! pic_obj_p(v)) + if (! pic_obj_p(pic, v)) return; gc_mark_object(pic, pic_obj_ptr(v)); } static void -gc_mark_object(pic_state *pic, struct pic_object *obj) +gc_mark_object(pic_state *pic, struct object *obj) { loop: - if (obj->u.basic.gc_mark == PIC_GC_MARK) + if (obj->u.basic.gc_mark == BLACK) return; - obj->u.basic.gc_mark = PIC_GC_MARK; + obj->u.basic.gc_mark = BLACK; -#define LOOP(o) obj = (struct pic_object *)(o); goto loop +#define LOOP(o) obj = (struct object *)(o); goto loop switch (obj->u.basic.tt) { - case PIC_TT_PAIR: { + case PIC_TYPE_PAIR: { gc_mark(pic, obj->u.pair.car); - if (pic_obj_p(obj->u.pair.cdr)) { + if (pic_obj_p(pic, obj->u.pair.cdr)) { LOOP(pic_obj_ptr(obj->u.pair.cdr)); } break; } - case PIC_TT_CXT: { + case PIC_TYPE_CXT: { int i; for (i = 0; i < obj->u.cxt.regc; ++i) { @@ -296,144 +301,128 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) } break; } - case PIC_TT_PROC: { - if (pic_proc_irep_p(&obj->u.proc)) { - if (obj->u.proc.u.i.cxt) { - LOOP(obj->u.proc.u.i.cxt); - } - } else { - if (obj->u.proc.u.f.env) { - LOOP(obj->u.proc.u.f.env); - } + case PIC_TYPE_FUNC: { + int i; + for (i = 0; i < obj->u.proc.u.f.localc; ++i) { + gc_mark(pic, obj->u.proc.locals[i]); } break; } - case PIC_TT_PORT: { + case PIC_TYPE_IREP: { + if (obj->u.proc.u.i.cxt) { + LOOP(obj->u.proc.u.i.cxt); + } break; } - case PIC_TT_ERROR: { - gc_mark_object(pic, (struct pic_object *)obj->u.err.type); - gc_mark_object(pic, (struct pic_object *)obj->u.err.msg); + case PIC_TYPE_PORT: { + break; + } + case PIC_TYPE_ERROR: { + gc_mark_object(pic, (struct object *)obj->u.err.type); + gc_mark_object(pic, (struct object *)obj->u.err.msg); gc_mark(pic, obj->u.err.irrs); LOOP(obj->u.err.stack); break; } - case PIC_TT_STRING: { + case PIC_TYPE_STRING: { break; } - case PIC_TT_VECTOR: { + case PIC_TYPE_VECTOR: { int i; for (i = 0; i < obj->u.vec.len; ++i) { gc_mark(pic, obj->u.vec.data[i]); } break; } - case PIC_TT_BLOB: { + case PIC_TYPE_BLOB: { break; } - case PIC_TT_ID: { - gc_mark_object(pic, (struct pic_object *)obj->u.id.u.id.id); - LOOP(obj->u.id.u.id.env); + case PIC_TYPE_ID: { + gc_mark_object(pic, (struct object *)obj->u.id.u.id); + LOOP(obj->u.id.env); break; } - case PIC_TT_ENV: { + case PIC_TYPE_ENV: { khash_t(env) *h = &obj->u.env.map; - khiter_t it; + int it; for (it = kh_begin(h); it != kh_end(h); ++it) { if (kh_exist(h, it)) { - gc_mark_object(pic, (struct pic_object *)kh_key(h, it)); - gc_mark_object(pic, (struct pic_object *)kh_val(h, it)); + gc_mark_object(pic, (struct object *)kh_key(h, it)); + gc_mark_object(pic, (struct object *)kh_val(h, it)); } } - if (obj->u.env.prefix) { - gc_mark_object(pic, (struct pic_object *)obj->u.env.prefix); - } if (obj->u.env.up) { LOOP(obj->u.env.up); } break; } - case PIC_TT_LIB: { - gc_mark(pic, obj->u.lib.name); - gc_mark_object(pic, (struct pic_object *)obj->u.lib.env); - LOOP(obj->u.lib.exports); - break; - } - case PIC_TT_DATA: { + 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_TT_DICT: { - pic_sym *sym; - khiter_t it; + case PIC_TYPE_DICT: { + pic_value key, val; + int it = 0; - pic_dict_for_each (sym, &obj->u.dict, it) { - gc_mark_object(pic, (struct pic_object *)sym); - gc_mark(pic, pic_dict_ref(pic, &obj->u.dict, sym)); + while (pic_dict_next(pic, pic_obj_value(&obj->u.dict), &it, &key, &val)) { + gc_mark(pic, key); + gc_mark(pic, val); } break; } - case PIC_TT_RECORD: { + case PIC_TYPE_RECORD: { gc_mark(pic, obj->u.rec.type); - if (pic_obj_p(obj->u.rec.datum)) { + if (pic_obj_p(pic, obj->u.rec.datum)) { LOOP(pic_obj_ptr(obj->u.rec.datum)); } break; } - case PIC_TT_SYMBOL: { - LOOP(obj->u.sym.str); + case PIC_TYPE_SYMBOL: { + LOOP(obj->u.id.u.str); break; } - case PIC_TT_WEAK: { - struct pic_weak *weak = (struct pic_weak *)obj; + case PIC_TYPE_WEAK: { + struct weak *weak = (struct weak *)obj; weak->prev = pic->heap->weaks; pic->heap->weaks = weak; break; } - case PIC_TT_CP: { + case PIC_TYPE_CP: { if (obj->u.cp.prev) { - gc_mark_object(pic, (struct pic_object *)obj->u.cp.prev); + gc_mark_object(pic, (struct object *)obj->u.cp.prev); } if (obj->u.cp.in) { - gc_mark_object(pic, (struct pic_object *)obj->u.cp.in); + gc_mark_object(pic, (struct object *)obj->u.cp.in); } if (obj->u.cp.out) { - LOOP((struct pic_object *)obj->u.cp.out); + LOOP((struct object *)obj->u.cp.out); } break; } - case PIC_TT_NIL: - case PIC_TT_BOOL: - case PIC_TT_FLOAT: - case PIC_TT_INT: - case PIC_TT_CHAR: - case PIC_TT_EOF: - case PIC_TT_UNDEF: - case PIC_TT_INVALID: - pic_panic(pic, "logic flaw"); + default: + PIC_UNREACHABLE(); } } -#define M(x) gc_mark_object(pic, (struct pic_object *)pic->x) - static void gc_mark_phase(pic_state *pic) { pic_value *stack; - pic_callinfo *ci; - struct pic_proc **xhandler; - struct pic_list *list; + struct callinfo *ci; + struct proc **xhandler; + struct list_head *list; + int it; size_t j; assert(pic->heap->weaks == NULL); /* checkpoint */ if (pic->cp) { - gc_mark_object(pic, (struct pic_object *)pic->cp); + gc_mark_object(pic, (struct object *)pic->cp); } /* stack */ @@ -444,46 +433,33 @@ gc_mark_phase(pic_state *pic) /* callinfo */ for (ci = pic->ci; ci != pic->cibase; --ci) { if (ci->cxt) { - gc_mark_object(pic, (struct pic_object *)ci->cxt); + gc_mark_object(pic, (struct object *)ci->cxt); } } /* exception handlers */ for (xhandler = pic->xpbase; xhandler != pic->xp; ++xhandler) { - gc_mark_object(pic, (struct pic_object *)*xhandler); + gc_mark_object(pic, (struct object *)*xhandler); } /* arena */ for (j = 0; j < pic->arena_idx; ++j) { - gc_mark_object(pic, (struct pic_object *)pic->arena[j]); + gc_mark_object(pic, (struct object *)pic->arena[j]); } /* ireps */ for (list = pic->ireps.next; list != &pic->ireps; list = list->next) { - struct pic_irep *irep = (struct pic_irep *)list; + struct irep *irep = (struct irep *)list; for (j = 0; j < irep->npool; ++j) { gc_mark_object(pic, irep->pool[j]); } } - /* mark reserved symbols */ - M(sDEFINE); M(sDEFINE_MACRO); M(sLAMBDA); M(sIF); M(sBEGIN); M(sSETBANG); - M(sQUOTE); M(sQUASIQUOTE); M(sUNQUOTE); M(sUNQUOTE_SPLICING); - M(sSYNTAX_QUOTE); M(sSYNTAX_QUASIQUOTE); M(sSYNTAX_UNQUOTE); M(sSYNTAX_UNQUOTE_SPLICING); - M(sDEFINE_LIBRARY); M(sIMPORT); M(sEXPORT); M(sCOND_EXPAND); - - M(sCONS); M(sCAR); M(sCDR); M(sNILP); M(sSYMBOLP); M(sPAIRP); - M(sADD); M(sSUB); M(sMUL); M(sDIV); M(sEQ); M(sLT); M(sLE); M(sGT); M(sGE); M(sNOT); - /* global variables */ - if (pic->globals) { - gc_mark_object(pic, (struct pic_object *)pic->globals); - } + gc_mark(pic, pic->globals); /* macro objects */ - if (pic->macros) { - gc_mark_object(pic, (struct pic_object *)pic->macros); - } + gc_mark(pic, pic->macros); /* error object */ gc_mark(pic, pic->err); @@ -491,19 +467,26 @@ gc_mark_phase(pic_state *pic) /* features */ gc_mark(pic, pic->features); - /* library table */ - gc_mark(pic, pic->libs); - /* parameter table */ gc_mark(pic, pic->ptable); + /* library table */ + for (it = kh_begin(&pic->ltable); it != kh_end(&pic->ltable); ++it) { + if (! kh_exist(&pic->ltable, it)) { + continue; + } + gc_mark_object(pic, (struct object *)kh_val(&pic->ltable, it).name); + gc_mark_object(pic, (struct object *)kh_val(&pic->ltable, it).env); + gc_mark_object(pic, (struct object *)kh_val(&pic->ltable, it).exports); + } + /* weak maps */ do { - struct pic_object *key; + struct object *key; pic_value val; - khiter_t it; + int it; khash_t(weak) *h; - struct pic_weak *weak; + struct weak *weak; j = 0; weak = pic->heap->weaks; @@ -515,8 +498,8 @@ gc_mark_phase(pic_state *pic) continue; key = kh_key(h, it); val = kh_val(h, it); - if (key->u.basic.gc_mark == PIC_GC_MARK) { - if (pic_obj_p(val) && pic_obj_ptr(val)->u.basic.gc_mark == PIC_GC_UNMARK) { + if (key->u.basic.gc_mark == BLACK) { + if (pic_obj_p(pic, val) && pic_obj_ptr(val)->u.basic.gc_mark == WHITE) { gc_mark(pic, val); ++j; } @@ -530,69 +513,60 @@ gc_mark_phase(pic_state *pic) /* SWEEP */ static void -gc_finalize_object(pic_state *pic, struct pic_object *obj) +gc_finalize_object(pic_state *pic, struct object *obj) { switch (obj->u.basic.tt) { - case PIC_TT_VECTOR: { + case PIC_TYPE_VECTOR: { pic_free(pic, obj->u.vec.data); break; } - case PIC_TT_BLOB: { + case PIC_TYPE_BLOB: { pic_free(pic, obj->u.blob.data); break; } - case PIC_TT_STRING: { + case PIC_TYPE_STRING: { pic_rope_decref(pic, obj->u.str.rope); break; } - case PIC_TT_ENV: { + case PIC_TYPE_ENV: { kh_destroy(env, &obj->u.env.map); break; } - case PIC_TT_DATA: { + case PIC_TYPE_DATA: { if (obj->u.data.type->dtor) { obj->u.data.type->dtor(pic, obj->u.data.data); } break; } - case PIC_TT_DICT: { + case PIC_TYPE_DICT: { kh_destroy(dict, &obj->u.dict.hash); break; } - case PIC_TT_SYMBOL: { + case PIC_TYPE_SYMBOL: { /* TODO: remove this symbol's entry from pic->syms immediately */ break; } - case PIC_TT_WEAK: { + case PIC_TYPE_WEAK: { kh_destroy(weak, &obj->u.weak.hash); break; } - case PIC_TT_PROC: { - if (pic_proc_irep_p(&obj->u.proc)) { - pic_irep_decref(pic, obj->u.proc.u.i.irep); - } + case PIC_TYPE_IREP: { + pic_irep_decref(pic, obj->u.proc.u.i.irep); break; } - case PIC_TT_PAIR: - case PIC_TT_CXT: - case PIC_TT_PORT: - case PIC_TT_ERROR: - case PIC_TT_ID: - case PIC_TT_LIB: - case PIC_TT_RECORD: - case PIC_TT_CP: + case PIC_TYPE_PAIR: + case PIC_TYPE_CXT: + case PIC_TYPE_PORT: + case PIC_TYPE_ERROR: + case PIC_TYPE_ID: + case PIC_TYPE_RECORD: + case PIC_TYPE_CP: + case PIC_TYPE_FUNC: break; - case PIC_TT_NIL: - case PIC_TT_BOOL: - case PIC_TT_FLOAT: - case PIC_TT_INT: - case PIC_TT_CHAR: - case PIC_TT_EOF: - case PIC_TT_UNDEF: - case PIC_TT_INVALID: - pic_panic(pic, "logic flaw"); + default: + PIC_UNREACHABLE(); } } @@ -600,7 +574,7 @@ static size_t gc_sweep_page(pic_state *pic, struct heap_page *page) { union header *bp, *p, *head = NULL, *tail = NULL; - struct pic_object *obj; + struct object *obj; size_t alive = 0; for (bp = page->basep; ; bp = bp->s.ptr) { @@ -609,9 +583,9 @@ gc_sweep_page(pic_state *pic, struct heap_page *page) if (p < page->basep || page->endp <= p) { goto escape; } - obj = (struct pic_object *)(p + 1); - if (obj->u.basic.gc_mark == PIC_GC_MARK) { - obj->u.basic.gc_mark = PIC_GC_UNMARK; + obj = (struct object *)(p + 1); + if (obj->u.basic.gc_mark == BLACK) { + obj->u.basic.gc_mark = WHITE; alive += p->s.size; } else { if (head == NULL) { @@ -631,7 +605,7 @@ gc_sweep_page(pic_state *pic, struct heap_page *page) while (head != NULL) { p = head; head = head->s.ptr; - gc_finalize_object(pic, (struct pic_object *)(p + 1)); + gc_finalize_object(pic, (struct object *)(p + 1)); heap_free(pic, p + 1); } @@ -642,11 +616,11 @@ static void gc_sweep_phase(pic_state *pic) { struct heap_page *page; - khiter_t it; + int it; khash_t(weak) *h; - khash_t(s) *s = &pic->oblist; - pic_sym *sym; - struct pic_object *obj; + khash_t(oblist) *s = &pic->oblist; + symbol *sym; + struct object *obj; size_t total = 0, inuse = 0; /* weak maps */ @@ -656,7 +630,7 @@ gc_sweep_phase(pic_state *pic) if (! kh_exist(h, it)) continue; obj = kh_key(h, it); - if (obj->u.basic.gc_mark == PIC_GC_UNMARK) { + if (obj->u.basic.gc_mark == WHITE) { kh_del(weak, h, it); } } @@ -668,8 +642,8 @@ gc_sweep_phase(pic_state *pic) if (! kh_exist(s, it)) continue; sym = kh_val(s, it); - if (sym->gc_mark == PIC_GC_UNMARK) { - kh_del(s, s, it); + if (sym && sym->gc_mark == WHITE) { + kh_del(oblist, s, it); } } @@ -686,7 +660,7 @@ gc_sweep_phase(pic_state *pic) } void -pic_gc_run(pic_state *pic) +pic_gc(pic_state *pic) { if (! pic->gc_enable) { return; @@ -696,38 +670,47 @@ pic_gc_run(pic_state *pic) gc_sweep_phase(pic); } -struct pic_object * -pic_obj_alloc_unsafe(pic_state *pic, size_t size, enum pic_tt tt) +void * +pic_alloca(pic_state *pic, size_t n) { - struct pic_object *obj; + static const pic_data_type t = { "pic_alloca", pic_free, 0 }; + + /* TODO: optimize */ + return pic_data(pic, pic_data_value(pic, pic_malloc(pic, n), &t)); +} + +struct object * +pic_obj_alloc_unsafe(pic_state *pic, size_t size, int type) +{ + struct object *obj; #if GC_STRESS - pic_gc_run(pic); + pic_gc(pic); #endif - obj = (struct pic_object *)heap_alloc(pic, size); + obj = (struct object *)heap_alloc(pic, size); if (obj == NULL) { - pic_gc_run(pic); - obj = (struct pic_object *)heap_alloc(pic, size); + pic_gc(pic); + obj = (struct object *)heap_alloc(pic, size); if (obj == NULL) { heap_morecore(pic); - obj = (struct pic_object *)heap_alloc(pic, size); + obj = (struct object *)heap_alloc(pic, size); if (obj == NULL) pic_panic(pic, "GC memory exhausted"); } } - obj->u.basic.gc_mark = PIC_GC_UNMARK; - obj->u.basic.tt = tt; + obj->u.basic.gc_mark = WHITE; + obj->u.basic.tt = type; return obj; } -struct pic_object * -pic_obj_alloc(pic_state *pic, size_t size, enum pic_tt tt) +struct object * +pic_obj_alloc(pic_state *pic, size_t size, int type) { - struct pic_object *obj; + struct object *obj; - obj = pic_obj_alloc_unsafe(pic, size, tt); + obj = pic_obj_alloc_unsafe(pic, size, type); gc_protect(pic, obj); return obj; diff --git a/extlib/benz/include/picconf.h b/extlib/benz/include/picconf.h new file mode 100644 index 00000000..eb1c3643 --- /dev/null +++ b/extlib/benz/include/picconf.h @@ -0,0 +1,30 @@ +/** + * See Copyright Notice in picrin.h + */ + +/** no dependency on libc? */ +/* #define PIC_USE_LIBC 1 */ + +/** use stdio or not */ +/* #define PIC_USE_STDIO 1 */ + +/** enable some specific features? */ +/* #define PIC_USE_WRITE 1 */ + +/** essential external functions */ +/* #define PIC_JMPBUF jmp_buf */ +/* #define PIC_SETJMP(pic, buf) setjmp(buf) */ +/* #define PIC_LONGJMP(pic, buf, val) longjmp((buf), (val)) */ +/* #define PIC_ABORT(pic) abort() */ + +/** initial memory size (to be dynamically extended if necessary) */ +/* #define PIC_ARENA_SIZE 1000 */ +/* #define PIC_HEAP_PAGE_SIZE 10000 */ +/* #define PIC_PAGE_REQUEST_THRESHOLD(total) ((total) * 77 / 100) */ +/* #define PIC_STACK_SIZE 1024 */ +/* #define PIC_RESCUE_SIZE 30 */ +/* #define PIC_SYM_POOL_SIZE 128 */ +/* #define PIC_IREP_SIZE 8 */ +/* #define PIC_POOL_SIZE 8 */ +/* #define PIC_SYMS_SIZE 32 */ +/* #define PIC_ISEQ_SIZE 1024 */ diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index 88ed0176..b5e63b05 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -1,5 +1,5 @@ /** - * Copyright (c) 2013-2014 Yuichi Nishiwaki and other picrin contributors. + * Copyright (c) 2013-2016 Picrin developers. * * Permission is hereby granted, free of charge, to any person obtaining * a copy of this software and associated documentation files (the @@ -32,221 +32,271 @@ extern "C" { #include #include -#include "picrin/config.h" - -#include "picrin/compat.h" -#include "picrin/khash.h" +#include "picrin/setup.h" typedef struct pic_state pic_state; -#include "picrin/type.h" -#include "picrin/irep.h" -#include "picrin/file.h" -#include "picrin/read.h" -#include "picrin/gc.h" - -KHASH_DECLARE(s, pic_str *, pic_sym *) - -typedef struct pic_checkpoint { - PIC_OBJECT_HEADER - struct pic_proc *in; - struct pic_proc *out; - int depth; - struct pic_checkpoint *prev; -} pic_checkpoint; - +#if PIC_NAN_BOXING +# include +typedef uint64_t pic_value; +#else typedef struct { - int argc, retc; - pic_code *ip; - pic_value *fp; - struct pic_irep *irep; - struct pic_context *cxt; - int regc; - pic_value *regs; - struct pic_context *up; -} pic_callinfo; + unsigned char type; + union { + void *data; + double f; + int i; + char c; + } u; +} pic_value; +#endif -typedef void *(*pic_allocf)(void *, void *, size_t); +typedef void *(*pic_allocf)(void *userdata, void *ptr, size_t n); -struct pic_state { - pic_allocf allocf; - void *userdata; +pic_state *pic_open(pic_allocf f, void *userdata); +void pic_close(pic_state *); - pic_checkpoint *cp; - struct pic_cont *cc; - int ccnt; - - pic_value *sp; - pic_value *stbase, *stend; - - pic_callinfo *ci; - pic_callinfo *cibase, *ciend; - - struct pic_proc **xp; - struct pic_proc **xpbase, **xpend; - - pic_code *ip; - - pic_value ptable; /* list of ephemerons */ - - struct pic_lib *lib, *prev_lib; - - pic_sym *sDEFINE, *sDEFINE_MACRO, *sLAMBDA, *sIF, *sBEGIN, *sSETBANG; - pic_sym *sQUOTE, *sQUASIQUOTE, *sUNQUOTE, *sUNQUOTE_SPLICING; - pic_sym *sSYNTAX_QUOTE, *sSYNTAX_QUASIQUOTE; - pic_sym *sSYNTAX_UNQUOTE, *sSYNTAX_UNQUOTE_SPLICING; - pic_sym *sDEFINE_LIBRARY, *sIMPORT, *sEXPORT, *sCOND_EXPAND; - pic_sym *sCONS, *sCAR, *sCDR, *sNILP, *sSYMBOLP, *sPAIRP; - pic_sym *sADD, *sSUB, *sMUL, *sDIV, *sEQ, *sLT, *sLE, *sGT, *sGE, *sNOT; - - struct pic_lib *PICRIN_BASE; - struct pic_lib *PICRIN_USER; - - pic_value features; - - khash_t(s) oblist; /* string to symbol */ - int ucnt; - struct pic_weak *globals; - struct pic_weak *macros; - pic_value libs; - struct pic_list ireps; /* chain */ - - pic_reader reader; - xFILE files[XOPEN_MAX]; - pic_code iseq[2]; /* for pic_apply_trampoline */ - - bool gc_enable; - struct pic_heap *heap; - struct pic_object **arena; - size_t arena_size, arena_idx; - - pic_value err; - - char *native_stack_start; -}; - -typedef pic_value (*pic_func_t)(pic_state *); +int pic_get_args(pic_state *, const char *fmt, ...); void *pic_malloc(pic_state *, size_t); void *pic_realloc(pic_state *, void *, size_t); void *pic_calloc(pic_state *, size_t, size_t); void pic_free(pic_state *, void *); -struct pic_object *pic_obj_alloc(pic_state *, size_t, enum pic_tt); -void pic_gc_run(pic_state *); -pic_value pic_gc_protect(pic_state *, pic_value); -size_t pic_gc_arena_preserve(pic_state *); -void pic_gc_arena_restore(pic_state *, size_t); -#define pic_void(exec) \ - pic_void_(PIC_GENSYM(ai), exec) -#define pic_void_(ai,exec) do { \ - size_t ai = pic_gc_arena_preserve(pic); \ - exec; \ - pic_gc_arena_restore(pic, ai); \ - } while (0) +typedef pic_value (*pic_func_t)(pic_state *); -void *pic_default_allocf(void *, void *, size_t); -pic_state *pic_open(pic_allocf, void *); -void pic_close(pic_state *); +void *pic_alloca(pic_state *, size_t); +size_t pic_enter(pic_state *); +void pic_leave(pic_state *, size_t); +pic_value pic_protect(pic_state *, pic_value); +void pic_gc(pic_state *); -void pic_add_feature(pic_state *, const char *); +void pic_add_feature(pic_state *, const char *feature); -int pic_get_args(pic_state *, const char *, ...); +void pic_defun(pic_state *, const char *name, pic_func_t f); +void pic_defvar(pic_state *, const char *name, pic_value v, pic_value conv); -bool pic_eq_p(pic_value, pic_value); -bool pic_eqv_p(pic_value, pic_value); +void pic_define(pic_state *, const char *lib, const char *name, pic_value v); +pic_value pic_ref(pic_state *, const char *lib, const char *name); +void pic_set(pic_state *, const char *lib, const char *name, pic_value v); +pic_value pic_closure_ref(pic_state *, int i); +void pic_closure_set(pic_state *, int i, pic_value v); +pic_value pic_funcall(pic_state *, const char *lib, const char *name, int n, ...); +pic_value pic_make_var(pic_state *, pic_value init, pic_value conv); + +pic_value pic_return(pic_state *, int n, ...); +pic_value pic_vreturn(pic_state *, int n, va_list); +pic_value pic_valuesk(pic_state *, int n, pic_value *retv); +int pic_receive(pic_state *, int n, pic_value *retv); + +void pic_make_library(pic_state *, const char *lib); +void pic_in_library(pic_state *, const char *lib); +bool pic_find_library(pic_state *, const char *lib); +const char *pic_current_library(pic_state *); +void pic_import(pic_state *, const char *lib); +void pic_export(pic_state *, pic_value sym); + +typedef void (*pic_panicf)(pic_state *, const char *msg); + +pic_panicf pic_atpanic(pic_state *, pic_panicf f); +PIC_NORETURN void pic_panic(pic_state *, const char *msg); +PIC_NORETURN void pic_error(pic_state *, const char *msg, int n, ...); +PIC_NORETURN void pic_raise(pic_state *, pic_value v); +pic_value pic_make_error(pic_state *, const char *type, const char *msg, pic_value irrs); + +pic_value pic_lambda(pic_state *, pic_func_t f, int n, ...); +pic_value pic_vlambda(pic_state *, pic_func_t f, int n, va_list); +pic_value pic_call(pic_state *, pic_value proc, int, ...); +pic_value pic_vcall(pic_state *, pic_value proc, int, va_list); +pic_value pic_apply(pic_state *, pic_value proc, int n, pic_value *argv); +pic_value pic_applyk(pic_state *, pic_value proc, int n, pic_value *argv); + +typedef struct xFILE xFILE; + +pic_value pic_open_port(pic_state *, xFILE *file); +xFILE *pic_fileno(pic_state *, pic_value port); +void pic_close_port(pic_state *, pic_value port); + +int pic_int(pic_state *, pic_value i); +double pic_float(pic_state *, pic_value f); +char pic_char(pic_state *, pic_value c); +#define pic_bool(pic,b) (! pic_false_p(pic, b)) +const char *pic_str(pic_state *, pic_value str); +#define pic_sym(pic,s) (pic_str(pic, pic_sym_name(pic, (s)))) +unsigned char *pic_blob(pic_state *, pic_value blob, int *len); +void *pic_data(pic_state *, pic_value data); + +typedef struct { + const char *type_name; + void (*dtor)(pic_state *, void *); + void (*mark)(pic_state *, void *, void (*)(pic_state *, pic_value)); +} pic_data_type; + +pic_value pic_invalid_value(pic_state *); +pic_value pic_undef_value(pic_state *); +pic_value pic_int_value(pic_state *, int); +pic_value pic_float_value(pic_state *, double); +pic_value pic_char_value(pic_state *, char); +pic_value pic_true_value(pic_state *); +pic_value pic_false_value(pic_state *); +#define pic_bool_value(pic, b) ((b) ? pic_true_value(pic) : pic_false_value(pic)) +pic_value pic_eof_object(pic_state *); +pic_value pic_str_value(pic_state *, const char *str, int len); +#define pic_cstr_value(pic, cstr) pic_str_value(pic, (cstr), strlen(cstr)) +#define pic_lit_value(pic, lit) pic_str_value(pic, "" lit, -((int)sizeof lit - 1)) +pic_value pic_strf_value(pic_state *, const char *fmt, ...); +pic_value pic_vstrf_value(pic_state *, const char *fmt, va_list ap); +pic_value pic_blob_value(pic_state *, const unsigned char *buf, int len); +pic_value pic_data_value(pic_state *, void *ptr, const pic_data_type *type); + +enum { + PIC_TYPE_INVALID = 1, + PIC_TYPE_FLOAT = 2, + PIC_TYPE_INT = 3, + PIC_TYPE_CHAR = 4, + PIC_TYPE_EOF = 5, + PIC_TYPE_UNDEF = 6, + PIC_TYPE_TRUE = 8, + PIC_TYPE_NIL = 7, + PIC_TYPE_FALSE = 9, + PIC_IVAL_END = 10, +/* -------------------- */ + PIC_TYPE_STRING = 16, + PIC_TYPE_VECTOR = 17, + PIC_TYPE_BLOB = 18, + PIC_TYPE_PORT = 20, + PIC_TYPE_ERROR = 21, + PIC_TYPE_ID = 22, + PIC_TYPE_ENV = 23, + PIC_TYPE_DATA = 24, + PIC_TYPE_DICT = 25, + PIC_TYPE_WEAK = 26, + PIC_TYPE_RECORD = 27, + PIC_TYPE_SYMBOL = 28, + PIC_TYPE_PAIR = 29, + PIC_TYPE_CXT = 30, + PIC_TYPE_CP = 31, + PIC_TYPE_FUNC = 32, + PIC_TYPE_IREP = 33 +}; + +#define pic_invalid_p(pic,v) (pic_type(pic,v) == PIC_TYPE_INVALID) +#define pic_undef_p(pic,v) (pic_type(pic,v) == PIC_TYPE_UNDEF) +#define pic_int_p(pic,v) (pic_type(pic,v) == PIC_TYPE_INT) +#define pic_float_p(pic,v) (pic_type(pic,v) == PIC_TYPE_FLOAT) +#define pic_char_p(pic,v) (pic_type(pic,v) == PIC_TYPE_CHAR) +#define pic_eof_p(pic, v) (pic_type(pic, v) == PIC_TYPE_EOF) +#define pic_true_p(pic,v) (pic_type(pic,v) == PIC_TYPE_TRUE) +#define pic_false_p(pic,v) (pic_type(pic,v) == PIC_TYPE_FALSE) +#define pic_id_p(pic, v) (pic_type(pic, v) == PIC_TYPE_ID || pic_type(pic, v) == PIC_TYPE_SYMBOL) +#define pic_str_p(pic,v) (pic_type(pic,v) == PIC_TYPE_STRING) +#define pic_blob_p(pic,v) (pic_type(pic,v) == PIC_TYPE_BLOB) +#define pic_proc_p(pic,v) (pic_type(pic,v) == PIC_TYPE_FUNC || pic_type(pic, v) == PIC_TYPE_IREP) +#define pic_nil_p(pic,v) (pic_type(pic,v) == PIC_TYPE_NIL) +#define pic_pair_p(pic,v) (pic_type(pic,v) == PIC_TYPE_PAIR) +#define pic_vec_p(pic,v) (pic_type(pic,v) == PIC_TYPE_VECTOR) +#define pic_dict_p(pic,v) (pic_type(pic,v) == PIC_TYPE_DICT) +#define pic_weak_p(pic,v) (pic_type(pic,v) == PIC_TYPE_WEAK) +#define pic_port_p(pic, v) (pic_type(pic, v) == PIC_TYPE_PORT) +#define pic_sym_p(pic,v) (pic_type(pic,v) == PIC_TYPE_SYMBOL) +bool pic_data_p(pic_state *, pic_value, const pic_data_type *); + +int pic_type(pic_state *, pic_value); +const char *pic_typename(pic_state *, int); + +bool pic_eq_p(pic_state *, pic_value, pic_value); +bool pic_eqv_p(pic_state *, pic_value, pic_value); bool pic_equal_p(pic_state *, pic_value, pic_value); -pic_value pic_read(pic_state *, struct pic_port *); -pic_value pic_read_cstr(pic_state *, const char *); +/* pair */ +pic_value pic_cons(pic_state *, pic_value car, pic_value cdr); +pic_value pic_car(pic_state *, pic_value pair); +pic_value pic_cdr(pic_state *, pic_value pair); +void pic_set_car(pic_state *, pic_value pair, pic_value car); +void pic_set_cdr(pic_state *, pic_value pair, pic_value cdr); +pic_value pic_caar(pic_state *, pic_value); +pic_value pic_cadr(pic_state *, pic_value); +pic_value pic_cdar(pic_state *, pic_value); +pic_value pic_cddr(pic_state *, pic_value); -void pic_load(pic_state *, struct pic_port *); -void pic_load_cstr(pic_state *, const char *); +/* list */ +pic_value pic_nil_value(pic_state *); +bool pic_list_p(pic_state *, pic_value); +pic_value pic_make_list(pic_state *, int n, pic_value *argv); +pic_value pic_list(pic_state *, int n, ...); +pic_value pic_vlist(pic_state *, int n, va_list); +pic_value pic_list_ref(pic_state *, pic_value list, int i); +void pic_list_set(pic_state *, pic_value list, int i, pic_value v); +pic_value pic_list_tail(pic_state *, pic_value list, int i); +int pic_length(pic_state *, pic_value list); +pic_value pic_reverse(pic_state *, pic_value list); +pic_value pic_append(pic_state *, pic_value xs, pic_value ys); -void pic_define(pic_state *, const char *, pic_value); -void pic_defun(pic_state *, const char *, pic_func_t); -void pic_defvar(pic_state *, const char *, pic_value, struct pic_proc *); -/* functions suffixed with '_' do not involve automatic export */ -void pic_define_(pic_state *, const char *, pic_value); -void pic_defun_(pic_state *, const char *, pic_func_t); -void pic_defvar_(pic_state *, const char *, pic_value, struct pic_proc *); +/* vector */ +pic_value pic_make_vec(pic_state *, int n, pic_value *argv); +pic_value pic_vec_ref(pic_state *, pic_value vec, int i); +void pic_vec_set(pic_state *, pic_value vec, int i, pic_value v); +int pic_vec_len(pic_state *, pic_value vec); -pic_value pic_ref(pic_state *, struct pic_lib *, const char *); -void pic_set(pic_state *, struct pic_lib *, const char *, pic_value); -pic_value pic_funcall(pic_state *pic, struct pic_lib *, const char *, pic_value); -pic_value pic_funcall0(pic_state *pic, struct pic_lib *, const char *); -pic_value pic_funcall1(pic_state *pic, struct pic_lib *, const char *, pic_value); -pic_value pic_funcall2(pic_state *pic, struct pic_lib *, const char *, pic_value, pic_value); -pic_value pic_funcall3(pic_state *pic, struct pic_lib *, const char *, pic_value, pic_value, pic_value); +/* dictionary */ +pic_value pic_make_dict(pic_state *); +pic_value pic_dict_ref(pic_state *, pic_value dict, pic_value key); +void pic_dict_set(pic_state *, pic_value dict, pic_value key, pic_value); +void pic_dict_del(pic_state *, pic_value dict, pic_value key); +bool pic_dict_has(pic_state *, pic_value dict, pic_value key); +int pic_dict_size(pic_state *, pic_value dict); +bool pic_dict_next(pic_state *, pic_value dict, int *iter, pic_value *key, pic_value *val); -pic_value pic_apply(pic_state *, struct pic_proc *, int, pic_value *); -pic_value pic_apply0(pic_state *, struct pic_proc *); -pic_value pic_apply1(pic_state *, struct pic_proc *, pic_value); -pic_value pic_apply2(pic_state *, struct pic_proc *, pic_value, pic_value); -pic_value pic_apply3(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value); -pic_value pic_apply4(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value, pic_value); -pic_value pic_apply5(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value, pic_value, pic_value); -pic_value pic_apply_list(pic_state *, struct pic_proc *, pic_value); -pic_value pic_apply_trampoline(pic_state *, struct pic_proc *, int, pic_value *); -pic_value pic_apply_trampoline_list(pic_state *, struct pic_proc *, pic_value); -pic_value pic_eval(pic_state *, pic_value, struct pic_lib *); +/* ephemeron */ +pic_value pic_make_weak(pic_state *); +pic_value pic_weak_ref(pic_state *, pic_value weak, pic_value key); +void pic_weak_set(pic_state *, pic_value weak, pic_value key, pic_value val); +void pic_weak_del(pic_state *, pic_value weak, pic_value key); +bool pic_weak_has(pic_state *, pic_value weak, pic_value key); -struct pic_proc *pic_make_var(pic_state *, pic_value, struct pic_proc *); +/* symbol */ +pic_value pic_intern(pic_state *, pic_value str); +#define pic_intern_str(pic,s,i) pic_intern(pic, pic_str_value(pic, (s), (i))) +#define pic_intern_cstr(pic,s) pic_intern(pic, pic_cstr_value(pic, (s))) +#define pic_intern_lit(pic,lit) pic_intern(pic, pic_lit_value(pic, lit)) +pic_value pic_sym_name(pic_state *, pic_value sym); -struct pic_lib *pic_make_library(pic_state *, pic_value); -struct pic_lib *pic_find_library(pic_state *, pic_value); +/* string */ +int pic_str_len(pic_state *, pic_value str); +char pic_str_ref(pic_state *, pic_value str, int i); +pic_value pic_str_cat(pic_state *, pic_value str1, pic_value str2); +pic_value pic_str_sub(pic_state *, pic_value str, int i, int j); +int pic_str_cmp(pic_state *, pic_value str1, pic_value str2); +int pic_str_hash(pic_state *, pic_value str); -#define pic_deflibrary(pic, spec) \ - for (((assert(pic->prev_lib == NULL)), \ - (pic->prev_lib = pic->lib), \ - (pic->lib = pic_find_library(pic, pic_read_cstr(pic, (spec)))), \ - (pic->lib = pic->lib \ - ? pic->lib \ - : pic_make_library(pic, pic_read_cstr(pic, (spec))))); \ - pic->prev_lib != NULL; \ - ((pic->lib = pic->prev_lib), \ - (pic->prev_lib = NULL))) -void pic_import(pic_state *, struct pic_lib *); -void pic_export(pic_state *, pic_sym *); -PIC_NORETURN void pic_panic(pic_state *, const char *); -PIC_NORETURN void pic_errorf(pic_state *, const char *, ...); -void pic_warnf(pic_state *, const char *, ...); -pic_str *pic_get_backtrace(pic_state *); -void pic_print_backtrace(pic_state *, xFILE *); +/* External I/O */ -struct pic_port *pic_stdin(pic_state *); -struct pic_port *pic_stdout(pic_state *); -struct pic_port *pic_stderr(pic_state *); +#define XSEEK_CUR 0 +#define XSEEK_END 1 +#define XSEEK_SET 2 -pic_value pic_write(pic_state *, pic_value); /* returns given obj */ -pic_value pic_fwrite(pic_state *, pic_value, xFILE *); -void pic_printf(pic_state *, const char *, ...); -void pic_fprintf(pic_state *, struct pic_port *, const char *, ...); -pic_value pic_display(pic_state *, pic_value); -pic_value pic_fdisplay(pic_state *, pic_value, xFILE *); +xFILE *xfunopen(pic_state *, void *cookie, int (*read)(pic_state *, void *, char *, int), int (*write)(pic_state *, void *, const char *, int), long (*seek)(pic_state *, void *, long, int), int (*close)(pic_state *, void *)); +size_t xfread(pic_state *, void *ptr, size_t size, size_t count, xFILE *fp); +size_t xfwrite(pic_state *, const void *ptr, size_t size, size_t count, xFILE *fp); +long xfseek(pic_state *, xFILE *fp, long offset, int whence); +int xfclose(pic_state *, xFILE *fp); -#if DEBUG -# define pic_debug(pic,obj) pic_fwrite(pic,obj,xstderr) -# define pic_fdebug(pic,obj,file) pic_fwrite(pic,obj,file) -#endif +void xclearerr(pic_state *, xFILE *fp); +int xfeof(pic_state *, xFILE *fp); +int xferror(pic_state *, xFILE *fp); + +int xfputc(pic_state *, int c, xFILE *fp); +int xfgetc(pic_state *, xFILE *fp); +int xfputs(pic_state *, const char *s, xFILE *fp); +char *xfgets(pic_state *, char *s, int size, xFILE *fp); +int xungetc(pic_state *, int c, xFILE *fp); +int xfflush(pic_state *, xFILE *fp); + +int xfprintf(pic_state *, xFILE *fp, const char *fmt, ...); +int xvfprintf(pic_state *, xFILE *fp, const char *fmt, va_list); -#include "picrin/blob.h" -#include "picrin/cont.h" -#include "picrin/data.h" -#include "picrin/dict.h" -#include "picrin/error.h" -#include "picrin/lib.h" -#include "picrin/macro.h" -#include "picrin/pair.h" -#include "picrin/port.h" -#include "picrin/proc.h" -#include "picrin/record.h" -#include "picrin/string.h" -#include "picrin/symbol.h" -#include "picrin/vector.h" -#include "picrin/weak.h" #if defined(__cplusplus) } diff --git a/extlib/benz/include/picrin/blob.h b/extlib/benz/include/picrin/blob.h deleted file mode 100644 index 6e6b5532..00000000 --- a/extlib/benz/include/picrin/blob.h +++ /dev/null @@ -1,27 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_BLOB_H -#define PICRIN_BLOB_H - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_blob { - PIC_OBJECT_HEADER - unsigned char *data; - int len; -}; - -#define pic_blob_p(v) (pic_type(v) == PIC_TT_BLOB) -#define pic_blob_ptr(v) ((struct pic_blob *)pic_ptr(v)) - -struct pic_blob *pic_make_blob(pic_state *, int); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/config.h b/extlib/benz/include/picrin/config.h deleted file mode 100644 index e90684d0..00000000 --- a/extlib/benz/include/picrin/config.h +++ /dev/null @@ -1,153 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -/** switch normal VM and direct threaded VM */ -/* #define PIC_DIRECT_THREADED_VM 1 */ - -/** switch internal value representation */ -/* #define PIC_NAN_BOXING 1 */ - -/** enable word boxing */ -/* #define PIC_WORD_BOXING 0 */ - -/** no dependency on libc */ -/* #define PIC_ENABLE_LIBC 1 */ - -/** use stdio or not */ -/* #define PIC_ENABLE_STDIO 1 */ - -/** custom setjmp/longjmp */ -/* #define PIC_JMPBUF jmp_buf */ -/* #define PIC_SETJMP(pic, buf) setjmp(buf) */ -/* #define PIC_LONGJMP(pic, buf, val) longjmp((buf), (val)) */ - -/** custom abort */ -/* #define PIC_ABORT(pic) abort() */ - -/** initial memory size (to be dynamically extended if necessary) */ -/* #define PIC_ARENA_SIZE 1000 */ - -/* #define PIC_HEAP_PAGE_SIZE 10000 */ - -/* #define PIC_PAGE_REQUEST_THRESHOLD(total) ((total) * 77 / 100) */ - -/* #define PIC_STACK_SIZE 1024 */ - -/* #define PIC_RESCUE_SIZE 30 */ - -/* #define PIC_SYM_POOL_SIZE 128 */ - -/* #define PIC_IREP_SIZE 8 */ - -/* #define PIC_POOL_SIZE 8 */ - -/* #define PIC_SYMS_SIZE 32 */ - -/* #define PIC_ISEQ_SIZE 1024 */ - -/** enable all debug flags */ -/* #define DEBUG 1 */ - -/** auxiliary debug flags */ -/* #define GC_STRESS 1 */ -/* #define VM_DEBUG 1 */ -/* #define GC_DEBUG 1 */ -/* #define GC_DEBUG_DETAIL 1 */ - -#ifndef PIC_DIRECT_THREADED_VM -# if (defined(__GNUC__) || defined(__clang__)) && __STRICT_ANSI__ != 1 -# define PIC_DIRECT_THREADED_VM 1 -# endif -#endif - -#if PIC_NAN_BOXING && PIC_WORD_BOXING -# error cannot enable both PIC_NAN_BOXING and PIC_WORD_BOXING simultaneously -#endif - -#ifndef PIC_WORD_BOXING -# define PIC_WORD_BOXING 0 -#endif - -#if ! PIC_WORD_BOXING -# ifndef PIC_NAN_BOXING -# if __x86_64__ && (defined(__GNUC__) || defined(__clang__)) && __STRICT_ANSI__ != 1 -# define PIC_NAN_BOXING 1 -# endif -# endif -#endif - -#ifndef PIC_ENABLE_LIBC -# define PIC_ENABLE_LIBC 1 -#endif - -#ifndef PIC_ENABLE_STDIO -# define PIC_ENABLE_STDIO 1 -#endif - -#ifndef PIC_JMPBUF -# include -# define PIC_JMPBUF jmp_buf -#endif - -#ifndef PIC_SETJMP -# include -# define PIC_SETJMP(pic, buf) setjmp(buf) -#endif - -#ifndef PIC_LONGJMP -# include -# define PIC_LONGJMP(pic, buf, val) longjmp((buf), (val)) -#endif - -#ifndef PIC_ABORT -# define PIC_ABORT(pic) abort() -#endif - -#ifndef PIC_ARENA_SIZE -# define PIC_ARENA_SIZE (8 * 1024) -#endif - -#ifndef PIC_HEAP_PAGE_SIZE -# define PIC_HEAP_PAGE_SIZE (4 * 1024 * 1024) -#endif - -#ifndef PIC_PAGE_REQUEST_THRESHOLD -# define PIC_PAGE_REQUEST_THRESHOLD(total) ((total) * 77 / 100) -#endif - -#ifndef PIC_STACK_SIZE -# define PIC_STACK_SIZE 2048 -#endif - -#ifndef PIC_RESCUE_SIZE -# define PIC_RESCUE_SIZE 30 -#endif - -#ifndef PIC_SYM_POOL_SIZE -# define PIC_SYM_POOL_SIZE (2 * 1024) -#endif - -#ifndef PIC_IREP_SIZE -# define PIC_IREP_SIZE 8 -#endif - -#ifndef PIC_POOL_SIZE -# define PIC_POOL_SIZE 8 -#endif - -#ifndef PIC_SYMS_SIZE -# define PIC_SYMS_SIZE 32 -#endif - -#ifndef PIC_ISEQ_SIZE -# define PIC_ISEQ_SIZE 1024 -#endif - -#if DEBUG -# include -# define GC_STRESS 0 -# define VM_DEBUG 1 -# define GC_DEBUG 0 -# define GC_DEBUG_DETAIL 0 -#endif diff --git a/extlib/benz/include/picrin/cont.h b/extlib/benz/include/picrin/cont.h deleted file mode 100644 index b224597d..00000000 --- a/extlib/benz/include/picrin/cont.h +++ /dev/null @@ -1,54 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_CONT_H -#define PICRIN_CONT_H - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_cont { - PIC_JMPBUF jmp; - - int id; - - pic_checkpoint *cp; - ptrdiff_t sp_offset; - ptrdiff_t ci_offset; - ptrdiff_t xp_offset; - size_t arena_idx; - pic_value ptable; - pic_code *ip; - - pic_value results; - - struct pic_cont *prev; -}; - -void pic_save_point(pic_state *, struct pic_cont *); -void pic_load_point(pic_state *, struct pic_cont *); - -struct pic_proc *pic_make_cont(pic_state *, struct pic_cont *); - -void pic_wind(pic_state *, pic_checkpoint *, pic_checkpoint *); -pic_value pic_dynamic_wind(pic_state *, struct pic_proc *, struct pic_proc *, struct pic_proc *); - -pic_value pic_values0(pic_state *); -pic_value pic_values1(pic_state *, pic_value); -pic_value pic_values2(pic_state *, pic_value, pic_value); -pic_value pic_values3(pic_state *, pic_value, pic_value, pic_value); -pic_value pic_values4(pic_state *, pic_value, pic_value, pic_value, pic_value); -pic_value pic_values5(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value); -pic_value pic_values(pic_state *, int, pic_value *); -pic_value pic_values_by_list(pic_state *, pic_value); -int pic_receive(pic_state *, int, pic_value *); - -pic_value pic_callcc(pic_state *, struct pic_proc *); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/data.h b/extlib/benz/include/picrin/data.h deleted file mode 100644 index 4b9b27d1..00000000 --- a/extlib/benz/include/picrin/data.h +++ /dev/null @@ -1,37 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_DATA_H -#define PICRIN_DATA_H - -#if defined(__cplusplus) -extern "C" { -#endif - -typedef struct { - const char *type_name; - void (*dtor)(pic_state *, void *); - void (*mark)(pic_state *, void *, void (*)(pic_state *, pic_value)); -} pic_data_type; - -struct pic_data { - PIC_OBJECT_HEADER - const pic_data_type *type; - void *data; -}; - -#define pic_data_p(o) (pic_type(o) == PIC_TT_DATA) -#define pic_data_ptr(o) ((struct pic_data *)pic_ptr(o)) - -PIC_INLINE bool pic_data_type_p(const pic_value obj, const pic_data_type *type) { - return pic_data_p(obj) && pic_data_ptr(obj)->type == type; -} - -struct pic_data *pic_data_alloc(pic_state *, const pic_data_type *, void *); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/dict.h b/extlib/benz/include/picrin/dict.h deleted file mode 100644 index be7c675e..00000000 --- a/extlib/benz/include/picrin/dict.h +++ /dev/null @@ -1,40 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_DICT_H -#define PICRIN_DICT_H - -#if defined(__cplusplus) -extern "C" { -#endif - -KHASH_DECLARE(dict, pic_sym *, pic_value) - -struct pic_dict { - PIC_OBJECT_HEADER - khash_t(dict) hash; -}; - -#define pic_dict_p(v) (pic_type(v) == PIC_TT_DICT) -#define pic_dict_ptr(v) ((struct pic_dict *)pic_ptr(v)) - -struct pic_dict *pic_make_dict(pic_state *); - -#define pic_dict_for_each(sym, dict, it) \ - pic_dict_for_each_help(sym, (&(dict)->hash), it) -#define pic_dict_for_each_help(sym, h, it) \ - for (it = kh_begin(h); it != kh_end(h); ++it) \ - if ((sym = kh_key(h, it)), kh_exist(h, it)) - -pic_value pic_dict_ref(pic_state *, struct pic_dict *, pic_sym *); -void pic_dict_set(pic_state *, struct pic_dict *, pic_sym *, pic_value); -void pic_dict_del(pic_state *, struct pic_dict *, pic_sym *); -int pic_dict_size(pic_state *, struct pic_dict *); -bool pic_dict_has(pic_state *, struct pic_dict *, pic_sym *); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/error.h b/extlib/benz/include/picrin/error.h deleted file mode 100644 index ecf59dda..00000000 --- a/extlib/benz/include/picrin/error.h +++ /dev/null @@ -1,64 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_ERROR_H -#define PICRIN_ERROR_H - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_error { - PIC_OBJECT_HEADER - pic_sym *type; - pic_str *msg; - pic_value irrs; - pic_str *stack; -}; - -#define pic_error_p(v) (pic_type(v) == PIC_TT_ERROR) -#define pic_error_ptr(v) ((struct pic_error *)pic_ptr(v)) - -struct pic_error *pic_make_error(pic_state *, pic_sym *, const char *, pic_value); - -/* do not return from try block! */ - -#define pic_try \ - pic_try_(PIC_GENSYM(cont), PIC_GENSYM(handler)) -#define pic_catch \ - pic_catch_(PIC_GENSYM(label)) -#define pic_try_(cont, handler) \ - do { \ - struct pic_cont cont; \ - pic_save_point(pic, &cont); \ - if (PIC_SETJMP(pic, cont.jmp) == 0) { \ - extern pic_value pic_native_exception_handler(pic_state *); \ - struct pic_proc *handler; \ - handler = pic_make_proc(pic, pic_native_exception_handler); \ - pic_proc_env_set(pic, handler, "cont", pic_obj_value(pic_make_cont(pic, &cont))); \ - do { \ - pic_push_handler(pic, handler); -#define pic_catch_(label) \ - pic_pop_handler(pic); \ - } while (0); \ - pic->cc = pic->cc->prev; \ - } else { \ - goto label; \ - } \ - } while (0); \ - if (0) \ - label: - -void pic_push_handler(pic_state *, struct pic_proc *); -struct pic_proc *pic_pop_handler(pic_state *); - -pic_value pic_raise_continuable(pic_state *, pic_value); -PIC_NORETURN void pic_raise(pic_state *, pic_value); -PIC_NORETURN void pic_error(pic_state *, const char *, pic_value); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/extra.h b/extlib/benz/include/picrin/extra.h new file mode 100644 index 00000000..e574e24c --- /dev/null +++ b/extlib/benz/include/picrin/extra.h @@ -0,0 +1,124 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_EXTRA_H +#define PICRIN_EXTRA_H + +#if defined(__cplusplus) +extern "C" { +#endif + + +#if PIC_USE_LIBC +void *pic_default_allocf(void *, void *, size_t); +#endif + +pic_value pic_read(pic_state *, pic_value port); +pic_value pic_read_cstr(pic_state *, const char *); + +pic_value pic_expand(pic_state *, pic_value program, pic_value env); +pic_value pic_eval(pic_state *, pic_value program, const char *lib); + +void pic_load(pic_state *, pic_value port); +void pic_load_cstr(pic_state *, const char *); + +#if PIC_USE_WRITE +void pic_printf(pic_state *, const char *fmt, ...); +void pic_fprintf(pic_state *, pic_value port, const char *fmt, ...); +void pic_vfprintf(pic_state *, pic_value port, const char *fmt, va_list ap); +#endif + +/* extra xfile methods */ + +xFILE *xfile_xstdin(pic_state *); +xFILE *xfile_xstdout(pic_state *); +xFILE *xfile_xstderr(pic_state *); +#define xstdin (xfile_xstdin(pic)) +#define xstdout (xfile_xstdout(pic)) +#define xstderr (xfile_xstderr(pic)) +#if PIC_USE_STDIO +xFILE *xfopen_file(pic_state *, FILE *, const char *mode); +#endif +xFILE *xfopen_buf(pic_state *, const char *buf, int len, const char *mode); +int xfget_buf(pic_state *, xFILE *file, const char **buf, int *len); +xFILE *xfopen_null(pic_state *, const char *mode); + +/* port manipulation */ + +#define pic_stdin(pic) pic_funcall(pic, "picrin.base", "current-input-port", 0) +#define pic_stdout(pic) pic_funcall(pic, "picrin.base", "current-output-port", 0) +#define pic_stderr(pic) pic_funcall(pic, "picrin.base", "current-error-port", 0) + +/* utility macros */ + +#define pic_for_each(var, list, it) \ + for (it = (list); ! pic_nil_p(pic, it); it = pic_cdr(pic, it)) \ + if ((var = pic_car(pic, it)), true) + +#define pic_push(pic, item, place) (place = pic_cons(pic, item, place)) +#define pic_pop(pic, place) (place = pic_cdr(pic, place)) + +#define pic_assert_type(pic, v, type) do { \ + if (! pic_##type##_p(pic, v)) \ + pic_error(pic, #type " required", 1, v); \ + } while (0) + +#define pic_void(exec) pic_void_(PIC_GENSYM(ai), exec) +#define pic_void_(ai,exec) do { \ + size_t ai = pic_enter(pic); \ + exec; \ + pic_leave(pic, ai); \ + } while (0) + +#define pic_deflibrary(pic, lib) do { \ + if (! pic_find_library(pic, lib)) { \ + pic_make_library(pic, lib); \ + } \ + pic_in_library(pic, lib); \ + } while (0) + +/* for pic_try & pic_catch macros */ +struct pic_cont *pic_alloca_cont(pic_state *); +pic_value pic_make_cont(pic_state *, struct pic_cont *); +void pic_push_native_handler(pic_state *, struct pic_cont *); +pic_value pic_pop_handler(pic_state *); +void pic_save_point(pic_state *, struct pic_cont *, PIC_JMPBUF *); +void pic_exit_point(pic_state *); + +#define pic_try pic_try_(PIC_GENSYM(cont), PIC_GENSYM(jmp)) +#define pic_try_(cont, jmp) \ + do { \ + PIC_JMPBUF jmp; \ + struct pic_cont *cont = pic_alloca_cont(pic); \ + if (PIC_SETJMP(pic, jmp) == 0) { \ + pic_save_point(pic, cont, &jmp); \ + pic_push_native_handler(pic, cont); +#define pic_catch pic_catch_(PIC_GENSYM(label)) +#define pic_catch_(label) \ + pic_pop_handler(pic); \ + pic_exit_point(pic); \ + } else { \ + goto label; \ + } \ + } while (0); \ + if (0) \ + label: + +pic_value pic_err(pic_state *); + +/* for debug */ + +void pic_warnf(pic_state *, const char *, ...); +pic_value pic_get_backtrace(pic_state *); +#if PIC_USE_WRITE +void pic_print_error(pic_state *, xFILE *); +#endif + +pic_value pic_library_environment(pic_state *, const char *); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/file.h b/extlib/benz/include/picrin/file.h deleted file mode 100644 index b07e1a27..00000000 --- a/extlib/benz/include/picrin/file.h +++ /dev/null @@ -1,104 +0,0 @@ -#ifndef PICRIN_FILE_H -#define PICRIN_FILE_H - -#if defined(__cplusplus) -extern "C" { -#endif - -#ifndef EOF -# define EOF (-1) -#endif - -#define XBUFSIZ 1024 -#define XOPEN_MAX 1024 - -typedef struct { - /* buffer */ - char buf[1]; /* fallback buffer */ - long cnt; /* characters left */ - char *ptr; /* next character position */ - char *base; /* location of the buffer */ - /* operators */ - struct { - void *cookie; - int (*read)(pic_state *, void *, char *, int); - int (*write)(pic_state *, void *, const char *, int); - long (*seek)(pic_state *, void *, long, int); - int (*close)(pic_state *, void *); - } vtable; - int flag; /* mode of the file access */ -} xFILE; - -#define xstdin (&pic->files[0]) -#define xstdout (&pic->files[1]) -#define xstderr (&pic->files[2]) - -extern const xFILE x_iob[XOPEN_MAX]; - -enum _flags { - X_READ = 01, - X_WRITE = 02, - X_UNBUF = 04, - X_EOF = 010, - X_ERR = 020, - X_LNBUF = 040 -}; - -#define xclearerr(p) ((p)->flag &= ~(X_EOF | X_ERR)) -#define xfeof(p) (((p)->flag & X_EOF) != 0) -#define xferror(p) (((p)->flag & X_ERR) != 0) -#define xfileno(p) ((p)->fd) - -#define xgetc(pic, p) \ - ((--(p)->cnt >= 0) \ - ? (unsigned char) *(p)->ptr++ \ - : x_fillbuf((pic), p)) -#define xputc(pic, x, p) \ - ((--(p)->cnt >= 0 && !(((p)->flag & X_LNBUF) && (x) == '\n')) \ - ? *(p)->ptr++ = (x) \ - : x_flushbuf((pic), (x), (p))) -#define xgetchar(pic) xgetc((pic), xstdin) -#define xputchar(pic, x) xputc((pic), (x), xstdout) - -/* resource aquisition */ -xFILE *xfunopen(pic_state *, void *cookie, int (*read)(pic_state *, void *, char *, int), int (*write)(pic_state *, void *, const char *, int), long (*seek)(pic_state *, void *, long, int), int (*close)(pic_state *, void *)); -int xfclose(pic_state *, xFILE *); - -/* buffer management */ -int x_fillbuf(pic_state *, xFILE *); -int x_flushbuf(pic_state *, int, xFILE *); -int xfflush(pic_state *, xFILE *); - -/* direct IO */ -size_t xfread(pic_state *, void *, size_t, size_t, xFILE *); -size_t xfwrite(pic_state *, const void *, size_t, size_t, xFILE *); - -enum { - XSEEK_CUR, - XSEEK_END, - XSEEK_SET -}; - -/* indicator positioning */ -long xfseek(pic_state *, xFILE *, long, int); -long xftell(pic_state *, xFILE *); -void xrewind(pic_state *, xFILE *); - -/* character IO */ -int xfputc(pic_state *, int, xFILE *); -int xfgetc(pic_state *, xFILE *); -int xfputs(pic_state *, const char *, xFILE *); -char *xfgets(pic_state *, char *, int, xFILE *); -int xputs(pic_state *, const char *); -int xungetc(int, xFILE *); - -/* formatted I/O */ -int xprintf(pic_state *, const char *, ...); -int xfprintf(pic_state *, xFILE *, const char *, ...); -int xvfprintf(pic_state *, xFILE *, const char *, va_list); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/irep.h b/extlib/benz/include/picrin/irep.h deleted file mode 100644 index fff6c249..00000000 --- a/extlib/benz/include/picrin/irep.h +++ /dev/null @@ -1,42 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_IREP_H -#define PICRIN_IREP_H - -#if defined(__cplusplus) -extern "C" { -#endif - -typedef struct { - int insn; - int a; - int b; -} pic_code; - -struct pic_list { - struct pic_list *prev, *next; -}; - -struct pic_irep { - struct pic_list list; - unsigned refc; - int argc, localc, capturec; - bool varg; - pic_code *code; - struct pic_irep **irep; - int *ints; - double *nums; - struct pic_object **pool; - size_t ncode, nirep, nints, nnums, npool; -}; - -void pic_irep_incref(pic_state *, struct pic_irep *); -void pic_irep_decref(pic_state *, struct pic_irep *); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/lib.h b/extlib/benz/include/picrin/lib.h deleted file mode 100644 index 50cd45fe..00000000 --- a/extlib/benz/include/picrin/lib.h +++ /dev/null @@ -1,26 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_LIB_H -#define PICRIN_LIB_H - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_lib { - PIC_OBJECT_HEADER - pic_value name; - struct pic_env *env; - struct pic_dict *exports; -}; - -#define pic_lib_p(o) (pic_type(o) == PIC_TT_LIB) -#define pic_lib_ptr(o) ((struct pic_lib *)pic_ptr(o)) - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/macro.h b/extlib/benz/include/picrin/macro.h deleted file mode 100644 index 5076f367..00000000 --- a/extlib/benz/include/picrin/macro.h +++ /dev/null @@ -1,38 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_MACRO_H -#define PICRIN_MACRO_H - -#if defined(__cplusplus) -extern "C" { -#endif - -KHASH_DECLARE(env, pic_id *, pic_sym *) - -struct pic_env { - PIC_OBJECT_HEADER - khash_t(env) map; - struct pic_env *up; - pic_str *prefix; -}; - -#define pic_env_p(v) (pic_type(v) == PIC_TT_ENV) -#define pic_env_ptr(v) ((struct pic_env *)pic_ptr(v)) - -struct pic_env *pic_make_topenv(pic_state *, pic_str *); -struct pic_env *pic_make_env(pic_state *, struct pic_env *); - -pic_sym *pic_add_identifier(pic_state *, pic_id *, struct pic_env *); -pic_sym *pic_put_identifier(pic_state *, pic_id *, pic_sym *, struct pic_env *); -pic_sym *pic_find_identifier(pic_state *, pic_id *, struct pic_env *); -pic_sym *pic_lookup_identifier(pic_state *, pic_id *, struct pic_env *); - -pic_value pic_expand(pic_state *, pic_value, struct pic_env *); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/opcode.h b/extlib/benz/include/picrin/opcode.h deleted file mode 100644 index e27a4a12..00000000 --- a/extlib/benz/include/picrin/opcode.h +++ /dev/null @@ -1,215 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_OPCODE_H -#define PICRIN_OPCODE_H - -#if defined(__cplusplus) -extern "C" { -#endif - -enum pic_opcode { - OP_NOP, - OP_POP, - OP_PUSHUNDEF, - OP_PUSHNIL, - OP_PUSHTRUE, - OP_PUSHFALSE, - OP_PUSHINT, - OP_PUSHFLOAT, - OP_PUSHCHAR, - OP_PUSHEOF, - OP_PUSHCONST, - OP_GREF, - OP_GSET, - OP_LREF, - OP_LSET, - OP_CREF, - OP_CSET, - OP_JMP, - OP_JMPIF, - OP_NOT, - OP_CALL, - OP_TAILCALL, - OP_RET, - OP_LAMBDA, - OP_CONS, - OP_CAR, - OP_CDR, - OP_NILP, - OP_SYMBOLP, - OP_PAIRP, - OP_ADD, - OP_SUB, - OP_MUL, - OP_DIV, - OP_EQ, - OP_LT, - OP_LE, - OP_GT, - OP_GE, - OP_STOP -}; - -#define PIC_INIT_CODE_I(code, op, ival) do { \ - code.insn = op; \ - code.a = ival; \ - } while (0) - -#if DEBUG - -PIC_INLINE void -pic_dump_code(pic_code c) -{ - switch (c.insn) { - case OP_NOP: - puts("OP_NOP"); - break; - case OP_POP: - puts("OP_POP"); - break; - case OP_PUSHUNDEF: - puts("OP_PUSHUNDEF"); - break; - case OP_PUSHNIL: - puts("OP_PUSHNIL"); - break; - case OP_PUSHTRUE: - puts("OP_PUSHTRUE"); - break; - case OP_PUSHFALSE: - puts("OP_PUSHFALSE"); - break; - case OP_PUSHINT: - printf("OP_PUSHINT\t%d\n", c.a); - break; - case OP_PUSHFLOAT: - printf("OP_PUSHFLAOT\t%d\n", c.a); - break; - case OP_PUSHCHAR: - printf("OP_PUSHCHAR\t%c\n", c.a); - break; - case OP_PUSHEOF: - puts("OP_PUSHEOF"); - break; - case OP_PUSHCONST: - printf("OP_PUSHCONST\t%d\n", c.a); - break; - case OP_GREF: - printf("OP_GREF\t%i\n", c.a); - break; - case OP_GSET: - printf("OP_GSET\t%i\n", c.a); - break; - case OP_LREF: - printf("OP_LREF\t%d\n", c.a); - break; - case OP_LSET: - printf("OP_LSET\t%d\n", c.a); - break; - case OP_CREF: - printf("OP_CREF\t%d\t%d\n", c.a, c.b); - break; - case OP_CSET: - printf("OP_CSET\t%d\t%d\n", c.a, c.b); - break; - case OP_JMP: - printf("OP_JMP\t%x\n", c.a); - break; - case OP_JMPIF: - printf("OP_JMPIF\t%x\n", c.a); - break; - case OP_NOT: - puts("OP_NOT"); - break; - case OP_CALL: - printf("OP_CALL\t%d\n", c.a); - break; - case OP_TAILCALL: - printf("OP_TAILCALL\t%d\n", c.a); - break; - case OP_RET: - puts("OP_RET"); - break; - case OP_LAMBDA: - printf("OP_LAMBDA\t%d\n", c.a); - break; - case OP_CONS: - puts("OP_CONS"); - break; - case OP_CAR: - puts("OP_CAR"); - break; - case OP_NILP: - puts("OP_NILP"); - break; - case OP_SYMBOLP: - puts("OP_SYMBOLP"); - break; - case OP_PAIRP: - puts("OP_PAIRP"); - break; - case OP_CDR: - puts("OP_CDR"); - break; - case OP_ADD: - puts("OP_ADD"); - break; - case OP_SUB: - puts("OP_SUB"); - break; - case OP_MUL: - puts("OP_MUL"); - break; - case OP_DIV: - puts("OP_DIV"); - break; - case OP_EQ: - puts("OP_EQ"); - break; - case OP_LT: - puts("OP_LT"); - break; - case OP_LE: - puts("OP_LE"); - break; - case OP_GT: - puts("OP_GT"); - break; - case OP_GE: - puts("OP_GE"); - break; - case OP_STOP: - puts("OP_STOP"); - break; - } -} - -PIC_INLINE void -pic_dump_irep(struct pic_irep *irep) -{ - size_t i; - - printf("## irep %p\n", (void *)irep); - printf("# argc = %d\n", irep->argc); - printf("# localc = %d\n", irep->localc); - printf("# capturec = %d\n", irep->capturec); - - for (i = 0; i < irep->ncode; ++i) { - printf("%02x: ", i); - pic_dump_code(irep->u.s.code[i]); - } - - for (i = 0; i < irep->nirep; ++i) { - pic_dump_irep(irep->u.s.irep[i].i); - } -} - -#endif - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/pair.h b/extlib/benz/include/picrin/pair.h deleted file mode 100644 index d8f7a675..00000000 --- a/extlib/benz/include/picrin/pair.h +++ /dev/null @@ -1,97 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_PAIR_H -#define PICRIN_PAIR_H - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_pair { - PIC_OBJECT_HEADER - pic_value car; - pic_value cdr; -}; - -#define pic_pair_p(v) (pic_type(v) == PIC_TT_PAIR) -#define pic_pair_ptr(o) ((struct pic_pair *)pic_ptr(o)) - -PIC_INLINE pic_value -pic_car(pic_state *pic, pic_value obj) -{ - struct pic_pair *pair; - - if (! pic_pair_p(obj)) { - pic_errorf(pic, "car: pair required, but got ~s", obj); - } - pair = pic_pair_ptr(obj); - - return pair->car; -} - -PIC_INLINE pic_value -pic_cdr(pic_state *pic, pic_value obj) -{ - struct pic_pair *pair; - - if (! pic_pair_p(obj)) { - pic_errorf(pic, "cdr: pair required, but got ~s", obj); - } - pair = pic_pair_ptr(obj); - - return pair->cdr; -} - -pic_value pic_cons(pic_state *, pic_value, pic_value); -void pic_set_car(pic_state *, pic_value, pic_value); -void pic_set_cdr(pic_state *, pic_value, pic_value); - -bool pic_list_p(pic_value); -pic_value pic_list1(pic_state *, pic_value); -pic_value pic_list2(pic_state *, pic_value, pic_value); -pic_value pic_list3(pic_state *, pic_value, pic_value, pic_value); -pic_value pic_list4(pic_state *, pic_value, pic_value, pic_value, pic_value); -pic_value pic_list5(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value); -pic_value pic_list6(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value); -pic_value pic_list7(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value); -pic_value pic_list_by_array(pic_state *, int, pic_value *); -pic_value pic_make_list(pic_state *, int, pic_value); - -#define pic_for_each(var, list, it) \ - for (it = (list); ! pic_nil_p(it); it = pic_cdr(pic, it)) \ - if ((var = pic_car(pic, it)), true) - -#define pic_push(pic, item, place) (place = pic_cons(pic, item, place)) -#define pic_pop(pic, place) (place = pic_cdr(pic, place)) - -int pic_length(pic_state *, pic_value); -pic_value pic_reverse(pic_state *, pic_value); -pic_value pic_append(pic_state *, pic_value, pic_value); - -pic_value pic_memq(pic_state *, pic_value key, pic_value list); -pic_value pic_memv(pic_state *, pic_value key, pic_value list); -pic_value pic_member(pic_state *, pic_value key, pic_value list, struct pic_proc * /* = NULL */); - -pic_value pic_assq(pic_state *, pic_value key, pic_value assoc); -pic_value pic_assv(pic_state *, pic_value key, pic_value assoc); -pic_value pic_assoc(pic_state *, pic_value key, pic_value assoc, struct pic_proc * /* = NULL */); - -pic_value pic_acons(pic_state *, pic_value key, pic_value val, pic_value assoc); - -pic_value pic_caar(pic_state *, pic_value); -pic_value pic_cadr(pic_state *, pic_value); -pic_value pic_cdar(pic_state *, pic_value); -pic_value pic_cddr(pic_state *, pic_value); - -pic_value pic_list_tail(pic_state *, pic_value, int); -pic_value pic_list_ref(pic_state *, pic_value, int); -void pic_list_set(pic_state *, pic_value, int, pic_value); -pic_value pic_list_copy(pic_state *, pic_value); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/port.h b/extlib/benz/include/picrin/port.h deleted file mode 100644 index c806ba8e..00000000 --- a/extlib/benz/include/picrin/port.h +++ /dev/null @@ -1,42 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_PORT_H -#define PICRIN_PORT_H - -#if defined(__cplusplus) -extern "C" { -#endif - -enum pic_port_flag { - PIC_PORT_IN = 1, - PIC_PORT_OUT = 2, - PIC_PORT_TEXT = 4, - PIC_PORT_BINARY = 8, - PIC_PORT_OPEN = 16 -}; - -struct pic_port { - PIC_OBJECT_HEADER - xFILE *file; - int flags; -}; - -#define pic_port_p(v) (pic_type(v) == PIC_TT_PORT) -#define pic_port_ptr(v) ((struct pic_port *)pic_ptr(v)) - -pic_value pic_eof_object(); - -struct pic_port *pic_open_input_string(pic_state *, const char *); -struct pic_port *pic_open_output_string(pic_state *); -struct pic_string *pic_get_output_string(pic_state *, struct pic_port *); - -struct pic_port *pic_open_file(pic_state *, const char *, int); -void pic_close_port(pic_state *pic, struct pic_port *); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/private/file.h b/extlib/benz/include/picrin/private/file.h new file mode 100644 index 00000000..7595d4fb --- /dev/null +++ b/extlib/benz/include/picrin/private/file.h @@ -0,0 +1,42 @@ +#ifndef PICRIN_FILE_H +#define PICRIN_FILE_H + +#if defined(__cplusplus) +extern "C" { +#endif + +#define XBUFSIZ 1024 +#define XOPEN_MAX 1024 + +struct xFILE { + /* buffer */ + char buf[1]; /* fallback buffer */ + long cnt; /* characters left */ + char *ptr; /* next character position */ + char *base; /* location of the buffer */ + /* operators */ + struct { + void *cookie; + int (*read)(pic_state *, void *, char *, int); + int (*write)(pic_state *, void *, const char *, int); + long (*seek)(pic_state *, void *, long, int); + int (*close)(pic_state *, void *); + } vtable; + int flag; /* mode of the file access */ +}; + +enum { + X_READ = 01, + X_WRITE = 02, + X_UNBUF = 04, + X_EOF = 010, + X_ERR = 020, + X_LNBUF = 040 +}; + + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/gc.h b/extlib/benz/include/picrin/private/gc.h similarity index 51% rename from extlib/benz/include/picrin/gc.h rename to extlib/benz/include/picrin/private/gc.h index c7ed0426..183cc6f8 100644 --- a/extlib/benz/include/picrin/gc.h +++ b/extlib/benz/include/picrin/private/gc.h @@ -9,13 +9,8 @@ extern "C" { #endif -#define PIC_GC_UNMARK 0 -#define PIC_GC_MARK 1 - -struct pic_heap; - -struct pic_heap *pic_heap_open(pic_state *); -void pic_heap_close(pic_state *, struct pic_heap *); +struct heap *pic_heap_open(pic_state *); +void pic_heap_close(pic_state *, struct heap *); #if defined(__cplusplus) } diff --git a/extlib/benz/include/picrin/khash.h b/extlib/benz/include/picrin/private/khash.h similarity index 91% rename from extlib/benz/include/picrin/khash.h rename to extlib/benz/include/picrin/private/khash.h index 157926ee..83c62860 100644 --- a/extlib/benz/include/picrin/khash.h +++ b/extlib/benz/include/picrin/private/khash.h @@ -24,13 +24,8 @@ SOFTWARE. */ -#ifndef AC_KHASH_H -#define AC_KHASH_H - -#include - -typedef int khint_t; -typedef khint_t khiter_t; +#ifndef PICRIN_KHASH_H +#define PICRIN_KHASH_H #define ac_isempty(flag, i) ((flag[i>>4]>>((i&0xfU)<<1))&2) #define ac_isdel(flag, i) ((flag[i>>4]>>((i&0xfU)<<1))&1) @@ -48,18 +43,18 @@ typedef khint_t khiter_t; #define KHASH_DECLARE(name, khkey_t, khval_t) \ typedef struct { \ - khint_t n_buckets, size, n_occupied, upper_bound; \ + int n_buckets, size, n_occupied, upper_bound; \ int *flags; \ khkey_t *keys; \ khval_t *vals; \ } kh_##name##_t; \ void kh_init_##name(kh_##name##_t *h); \ - void kh_destroy_##name(pic_state *, kh_##name##_t *h); \ + void kh_destroy_##name(pic_state *, kh_##name##_t *h); \ void kh_clear_##name(kh_##name##_t *h); \ - khint_t kh_get_##name(pic_state *, const kh_##name##_t *h, khkey_t key); \ - void kh_resize_##name(pic_state *, kh_##name##_t *h, khint_t new_n_buckets); \ - khint_t kh_put_##name(pic_state *, kh_##name##_t *h, khkey_t key, int *ret); \ - void kh_del_##name(kh_##name##_t *h, khint_t x); + int kh_get_##name(pic_state *, const kh_##name##_t *h, khkey_t key); \ + void kh_resize_##name(pic_state *, kh_##name##_t *h, int new_n_buckets); \ + int kh_put_##name(pic_state *, kh_##name##_t *h, khkey_t key, int *ret); \ + void kh_del_##name(kh_##name##_t *h, int x); #define KHASH_DEFINE(name, khkey_t, khval_t, hash_func, hash_equal) \ KHASH_DEFINE2(name, khkey_t, khval_t, 1, hash_func, hash_equal) @@ -80,11 +75,11 @@ typedef khint_t khiter_t; h->size = h->n_occupied = 0; \ } \ } \ - khint_t kh_get_##name(pic_state *pic, const kh_##name##_t *h, khkey_t key) \ + int kh_get_##name(pic_state *pic, const kh_##name##_t *h, khkey_t key) \ { \ (void)pic; \ if (h->n_buckets) { \ - khint_t k, i, last, mask, step = 0; \ + int k, i, last, mask, step = 0; \ mask = h->n_buckets - 1; \ k = hash_func(key); i = k & mask; \ last = i; \ @@ -95,10 +90,10 @@ typedef khint_t khiter_t; return ac_iseither(h->flags, i)? h->n_buckets : i; \ } else return 0; \ } \ - void kh_resize_##name(pic_state *pic, kh_##name##_t *h, khint_t new_n_buckets) \ + void kh_resize_##name(pic_state *pic, kh_##name##_t *h, int new_n_buckets) \ { /* This function uses 0.25*n_buckets bytes of working space instead of [sizeof(key_t+val_t)+.25]*n_buckets. */ \ int *new_flags = 0; \ - khint_t j = 1; \ + int j = 1; \ { \ ac_roundup32(new_n_buckets); \ if (new_n_buckets < 4) new_n_buckets = 4; \ @@ -119,12 +114,12 @@ typedef khint_t khiter_t; if (ac_iseither(h->flags, j) == 0) { \ khkey_t key = h->keys[j]; \ khval_t val; \ - khint_t new_mask; \ + int new_mask; \ new_mask = new_n_buckets - 1; \ if (kh_is_map) val = h->vals[j]; \ ac_set_isdel_true(h->flags, j); \ while (1) { /* kick-out process; sort of like in Cuckoo hashing */ \ - khint_t k, i, step = 0; \ + int k, i, step = 0; \ k = hash_func(key); \ i = k & new_mask; \ while (!ac_isempty(new_flags, i)) i = (i + (++step)) & new_mask; \ @@ -152,9 +147,9 @@ typedef khint_t khiter_t; h->upper_bound = ac_hash_upper(h->n_buckets); \ } \ } \ - khint_t kh_put_##name(pic_state *pic, kh_##name##_t *h, khkey_t key, int *ret) \ + int kh_put_##name(pic_state *pic, kh_##name##_t *h, khkey_t key, int *ret) \ { \ - khint_t x; \ + int x; \ if (h->n_occupied >= h->upper_bound) { /* update the hash table */ \ if (h->n_buckets > (h->size<<1)) { \ kh_resize_##name(pic, h, h->n_buckets - 1); /* clear "deleted" elements */ \ @@ -163,7 +158,7 @@ typedef khint_t khiter_t; } \ } /* TODO: to implement automatically shrinking; resize() already support shrinking */ \ { \ - khint_t k, i, site, last, mask = h->n_buckets - 1, step = 0; \ + int k, i, site, last, mask = h->n_buckets - 1, step = 0; \ x = site = h->n_buckets; k = hash_func(key); i = k & mask; \ if (ac_isempty(h->flags, i)) x = i; /* for speed up */ \ else { \ @@ -192,7 +187,7 @@ typedef khint_t khiter_t; } else *ret = 0; /* Don't touch h->keys[x] if present and not deleted */ \ return x; \ } \ - void kh_del_##name(kh_##name##_t *h, khint_t x) \ + void kh_del_##name(kh_##name##_t *h, int x) \ { \ if (x != h->n_buckets && !ac_iseither(h->flags, x)) { \ ac_set_isdel_true(h->flags, x); \ @@ -206,6 +201,15 @@ typedef khint_t khiter_t; #define kh_ptr_hash_equal(a, b) ((a) == (b)) #define kh_int_hash_func(key) (int)(key) #define kh_int_hash_equal(a, b) ((a) == (b)) +PIC_INLINE int kh_str_hash_func(const char *s) { + int h = 0; + while (*s) { + h = (h << 5) - h + *s++; + } + return h; +} +#define kh_str_cmp_func(a, b) (strcmp((a), (b)) == 0) + /* --- END OF HASH FUNCTIONS --- */ @@ -222,7 +226,7 @@ typedef khint_t khiter_t; #define kh_key(h, x) ((h)->keys[x]) #define kh_val(h, x) ((h)->vals[x]) #define kh_value(h, x) ((h)->vals[x]) -#define kh_begin(h) (khint_t)(0) +#define kh_begin(h) (0) #define kh_end(h) ((h)->n_buckets) #define kh_size(h) ((h)->size) #define kh_n_buckets(h) ((h)->n_buckets) diff --git a/extlib/benz/include/picrin/private/object.h b/extlib/benz/include/picrin/private/object.h new file mode 100644 index 00000000..2dedfcec --- /dev/null +++ b/extlib/benz/include/picrin/private/object.h @@ -0,0 +1,198 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_OBJECT_H +#define PICRIN_OBJECT_H + +#if defined(__cplusplus) +extern "C" { +#endif + +#include "picrin/private/khash.h" + +typedef struct identifier symbol; + +KHASH_DECLARE(env, struct identifier *, symbol *) +KHASH_DECLARE(dict, symbol *, pic_value) +KHASH_DECLARE(weak, struct object *, pic_value) + +#define PIC_OBJECT_HEADER \ + unsigned char tt; \ + char gc_mark; + +struct object; /* defined in gc.c */ + +struct basic { + PIC_OBJECT_HEADER +}; + +struct identifier { + PIC_OBJECT_HEADER + union { + struct string *str; + struct identifier *id; + } u; + struct env *env; +}; + +struct env { + PIC_OBJECT_HEADER + khash_t(env) map; + struct env *up; + struct string *lib; +}; + +struct pair { + PIC_OBJECT_HEADER + pic_value car; + pic_value cdr; +}; + +struct blob { + PIC_OBJECT_HEADER + unsigned char *data; + int len; +}; + +struct string { + PIC_OBJECT_HEADER + struct rope *rope; +}; + +struct dict { + PIC_OBJECT_HEADER + khash_t(dict) hash; +}; + +struct weak { + PIC_OBJECT_HEADER + khash_t(weak) hash; + struct weak *prev; /* for GC */ +}; + +struct vector { + PIC_OBJECT_HEADER + pic_value *data; + int len; +}; + +struct data { + PIC_OBJECT_HEADER + const pic_data_type *type; + void *data; +}; + +struct context { + PIC_OBJECT_HEADER + pic_value *regs; + int regc; + struct context *up; + pic_value storage[1]; +}; + +struct proc { + PIC_OBJECT_HEADER + union { + struct { + pic_func_t func; + int localc; + } f; + struct { + struct irep *irep; + struct context *cxt; + } i; + } u; + pic_value locals[1]; +}; + +struct record { + PIC_OBJECT_HEADER + pic_value type; + pic_value datum; +}; + +struct error { + PIC_OBJECT_HEADER + symbol *type; + struct string *msg; + pic_value irrs; + struct string *stack; +}; + +struct port { + PIC_OBJECT_HEADER + xFILE *file; +}; + +struct checkpoint { + PIC_OBJECT_HEADER + struct proc *in; + struct proc *out; + int depth; + struct checkpoint *prev; +}; + +struct object *pic_obj_ptr(pic_value); + +#define pic_id_ptr(pic, o) (assert(pic_id_p(pic, o)), (struct identifier *)pic_obj_ptr(o)) +#define pic_sym_ptr(pic, o) (assert(pic_sym_p(pic, o)), (symbol *)pic_obj_ptr(o)) +#define pic_str_ptr(pic, o) (assert(pic_str_p(pic, o)), (struct string *)pic_obj_ptr(o)) +#define pic_blob_ptr(pic, o) (assert(pic_blob_p(pic, o)), (struct blob *)pic_obj_ptr(o)) +#define pic_pair_ptr(pic, o) (assert(pic_pair_p(pic, o)), (struct pair *)pic_obj_ptr(o)) +#define pic_vec_ptr(pic, o) (assert(pic_vec_p(pic, o)), (struct vector *)pic_obj_ptr(o)) +#define pic_dict_ptr(pic, o) (assert(pic_dict_p(pic, o)), (struct dict *)pic_obj_ptr(o)) +#define pic_weak_ptr(pic, o) (assert(pic_weak_p(pic, o)), (struct weak *)pic_obj_ptr(o)) +#define pic_data_ptr(pic, o) (assert(pic_data_p(pic, o, NULL)), (struct data *)pic_obj_ptr(o)) +#define pic_proc_ptr(pic, o) (assert(pic_proc_p(pic, o)), (struct proc *)pic_obj_ptr(o)) +#define pic_env_ptr(pic, o) (assert(pic_env_p(pic, o)), (struct env *)pic_obj_ptr(o)) +#define pic_port_ptr(pic, o) (assert(pic_port_p(pic, o)), (struct port *)pic_obj_ptr(o)) +#define pic_error_ptr(pic, o) (assert(pic_error_p(pic, o)), (struct error *)pic_obj_ptr(o)) +#define pic_rec_ptr(pic, o) (assert(pic_rec_p(pic, o)), (struct record *)pic_obj_ptr(o)) + +#define pic_obj_p(pic,v) (pic_type(pic,v) > PIC_IVAL_END) +#define pic_env_p(pic, v) (pic_type(pic, v) == PIC_TYPE_ENV) +#define pic_error_p(pic, v) (pic_type(pic, v) == PIC_TYPE_ERROR) +#define pic_rec_p(pic, v) (pic_type(pic, v) == PIC_TYPE_RECORD) + +pic_value pic_obj_value(void *ptr); +struct object *pic_obj_alloc(pic_state *, size_t, int type); + +#define VALID_INDEX(pic, len, i) do { \ + if (i < 0 || len <= i) pic_error(pic, "index out of range", 1, pic_int_value(pic, i)); \ + } while (0) +#define VALID_RANGE(pic, len, s, e) do { \ + if (s < 0 || len < s) pic_error(pic, "invalid start index", 1, pic_int_value(pic, s)); \ + if (e < s || len < e) pic_error(pic, "invalid end index", 1, pic_int_value(pic, e)); \ + } while (0) +#define VALID_ATRANGE(pic, tolen, at, fromlen, s, e) do { \ + VALID_INDEX(pic, tolen, at); \ + VALID_RANGE(pic, fromlen, s, e); \ + if (tolen - at < e - s) pic_error(pic, "invalid range", 0); \ + } while (0) + +pic_value pic_make_identifier(pic_state *, pic_value id, pic_value env); +pic_value pic_make_proc(pic_state *, pic_func_t, int, pic_value *); +pic_value pic_make_proc_irep(pic_state *, struct irep *, struct context *); +pic_value pic_make_env(pic_state *, pic_value env); +pic_value pic_make_rec(pic_state *, pic_value type, pic_value datum); + +pic_value pic_add_identifier(pic_state *, pic_value id, pic_value env); +void pic_put_identifier(pic_state *, pic_value id, pic_value uid, pic_value env); +pic_value pic_find_identifier(pic_state *, pic_value id, pic_value env); +pic_value pic_id_name(pic_state *, pic_value id); + +void pic_rope_incref(pic_state *, struct rope *); +void pic_rope_decref(pic_state *, struct rope *); + +#define pic_func_p(proc) (pic_type(pic, proc) == PIC_TYPE_FUNC) +#define pic_irep_p(proc) (pic_type(pic, proc) == PIC_TYPE_IREP) + +void pic_wind(pic_state *, struct checkpoint *, struct checkpoint *); + + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/private/state.h b/extlib/benz/include/picrin/private/state.h new file mode 100644 index 00000000..a5ea7ae8 --- /dev/null +++ b/extlib/benz/include/picrin/private/state.h @@ -0,0 +1,88 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_STATE_H +#define PICRIN_STATE_H + +#if defined(__cplusplus) +extern "C" { +#endif + +#include "picrin/private/khash.h" +#include "picrin/private/file.h" + +#include "picrin/private/vm.h" +#include "picrin/private/gc.h" + +struct lib { + struct string *name; + struct env *env; + struct dict *exports; +}; + +struct callinfo { + int argc, retc; + struct code *ip; + pic_value *fp; + struct irep *irep; + struct context *cxt; + int regc; + pic_value *regs; + struct context *up; +}; + +KHASH_DECLARE(oblist, struct string *, struct identifier *) +KHASH_DECLARE(ltable, const char *, struct lib) + +struct pic_state { + pic_allocf allocf; + void *userdata; + + struct checkpoint *cp; + struct pic_cont *cc; + int ccnt; + + pic_value *sp; + pic_value *stbase, *stend; + + struct callinfo *ci; + struct callinfo *cibase, *ciend; + + struct proc **xp; + struct proc **xpbase, **xpend; + + struct code *ip; + + pic_value ptable; /* list of ephemerons */ + + struct lib *lib; + + pic_value features; + + khash_t(oblist) oblist; /* string to symbol */ + int ucnt; + pic_value globals; /* weak */ + pic_value macros; /* weak */ + khash_t(ltable) ltable; + struct list_head ireps; /* chain */ + + xFILE files[XOPEN_MAX]; + struct code iseq[2]; /* for pic_apply_trampoline */ + + bool gc_enable; + struct heap *heap; + struct object **arena; + size_t arena_size, arena_idx; + + pic_value err; + pic_panicf panicf; + + char *native_stack_start; +}; + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/private/vm.h b/extlib/benz/include/picrin/private/vm.h new file mode 100644 index 00000000..2ad09095 --- /dev/null +++ b/extlib/benz/include/picrin/private/vm.h @@ -0,0 +1,85 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_VM_H +#define PICRIN_VM_H + +#if defined(__cplusplus) +extern "C" { +#endif + +enum { + OP_NOP, + OP_POP, + OP_PUSHUNDEF, + OP_PUSHNIL, + OP_PUSHTRUE, + OP_PUSHFALSE, + OP_PUSHINT, + OP_PUSHFLOAT, + OP_PUSHCHAR, + OP_PUSHEOF, + OP_PUSHCONST, + OP_GREF, + OP_GSET, + OP_LREF, + OP_LSET, + OP_CREF, + OP_CSET, + OP_JMP, + OP_JMPIF, + OP_NOT, + OP_CALL, + OP_TAILCALL, + OP_RET, + OP_LAMBDA, + OP_CONS, + OP_CAR, + OP_CDR, + OP_NILP, + OP_SYMBOLP, + OP_PAIRP, + OP_ADD, + OP_SUB, + OP_MUL, + OP_DIV, + OP_EQ, + OP_LT, + OP_LE, + OP_GT, + OP_GE, + OP_STOP +}; + +struct code { + int insn; + int a; + int b; +}; + +struct list_head { + struct list_head *prev, *next; +}; + +struct irep { + struct list_head list; + unsigned refc; + int argc, localc, capturec; + bool varg; + struct code *code; + struct irep **irep; + int *ints; + double *nums; + struct object **pool; + size_t ncode, nirep, nints, nnums, npool; +}; + +void pic_irep_incref(pic_state *, struct irep *); +void pic_irep_decref(pic_state *, struct irep *); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/proc.h b/extlib/benz/include/picrin/proc.h deleted file mode 100644 index e5cc2bdb..00000000 --- a/extlib/benz/include/picrin/proc.h +++ /dev/null @@ -1,59 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_PROC_H -#define PICRIN_PROC_H - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_context { - PIC_OBJECT_HEADER - pic_value *regs; - int regc; - struct pic_context *up; - pic_value storage[1]; -}; - -struct pic_proc { - PIC_OBJECT_HEADER - enum { - PIC_PROC_TAG_IREP, - PIC_PROC_TAG_FUNC - } tag; - union { - struct { - pic_func_t func; - struct pic_dict *env; - } f; - struct { - struct pic_irep *irep; - struct pic_context *cxt; - } i; - } u; -}; - -#define pic_proc_func_p(proc) ((proc)->tag == PIC_PROC_TAG_FUNC) -#define pic_proc_irep_p(proc) ((proc)->tag == PIC_PROC_TAG_IREP) - -#define pic_proc_p(o) (pic_type(o) == PIC_TT_PROC) -#define pic_proc_ptr(o) ((struct pic_proc *)pic_ptr(o)) - -#define pic_context_p(o) (pic_type(o) == PIC_TT_CXT) -#define pic_context_ptr(o) ((struct pic_context *)pic_ptr(o)) - -struct pic_proc *pic_make_proc(pic_state *, pic_func_t); -struct pic_proc *pic_make_proc_irep(pic_state *, struct pic_irep *, struct pic_context *); - -struct pic_dict *pic_proc_env(pic_state *, struct pic_proc *); -bool pic_proc_env_has(pic_state *, struct pic_proc *, const char *); -pic_value pic_proc_env_ref(pic_state *, struct pic_proc *, const char *); -void pic_proc_env_set(pic_state *, struct pic_proc *, const char *, pic_value); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/read.h b/extlib/benz/include/picrin/read.h deleted file mode 100644 index 27c715bb..00000000 --- a/extlib/benz/include/picrin/read.h +++ /dev/null @@ -1,33 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_READ_H -#define PICRIN_READ_H - -#if defined(__cplusplus) -extern "C" { -#endif - -KHASH_DECLARE(read, int, pic_value) - -typedef pic_value (*pic_reader_t)(pic_state *, struct pic_port *port, int c); - -typedef struct { - enum pic_typecase { - PIC_CASE_DEFAULT, - PIC_CASE_FOLD - } typecase; - khash_t(read) labels; - pic_reader_t table[256]; - pic_reader_t dispatch[256]; -} pic_reader; - -void pic_reader_init(pic_state *); -void pic_reader_destroy(pic_state *); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/record.h b/extlib/benz/include/picrin/record.h deleted file mode 100644 index 2ccf2669..00000000 --- a/extlib/benz/include/picrin/record.h +++ /dev/null @@ -1,30 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_RECORD_H -#define PICRIN_RECORD_H - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_record { - PIC_OBJECT_HEADER - pic_value type; - pic_value datum; -}; - -#define pic_rec_p(v) (pic_type(v) == PIC_TT_RECORD) -#define pic_rec_ptr(v) ((struct pic_record *)pic_ptr(v)) - -struct pic_record *pic_make_rec(pic_state *, pic_value, pic_value); - -pic_value pic_rec_type(pic_state *, struct pic_record *); -pic_value pic_rec_datum(pic_state *, struct pic_record *); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/compat.h b/extlib/benz/include/picrin/setup.h similarity index 72% rename from extlib/benz/include/picrin/compat.h rename to extlib/benz/include/picrin/setup.h index 8f2bb886..099de355 100644 --- a/extlib/benz/include/picrin/compat.h +++ b/extlib/benz/include/picrin/setup.h @@ -2,13 +2,82 @@ * See Copyright Notice in picrin.h */ -#ifndef PICRIN_COMPAT_H -#define PICRIN_COMPAT_H +#include "picconf.h" -#if defined(__cplusplus) -extern "C" { +#ifndef PIC_USE_LIBC +# define PIC_USE_LIBC 1 #endif +#ifndef PIC_USE_STDIO +# define PIC_USE_STDIO 1 +#endif + +#ifndef PIC_USE_WRITE +# define PIC_USE_WRITE 1 +#endif + +#ifndef PIC_JMPBUF +# include +# define PIC_JMPBUF jmp_buf +#endif + +#ifndef PIC_SETJMP +# include +# define PIC_SETJMP(pic, buf) setjmp(buf) +#endif + +#ifndef PIC_LONGJMP +# include +# define PIC_LONGJMP(pic, buf, val) longjmp((buf), (val)) +#endif + +#ifndef PIC_ABORT +void abort(void); +# define PIC_ABORT(pic) abort() +#endif + +#ifndef PIC_ARENA_SIZE +# define PIC_ARENA_SIZE (8 * 1024) +#endif + +#ifndef PIC_HEAP_PAGE_SIZE +# define PIC_HEAP_PAGE_SIZE (4 * 1024 * 1024) +#endif + +#ifndef PIC_PAGE_REQUEST_THRESHOLD +# define PIC_PAGE_REQUEST_THRESHOLD(total) ((total) * 77 / 100) +#endif + +#ifndef PIC_STACK_SIZE +# define PIC_STACK_SIZE 2048 +#endif + +#ifndef PIC_RESCUE_SIZE +# define PIC_RESCUE_SIZE 30 +#endif + +#ifndef PIC_SYM_POOL_SIZE +# define PIC_SYM_POOL_SIZE (2 * 1024) +#endif + +#ifndef PIC_IREP_SIZE +# define PIC_IREP_SIZE 8 +#endif + +#ifndef PIC_POOL_SIZE +# define PIC_POOL_SIZE 8 +#endif + +#ifndef PIC_SYMS_SIZE +# define PIC_SYMS_SIZE 32 +#endif + +#ifndef PIC_ISEQ_SIZE +# define PIC_ISEQ_SIZE 1024 +#endif + +/* check compatibility */ + #if __STDC_VERSION__ >= 199901L # include #else @@ -20,7 +89,7 @@ extern "C" { #if __STDC_VERSION__ >= 199901L # include #elif ! defined(offsetof) -# define offsetof(s,m) ((size_t)&(((s *)NULL)->m)) +# define offsetof(s,m) ((size_t)(&(((s *)0)->m) - 0)) #endif #if __STDC_VERSION__ >= 199901L @@ -54,8 +123,10 @@ typedef unsigned long uint32_t; #define PIC_FALLTHROUGH ((void)0) -#if __GNUC__ || __clang__ -# define PIC_UNUSED(v) __attribute__((unused)) v +#if defined(__cplusplus) +# define PIC_UNUSED(v) +#elif __GNUC__ || __clang__ +# define PIC_UNUSED(v) v __attribute__((unused)) #else # define PIC_UNUSED(v) v #endif @@ -80,8 +151,7 @@ typedef unsigned long uint32_t; # undef GCC_VERSION #endif -#define PIC_SWAP(type,a,b) \ - PIC_SWAP_HELPER_(type, PIC_GENSYM(tmp), a, b) +#define PIC_SWAP(type,a,b) PIC_SWAP_HELPER_(type, PIC_GENSYM(tmp), a, b) #define PIC_SWAP_HELPER_(type,tmp,a,b) \ do { \ type tmp = (a); \ @@ -90,7 +160,7 @@ typedef unsigned long uint32_t; } while (0) -#if PIC_ENABLE_LIBC +#if PIC_USE_LIBC #include #include @@ -203,6 +273,36 @@ memcpy(void *dst, const void *src, size_t n) return d; } +PIC_INLINE void * +memmove(void *dst, const void *src, size_t n) +{ + const char *s = src; + char *d = dst; + + if (d <= s || d >= s + n) { + memcpy(dst, src, n); + } else { + s += n; + d += n; + while (n-- > 0) { + *--d = *--s; + } + } + return d; +} + +PIC_INLINE int +memcmp(const void *b1, const void *b2, size_t n) +{ + const char *s1 = b1, *s2 = b2; + + while (*s1 == *s2 && n-- > 0) { + s1++; + s2++; + } + return (unsigned)*s1 - (unsigned)*s2; +} + PIC_INLINE char * strcpy(char *dst, const char *src) { @@ -279,7 +379,7 @@ atof(const char *nptr) #endif -#if PIC_ENABLE_STDIO +#if PIC_USE_STDIO # include PIC_INLINE void @@ -349,8 +449,16 @@ void PIC_DOUBLE_TO_CSTRING(double, char *); #endif double PIC_CSTRING_TO_DOUBLE(const char *); -#if defined(__cplusplus) -} +/* optional features available? */ + +#if (defined(__GNUC__) || defined(__clang__)) && ! defined(__STRICT_ANSI__) +# define PIC_DIRECT_THREADED_VM 1 +#else +# define PIC_DIRECT_THREADED_VM 0 #endif +#if __x86_64__ && (defined(__GNUC__) || defined(__clang__)) && ! defined(__STRICT_ANSI__) +# define PIC_NAN_BOXING 1 +#else +# define PIC_NAN_BOXING 0 #endif diff --git a/extlib/benz/include/picrin/string.h b/extlib/benz/include/picrin/string.h deleted file mode 100644 index f3343e2d..00000000 --- a/extlib/benz/include/picrin/string.h +++ /dev/null @@ -1,42 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_STRING_H -#define PICRIN_STRING_H - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_string { - PIC_OBJECT_HEADER - struct pic_rope *rope; -}; - -void pic_rope_incref(pic_state *, struct pic_rope *); -void pic_rope_decref(pic_state *, struct pic_rope *); - -#define pic_str_p(v) (pic_type(v) == PIC_TT_STRING) -#define pic_str_ptr(o) ((struct pic_string *)pic_ptr(o)) - -pic_str *pic_make_str(pic_state *, const char *, int); -#define pic_make_cstr(pic, cstr) pic_make_str(pic, (cstr), strlen(cstr)) -#define pic_make_lit(pic, lit) pic_make_str(pic, "" lit, -((int)sizeof lit - 1)) - -char pic_str_ref(pic_state *, pic_str *, int); -int pic_str_len(pic_str *); -pic_str *pic_str_cat(pic_state *, pic_str *, pic_str *); -pic_str *pic_str_sub(pic_state *, pic_str *, int, int); -int pic_str_cmp(pic_state *, pic_str *, pic_str *); -int pic_str_hash(pic_state *, pic_str *); -const char *pic_str_cstr(pic_state *, pic_str *); - -pic_str *pic_format(pic_state *, const char *, ...); -pic_str *pic_vformat(pic_state *, const char *, va_list); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/symbol.h b/extlib/benz/include/picrin/symbol.h deleted file mode 100644 index 6581bbd5..00000000 --- a/extlib/benz/include/picrin/symbol.h +++ /dev/null @@ -1,46 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_SYMBOL_H -#define PICRIN_SYMBOL_H - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_id { - union { - struct pic_symbol { - PIC_OBJECT_HEADER - pic_str *str; - } sym; - struct { - PIC_OBJECT_HEADER - struct pic_id *id; - struct pic_env *env; - } id; - } u; -}; - -#define pic_sym_p(v) (pic_type(v) == PIC_TT_SYMBOL) -#define pic_sym_ptr(v) ((pic_sym *)pic_ptr(v)) - -#define pic_id_p(v) (pic_type(v) == PIC_TT_ID || pic_type(v) == PIC_TT_SYMBOL) -#define pic_id_ptr(v) ((pic_id *)pic_ptr(v)) - -pic_sym *pic_intern(pic_state *, pic_str *); -#define pic_intern_str(pic,s,i) pic_intern(pic, pic_make_str(pic, (s), (i))) -#define pic_intern_cstr(pic,s) pic_intern(pic, pic_make_cstr(pic, (s))) -#define pic_intern_lit(pic,lit) pic_intern(pic, pic_make_lit(pic, lit)) - -pic_id *pic_make_identifier(pic_state *, pic_id *, struct pic_env *); - -const char *pic_symbol_name(pic_state *, pic_sym *); -const char *pic_identifier_name(pic_state *, pic_id *); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/type.h b/extlib/benz/include/picrin/type.h deleted file mode 100644 index fb99fc86..00000000 --- a/extlib/benz/include/picrin/type.h +++ /dev/null @@ -1,598 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_TYPE_H -#define PICRIN_TYPE_H - -#if defined(__cplusplus) -extern "C" { -#endif - -/** - * `invalid` value will never be seen from user-end: - * it is only used for repsenting internal special state - */ - -enum pic_vtype { - PIC_VTYPE_NIL = 1, - PIC_VTYPE_TRUE, - PIC_VTYPE_FALSE, - PIC_VTYPE_UNDEF, - PIC_VTYPE_INVALID, - PIC_VTYPE_FLOAT, - PIC_VTYPE_INT, - PIC_VTYPE_CHAR, - PIC_VTYPE_EOF, - PIC_VTYPE_HEAP -}; - -#if PIC_NAN_BOXING - -#include - -/** - * value representation by nan-boxing: - * float : FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF - * ptr : 111111111111TTTT PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP - * int : 1111111111110110 0000000000000000 IIIIIIIIIIIIIIII IIIIIIIIIIIIIIII - * char : 1111111111111000 0000000000000000 CCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCC - */ - -typedef uint64_t pic_value; - -#define pic_ptr(v) ((void *)(0xfffffffffffful & (v))) -#define pic_init_value(v,vtype) (v = (0xfff0000000000000ul | ((uint64_t)(vtype) << 48))) - -static inline enum pic_vtype -pic_vtype(pic_value v) -{ - return 0xfff0 >= (v >> 48) ? PIC_VTYPE_FLOAT : ((v >> 48) & 0xf); -} - -static inline double -pic_float(pic_value v) -{ - union { double f; uint64_t i; } u; - u.i = v; - return u.f; -} - -static inline int -pic_int(pic_value v) -{ - union { int i; unsigned u; } u; - u.u = v & 0xfffffffful; - return u.i; -} - -#define pic_char(v) ((v) & 0xfffffffful) - -#elif PIC_WORD_BOXING - -typedef unsigned long pic_value; - -#define pic_ptr(v) ((void *)(v)) -#define pic_init_value(v,vtype) do { \ - v = (vtype << 3) + 7; \ - } while (0) - -PIC_INLINE enum pic_vtype -pic_vtype(pic_value v) -{ - if ((v & 1) == 0) { - return PIC_VTYPE_HEAP; - } - if ((v & 2) == 0) { - return PIC_VTYPE_INT; - } - if ((v & 4) == 0) { - return PIC_VTYPE_CHAR; - } - return v >> 3; -} - -PIC_INLINE int -pic_int(pic_value v) -{ - v >>= 2; - if ((v & ((ULONG_MAX >> 3) + 1)) != 0) { - v |= ULONG_MAX - (ULONG_MAX >> 2); - } - return v; -} - -PIC_INLINE char -pic_char(pic_value v) -{ - return v >> 3; -} - -#else - -typedef struct { - enum pic_vtype type; - union { - void *data; - double f; - int i; - char c; - } u; -} pic_value; - -#define pic_ptr(v) ((v).u.data) -#define pic_vtype(v) ((v).type) -#define pic_init_value(v,vtype) ((v).type = (vtype), (v).u.data = NULL) - -#define pic_float(v) ((v).u.f) -#define pic_int(v) ((v).u.i) -#define pic_char(v) ((v).u.c) - -#endif - -enum pic_tt { - /* immediate */ - PIC_TT_NIL, - PIC_TT_BOOL, - PIC_TT_FLOAT, - PIC_TT_INT, - PIC_TT_CHAR, - PIC_TT_EOF, - PIC_TT_UNDEF, - PIC_TT_INVALID, - /* heap */ - PIC_TT_SYMBOL, - PIC_TT_PAIR, - PIC_TT_STRING, - PIC_TT_VECTOR, - PIC_TT_BLOB, - PIC_TT_PROC, - PIC_TT_PORT, - PIC_TT_ERROR, - PIC_TT_ID, - PIC_TT_ENV, - PIC_TT_LIB, - PIC_TT_DATA, - PIC_TT_DICT, - PIC_TT_WEAK, - PIC_TT_RECORD, - PIC_TT_CXT, - PIC_TT_CP -}; - -#define PIC_OBJECT_HEADER \ - enum pic_tt tt; \ - char gc_mark; - -struct pic_basic { - PIC_OBJECT_HEADER -}; - -struct pic_object; -struct pic_symbol; -struct pic_pair; -struct pic_string; -struct pic_vector; -struct pic_blob; - -struct pic_proc; -struct pic_port; -struct pic_error; -struct pic_env; - -/* set aliases to basic types */ -typedef struct pic_symbol pic_sym; -typedef struct pic_id pic_id; -typedef struct pic_pair pic_pair; -typedef struct pic_string pic_str; -typedef struct pic_vector pic_vec; -typedef struct pic_blob pic_blob; - -#define pic_obj_p(v) (pic_vtype(v) == PIC_VTYPE_HEAP) -#define pic_obj_ptr(v) ((struct pic_object *)pic_ptr(v)) - -#define pic_nil_p(v) (pic_vtype(v) == PIC_VTYPE_NIL) -#define pic_true_p(v) (pic_vtype(v) == PIC_VTYPE_TRUE) -#define pic_false_p(v) (pic_vtype(v) == PIC_VTYPE_FALSE) -#define pic_undef_p(v) (pic_vtype(v) == PIC_VTYPE_UNDEF) -#define pic_invalid_p(v) (pic_vtype(v) == PIC_VTYPE_INVALID) -#define pic_float_p(v) (pic_vtype(v) == PIC_VTYPE_FLOAT) -#define pic_int_p(v) (pic_vtype(v) == PIC_VTYPE_INT) -#define pic_char_p(v) (pic_vtype(v) == PIC_VTYPE_CHAR) -#define pic_eof_p(v) (pic_vtype(v) == PIC_VTYPE_EOF) - -#define pic_test(v) (! pic_false_p(v)) - -PIC_INLINE enum pic_tt pic_type(pic_value); -PIC_INLINE const char *pic_type_repr(enum pic_tt); - -#define pic_assert_type(pic, v, type) \ - if (! pic_##type##_p(v)) { \ - pic_errorf(pic, "expected " #type ", but got ~s", v); \ - } - -PIC_INLINE bool -pic_valid_int(double v) -{ - return INT_MIN <= v && v <= INT_MAX; -} - -PIC_INLINE pic_value pic_nil_value(); -PIC_INLINE pic_value pic_true_value(); -PIC_INLINE pic_value pic_false_value(); -PIC_INLINE pic_value pic_bool_value(bool); -PIC_INLINE pic_value pic_undef_value(); -PIC_INLINE pic_value pic_invalid_value(); -PIC_INLINE pic_value pic_obj_value(void *); -PIC_INLINE pic_value pic_float_value(double); -PIC_INLINE pic_value pic_int_value(int); -PIC_INLINE pic_value pic_char_value(char c); - -PIC_INLINE bool pic_eq_p(pic_value, pic_value); -PIC_INLINE bool pic_eqv_p(pic_value, pic_value); - -PIC_INLINE enum pic_tt -pic_type(pic_value v) -{ - switch (pic_vtype(v)) { - case PIC_VTYPE_NIL: - return PIC_TT_NIL; - case PIC_VTYPE_TRUE: - return PIC_TT_BOOL; - case PIC_VTYPE_FALSE: - return PIC_TT_BOOL; - case PIC_VTYPE_UNDEF: - return PIC_TT_UNDEF; - case PIC_VTYPE_INVALID: - return PIC_TT_INVALID; - case PIC_VTYPE_FLOAT: - return PIC_TT_FLOAT; - case PIC_VTYPE_INT: - return PIC_TT_INT; - case PIC_VTYPE_CHAR: - return PIC_TT_CHAR; - case PIC_VTYPE_EOF: - return PIC_TT_EOF; - case PIC_VTYPE_HEAP: - return ((struct pic_basic *)pic_ptr(v))->tt; - } - - PIC_UNREACHABLE(); -} - -PIC_INLINE const char * -pic_type_repr(enum pic_tt tt) -{ - switch (tt) { - case PIC_TT_NIL: - return "nil"; - case PIC_TT_BOOL: - return "boolean"; - case PIC_TT_FLOAT: - return "float"; - case PIC_TT_INT: - return "int"; - case PIC_TT_SYMBOL: - return "symbol"; - case PIC_TT_CHAR: - return "char"; - case PIC_TT_EOF: - return "eof"; - case PIC_TT_UNDEF: - return "undef"; - case PIC_TT_INVALID: - return "invalid"; - case PIC_TT_PAIR: - return "pair"; - case PIC_TT_STRING: - return "string"; - case PIC_TT_VECTOR: - return "vector"; - case PIC_TT_BLOB: - return "blob"; - case PIC_TT_PORT: - return "port"; - case PIC_TT_ERROR: - return "error"; - case PIC_TT_ID: - return "id"; - case PIC_TT_CXT: - return "cxt"; - case PIC_TT_PROC: - return "proc"; - case PIC_TT_ENV: - return "env"; - case PIC_TT_LIB: - return "lib"; - case PIC_TT_DATA: - return "data"; - case PIC_TT_DICT: - return "dict"; - case PIC_TT_WEAK: - return "weak"; - case PIC_TT_RECORD: - return "record"; - case PIC_TT_CP: - return "checkpoint"; - } - PIC_UNREACHABLE(); -} - -PIC_INLINE pic_value -pic_nil_value() -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_NIL); - return v; -} - -PIC_INLINE pic_value -pic_true_value() -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_TRUE); - return v; -} - -PIC_INLINE pic_value -pic_false_value() -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_FALSE); - return v; -} - -PIC_INLINE pic_value -pic_bool_value(bool b) -{ - pic_value v; - - pic_init_value(v, b ? PIC_VTYPE_TRUE : PIC_VTYPE_FALSE); - return v; -} - -#if PIC_NAN_BOXING - -PIC_INLINE pic_value -pic_obj_value(void *ptr) -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_HEAP); - v |= 0xfffffffffffful & (uint64_t)ptr; - return v; -} - -PIC_INLINE pic_value -pic_float_value(double f) -{ - union { double f; uint64_t i; } u; - - if (f != f) { - return 0x7ff8000000000000ul; - } else { - u.f = f; - return u.i; - } -} - -PIC_INLINE pic_value -pic_int_value(int i) -{ - union { int i; unsigned u; } u; - pic_value v; - - u.i = i; - - pic_init_value(v, PIC_VTYPE_INT); - v |= u.u; - return v; -} - -PIC_INLINE pic_value -pic_char_value(char c) -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_CHAR); - v |= c; - return v; -} - -#elif PIC_WORD_BOXING - -PIC_INLINE pic_value -pic_obj_value(void *ptr) -{ - return (pic_value)ptr; -} - -PIC_INLINE pic_value -pic_int_value(int i) -{ - return (i << 2) + 1; -} - -PIC_INLINE pic_value -pic_char_value(char c) -{ - return (c << 3) + 3; -} - -#else - -PIC_INLINE pic_value -pic_obj_value(void *ptr) -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_HEAP); - v.u.data = ptr; - return v; -} - -PIC_INLINE pic_value -pic_float_value(double f) -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_FLOAT); - v.u.f = f; - return v; -} - -PIC_INLINE pic_value -pic_int_value(int i) -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_INT); - v.u.i = i; - return v; -} - -PIC_INLINE pic_value -pic_char_value(char c) -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_CHAR); - v.u.c = c; - return v; -} - -#endif - -PIC_INLINE pic_value -pic_undef_value() -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_UNDEF); - return v; -} - -PIC_INLINE pic_value -pic_invalid_value() -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_INVALID); - return v; -} - -#if PIC_NAN_BOXING || PIC_WORD_BOXING - -PIC_INLINE bool -pic_eq_p(pic_value x, pic_value y) -{ - return x == y; -} - -PIC_INLINE bool -pic_eqv_p(pic_value x, pic_value y) -{ - return x == y; -} - -#else - -PIC_INLINE bool -pic_eq_p(pic_value x, pic_value y) -{ - if (pic_type(x) != pic_type(y)) - return false; - - switch (pic_type(x)) { - case PIC_TT_NIL: - return true; - case PIC_TT_BOOL: - return pic_vtype(x) == pic_vtype(y); - default: - return pic_ptr(x) == pic_ptr(y); - } -} - -PIC_INLINE bool -pic_eqv_p(pic_value x, pic_value y) -{ - if (pic_type(x) != pic_type(y)) - return false; - - switch (pic_type(x)) { - case PIC_TT_NIL: - return true; - case PIC_TT_BOOL: - return pic_vtype(x) == pic_vtype(y); - case PIC_TT_FLOAT: - return pic_float(x) == pic_float(y); - case PIC_TT_INT: - return pic_int(x) == pic_int(y); - default: - return pic_ptr(x) == pic_ptr(y); - } -} - -#endif - -#define pic_define_aop(name, op, guard) \ - PIC_INLINE pic_value \ - name(pic_state *pic, pic_value a, pic_value b) \ - { \ - PIC_NORETURN void pic_errorf(pic_state *, const char *, ...); \ - double f; \ - if (pic_int_p(a) && pic_int_p(b)) { \ - f = (double)pic_int(a) op (double)pic_int(b); \ - return (INT_MIN <= f && f <= INT_MAX && guard) \ - ? pic_int_value((int)f) \ - : pic_float_value(f); \ - } else if (pic_float_p(a) && pic_float_p(b)) { \ - return pic_float_value(pic_float(a) op pic_float(b)); \ - } else if (pic_int_p(a) && pic_float_p(b)) { \ - return pic_float_value(pic_int(a) op pic_float(b)); \ - } else if (pic_float_p(a) && pic_int_p(b)) { \ - return pic_float_value(pic_float(a) op pic_int(b)); \ - } else { \ - pic_errorf(pic, #name ": non-number operand given"); \ - } \ - PIC_UNREACHABLE(); \ - } - -pic_define_aop(pic_add, +, true) -pic_define_aop(pic_sub, -, true) -pic_define_aop(pic_mul, *, true) -pic_define_aop(pic_div, /, f == (int)f) - -#define pic_define_cmp(name, op) \ - PIC_INLINE bool \ - name(pic_state *pic, pic_value a, pic_value b) \ - { \ - PIC_NORETURN void pic_errorf(pic_state *, const char *, ...); \ - if (pic_int_p(a) && pic_int_p(b)) { \ - return pic_int(a) op pic_int(b); \ - } else if (pic_float_p(a) && pic_float_p(b)) { \ - return pic_float(a) op pic_float(b); \ - } else if (pic_int_p(a) && pic_float_p(b)) { \ - return pic_int(a) op pic_float(b); \ - } else if (pic_float_p(a) && pic_int_p(b)) { \ - return pic_float(a) op pic_int(b); \ - } else { \ - pic_errorf(pic, #name ": non-number operand given"); \ - } \ - PIC_UNREACHABLE(); \ - } - -pic_define_cmp(pic_eq, ==) -pic_define_cmp(pic_lt, <) -pic_define_cmp(pic_le, <=) -pic_define_cmp(pic_gt, >) -pic_define_cmp(pic_ge, >=) - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/vector.h b/extlib/benz/include/picrin/vector.h deleted file mode 100644 index d18f16e2..00000000 --- a/extlib/benz/include/picrin/vector.h +++ /dev/null @@ -1,27 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_VECTOR_H -#define PICRIN_VECTOR_H - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_vector { - PIC_OBJECT_HEADER - pic_value *data; - int len; -}; - -#define pic_vec_p(v) (pic_type(v) == PIC_TT_VECTOR) -#define pic_vec_ptr(o) ((struct pic_vector *)pic_ptr(o)) - -pic_vec *pic_make_vec(pic_state *, int); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/weak.h b/extlib/benz/include/picrin/weak.h deleted file mode 100644 index ac938c88..00000000 --- a/extlib/benz/include/picrin/weak.h +++ /dev/null @@ -1,34 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_WEAK_H -#define PICRIN_WEAK_H - -#if defined(__cplusplus) -extern "C" { -#endif - -KHASH_DECLARE(weak, void *, pic_value) - -struct pic_weak { - PIC_OBJECT_HEADER - khash_t(weak) hash; - struct pic_weak *prev; /* for GC */ -}; - -#define pic_weak_p(v) (pic_type(v) == PIC_TT_WEAK) -#define pic_weak_ptr(v) ((struct pic_weak *)pic_ptr(v)) - -struct pic_weak *pic_make_weak(pic_state *); - -pic_value pic_weak_ref(pic_state *, struct pic_weak *, void *); -void pic_weak_set(pic_state *, struct pic_weak *, void *, pic_value); -void pic_weak_del(pic_state *, struct pic_weak *, void *); -bool pic_weak_has(pic_state *, struct pic_weak *, void *); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index 0faac96b..b65fa3b0 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -3,197 +3,341 @@ */ #include "picrin.h" +#include "picrin/extra.h" +#include "picrin/private/object.h" +#include "picrin/private/state.h" -static struct pic_env * -make_library_env(pic_state *pic, pic_value name) +KHASH_DEFINE(env, struct identifier *, symbol *, kh_ptr_hash_func, kh_ptr_hash_equal) +KHASH_DEFINE(ltable, const char *, struct lib, kh_str_hash_func, kh_str_cmp_func) + +pic_value +pic_make_env(pic_state *pic, pic_value up) { - struct pic_env *env; - pic_value dir, it; - pic_str *prefix = NULL; + struct env *env; - pic_for_each (dir, name, it) { - if (prefix == NULL) { - prefix = pic_format(pic, "~a", dir); - } else { - prefix = pic_format(pic, "~a.~a", pic_obj_value(prefix), dir); - } - } + env = (struct env *)pic_obj_alloc(pic, sizeof(struct env), PIC_TYPE_ENV); + env->up = pic_env_ptr(pic, up); + env->lib = NULL; + kh_init(env, &env->map); - env = pic_make_topenv(pic, prefix); - - /* set up default environment */ - pic_put_identifier(pic, (pic_id *)pic->sDEFINE_LIBRARY, pic->sDEFINE_LIBRARY, env); - pic_put_identifier(pic, (pic_id *)pic->sIMPORT, pic->sIMPORT, env); - pic_put_identifier(pic, (pic_id *)pic->sEXPORT, pic->sEXPORT, env); - pic_put_identifier(pic, (pic_id *)pic->sCOND_EXPAND, pic->sCOND_EXPAND, env); - - return env; + return pic_obj_value(env); } -struct pic_lib * -pic_make_library(pic_state *pic, pic_value name) +static bool +search_scope(pic_state *pic, pic_value id, pic_value env, pic_value *uid) { - struct pic_lib *lib; - struct pic_env *env; - struct pic_dict *exports; + int it; - if ((lib = pic_find_library(pic, name)) != NULL) { - pic_errorf(pic, "library name already in use: ~s", name); + it = kh_get(env, &pic_env_ptr(pic, env)->map, pic_id_ptr(pic, id)); + if (it == kh_end(&pic_env_ptr(pic, env)->map)) { + return false; + } + *uid = pic_obj_value(kh_val(&pic_env_ptr(pic, env)->map, it)); + return true; +} + +static bool +search(pic_state *pic, pic_value id, pic_value env, pic_value *uid) +{ + struct env *e; + + while (1) { + if (search_scope(pic, id, env, uid)) + return true; + e = pic_env_ptr(pic, env)->up; + if (e == NULL) + break; + env = pic_obj_value(e); + } + return false; +} + +pic_value +pic_find_identifier(pic_state *pic, pic_value id, pic_value env) +{ + struct env *e; + pic_value uid; + + while (! search(pic, id, env, &uid)) { + if (pic_sym_p(pic, id)) { + while (1) { + e = pic_env_ptr(pic, env); + if (e->up == NULL) + break; + env = pic_obj_value(e->up); + } + return pic_add_identifier(pic, id, env); + } + env = pic_obj_value(pic_id_ptr(pic, id)->env); /* do not overwrite id first */ + id = pic_obj_value(pic_id_ptr(pic, id)->u.id); + } + return uid; +} + +pic_value +pic_add_identifier(pic_state *pic, pic_value id, pic_value env) +{ + const char *name, *lib; + pic_value uid, str; + + if (search_scope(pic, id, env, &uid)) { + return uid; } + name = pic_str(pic, pic_id_name(pic, id)); + + if (pic_env_ptr(pic, env)->up == NULL && pic_sym_p(pic, id)) { /* toplevel & public */ + lib = pic_str(pic, pic_obj_value(pic_env_ptr(pic, env)->lib)); + str = pic_strf_value(pic, "%s/%s", lib, name); + } else { + str = pic_strf_value(pic, ".%s.%d", name, pic->ucnt++); + } + uid = pic_intern(pic, str); + + pic_put_identifier(pic, id, uid, env); + + return uid; +} + +void +pic_put_identifier(pic_state *pic, pic_value id, pic_value uid, pic_value env) +{ + int it, ret; + + it = kh_put(env, &pic_env_ptr(pic, env)->map, pic_id_ptr(pic, id), &ret); + kh_val(&pic_env_ptr(pic, env)->map, it) = pic_sym_ptr(pic, uid); +} + +static struct lib * +get_library_opt(pic_state *pic, const char *lib) +{ + khash_t(ltable) *h = &pic->ltable; + int it; + + it = kh_get(ltable, h, lib); + if (it == kh_end(h)) { + return NULL; + } + return &kh_val(h, it); +} + +static struct lib * +get_library(pic_state *pic, const char *lib) +{ + struct lib *libp; + + if ((libp = get_library_opt(pic, lib)) == NULL) { + pic_error(pic, "library not found", 1, pic_cstr_value(pic, lib)); + } + return libp; +} + +static pic_value +make_library_env(pic_state *pic, pic_value name) +{ + struct env *env; + pic_value e; + + env = (struct env *)pic_obj_alloc(pic, sizeof(struct env), PIC_TYPE_ENV); + env->up = NULL; + env->lib = pic_str_ptr(pic, name); + kh_init(env, &env->map); + + e = pic_obj_value(env); + +#define REGISTER(name) pic_put_identifier(pic, pic_intern_lit(pic, name), pic_intern_lit(pic, name), e) + + /* set up default environment */ + REGISTER("define-library"); + REGISTER("import"); + REGISTER("export"); + REGISTER("cond-expand"); + + return e; +} + +void +pic_make_library(pic_state *pic, const char *lib) +{ + khash_t(ltable) *h = &pic->ltable; + const char *old_lib = NULL; + pic_value name, env, exports; + int it; + int ret; + + if (pic->lib) { + old_lib = pic_current_library(pic); + } + + name = pic_cstr_value(pic, lib); env = make_library_env(pic, name); exports = pic_make_dict(pic); - lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB); - lib->name = name; - lib->env = env; - lib->exports = exports; - - /* register! */ - pic->libs = pic_acons(pic, name, pic_obj_value(lib), pic->libs); - - return lib; -} - -struct pic_lib * -pic_find_library(pic_state *pic, pic_value spec) -{ - pic_value v; - - v = pic_assoc(pic, spec, pic->libs, NULL); - if (pic_false_p(v)) { - return NULL; + it = kh_put(ltable, h, pic_str(pic, name), &ret); + if (ret == 0) { /* if exists */ + pic_error(pic, "library name already in use", 1, pic_cstr_value(pic, lib)); + } + + kh_val(h, it).name = pic_str_ptr(pic, name); + kh_val(h, it).env = pic_env_ptr(pic, env); + kh_val(h, it).exports = pic_dict_ptr(pic, exports); + + if (pic->lib) { + pic->lib = get_library(pic, old_lib); /* ltable might be rehashed */ } - return pic_lib_ptr(pic_cdr(pic, v)); } void -pic_import(pic_state *pic, struct pic_lib *lib) +pic_in_library(pic_state *pic, const char *lib) { - pic_sym *name, *realname, *uid; - khiter_t it; + pic->lib = get_library(pic, lib); +} - pic_dict_for_each (name, lib->exports, it) { - realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, name)); +bool +pic_find_library(pic_state *pic, const char *lib) +{ + return get_library_opt(pic, lib) != NULL; +} - if ((uid = pic_find_identifier(pic, (pic_id *)realname, lib->env)) == NULL) { - pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname)); +const char * +pic_current_library(pic_state *pic) +{ + return pic_str(pic, pic_obj_value(pic->lib->name)); +} + +pic_value +pic_library_environment(pic_state *pic, const char *lib) +{ + return pic_obj_value(get_library(pic, lib)->env); +} + +void +pic_import(pic_state *pic, const char *lib) +{ + pic_value name, realname, uid; + int it = 0; + struct lib *libp; + + libp = get_library(pic, lib); + + while (pic_dict_next(pic, pic_obj_value(libp->exports), &it, &name, &realname)) { + uid = pic_find_identifier(pic, realname, pic_obj_value(libp->env)); + if (! pic_weak_has(pic, pic->globals, uid) && ! pic_weak_has(pic, pic->macros, uid)) { + pic_error(pic, "attempted to export undefined variable", 1, realname); } - pic_put_identifier(pic, (pic_id *)name, uid, pic->lib->env); + pic_put_identifier(pic, name, uid, pic_obj_value(pic->lib->env)); } } void -pic_export(pic_state *pic, pic_sym *name) +pic_export(pic_state *pic, pic_value name) { - pic_dict_set(pic, pic->lib->exports, name, pic_obj_value(name)); + pic_dict_set(pic, pic_obj_value(pic->lib->exports), name, name); } static pic_value pic_lib_make_library(pic_state *pic) { - pic_value name; + const char *lib; - pic_get_args(pic, "o", &name); + pic_get_args(pic, "z", &lib); - return pic_obj_value(pic_make_library(pic, name)); + pic_make_library(pic, lib); + + return pic_undef_value(pic); } static pic_value pic_lib_find_library(pic_state *pic) { - pic_value name; - struct pic_lib *lib; + const char *lib; - pic_get_args(pic, "o", &name); + pic_get_args(pic, "z", &lib); - if ((lib = pic_find_library(pic, name)) == NULL) { - return pic_false_value(); - } - return pic_obj_value(lib); + return pic_bool_value(pic, pic_find_library(pic, lib)); } static pic_value pic_lib_current_library(pic_state *pic) { - pic_value lib; + const char *lib; int n; - n = pic_get_args(pic, "|o", &lib); + n = pic_get_args(pic, "|z", &lib); if (n == 0) { - return pic_obj_value(pic->lib); + return pic_obj_value(pic->lib->name); } else { - pic_assert_type(pic, lib, lib); + pic_in_library(pic, lib); - pic->lib = pic_lib_ptr(lib); - - return pic_undef_value(); + return pic_undef_value(pic); } } static pic_value pic_lib_library_import(pic_state *pic) { - pic_value lib_opt; - pic_sym *name, *realname, *uid, *alias = NULL; - struct pic_lib *lib; + const char *lib; + pic_value name, alias, realname, uid; + struct lib *libp; + int n; - pic_get_args(pic, "om|m", &lib_opt, &name, &alias); + n = pic_get_args(pic, "zm|m", &lib, &name, &alias); - pic_assert_type(pic, lib_opt, lib); - - if (alias == NULL) { + if (n == 2) { alias = name; } - lib = pic_lib_ptr(lib_opt); + libp = get_library(pic, lib); - if (! pic_dict_has(pic, lib->exports, name)) { - pic_errorf(pic, "attempted to import undefined variable '~s'", pic_obj_value(name)); + if (! pic_dict_has(pic, pic_obj_value(libp->exports), name)) { + pic_error(pic, "library-import: variable is not exported", 1, name); } else { - realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, name)); + realname = pic_dict_ref(pic, pic_obj_value(libp->exports), name); } - if ((uid = pic_find_identifier(pic, (pic_id *)realname, lib->env)) == NULL) { - pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname)); - } else { - pic_put_identifier(pic, (pic_id *)alias, uid, pic->lib->env); + uid = pic_find_identifier(pic, realname, pic_obj_value(libp->env)); + if (! pic_weak_has(pic, pic->globals, uid) && ! pic_weak_has(pic, pic->macros, uid)) { + pic_error(pic, "attempted to export undefined variable", 1, realname); } - return pic_undef_value(); + pic_put_identifier(pic, alias, uid, pic_obj_value(pic->lib->env)); + + return pic_undef_value(pic); } static pic_value pic_lib_library_export(pic_state *pic) { - pic_sym *name, *alias = NULL; + pic_value name, alias = pic_false_value(pic); + int n; - pic_get_args(pic, "m|m", &name, &alias); + n = pic_get_args(pic, "m|m", &name, &alias); - if (alias == NULL) { + if (n == 1) { alias = name; } - pic_dict_set(pic, pic->lib->exports, alias, pic_obj_value(name)); + pic_dict_set(pic, pic_obj_value(pic->lib->exports), alias, name); - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value pic_lib_library_exports(pic_state *pic) { - pic_value lib, exports = pic_nil_value(); - pic_sym *sym; - khiter_t it; + const char *lib; + pic_value sym, exports = pic_nil_value(pic); + int it = 0; + struct lib *libp; - pic_get_args(pic, "o", &lib); + pic_get_args(pic, "z", &lib); - pic_assert_type(pic, lib, lib); + libp = get_library(pic, lib); - pic_dict_for_each (sym, pic_lib_ptr(lib)->exports, it) { - pic_push(pic, pic_obj_value(sym), exports); + while (pic_dict_next(pic, pic_obj_value(libp->exports), &it, &sym, NULL)) { + pic_push(pic, sym, exports); } return exports; @@ -202,13 +346,11 @@ pic_lib_library_exports(pic_state *pic) static pic_value pic_lib_library_environment(pic_state *pic) { - pic_value lib; + const char *lib; - pic_get_args(pic, "o", &lib); + pic_get_args(pic, "z", &lib); - pic_assert_type(pic, lib, lib); - - return pic_obj_value(pic_lib_ptr(lib)->env); + return pic_obj_value(get_library(pic, lib)->env); } void diff --git a/extlib/benz/load.c b/extlib/benz/load.c index e07b70d3..25d79d7d 100644 --- a/extlib/benz/load.c +++ b/extlib/benz/load.c @@ -3,31 +3,32 @@ */ #include "picrin.h" +#include "picrin/extra.h" void -pic_load(pic_state *pic, struct pic_port *port) +pic_load(pic_state *pic, pic_value port) { pic_value form; - size_t ai = pic_gc_arena_preserve(pic); + size_t ai = pic_enter(pic); - while (! pic_eof_p(form = pic_read(pic, port))) { - pic_eval(pic, form, pic->lib); + while (! pic_eof_p(pic, form = pic_read(pic, port))) { + pic_eval(pic, form, pic_current_library(pic)); - pic_gc_arena_restore(pic, ai); + pic_leave(pic, ai); } } void -pic_load_cstr(pic_state *pic, const char *src) +pic_load_cstr(pic_state *pic, const char *str) { - struct pic_port *port = pic_open_input_string(pic, src); + pic_value port = pic_open_port(pic, xfopen_buf(pic, str, strlen(str), "r")); pic_try { pic_load(pic, port); } pic_catch { pic_close_port(pic, port); - pic_raise(pic, pic->err); + pic_raise(pic, pic_err(pic)); } pic_close_port(pic, port); diff --git a/extlib/benz/macro.c b/extlib/benz/macro.c deleted file mode 100644 index ad39e354..00000000 --- a/extlib/benz/macro.c +++ /dev/null @@ -1,365 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" - -KHASH_DEFINE(env, pic_id *, pic_sym *, kh_ptr_hash_func, kh_ptr_hash_equal) - -struct pic_env * -pic_make_env(pic_state *pic, struct pic_env *up) -{ - struct pic_env *env; - - assert(up != NULL); - - env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV); - env->up = up; - env->prefix = NULL; - kh_init(env, &env->map); - return env; -} - -struct pic_env * -pic_make_topenv(pic_state *pic, pic_str *prefix) -{ - struct pic_env *env; - - env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV); - env->up = NULL; - env->prefix = prefix; - kh_init(env, &env->map); - return env; -} - -pic_sym * -pic_add_identifier(pic_state *pic, pic_id *id, struct pic_env *env) -{ - const char *name; - pic_sym *uid; - pic_str *str; - - name = pic_identifier_name(pic, id); - - if (env->up == NULL && pic_sym_p(pic_obj_value(id))) { /* toplevel & public */ - str = pic_format(pic, "%s/%s", pic_str_cstr(pic, env->prefix), name); - } else { - str = pic_format(pic, ".%s.%d", name, pic->ucnt++); - } - uid = pic_intern(pic, str); - - return pic_put_identifier(pic, id, uid, env); -} - -pic_sym * -pic_put_identifier(pic_state *pic, pic_id *id, pic_sym *uid, struct pic_env *env) -{ - khiter_t it; - int ret; - - it = kh_put(env, &env->map, id, &ret); - kh_val(&env->map, it) = uid; - - return uid; -} - -pic_sym * -pic_find_identifier(pic_state PIC_UNUSED(*pic), pic_id *id, struct pic_env *env) -{ - khiter_t it; - - it = kh_get(env, &env->map, id); - if (it == kh_end(&env->map)) { - return NULL; - } - return kh_val(&env->map, it); -} - -static pic_sym * -lookup(pic_state *pic, pic_id *id, struct pic_env *env) -{ - pic_sym *uid = NULL; - - while (env != NULL) { - uid = pic_find_identifier(pic, id, env); - if (uid != NULL) { - break; - } - env = env->up; - } - return uid; -} - -pic_sym * -pic_lookup_identifier(pic_state *pic, pic_id *id, struct pic_env *env) -{ - pic_sym *uid; - - while ((uid = lookup(pic, id, env)) == NULL) { - if (pic_sym_p(pic_obj_value(id))) { - break; - } - env = id->u.id.env; /* do not overwrite id first */ - id = id->u.id.id; - } - if (uid == NULL) { - while (env->up != NULL) { - env = env->up; - } - uid = pic_add_identifier(pic, id, env); - } - return uid; -} - - -/** - * macro expander - */ - - -static void -define_macro(pic_state *pic, pic_sym *uid, struct pic_proc *mac) -{ - if (pic_weak_has(pic, pic->macros, uid)) { - pic_warnf(pic, "redefining syntax variable: ~s", pic_obj_value(uid)); - } - pic_weak_set(pic, pic->macros, uid, pic_obj_value(mac)); -} - -static struct pic_proc * -find_macro(pic_state *pic, pic_sym *uid) -{ - if (! pic_weak_has(pic, pic->macros, uid)) { - return NULL; - } - return pic_proc_ptr(pic_weak_ref(pic, pic->macros, uid)); -} - -static void -shadow_macro(pic_state *pic, pic_sym *uid) -{ - if (pic_weak_has(pic, pic->macros, uid)) { - pic_weak_del(pic, pic->macros, uid); - } -} - -static pic_value expand(pic_state *, pic_value, struct pic_env *, pic_value); -static pic_value expand_lambda(pic_state *, pic_value, struct pic_env *); - -static pic_value -expand_var(pic_state *pic, pic_id *id, struct pic_env *env, pic_value deferred) -{ - struct pic_proc *mac; - pic_sym *functor; - - functor = pic_lookup_identifier(pic, id, env); - - if ((mac = find_macro(pic, functor)) != NULL) { - return expand(pic, pic_apply2(pic, mac, pic_obj_value(id), pic_obj_value(env)), env, deferred); - } - return pic_obj_value(functor); -} - -static pic_value -expand_quote(pic_state *pic, pic_value expr) -{ - return pic_cons(pic, pic_obj_value(pic->sQUOTE), pic_cdr(pic, expr)); -} - -static pic_value -expand_list(pic_state *pic, pic_value obj, struct pic_env *env, pic_value deferred) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value x, head, tail; - - if (pic_pair_p(obj)) { - head = expand(pic, pic_car(pic, obj), env, deferred); - tail = expand_list(pic, pic_cdr(pic, obj), env, deferred); - x = pic_cons(pic, head, tail); - } else { - x = expand(pic, obj, env, deferred); - } - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, x); - return x; -} - -static pic_value -expand_defer(pic_state *pic, pic_value expr, pic_value deferred) -{ - pic_value skel = pic_cons(pic, pic_invalid_value(), pic_invalid_value()); - - pic_set_car(pic, deferred, pic_acons(pic, expr, skel, pic_car(pic, deferred))); - - return skel; -} - -static void -expand_deferred(pic_state *pic, pic_value deferred, struct pic_env *env) -{ - pic_value defer, val, src, dst, it; - - deferred = pic_car(pic, deferred); - - pic_for_each (defer, pic_reverse(pic, deferred), it) { - src = pic_car(pic, defer); - dst = pic_cdr(pic, defer); - - val = expand_lambda(pic, src, env); - - /* copy */ - pic_set_car(pic, dst, pic_car(pic, val)); - pic_set_cdr(pic, dst, pic_cdr(pic, val)); - } -} - -static pic_value -expand_lambda(pic_state *pic, pic_value expr, struct pic_env *env) -{ - pic_value formal, body; - struct pic_env *in; - pic_value a, deferred; - - in = pic_make_env(pic, env); - - for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) { - pic_add_identifier(pic, pic_id_ptr(pic_car(pic, a)), in); - } - if (pic_id_p(a)) { - pic_add_identifier(pic, pic_id_ptr(a), in); - } - - deferred = pic_list1(pic, pic_nil_value()); - - formal = expand_list(pic, pic_list_ref(pic, expr, 1), in, deferred); - body = expand(pic, pic_list_ref(pic, expr, 2), in, deferred); - - expand_deferred(pic, deferred, in); - - return pic_list3(pic, pic_obj_value(pic->sLAMBDA), formal, body); -} - -static pic_value -expand_define(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred) -{ - pic_sym *uid; - pic_id *id; - pic_value val; - - id = pic_id_ptr(pic_cadr(pic, expr)); - if ((uid = pic_find_identifier(pic, id, env)) == NULL) { - uid = pic_add_identifier(pic, id, env); - } else { - shadow_macro(pic, uid); - } - val = expand(pic, pic_list_ref(pic, expr, 2), env, deferred); - - return pic_list3(pic, pic_obj_value(pic->sDEFINE), pic_obj_value(uid), val); -} - -static pic_value -expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) -{ - struct pic_proc *pic_compile(pic_state *, pic_value); - pic_id *id; - pic_value val; - pic_sym *uid; - - id = pic_id_ptr(pic_cadr(pic, expr)); - if ((uid = pic_find_identifier(pic, id, env)) == NULL) { - uid = pic_add_identifier(pic, id, env); - } - - val = pic_apply0(pic, pic_compile(pic, pic_expand(pic, pic_list_ref(pic, expr, 2), env))); - if (! pic_proc_p(val)) { - pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", pic_identifier_name(pic, id)); - } - - define_macro(pic, uid, pic_proc_ptr(val)); - - return pic_undef_value(); -} - -static pic_value -expand_node(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred) -{ - switch (pic_type(expr)) { - case PIC_TT_ID: - case PIC_TT_SYMBOL: { - return expand_var(pic, pic_id_ptr(expr), env, deferred); - } - case PIC_TT_PAIR: { - struct pic_proc *mac; - - if (! pic_list_p(expr)) { - pic_errorf(pic, "cannot expand improper list: ~s", expr); - } - - if (pic_id_p(pic_car(pic, expr))) { - pic_sym *functor; - - functor = pic_lookup_identifier(pic, pic_id_ptr(pic_car(pic, expr)), env); - - if (functor == pic->sDEFINE_MACRO) { - return expand_defmacro(pic, expr, env); - } - else if (functor == pic->sLAMBDA) { - return expand_defer(pic, expr, deferred); - } - else if (functor == pic->sDEFINE) { - return expand_define(pic, expr, env, deferred); - } - else if (functor == pic->sQUOTE) { - return expand_quote(pic, expr); - } - - if ((mac = find_macro(pic, functor)) != NULL) { - return expand(pic, pic_apply2(pic, mac, expr, pic_obj_value(env)), env, deferred); - } - } - return expand_list(pic, expr, env, deferred); - } - default: - return expr; - } -} - -static pic_value -expand(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value v; - - v = expand_node(pic, expr, env, deferred); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, v); - return v; -} - -pic_value -pic_expand(pic_state *pic, pic_value expr, struct pic_env *env) -{ - pic_value v, deferred; - -#if DEBUG - puts("before expand:"); - pic_debug(pic, expr); - puts(""); -#endif - - deferred = pic_list1(pic, pic_nil_value()); - - v = expand(pic, expr, env, deferred); - - expand_deferred(pic, deferred, env); - -#if DEBUG - puts("after expand:"); - pic_debug(pic, v); - puts(""); -#endif - - return v; -} diff --git a/extlib/benz/number.c b/extlib/benz/number.c index 4f60a7ca..2ecbe2d9 100644 --- a/extlib/benz/number.c +++ b/extlib/benz/number.c @@ -3,6 +3,7 @@ */ #include "picrin.h" +#include "picrin/extra.h" static pic_value pic_number_number_p(pic_state *pic) @@ -11,7 +12,7 @@ pic_number_number_p(pic_state *pic) pic_get_args(pic, "o", &v); - return pic_bool_value(pic_float_p(v) || pic_int_p(v)); + return pic_bool_value(pic, pic_float_p(pic, v) || pic_int_p(pic, v)); } static pic_value @@ -21,7 +22,7 @@ pic_number_exact_p(pic_state *pic) pic_get_args(pic, "o", &v); - return pic_bool_value(pic_int_p(v)); + return pic_bool_value(pic, pic_int_p(pic, v)); } static pic_value @@ -31,7 +32,7 @@ pic_number_inexact_p(pic_state *pic) pic_get_args(pic, "o", &v); - return pic_bool_value(pic_float_p(v)); + return pic_bool_value(pic, pic_float_p(pic, v)); } static pic_value @@ -41,7 +42,7 @@ pic_number_inexact(pic_state *pic) pic_get_args(pic, "f", &f); - return pic_float_value(f); + return pic_float_value(pic, f); } static pic_value @@ -51,9 +52,60 @@ pic_number_exact(pic_state *pic) pic_get_args(pic, "f", &f); - return pic_int_value((int)f); + return pic_int_value(pic, (int)f); } +#define pic_define_aop(name, op, guard) \ + pic_value \ + name(pic_state *pic, pic_value a, pic_value b) \ + { \ + double f; \ + if (pic_int_p(pic, a) && pic_int_p(pic, b)) { \ + f = (double)pic_int(pic, a) op (double)pic_int(pic, b); \ + return (INT_MIN <= f && f <= INT_MAX && guard) \ + ? pic_int_value(pic, (int)f) \ + : pic_float_value(pic, f); \ + } else if (pic_float_p(pic, a) && pic_float_p(pic, b)) { \ + return pic_float_value(pic, pic_float(pic, a) op pic_float(pic, b)); \ + } else if (pic_int_p(pic, a) && pic_float_p(pic, b)) { \ + return pic_float_value(pic, pic_int(pic, a) op pic_float(pic, b)); \ + } else if (pic_float_p(pic, a) && pic_int_p(pic, b)) { \ + return pic_float_value(pic, pic_float(pic, a) op pic_int(pic, b)); \ + } else { \ + pic_error(pic, #name ": non-number operand given", 0); \ + } \ + PIC_UNREACHABLE(); \ + } + +pic_define_aop(pic_add, +, true) +pic_define_aop(pic_sub, -, true) +pic_define_aop(pic_mul, *, true) +pic_define_aop(pic_div, /, f == (int)f) + +#define pic_define_cmp(name, op) \ + bool \ + name(pic_state *pic, pic_value a, pic_value b) \ + { \ + if (pic_int_p(pic, a) && pic_int_p(pic, b)) { \ + return pic_int(pic, a) op pic_int(pic, b); \ + } else if (pic_float_p(pic, a) && pic_float_p(pic, b)) { \ + return pic_float(pic, a) op pic_float(pic, b); \ + } else if (pic_int_p(pic, a) && pic_float_p(pic, b)) { \ + return pic_int(pic, a) op pic_float(pic, b); \ + } else if (pic_float_p(pic, a) && pic_int_p(pic, b)) { \ + return pic_float(pic, a) op pic_int(pic, b); \ + } else { \ + pic_error(pic, #name ": non-number operand given", 0); \ + } \ + PIC_UNREACHABLE(); \ + } + +pic_define_cmp(pic_eq, ==) +pic_define_cmp(pic_lt, <) +pic_define_cmp(pic_le, <=) +pic_define_cmp(pic_gt, >) +pic_define_cmp(pic_ge, >=) + #define DEFINE_CMP(op) \ static pic_value \ pic_number_##op(pic_state *pic) \ @@ -64,15 +116,15 @@ pic_number_exact(pic_state *pic) pic_get_args(pic, "*", &argc, &argv); \ \ if (argc < 2) { \ - return pic_true_value(); \ + return pic_true_value(pic); \ } \ \ for (i = 1; i < argc; ++i) { \ if (! pic_##op(pic, argv[i - 1], argv[i])) { \ - return pic_false_value(); \ + return pic_false_value(pic); \ } \ } \ - return pic_true_value(); \ + return pic_true_value(pic); \ } DEFINE_CMP(eq) @@ -105,16 +157,16 @@ DEFINE_CMP(ge) } DEFINE_AOP(add, argv[0], do { - return pic_int_value(0); + return pic_int_value(pic, 0); } while (0)) DEFINE_AOP(mul, argv[0], do { - return pic_int_value(1); + return pic_int_value(pic, 1); } while (0)) -DEFINE_AOP(sub, pic_sub(pic, pic_int_value(0), argv[0]), do { - pic_errorf(pic, "-: at least one argument required"); +DEFINE_AOP(sub, pic_sub(pic, pic_int_value(pic, 0), argv[0]), do { + pic_error(pic, "-: at least one argument required", 0); } while (0)) -DEFINE_AOP(div, pic_div(pic, pic_int_value(1), argv[0]), do { - pic_errorf(pic, "/: at least one argument required"); +DEFINE_AOP(div, pic_div(pic, pic_int_value(pic, 1), argv[0]), do { + pic_error(pic, "/: at least one argument required", 0); } while (0)) static int @@ -165,37 +217,35 @@ pic_number_number_to_string(pic_state *pic) double f; bool e; int radix = 10; - pic_str *str; + pic_value str; pic_get_args(pic, "F|i", &f, &e, &radix); if (radix < 2 || radix > 36) { - pic_errorf(pic, "number->string: invalid radix %d (between 2 and 36, inclusive)", radix); + pic_error(pic, "number->string: invalid radix (between 2 and 36, inclusive)", 1, pic_int_value(pic, radix)); } if (e) { int ival = (int) f; int ilen = number_string_length(ival, radix); - int s = ilen + 1; - char *buf = pic_malloc(pic, s); + char *buf = pic_alloca(pic, ilen + 1); number_string(ival, radix, ilen, buf); - str = pic_make_str(pic, buf, s - 1); - - pic_free(pic, buf); + str = pic_str_value(pic, buf, ilen); } else { - struct pic_port *port = pic_open_output_string(pic); + xFILE *file = xfopen_buf(pic, NULL, 0, "w"); + const char *buf; + int len; - xfprintf(pic, port->file, "%f", f); - - str = pic_get_output_string(pic, port); - - pic_close_port(pic, port); + xfprintf(pic, file, "%f", f); + xfget_buf(pic, file, &buf, &len); + str = pic_str_value(pic, buf, len); + xfclose(pic, file); } - return pic_obj_value(str); + return str; } static pic_value @@ -211,9 +261,9 @@ pic_number_string_to_number(pic_state *pic) num = strtol(str, &eptr, radix); if (*eptr == '\0') { - return pic_valid_int(num) - ? pic_int_value((int)num) - : pic_float_value(num); + return INT_MIN <= num && num <= INT_MAX + ? pic_int_value(pic, num) + : pic_float_value(pic, num); } pic_try { @@ -221,46 +271,46 @@ pic_number_string_to_number(pic_state *pic) } pic_catch { /* swallow error */ - flo = pic_false_value(); + flo = pic_false_value(pic); } - if (pic_int_p(flo) || pic_float_p(flo)) { + if (pic_int_p(pic, flo) || pic_float_p(pic, flo)) { return flo; } - return pic_false_value(); + return pic_false_value(pic); } void pic_init_number(pic_state *pic) { - size_t ai = pic_gc_arena_preserve(pic); + size_t ai = pic_enter(pic); pic_defun(pic, "number?", pic_number_number_p); - pic_gc_arena_restore(pic, ai); + pic_leave(pic, ai); pic_defun(pic, "exact?", pic_number_exact_p); pic_defun(pic, "inexact?", pic_number_inexact_p); - pic_gc_arena_restore(pic, ai); + pic_leave(pic, ai); pic_defun(pic, "inexact", pic_number_inexact); pic_defun(pic, "exact", pic_number_exact); - pic_gc_arena_restore(pic, ai); + pic_leave(pic, ai); pic_defun(pic, "=", pic_number_eq); pic_defun(pic, "<", pic_number_lt); pic_defun(pic, ">", pic_number_gt); pic_defun(pic, "<=", pic_number_le); pic_defun(pic, ">=", pic_number_ge); - pic_gc_arena_restore(pic, ai); + pic_leave(pic, ai); pic_defun(pic, "+", pic_number_add); pic_defun(pic, "-", pic_number_sub); pic_defun(pic, "*", pic_number_mul); pic_defun(pic, "/", pic_number_div); - pic_gc_arena_restore(pic, ai); + pic_leave(pic, ai); pic_defun(pic, "number->string", pic_number_number_to_string); pic_defun(pic, "string->number", pic_number_string_to_number); - pic_gc_arena_restore(pic, ai); + pic_leave(pic, ai); } diff --git a/extlib/benz/pair.c b/extlib/benz/pair.c index 6bb698c7..4e7c27b3 100644 --- a/extlib/benz/pair.c +++ b/extlib/benz/pair.c @@ -3,348 +3,55 @@ */ #include "picrin.h" +#include "picrin/extra.h" +#include "picrin/private/object.h" pic_value pic_cons(pic_state *pic, pic_value car, pic_value cdr) { - struct pic_pair *pair; + struct pair *pair; - pair = (struct pic_pair *)pic_obj_alloc(pic, sizeof(struct pic_pair), PIC_TT_PAIR); + pair = (struct pair *)pic_obj_alloc(pic, sizeof(struct pair), PIC_TYPE_PAIR); pair->car = car; pair->cdr = cdr; return pic_obj_value(pair); } +pic_value +pic_car(pic_state *pic, pic_value obj) +{ + if (! pic_pair_p(pic, obj)) { + pic_error(pic, "car: pair required", 1, obj); + } + return pic_pair_ptr(pic, obj)->car; +} + +pic_value +pic_cdr(pic_state *pic, pic_value obj) +{ + if (! pic_pair_p(pic, obj)) { + pic_error(pic, "cdr: pair required", 1, obj); + } + return pic_pair_ptr(pic, obj)->cdr; +} + void pic_set_car(pic_state *pic, pic_value obj, pic_value val) { - struct pic_pair *pair; - - if (! pic_pair_p(obj)) { - pic_errorf(pic, "pair required"); + if (! pic_pair_p(pic, obj)) { + pic_error(pic, "pair required", 0); } - pair = pic_pair_ptr(obj); - - pair->car = val; + pic_pair_ptr(pic, obj)->car = val; } void pic_set_cdr(pic_state *pic, pic_value obj, pic_value val) { - struct pic_pair *pair; - - if (! pic_pair_p(obj)) { - pic_errorf(pic, "pair required"); + if (! pic_pair_p(pic, obj)) { + pic_error(pic, "pair required", 0); } - pair = pic_pair_ptr(obj); - - pair->cdr = val; -} - -bool -pic_list_p(pic_value obj) -{ - pic_value local, rapid; - int i; - - /* Floyd's cycle-finding algorithm. */ - - local = rapid = obj; - while (true) { - - /* advance rapid fast-forward; runs 2x faster than local */ - for (i = 0; i < 2; ++i) { - if (pic_pair_p(rapid)) { - rapid = pic_pair_ptr(rapid)->cdr; - } - else { - return pic_nil_p(rapid); - } - } - - /* advance local */ - local = pic_pair_ptr(local)->cdr; - - if (pic_eq_p(local, rapid)) { - return false; - } - } -} - -pic_value -pic_list1(pic_state *pic, pic_value obj1) -{ - return pic_cons(pic, obj1, pic_nil_value()); -} - -pic_value -pic_list2(pic_state *pic, pic_value obj1, pic_value obj2) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value val; - - val = pic_cons(pic, obj1, pic_list1(pic, obj2)); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, val); - return val; -} - -pic_value -pic_list3(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value val; - - val = pic_cons(pic, obj1, pic_list2(pic, obj2, obj3)); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, val); - return val; -} - -pic_value -pic_list4(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value val; - - val = pic_cons(pic, obj1, pic_list3(pic, obj2, obj3, obj4)); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, val); - return val; -} - -pic_value -pic_list5(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value val; - - val = pic_cons(pic, obj1, pic_list4(pic, obj2, obj3, obj4, obj5)); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, val); - return val; -} - -pic_value -pic_list6(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5, pic_value obj6) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value val; - - val = pic_cons(pic, obj1, pic_list5(pic, obj2, obj3, obj4, obj5, obj6)); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, val); - return val; -} - -pic_value -pic_list7(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5, pic_value obj6, pic_value obj7) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value val; - - val = pic_cons(pic, obj1, pic_list6(pic, obj2, obj3, obj4, obj5, obj6, obj7)); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, val); - return val; -} - -pic_value -pic_list_by_array(pic_state *pic, int c, pic_value *vs) -{ - pic_value v; - - v = pic_nil_value(); - while (c--) { - v = pic_cons(pic, vs[c], v); - } - return v; -} - -pic_value -pic_make_list(pic_state *pic, int k, pic_value fill) -{ - pic_value list; - int i; - - list = pic_nil_value(); - for (i = 0; i < k; ++i) { - list = pic_cons(pic, fill, list); - } - - return list; -} - -int -pic_length(pic_state *pic, pic_value obj) -{ - int c = 0; - - if (! pic_list_p(obj)) { - pic_errorf(pic, "length: expected list, but got ~s", obj); - } - - while (! pic_nil_p(obj)) { - obj = pic_cdr(pic, obj); - ++c; - } - - return c; -} - -pic_value -pic_reverse(pic_state *pic, pic_value list) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value v, acc, it; - - acc = pic_nil_value(); - pic_for_each(v, list, it) { - acc = pic_cons(pic, v, acc); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, acc); - } - return acc; -} - -pic_value -pic_append(pic_state *pic, pic_value xs, pic_value ys) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value x, it; - - xs = pic_reverse(pic, xs); - pic_for_each (x, xs, it) { - ys = pic_cons(pic, x, ys); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, xs); - pic_gc_protect(pic, ys); - } - return ys; -} - -pic_value -pic_memq(pic_state *pic, pic_value key, pic_value list) -{ - enter: - - if (pic_nil_p(list)) - return pic_false_value(); - - if (pic_eq_p(key, pic_car(pic, list))) - return list; - - list = pic_cdr(pic, list); - goto enter; -} - -pic_value -pic_memv(pic_state *pic, pic_value key, pic_value list) -{ - enter: - - if (pic_nil_p(list)) - return pic_false_value(); - - if (pic_eqv_p(key, pic_car(pic, list))) - return list; - - list = pic_cdr(pic, list); - goto enter; -} - -pic_value -pic_member(pic_state *pic, pic_value key, pic_value list, struct pic_proc *compar) -{ - enter: - - if (pic_nil_p(list)) - return pic_false_value(); - - if (compar == NULL) { - if (pic_equal_p(pic, key, pic_car(pic, list))) - return list; - } else { - if (pic_test(pic_apply2(pic, compar, key, pic_car(pic, list)))) - return list; - } - - list = pic_cdr(pic, list); - goto enter; -} - -pic_value -pic_assq(pic_state *pic, pic_value key, pic_value assoc) -{ - pic_value cell; - - enter: - - if (pic_nil_p(assoc)) - return pic_false_value(); - - cell = pic_car(pic, assoc); - if (pic_eq_p(key, pic_car(pic, cell))) - return cell; - - assoc = pic_cdr(pic, assoc); - goto enter; -} - -pic_value -pic_assv(pic_state *pic, pic_value key, pic_value assoc) -{ - pic_value cell; - - enter: - - if (pic_nil_p(assoc)) - return pic_false_value(); - - cell = pic_car(pic, assoc); - if (pic_eqv_p(key, pic_car(pic, cell))) - return cell; - - assoc = pic_cdr(pic, assoc); - goto enter; -} - -pic_value -pic_assoc(pic_state *pic, pic_value key, pic_value assoc, struct pic_proc *compar) -{ - pic_value cell; - - enter: - - if (pic_nil_p(assoc)) - return pic_false_value(); - - cell = pic_car(pic, assoc); - if (compar == NULL) { - if (pic_equal_p(pic, key, pic_car(pic, cell))) - return cell; - } else { - if (pic_test(pic_apply2(pic, compar, key, pic_car(pic, cell)))) - return cell; - } - - assoc = pic_cdr(pic, assoc); - goto enter; -} - -pic_value -pic_acons(pic_state *pic, pic_value key, pic_value val, pic_value assoc) -{ - return pic_cons(pic, pic_cons(pic, key, val), assoc); + pic_pair_ptr(pic, obj)->cdr = val; } pic_value @@ -371,15 +78,73 @@ pic_cddr(pic_state *pic, pic_value v) return pic_cdr(pic, pic_cdr(pic, v)); } -pic_value -pic_list_tail(pic_state *pic, pic_value list, int i) +bool +pic_list_p(pic_state *pic, pic_value obj) { - while (i-- > 0) { - list = pic_cdr(pic, list); + pic_value local, rapid; + int i; + + /* Floyd's cycle-finding algorithm. */ + + local = rapid = obj; + while (true) { + + /* advance rapid fast-forward; runs 2x faster than local */ + for (i = 0; i < 2; ++i) { + if (pic_pair_p(pic, rapid)) { + rapid = pic_pair_ptr(pic, rapid)->cdr; + } + else { + return pic_nil_p(pic, rapid); + } + } + + /* advance local */ + local = pic_pair_ptr(pic, local)->cdr; + + if (pic_eq_p(pic, local, rapid)) { + return false; + } + } +} + +pic_value +pic_make_list(pic_state *pic, int n, pic_value *argv) +{ + pic_value list; + int i; + + list = pic_nil_value(pic); + for (i = n - 1; i >= 0; --i) { + list = pic_cons(pic, argv[i], list); } return list; } +pic_value +pic_list(pic_state *pic, int n, ...) +{ + va_list ap; + pic_value list; + + va_start(ap, n); + list = pic_vlist(pic, n, ap); + va_end(ap); + return list; +} + +pic_value +pic_vlist(pic_state *pic, int n, va_list ap) +{ + pic_value *argv = pic_alloca(pic, sizeof(pic_value) * n); + int i; + + for (i = 0; i < n; ++i) { + argv[i] = va_arg(ap, pic_value); + } + return pic_make_list(pic, n, argv); +} + pic_value pic_list_ref(pic_state *pic, pic_value list, int i) { @@ -389,18 +154,61 @@ pic_list_ref(pic_state *pic, pic_value list, int i) void pic_list_set(pic_state *pic, pic_value list, int i, pic_value obj) { - pic_pair_ptr(pic_list_tail(pic, list, i))->car = obj; + pic_pair_ptr(pic, pic_list_tail(pic, list, i))->car = obj; } pic_value -pic_list_copy(pic_state *pic, pic_value obj) +pic_list_tail(pic_state *pic, pic_value list, int i) { - if (pic_pair_p(obj)) { - return pic_cons(pic, pic_car(pic, obj), pic_list_copy(pic, pic_cdr(pic, obj))); + while (i-- > 0) { + list = pic_cdr(pic, list); } - else { - return obj; + return list; +} + +int +pic_length(pic_state *pic, pic_value obj) +{ + int c = 0; + + while (! pic_nil_p(pic, obj)) { + obj = pic_cdr(pic, obj); + ++c; } + return c; +} + +pic_value +pic_reverse(pic_state *pic, pic_value list) +{ + size_t ai = pic_enter(pic); + pic_value v, acc, it; + + acc = pic_nil_value(pic); + pic_for_each(v, list, it) { + acc = pic_cons(pic, v, acc); + + pic_leave(pic, ai); + pic_protect(pic, acc); + } + return acc; +} + +pic_value +pic_append(pic_state *pic, pic_value xs, pic_value ys) +{ + size_t ai = pic_enter(pic); + pic_value x, it; + + xs = pic_reverse(pic, xs); + pic_for_each (x, xs, it) { + ys = pic_cons(pic, x, ys); + + pic_leave(pic, ai); + pic_protect(pic, xs); + pic_protect(pic, ys); + } + return ys; } static pic_value @@ -410,7 +218,7 @@ pic_pair_pair_p(pic_state *pic) pic_get_args(pic, "o", &v); - return pic_bool_value(pic_pair_p(v)); + return pic_bool_value(pic, pic_pair_p(pic, v)); } static pic_value @@ -492,7 +300,7 @@ pic_pair_set_car(pic_state *pic) pic_set_car(pic, v, w); - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value @@ -504,7 +312,7 @@ pic_pair_set_cdr(pic_state *pic) pic_set_cdr(pic, v, w); - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value @@ -514,7 +322,7 @@ pic_pair_null_p(pic_state *pic) pic_get_args(pic, "o", &v); - return pic_bool_value(pic_nil_p(v)); + return pic_bool_value(pic, pic_nil_p(pic, v)); } static pic_value @@ -524,18 +332,22 @@ pic_pair_list_p(pic_state *pic) pic_get_args(pic, "o", &v); - return pic_bool_value(pic_list_p(v)); + return pic_bool_value(pic, pic_list_p(pic, v)); } static pic_value pic_pair_make_list(pic_state *pic) { - int i; - pic_value fill = pic_undef_value(); + int k, i; + pic_value list, fill = pic_undef_value(pic); - pic_get_args(pic, "i|o", &i, &fill); + pic_get_args(pic, "i|o", &k, &fill); - return pic_make_list(pic, i, fill); + list = pic_nil_value(pic); + for (i = 0; i < k; ++i) { + list = pic_cons(pic, fill, list); + } + return list; } static pic_value @@ -546,7 +358,7 @@ pic_pair_list(pic_state *pic) pic_get_args(pic, "*", &argc, &argv); - return pic_list_by_array(pic, argc, argv); + return pic_make_list(pic, argc, argv); } static pic_value @@ -556,7 +368,7 @@ pic_pair_length(pic_state *pic) pic_get_args(pic, "o", &list); - return pic_int_value(pic_length(pic, list)); + return pic_int_value(pic, pic_length(pic, list)); } static pic_value @@ -568,7 +380,7 @@ pic_pair_append(pic_state *pic) pic_get_args(pic, "*", &argc, &args); if (argc == 0) { - return pic_nil_value(); + return pic_nil_value(pic); } list = args[--argc]; @@ -621,47 +433,63 @@ pic_pair_list_set(pic_state *pic) pic_list_set(pic, list, i, obj); - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value pic_pair_list_copy(pic_state *pic) { - pic_value obj; + pic_value list, head, tail, tmp; - pic_get_args(pic, "o", &obj); + pic_get_args(pic, "o", &list); - return pic_list_copy(pic, obj); + head = tail = pic_nil_value(pic); + + while (pic_pair_p(pic, list)) { + tmp = pic_list(pic, 1, pic_car(pic, list)); + if (! pic_nil_p(pic, tail)) { + pic_set_cdr(pic, tail, tmp); + } + tail = tmp; + if (pic_nil_p(pic, head)) { + head = tail; + } + list = pic_cdr(pic, list); + } + if (pic_nil_p(pic, tail)) { + return list; + } + pic_set_cdr(pic, tail, list); + return head; } static pic_value pic_pair_map(pic_state *pic) { - struct pic_proc *proc; int argc, i; - pic_value *args; - pic_value arg, ret; + pic_value proc, *args, *arg_list, ret; pic_get_args(pic, "l*", &proc, &argc, &args); if (argc == 0) - pic_errorf(pic, "map: wrong number of arguments (1 for at least 2)"); + pic_error(pic, "map: wrong number of arguments (1 for at least 2)", 0); - ret = pic_nil_value(); + arg_list = pic_alloca(pic, sizeof(pic_value) * argc); + + ret = pic_nil_value(pic); do { - arg = pic_nil_value(); for (i = 0; i < argc; ++i) { - if (! pic_pair_p(args[i])) { + if (! pic_pair_p(pic, args[i])) { break; } - pic_push(pic, pic_car(pic, args[i]), arg); + arg_list[i] = pic_car(pic, args[i]); args[i] = pic_cdr(pic, args[i]); } if (i != argc) { break; } - pic_push(pic, pic_apply_list(pic, proc, pic_reverse(pic, arg)), ret); + pic_push(pic, pic_apply(pic, proc, i, arg_list), ret); } while (1); return pic_reverse(pic, ret); @@ -670,29 +498,28 @@ pic_pair_map(pic_state *pic) static pic_value pic_pair_for_each(pic_state *pic) { - struct pic_proc *proc; int argc, i; - pic_value *args; - pic_value arg; + pic_value proc, *args, *arg_list; pic_get_args(pic, "l*", &proc, &argc, &args); + arg_list = pic_alloca(pic, sizeof(pic_value) * argc); + do { - arg = pic_nil_value(); for (i = 0; i < argc; ++i) { - if (! pic_pair_p(args[i])) { + if (! pic_pair_p(pic, args[i])) { break; } - pic_push(pic, pic_car(pic, args[i]), arg); + arg_list[i] = pic_car(pic, args[i]); args[i] = pic_cdr(pic, args[i]); } if (i != argc) { break; } - pic_apply_list(pic, proc, pic_reverse(pic, arg)); + pic_apply(pic, proc, i, arg_list); } while (1); - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value @@ -702,7 +529,13 @@ pic_pair_memq(pic_state *pic) pic_get_args(pic, "oo", &key, &list); - return pic_memq(pic, key, list); + while (! pic_nil_p(pic, list)) { + if (pic_eq_p(pic, key, pic_car(pic, list))) { + return list; + } + list = pic_cdr(pic, list); + } + return pic_false_value(pic); } static pic_value @@ -712,49 +545,90 @@ pic_pair_memv(pic_state *pic) pic_get_args(pic, "oo", &key, &list); - return pic_memv(pic, key, list); + while (! pic_nil_p(pic, list)) { + if (pic_eqv_p(pic, key, pic_car(pic, list))) { + return list; + } + list = pic_cdr(pic, list); + } + return pic_false_value(pic); } static pic_value pic_pair_member(pic_state *pic) { - struct pic_proc *proc = NULL; - pic_value key, list; + pic_value key, list, proc; + int n; - pic_get_args(pic, "oo|l", &key, &list, &proc); + n = pic_get_args(pic, "oo|l", &key, &list, &proc); - return pic_member(pic, key, list, proc); + while (! pic_nil_p(pic, list)) { + if (n == 2) { + if (pic_equal_p(pic, key, pic_car(pic, list))) + return list; + } else { + if (! pic_false_p(pic, pic_call(pic, proc, 2, key, pic_car(pic, list)))) + return list; + } + list = pic_cdr(pic, list); + } + return pic_false_value(pic); } static pic_value pic_pair_assq(pic_state *pic) { - pic_value key, list; + pic_value key, alist, cell; - pic_get_args(pic, "oo", &key, &list); + pic_get_args(pic, "oo", &key, &alist); - return pic_assq(pic, key, list); + while (! pic_nil_p(pic, alist)) { + cell = pic_car(pic, alist); + if (pic_eq_p(pic, key, pic_car(pic, cell))) { + return cell; + } + alist = pic_cdr(pic, alist); + } + return pic_false_value(pic); } static pic_value pic_pair_assv(pic_state *pic) { - pic_value key, list; + pic_value key, alist, cell; - pic_get_args(pic, "oo", &key, &list); + pic_get_args(pic, "oo", &key, &alist); - return pic_assv(pic, key, list); + while (! pic_nil_p(pic, alist)) { + cell = pic_car(pic, alist); + if (pic_eqv_p(pic, key, pic_car(pic, cell))) { + return cell; + } + alist = pic_cdr(pic, alist); + } + return pic_false_value(pic); } static pic_value pic_pair_assoc(pic_state *pic) { - struct pic_proc *proc = NULL; - pic_value key, list; + pic_value key, alist, proc, cell; + int n; - pic_get_args(pic, "oo|l", &key, &list, &proc); + n = pic_get_args(pic, "oo|l", &key, &alist, &proc); - return pic_assoc(pic, key, list, proc); + while (! pic_nil_p(pic, alist)) { + cell = pic_car(pic, alist); + if (n == 2) { + if (pic_equal_p(pic, key, pic_car(pic, cell))) + return cell; + } else { + if (! pic_false_p(pic, pic_call(pic, proc, 2, key, pic_car(pic, cell)))) + return cell; + } + alist = pic_cdr(pic, alist); + } + return pic_false_value(pic); } void diff --git a/extlib/benz/port.c b/extlib/benz/port.c index e1056aba..f4d80092 100644 --- a/extlib/benz/port.c +++ b/extlib/benz/port.c @@ -3,340 +3,41 @@ */ #include "picrin.h" +#include "picrin/extra.h" +#include "picrin/private/object.h" +#include "picrin/private/file.h" + +#undef EOF +#define EOF (-1) pic_value -pic_eof_object() +pic_open_port(pic_state *pic, xFILE *file) { - pic_value v; + struct port *port; - pic_init_value(v, PIC_VTYPE_EOF); - - return v; -} - -static pic_value -pic_assert_port(pic_state *pic) -{ - struct pic_port *port; - - pic_get_args(pic, "p", &port); + port = (struct port *)pic_obj_alloc(pic, sizeof(struct port), PIC_TYPE_PORT); + port->file = file; return pic_obj_value(port); } -/* current-(input|output|error)-port */ - -#if PIC_ENABLE_STDIO - -static int -file_read(pic_state PIC_UNUSED(*pic), void *cookie, char *ptr, int size) { - FILE *file = cookie; - int r; - - size = 1; /* override size */ - - r = (int)fread(ptr, 1, (size_t)size, file); - if (r < size && ferror(file)) { - return -1; - } - if (r == 0 && feof(file)) { - clearerr(file); - } - return r; -} - -static int -file_write(pic_state PIC_UNUSED(*pic), void *cookie, const char *ptr, int size) { - FILE *file = cookie; - int r; - - r = (int)fwrite(ptr, 1, (size_t)size, file); - if (r < size) { - return -1; - } - fflush(cookie); - return r; -} - -static long -file_seek(pic_state PIC_UNUSED(*pic), void *cookie, long pos, int whence) { - switch (whence) { - case XSEEK_CUR: - whence = SEEK_CUR; - break; - case XSEEK_SET: - whence = SEEK_SET; - break; - case XSEEK_END: - whence = SEEK_END; - break; - } - if (fseek(cookie, pos, whence) == 0) { - return ftell(cookie); - } - return -1; -} - -static int -file_close(pic_state PIC_UNUSED(*pic), void *cookie) { - return fclose(cookie); -} - -static xFILE * -file_open(pic_state *pic, const char *name, const char *mode) { - FILE *fp; - - if ((fp = fopen(name, mode)) == NULL) { - return NULL; - } - - switch (*mode) { - case 'r': - return xfunopen(pic, fp, file_read, NULL, file_seek, file_close); - default: - return xfunopen(pic, fp, NULL, file_write, file_seek, file_close); - } -} - -PIC_NORETURN static void -file_error(pic_state *pic, const char *msg) +xFILE * +pic_fileno(pic_state *PIC_UNUSED(pic), pic_value port) { - struct pic_error *e; - - e = pic_make_error(pic, pic_intern_lit(pic, "file"), msg, pic_nil_value()); - - pic_raise(pic, pic_obj_value(e)); -} - -struct pic_port * -pic_open_file(pic_state *pic, const char *name, int flags) { - struct pic_port *port; - xFILE *file; - char mode = 'r'; - - if ((flags & PIC_PORT_IN) == 0) { - mode = 'w'; - } - if ((file = file_open(pic, name, &mode)) == NULL) { - file_error(pic, pic_str_cstr(pic, pic_format(pic, "could not open file '%s'", name))); - } - - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); - port->file = file; - port->flags = flags | PIC_PORT_OPEN; - - return port; -} - -#else - -/* null file */ - -static int -null_read(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie), char PIC_UNUSED(*ptr), int PIC_UNUSED(size)) { - return 0; -} - -static int -null_write(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie), const char PIC_UNUSED(*ptr), int size) { - return size; -} - -static long -null_seek(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie), long PIC_UNUSED(pos), int PIC_UNUSED(whence)) { - return 0; -} - -static int -null_close(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie)) { - return 0; -} - -#endif - -static void -pic_define_standard_port(pic_state *pic, const char *name, xFILE *file, int dir) -{ - struct pic_port *port; - - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); - port->file = file; - port->flags = dir | PIC_PORT_TEXT | PIC_PORT_OPEN; - - pic_defvar(pic, name, pic_obj_value(port), pic_make_proc(pic, pic_assert_port)); -} - -#define DEFINE_STANDARD_PORT_ACCESSOR(name, var) \ - struct pic_port * \ - name(pic_state *pic) \ - { \ - pic_value obj; \ - \ - obj = pic_funcall0(pic, pic->PICRIN_BASE, var); \ - \ - return pic_port_ptr(obj); \ - } - -DEFINE_STANDARD_PORT_ACCESSOR(pic_stdin, "current-input-port") -DEFINE_STANDARD_PORT_ACCESSOR(pic_stdout, "current-output-port") -DEFINE_STANDARD_PORT_ACCESSOR(pic_stderr, "current-error-port") - -struct strfile { - char *buf; - long pos, end, capa; -}; - -static int -string_read(pic_state PIC_UNUSED(*pic), void *cookie, char *ptr, int size) -{ - struct strfile *m = cookie; - - if (size > (int)(m->end - m->pos)) - size = (int)(m->end - m->pos); - memcpy(ptr, m->buf + m->pos, size); - m->pos += size; - return size; -} - -static int -string_write(pic_state *pic, void *cookie, const char *ptr, int size) -{ - struct strfile *m = cookie; - - if (m->pos + size >= m->capa) { - m->capa = (m->pos + size) * 2; - m->buf = pic_realloc(pic, m->buf, m->capa); - } - memcpy(m->buf + m->pos, ptr, size); - m->pos += size; - if (m->end < m->pos) - m->end = m->pos; - return size; -} - -static long -string_seek(pic_state PIC_UNUSED(*pic), void *cookie, long pos, int whence) -{ - struct strfile *m = cookie; - - switch (whence) { - case XSEEK_SET: - m->pos = pos; - break; - case XSEEK_CUR: - m->pos += pos; - break; - case XSEEK_END: - m->pos = m->end + pos; - break; - } - - return m->pos; -} - -static int -string_close(pic_state *pic, void *cookie) -{ - struct strfile *m = cookie; - - pic_free(pic, m->buf); - pic_free(pic, m); - return 0; -} - -static xFILE * -string_open(pic_state *pic, const char *data, size_t size) -{ - struct strfile *m; - xFILE *file; - - m = pic_malloc(pic, sizeof(struct strfile)); - m->buf = pic_malloc(pic, size); - m->pos = 0; - m->end = size; - m->capa = size; - - - if (data != NULL) { - memcpy(m->buf, data, size); - file = xfunopen(pic, m, string_read, NULL, string_seek, string_close); - } else { - file = xfunopen(pic, m, NULL, string_write, string_seek, string_close); - } - - if (file == NULL) { - string_close(pic, m); - pic_error(pic, "could not open new output string/bytevector port", pic_nil_value()); - } - return file; -} - -struct pic_port * -pic_open_input_string(pic_state *pic, const char *str) -{ - struct pic_port *port; - - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); - port->file = string_open(pic, str, strlen(str)); - port->flags = PIC_PORT_IN | PIC_PORT_TEXT | PIC_PORT_OPEN; - - return port; -} - -struct pic_port * -pic_open_output_string(pic_state *pic) -{ - struct pic_port *port; - - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); - port->file = string_open(pic, NULL, 0); - port->flags = PIC_PORT_OUT | PIC_PORT_TEXT | PIC_PORT_OPEN; - - return port; -} - -struct pic_string * -pic_get_output_string(pic_state *pic, struct pic_port *port) -{ - struct strfile *s; - - if (port->file->vtable.write != string_write) { - pic_errorf(pic, "get-output-string: port is not made by open-output-string"); - } - - xfflush(pic, port->file); - - s = port->file->vtable.cookie; - - return pic_make_str(pic, s->buf, s->end); + return pic_port_ptr(pic, port)->file; } void -pic_close_port(pic_state *pic, struct pic_port *port) +pic_close_port(pic_state *pic, pic_value port) { - if ((port->flags & PIC_PORT_OPEN) == 0) { + xFILE *file = pic_fileno(pic, port); + + if (file->flag == 0) { return; } - if (xfclose(pic, port->file) == EOF) { - pic_errorf(pic, "close-port: failure"); + if (xfclose(pic, file) == EOF) { + pic_error(pic, "close-port: failure", 0); } - port->flags &= ~PIC_PORT_OPEN; -} - -static pic_value -pic_port_call_with_port(pic_state *pic) -{ - struct pic_port *port; - struct pic_proc *proc; - pic_value value; - - pic_get_args(pic, "pl", &port, &proc); - - value = pic_apply1(pic, proc, pic_obj_value(port)); - - pic_close_port(pic, port); - - return value; } static pic_value @@ -346,11 +47,10 @@ pic_port_input_port_p(pic_state *pic) pic_get_args(pic, "o", &v); - if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_IN) != 0) { - return pic_true_value(); - } - else { - return pic_false_value(); + if (pic_port_p(pic, v) && (pic_fileno(pic, v)->flag & X_READ) != 0) { + return pic_true_value(pic); + } else { + return pic_false_value(pic); } } @@ -361,41 +61,11 @@ pic_port_output_port_p(pic_state *pic) pic_get_args(pic, "o", &v); - if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_OUT) != 0) { - return pic_true_value(); + if (pic_port_p(pic, v) && (pic_fileno(pic, v)->flag & X_WRITE) != 0) { + return pic_true_value(pic); } else { - return pic_false_value(); - } -} - -static pic_value -pic_port_textual_port_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_TEXT) != 0) { - return pic_true_value(); - } - else { - return pic_false_value(); - } -} - -static pic_value -pic_port_binary_port_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_BINARY) != 0) { - return pic_true_value(); - } - else { - return pic_false_value(); + return pic_false_value(pic); } } @@ -406,7 +76,7 @@ pic_port_port_p(pic_state *pic) pic_get_args(pic, "o", &v); - return pic_bool_value(pic_port_p(v)); + return pic_bool_value(pic, pic_port_p(pic, v)); } static pic_value @@ -416,12 +86,7 @@ pic_port_eof_object_p(pic_state *pic) pic_get_args(pic, "o", &v); - if (pic_vtype(v) == PIC_VTYPE_EOF) { - return pic_true_value(); - } - else { - return pic_false_value(); - } + return pic_bool_value(pic, pic_eof_p(pic, v)); } static pic_value @@ -429,532 +94,277 @@ pic_port_eof_object(pic_state *pic) { pic_get_args(pic, ""); - return pic_eof_object(); + return pic_eof_object(pic); } static pic_value pic_port_port_open_p(pic_state *pic) { - struct pic_port *port; + pic_value port; pic_get_args(pic, "p", &port); - return pic_bool_value(port->flags & PIC_PORT_OPEN); + return pic_bool_value(pic, pic_fileno(pic, port)->flag != 0); } static pic_value pic_port_close_port(pic_state *pic) { - struct pic_port *port; + pic_value port; pic_get_args(pic, "p", &port); pic_close_port(pic, port); - return pic_undef_value(); + return pic_undef_value(pic); } -#define assert_port_profile(port, flgs, caller) do { \ - if ((port->flags & (flgs)) != (flgs)) { \ - switch (flgs) { \ - case PIC_PORT_IN: \ - pic_errorf(pic, caller ": expected output port"); \ - case PIC_PORT_OUT: \ - pic_errorf(pic, caller ": expected input port"); \ - case PIC_PORT_IN | PIC_PORT_TEXT: \ - pic_errorf(pic, caller ": expected input/textual port"); \ - case PIC_PORT_IN | PIC_PORT_BINARY: \ - pic_errorf(pic, caller ": expected input/binary port"); \ - case PIC_PORT_OUT | PIC_PORT_TEXT: \ - pic_errorf(pic, caller ": expected output/textual port"); \ - case PIC_PORT_OUT | PIC_PORT_BINARY: \ - pic_errorf(pic, caller ": expected output/binary port"); \ +#define assert_port_profile(port, flags, caller) do { \ + if ((pic_fileno(pic, port)->flag & (flags)) != (flags)) { \ + switch (flags) { \ + case X_WRITE: \ + pic_error(pic, caller ": output port required", 0); \ + case X_READ: \ + pic_error(pic, caller ": input port required", 0); \ } \ } \ - if ((port->flags & PIC_PORT_OPEN) == 0) { \ - pic_errorf(pic, caller ": expected open port"); \ + if (pic_fileno(pic, port)->flag == 0) { \ + pic_error(pic, caller ": open port required", 0); \ } \ } while (0) static pic_value -pic_port_open_input_string(pic_state *pic) +pic_port_open_input_bytevector(pic_state *pic) { - struct pic_port *port; - char *str; + unsigned char *buf; + int len; - pic_get_args(pic, "z", &str); + pic_get_args(pic, "b", &buf, &len); - port = pic_open_input_string(pic, str); - - return pic_obj_value(port); -} - -static pic_value -pic_port_open_output_string(pic_state *pic) -{ - struct pic_port *port; - - pic_get_args(pic, ""); - - port = pic_open_output_string(pic); - - return pic_obj_value(port); -} - -static pic_value -pic_port_get_output_string(pic_state *pic) -{ - struct pic_port *port = pic_stdout(pic); - - pic_get_args(pic, "|p", &port); - - assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, "get-output-string"); - - return pic_obj_value(pic_get_output_string(pic, port)); -} - -static pic_value -pic_port_open_input_blob(pic_state *pic) -{ - struct pic_port *port; - struct pic_blob *blob; - - pic_get_args(pic, "b", &blob); - - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); - port->file = string_open(pic, (const char *)blob->data, blob->len); - port->flags = PIC_PORT_IN | PIC_PORT_BINARY | PIC_PORT_OPEN; - - return pic_obj_value(port); + return pic_open_port(pic, xfopen_buf(pic, (char *)buf, len, "r")); } static pic_value pic_port_open_output_bytevector(pic_state *pic) { - struct pic_port *port; - pic_get_args(pic, ""); - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); - port->file = string_open(pic, NULL, 0); - port->flags = PIC_PORT_OUT | PIC_PORT_BINARY | PIC_PORT_OPEN; - - return pic_obj_value(port); + return pic_open_port(pic, xfopen_buf(pic, NULL, 0, "w")); } static pic_value pic_port_get_output_bytevector(pic_state *pic) { - struct pic_port *port = pic_stdout(pic); - pic_blob *blob; - struct strfile *s; + pic_value port = pic_stdout(pic); + const char *buf; + int len; pic_get_args(pic, "|p", &port); - assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, "get-output-bytevector"); + assert_port_profile(port, X_WRITE, "get-output-bytevector"); - if (port->file->vtable.write != string_write) { - pic_errorf(pic, "get-output-bytevector: port is not made by open-output-bytevector"); + if (xfget_buf(pic, pic_fileno(pic, port), &buf, &len) < 0) { + pic_error(pic, "port was not created by open-output-bytevector", 0); } - - xfflush(pic, port->file); - - s = port->file->vtable.cookie; - - blob = pic_make_blob(pic, s->end); - memcpy(blob->data, s->buf, s->end); - - return pic_obj_value(blob); + return pic_blob_value(pic, (unsigned char *)buf, len); } static pic_value -pic_port_read_char(pic_state *pic) +pic_port_read_u8(pic_state *pic){ + pic_value port = pic_stdin(pic); + int c; + pic_get_args(pic, "|p", &port); + + assert_port_profile(port, X_READ, "read-u8"); + if ((c = xfgetc(pic, pic_fileno(pic, port))) == EOF) { + return pic_eof_object(pic); + } + + return pic_int_value(pic, c); +} + +static pic_value +pic_port_peek_u8(pic_state *pic) { int c; - struct pic_port *port = pic_stdin(pic); + pic_value port = pic_stdin(pic); pic_get_args(pic, "|p", &port); - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, "read-char"); + assert_port_profile(port, X_READ, "peek-u8"); - if ((c = xfgetc(pic, port->file)) == EOF) { - return pic_eof_object(); - } - else { - return pic_char_value((char)c); - } -} - -static pic_value -pic_port_peek_char(pic_state *pic) -{ - int c; - struct pic_port *port = pic_stdin(pic); - - pic_get_args(pic, "|p", &port); - - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, "peek-char"); - - if ((c = xfgetc(pic, port->file)) == EOF) { - return pic_eof_object(); - } - else { - xungetc(c, port->file); - return pic_char_value((char)c); - } -} - -static pic_value -pic_port_read_line(pic_state *pic) -{ - int c; - struct pic_port *port = pic_stdin(pic), *buf; - struct pic_string *str; - pic_value res = pic_eof_object(); - - pic_get_args(pic, "|p", &port); - - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, "read-line"); - - buf = pic_open_output_string(pic); - while ((c = xfgetc(pic, port->file)) != EOF && c != '\n') { - xfputc(pic, c, buf->file); - } - - str = pic_get_output_string(pic, buf); - if (pic_str_len(str) == 0 && c == EOF) { - /* EOF */ - } else { - res = pic_obj_value(str); - } - pic_close_port(pic, buf); - return res; -} - -static pic_value -pic_port_char_ready_p(pic_state *pic) -{ - struct pic_port *port = pic_stdin(pic); - - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, "char-ready?"); - - pic_get_args(pic, "|p", &port); - - return pic_true_value(); /* FIXME: always returns #t */ -} - -static pic_value -pic_port_read_string(pic_state *pic){ - struct pic_port *port = pic_stdin(pic), *buf; - pic_str *str; - int k, i; - int c; - pic_value res = pic_eof_object(); - - pic_get_args(pic, "i|p", &k, &port); - - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, "read-stritg"); - - c = EOF; - buf = pic_open_output_string(pic); - for(i = 0; i < k; ++i) { - if((c = xfgetc(pic, port->file)) == EOF){ - break; - } - xfputc(pic, c, buf->file); - } - - str = pic_get_output_string(pic, buf); - if (pic_str_len(str) == 0 && c == EOF) { - /* EOF */ - } else { - res = pic_obj_value(str); - } - pic_close_port(pic, buf); - return res; -} - -static pic_value -pic_port_read_byte(pic_state *pic){ - struct pic_port *port = pic_stdin(pic); - int c; - pic_get_args(pic, "|p", &port); - - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, "read-u8"); - if ((c = xfgetc(pic, port->file)) == EOF) { - return pic_eof_object(); - } - - return pic_int_value(c); -} - -static pic_value -pic_port_peek_byte(pic_state *pic) -{ - int c; - struct pic_port *port = pic_stdin(pic); - - pic_get_args(pic, "|p", &port); - - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, "peek-u8"); - - c = xfgetc(pic, port->file); + c = xfgetc(pic, pic_fileno(pic, port)); if (c == EOF) { - return pic_eof_object(); + return pic_eof_object(pic); } else { - xungetc(c, port->file); - return pic_int_value(c); + xungetc(pic, c, pic_fileno(pic, port)); + return pic_int_value(pic, c); } } static pic_value -pic_port_byte_ready_p(pic_state *pic) +pic_port_u8_ready_p(pic_state *pic) { - struct pic_port *port = pic_stdin(pic); + pic_value port = pic_stdin(pic); pic_get_args(pic, "|p", &port); - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, "u8-ready?"); + assert_port_profile(port, X_READ, "u8-ready?"); - return pic_true_value(); /* FIXME: always returns #t */ + return pic_true_value(pic); /* FIXME: always returns #t */ } static pic_value -pic_port_read_blob(pic_state *pic) +pic_port_read_bytevector(pic_state *pic) { - struct pic_port *port = pic_stdin(pic); - pic_blob *blob; + pic_value port = pic_stdin(pic); + unsigned char *buf; int k, i; pic_get_args(pic, "i|p", &k, &port); - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, "read-bytevector"); + assert_port_profile(port, X_READ, "read-bytevector"); - blob = pic_make_blob(pic, k); + buf = pic_blob(pic, pic_blob_value(pic, NULL, k), NULL); - i = xfread(pic, blob->data, sizeof(char), k, port->file); + i = xfread(pic, buf, sizeof(char), k, pic_fileno(pic, port)); if (i == 0) { - return pic_eof_object(); - } - else { - pic_realloc(pic, blob->data, i); - blob->len = i; - return pic_obj_value(blob); + return pic_eof_object(pic); } + return pic_blob_value(pic, buf, i); } static pic_value -pic_port_read_blob_ip(pic_state *pic) +pic_port_read_bytevector_ip(pic_state *pic) { - struct pic_port *port; - struct pic_blob *bv; - char *buf; + pic_value port; + unsigned char *buf; int n, start, end, i, len; - n = pic_get_args(pic, "b|pii", &bv, &port, &start, &end); + n = pic_get_args(pic, "b|pii", &buf, &len, &port, &start, &end); + switch (n) { case 1: port = pic_stdin(pic); case 2: start = 0; case 3: - end = bv->len; + end = len; } - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, "read-bytevector!"); - - if (end < start) { - pic_errorf(pic, "read-bytevector!: end index must be greater than or equal to start index"); - } - - len = end - start; - - buf = pic_calloc(pic, len, sizeof(char)); - i = xfread(pic, buf, sizeof(char), len, port->file); - memcpy(bv->data + start, buf, i); - pic_free(pic, buf); + VALID_RANGE(pic, len, start, end); + assert_port_profile(port, X_READ, "read-bytevector!"); + i = xfread(pic, buf + start, 1, end - start, pic_fileno(pic, port)); if (i == 0) { - return pic_eof_object(); - } - else { - return pic_int_value(i); + return pic_eof_object(pic); } + return pic_int_value(pic, i); } static pic_value -pic_port_newline(pic_state *pic) -{ - struct pic_port *port = pic_stdout(pic); - - pic_get_args(pic, "|p", &port); - - assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, "newline"); - - xfputs(pic, "\n", port->file); - return pic_undef_value(); -} - -static pic_value -pic_port_write_char(pic_state *pic) -{ - char c; - struct pic_port *port = pic_stdout(pic); - - pic_get_args(pic, "c|p", &c, &port); - - assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, "write-char"); - - xfputc(pic, c, port->file); - return pic_undef_value(); -} - -static pic_value -pic_port_write_string(pic_state *pic) -{ - char *str; - struct pic_port *port; - int start, end, n, i; - - n = pic_get_args(pic, "z|pii", &str, &port, &start, &end); - switch (n) { - case 1: - port = pic_stdout(pic); - case 2: - start = 0; - case 3: - end = INT_MAX; - } - - assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, "write-string"); - - for (i = start; i < end && str[i] != '\0'; ++i) { - xfputc(pic, str[i], port->file); - } - return pic_undef_value(); -} - -static pic_value -pic_port_write_byte(pic_state *pic) +pic_port_write_u8(pic_state *pic) { int i; - struct pic_port *port = pic_stdout(pic); + pic_value port = pic_stdout(pic); pic_get_args(pic, "i|p", &i, &port); - assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, "write-u8"); + assert_port_profile(port, X_WRITE, "write-u8"); - xfputc(pic, i, port->file); - return pic_undef_value(); + xfputc(pic, i, pic_fileno(pic, port)); + return pic_undef_value(pic); } static pic_value -pic_port_write_blob(pic_state *pic) +pic_port_write_bytevector(pic_state *pic) { - struct pic_blob *blob; - struct pic_port *port; - int n, start, end, i; + pic_value port; + unsigned char *buf; + int n, start, end, len, done; + + n = pic_get_args(pic, "b|pii", &buf, &len, &port, &start, &end); - n = pic_get_args(pic, "b|pii", &blob, &port, &start, &end); switch (n) { case 1: port = pic_stdout(pic); case 2: start = 0; case 3: - end = blob->len; + end = len; } - assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, "write-bytevector"); + VALID_RANGE(pic, len, start, end); + assert_port_profile(port, X_WRITE, "write-bytevector"); - for (i = start; i < end; ++i) { - xfputc(pic, blob->data[i], port->file); + done = 0; + while (done < end - start) { + done += xfwrite(pic, buf + start + done, 1, end - start - done, pic_fileno(pic, port)); + /* FIXME: error check... */ } - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value pic_port_flush(pic_state *pic) { - struct pic_port *port = pic_stdout(pic); + pic_value port = pic_stdout(pic); pic_get_args(pic, "|p", &port); - assert_port_profile(port, PIC_PORT_OUT, "flush-output-port"); + assert_port_profile(port, X_WRITE, "flush-output-port"); - xfflush(pic, port->file); - return pic_undef_value(); + xfflush(pic, pic_fileno(pic, port)); + return pic_undef_value(pic); } +static pic_value +coerce_port(pic_state *pic) +{ + pic_value port; + + pic_get_args(pic, "p", &port); + + return port; +} + +#define DEFINE_PORT(pic, name, file) \ + pic_defvar(pic, name, pic_open_port(pic, file), coerce) + void pic_init_port(pic_state *pic) { -#if PIC_ENABLE_STDIO -# define FILE_VTABLE { 0, file_read, file_write, file_seek, file_close } -#else -# define FILE_VTABLE { 0, null_read, null_write, null_seek, null_close } -#endif + pic_value coerce = pic_lambda(pic, coerce_port, 0); - static const xFILE skel[3] = { - { { 0 }, 0, NULL, NULL, FILE_VTABLE, X_READ }, - { { 0 }, 0, NULL, NULL, FILE_VTABLE, X_WRITE | X_LNBUF }, - { { 0 }, 0, NULL, NULL, FILE_VTABLE, X_WRITE | X_UNBUF } - }; - - pic->files[0] = skel[0]; - pic->files[1] = skel[1]; - pic->files[2] = skel[2]; - -#if PIC_ENABLE_STDIO - pic->files[0].vtable.cookie = stdin; - pic->files[1].vtable.cookie = stdout; - pic->files[2].vtable.cookie = stderr; -#endif - - pic_define_standard_port(pic, "current-input-port", xstdin, PIC_PORT_IN); - pic_define_standard_port(pic, "current-output-port", xstdout, PIC_PORT_OUT); - pic_define_standard_port(pic, "current-error-port", xstderr, PIC_PORT_OUT); - - pic_defun(pic, "call-with-port", pic_port_call_with_port); + DEFINE_PORT(pic, "current-input-port", xstdin); + DEFINE_PORT(pic, "current-output-port", xstdout); + DEFINE_PORT(pic, "current-error-port", xstderr); + pic_defun(pic, "port?", pic_port_port_p); pic_defun(pic, "input-port?", pic_port_input_port_p); pic_defun(pic, "output-port?", pic_port_output_port_p); - pic_defun(pic, "textual-port?", pic_port_textual_port_p); - pic_defun(pic, "binary-port?", pic_port_binary_port_p); - pic_defun(pic, "port?", pic_port_port_p); - pic_defun(pic, "port-open?", pic_port_port_open_p); pic_defun(pic, "close-port", pic_port_close_port); - /* string I/O */ - pic_defun(pic, "open-input-string", pic_port_open_input_string); - pic_defun(pic, "open-output-string", pic_port_open_output_string); - pic_defun(pic, "get-output-string", pic_port_get_output_string); - pic_defun(pic, "open-input-bytevector", pic_port_open_input_blob); - pic_defun(pic, "open-output-bytevector", pic_port_open_output_bytevector); - pic_defun(pic, "get-output-bytevector", pic_port_get_output_bytevector); - - /* input */ - pic_defun(pic, "read-char", pic_port_read_char); - pic_defun(pic, "peek-char", pic_port_peek_char); - pic_defun(pic, "read-line", pic_port_read_line); pic_defun(pic, "eof-object?", pic_port_eof_object_p); pic_defun(pic, "eof-object", pic_port_eof_object); - pic_defun(pic, "char-ready?", pic_port_char_ready_p); - pic_defun(pic, "read-string", pic_port_read_string); - pic_defun(pic, "read-u8", pic_port_read_byte); - pic_defun(pic, "peek-u8", pic_port_peek_byte); - pic_defun(pic, "u8-ready?", pic_port_byte_ready_p); - pic_defun(pic, "read-bytevector", pic_port_read_blob); - pic_defun(pic, "read-bytevector!", pic_port_read_blob_ip); + + /* input */ + pic_defun(pic, "read-u8", pic_port_read_u8); + pic_defun(pic, "peek-u8", pic_port_peek_u8); + pic_defun(pic, "u8-ready?", pic_port_u8_ready_p); + pic_defun(pic, "read-bytevector", pic_port_read_bytevector); + pic_defun(pic, "read-bytevector!", pic_port_read_bytevector_ip); /* output */ - pic_defun(pic, "newline", pic_port_newline); - pic_defun(pic, "write-char", pic_port_write_char); - pic_defun(pic, "write-string", pic_port_write_string); - pic_defun(pic, "write-u8", pic_port_write_byte); - pic_defun(pic, "write-bytevector", pic_port_write_blob); + pic_defun(pic, "write-u8", pic_port_write_u8); + pic_defun(pic, "write-bytevector", pic_port_write_bytevector); pic_defun(pic, "flush-output-port", pic_port_flush); + + /* string I/O */ + pic_defun(pic, "open-input-bytevector", pic_port_open_input_bytevector); + pic_defun(pic, "open-output-bytevector", pic_port_open_output_bytevector); + pic_defun(pic, "get-output-bytevector", pic_port_get_output_bytevector); } diff --git a/extlib/benz/proc.c b/extlib/benz/proc.c index 2f3aa9ba..66061ade 100644 --- a/extlib/benz/proc.c +++ b/extlib/benz/proc.c @@ -3,10 +3,23 @@ */ #include "picrin.h" -#include "picrin/opcode.h" +#include "picrin/extra.h" +#include "picrin/private/object.h" +#include "picrin/private/vm.h" +#include "picrin/private/state.h" #define MIN(x,y) ((x) < (y) ? (x) : (y)) +PIC_NORETURN static void +arg_error(pic_state *pic, int actual, bool varg, int expected) +{ + const char *msg; + + msg = pic_str(pic, pic_strf_value(pic, "wrong number of arguments (%d for %s%d)", actual, (varg ? "at least " : ""), expected)); + + pic_error(pic, msg, 0); +} + #define GET_OPERAND(pic,n) ((pic)->ci->fp[(n)]) /** @@ -19,66 +32,76 @@ * F double *, bool * float with exactness * c char * char * z char ** c string - * s pic_str ** string object - * m pic_sym ** symbol - * v pic_vec ** vector object - * b pic_blob ** bytevector object - * l struct pic_proc ** lambda object - * p struct pic_port ** port object - * d struct pic_dict ** dictionary object - * e struct pic_error ** error object - * r struct pic_record ** record object + * b unsigned char *, int * bytevector + * u void **, const pic_data_type * user data type + * m pic_value * symbol + * v pic_value * vector + * s pic_value * string + * l pic_value * lambda + * p pic_value * port + * d pic_value * dictionary + * r pic_value * record * + * + aliasing operator * | optional operator - * * int *, pic_value ** variable length operator + * * int *, pic_value ** variable length operator + * ---- ---- ---- */ int pic_get_args(pic_state *pic, const char *format, ...) { char c; + const char *p = format; int paramc = 0, optc = 0; int i, argc = pic->ci->argc - 1; va_list ap; - bool proc = false, rest = false, opt = false; + bool proc = 0, rest = 0, opt = 0; /* parse format */ - if ((c = *format) != '\0') { + if ((c = *p) != '\0') { if (c == '&') { - proc = true; - format++; /* forget about '&' */ + proc = 1; + p++; } - for (paramc = 0, c = *format; c; c = format[++paramc]) { + while ((c = *p++) != '\0') { + if (c == '+') + continue; if (c == '|') { - opt = true; - break; + opt = 1; break; } else if (c == '*') { - rest = true; - break; + rest = 1; break; + } + paramc++; + } + if (opt) { + while ((c = *p++) != '\0') { + if (c == '+') + continue; + if (c == '*') { + rest = 1; break; + } + optc++; } } - for (optc = 0; opt && c; c = format[paramc + opt + ++optc]) { - if (c == '*') { - rest = true; - break; - } - } - assert((opt ? 1 : 0) <= optc); /* at least 1 char after '|'? */ - assert(format[paramc + opt + optc + rest] == '\0'); /* no extra chars? */ + if (rest) c = *p++; + assert(opt <= optc); /* at least 1 char after '|'? */ + assert(c == '\0'); /* no extra chars? */ } if (argc < paramc || (paramc + optc < argc && ! rest)) { - pic_errorf(pic, "pic_get_args: wrong number of arguments (%d for %s%d)", argc, rest? "at least " : "", paramc); + arg_error(pic, argc, rest, paramc); } va_start(ap, format); /* dispatch */ if (proc) { - struct pic_proc **proc; + pic_value *proc; - proc = va_arg(ap, struct pic_proc **); - *proc = pic_proc_ptr(GET_OPERAND(pic, 0)); + proc = va_arg(ap, pic_value *); + *proc = GET_OPERAND(pic, 0); + format++; /* skip '&' */ } for (i = 1; i <= MIN(paramc + optc, argc); ++i) { @@ -96,6 +119,43 @@ pic_get_args(pic_state *pic, const char *format, ...) break; } + case 'u': { + void **data; + const pic_data_type *type; + pic_value v; + + data = va_arg(ap, void **); + type = va_arg(ap, const pic_data_type *); + v = GET_OPERAND(pic, i); + if (pic_data_p(pic, v, type)) { + *data = pic_data(pic, v); + } + else { + const char *msg; + msg = pic_str(pic, pic_strf_value(pic, "pic_get_args: data type \"%s\" required", type->type_name)); + pic_error(pic, msg, 1, v); + } + break; + } + + case 'b': { + unsigned char **buf; + int *len; + pic_value v; + + buf = va_arg(ap, unsigned char **); + len = va_arg(ap, int *); + v = GET_OPERAND(pic, i); + if (pic_blob_p(pic, v)) { + unsigned char *tmp = pic_blob(pic, v, len); + if (buf) *buf = tmp; + } + else { + pic_error(pic, "pic_get_args: bytevector required", 1, v); + } + break; + } + #define NUM_CASE(c1, c2, ctype) \ case c1: case c2: { \ ctype *n; \ @@ -106,17 +166,17 @@ pic_get_args(pic_state *pic, const char *format, ...) e = (c == c2 ? va_arg(ap, bool *) : &dummy); \ \ v = GET_OPERAND(pic, i); \ - switch (pic_type(v)) { \ - case PIC_TT_FLOAT: \ - *n = pic_float(v); \ + switch (pic_type(pic, v)) { \ + case PIC_TYPE_FLOAT: \ + *n = pic_float(pic, v); \ *e = false; \ break; \ - case PIC_TT_INT: \ - *n = pic_int(v); \ + case PIC_TYPE_INT: \ + *n = pic_int(pic, v); \ *e = true; \ break; \ default: \ - pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v); \ + pic_error(pic, "pic_get_args: float or int required", 1, v); \ } \ break; \ } @@ -131,33 +191,36 @@ pic_get_args(pic_state *pic, const char *format, ...) \ ptr = va_arg(ap, ctype *); \ v = GET_OPERAND(pic, i); \ - if (pic_## type ##_p(v)) { \ + if (pic_## type ##_p(pic, v)) { \ *ptr = conv; \ } \ else { \ - pic_errorf(pic, "pic_get_args: expected " #type ", but got ~s", v); \ + pic_error(pic, "pic_get_args: " #type " required", 1, v); \ } \ break; \ } - VAL_CASE('c', char, char, pic_char(v)) - VAL_CASE('z', str, const char *, pic_str_cstr(pic, pic_str_ptr(v))) + VAL_CASE('c', char, char, pic_char(pic, v)) + VAL_CASE('z', str, const char *, pic_str(pic, v)) -#define PTR_CASE(c, type, ctype) \ - VAL_CASE(c, type, ctype, pic_## type ##_ptr(v)) +#define OBJ_CASE(c, type) VAL_CASE(c, type, pic_value, v) - PTR_CASE('s', str, pic_str *) - PTR_CASE('m', sym, pic_sym *) - PTR_CASE('v', vec, pic_vec *) - PTR_CASE('b', blob, pic_blob *) - PTR_CASE('l', proc, struct pic_proc *) - PTR_CASE('p', port, struct pic_port *) - PTR_CASE('d', dict, struct pic_dict *) - PTR_CASE('e', error, struct pic_error *) - PTR_CASE('r', rec, struct pic_record *) + OBJ_CASE('m', sym) + OBJ_CASE('s', str) + OBJ_CASE('l', proc) + OBJ_CASE('v', vec) + OBJ_CASE('d', dict) + OBJ_CASE('p', port) + OBJ_CASE('r', rec) default: - pic_errorf(pic, "pic_get_args: invalid argument specifier '%c' given", c); + pic_error(pic, "pic_get_args: invalid argument specifier given", 1, pic_char_value(pic, c)); + } + + if (format[1] == '+') { + pic_value *p; + p = va_arg(ap, pic_value*); + *p = GET_OPERAND(pic, i); } } if (rest) { @@ -176,40 +239,44 @@ pic_get_args(pic_state *pic, const char *format, ...) } static pic_value -vm_gref(pic_state *pic, pic_sym *uid) +vm_gref(pic_state *pic, pic_value uid) { + pic_value val; + if (! pic_weak_has(pic, pic->globals, uid)) { - pic_weak_set(pic, pic->globals, uid, pic_invalid_value()); - - pic_errorf(pic, "uninitialized global variable: %s", pic_symbol_name(pic, uid)); - - return pic_invalid_value(); + pic_error(pic, "undefined variable", 1, uid); } - - return pic_weak_ref(pic, pic->globals, uid); + val = pic_weak_ref(pic, pic->globals, uid);; + if (pic_invalid_p(pic, val)) { + pic_error(pic, "uninitialized global variable", 1, uid); + } + return val; } static void -vm_gset(pic_state *pic, pic_sym *uid, pic_value value) +vm_gset(pic_state *pic, pic_value uid, pic_value value) { + if (! pic_weak_has(pic, pic->globals, uid)) { + pic_error(pic, "undefined variable", 1, uid); + } pic_weak_set(pic, pic->globals, uid, value); } static void vm_push_cxt(pic_state *pic) { - pic_callinfo *ci = pic->ci; + struct callinfo *ci = pic->ci; - ci->cxt = (struct pic_context *)pic_obj_alloc(pic, sizeof(struct pic_context) + sizeof(pic_value) * ci->regc, PIC_TT_CXT); + ci->cxt = (struct context *)pic_obj_alloc(pic, offsetof(struct context, storage) + sizeof(pic_value) * ci->regc, PIC_TYPE_CXT); ci->cxt->up = ci->up; ci->cxt->regc = ci->regc; ci->cxt->regs = ci->regs; } static void -vm_tear_off(pic_callinfo *ci) +vm_tear_off(struct callinfo *ci) { - struct pic_context *cxt; + struct context *cxt; int i; assert(ci->cxt != NULL); @@ -228,7 +295,7 @@ vm_tear_off(pic_callinfo *ci) void pic_vm_tear_off(pic_state *pic) { - pic_callinfo *ci; + struct callinfo *ci; for (ci = pic->ci; ci > pic->cibase; ci--) { if (ci->cxt != NULL) { @@ -237,15 +304,9 @@ pic_vm_tear_off(pic_state *pic) } } -#if VM_DEBUG -# define OPCODE_EXEC_HOOK pic_dump_code(c) -#else -# define OPCODE_EXEC_HOOK ((void)0) -#endif - #if PIC_DIRECT_THREADED_VM # define VM_LOOP JUMP; -# define CASE(x) L_##x: OPCODE_EXEC_HOOK; +# define CASE(x) L_##x: # define NEXT pic->ip++; JUMP; # define JUMP c = *pic->ip; goto *oplabels[c.insn]; # define VM_LOOP_END @@ -263,75 +324,23 @@ pic_vm_tear_off(pic_state *pic) #define PUSHCI() (++pic->ci) #define POPCI() (pic->ci--) -#if VM_DEBUG -# define VM_BOOT_PRINT \ - do { \ - puts("### booting VM... ###"); \ - stbase = pic->sp; \ - cibase = pic->ci; \ - } while (0) -#else -# define VM_BOOT_PRINT -#endif - -#if VM_DEBUG -# define VM_END_PRINT \ - do { \ - puts("**VM END STATE**"); \ - printf("stbase\t= %p\nsp\t= %p\n", (void *)stbase, (void *)pic->sp); \ - printf("cibase\t= %p\nci\t= %p\n", (void *)cibase, (void *)pic->ci); \ - if (stbase < pic->sp - 1) { \ - pic_value *sp; \ - printf("* stack trace:"); \ - for (sp = stbase; pic->sp != sp; ++sp) { \ - pic_debug(pic, *sp); \ - puts(""); \ - } \ - } \ - if (stbase > pic->sp - 1) { \ - puts("*** stack underflow!"); \ - } \ - } while (0) -#else -# define VM_END_PRINT -#endif - -#if VM_DEBUG -# define VM_CALL_PRINT \ - do { \ - short i; \ - puts("\n== calling proc..."); \ - printf(" proc = "); \ - pic_debug(pic, pic_obj_value(proc)); \ - puts(""); \ - printf(" argv = ("); \ - for (i = 1; i < c.u.i; ++i) { \ - if (i > 1) \ - printf(" "); \ - pic_debug(pic, pic->sp[-c.u.i + i]); \ - } \ - puts(")"); \ - if (! pic_proc_func_p(proc)) { \ - printf(" irep = %p\n", proc->u.i.irep); \ - printf(" name = %s\n", pic_symbol_name(pic, pic_proc_name(proc))); \ - pic_dump_irep(proc->u.i.irep); \ - } \ - else { \ - printf(" cfunc = %p\n", (void *)proc->u.f.func); \ - printf(" name = %s\n", pic_symbol_name(pic, pic_proc_name(proc))); \ - } \ - puts("== end\n"); \ - } while (0) -#else -# define VM_CALL_PRINT -#endif +/* for arithmetic instructions */ +pic_value pic_add(pic_state *, pic_value, pic_value); +pic_value pic_sub(pic_state *, pic_value, pic_value); +pic_value pic_mul(pic_state *, pic_value, pic_value); +pic_value pic_div(pic_state *, pic_value, pic_value); +bool pic_eq(pic_state *, pic_value, pic_value); +bool pic_lt(pic_state *, pic_value, pic_value); +bool pic_le(pic_state *, pic_value, pic_value); +bool pic_gt(pic_state *, pic_value, pic_value); +bool pic_ge(pic_state *, pic_value, pic_value); pic_value -pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) +pic_apply(pic_state *pic, pic_value proc, int argc, pic_value *argv) { - pic_code c; - size_t ai = pic_gc_arena_preserve(pic); - pic_code boot[2]; + struct code c; + size_t ai = pic_enter(pic); + struct code boot[2]; int i; #if PIC_DIRECT_THREADED_VM @@ -348,19 +357,12 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) }; #endif -#if VM_DEBUG - pic_value *stbase; - pic_callinfo *cibase; -#endif - - PUSH(pic_obj_value(proc)); + PUSH(proc); for (i = 0; i < argc; ++i) { PUSH(argv[i]); } - VM_BOOT_PRINT; - /* boot! */ boot[0].insn = OP_CALL; boot[0].a = argc + 1; @@ -376,35 +378,35 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) NEXT; } CASE(OP_PUSHUNDEF) { - PUSH(pic_undef_value()); + PUSH(pic_undef_value(pic)); NEXT; } CASE(OP_PUSHNIL) { - PUSH(pic_nil_value()); + PUSH(pic_nil_value(pic)); NEXT; } CASE(OP_PUSHTRUE) { - PUSH(pic_true_value()); + PUSH(pic_true_value(pic)); NEXT; } CASE(OP_PUSHFALSE) { - PUSH(pic_false_value()); + PUSH(pic_false_value(pic)); NEXT; } CASE(OP_PUSHINT) { - PUSH(pic_int_value(pic->ci->irep->ints[c.a])); + PUSH(pic_int_value(pic, pic->ci->irep->ints[c.a])); NEXT; } CASE(OP_PUSHFLOAT) { - PUSH(pic_float_value(pic->ci->irep->nums[c.a])); + PUSH(pic_float_value(pic, pic->ci->irep->nums[c.a])); NEXT; } CASE(OP_PUSHCHAR) { - PUSH(pic_char_value(pic->ci->irep->ints[c.a])); + PUSH(pic_char_value(pic, pic->ci->irep->ints[c.a])); NEXT; } CASE(OP_PUSHEOF) { - PUSH(pic_eof_object()); + PUSH(pic_eof_object(pic)); NEXT; } CASE(OP_PUSHCONST) { @@ -412,17 +414,17 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) NEXT; } CASE(OP_GREF) { - PUSH(vm_gref(pic, (pic_sym *)pic->ci->irep->pool[c.a])); + PUSH(vm_gref(pic, pic_obj_value(pic->ci->irep->pool[c.a]))); NEXT; } CASE(OP_GSET) { - vm_gset(pic, (pic_sym *)pic->ci->irep->pool[c.a], POP()); - PUSH(pic_undef_value()); + vm_gset(pic, pic_obj_value(pic->ci->irep->pool[c.a]), POP()); + PUSH(pic_undef_value(pic)); NEXT; } CASE(OP_LREF) { - pic_callinfo *ci = pic->ci; - struct pic_irep *irep = ci->irep; + struct callinfo *ci = pic->ci; + struct irep *irep = ci->irep; if (ci->cxt != NULL && ci->cxt->regs == ci->cxt->storage) { if (c.a >= irep->argc + irep->localc) { @@ -434,23 +436,23 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) NEXT; } CASE(OP_LSET) { - pic_callinfo *ci = pic->ci; - struct pic_irep *irep = ci->irep; + struct callinfo *ci = pic->ci; + struct irep *irep = ci->irep; if (ci->cxt != NULL && ci->cxt->regs == ci->cxt->storage) { if (c.a >= irep->argc + irep->localc) { ci->cxt->regs[c.a - (ci->regs - ci->fp)] = POP(); - PUSH(pic_undef_value()); + PUSH(pic_undef_value(pic)); NEXT; } } pic->ci->fp[c.a] = POP(); - PUSH(pic_undef_value()); + PUSH(pic_undef_value(pic)); NEXT; } CASE(OP_CREF) { int depth = c.a; - struct pic_context *cxt; + struct context *cxt; cxt = pic->ci->up; while (--depth) { @@ -461,14 +463,14 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) } CASE(OP_CSET) { int depth = c.a; - struct pic_context *cxt; + struct context *cxt; cxt = pic->ci->up; while (--depth) { cxt = cxt->up; } cxt->regs[c.b] = POP(); - PUSH(pic_undef_value()); + PUSH(pic_undef_value(pic)); NEXT; } CASE(OP_JMP) { @@ -479,7 +481,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) pic_value v; v = POP(); - if (! pic_false_p(v)) { + if (! pic_false_p(pic, v)) { pic->ip += c.a; JUMP; } @@ -487,7 +489,8 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) } CASE(OP_CALL) { pic_value x, v; - pic_callinfo *ci; + struct callinfo *ci; + struct proc *proc; if (c.a == -1) { pic->sp += pic->ci[1].retc - 1; @@ -496,12 +499,10 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) L_CALL: x = pic->sp[-c.a]; - if (! pic_proc_p(x)) { - pic_errorf(pic, "invalid application: ~s", x); + if (! pic_proc_p(pic, x)) { + pic_error(pic, "invalid application", 1, x); } - proc = pic_proc_ptr(x); - - VM_CALL_PRINT; + proc = pic_proc_ptr(pic, x); if (pic->sp >= pic->stend) { pic_panic(pic, "VM stack overflow"); @@ -514,32 +515,32 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) ci->fp = pic->sp - c.a; ci->irep = NULL; ci->cxt = NULL; - if (pic_proc_func_p(proc)) { + if (proc->tt == PIC_TYPE_FUNC) { /* invoke! */ v = proc->u.f.func(pic); pic->sp[0] = v; pic->sp += pic->ci->retc; - pic_gc_arena_restore(pic, ai); + pic_leave(pic, ai); goto L_RET; } else { - struct pic_irep *irep = proc->u.i.irep; + struct irep *irep = proc->u.i.irep; int i; pic_value rest; ci->irep = irep; if (ci->argc != irep->argc) { if (! (irep->varg && ci->argc >= irep->argc)) { - pic_errorf(pic, "wrong number of arguments (%d for %s%d)", ci->argc - 1, (irep->varg ? "at least " : ""), irep->argc - 1); + arg_error(pic, ci->argc - 1, irep->varg, irep->argc - 1); } } /* prepare rest args */ if (irep->varg) { - rest = pic_nil_value(); + rest = pic_nil_value(pic); for (i = 0; i < ci->argc - irep->argc; ++i) { - pic_gc_protect(pic, v = POP()); + pic_protect(pic, v = POP()); rest = pic_cons(pic, v, rest); } PUSH(rest); @@ -551,7 +552,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) --l; } for (i = 0; i < l; ++i) { - PUSH(pic_undef_value()); + PUSH(pic_undef_value(pic)); } } @@ -561,14 +562,14 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) ci->regs = ci->fp + irep->argc + irep->localc; pic->ip = irep->code; - pic_gc_arena_restore(pic, ai); + pic_leave(pic, ai); JUMP; } } CASE(OP_TAILCALL) { int i, argc; pic_value *argv; - pic_callinfo *ci; + struct callinfo *ci; if (pic->ci->cxt != NULL) { vm_tear_off(pic->ci); @@ -594,7 +595,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) CASE(OP_RET) { int i, retc; pic_value *retv; - pic_callinfo *ci; + struct callinfo *ci; if (pic->ci->cxt != NULL) { vm_tear_off(pic->ci); @@ -622,9 +623,8 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) vm_push_cxt(pic); } - proc = pic_make_proc_irep(pic, pic->ci->irep->irep[c.a], pic->ci->cxt); - PUSH(pic_obj_value(proc)); - pic_gc_arena_restore(pic, ai); + PUSH(pic_make_proc_irep(pic, pic->ci->irep->irep[c.a], pic->ci->cxt)); + pic_leave(pic, ai); NEXT; } @@ -636,11 +636,11 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) CASE(OP_CONS) { pic_value a, b; check_condition(CONS, 2); - pic_gc_protect(pic, b = POP()); - pic_gc_protect(pic, a = POP()); + pic_protect(pic, b = POP()); + pic_protect(pic, a = POP()); (void)POP(); PUSH(pic_cons(pic, a, b)); - pic_gc_arena_restore(pic, ai); + pic_leave(pic, ai); NEXT; } CASE(OP_CAR) { @@ -664,7 +664,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) check_condition(NILP, 1); p = POP(); (void)POP(); - PUSH(pic_bool_value(pic_nil_p(p))); + PUSH(pic_bool_value(pic, pic_nil_p(pic, p))); NEXT; } CASE(OP_SYMBOLP) { @@ -672,7 +672,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) check_condition(SYMBOLP, 1); p = POP(); (void)POP(); - PUSH(pic_bool_value(pic_sym_p(p))); + PUSH(pic_bool_value(pic, pic_sym_p(pic, p))); NEXT; } CASE(OP_PAIRP) { @@ -680,13 +680,13 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) check_condition(PAIRP, 1); p = POP(); (void)POP(); - PUSH(pic_bool_value(pic_pair_p(p))); + PUSH(pic_bool_value(pic, pic_pair_p(pic, p))); NEXT; } CASE(OP_NOT) { pic_value v; check_condition(NOT, 1); - v = pic_false_p(POP()) ? pic_true_value() : pic_false_value(); + v = pic_false_p(pic, POP()) ? pic_true_value(pic) : pic_false_value(pic); (void)POP(); PUSH(v); NEXT; @@ -734,7 +734,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) b = POP(); a = POP(); (void)POP(); - PUSH(pic_bool_value(pic_eq(pic, a, b))); + PUSH(pic_bool_value(pic, pic_eq(pic, a, b))); NEXT; } CASE(OP_LE) { @@ -743,7 +743,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) b = POP(); a = POP(); (void)POP(); - PUSH(pic_bool_value(pic_le(pic, a, b))); + PUSH(pic_bool_value(pic, pic_le(pic, a, b))); NEXT; } CASE(OP_LT) { @@ -752,7 +752,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) b = POP(); a = POP(); (void)POP(); - PUSH(pic_bool_value(pic_lt(pic, a, b))); + PUSH(pic_bool_value(pic, pic_lt(pic, a, b))); NEXT; } CASE(OP_GE) { @@ -761,7 +761,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) b = POP(); a = POP(); (void)POP(); - PUSH(pic_bool_value(pic_ge(pic, a, b))); + PUSH(pic_bool_value(pic, pic_ge(pic, a, b))); NEXT; } CASE(OP_GT) { @@ -770,48 +770,29 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) b = POP(); a = POP(); (void)POP(); - PUSH(pic_bool_value(pic_gt(pic, a, b))); + PUSH(pic_bool_value(pic, pic_gt(pic, a, b))); NEXT; } CASE(OP_STOP) { - - VM_END_PRINT; - - return pic_gc_protect(pic, POP()); + return pic_protect(pic, POP()); } } VM_LOOP_END; } pic_value -pic_apply_list(pic_state *pic, struct pic_proc *proc, pic_value list) -{ - int n, i = 0; - pic_vec *args; - pic_value x, it; - - n = pic_length(pic, list); - - args = pic_make_vec(pic, n); - - pic_for_each (x, list, it) { - args->data[i++] = x; - } - - return pic_apply(pic, proc, n, args->data); -} - -pic_value -pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, int argc, pic_value *args) +pic_applyk(pic_state *pic, pic_value proc, int argc, pic_value *args) { pic_value *sp; - pic_callinfo *ci; + struct callinfo *ci; int i; - PIC_INIT_CODE_I(pic->iseq[0], OP_NOP, 0); - PIC_INIT_CODE_I(pic->iseq[1], OP_TAILCALL, -1); + pic->iseq[0].insn = OP_NOP; + pic->iseq[0].a = 0; + pic->iseq[1].insn = OP_TAILCALL; + pic->iseq[1].a = -1; - *pic->sp++ = pic_obj_value(proc); + *pic->sp++ = proc; sp = pic->sp; for (i = 0; i < argc; ++i) { @@ -824,210 +805,165 @@ pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, int argc, pic_value ci->retc = (int)argc; if (ci->retc == 0) { - return pic_undef_value(); + return pic_undef_value(pic); } else { return args[0]; } } pic_value -pic_apply_trampoline_list(pic_state *pic, struct pic_proc *proc, pic_value args) +pic_call(pic_state *pic, pic_value proc, int n, ...) { - int i, argc = pic_length(pic, args); - pic_value val, it; - pic_vec *argv = pic_make_vec(pic, argc); - - i = 0; - pic_for_each (val, args, it) { - argv->data[i++] = val; - } - - return pic_apply_trampoline(pic, proc, argc, argv->data); -} - -static pic_value -pic_va_apply(pic_state *pic, struct pic_proc *proc, int n, ...) -{ - pic_vec *args = pic_make_vec(pic, n); + pic_value r; va_list ap; - int i = 0; va_start(ap, n); - - while (i < n) { - args->data[i++] = va_arg(ap, pic_value); - } - + r = pic_vcall(pic, proc, n, ap); va_end(ap); - - return pic_apply(pic, proc, n, args->data); + return r; } pic_value -pic_apply0(pic_state *pic, struct pic_proc *proc) +pic_vcall(pic_state *pic, pic_value proc, int n, va_list ap) { - return pic_va_apply(pic, proc, 0); -} + pic_value *args = pic_alloca(pic, sizeof(pic_value) * n); + int i; -pic_value -pic_apply1(pic_state *pic, struct pic_proc *proc, pic_value arg1) -{ - return pic_va_apply(pic, proc, 1, arg1); -} - -pic_value -pic_apply2(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2) -{ - return pic_va_apply(pic, proc, 2, arg1, arg2); -} - -pic_value -pic_apply3(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2, pic_value arg3) -{ - return pic_va_apply(pic, proc, 3, arg1, arg2, arg3); -} - -pic_value -pic_apply4(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4) -{ - return pic_va_apply(pic, proc, 4, arg1, arg2, arg3, arg4); -} - -pic_value -pic_apply5(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4, pic_value arg5) -{ - return pic_va_apply(pic, proc, 5, arg1, arg2, arg3, arg4, arg5); -} - -void -pic_define_(pic_state *pic, const char *name, pic_value val) -{ - pic_sym *sym, *uid; - - sym = pic_intern_cstr(pic, name); - - if ((uid = pic_find_identifier(pic, (pic_id *)sym, pic->lib->env)) == NULL) { - uid = pic_add_identifier(pic, (pic_id *)sym, pic->lib->env); - } else { - if (pic_weak_has(pic, pic->globals, uid)) { - pic_warnf(pic, "redefining variable: ~s", pic_obj_value(uid)); - } + for (i = 0; i < n; ++i) { + args[i] = va_arg(ap, pic_value); } - - pic_set(pic, pic->lib, name, val); -} - -void -pic_define(pic_state *pic, const char *name, pic_value val) -{ - pic_define_(pic, name, val); - pic_export(pic, pic_intern_cstr(pic, name)); -} - -void -pic_defun_(pic_state *pic, const char *name, pic_func_t cfunc) -{ - pic_define_(pic, name, pic_obj_value(pic_make_proc(pic, cfunc))); -} - -void -pic_defun(pic_state *pic, const char *name, pic_func_t cfunc) -{ - pic_defun_(pic, name, cfunc); - pic_export(pic, pic_intern_cstr(pic, name)); -} - -void -pic_defvar_(pic_state *pic, const char *name, pic_value init, struct pic_proc *conv) -{ - pic_define_(pic, name, pic_obj_value(pic_make_var(pic, init, conv))); -} - -void -pic_defvar(pic_state *pic, const char *name, pic_value init, struct pic_proc *conv) -{ - pic_defvar_(pic, name, init, conv); - pic_export(pic, pic_intern_cstr(pic, name)); + return pic_apply(pic, proc, n, args); } pic_value -pic_ref(pic_state *pic, struct pic_lib *lib, const char *name) -{ - pic_sym *sym, *uid; - - sym = pic_intern_cstr(pic, name); - - if ((uid = pic_find_identifier(pic, (pic_id *)sym, lib->env)) == NULL) { - pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); - } - - return vm_gref(pic, uid); -} - -void -pic_set(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val) -{ - pic_sym *sym, *uid; - - sym = pic_intern_cstr(pic, name); - - if ((uid = pic_find_identifier(pic, (pic_id *)sym, lib->env)) == NULL) { - pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); - } - - vm_gset(pic, uid, val); -} - -static struct pic_proc * -pic_ref_proc(pic_state *pic, struct pic_lib *lib, const char *name) +pic_lambda(pic_state *pic, pic_func_t f, int n, ...) { pic_value proc; + va_list ap; + + va_start(ap, n); + proc = pic_vlambda(pic, f, n, ap); + va_end(ap); + return proc; +} + +pic_value +pic_vlambda(pic_state *pic, pic_func_t f, int n, va_list ap) +{ + pic_value *env = pic_alloca(pic, sizeof(pic_value) * n); + int i; + + for (i = 0; i < n; ++i) { + env[i] = va_arg(ap, pic_value); + } + return pic_make_proc(pic, f, n, env); +} + +void +pic_defun(pic_state *pic, const char *name, pic_func_t f) +{ + pic_define(pic, pic_current_library(pic), name, pic_make_proc(pic, f, 0, NULL)); + pic_export(pic, pic_intern_cstr(pic, name)); +} + +void +pic_defvar(pic_state *pic, const char *name, pic_value init, pic_value conv) +{ + pic_define(pic, pic_current_library(pic), name, pic_make_var(pic, init, conv)); + pic_export(pic, pic_intern_cstr(pic, name)); +} + +void +pic_define(pic_state *pic, const char *lib, const char *name, pic_value val) +{ + pic_value sym, uid, env; + + sym = pic_intern_cstr(pic, name); + + env = pic_library_environment(pic, lib); + + uid = pic_find_identifier(pic, sym, env); + if (pic_weak_has(pic, pic->globals, uid)) { + pic_warnf(pic, "redefining variable: %s", pic_sym(pic, uid)); + } + pic_weak_set(pic, pic->globals, uid, val); +} + +pic_value +pic_ref(pic_state *pic, const char *lib, const char *name) +{ + pic_value sym, env; + + sym = pic_intern_cstr(pic, name); + + env = pic_library_environment(pic, lib); + + return vm_gref(pic, pic_find_identifier(pic, sym, env)); +} + +void +pic_set(pic_state *pic, const char *lib, const char *name, pic_value val) +{ + pic_value sym, env; + + sym = pic_intern_cstr(pic, name); + + env = pic_library_environment(pic, lib); + + vm_gset(pic, pic_find_identifier(pic, sym, env), val); +} + +pic_value +pic_closure_ref(pic_state *pic, int n) +{ + pic_value self = GET_OPERAND(pic, 0); + + assert(pic_func_p(self)); + + if (n < 0 || pic_proc_ptr(pic, self)->u.f.localc <= n) { + pic_error(pic, "pic_closure_ref: index out of range", 1, pic_int_value(pic, n)); + } + return pic_proc_ptr(pic, self)->locals[n]; +} + +void +pic_closure_set(pic_state *pic, int n, pic_value v) +{ + pic_value self = GET_OPERAND(pic, 0); + + assert(pic_func_p(self)); + + if (n < 0 || pic_proc_ptr(pic, self)->u.f.localc <= n) { + pic_error(pic, "pic_closure_ref: index out of range", 1, pic_int_value(pic, n)); + } + pic_proc_ptr(pic, self)->locals[n] = v; +} + +pic_value +pic_funcall(pic_state *pic, const char *lib, const char *name, int n, ...) +{ + pic_value proc, r; + va_list ap; proc = pic_ref(pic, lib, name); pic_assert_type(pic, proc, proc); - return pic_proc_ptr(proc); -} + va_start(ap, n); + r = pic_vcall(pic, proc, n, ap); + va_end(ap); -pic_value -pic_funcall(pic_state *pic, struct pic_lib *lib, const char *name, pic_value args) -{ - return pic_apply_list(pic, pic_ref_proc(pic, lib, name), args); -} - -pic_value -pic_funcall0(pic_state *pic, struct pic_lib *lib, const char *name) -{ - return pic_apply0(pic, pic_ref_proc(pic, lib, name)); -} - -pic_value -pic_funcall1(pic_state *pic, struct pic_lib *lib, const char *name, pic_value arg0) -{ - return pic_apply1(pic, pic_ref_proc(pic, lib, name), arg0); -} - -pic_value -pic_funcall2(pic_state *pic, struct pic_lib *lib, const char *name, pic_value arg0, pic_value arg1) -{ - return pic_apply2(pic, pic_ref_proc(pic, lib, name), arg0, arg1); -} - -pic_value -pic_funcall3(pic_state *pic, struct pic_lib *lib, const char *name, pic_value arg0, pic_value arg1, pic_value arg2) -{ - return pic_apply3(pic, pic_ref_proc(pic, lib, name), arg0, arg1, arg2); + return r; } void -pic_irep_incref(pic_state PIC_UNUSED(*pic), struct pic_irep *irep) +pic_irep_incref(pic_state *PIC_UNUSED(pic), struct irep *irep) { irep->refc++; } void -pic_irep_decref(pic_state *pic, struct pic_irep *irep) +pic_irep_decref(pic_state *pic, struct irep *irep) { size_t i; @@ -1049,58 +985,31 @@ pic_irep_decref(pic_state *pic, struct pic_irep *irep) } } -struct pic_proc * -pic_make_proc(pic_state *pic, pic_func_t func) +pic_value +pic_make_proc(pic_state *pic, pic_func_t func, int n, pic_value *env) { - struct pic_proc *proc; + struct proc *proc; + int i; - proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC); - proc->tag = PIC_PROC_TAG_FUNC; + proc = (struct proc *)pic_obj_alloc(pic, offsetof(struct proc, locals) + sizeof(pic_value) * n, PIC_TYPE_FUNC); proc->u.f.func = func; - proc->u.f.env = NULL; - return proc; -} - -struct pic_proc * -pic_make_proc_irep(pic_state *pic, struct pic_irep *irep, struct pic_context *cxt) -{ - struct pic_proc *proc; - - proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC); - proc->tag = PIC_PROC_TAG_IREP; - proc->u.i.irep = irep; - proc->u.i.cxt = cxt; - pic_irep_incref(pic, irep); - return proc; -} - -struct pic_dict * -pic_proc_env(pic_state *pic, struct pic_proc *proc) -{ - assert(pic_proc_func_p(proc)); - - if (! proc->u.f.env) { - proc->u.f.env = pic_make_dict(pic); + proc->u.f.localc = n; + for (i = 0; i < n; ++i) { + proc->locals[i] = env[i]; } - return proc->u.f.env; -} - -bool -pic_proc_env_has(pic_state *pic, struct pic_proc *proc, const char *key) -{ - return pic_dict_has(pic, pic_proc_env(pic, proc), pic_intern_cstr(pic, key)); + return pic_obj_value(proc); } pic_value -pic_proc_env_ref(pic_state *pic, struct pic_proc *proc, const char *key) +pic_make_proc_irep(pic_state *pic, struct irep *irep, struct context *cxt) { - return pic_dict_ref(pic, pic_proc_env(pic, proc), pic_intern_cstr(pic, key)); -} + struct proc *proc; -void -pic_proc_env_set(pic_state *pic, struct pic_proc *proc, const char *key, pic_value val) -{ - pic_dict_set(pic, pic_proc_env(pic, proc), pic_intern_cstr(pic, key), val); + proc = (struct proc *)pic_obj_alloc(pic, offsetof(struct proc, locals), PIC_TYPE_IREP); + proc->u.i.irep = irep; + proc->u.i.cxt = cxt; + pic_irep_incref(pic, irep); + return pic_obj_value(proc); } static pic_value @@ -1110,29 +1019,32 @@ pic_proc_proc_p(pic_state *pic) pic_get_args(pic, "o", &v); - return pic_bool_value(pic_proc_p(v)); + return pic_bool_value(pic, pic_proc_p(pic, v)); } static pic_value pic_proc_apply(pic_state *pic) { - struct pic_proc *proc; - pic_value *args; - int argc; - pic_value arg_list; + pic_value proc, *args, *arg_list; + int argc, n, i; pic_get_args(pic, "l*", &proc, &argc, &args); if (argc == 0) { - pic_errorf(pic, "apply: wrong number of arguments"); + pic_error(pic, "apply: wrong number of arguments", 0); } - arg_list = args[--argc]; - while (argc--) { - arg_list = pic_cons(pic, args[argc], arg_list); - } + n = argc - 1 + pic_length(pic, args[argc - 1]); - return pic_apply_trampoline_list(pic, proc, arg_list); + arg_list = pic_alloca(pic, sizeof(pic_value) * n); + for (i = 0; i < argc - 1; ++i) { + arg_list[i] = args[i]; + } + while (i < n) { + arg_list[i] = pic_list_ref(pic, args[argc - 1], i - argc + 1); + i++; + } + return pic_applyk(pic, proc, n, arg_list); } void diff --git a/extlib/benz/read.c b/extlib/benz/read.c index 1fb6a713..5db65c72 100644 --- a/extlib/benz/read.c +++ b/extlib/benz/read.c @@ -3,56 +3,71 @@ */ #include "picrin.h" +#include "picrin/extra.h" +#include "picrin/private/object.h" +#undef EOF +#define EOF (-1) + +KHASH_DECLARE(read, int, pic_value) KHASH_DEFINE(read, int, pic_value, kh_int_hash_func, kh_int_hash_equal) -static pic_value read(pic_state *pic, struct pic_port *port, int c); -static pic_value read_nullable(pic_state *pic, struct pic_port *port, int c); +struct reader_control { + int typecase; + khash_t(read) labels; +}; + +#define CASE_DEFAULT 0 +#define CASE_FOLD 1 + +typedef pic_value (*pic_reader_t)(pic_state *, xFILE *file, int c, struct reader_control *); + +static pic_reader_t reader_table[256]; +static pic_reader_t reader_dispatch[256]; + +static pic_value read(pic_state *pic, xFILE *file, int c, struct reader_control *p); +static pic_value read_nullable(pic_state *pic, xFILE *file, int c, struct reader_control *p); PIC_NORETURN static void -read_error(pic_state *pic, const char *msg, pic_value irritant) +read_error(pic_state *pic, const char *msg, pic_value irritants) { - struct pic_error *e; - - e = pic_make_error(pic, pic_intern_lit(pic, "read"), msg, irritant); - - pic_raise(pic, pic_obj_value(e)); + pic_raise(pic, pic_make_error(pic, "read", msg, irritants)); } static int -skip(pic_state *pic, struct pic_port *port, int c) +skip(pic_state *pic, xFILE *file, int c) { while (isspace(c)) { - c = xfgetc(pic, port->file); + c = xfgetc(pic, file); } return c; } static int -next(pic_state *pic, struct pic_port *port) +next(pic_state *pic, xFILE *file) { - return xfgetc(pic, port->file); + return xfgetc(pic, file); } static int -peek(pic_state *pic, struct pic_port *port) +peek(pic_state *pic, xFILE *file) { int c; - xungetc((c = xfgetc(pic, port->file)), port->file); + xungetc(pic, (c = xfgetc(pic, file)), file); return c; } static bool -expect(pic_state *pic, struct pic_port *port, const char *str) +expect(pic_state *pic, xFILE *file, const char *str) { int c; while ((c = (int)*str++) != 0) { - if (c != peek(pic, port)) + if (c != peek(pic, file)) return false; - next(pic, port); + next(pic, file); } return true; @@ -77,35 +92,35 @@ strcaseeq(const char *s1, const char *s2) } static int -case_fold(pic_state *pic, int c) +case_fold(int c, struct reader_control *p) { - if (pic->reader.typecase == PIC_CASE_FOLD) { + if (p->typecase == CASE_FOLD) { c = tolower(c); } return c; } static pic_value -read_comment(pic_state PIC_UNUSED(*pic), struct pic_port *port, int c) +read_comment(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSED(p)) { do { - c = next(pic, port); + c = next(pic, file); } while (! (c == EOF || c == '\n')); - return pic_invalid_value(); + return pic_invalid_value(pic); } static pic_value -read_block_comment(pic_state PIC_UNUSED(*pic), struct pic_port *port, int PIC_UNUSED(c)) +read_block_comment(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_control *PIC_UNUSED(p)) { int x, y; int i = 1; - y = next(pic, port); + y = next(pic, file); while (y != EOF && i > 0) { x = y; - y = next(pic, port); + y = next(pic, file); if (x == '|' && y == '#') { i--; } @@ -114,131 +129,135 @@ read_block_comment(pic_state PIC_UNUSED(*pic), struct pic_port *port, int PIC_UN } } - return pic_invalid_value(); + return pic_invalid_value(pic); } static pic_value -read_datum_comment(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) +read_datum_comment(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_control *p) { - read(pic, port, next(pic, port)); + read(pic, file, next(pic, file), p); - return pic_invalid_value(); + return pic_invalid_value(pic); } static pic_value -read_directive(pic_state *pic, struct pic_port *port, int c) +read_directive(pic_state *pic, xFILE *file, int c, struct reader_control *p) { - switch (peek(pic, port)) { + switch (peek(pic, file)) { case 'n': - if (expect(pic, port, "no-fold-case")) { - pic->reader.typecase = PIC_CASE_DEFAULT; - return pic_invalid_value(); + if (expect(pic, file, "no-fold-case")) { + p->typecase = CASE_DEFAULT; + return pic_invalid_value(pic); } break; case 'f': - if (expect(pic, port, "fold-case")) { - pic->reader.typecase = PIC_CASE_FOLD; - return pic_invalid_value(); + if (expect(pic, file, "fold-case")) { + p->typecase = CASE_FOLD; + return pic_invalid_value(pic); } break; } - return read_comment(pic, port, c); + return read_comment(pic, file, c, p); } static pic_value -read_quote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) +read_quote(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_control *p) { - return pic_list2(pic, pic_obj_value(pic->sQUOTE), read(pic, port, next(pic, port))); + return pic_list(pic, 2, pic_intern_lit(pic, "quote"), read(pic, file, next(pic, file), p)); } static pic_value -read_quasiquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) +read_quasiquote(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_control *p) { - return pic_list2(pic, pic_obj_value(pic->sQUASIQUOTE), read(pic, port, next(pic, port))); + return pic_list(pic, 2, pic_intern_lit(pic, "quasiquote"), read(pic, file, next(pic, file), p)); } static pic_value -read_unquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) +read_unquote(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_control *p) { - pic_sym *tag = pic->sUNQUOTE; + pic_value tag; - if (peek(pic, port) == '@') { - tag = pic->sUNQUOTE_SPLICING; - next(pic, port); + if (peek(pic, file) == '@') { + tag = pic_intern_lit(pic, "unquote-splicing"); + next(pic, file); + } else { + tag = pic_intern_lit(pic, "unquote"); } - return pic_list2(pic, pic_obj_value(tag), read(pic, port, next(pic, port))); + return pic_list(pic, 2, tag, read(pic, file, next(pic, file), p)); } static pic_value -read_syntax_quote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) +read_syntax_quote(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_control *p) { - return pic_list2(pic, pic_obj_value(pic->sSYNTAX_QUOTE), read(pic, port, next(pic, port))); + return pic_list(pic, 2, pic_intern_lit(pic, "syntax-quote"), read(pic, file, next(pic, file), p)); } static pic_value -read_syntax_quasiquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) +read_syntax_quasiquote(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_control *p) { - return pic_list2(pic, pic_obj_value(pic->sSYNTAX_QUASIQUOTE), read(pic, port, next(pic, port))); + return pic_list(pic, 2, pic_intern_lit(pic, "syntax-quasiquote"), read(pic, file, next(pic, file), p)); } static pic_value -read_syntax_unquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) +read_syntax_unquote(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_control *p) { - pic_sym *tag = pic->sSYNTAX_UNQUOTE; + pic_value tag; - if (peek(pic, port) == '@') { - tag = pic->sSYNTAX_UNQUOTE_SPLICING; - next(pic, port); + if (peek(pic, file) == '@') { + tag = pic_intern_lit(pic, "syntax-unquote-splicing"); + next(pic, file); + } else { + tag = pic_intern_lit(pic, "syntax-unquote"); } - return pic_list2(pic, pic_obj_value(tag), read(pic, port, next(pic, port))); + return pic_list(pic, 2, tag, read(pic, file, next(pic, file), p)); } static pic_value -read_symbol(pic_state *pic, struct pic_port *port, int c) +read_symbol(pic_state *pic, xFILE *file, int c, struct reader_control *p) { int len; char *buf; - pic_sym *sym; + pic_value sym; len = 1; buf = pic_malloc(pic, len + 1); - buf[0] = case_fold(pic, c); + buf[0] = case_fold(c, p); buf[1] = 0; - while (! isdelim(peek(pic, port))) { - c = next(pic, port); + while (! isdelim(peek(pic, file))) { + c = next(pic, file); len += 1; buf = pic_realloc(pic, buf, len + 1); - buf[len - 1] = case_fold(pic, c); + buf[len - 1] = case_fold(c, p); buf[len] = 0; } sym = pic_intern_cstr(pic, buf); pic_free(pic, buf); - return pic_obj_value(sym); + return sym; } static unsigned -read_uinteger(pic_state *pic, struct pic_port *port, int c) +read_uinteger(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSED(p)) { unsigned u = 0; if (! isdigit(c)) { - read_error(pic, "expected one or more digits", pic_list1(pic, pic_char_value(c))); + read_error(pic, "expected one or more digits", pic_list(pic, 1, pic_char_value(pic, c))); } u = c - '0'; - while (isdigit(c = peek(pic, port))) { - u = u * 10 + next(pic, port) - '0'; + while (isdigit(c = peek(pic, file))) { + u = u * 10 + next(pic, file) - '0'; } return u; } static pic_value -read_unsigned(pic_state *pic, struct pic_port *port, int c) +read_unsigned(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSED(p)) { #define ATOF_BUF_SIZE (64) char buf[ATOF_BUF_SIZE]; @@ -247,179 +266,178 @@ read_unsigned(pic_state *pic, struct pic_port *port, int c) int dpe = 0; /* the number of '.' or 'e' characters seen */ if (! isdigit(c)) { - read_error(pic, "expected one or more digits", pic_list1(pic, pic_char_value(c))); + read_error(pic, "expected one or more digits", pic_list(pic, 1, pic_char_value(pic, c))); } buf[idx++] = (char )c; - while (isdigit(c = peek(pic, port)) && idx < ATOF_BUF_SIZE) { - buf[idx++] = (char )next(pic, port); + while (isdigit(c = peek(pic, file)) && idx < ATOF_BUF_SIZE) { + buf[idx++] = (char )next(pic, file); } - if ('.' == peek(pic, port) && idx < ATOF_BUF_SIZE) { + if ('.' == peek(pic, file) && idx < ATOF_BUF_SIZE) { dpe++; - buf[idx++] = (char )next(pic, port); - while (isdigit(c = peek(pic, port)) && idx < ATOF_BUF_SIZE) { - buf[idx++] = (char )next(pic, port); + buf[idx++] = (char )next(pic, file); + while (isdigit(c = peek(pic, file)) && idx < ATOF_BUF_SIZE) { + buf[idx++] = (char )next(pic, file); } } - c = peek(pic, port); + c = peek(pic, file); if ((c == 'e' || c == 'E') && idx < (ATOF_BUF_SIZE - 2)) { dpe++; - buf[idx++] = (char )next(pic, port); - switch ((c = peek(pic, port))) { + buf[idx++] = (char )next(pic, file); + switch ((c = peek(pic, file))) { case '-': case '+': - buf[idx++] = (char )next(pic, port); + buf[idx++] = (char )next(pic, file); break; default: break; } - if (! isdigit(peek(pic, port))) { - read_error(pic, "expected one or more digits", pic_list1(pic, pic_char_value(c))); + if (! isdigit(peek(pic, file))) { + read_error(pic, "expected one or more digits", pic_list(pic, 1, pic_char_value(pic, c))); } - while (isdigit(c = peek(pic, port)) && idx < ATOF_BUF_SIZE) { - buf[idx++] = (char )next(pic, port); + while (isdigit(c = peek(pic, file)) && idx < ATOF_BUF_SIZE) { + buf[idx++] = (char )next(pic, file); } } if (idx >= ATOF_BUF_SIZE) - read_error(pic, "number too large", - pic_obj_value(pic_make_str(pic, (const char *)buf, ATOF_BUF_SIZE))); + read_error(pic, "number too large", pic_list(pic, 1, pic_str_value(pic, (const char *)buf, ATOF_BUF_SIZE))); if (! isdelim(c)) - read_error(pic, "non-delimiter character given after number", pic_list1(pic, pic_char_value(c))); + read_error(pic, "non-delimiter character given after number", pic_list(pic, 1, pic_char_value(pic, c))); buf[idx] = 0; flt = PIC_CSTRING_TO_DOUBLE(buf); - if (dpe == 0 && pic_valid_int(flt)) - return pic_int_value((int )flt); - return pic_float_value(flt); + if (dpe == 0 && INT_MIN <= flt && flt <= INT_MAX) + return pic_int_value(pic, flt); + return pic_float_value(pic, flt); } static pic_value -read_number(pic_state *pic, struct pic_port *port, int c) +read_number(pic_state *pic, xFILE *file, int c, struct reader_control *p) { - return read_unsigned(pic, port, c); + return read_unsigned(pic, file, c, p); } static pic_value -negate(pic_value n) +negate(pic_state *pic, pic_value n) { - if (pic_int_p(n) && (INT_MIN != pic_int(n))) { - return pic_int_value(-pic_int(n)); + if (pic_int_p(pic, n) && (INT_MIN != pic_int(pic, n))) { + return pic_int_value(pic, -pic_int(pic, n)); } else { - return pic_float_value(-pic_float(n)); + return pic_float_value(pic, -pic_float(pic, n)); } } static pic_value -read_minus(pic_state *pic, struct pic_port *port, int c) +read_minus(pic_state *pic, xFILE *file, int c, struct reader_control *p) { pic_value sym; - if (isdigit(peek(pic, port))) { - return negate(read_unsigned(pic, port, next(pic, port))); + if (isdigit(peek(pic, file))) { + return negate(pic, read_unsigned(pic, file, next(pic, file), p)); } else { - sym = read_symbol(pic, port, c); - if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "-inf.0")) { - return pic_float_value(-(1.0 / 0.0)); + sym = read_symbol(pic, file, c, p); + if (strcaseeq(pic_sym(pic, sym), "-inf.0")) { + return pic_float_value(pic, -(1.0 / 0.0)); } - if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "-nan.0")) { - return pic_float_value(-(0.0 / 0.0)); + if (strcaseeq(pic_sym(pic, sym), "-nan.0")) { + return pic_float_value(pic, -(0.0 / 0.0)); } return sym; } } static pic_value -read_plus(pic_state *pic, struct pic_port *port, int c) +read_plus(pic_state *pic, xFILE *file, int c, struct reader_control *p) { pic_value sym; - if (isdigit(peek(pic, port))) { - return read_unsigned(pic, port, next(pic, port)); + if (isdigit(peek(pic, file))) { + return read_unsigned(pic, file, next(pic, file), p); } else { - sym = read_symbol(pic, port, c); - if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "+inf.0")) { - return pic_float_value(1.0 / 0.0); + sym = read_symbol(pic, file, c, p); + if (strcaseeq(pic_sym(pic, sym), "+inf.0")) { + return pic_float_value(pic, 1.0 / 0.0); } - if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "+nan.0")) { - return pic_float_value(0.0 / 0.0); + if (strcaseeq(pic_sym(pic, sym), "+nan.0")) { + return pic_float_value(pic, 0.0 / 0.0); } return sym; } } static pic_value -read_true(pic_state *pic, struct pic_port *port, int c) +read_true(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSED(p)) { - if ((c = peek(pic, port)) == 'r') { - if (! expect(pic, port, "rue")) { - read_error(pic, "unexpected character while reading #true", pic_nil_value()); + if ((c = peek(pic, file)) == 'r') { + if (! expect(pic, file, "rue")) { + read_error(pic, "unexpected character while reading #true", pic_nil_value(pic)); } } else if (! isdelim(c)) { - read_error(pic, "non-delimiter character given after #t", pic_list1(pic, pic_char_value(c))); + read_error(pic, "non-delimiter character given after #t", pic_list(pic, 1, pic_char_value(pic, c))); } - return pic_true_value(); + return pic_true_value(pic); } static pic_value -read_false(pic_state *pic, struct pic_port *port, int c) +read_false(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSED(p)) { - if ((c = peek(pic, port)) == 'a') { - if (! expect(pic, port, "alse")) { - read_error(pic, "unexpected character while reading #false", pic_nil_value()); + if ((c = peek(pic, file)) == 'a') { + if (! expect(pic, file, "alse")) { + read_error(pic, "unexpected character while reading #false", pic_nil_value(pic)); } } else if (! isdelim(c)) { - read_error(pic, "non-delimiter character given after #f", pic_list1(pic, pic_char_value(c))); + read_error(pic, "non-delimiter character given after #f", pic_list(pic, 1, pic_char_value(pic, c))); } - return pic_false_value(); + return pic_false_value(pic); } static pic_value -read_char(pic_state *pic, struct pic_port *port, int c) +read_char(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSED(p)) { - c = next(pic, port); + c = next(pic, file); - if (! isdelim(peek(pic, port))) { + if (! isdelim(peek(pic, file))) { switch (c) { - default: read_error(pic, "unexpected character after char literal", pic_list1(pic, pic_char_value(c))); - case 'a': c = '\a'; if (! expect(pic, port, "larm")) goto fail; break; - case 'b': c = '\b'; if (! expect(pic, port, "ackspace")) goto fail; break; - case 'd': c = 0x7F; if (! expect(pic, port, "elete")) goto fail; break; - case 'e': c = 0x1B; if (! expect(pic, port, "scape")) goto fail; break; + default: read_error(pic, "unexpected character after char literal", pic_list(pic, 1, pic_char_value(pic, c))); + case 'a': c = '\a'; if (! expect(pic, file, "larm")) goto fail; break; + case 'b': c = '\b'; if (! expect(pic, file, "ackspace")) goto fail; break; + case 'd': c = 0x7F; if (! expect(pic, file, "elete")) goto fail; break; + case 'e': c = 0x1B; if (! expect(pic, file, "scape")) goto fail; break; case 'n': - if ((c = peek(pic, port)) == 'e') { + if ((c = peek(pic, file)) == 'e') { c = '\n'; - if (! expect(pic, port, "ewline")) + if (! expect(pic, file, "ewline")) goto fail; } else { c = '\0'; - if (! expect(pic, port, "ull")) + if (! expect(pic, file, "ull")) goto fail; } break; - case 'r': c = '\r'; if (! expect(pic, port, "eturn")) goto fail; break; - case 's': c = ' '; if (! expect(pic, port, "pace")) goto fail; break; - case 't': c = '\t'; if (! expect(pic, port, "ab")) goto fail; break; + case 'r': c = '\r'; if (! expect(pic, file, "eturn")) goto fail; break; + case 's': c = ' '; if (! expect(pic, file, "pace")) goto fail; break; + case 't': c = '\t'; if (! expect(pic, file, "ab")) goto fail; break; } } - return pic_char_value((char)c); + return pic_char_value(pic, (char)c); fail: - read_error(pic, "unexpected character while reading character literal", pic_list1(pic, pic_char_value(c))); + read_error(pic, "unexpected character while reading character literal", pic_list(pic, 1, pic_char_value(pic, c))); } static pic_value -read_string(pic_state *pic, struct pic_port *port, int c) +read_string(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSED(p)) { char *buf; int size, cnt; - pic_str *str; + pic_value str; size = 256; buf = pic_malloc(pic, size); @@ -427,9 +445,9 @@ read_string(pic_state *pic, struct pic_port *port, int c) /* TODO: intraline whitespaces */ - while ((c = next(pic, port)) != '"') { + while ((c = next(pic, file)) != '"') { if (c == '\\') { - switch (c = next(pic, port)) { + switch (c = next(pic, file)) { case 'a': c = '\a'; break; case 'b': c = '\b'; break; case 't': c = '\t'; break; @@ -444,17 +462,17 @@ read_string(pic_state *pic, struct pic_port *port, int c) } buf[cnt] = '\0'; - str = pic_make_str(pic, buf, cnt); + str = pic_str_value(pic, buf, cnt); pic_free(pic, buf); - return pic_obj_value(str); + return str; } static pic_value -read_pipe(pic_state *pic, struct pic_port *port, int c) +read_pipe(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSED(p)) { char *buf; int size, cnt; - pic_sym *sym; + pic_value sym; /* Currently supports only ascii chars */ char HEX_BUF[3]; size_t i = 0; @@ -462,9 +480,9 @@ read_pipe(pic_state *pic, struct pic_port *port, int c) size = 256; buf = pic_malloc(pic, size); cnt = 0; - while ((c = next(pic, port)) != '|') { + while ((c = next(pic, file)) != '|') { if (c == '\\') { - switch ((c = next(pic, port))) { + switch ((c = next(pic, file))) { case 'a': c = '\a'; break; case 'b': c = '\b'; break; case 't': c = '\t'; break; @@ -472,9 +490,9 @@ read_pipe(pic_state *pic, struct pic_port *port, int c) case 'r': c = '\r'; break; case 'x': i = 0; - while ((HEX_BUF[i++] = (char)next(pic, port)) != ';') { + while ((HEX_BUF[i++] = (char)next(pic, file)) != ';') { if (i >= sizeof HEX_BUF) - read_error(pic, "expected ';'", pic_list1(pic, pic_char_value(HEX_BUF[sizeof(HEX_BUF) - 1]))); + read_error(pic, "expected ';'", pic_list(pic, 1, pic_char_value(pic, HEX_BUF[sizeof(HEX_BUF) - 1]))); } c = (char)strtol(HEX_BUF, NULL, 16); break; @@ -490,144 +508,139 @@ read_pipe(pic_state *pic, struct pic_port *port, int c) sym = pic_intern_cstr(pic, buf); pic_free(pic, buf); - return pic_obj_value(sym); + return sym; } static pic_value -read_blob(pic_state *pic, struct pic_port *port, int c) +read_blob(pic_state *pic, xFILE *file, int c, struct reader_control *p) { int nbits, n; - int len, i; + int len; unsigned char *dat; - pic_blob *blob; + pic_value blob; nbits = 0; - while (isdigit(c = next(pic, port))) { + while (isdigit(c = next(pic, file))) { nbits = 10 * nbits + c - '0'; } if (nbits != 8) { - read_error(pic, "unsupported bytevector bit width", pic_list1(pic, pic_int_value(nbits))); + read_error(pic, "unsupported bytevector bit width", pic_list(pic, 1, pic_int_value(pic, nbits))); } if (c != '(') { - read_error(pic, "expected '(' character", pic_list1(pic, pic_char_value(c))); + read_error(pic, "expected '(' character", pic_list(pic, 1, pic_char_value(pic, c))); } len = 0; dat = NULL; - c = next(pic, port); - while ((c = skip(pic, port, c)) != ')') { - n = read_uinteger(pic, port, c); + c = next(pic, file); + while ((c = skip(pic, file, c)) != ')') { + n = read_uinteger(pic, file, c, p); if (n < 0 || (1 << nbits) <= n) { - read_error(pic, "invalid element in bytevector literal", pic_list1(pic, pic_int_value(n))); + read_error(pic, "invalid element in bytevector literal", pic_list(pic, 1, pic_int_value(pic, n))); } len += 1; dat = pic_realloc(pic, dat, len); dat[len - 1] = (unsigned char)n; - c = next(pic, port); + c = next(pic, file); } - blob = pic_make_blob(pic, len); - for (i = 0; i < len; ++i) { - blob->data[i] = dat[i]; - } + blob = pic_blob_value(pic, dat, len); pic_free(pic, dat); - return pic_obj_value(blob); + return blob; } static pic_value -read_undef_or_blob(pic_state *pic, struct pic_port *port, int c) +read_undef_or_blob(pic_state *pic, xFILE *file, int c, struct reader_control *p) { - if ((c = peek(pic, port)) == 'n') { - if (! expect(pic, port, "ndefined")) { - read_error(pic, "unexpected character while reading #undefined", pic_nil_value()); + if ((c = peek(pic, file)) == 'n') { + if (! expect(pic, file, "ndefined")) { + read_error(pic, "unexpected character while reading #undefined", pic_nil_value(pic)); } - return pic_undef_value(); + return pic_undef_value(pic); } if (! isdigit(c)) { - read_error(pic, "expect #undefined or #u8(...), but illegal character given", pic_list1(pic, pic_char_value(c))); + read_error(pic, "expect #undefined or #u8(...), but illegal character given", pic_list(pic, 1, pic_char_value(pic, c))); } - return read_blob(pic, port, 'u'); + return read_blob(pic, file, 'u', p); } static pic_value -read_pair(pic_state *pic, struct pic_port *port, int c) +read_pair(pic_state *pic, xFILE *file, int c, struct reader_control *p) { static const int tCLOSE = ')'; pic_value car, cdr; retry: - c = skip(pic, port, ' '); + c = skip(pic, file, ' '); if (c == tCLOSE) { - return pic_nil_value(); + return pic_nil_value(pic); } - if (c == '.' && isdelim(peek(pic, port))) { - cdr = read(pic, port, next(pic, port)); + if (c == '.' && isdelim(peek(pic, file))) { + cdr = read(pic, file, next(pic, file), p); closing: - if ((c = skip(pic, port, ' ')) != tCLOSE) { - if (pic_invalid_p(read_nullable(pic, port, c))) { + if ((c = skip(pic, file, ' ')) != tCLOSE) { + if (pic_invalid_p(pic, read_nullable(pic, file, c, p))) { goto closing; } - read_error(pic, "unmatched parenthesis", pic_nil_value()); + read_error(pic, "unmatched parenthesis", pic_nil_value(pic)); } return cdr; } else { - car = read_nullable(pic, port, c); + car = read_nullable(pic, file, c, p); - if (pic_invalid_p(car)) { + if (pic_invalid_p(pic, car)) { goto retry; } - cdr = read_pair(pic, port, '('); + cdr = read_pair(pic, file, '(', p); return pic_cons(pic, car, cdr); } } static pic_value -read_vector(pic_state *pic, struct pic_port *port, int c) +read_vector(pic_state *pic, xFILE *file, int c, struct reader_control *p) { - pic_value list, it, elem; - pic_vec *vec; + pic_value list, it, elem, vec; int i = 0; - list = read(pic, port, c); + list = read(pic, file, c, p); - vec = pic_make_vec(pic, pic_length(pic, list)); + vec = pic_make_vec(pic, pic_length(pic, list), NULL); pic_for_each (elem, list, it) { - vec->data[i++] = elem; + pic_vec_set(pic, vec, i++, elem); } - return pic_obj_value(vec); + return vec; } static pic_value -read_label_set(pic_state *pic, struct pic_port *port, int i) +read_label_set(pic_state *pic, xFILE *file, int i, struct reader_control *p) { - khash_t(read) *h = &pic->reader.labels; + khash_t(read) *h = &p->labels; pic_value val; - int c, ret; - khiter_t it; + int c, ret, it; it = kh_put(read, h, i, &ret); - switch ((c = skip(pic, port, ' '))) { + switch ((c = skip(pic, file, ' '))) { case '(': { pic_value tmp; - kh_val(h, it) = val = pic_cons(pic, pic_undef_value(), pic_undef_value()); + kh_val(h, it) = val = pic_cons(pic, pic_undef_value(pic), pic_undef_value(pic)); - tmp = read(pic, port, c); - pic_pair_ptr(val)->car = pic_car(pic, tmp); - pic_pair_ptr(val)->cdr = pic_cdr(pic, tmp); + tmp = read(pic, file, c, p); + pic_pair_ptr(pic, val)->car = pic_car(pic, tmp); + pic_pair_ptr(pic, val)->cdr = pic_cdr(pic, tmp); return val; } @@ -635,20 +648,20 @@ read_label_set(pic_state *pic, struct pic_port *port, int i) { bool vect; - if (peek(pic, port) == '(') { + if (peek(pic, file) == '(') { vect = true; } else { vect = false; } if (vect) { - pic_vec *tmp; + pic_value tmp; - kh_val(h, it) = val = pic_obj_value(pic_make_vec(pic, 0)); + kh_val(h, it) = val = pic_make_vec(pic, 0, NULL); - tmp = pic_vec_ptr(read(pic, port, c)); - PIC_SWAP(pic_value *, tmp->data, pic_vec_ptr(val)->data); - PIC_SWAP(int, tmp->len, pic_vec_ptr(val)->len); + tmp = read(pic, file, c, p); + PIC_SWAP(pic_value *, pic_vec_ptr(pic, tmp)->data, pic_vec_ptr(pic, val)->data); + PIC_SWAP(int, pic_vec_ptr(pic, tmp)->len, pic_vec_ptr(pic, val)->len); return val; } @@ -657,7 +670,7 @@ read_label_set(pic_state *pic, struct pic_port *port, int i) } default: { - kh_val(h, it) = val = read(pic, port, c); + kh_val(h, it) = val = read(pic, file, c, p); return val; } @@ -665,85 +678,85 @@ read_label_set(pic_state *pic, struct pic_port *port, int i) } static pic_value -read_label_ref(pic_state *pic, struct pic_port PIC_UNUSED(*port), int i) +read_label_ref(pic_state *pic, xFILE *PIC_UNUSED(file), int i, struct reader_control *p) { - khash_t(read) *h = &pic->reader.labels; - khiter_t it; + khash_t(read) *h = &p->labels; + int it; it = kh_get(read, h, i); if (it == kh_end(h)) { - read_error(pic, "label of given index not defined", pic_list1(pic, pic_int_value(i))); + read_error(pic, "label of given index not defined", pic_list(pic, 1, pic_int_value(pic, i))); } return kh_val(h, it); } static pic_value -read_label(pic_state *pic, struct pic_port *port, int c) +read_label(pic_state *pic, xFILE *file, int c, struct reader_control *p) { int i; i = 0; do { i = i * 10 + c - '0'; - } while (isdigit(c = next(pic, port))); + } while (isdigit(c = next(pic, file))); if (c == '=') { - return read_label_set(pic, port, i); + return read_label_set(pic, file, i, p); } if (c == '#') { - return read_label_ref(pic, port, i); + return read_label_ref(pic, file, i, p); } - read_error(pic, "broken label expression", pic_nil_value()); + read_error(pic, "broken label expression", pic_nil_value(pic)); } static pic_value -read_unmatch(pic_state *pic, struct pic_port PIC_UNUSED(*port), int PIC_UNUSED(c)) +read_unmatch(pic_state *pic, xFILE *PIC_UNUSED(file), int PIC_UNUSED(c), struct reader_control *PIC_UNUSED(p)) { - read_error(pic, "unmatched parenthesis", pic_nil_value()); + read_error(pic, "unmatched parenthesis", pic_nil_value(pic)); } static pic_value -read_dispatch(pic_state *pic, struct pic_port *port, int c) +read_dispatch(pic_state *pic, xFILE *file, int c, struct reader_control *p) { - c = next(pic, port); + c = next(pic, file); if (c == EOF) { - read_error(pic, "unexpected EOF", pic_nil_value()); + read_error(pic, "unexpected EOF", pic_nil_value(pic)); } - if (pic->reader.dispatch[c] == NULL) { - read_error(pic, "invalid character at the seeker head", pic_list1(pic, pic_char_value(c))); + if (reader_dispatch[c] == NULL) { + read_error(pic, "invalid character at the seeker head", pic_list(pic, 1, pic_char_value(pic, c))); } - return pic->reader.dispatch[c](pic, port, c); + return reader_dispatch[c](pic, file, c, p); } static pic_value -read_nullable(pic_state *pic, struct pic_port *port, int c) +read_nullable(pic_state *pic, xFILE *file, int c, struct reader_control *p) { - c = skip(pic, port, c); + c = skip(pic, file, c); if (c == EOF) { - read_error(pic, "unexpected EOF", pic_nil_value()); + read_error(pic, "unexpected EOF", pic_nil_value(pic)); } - if (pic->reader.table[c] == NULL) { - read_error(pic, "invalid character at the seeker head", pic_list1(pic, pic_char_value(c))); + if (reader_table[c] == NULL) { + read_error(pic, "invalid character at the seeker head", pic_list(pic, 1, pic_char_value(pic, c))); } - return pic->reader.table[c](pic, port, c); + return reader_table[c](pic, file, c, p); } static pic_value -read(pic_state *pic, struct pic_port *port, int c) +read(pic_state *pic, xFILE *file, int c, struct reader_control *p) { pic_value val; retry: - val = read_nullable(pic, port, c); + val = read_nullable(pic, file, c, p); - if (pic_invalid_p(val)) { - c = next(pic, port); + if (pic_invalid_p(pic, val)) { + c = next(pic, file); goto retry; } @@ -751,104 +764,107 @@ read(pic_state *pic, struct pic_port *port, int c) } static void -reader_table_init(pic_reader *reader) +reader_table_init(void) { int c; - reader->table[0] = NULL; + for (c = 0; c < 256; ++c) { + reader_table[c] = NULL; + } + for (c = 0; c < 256; ++c) { + reader_dispatch[c] = NULL; + } /* default reader */ for (c = 1; c < 256; ++c) { - reader->table[c] = read_symbol; + reader_table[c] = read_symbol; } - reader->table[')'] = read_unmatch; - reader->table[';'] = read_comment; - reader->table['\''] = read_quote; - reader->table['`'] = read_quasiquote; - reader->table[','] = read_unquote; - reader->table['"'] = read_string; - reader->table['|'] = read_pipe; - reader->table['+'] = read_plus; - reader->table['-'] = read_minus; - reader->table['('] = read_pair; - reader->table['#'] = read_dispatch; + reader_table[')'] = read_unmatch; + reader_table[';'] = read_comment; + reader_table['\''] = read_quote; + reader_table['`'] = read_quasiquote; + reader_table[','] = read_unquote; + reader_table['"'] = read_string; + reader_table['|'] = read_pipe; + reader_table['+'] = read_plus; + reader_table['-'] = read_minus; + reader_table['('] = read_pair; + reader_table['#'] = read_dispatch; /* read number */ for (c = '0'; c <= '9'; ++c) { - reader->table[c] = read_number; + reader_table[c] = read_number; } - reader->dispatch['!'] = read_directive; - reader->dispatch['|'] = read_block_comment; - reader->dispatch[';'] = read_datum_comment; - reader->dispatch['t'] = read_true; - reader->dispatch['f'] = read_false; - reader->dispatch['\''] = read_syntax_quote; - reader->dispatch['`'] = read_syntax_quasiquote; - reader->dispatch[','] = read_syntax_unquote; - reader->dispatch['\\'] = read_char; - reader->dispatch['('] = read_vector; - reader->dispatch['u'] = read_undef_or_blob; + reader_dispatch['!'] = read_directive; + reader_dispatch['|'] = read_block_comment; + reader_dispatch[';'] = read_datum_comment; + reader_dispatch['t'] = read_true; + reader_dispatch['f'] = read_false; + reader_dispatch['\''] = read_syntax_quote; + reader_dispatch['`'] = read_syntax_quasiquote; + reader_dispatch[','] = read_syntax_unquote; + reader_dispatch['\\'] = read_char; + reader_dispatch['('] = read_vector; + reader_dispatch['u'] = read_undef_or_blob; /* read labels */ for (c = '0'; c <= '9'; ++c) { - reader->dispatch[c] = read_label; + reader_dispatch[c] = read_label; } } -void -pic_reader_init(pic_state *pic) +static void +reader_init(pic_state *PIC_UNUSED(pic), struct reader_control *p) { - int c; - - pic->reader.typecase = PIC_CASE_DEFAULT; - kh_init(read, &pic->reader.labels); - - for (c = 0; c < 256; ++c) { - pic->reader.table[c] = NULL; - } - - for (c = 0; c < 256; ++c) { - pic->reader.dispatch[c] = NULL; - } - - reader_table_init(&pic->reader); + p->typecase = CASE_DEFAULT; + kh_init(read, &p->labels); } -void -pic_reader_destroy(pic_state *pic) +static void +reader_destroy(pic_state *pic, struct reader_control *p) { - kh_destroy(read, &pic->reader.labels); + kh_destroy(read, &p->labels); } pic_value -pic_read(pic_state *pic, struct pic_port *port) +pic_read(pic_state *pic, pic_value port) { - size_t ai = pic_gc_arena_preserve(pic); + struct reader_control p; + size_t ai = pic_enter(pic); pic_value val; + xFILE *file = pic_fileno(pic, port); int c; - while ((c = skip(pic, port, next(pic, port))) != EOF) { - val = read_nullable(pic, port, c); + reader_init(pic, &p); - if (! pic_invalid_p(val)) { - break; + pic_try { + while ((c = skip(pic, file, next(pic, file))) != EOF) { + val = read_nullable(pic, file, c, &p); + + if (! pic_invalid_p(pic, val)) { + break; + } + pic_leave(pic, ai); + } + if (c == EOF) { + val = pic_eof_object(pic); } - pic_gc_arena_restore(pic, ai); } - if (c == EOF) { - return pic_eof_object(); + pic_catch { + reader_destroy(pic, &p); + pic_raise(pic, pic_err(pic)); } - pic_gc_arena_restore(pic, ai); - return pic_gc_protect(pic, val); + pic_leave(pic, ai); + return pic_protect(pic, val); } pic_value pic_read_cstr(pic_state *pic, const char *str) { - struct pic_port *port = pic_open_input_string(pic, str); + pic_value port = pic_open_port(pic, xfopen_buf(pic, str, strlen(str), "r")); pic_value form; pic_try { @@ -856,7 +872,7 @@ pic_read_cstr(pic_state *pic, const char *str) } pic_catch { pic_close_port(pic, port); - pic_raise(pic, pic->err); + pic_raise(pic, pic_err(pic)); } pic_close_port(pic, port); @@ -867,7 +883,7 @@ pic_read_cstr(pic_state *pic, const char *str) static pic_value pic_read_read(pic_state *pic) { - struct pic_port *port = pic_stdin(pic); + pic_value port = pic_stdin(pic); pic_get_args(pic, "|p", &port); @@ -877,5 +893,7 @@ pic_read_read(pic_state *pic) void pic_init_read(pic_state *pic) { + reader_table_init(); + pic_defun(pic, "read", pic_read_read); } diff --git a/extlib/benz/record.c b/extlib/benz/record.c index 301b9a12..36a9dc79 100644 --- a/extlib/benz/record.c +++ b/extlib/benz/record.c @@ -3,29 +3,18 @@ */ #include "picrin.h" +#include "picrin/private/object.h" -struct pic_record * +pic_value pic_make_rec(pic_state *pic, pic_value type, pic_value datum) { - struct pic_record *rec; + struct record *rec; - rec = (struct pic_record *)pic_obj_alloc(pic, sizeof(struct pic_record), PIC_TT_RECORD); + rec = (struct record *)pic_obj_alloc(pic, sizeof(struct record), PIC_TYPE_RECORD); rec->type = type; rec->datum = datum; - return rec; -} - -pic_value -pic_rec_type(pic_state PIC_UNUSED(*pic), struct pic_record *rec) -{ - return rec->type; -} - -pic_value -pic_rec_datum(pic_state PIC_UNUSED(*pic), struct pic_record *rec) -{ - return rec->datum; + return pic_obj_value(rec); } static pic_value @@ -35,7 +24,7 @@ pic_rec_make_record(pic_state *pic) pic_get_args(pic, "oo", &type, &datum); - return pic_obj_value(pic_make_rec(pic, type, datum)); + return pic_make_rec(pic, type, datum); } static pic_value @@ -45,27 +34,27 @@ pic_rec_record_p(pic_state *pic) pic_get_args(pic, "o", &rec); - return pic_bool_value(pic_rec_p(rec)); + return pic_bool_value(pic, pic_rec_p(pic, rec)); } static pic_value pic_rec_record_type(pic_state *pic) { - struct pic_record *rec; + pic_value rec; pic_get_args(pic, "r", &rec); - return pic_rec_type(pic, rec); + return pic_rec_ptr(pic, rec)->type; } static pic_value pic_rec_record_datum(pic_state *pic) { - struct pic_record *rec; + pic_value rec; pic_get_args(pic, "r", &rec); - return pic_rec_datum(pic, rec); + return pic_rec_ptr(pic, rec)->datum; } void diff --git a/extlib/benz/state.c b/extlib/benz/state.c index a84dcf38..bbbc28d7 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -3,6 +3,9 @@ */ #include "picrin.h" +#include "picrin/extra.h" +#include "picrin/private/object.h" +#include "picrin/private/state.h" static void pic_init_features(pic_state *pic) @@ -65,7 +68,7 @@ pic_init_features(pic_state *pic) void pic_add_feature(pic_state *pic, const char *feature) { - pic_push(pic, pic_obj_value(pic_intern_cstr(pic, feature)), pic->features); + pic_push(pic, pic_intern_cstr(pic, feature), pic->features); } static pic_value @@ -77,16 +80,16 @@ pic_features(pic_state *pic) } #define import_builtin_syntax(name) do { \ - pic_sym *nick, *real; \ + pic_value nick, real; \ nick = pic_intern_lit(pic, "builtin:" name); \ real = pic_intern_lit(pic, name); \ - pic_put_identifier(pic, (pic_id *)nick, real, pic->lib->env); \ + pic_put_identifier(pic, nick, real, pic_obj_value(pic->lib->env)); \ } while (0) #define declare_vm_procedure(name) do { \ - pic_sym *sym; \ + pic_value sym; \ sym = pic_intern_lit(pic, name); \ - pic_put_identifier(pic, (pic_id *)sym, sym, pic->lib->env); \ + pic_put_identifier(pic, sym, sym, pic_obj_value(pic->lib->env)); \ } while (0) void pic_init_bool(pic_state *); @@ -115,83 +118,78 @@ extern const char pic_boot[][80]; static void pic_init_core(pic_state *pic) { - struct pic_box *pic_vm_gref_slot(pic_state *, pic_sym *); + size_t ai; pic_init_features(pic); - pic_deflibrary (pic, "(picrin base)") { - size_t ai = pic_gc_arena_preserve(pic); + pic_deflibrary(pic, "picrin.base"); -#define DONE pic_gc_arena_restore(pic, ai); + ai = pic_enter(pic); - import_builtin_syntax("define"); - import_builtin_syntax("set!"); - import_builtin_syntax("quote"); - import_builtin_syntax("lambda"); - import_builtin_syntax("if"); - import_builtin_syntax("begin"); - import_builtin_syntax("define-macro"); +#define DONE pic_leave(pic, ai); - declare_vm_procedure("cons"); - declare_vm_procedure("car"); - declare_vm_procedure("cdr"); - declare_vm_procedure("null?"); - declare_vm_procedure("symbol?"); - declare_vm_procedure("pair?"); - declare_vm_procedure("+"); - declare_vm_procedure("-"); - declare_vm_procedure("*"); - declare_vm_procedure("/"); - declare_vm_procedure("="); - declare_vm_procedure("<"); - declare_vm_procedure(">"); - declare_vm_procedure("<="); - declare_vm_procedure(">="); - declare_vm_procedure("not"); + import_builtin_syntax("define"); + import_builtin_syntax("set!"); + import_builtin_syntax("quote"); + import_builtin_syntax("lambda"); + import_builtin_syntax("if"); + import_builtin_syntax("begin"); + import_builtin_syntax("define-macro"); - DONE; + declare_vm_procedure("cons"); + declare_vm_procedure("car"); + declare_vm_procedure("cdr"); + declare_vm_procedure("null?"); + declare_vm_procedure("symbol?"); + declare_vm_procedure("pair?"); + declare_vm_procedure("+"); + declare_vm_procedure("-"); + declare_vm_procedure("*"); + declare_vm_procedure("/"); + declare_vm_procedure("="); + declare_vm_procedure("<"); + declare_vm_procedure(">"); + declare_vm_procedure("<="); + declare_vm_procedure(">="); + declare_vm_procedure("not"); - pic_init_bool(pic); DONE; - pic_init_pair(pic); DONE; - pic_init_port(pic); DONE; - pic_init_number(pic); DONE; - pic_init_proc(pic); DONE; - pic_init_symbol(pic); DONE; - pic_init_vector(pic); DONE; - pic_init_blob(pic); DONE; - pic_init_cont(pic); DONE; - pic_init_char(pic); DONE; - pic_init_error(pic); DONE; - pic_init_str(pic); DONE; - pic_init_var(pic); DONE; - pic_init_write(pic); DONE; - pic_init_read(pic); DONE; - pic_init_dict(pic); DONE; - pic_init_record(pic); DONE; - pic_init_eval(pic); DONE; - pic_init_lib(pic); DONE; - pic_init_weak(pic); DONE; + DONE; - pic_defun(pic, "features", pic_features); + pic_init_bool(pic); DONE; + pic_init_pair(pic); DONE; + pic_init_port(pic); DONE; + pic_init_number(pic); DONE; + pic_init_proc(pic); DONE; + pic_init_symbol(pic); DONE; + pic_init_vector(pic); DONE; + pic_init_blob(pic); DONE; + pic_init_cont(pic); DONE; + pic_init_char(pic); DONE; + pic_init_error(pic); DONE; + pic_init_str(pic); DONE; + pic_init_var(pic); DONE; + pic_init_read(pic); DONE; + pic_init_dict(pic); DONE; + pic_init_record(pic); DONE; + pic_init_eval(pic); DONE; + pic_init_lib(pic); DONE; + pic_init_weak(pic); DONE; - pic_try { - pic_load_cstr(pic, &pic_boot[0][0]); - } - pic_catch { - pic_print_backtrace(pic, xstdout); - pic_panic(pic, ""); - } - } +#if PIC_USE_WRITE + pic_init_write(pic); DONE; +#endif + + pic_defun(pic, "features", pic_features); + + pic_load_cstr(pic, &pic_boot[0][0]); } pic_state * pic_open(pic_allocf allocf, void *userdata) { - struct pic_port *pic_make_standard_port(pic_state *, xFILE *, short); char t; pic_state *pic; - size_t ai; pic = allocf(userdata, NULL, sizeof(pic_state)); @@ -224,7 +222,7 @@ pic_open(pic_allocf allocf, void *userdata) } /* callinfo */ - pic->cibase = pic->ci = allocf(userdata, NULL, PIC_STACK_SIZE * sizeof(pic_callinfo)); + pic->cibase = pic->ci = allocf(userdata, NULL, PIC_STACK_SIZE * sizeof(struct callinfo)); pic->ciend = pic->cibase + PIC_STACK_SIZE; if (! pic->ci) { @@ -232,7 +230,7 @@ pic_open(pic_allocf allocf, void *userdata) } /* exception handler */ - pic->xpbase = pic->xp = allocf(userdata, NULL, PIC_RESCUE_SIZE * sizeof(struct pic_proc *)); + pic->xpbase = pic->xp = allocf(userdata, NULL, PIC_RESCUE_SIZE * sizeof(struct proc *)); pic->xpend = pic->xpbase + PIC_RESCUE_SIZE; if (! pic->xp) { @@ -240,7 +238,7 @@ pic_open(pic_allocf allocf, void *userdata) } /* GC arena */ - pic->arena = allocf(userdata, NULL, PIC_ARENA_SIZE * sizeof(struct pic_object *)); + pic->arena = allocf(userdata, NULL, PIC_ARENA_SIZE * sizeof(struct object *)); pic->arena_size = PIC_ARENA_SIZE; pic->arena_idx = 0; @@ -252,22 +250,22 @@ pic_open(pic_allocf allocf, void *userdata) pic->heap = pic_heap_open(pic); /* symbol table */ - kh_init(s, &pic->oblist); + kh_init(oblist, &pic->oblist); /* unique symbol count */ pic->ucnt = 0; /* global variables */ - pic->globals = NULL; + pic->globals = pic_invalid_value(pic); /* macros */ - pic->macros = NULL; + pic->macros = pic_invalid_value(pic); /* features */ - pic->features = pic_nil_value(); + pic->features = pic_nil_value(pic); /* libraries */ - pic->libs = pic_nil_value(); + kh_init(ltable, &pic->ltable); pic->lib = NULL; /* ireps */ @@ -275,89 +273,52 @@ pic_open(pic_allocf allocf, void *userdata) pic->ireps.prev = &pic->ireps; /* raised error object */ - pic->err = pic_invalid_value(); + pic->panicf = NULL; + pic->err = pic_invalid_value(pic); /* file pool */ memset(pic->files, 0, sizeof pic->files); +#if PIC_USE_STDIO + xfopen_file(pic, stdin, "r"); + xfopen_file(pic, stdout, "w"); + xfopen_file(pic, stderr, "w"); + pic->files[1].flag |= X_LNBUF; + pic->files[2].flag |= X_UNBUF; +#else + xfopen_null(pic, "r"); + xfopen_null(pic, "w"); + xfopen_null(pic, "w"); +#endif /* parameter table */ - pic->ptable = pic_nil_value(); + pic->ptable = pic_nil_value(pic); /* native stack marker */ pic->native_stack_start = &t; - ai = pic_gc_arena_preserve(pic); - -#define S(slot,name) pic->slot = pic_intern_lit(pic, name) - - S(sDEFINE, "define"); - S(sDEFINE_MACRO, "define-macro"); - S(sLAMBDA, "lambda"); - S(sIF, "if"); - S(sBEGIN, "begin"); - S(sSETBANG, "set!"); - S(sQUOTE, "quote"); - S(sQUASIQUOTE, "quasiquote"); - S(sUNQUOTE, "unquote"); - S(sUNQUOTE_SPLICING, "unquote-splicing"); - S(sSYNTAX_QUOTE, "syntax-quote"); - S(sSYNTAX_QUASIQUOTE, "syntax-quasiquote"); - S(sSYNTAX_UNQUOTE, "syntax-unquote"); - S(sSYNTAX_UNQUOTE_SPLICING, "syntax-unquote-splicing"); - S(sIMPORT, "import"); - S(sEXPORT, "export"); - S(sDEFINE_LIBRARY, "define-library"); - S(sCOND_EXPAND, "cond-expand"); - - S(sCONS, "cons"); - S(sCAR, "car"); - S(sCDR, "cdr"); - S(sNILP, "null?"); - S(sSYMBOLP, "symbol?"); - S(sPAIRP, "pair?"); - S(sADD, "+"); - S(sSUB, "-"); - S(sMUL, "*"); - S(sDIV, "/"); - S(sEQ, "="); - S(sLT, "<"); - S(sLE, "<="); - S(sGT, ">"); - S(sGE, ">="); - S(sNOT, "not"); - - pic_gc_arena_restore(pic, ai); - /* root tables */ pic->globals = pic_make_weak(pic); pic->macros = pic_make_weak(pic); /* root block */ - pic->cp = (pic_checkpoint *)pic_obj_alloc(pic, sizeof(pic_checkpoint), PIC_TT_CP); + pic->cp = (struct checkpoint *)pic_obj_alloc(pic, sizeof(struct checkpoint), PIC_TYPE_CP); pic->cp->prev = NULL; pic->cp->depth = 0; pic->cp->in = pic->cp->out = NULL; - /* reader */ - pic_reader_init(pic); - /* parameter table */ - pic->ptable = pic_cons(pic, pic_obj_value(pic_make_weak(pic)), pic->ptable); + pic->ptable = pic_cons(pic, pic_make_weak(pic), pic_nil_value(pic)); /* standard libraries */ - pic->PICRIN_BASE = pic_make_library(pic, pic_read_cstr(pic, "(picrin base)")); - pic->PICRIN_USER = pic_make_library(pic, pic_read_cstr(pic, "(picrin user)")); - pic->lib = pic->PICRIN_USER; - pic->prev_lib = NULL; - - pic_gc_arena_restore(pic, ai); + pic_make_library(pic, "picrin.user"); + pic_in_library(pic, "picrin.user"); /* turn on GC */ pic->gc_enable = true; pic_init_core(pic); - pic_gc_arena_restore(pic, ai); + pic_leave(pic, 0); /* empty arena */ return pic; @@ -376,7 +337,6 @@ pic_open(pic_allocf allocf, void *userdata) void pic_close(pic_state *pic) { - khash_t(s) *h = &pic->oblist; pic_allocf allocf = pic->allocf; /* clear out root objects */ @@ -384,26 +344,16 @@ pic_close(pic_state *pic) pic->ci = pic->cibase; pic->xp = pic->xpbase; pic->arena_idx = 0; - pic->err = pic_invalid_value(); - pic->globals = NULL; - pic->macros = NULL; - pic->features = pic_nil_value(); - pic->libs = pic_nil_value(); + pic->err = pic_invalid_value(pic); + pic->globals = pic_invalid_value(pic); + pic->macros = pic_invalid_value(pic); + pic->features = pic_nil_value(pic); + + /* free all libraries */ + kh_clear(ltable, &pic->ltable); /* free all heap objects */ - pic_gc_run(pic); - -#if 0 - { - /* FIXME */ - int i = 0; - struct pic_list *list; - for (list = pic->ireps.next; list != &pic->ireps; list = list->next) { - i++; - } - printf("%d\n", i); - } -#endif + pic_gc(pic); /* flush all xfiles */ xfflush(pic, NULL); @@ -411,16 +361,14 @@ pic_close(pic_state *pic) /* free heaps */ pic_heap_close(pic, pic->heap); - /* free reader struct */ - pic_reader_destroy(pic); - /* free runtime context */ allocf(pic->userdata, pic->stbase, 0); allocf(pic->userdata, pic->cibase, 0); allocf(pic->userdata, pic->xpbase, 0); /* free global stacks */ - kh_destroy(s, h); + kh_destroy(oblist, &pic->oblist); + kh_destroy(ltable, &pic->ltable); /* free GC arena */ allocf(pic->userdata, pic->arena, 0); diff --git a/extlib/benz/string.c b/extlib/benz/string.c index fb3d3ae9..eff041ed 100644 --- a/extlib/benz/string.c +++ b/extlib/benz/string.c @@ -3,20 +3,22 @@ */ #include "picrin.h" +#include "picrin/extra.h" +#include "picrin/private/object.h" -struct pic_chunk { +struct chunk { char *str; int refcnt; size_t len; char buf[1]; }; -struct pic_rope { +struct rope { int refcnt; size_t weight; - struct pic_chunk *chunk; + struct chunk *chunk; size_t offset; - struct pic_rope *left, *right; + struct rope *left, *right; }; #define CHUNK_INCREF(c) do { \ @@ -24,19 +26,19 @@ struct pic_rope { } while (0) #define CHUNK_DECREF(c) do { \ - struct pic_chunk *c_ = (c); \ + struct chunk *c_ = (c); \ if (! --c_->refcnt) { \ pic_free(pic, c_); \ } \ } while (0) void -pic_rope_incref(pic_state PIC_UNUSED(*pic), struct pic_rope *x) { +pic_rope_incref(pic_state *PIC_UNUSED(pic), struct rope *x) { x->refcnt++; } void -pic_rope_decref(pic_state *pic, struct pic_rope *x) { +pic_rope_decref(pic_state *pic, struct rope *x) { if (! --x->refcnt) { if (x->chunk) { CHUNK_DECREF(x->chunk); @@ -49,12 +51,12 @@ pic_rope_decref(pic_state *pic, struct pic_rope *x) { } } -static struct pic_chunk * +static struct chunk * pic_make_chunk(pic_state *pic, const char *str, size_t len) { - struct pic_chunk *c; + struct chunk *c; - c = pic_malloc(pic, offsetof(struct pic_chunk, buf) + len + 1); + c = pic_malloc(pic, offsetof(struct chunk, buf) + len + 1); c->refcnt = 1; c->str = c->buf; c->len = len; @@ -64,12 +66,12 @@ pic_make_chunk(pic_state *pic, const char *str, size_t len) return c; } -static struct pic_chunk * +static struct chunk * pic_make_chunk_lit(pic_state *pic, const char *str, size_t len) { - struct pic_chunk *c; + struct chunk *c; - c = pic_malloc(pic, sizeof(struct pic_chunk)); + c = pic_malloc(pic, sizeof(struct chunk)); c->refcnt = 1; c->str = (char *)str; c->len = len; @@ -77,12 +79,12 @@ pic_make_chunk_lit(pic_state *pic, const char *str, size_t len) return c; } -static struct pic_rope * -pic_make_rope(pic_state *pic, struct pic_chunk *c) +static struct rope * +pic_make_rope(pic_state *pic, struct chunk *c) { - struct pic_rope *x; + struct rope *x; - x = pic_malloc(pic, sizeof(struct pic_rope)); + x = pic_malloc(pic, sizeof(struct rope)); x->refcnt = 1; x->left = NULL; x->right = NULL; @@ -93,24 +95,25 @@ pic_make_rope(pic_state *pic, struct pic_chunk *c) return x; } -static pic_str * -pic_make_string(pic_state *pic, struct pic_rope *rope) +static pic_value +pic_make_str(pic_state *pic, struct rope *rope) { - pic_str *str; + struct string *str; - str = (pic_str *)pic_obj_alloc(pic, sizeof(pic_str), PIC_TT_STRING); + str = (struct string *)pic_obj_alloc(pic, sizeof(struct string), PIC_TYPE_STRING); str->rope = rope; /* delegate ownership */ - return str; + + return pic_obj_value(str); } static size_t -rope_len(struct pic_rope *x) +rope_len(struct rope *x) { return x->weight; } static char -rope_at(struct pic_rope *x, size_t i) +rope_at(struct rope *x, size_t i) { while (i < x->weight) { if (x->chunk) { @@ -119,19 +122,19 @@ rope_at(struct pic_rope *x, size_t i) if (i < x->left->weight) { x = x->left; } else { - x = x->right; i -= x->left->weight; + x = x->right; } } return -1; } -static struct pic_rope * -rope_cat(pic_state *pic, struct pic_rope *x, struct pic_rope *y) +static struct rope * +rope_cat(pic_state *pic, struct rope *x, struct rope *y) { - struct pic_rope *z; + struct rope *z; - z = pic_malloc(pic, sizeof(struct pic_rope)); + z = pic_malloc(pic, sizeof(struct rope)); z->refcnt = 1; z->left = x; z->right = y; @@ -145,8 +148,8 @@ rope_cat(pic_state *pic, struct pic_rope *x, struct pic_rope *y) return z; } -static struct pic_rope * -rope_sub(pic_state *pic, struct pic_rope *x, size_t i, size_t j) +static struct rope * +rope_sub(pic_state *pic, struct rope *x, size_t i, size_t j) { assert(i <= j); assert(j <= x->weight); @@ -157,9 +160,9 @@ rope_sub(pic_state *pic, struct pic_rope *x, size_t i, size_t j) } if (x->chunk) { - struct pic_rope *y; + struct rope *y; - y = pic_malloc(pic, sizeof(struct pic_rope)); + y = pic_malloc(pic, sizeof(struct rope)); y->refcnt = 1; y->left = NULL; y->right = NULL; @@ -179,7 +182,7 @@ rope_sub(pic_state *pic, struct pic_rope *x, size_t i, size_t j) return rope_sub(pic, x->right, i - x->left->weight, j - x->left->weight); } else { - struct pic_rope *r, *l; + struct rope *r, *l; l = rope_sub(pic, x->left, i, x->left->weight); r = rope_sub(pic, x->right, 0, j - x->left->weight); @@ -193,7 +196,7 @@ rope_sub(pic_state *pic, struct pic_rope *x, size_t i, size_t j) } static void -flatten(pic_state *pic, struct pic_rope *x, struct pic_chunk *c, size_t offset) +flatten(pic_state *pic, struct rope *x, struct chunk *c, size_t offset) { if (x->chunk) { memcpy(c->str + offset, x->chunk->str + x->offset, x->weight); @@ -216,15 +219,15 @@ flatten(pic_state *pic, struct pic_rope *x, struct pic_chunk *c, size_t offset) } static const char * -rope_cstr(pic_state *pic, struct pic_rope *x) +rope_cstr(pic_state *pic, struct rope *x) { - struct pic_chunk *c; + struct chunk *c; if (x->chunk && x->offset == 0 && x->weight == x->chunk->len) { return x->chunk->str; /* reuse cached chunk */ } - c = pic_malloc(pic, offsetof(struct pic_chunk, buf) + x->weight + 1); + c = pic_malloc(pic, offsetof(struct chunk, buf) + x->weight + 1); c->refcnt = 1; c->len = x->weight; c->str = c->buf; @@ -236,10 +239,18 @@ rope_cstr(pic_state *pic, struct pic_rope *x) return c->str; } -pic_str * -pic_make_str(pic_state *pic, const char *str, int len) +static void +str_update(pic_state *pic, pic_value dst, pic_value src) { - struct pic_chunk *c; + pic_rope_incref(pic, pic_str_ptr(pic, src)->rope); + pic_rope_decref(pic, pic_str_ptr(pic, dst)->rope); + pic_str_ptr(pic, dst)->rope = pic_str_ptr(pic, src)->rope; +} + +pic_value +pic_str_value(pic_state *pic, const char *str, int len) +{ + struct chunk *c; if (len > 0) { c = pic_make_chunk(pic, str, len); @@ -249,52 +260,52 @@ pic_make_str(pic_state *pic, const char *str, int len) } c = pic_make_chunk_lit(pic, str, -len); } - return pic_make_string(pic, pic_make_rope(pic, c)); + return pic_make_str(pic, pic_make_rope(pic, c)); } int -pic_str_len(pic_str *str) +pic_str_len(pic_state *PIC_UNUSED(pic), pic_value str) { - return rope_len(str->rope); + return rope_len(pic_str_ptr(pic, str)->rope); } char -pic_str_ref(pic_state *pic, pic_str *str, int i) +pic_str_ref(pic_state *pic, pic_value str, int i) { int c; - c = rope_at(str->rope, i); + c = rope_at(pic_str_ptr(pic, str)->rope, i); if (c == -1) { - pic_errorf(pic, "index out of range %d", i); + pic_error(pic, "index out of range", 1, pic_int_value(pic, i)); } return (char)c; } -pic_str * -pic_str_cat(pic_state *pic, pic_str *a, pic_str *b) +pic_value +pic_str_cat(pic_state *pic, pic_value a, pic_value b) { - return pic_make_string(pic, rope_cat(pic, a->rope, b->rope)); + return pic_make_str(pic, rope_cat(pic, pic_str_ptr(pic, a)->rope, pic_str_ptr(pic, b)->rope)); } -pic_str * -pic_str_sub(pic_state *pic, pic_str *str, int s, int e) +pic_value +pic_str_sub(pic_state *pic, pic_value str, int s, int e) { - return pic_make_string(pic, rope_sub(pic, str->rope, s, e)); + return pic_make_str(pic, rope_sub(pic, pic_str_ptr(pic, str)->rope, s, e)); } int -pic_str_cmp(pic_state *pic, pic_str *str1, pic_str *str2) +pic_str_cmp(pic_state *pic, pic_value str1, pic_value str2) { - return strcmp(pic_str_cstr(pic, str1), pic_str_cstr(pic, str2)); + return strcmp(pic_str(pic, str1), pic_str(pic, str2)); } int -pic_str_hash(pic_state *pic, pic_str *str) +pic_str_hash(pic_state *pic, pic_value str) { const char *s; int h = 0; - s = pic_str_cstr(pic, str); + s = pic_str(pic, str); while (*s) { h = (h << 5) - h + *s++; } @@ -302,100 +313,36 @@ pic_str_hash(pic_state *pic, pic_str *str) } const char * -pic_str_cstr(pic_state *pic, pic_str *str) +pic_str(pic_state *pic, pic_value str) { - return rope_cstr(pic, str->rope); + return rope_cstr(pic, pic_str_ptr(pic, str)->rope); } -static void -pic_vfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap) +pic_value +pic_vstrf_value(pic_state *pic, const char *fmt, va_list ap) { - char c; + pic_value str; + xFILE *file; + const char *buf; + int len; - while ((c = *fmt++) != '\0') { - switch (c) { - default: - xfputc(pic, c, file); - break; - case '%': - c = *fmt++; - if (! c) - goto exit; - switch (c) { - default: - xfputc(pic, c, file); - break; - case '%': - xfputc(pic, '%', file); - break; - case 'c': - xfprintf(pic, file, "%c", va_arg(ap, int)); - break; - case 's': - xfprintf(pic, file, "%s", va_arg(ap, const char *)); - break; - case 'd': - xfprintf(pic, file, "%d", va_arg(ap, int)); - break; - case 'p': - xfprintf(pic, file, "%p", va_arg(ap, void *)); - break; - case 'f': - xfprintf(pic, file, "%f", va_arg(ap, double)); - break; - } - break; - case '~': - c = *fmt++; - if (! c) - goto exit; - switch (c) { - default: - xfputc(pic, c, file); - break; - case '~': - xfputc(pic, '~', file); - break; - case '%': - xfputc(pic, '\n', file); - break; - case 'a': - pic_fdisplay(pic, va_arg(ap, pic_value), file); - break; - case 's': - pic_fwrite(pic, va_arg(ap, pic_value), file); - break; - } - break; - } - } - exit: - return; -} + file = xfopen_buf(pic, NULL, 0, "w"); -pic_str * -pic_vformat(pic_state *pic, const char *fmt, va_list ap) -{ - struct pic_port *port; - pic_str *str; - - port = pic_open_output_string(pic); - - pic_vfformat(pic, port->file, fmt, ap); - str = pic_get_output_string(pic, port); - - pic_close_port(pic, port); + xvfprintf(pic, file, fmt, ap); + xfget_buf(pic, file, &buf, &len); + str = pic_str_value(pic, buf, len); + xfclose(pic, file); return str; } -pic_str * -pic_format(pic_state *pic, const char *fmt, ...) +pic_value +pic_strf_value(pic_state *pic, const char *fmt, ...) { va_list ap; - pic_str *str; + pic_value str; va_start(ap, fmt); - str = pic_vformat(pic, fmt, ap); + str = pic_vstrf_value(pic, fmt, ap); va_end(ap); return str; @@ -408,7 +355,7 @@ pic_str_string_p(pic_state *pic) pic_get_args(pic, "o", &v); - return pic_bool_value(pic_str_p(v)); + return pic_bool_value(pic, pic_str_p(pic, v)); } static pic_value @@ -416,22 +363,18 @@ pic_str_string(pic_state *pic) { int argc, i; pic_value *argv; - pic_str *str; char *buf; pic_get_args(pic, "*", &argc, &argv); - buf = pic_malloc(pic, argc); + buf = pic_alloca(pic, argc); for (i = 0; i < argc; ++i) { pic_assert_type(pic, argv[i], char); - buf[i] = pic_char(argv[i]); + buf[i] = pic_char(pic, argv[i]); } - str = pic_make_str(pic, buf, argc); - pic_free(pic, buf); - - return pic_obj_value(str); + return pic_str_value(pic, buf, argc); } static pic_value @@ -440,62 +383,87 @@ pic_str_make_string(pic_state *pic) int len; char c = ' '; char *buf; - pic_value ret; pic_get_args(pic, "i|c", &len, &c); - buf = pic_malloc(pic, len); + if (len < 0) { + pic_error(pic, "make-string: negative length given", 1, pic_int_value(pic, len)); + } + + buf = pic_alloca(pic, len); + memset(buf, c, len); - ret = pic_obj_value(pic_make_str(pic, buf, len)); - - pic_free(pic, buf); - return ret; + return pic_str_value(pic, buf, len); } static pic_value pic_str_string_length(pic_state *pic) { - pic_str *str; + pic_value str; pic_get_args(pic, "s", &str); - return pic_int_value(pic_str_len(str)); + return pic_int_value(pic, pic_str_len(pic, str)); } static pic_value pic_str_string_ref(pic_state *pic) { - pic_str *str; + pic_value str; int k; pic_get_args(pic, "si", &str, &k); - return pic_char_value(pic_str_ref(pic, str, k)); + VALID_INDEX(pic, pic_str_len(pic, str), k); + + return pic_char_value(pic, pic_str_ref(pic, str, k)); } -#define DEFINE_STRING_CMP(name, op) \ - static pic_value \ - pic_str_string_##name(pic_state *pic) \ - { \ - int argc, i; \ - pic_value *argv; \ - \ - pic_get_args(pic, "*", &argc, &argv); \ - \ - if (argc < 1 || ! pic_str_p(argv[0])) { \ - return pic_false_value(); \ - } \ - \ - for (i = 1; i < argc; ++i) { \ - if (! pic_str_p(argv[i])) { \ - return pic_false_value(); \ - } \ - if (! (pic_str_cmp(pic, pic_str_ptr(argv[i-1]), pic_str_ptr(argv[i])) op 0)) { \ - return pic_false_value(); \ - } \ - } \ - return pic_true_value(); \ +static pic_value +pic_str_string_set(pic_state *pic) +{ + pic_value str, x, y, z; + char c; + int k, len; + + pic_get_args(pic, "sic", &str, &k, &c); + + len = pic_str_len(pic, str); + + VALID_INDEX(pic, len, k); + + x = pic_str_sub(pic, str, 0, k); + y = pic_str_value(pic, &c, 1); + z = pic_str_sub(pic, str, k + 1, len); + + str_update(pic, str, pic_str_cat(pic, x, pic_str_cat(pic, y, z))); + + return pic_undef_value(pic); +} + +#define DEFINE_STRING_CMP(name, op) \ + static pic_value \ + pic_str_string_##name(pic_state *pic) \ + { \ + int argc, i; \ + pic_value *argv; \ + \ + pic_get_args(pic, "*", &argc, &argv); \ + \ + if (argc < 1 || ! pic_str_p(pic, argv[0])) { \ + return pic_false_value(pic); \ + } \ + \ + for (i = 1; i < argc; ++i) { \ + if (! pic_str_p(pic, argv[i])) { \ + return pic_false_value(pic); \ + } \ + if (! (pic_str_cmp(pic, argv[i-1], argv[i]) op 0)) { \ + return pic_false_value(pic); \ + } \ + } \ + return pic_true_value(pic); \ } DEFINE_STRING_CMP(eq, ==) @@ -507,12 +475,12 @@ DEFINE_STRING_CMP(ge, >=) static pic_value pic_str_string_copy(pic_state *pic) { - pic_str *str; + pic_value str; int n, start, end, len; n = pic_get_args(pic, "s|ii", &str, &start, &end); - len = pic_str_len(str); + len = pic_str_len(pic, str); switch (n) { case 1: @@ -521,10 +489,70 @@ pic_str_string_copy(pic_state *pic) end = len; } - if (start < 0 || end > len || end < start) - pic_errorf(pic, "string-copy: invalid index"); + VALID_RANGE(pic, len, start, end); - return pic_obj_value(pic_str_sub(pic, str, start, end)); + return pic_str_sub(pic, str, start, end); +} + +static pic_value +pic_str_string_copy_ip(pic_state *pic) +{ + pic_value to, from, x, y, z; + int n, at, start, end, tolen, fromlen; + + n = pic_get_args(pic, "sis|ii", &to, &at, &from, &start, &end); + + tolen = pic_str_len(pic, to); + fromlen = pic_str_len(pic, from); + + switch (n) { + case 3: + start = 0; + case 4: + end = fromlen; + } + + VALID_ATRANGE(pic, tolen, at, fromlen, start, end); + + x = pic_str_sub(pic, to, 0, at); + y = pic_str_sub(pic, from, start, end); + z = pic_str_sub(pic, to, at + end - start, tolen); + + str_update(pic, to, pic_str_cat(pic, x, pic_str_cat(pic, y, z))); + + return pic_undef_value(pic); +} + +static pic_value +pic_str_string_fill_ip(pic_state *pic) +{ + pic_value str, x, y, z; + char c, *buf; + int n, start, end, len; + + n = pic_get_args(pic, "sc|ii", &str, &c, &start, &end); + + len = pic_str_len(pic, str); + + switch (n) { + case 2: + start = 0; + case 3: + end = len; + } + + VALID_RANGE(pic, len, start, end); + + buf = pic_alloca(pic, end - start); + memset(buf, c, end - start); + + x = pic_str_sub(pic, str, 0, start); + y = pic_str_value(pic, buf, end - start); + z = pic_str_sub(pic, str, end, len); + + str_update(pic, str, pic_str_cat(pic, x, pic_str_cat(pic, y, z))); + + return pic_undef_value(pic); } static pic_value @@ -532,162 +560,133 @@ pic_str_string_append(pic_state *pic) { int argc, i; pic_value *argv; - pic_str *str; + pic_value str = pic_lit_value(pic, ""); pic_get_args(pic, "*", &argc, &argv); - str = pic_make_lit(pic, ""); for (i = 0; i < argc; ++i) { - if (! pic_str_p(argv[i])) { - pic_errorf(pic, "type error"); - } - str = pic_str_cat(pic, str, pic_str_ptr(argv[i])); + pic_assert_type(pic, argv[i], str); + str = pic_str_cat(pic, str, argv[i]); } - return pic_obj_value(str); + return str; } static pic_value pic_str_string_map(pic_state *pic) { - struct pic_proc *proc; - pic_value *argv, vals, val; + pic_value proc, *argv, vals, val; int argc, i, len, j; - pic_str *str; char *buf; pic_get_args(pic, "l*", &proc, &argc, &argv); if (argc == 0) { - pic_errorf(pic, "string-map: one or more strings expected, but got zero"); - } else { - pic_assert_type(pic, argv[0], str); - len = pic_str_len(pic_str_ptr(argv[0])); + pic_error(pic, "string-map: one or more strings expected, but got zero", 0); } - for (i = 1; i < argc; ++i) { + + len = INT_MAX; + for (i = 0; i < argc; ++i) { + int l; pic_assert_type(pic, argv[i], str); - - len = len < pic_str_len(pic_str_ptr(argv[i])) - ? len - : pic_str_len(pic_str_ptr(argv[i])); + l = pic_str_len(pic, argv[i]); + len = len < l ? len : l; } - buf = pic_malloc(pic, len); - pic_try { - for (i = 0; i < len; ++i) { - vals = pic_nil_value(); - for (j = 0; j < argc; ++j) { - pic_push(pic, pic_char_value(pic_str_ref(pic, pic_str_ptr(argv[j]), i)), vals); - } - val = pic_apply_list(pic, proc, vals); + buf = pic_alloca(pic, len); - pic_assert_type(pic, val, char); - buf[i] = pic_char(val); + for (i = 0; i < len; ++i) { + vals = pic_nil_value(pic); + for (j = 0; j < argc; ++j) { + pic_push(pic, pic_char_value(pic, pic_str_ref(pic, argv[j], i)), vals); } - str = pic_make_str(pic, buf, len); - } - pic_catch { - pic_free(pic, buf); - pic_raise(pic, pic->err); - } + vals = pic_reverse(pic, vals); + val = pic_funcall(pic, "picrin.base", "apply", 2, proc, vals); - pic_free(pic, buf); + pic_assert_type(pic, val, char); - return pic_obj_value(str); + buf[i] = pic_char(pic, val); + } + return pic_str_value(pic, buf, len); } static pic_value pic_str_string_for_each(pic_state *pic) { - struct pic_proc *proc; - int argc, len, i, j; - pic_value *argv, vals; + pic_value proc, *argv, vals; + int argc, i, len, j; pic_get_args(pic, "l*", &proc, &argc, &argv); if (argc == 0) { - pic_errorf(pic, "string-map: one or more strings expected, but got zero"); - } else { - pic_assert_type(pic, argv[0], str); - len = pic_str_len(pic_str_ptr(argv[0])); + pic_error(pic, "string-map: one or more strings expected, but got zero", 0); } - for (i = 1; i < argc; ++i) { - pic_assert_type(pic, argv[i], str); - len = len < pic_str_len(pic_str_ptr(argv[i])) - ? len - : pic_str_len(pic_str_ptr(argv[i])); + len = INT_MAX; + for (i = 0; i < argc; ++i) { + int l; + pic_assert_type(pic, argv[i], str); + l = pic_str_len(pic, argv[i]); + len = len < l ? len : l; } for (i = 0; i < len; ++i) { - vals = pic_nil_value(); + vals = pic_nil_value(pic); for (j = 0; j < argc; ++j) { - pic_push(pic, pic_char_value(pic_str_ref(pic, pic_str_ptr(argv[j]), i)), vals); + pic_push(pic, pic_char_value(pic, pic_str_ref(pic, argv[j], i)), vals); } - pic_apply_list(pic, proc, vals); + vals = pic_reverse(pic, vals); + pic_funcall(pic, "picrin.base", "apply", 2, proc, vals); } - - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value pic_str_list_to_string(pic_state *pic) { - pic_str *str; pic_value list, e, it; int i; char *buf; pic_get_args(pic, "o", &list); - if (pic_length(pic, list) == 0) { - return pic_obj_value(pic_make_lit(pic, "")); + buf = pic_alloca(pic, pic_length(pic, list)); + + i = 0; + pic_for_each (e, list, it) { + pic_assert_type(pic, e, char); + + buf[i++] = pic_char(pic, e); } - buf = pic_malloc(pic, pic_length(pic, list)); - - pic_try { - i = 0; - pic_for_each (e, list, it) { - pic_assert_type(pic, e, char); - - buf[i++] = pic_char(e); - } - - str = pic_make_str(pic, buf, i); - } - pic_catch { - pic_free(pic, buf); - pic_raise(pic, pic->err); - } - pic_free(pic, buf); - - return pic_obj_value(str); + return pic_str_value(pic, buf, i); } static pic_value pic_str_string_to_list(pic_state *pic) { - pic_str *str; - pic_value list; - int n, start, end, i; + pic_value str, list; + int n, start, end, len, i; n = pic_get_args(pic, "s|ii", &str, &start, &end); + len = pic_str_len(pic, str); + switch (n) { case 1: start = 0; case 2: - end = pic_str_len(str); + end = len; } - list = pic_nil_value(); + VALID_RANGE(pic, len, start, end); + list = pic_nil_value(pic); for (i = start; i < end; ++i) { - pic_push(pic, pic_char_value(pic_str_ref(pic, str, i)), list); + pic_push(pic, pic_char_value(pic, pic_str_ref(pic, str, i)), list); } return pic_reverse(pic, list); } - + void pic_init_str(pic_state *pic) { @@ -696,7 +695,10 @@ pic_init_str(pic_state *pic) pic_defun(pic, "make-string", pic_str_make_string); pic_defun(pic, "string-length", pic_str_string_length); pic_defun(pic, "string-ref", pic_str_string_ref); + pic_defun(pic, "string-set!", pic_str_string_set); pic_defun(pic, "string-copy", pic_str_string_copy); + pic_defun(pic, "string-copy!", pic_str_string_copy_ip); + pic_defun(pic, "string-fill!", pic_str_string_fill_ip); pic_defun(pic, "string-append", pic_str_string_append); pic_defun(pic, "string-map", pic_str_string_map); pic_defun(pic, "string-for-each", pic_str_string_for_each); diff --git a/extlib/benz/symbol.c b/extlib/benz/symbol.c index a3965dce..f67f7593 100644 --- a/extlib/benz/symbol.c +++ b/extlib/benz/symbol.c @@ -3,59 +3,65 @@ */ #include "picrin.h" +#include "picrin/extra.h" +#include "picrin/private/object.h" +#include "picrin/private/state.h" -#define kh_pic_str_hash(a) (pic_str_hash(pic, (a))) -#define kh_pic_str_cmp(a, b) (pic_str_cmp(pic, (a), (b)) == 0) +#define kh_pic_str_hash(a) (pic_str_hash(pic, pic_obj_value(a))) +#define kh_pic_str_cmp(a, b) (pic_str_cmp(pic, pic_obj_value(a), pic_obj_value(b)) == 0) -KHASH_DEFINE(s, pic_str *, pic_sym *, kh_pic_str_hash, kh_pic_str_cmp) +KHASH_DEFINE(oblist, struct string *, symbol *, kh_pic_str_hash, kh_pic_str_cmp) -pic_sym * -pic_intern(pic_state *pic, pic_str *str) +pic_value +pic_intern(pic_state *pic, pic_value str) { - khash_t(s) *h = &pic->oblist; - pic_sym *sym; - khiter_t it; + khash_t(oblist) *h = &pic->oblist; + symbol *sym; + int it; int ret; - it = kh_put(s, h, str, &ret); + it = kh_put(oblist, h, pic_str_ptr(pic, str), &ret); if (ret == 0) { /* if exists */ sym = kh_val(h, it); - pic_gc_protect(pic, pic_obj_value(sym)); - return sym; + pic_protect(pic, pic_obj_value(sym)); + return pic_obj_value(sym); } - sym = (pic_sym *)pic_obj_alloc(pic, sizeof(pic_sym), PIC_TT_SYMBOL); - sym->str = str; + kh_val(h, it) = NULL; /* dummy */ + + sym = (symbol *)pic_obj_alloc(pic, offsetof(symbol, env), PIC_TYPE_SYMBOL); + sym->u.str = pic_str_ptr(pic, str); kh_val(h, it) = sym; - return sym; + return pic_obj_value(sym); } -pic_id * -pic_make_identifier(pic_state *pic, pic_id *id, struct pic_env *env) +pic_value +pic_make_identifier(pic_state *pic, pic_value base, pic_value env) { - pic_id *nid; + struct identifier *id; - nid = (pic_id *)pic_obj_alloc(pic, sizeof(pic_id), PIC_TT_ID); - nid->u.id.id = id; - nid->u.id.env = env; - return nid; + id = (struct identifier *)pic_obj_alloc(pic, sizeof(struct identifier), PIC_TYPE_ID); + id->u.id = pic_id_ptr(pic, base); + id->env = pic_env_ptr(pic, env); + + return pic_obj_value(id); } -const char * -pic_symbol_name(pic_state *pic, pic_sym *sym) +pic_value +pic_sym_name(pic_state *PIC_UNUSED(pic), pic_value sym) { - return pic_str_cstr(pic, sym->str); + return pic_obj_value(pic_sym_ptr(pic, sym)->u.str); } -const char * -pic_identifier_name(pic_state *pic, pic_id *id) +pic_value +pic_id_name(pic_state *pic, pic_value id) { - while (! pic_sym_p(pic_obj_value(id))) { - id = id->u.id.id; + while (! pic_sym_p(pic, id)) { + id = pic_obj_value(pic_id_ptr(pic, id)->u.id); } - return pic_symbol_name(pic, (pic_sym *)id); + return pic_sym_name(pic, id); } static pic_value @@ -65,7 +71,7 @@ pic_symbol_symbol_p(pic_state *pic) pic_get_args(pic, "o", &v); - return pic_bool_value(pic_sym_p(v)); + return pic_bool_value(pic, pic_sym_p(pic, v)); } static pic_value @@ -77,34 +83,34 @@ pic_symbol_symbol_eq_p(pic_state *pic) pic_get_args(pic, "*", &argc, &argv); for (i = 0; i < argc; ++i) { - if (! pic_sym_p(argv[i])) { - return pic_false_value(); + if (! pic_sym_p(pic, argv[i])) { + return pic_false_value(pic); } - if (! pic_eq_p(argv[i], argv[0])) { - return pic_false_value(); + if (! pic_eq_p(pic, argv[i], argv[0])) { + return pic_false_value(pic); } } - return pic_true_value(); + return pic_true_value(pic); } static pic_value pic_symbol_symbol_to_string(pic_state *pic) { - pic_sym *sym; + pic_value sym; pic_get_args(pic, "m", &sym); - return pic_obj_value(sym->str); + return pic_sym_name(pic, sym); } static pic_value pic_symbol_string_to_symbol(pic_state *pic) { - pic_str *str; + pic_value str; pic_get_args(pic, "s", &str); - return pic_obj_value(pic_intern(pic, str)); + return pic_intern(pic, str); } static pic_value @@ -114,7 +120,7 @@ pic_symbol_identifier_p(pic_state *pic) pic_get_args(pic, "o", &obj); - return pic_bool_value(pic_id_p(obj)); + return pic_bool_value(pic, pic_id_p(pic, obj)); } static pic_value @@ -127,11 +133,11 @@ pic_symbol_make_identifier(pic_state *pic) pic_assert_type(pic, id, id); pic_assert_type(pic, env, env); - return pic_obj_value(pic_make_identifier(pic, pic_id_ptr(id), pic_env_ptr(env))); + return pic_make_identifier(pic, id, env); } static pic_value -pic_symbol_identifier_variable(pic_state *pic) +pic_symbol_identifier_base(pic_state *pic) { pic_value id; @@ -139,11 +145,11 @@ pic_symbol_identifier_variable(pic_state *pic) pic_assert_type(pic, id, id); - if (pic_sym_p(id)) { - pic_errorf(pic, "expected non-symbol identifier, but got symbol ~s", id); + if (pic_sym_p(pic, id)) { + pic_error(pic, "non-symbol identifier required", 1, id); } - return pic_obj_value(pic_id_ptr(id)->u.id.id); + return pic_obj_value(pic_id_ptr(pic, id)->u.id); } static pic_value @@ -155,11 +161,11 @@ pic_symbol_identifier_environment(pic_state *pic) pic_assert_type(pic, id, id); - if (pic_sym_p(id)) { - pic_errorf(pic, "expected non-symbol identifier, but got symbol ~s", id); + if (pic_sym_p(pic, id)) { + pic_error(pic, "non-symbol identifier required", 1, id); } - return pic_obj_value(pic_id_ptr(id)->u.id.env); + return pic_obj_value(pic_id_ptr(pic, id)->env); } static pic_value @@ -171,14 +177,14 @@ pic_symbol_identifier_eq_p(pic_state *pic) pic_get_args(pic, "*", &argc, &argv); for (i = 0; i < argc; ++i) { - if (! pic_id_p(argv[i])) { - return pic_false_value(); + if (! pic_id_p(pic, argv[i])) { + return pic_false_value(pic); } if (! pic_equal_p(pic, argv[i], argv[0])) { - return pic_false_value(); + return pic_false_value(pic); } } - return pic_true_value(); + return pic_true_value(pic); } void @@ -192,6 +198,6 @@ pic_init_symbol(pic_state *pic) pic_defun(pic, "make-identifier", pic_symbol_make_identifier); pic_defun(pic, "identifier?", pic_symbol_identifier_p); pic_defun(pic, "identifier=?", pic_symbol_identifier_eq_p); - pic_defun(pic, "identifier-variable", pic_symbol_identifier_variable); + pic_defun(pic, "identifier-base", pic_symbol_identifier_base); pic_defun(pic, "identifier-environment", pic_symbol_identifier_environment); } diff --git a/extlib/benz/value.c b/extlib/benz/value.c new file mode 100644 index 00000000..32b17d65 --- /dev/null +++ b/extlib/benz/value.c @@ -0,0 +1,261 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/private/object.h" + +#if PIC_NAN_BOXING + +/** + * value representation by nan-boxing: + * float : FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF + * ptr : 111111111111TTTT PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP + * int : 111111111111TTTT 0000000000000000 IIIIIIIIIIIIIIII IIIIIIIIIIIIIIII + * char : 111111111111TTTT 0000000000000000 CCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCC + */ + +#define pic_init_value(v,vtype) (v = (0xfff0000000000000ul | ((uint64_t)(vtype) << 48))) + +int +pic_vtype(pic_state *PIC_UNUSED(pic), pic_value v) +{ + return 0xfff0 >= (v >> 48) ? PIC_TYPE_FLOAT : ((v >> 48) & 0xf); +} + +double +pic_float(pic_state *PIC_UNUSED(pic), pic_value v) +{ + union { double f; uint64_t i; } u; + u.i = v; + return u.f; +} + +int +pic_int(pic_state *PIC_UNUSED(pic), pic_value v) +{ + union { int i; unsigned u; } u; + u.u = v & 0xfffffffful; + return u.i; +} + +char +pic_char(pic_state *PIC_UNUSED(pic), pic_value v) +{ + return v & 0xfffffffful; +} + +struct object * +pic_obj_ptr(pic_value v) +{ + return (struct object *)(0xfffffffffffful & v); +} + +#else + +#define pic_init_value(v,vtype) ((v).type = (vtype), (v).u.data = NULL) + +int +pic_vtype(pic_state *PIC_UNUSED(pic), pic_value v) +{ + return (int)(v.type); +} + +double +pic_float(pic_state *PIC_UNUSED(pic), pic_value v) +{ + return v.u.f; +} + +int +pic_int(pic_state *PIC_UNUSED(pic), pic_value v) +{ + return v.u.i; +} + +char +pic_char(pic_state *PIC_UNUSED(pic), pic_value v) +{ + return v.u.c; +} + +struct object * +pic_obj_ptr(pic_value v) +{ + return (struct object *)(v.u.data); +} + +#endif + +#if PIC_NAN_BOXING + +pic_value +pic_obj_value(void *ptr) +{ + pic_value v; + + pic_init_value(v, PIC_IVAL_END); + v |= 0xfffffffffffful & (uint64_t)ptr; + return v; +} + +pic_value +pic_float_value(pic_state *PIC_UNUSED(pic), double f) +{ + union { double f; uint64_t i; } u; + + if (f != f) { + return 0x7ff8000000000000ul; + } else { + u.f = f; + return u.i; + } +} + +pic_value +pic_int_value(pic_state *PIC_UNUSED(pic), int i) +{ + pic_value v; + + pic_init_value(v, PIC_TYPE_INT); + v |= (unsigned)i; + return v; +} + +pic_value +pic_char_value(pic_state *PIC_UNUSED(pic), char c) +{ + pic_value v; + + pic_init_value(v, PIC_TYPE_CHAR); + v |= (unsigned char)c; + return v; +} + +#else + +pic_value +pic_obj_value(void *ptr) +{ + pic_value v; + + pic_init_value(v, PIC_IVAL_END); + v.u.data = ptr; + return v; +} + +pic_value +pic_float_value(pic_state *PIC_UNUSED(pic), double f) +{ + pic_value v; + + pic_init_value(v, PIC_TYPE_FLOAT); + v.u.f = f; + return v; +} + +pic_value +pic_int_value(pic_state *PIC_UNUSED(pic), int i) +{ + pic_value v; + + pic_init_value(v, PIC_TYPE_INT); + v.u.i = i; + return v; +} + +pic_value +pic_char_value(pic_state *PIC_UNUSED(pic), char c) +{ + pic_value v; + + pic_init_value(v, PIC_TYPE_CHAR); + v.u.c = c; + return v; +} + +#endif + +#define DEFVAL(name, type) \ + pic_value name(pic_state *PIC_UNUSED(pic)) { \ + pic_value v; \ + pic_init_value(v, type); \ + return v; \ + } + +DEFVAL(pic_nil_value, PIC_TYPE_NIL) +DEFVAL(pic_eof_object, PIC_TYPE_EOF) +DEFVAL(pic_true_value, PIC_TYPE_TRUE) +DEFVAL(pic_false_value, PIC_TYPE_FALSE) +DEFVAL(pic_undef_value, PIC_TYPE_UNDEF) +DEFVAL(pic_invalid_value, PIC_TYPE_INVALID) + +int +pic_type(pic_state *PIC_UNUSED(pic), pic_value v) +{ + int tt = pic_vtype(pic, v); + + if (tt < PIC_IVAL_END) { + return tt; + } + return ((struct basic *)pic_obj_ptr(v))->tt; +} + +const char * +pic_typename(pic_state *pic, int type) +{ + switch (type) { + case PIC_TYPE_NIL: + return "null"; + case PIC_TYPE_TRUE: + case PIC_TYPE_FALSE: + return "boolean"; + case PIC_TYPE_FLOAT: + return "float"; + case PIC_TYPE_INT: + return "int"; + case PIC_TYPE_SYMBOL: + return "symbol"; + case PIC_TYPE_CHAR: + return "char"; + case PIC_TYPE_EOF: + return "eof-object"; + case PIC_TYPE_UNDEF: + return "undefined"; + case PIC_TYPE_INVALID: + return "invalid"; + case PIC_TYPE_PAIR: + return "pair"; + case PIC_TYPE_STRING: + return "string"; + case PIC_TYPE_VECTOR: + return "vector"; + case PIC_TYPE_BLOB: + return "bytevector"; + case PIC_TYPE_PORT: + return "port"; + case PIC_TYPE_ERROR: + return "error"; + case PIC_TYPE_ID: + return "identifier"; + case PIC_TYPE_CXT: + return "context"; + case PIC_TYPE_FUNC: + case PIC_TYPE_IREP: + return "procedure"; + case PIC_TYPE_ENV: + return "environment"; + case PIC_TYPE_DATA: + return "data"; + case PIC_TYPE_DICT: + return "dictionary"; + case PIC_TYPE_WEAK: + return "ephemeron"; + case PIC_TYPE_RECORD: + return "record"; + case PIC_TYPE_CP: + return "checkpoint"; + default: + pic_error(pic, "pic_typename: invalid type given", 1, pic_int_value(pic, type)); + } +} diff --git a/extlib/benz/var.c b/extlib/benz/var.c index e7c3d55a..72105734 100644 --- a/extlib/benz/var.c +++ b/extlib/benz/var.c @@ -3,48 +3,39 @@ */ #include "picrin.h" +#include "picrin/extra.h" +#include "picrin/private/object.h" +#include "picrin/private/state.h" static pic_value -var_conv(pic_state *pic, struct pic_proc *var, pic_value val) +var_get(pic_state *pic, pic_value var) { - if (pic_proc_env_has(pic, var, "conv") != 0) { - return pic_apply1(pic, pic_proc_ptr(pic_proc_env_ref(pic, var, "conv")), val); - } - return val; -} + pic_value weak, it; -static pic_value -var_get(pic_state *pic, struct pic_proc *var) -{ - pic_value elem, it; - struct pic_weak *weak; - - pic_for_each (elem, pic->ptable, it) { - weak = pic_weak_ptr(elem); + pic_for_each (weak, pic->ptable, it) { if (pic_weak_has(pic, weak, var)) { return pic_weak_ref(pic, weak, var); } } - pic_panic(pic, "logic flaw"); + PIC_UNREACHABLE(); } static pic_value -var_set(pic_state *pic, struct pic_proc *var, pic_value val) +var_set(pic_state *pic, pic_value var, pic_value val) { - struct pic_weak *weak; + pic_value weak; - weak = pic_weak_ptr(pic_car(pic, pic->ptable)); + weak = pic_car(pic, pic->ptable); pic_weak_set(pic, weak, var, val); - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value var_call(pic_state *pic) { - struct pic_proc *self; - pic_value val; + pic_value self, val; int n; n = pic_get_args(pic, "&|o", &self, &val); @@ -52,22 +43,24 @@ var_call(pic_state *pic) if (n == 0) { return var_get(pic, self); } else { - return var_set(pic, self, var_conv(pic, self, val)); + pic_value conv; + + conv = pic_closure_ref(pic, 0); + if (! pic_false_p(pic, conv)) { + val = pic_call(pic, conv, 1, val); + } + return var_set(pic, self, val); } } -struct pic_proc * -pic_make_var(pic_state *pic, pic_value init, struct pic_proc *conv) +pic_value +pic_make_var(pic_state *pic, pic_value init, pic_value conv) { - struct pic_proc *var; + pic_value var; - var = pic_make_proc(pic, var_call); + var = pic_lambda(pic, var_call, 1, conv); - if (conv != NULL) { - pic_proc_env_set(pic, var, "conv", pic_obj_value(conv)); - } - - pic_apply1(pic, var, init); + pic_call(pic, var, 1, init); return var; } @@ -75,25 +68,23 @@ pic_make_var(pic_state *pic, pic_value init, struct pic_proc *conv) static pic_value pic_var_make_parameter(pic_state *pic) { - struct pic_proc *conv = NULL; - pic_value init; + pic_value init, conv = pic_false_value(pic); pic_get_args(pic, "o|l", &init, &conv); - return pic_obj_value(pic_make_var(pic, init, conv)); + return pic_make_var(pic, init, conv); } static pic_value pic_var_with_parameter(pic_state *pic) { - struct pic_proc *body; - pic_value val; + pic_value body, val; pic_get_args(pic, "l", &body); - pic->ptable = pic_cons(pic, pic_obj_value(pic_make_weak(pic)), pic->ptable); + pic->ptable = pic_cons(pic, pic_make_weak(pic), pic->ptable); - val = pic_apply0(pic, body); + val = pic_call(pic, body, 0); pic->ptable = pic_cdr(pic, pic->ptable); diff --git a/extlib/benz/vector.c b/extlib/benz/vector.c index c06d0023..781d138a 100644 --- a/extlib/benz/vector.c +++ b/extlib/benz/vector.c @@ -3,20 +3,44 @@ */ #include "picrin.h" +#include "picrin/extra.h" +#include "picrin/private/object.h" -struct pic_vector * -pic_make_vec(pic_state *pic, int len) +pic_value +pic_make_vec(pic_state *pic, int len, pic_value *argv) { - struct pic_vector *vec; + struct vector *vec; int i; - vec = (struct pic_vector *)pic_obj_alloc(pic, sizeof(struct pic_vector), PIC_TT_VECTOR); + vec = (struct vector *)pic_obj_alloc(pic, sizeof(struct vector), PIC_TYPE_VECTOR); vec->len = len; vec->data = (pic_value *)pic_malloc(pic, sizeof(pic_value) * len); - for (i = 0; i < len; ++i) { - vec->data[i] = pic_undef_value(); + if (argv == NULL) { + for (i = 0; i < len; ++i) { + vec->data[i] = pic_undef_value(pic); + } + } else { + memcpy(vec->data, argv, sizeof(pic_value) * len); } - return vec; + return pic_obj_value(vec); +} + +pic_value +pic_vec_ref(pic_state *PIC_UNUSED(pic), pic_value vec, int k) +{ + return pic_vec_ptr(pic, vec)->data[k]; +} + +void +pic_vec_set(pic_state *PIC_UNUSED(pic), pic_value vec, int k, pic_value val) +{ + pic_vec_ptr(pic, vec)->data[k] = val; +} + +int +pic_vec_len(pic_state *PIC_UNUSED(pic), pic_value vec) +{ + return pic_vec_ptr(pic, vec)->len; } static pic_value @@ -26,293 +50,284 @@ pic_vec_vector_p(pic_state *pic) pic_get_args(pic, "o", &v); - return pic_bool_value(pic_vec_p(v)); + return pic_bool_value(pic, pic_vec_p(pic, v)); } static pic_value pic_vec_vector(pic_state *pic) { - int argc, i; + int argc; pic_value *argv; - pic_vec *vec; pic_get_args(pic, "*", &argc, &argv); - vec = pic_make_vec(pic, argc); - - for (i = 0; i < argc; ++i) { - vec->data[i] = argv[i]; - } - - return pic_obj_value(vec); + return pic_make_vec(pic, argc, argv); } static pic_value pic_vec_make_vector(pic_state *pic) { - pic_value v; + pic_value vec, init; int n, k, i; - struct pic_vector *vec; - n = pic_get_args(pic, "i|o", &k, &v); + n = pic_get_args(pic, "i|o", &k, &init); - vec = pic_make_vec(pic, k); + if (k < 0) { + pic_error(pic, "make-vector: negative length given", 1, pic_int_value(pic, k)); + } + + vec = pic_make_vec(pic, k, NULL); if (n == 2) { for (i = 0; i < k; ++i) { - vec->data[i] = v; + pic_vec_set(pic, vec, i, init); } } - return pic_obj_value(vec); + return vec; } static pic_value pic_vec_vector_length(pic_state *pic) { - struct pic_vector *v; + pic_value v; pic_get_args(pic, "v", &v); - return pic_int_value(v->len); + return pic_int_value(pic, pic_vec_len(pic, v)); } static pic_value pic_vec_vector_ref(pic_state *pic) { - struct pic_vector *v; + pic_value v; int k; pic_get_args(pic, "vi", &v, &k); - if (v->len <= k) { - pic_errorf(pic, "vector-ref: index out of range"); - } - return v->data[k]; + VALID_INDEX(pic, pic_vec_len(pic, v), k); + + return pic_vec_ref(pic, v, k); } static pic_value pic_vec_vector_set(pic_state *pic) { - struct pic_vector *v; + pic_value v, o; int k; - pic_value o; pic_get_args(pic, "vio", &v, &k, &o); - if (v->len <= k) { - pic_errorf(pic, "vector-set!: index out of range"); - } - v->data[k] = o; - return pic_undef_value(); + VALID_INDEX(pic, pic_vec_len(pic, v), k); + + pic_vec_set(pic, v, k, o); + + return pic_undef_value(pic); } static pic_value pic_vec_vector_copy_i(pic_state *pic) { - pic_vec *to, *from; - int n, at, start, end; + pic_value to, from; + int n, at, start, end, tolen, fromlen; n = pic_get_args(pic, "viv|ii", &to, &at, &from, &start, &end); + tolen = pic_vec_len(pic, to); + fromlen = pic_vec_len(pic, from); + switch (n) { case 3: start = 0; case 4: - end = from->len; + end = fromlen; } - if (to == from && (start <= at && at < end)) { - /* copy in reversed order */ - at += end - start; - while (start < end) { - to->data[--at] = from->data[--end]; - } - return pic_undef_value(); - } + VALID_ATRANGE(pic, tolen, at, fromlen, start, end); - while (start < end) { - to->data[at++] = from->data[start++]; - } + memmove(pic_vec_ptr(pic, to)->data + at, pic_vec_ptr(pic, from)->data + start, sizeof(pic_value) * (end - start)); - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value pic_vec_vector_copy(pic_state *pic) { - pic_vec *vec, *to; - int n, start, end, i = 0; + pic_value from; + int n, start, end, fromlen; - n = pic_get_args(pic, "v|ii", &vec, &start, &end); + n = pic_get_args(pic, "v|ii", &from, &start, &end); + + fromlen = pic_vec_len(pic, from); switch (n) { case 1: start = 0; case 2: - end = vec->len; + end = fromlen; } - if (end < start) { - pic_errorf(pic, "vector-copy: end index must not be less than start index"); - } + VALID_RANGE(pic, fromlen, start, end); - to = pic_make_vec(pic, end - start); - while (start < end) { - to->data[i++] = vec->data[start++]; - } - - return pic_obj_value(to); + return pic_make_vec(pic, end - start, pic_vec_ptr(pic, from)->data + start); } static pic_value pic_vec_vector_append(pic_state *pic) { - pic_value *argv; - int argc, i, j, len; - pic_vec *vec; + pic_value *argv, vec; + int argc, i, len; pic_get_args(pic, "*", &argc, &argv); len = 0; for (i = 0; i < argc; ++i) { pic_assert_type(pic, argv[i], vec); - len += pic_vec_ptr(argv[i])->len; + len += pic_vec_len(pic, argv[i]); } - vec = pic_make_vec(pic, len); + vec = pic_make_vec(pic, len, NULL); len = 0; for (i = 0; i < argc; ++i) { - for (j = 0; j < pic_vec_ptr(argv[i])->len; ++j) { - vec->data[len + j] = pic_vec_ptr(argv[i])->data[j]; - } - len += pic_vec_ptr(argv[i])->len; + int l = pic_vec_len(pic, argv[i]); + memcpy(pic_vec_ptr(pic, vec)->data + len, pic_vec_ptr(pic, argv[i])->data, sizeof(pic_value) * l); + len += l; } - return pic_obj_value(vec); + return vec; } static pic_value pic_vec_vector_fill_i(pic_state *pic) { - pic_vec *vec; - pic_value obj; - int n, start, end; + pic_value vec, obj; + int n, start, end, len; n = pic_get_args(pic, "vo|ii", &vec, &obj, &start, &end); + len = pic_vec_len(pic, vec); + switch (n) { case 2: start = 0; case 3: - end = vec->len; + end = len; } + VALID_RANGE(pic, len, start, end); + while (start < end) { - vec->data[start++] = obj; + pic_vec_set(pic, vec, start++, obj); } - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value pic_vec_vector_map(pic_state *pic) { - struct pic_proc *proc; int argc, i, len, j; - pic_value *argv, vals; - pic_vec *vec; + pic_value proc, *argv, vec, vals; pic_get_args(pic, "l*", &proc, &argc, &argv); + if (argc == 0) { + pic_error(pic, "vector-map: wrong number of arguments (1 for at least 2)", 0); + } + len = INT_MAX; for (i = 0; i < argc; ++i) { + int l; pic_assert_type(pic, argv[i], vec); - - len = len < pic_vec_ptr(argv[i])->len - ? len - : pic_vec_ptr(argv[i])->len; + l = pic_vec_len(pic, argv[i]); + len = len < l ? len : l; } - vec = pic_make_vec(pic, len); + vec = pic_make_vec(pic, len, NULL); for (i = 0; i < len; ++i) { - vals = pic_nil_value(); + vals = pic_nil_value(pic); for (j = 0; j < argc; ++j) { - pic_push(pic, pic_vec_ptr(argv[j])->data[i], vals); + pic_push(pic, pic_vec_ref(pic, argv[j], i), vals); } - vec->data[i] = pic_apply_list(pic, proc, vals); + vals = pic_reverse(pic, vals); + pic_vec_set(pic, vec, i, pic_funcall(pic, "picrin.base", "apply", 2, proc, vals)); } - return pic_obj_value(vec); + return vec; } static pic_value pic_vec_vector_for_each(pic_state *pic) { - struct pic_proc *proc; int argc, i, len, j; - pic_value *argv, vals; + pic_value proc, *argv, vals; pic_get_args(pic, "l*", &proc, &argc, &argv); + if (argc == 0) { + pic_error(pic, "vector-for-each: wrong number of arguments (1 for at least 2)", 0); + } + len = INT_MAX; for (i = 0; i < argc; ++i) { + int l; pic_assert_type(pic, argv[i], vec); - - len = len < pic_vec_ptr(argv[i])->len - ? len - : pic_vec_ptr(argv[i])->len; + l = pic_vec_len(pic, argv[i]); + len = len < l ? len : l; } for (i = 0; i < len; ++i) { - vals = pic_nil_value(); + vals = pic_nil_value(pic); for (j = 0; j < argc; ++j) { - pic_push(pic, pic_vec_ptr(argv[j])->data[i], vals); + pic_push(pic, pic_vec_ref(pic, argv[j], i), vals); } - pic_apply_list(pic, proc, vals); + vals = pic_reverse(pic, vals); + pic_funcall(pic, "picrin.base", "apply", 2, proc, vals); } - return pic_undef_value(); + return pic_undef_value(pic); } static pic_value pic_vec_list_to_vector(pic_state *pic) { - struct pic_vector *vec; - pic_value list, e, it, *data; + pic_value list, vec, e, it; + int len, i = 0; pic_get_args(pic, "o", &list); - vec = pic_make_vec(pic, pic_length(pic, list)); - - data = vec->data; + len = pic_length(pic, list); + vec = pic_make_vec(pic, len, NULL); pic_for_each (e, list, it) { - *data++ = e; + pic_vec_set(pic, vec, i++, e); } - return pic_obj_value(vec); + return vec; } static pic_value pic_vec_vector_to_list(pic_state *pic) { - struct pic_vector *vec; + pic_value vec; pic_value list; - int n, start, end, i; + int n, start, end, i, len; n = pic_get_args(pic, "v|ii", &vec, &start, &end); + len = pic_vec_len(pic, vec); + switch (n) { case 1: start = 0; case 2: - end = vec->len; + end = len; } - list = pic_nil_value(); + VALID_RANGE(pic, len, start, end); + list = pic_nil_value(pic); for (i = start; i < end; ++i) { - pic_push(pic, vec->data[i], list); + pic_push(pic, pic_vec_ref(pic, vec, i), list); } return pic_reverse(pic, list); } @@ -320,64 +335,60 @@ pic_vec_vector_to_list(pic_state *pic) static pic_value pic_vec_vector_to_string(pic_state *pic) { - pic_vec *vec; + pic_value vec, t; char *buf; - int n, start, end, i; - pic_str *str; + int n, start, end, i, len; n = pic_get_args(pic, "v|ii", &vec, &start, &end); + len = pic_vec_len(pic, vec); + switch (n) { case 1: start = 0; case 2: - end = vec->len; + end = len; } - if (end < start) { - pic_errorf(pic, "vector->string: end index must not be less than start index"); - } - - buf = pic_malloc(pic, end - start); + VALID_RANGE(pic, len, start, end); + buf = pic_alloca(pic, end - start); for (i = start; i < end; ++i) { - pic_assert_type(pic, vec->data[i], char); + t = pic_vec_ref(pic, vec, i); - buf[i - start] = pic_char(vec->data[i]); + pic_assert_type(pic, t, char); + + buf[i - start] = pic_char(pic, t); } - str = pic_make_str(pic, buf, end - start); - pic_free(pic, buf); - - return pic_obj_value(str); + return pic_str_value(pic, buf, end - start); } static pic_value pic_vec_string_to_vector(pic_state *pic) { - pic_str *str; - int n, start, end, i; - pic_vec *vec; + pic_value str, vec; + int n, start, end, len, i; n = pic_get_args(pic, "s|ii", &str, &start, &end); + len = pic_str_len(pic, str); + switch (n) { case 1: start = 0; case 2: - end = pic_str_len(str); + end = len; } - if (end < start) { - pic_errorf(pic, "string->vector: end index must not be less than start index"); - } + VALID_RANGE(pic, len, start, end); - vec = pic_make_vec(pic, end - start); + vec = pic_make_vec(pic, end - start, NULL); for (i = 0; i < end - start; ++i) { - vec->data[i] = pic_char_value(pic_str_ref(pic, str, i + start)); + pic_vec_set(pic, vec, i, pic_char_value(pic, pic_str_ref(pic, str, i + start))); } - return pic_obj_value(vec); + return vec; } void diff --git a/extlib/benz/weak.c b/extlib/benz/weak.c index 196846b8..722d153b 100644 --- a/extlib/benz/weak.c +++ b/extlib/benz/weak.c @@ -3,142 +3,105 @@ */ #include "picrin.h" +#include "picrin/private/object.h" -KHASH_DEFINE(weak, void *, pic_value, kh_ptr_hash_func, kh_ptr_hash_equal) +KHASH_DEFINE(weak, struct object *, pic_value, kh_ptr_hash_func, kh_ptr_hash_equal) -struct pic_weak * +pic_value pic_make_weak(pic_state *pic) { - struct pic_weak *weak; + struct weak *weak; - weak = (struct pic_weak *)pic_obj_alloc(pic, sizeof(struct pic_weak), PIC_TT_WEAK); + weak = (struct weak *)pic_obj_alloc(pic, sizeof(struct weak), PIC_TYPE_WEAK); weak->prev = NULL; kh_init(weak, &weak->hash); - return weak; + return pic_obj_value(weak); } pic_value -pic_weak_ref(pic_state *pic, struct pic_weak *weak, void *key) +pic_weak_ref(pic_state *pic, pic_value weak, pic_value key) { - khash_t(weak) *h = &weak->hash; - khiter_t it; + khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash; + int it; - it = kh_get(weak, h, key); + it = kh_get(weak, h, pic_obj_ptr(key)); if (it == kh_end(h)) { - pic_errorf(pic, "element not found for a key: ~s", pic_obj_value(key)); + pic_error(pic, "element not found for given key", 1, key); } return kh_val(h, it); } -void * -pic_weak_rev_ref(pic_state *pic, struct pic_weak *weak, pic_value val) -{ - khash_t(weak) *h = &weak->hash; - - if (h->n_buckets) { - khint_t i = 0; - while ((i < h->n_buckets) && (ac_iseither(h->flags, i) || !pic_eq_p(h->vals[i], val))) { - i += 1; - } - if (i < h->n_buckets) return kh_key(h, i); - } - pic_errorf(pic, "key not found for an element: ~s", val); - return NULL; -} - void -pic_weak_set(pic_state PIC_UNUSED(*pic), struct pic_weak *weak, void *key, pic_value val) +pic_weak_set(pic_state *pic, pic_value weak, pic_value key, pic_value val) { - khash_t(weak) *h = &weak->hash; + khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash; int ret; - khiter_t it; + int it; - it = kh_put(weak, h, key, &ret); + it = kh_put(weak, h, pic_obj_ptr(key), &ret); kh_val(h, it) = val; } bool -pic_weak_has(pic_state PIC_UNUSED(*pic), struct pic_weak *weak, void *key) +pic_weak_has(pic_state *pic, pic_value weak, pic_value key) { - return kh_get(weak, &weak->hash, key) != kh_end(&weak->hash); + khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash; + + return kh_get(weak, h, pic_obj_ptr(key)) != kh_end(h); } void -pic_weak_del(pic_state *pic, struct pic_weak *weak, void *key) +pic_weak_del(pic_state *pic, pic_value weak, pic_value key) { - khash_t(weak) *h = &weak->hash; - khiter_t it; + khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash; + int it; - it = kh_get(weak, h, key); + it = kh_get(weak, h, pic_obj_ptr(key)); if (it == kh_end(h)) { - pic_errorf(pic, "no slot named ~s found in ephemeron", pic_obj_value(key)); + pic_error(pic, "element not found for given key", 1, key); } kh_del(weak, h, it); } -static pic_value -weak_get(pic_state *pic, struct pic_weak *weak, void *key) -{ - if (! pic_weak_has(pic, weak, key)) { - return pic_false_value(); - } - return pic_cons(pic, pic_obj_value(key), pic_weak_ref(pic, weak, key)); -} - -static pic_value -weak_set(pic_state *pic, struct pic_weak *weak, void *key, pic_value val) -{ - if (pic_undef_p(val)) { - if (pic_weak_has(pic, weak, key)) { - pic_weak_del(pic, weak, key); - } - } else { - pic_weak_set(pic, weak, key, val); - } - - return pic_undef_value(); -} - static pic_value weak_call(pic_state *pic) { - struct pic_proc *self; - struct pic_weak *weak; - pic_value key, val; + pic_value key, val, weak; int n; - n = pic_get_args(pic, "&o|o", &self, &key, &val); + n = pic_get_args(pic, "o|o", &key, &val); - if (! pic_obj_p(key)) { - pic_errorf(pic, "attempted to set a non-object key '~s' in an ephemeron", key); + if (! pic_obj_p(pic, key)) { + pic_error(pic, "attempted to set a non-object key", 1, key); } - weak = pic_weak_ptr(pic_proc_env_ref(pic, self, "weak")); + weak = pic_closure_ref(pic, 0); if (n == 1) { - return weak_get(pic, weak, pic_obj_ptr(key)); + if (! pic_weak_has(pic, weak, key)) { + return pic_false_value(pic); + } + return pic_cons(pic, key, pic_weak_ref(pic, weak, key)); } else { - return weak_set(pic, weak, pic_obj_ptr(key), val); + if (pic_undef_p(pic, val)) { + if (pic_weak_has(pic, weak, key)) { + pic_weak_del(pic, weak, key); + } + } else { + pic_weak_set(pic, weak, key, val); + } + return pic_undef_value(pic); } } static pic_value pic_weak_make_ephemeron(pic_state *pic) { - struct pic_weak *weak; - struct pic_proc *proc; - pic_get_args(pic, ""); - weak = pic_make_weak(pic); - - proc = pic_make_proc(pic, weak_call); - - pic_proc_env_set(pic, proc, "weak", pic_obj_value(weak)); - - return pic_obj_value(proc); + return pic_lambda(pic, weak_call, 1, pic_make_weak(pic)); } void diff --git a/extlib/benz/write.c b/extlib/benz/write.c index e36a8a0b..b76914d0 100644 --- a/extlib/benz/write.c +++ b/extlib/benz/write.c @@ -3,20 +3,17 @@ */ #include "picrin.h" +#include "picrin/extra.h" +#include "picrin/private/object.h" -KHASH_DECLARE(l, void *, int) -KHASH_DECLARE(v, void *, int) -KHASH_DEFINE2(l, void *, int, 1, kh_ptr_hash_func, kh_ptr_hash_equal) -KHASH_DEFINE2(v, void *, int, 0, kh_ptr_hash_func, kh_ptr_hash_equal) +#if PIC_USE_WRITE struct writer_control { - pic_state *pic; - xFILE *file; int mode; int op; - khash_t(l) labels; /* object -> int */ - khash_t(v) visited; /* object -> int */ int cnt; + pic_value shared; /* is object shared? (yes if >0) */ + pic_value labels; /* object -> int */ }; #define WRITE_MODE 1 @@ -27,34 +24,93 @@ struct writer_control { #define OP_WRITE_SIMPLE 3 static void -writer_control_init(struct writer_control *p, pic_state *pic, xFILE *file, int mode, int op) +writer_control_init(pic_state *pic, struct writer_control *p, int mode, int op) { - p->pic = pic; - p->file = file; p->mode = mode; p->op = op; p->cnt = 0; - kh_init(l, &p->labels); - kh_init(v, &p->visited); + p->shared = pic_make_weak(pic); + p->labels = pic_make_weak(pic); } static void -writer_control_destroy(struct writer_control *p) +traverse(pic_state *pic, pic_value obj, struct writer_control *p) { - pic_state *pic = p->pic; - kh_destroy(l, &p->labels); - kh_destroy(v, &p->visited); + pic_value shared = p->shared; + + if (p->op == OP_WRITE_SIMPLE) { + return; + } + + switch (pic_type(pic, obj)) { + case PIC_TYPE_PAIR: + case PIC_TYPE_VECTOR: + case PIC_TYPE_DICT: { + + if (! pic_weak_has(pic, shared, obj)) { + /* first time */ + pic_weak_set(pic, shared, obj, pic_int_value(pic, 0)); + + if (pic_pair_p(pic, obj)) { + /* pair */ + traverse(pic, pic_car(pic, obj), p); + traverse(pic, pic_cdr(pic, obj), p); + } else if (pic_vec_p(pic, obj)) { + /* vector */ + int i, len = pic_vec_len(pic, obj); + for (i = 0; i < len; ++i) { + traverse(pic, pic_vec_ref(pic, obj, i), p); + } + } else { + /* dictionary */ + int it = 0; + pic_value val; + while (pic_dict_next(pic, obj, &it, NULL, &val)) { + traverse(pic, val, p); + } + } + + if (p->op == OP_WRITE) { + if (pic_int(pic, pic_weak_ref(pic, shared, obj)) == 0) { + pic_weak_del(pic, shared, obj); + } + } + } else { + /* second time */ + pic_weak_set(pic, shared, obj, pic_int_value(pic, 1)); + } + break; + } + default: + break; + } +} + +static bool +is_shared_object(pic_state *pic, pic_value obj, struct writer_control *p) { + pic_value shared = p->shared; + + if (! pic_obj_p(pic, obj)) { + return false; + } + if (! pic_weak_has(pic, shared, obj)) { + return false; + } + return pic_int(pic, pic_weak_ref(pic, shared, obj)) > 0; } static void -write_blob(pic_state *pic, pic_blob *blob, xFILE *file) +write_blob(pic_state *pic, pic_value blob, xFILE *file) { - int i; + const unsigned char *buf; + int len, i; + + buf = pic_blob(pic, blob, &len); xfprintf(pic, file, "#u8("); - for (i = 0; i < blob->len; ++i) { - xfprintf(pic, file, "%d", blob->data[i]); - if (i + 1 < blob->len) { + for (i = 0; i < len; ++i) { + xfprintf(pic, file, "%d", buf[i]); + if (i + 1 < len) { xfprintf(pic, file, " "); } } @@ -62,9 +118,11 @@ write_blob(pic_state *pic, pic_blob *blob, xFILE *file) } static void -write_char(pic_state *pic, char c, xFILE *file, int mode) +write_char(pic_state *pic, pic_value ch, xFILE *file, struct writer_control *p) { - if (mode == DISPLAY_MODE) { + char c = pic_char(pic, ch); + + if (p->mode == DISPLAY_MODE) { xfputc(pic, c, file); return; } @@ -82,17 +140,17 @@ write_char(pic_state *pic, char c, xFILE *file, int mode) } static void -write_str(pic_state *pic, pic_str *str, xFILE *file, int mode) +write_str(pic_state *pic, pic_value str, xFILE *file, struct writer_control *p) { int i; - const char *cstr = pic_str_cstr(pic, str); + const char *cstr = pic_str(pic, str); - if (mode == DISPLAY_MODE) { - xfprintf(pic, file, "%s", pic_str_cstr(pic, str)); + if (p->mode == DISPLAY_MODE) { + xfprintf(pic, file, "%s", pic_str(pic, str)); return; } xfprintf(pic, file, "\""); - for (i = 0; i < pic_str_len(str); ++i) { + for (i = 0; i < pic_str_len(pic, str); ++i) { if (cstr[i] == '"' || cstr[i] == '\\') { xfputc(pic, '\\', file); } @@ -102,8 +160,10 @@ write_str(pic_state *pic, pic_str *str, xFILE *file, int mode) } static void -write_float(pic_state *pic, double f, xFILE *file) +write_float(pic_state *pic, pic_value flo, xFILE *file) { + double f = pic_float(pic, flo); + if (f != f) { xfprintf(pic, file, "+nan.0"); } else if (f == 1.0 / 0.0) { @@ -115,121 +175,92 @@ write_float(pic_state *pic, double f, xFILE *file) } } -static void write_core(struct writer_control *p, pic_value); +static void write_core(pic_state *, pic_value, xFILE *, struct writer_control *); static void -write_pair_help(struct writer_control *p, struct pic_pair *pair) +write_pair_help(pic_state *pic, pic_value pair, xFILE *file, struct writer_control *p) { - pic_state *pic = p->pic; - khash_t(l) *lh = &p->labels; - khash_t(v) *vh = &p->visited; - khiter_t it; - int ret; + pic_value cdr = pic_cdr(pic, pair); - write_core(p, pair->car); + write_core(pic, pic_car(pic, pair), file, p); - if (pic_nil_p(pair->cdr)) { + if (pic_nil_p(pic, cdr)) { return; } - else if (pic_pair_p(pair->cdr)) { - - /* shared objects */ - if ((it = kh_get(l, lh, pic_ptr(pair->cdr))) != kh_end(lh) && kh_val(lh, it) != -1) { - xfprintf(pic, p->file, " . "); - - kh_put(v, vh, pic_ptr(pair->cdr), &ret); - if (ret == 0) { /* if exists */ - xfprintf(pic, p->file, "#%d#", kh_val(lh, it)); - return; - } - xfprintf(pic, p->file, "#%d=", kh_val(lh, it)); - } - else { - xfprintf(pic, p->file, " "); - } - - write_pair_help(p, pic_pair_ptr(pair->cdr)); - - if (p->op == OP_WRITE) { - if ((it = kh_get(l, lh, pic_ptr(pair->cdr))) != kh_end(lh) && kh_val(lh, it) != -1) { - it = kh_get(v, vh, pic_ptr(pair->cdr)); - kh_del(v, vh, it); - } - } - return; + else if (pic_pair_p(pic, cdr) && ! is_shared_object(pic, cdr, p)) { + xfprintf(pic, file, " "); + write_pair_help(pic, cdr, file, p); } else { - xfprintf(pic, p->file, " . "); - write_core(p, pair->cdr); + xfprintf(pic, file, " . "); + write_core(pic, cdr, file, p); } } -static void -write_pair(struct writer_control *p, struct pic_pair *pair) -{ - pic_state *pic = p->pic; - xFILE *file = p->file; - pic_sym *tag; +#define EQ(sym, lit) (strcmp(pic_sym(pic, sym), lit) == 0) - if (pic_pair_p(pair->cdr) && pic_nil_p(pic_cdr(pic, pair->cdr)) && pic_sym_p(pair->car)) { - tag = pic_sym_ptr(pair->car); - if (tag == pic->sQUOTE) { +static void +write_pair(pic_state *pic, pic_value pair, xFILE *file, struct writer_control *p) +{ + pic_value tag; + + if (pic_pair_p(pic, pic_cdr(pic, pair)) && pic_nil_p(pic, pic_cddr(pic, pair)) && pic_sym_p(pic, pic_car(pic, pair))) { + tag = pic_car(pic, pair); + if (EQ(tag, "quote")) { xfprintf(pic, file, "'"); - write_core(p, pic_car(pic, pair->cdr)); + write_core(pic, pic_cadr(pic, pair), file, p); return; } - else if (tag == pic->sUNQUOTE) { + else if (EQ(tag, "unquote")) { xfprintf(pic, file, ","); - write_core(p, pic_car(pic, pair->cdr)); + write_core(pic, pic_cadr(pic, pair), file, p); return; } - else if (tag == pic->sUNQUOTE_SPLICING) { + else if (EQ(tag, "unquote-splicing")) { xfprintf(pic, file, ",@"); - write_core(p, pic_car(pic, pair->cdr)); + write_core(pic, pic_cadr(pic, pair), file, p); return; } - else if (tag == pic->sQUASIQUOTE) { + else if (EQ(tag, "quasiquote")) { xfprintf(pic, file, "`"); - write_core(p, pic_car(pic, pair->cdr)); + write_core(pic, pic_cadr(pic, pair), file, p); return; } - else if (tag == pic->sSYNTAX_QUOTE) { + else if (EQ(tag, "syntax-quote")) { xfprintf(pic, file, "#'"); - write_core(p, pic_car(pic, pair->cdr)); + write_core(pic, pic_cadr(pic, pair), file, p); return; } - else if (tag == pic->sSYNTAX_UNQUOTE) { + else if (EQ(tag, "syntax-unquote")) { xfprintf(pic, file, "#,"); - write_core(p, pic_car(pic, pair->cdr)); + write_core(pic, pic_cadr(pic, pair), file, p); return; } - else if (tag == pic->sSYNTAX_UNQUOTE_SPLICING) { + else if (EQ(tag, "syntax-unquote-splicing")) { xfprintf(pic, file, "#,@"); - write_core(p, pic_car(pic, pair->cdr)); + write_core(pic, pic_cadr(pic, pair), file, p); return; } - else if (tag == pic->sSYNTAX_QUASIQUOTE) { + else if (EQ(tag, "syntax-quasiquote")) { xfprintf(pic, file, "#`"); - write_core(p, pic_car(pic, pair->cdr)); + write_core(pic, pic_cadr(pic, pair), file, p); return; } } xfprintf(pic, file, "("); - write_pair_help(p, pair); + write_pair_help(pic, pair, file, p); xfprintf(pic, file, ")"); } static void -write_vec(struct writer_control *p, pic_vec *vec) +write_vec(pic_state *pic, pic_value vec, xFILE *file, struct writer_control *p) { - pic_state *pic = p->pic; - xFILE *file = p->file; - int i; + int i, len = pic_vec_len(pic, vec); xfprintf(pic, file, "#("); - for (i = 0; i < vec->len; ++i) { - write_core(p, vec->data[i]); - if (i + 1 < vec->len) { + for (i = 0; i < len; ++i) { + write_core(pic, pic_vec_ref(pic, vec, i), file, p); + if (i + 1 < len) { xfprintf(pic, file, " "); } } @@ -237,256 +268,231 @@ write_vec(struct writer_control *p, pic_vec *vec) } static void -write_dict(struct writer_control *p, struct pic_dict *dict) +write_dict(pic_state *pic, pic_value dict, xFILE *file, struct writer_control *p) { - pic_state *pic = p->pic; - xFILE *file = p->file; - pic_sym *sym; - khiter_t it; + pic_value key, val; + int it = 0; xfprintf(pic, file, "#.(dictionary"); - pic_dict_for_each (sym, dict, it) { - xfprintf(pic, file, " '%s ", pic_symbol_name(pic, sym)); - write_core(p, pic_dict_ref(pic, dict, sym)); + while (pic_dict_next(pic, dict, &it, &key, &val)) { + xfprintf(pic, file, " '%s ", pic_sym(pic, key)); + write_core(pic, val, file, p); } xfprintf(pic, file, ")"); } static void -write_core(struct writer_control *p, pic_value obj) +write_core(pic_state *pic, pic_value obj, xFILE *file, struct writer_control *p) { - pic_state *pic = p->pic; - khash_t(l) *lh = &p->labels; - khash_t(v) *vh = &p->visited; - xFILE *file = p->file; - khiter_t it; - int ret; + pic_value labels = p->labels; + int i; /* shared objects */ - if (pic_vtype(obj) == PIC_VTYPE_HEAP && ((it = kh_get(l, lh, pic_ptr(obj))) != kh_end(lh)) && kh_val(lh, it) != -1) { - kh_put(v, vh, pic_ptr(obj), &ret); - if (ret == 0) { /* if exists */ - xfprintf(pic, file, "#%d#", kh_val(lh, it)); + if (is_shared_object(pic, obj, p)) { + if (pic_weak_has(pic, labels, obj)) { + xfprintf(pic, file, "#%d#", pic_int(pic, pic_weak_ref(pic, labels, obj))); return; } - xfprintf(pic, file, "#%d=", kh_val(lh, it)); + i = p->cnt++; + xfprintf(pic, file, "#%d=", i); + pic_weak_set(pic, labels, obj, pic_int_value(pic, i)); } - switch (pic_type(obj)) { - case PIC_TT_UNDEF: + switch (pic_type(pic, obj)) { + case PIC_TYPE_UNDEF: xfprintf(pic, file, "#undefined"); break; - case PIC_TT_NIL: + case PIC_TYPE_NIL: xfprintf(pic, file, "()"); break; - case PIC_TT_BOOL: - xfprintf(pic, file, pic_true_p(obj) ? "#t" : "#f"); + case PIC_TYPE_TRUE: + xfprintf(pic, file, "#t"); break; - case PIC_TT_ID: - xfprintf(pic, file, "#", pic_identifier_name(pic, pic_id_ptr(obj))); + case PIC_TYPE_FALSE: + xfprintf(pic, file, "#f"); break; - case PIC_TT_EOF: + case PIC_TYPE_ID: + xfprintf(pic, file, "#", pic_str(pic, pic_id_name(pic, obj))); + break; + case PIC_TYPE_EOF: xfprintf(pic, file, "#.(eof-object)"); break; - case PIC_TT_INT: - xfprintf(pic, file, "%d", pic_int(obj)); + case PIC_TYPE_INT: + xfprintf(pic, file, "%d", pic_int(pic, obj)); break; - case PIC_TT_FLOAT: - write_float(pic, pic_float(obj), file); + case PIC_TYPE_SYMBOL: + xfprintf(pic, file, "%s", pic_sym(pic, obj)); break; - case PIC_TT_SYMBOL: - xfprintf(pic, file, "%s", pic_symbol_name(pic, pic_sym_ptr(obj))); + case PIC_TYPE_FLOAT: + write_float(pic, obj, file); break; - case PIC_TT_BLOB: - write_blob(pic, pic_blob_ptr(obj), file); + case PIC_TYPE_BLOB: + write_blob(pic, obj, file); break; - case PIC_TT_CHAR: - write_char(pic, pic_char(obj), file, p->mode); + case PIC_TYPE_CHAR: + write_char(pic, obj, file, p); break; - case PIC_TT_STRING: - write_str(pic, pic_str_ptr(obj), file, p->mode); + case PIC_TYPE_STRING: + write_str(pic, obj, file, p); break; - case PIC_TT_PAIR: - write_pair(p, pic_pair_ptr(obj)); + case PIC_TYPE_PAIR: + write_pair(pic, obj, file, p); break; - case PIC_TT_VECTOR: - write_vec(p, pic_vec_ptr(obj)); + case PIC_TYPE_VECTOR: + write_vec(pic, obj, file, p); break; - case PIC_TT_DICT: - write_dict(p, pic_dict_ptr(obj)); + case PIC_TYPE_DICT: + write_dict(pic, obj, file, p); break; default: - xfprintf(pic, file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj)); + xfprintf(pic, file, "#<%s %p>", pic_typename(pic, pic_type(pic, obj)), pic_obj_ptr(obj)); break; } if (p->op == OP_WRITE) { - if (pic_obj_p(obj) && ((it = kh_get(l, lh, pic_ptr(obj))) != kh_end(lh)) && kh_val(lh, it) != -1) { - it = kh_get(v, vh, pic_ptr(obj)); - kh_del(v, vh, it); + if (is_shared_object(pic, obj, p)) { + pic_weak_del(pic, labels, obj); } } } -static void -traverse(struct writer_control *p, pic_value obj) -{ - pic_state *pic = p->pic; - - if (p->op == OP_WRITE_SIMPLE) { - return; - } - - switch (pic_type(obj)) { - case PIC_TT_PAIR: - case PIC_TT_VECTOR: - case PIC_TT_DICT: { - khash_t(l) *h = &p->labels; - khiter_t it; - int ret; - - it = kh_put(l, h, pic_ptr(obj), &ret); - if (ret != 0) { - /* first time */ - kh_val(h, it) = -1; - - if (pic_pair_p(obj)) { - /* pair */ - traverse(p, pic_car(pic, obj)); - traverse(p, pic_cdr(pic, obj)); - } else if (pic_vec_p(obj)) { - /* vector */ - int i; - for (i = 0; i < pic_vec_ptr(obj)->len; ++i) { - traverse(p, pic_vec_ptr(obj)->data[i]); - } - } else { - /* dictionary */ - pic_sym *sym; - pic_dict_for_each (sym, pic_dict_ptr(obj), it) { - traverse(p, pic_dict_ref(pic, pic_dict_ptr(obj), sym)); - } - } - - if (p->op == OP_WRITE) { - it = kh_get(l, h, pic_ptr(obj)); - if (kh_val(h, it) == -1) { - kh_del(l, h, it); - } - } - } else if (kh_val(h, it) == -1) { - /* second time */ - kh_val(h, it) = p->cnt++; - } - break; - } - default: - break; - } -} - static void write(pic_state *pic, pic_value obj, xFILE *file, int mode, int op) { struct writer_control p; - writer_control_init(&p, pic, file, mode, op); + writer_control_init(pic, &p, mode, op); - traverse(&p, obj); + traverse(pic, obj, &p); - write_core(&p, obj); - - writer_control_destroy(&p); + write_core(pic, obj, file, &p); } - -pic_value -pic_write(pic_state *pic, pic_value obj) +void +pic_vfprintf(pic_state *pic, pic_value port, const char *fmt, va_list ap) { - return pic_fwrite(pic, obj, pic_stdout(pic)->file); -} + xFILE *file = pic_fileno(pic, port); + char c; -pic_value -pic_fwrite(pic_state *pic, pic_value obj, xFILE *file) -{ - write(pic, obj, file, WRITE_MODE, OP_WRITE); + while ((c = *fmt++) != '\0') { + switch (c) { + default: + xfputc(pic, c, file); + break; + case '%': + c = *fmt++; + if (! c) + goto exit; + switch (c) { + default: + xfputc(pic, c, file); + break; + case '%': + xfputc(pic, '%', file); + break; + case 'c': + xfprintf(pic, file, "%c", va_arg(ap, int)); + break; + case 's': + xfprintf(pic, file, "%s", va_arg(ap, const char *)); + break; + case 'd': + xfprintf(pic, file, "%d", va_arg(ap, int)); + break; + case 'p': + xfprintf(pic, file, "%p", va_arg(ap, void *)); + break; + case 'f': + xfprintf(pic, file, "%f", va_arg(ap, double)); + break; + } + break; + case '~': + c = *fmt++; + if (! c) + goto exit; + switch (c) { + default: + xfputc(pic, c, file); + break; + case '~': + xfputc(pic, '~', file); + break; + case '%': + xfputc(pic, '\n', file); + break; + case 'a': + write(pic, va_arg(ap, pic_value), file, DISPLAY_MODE, OP_WRITE); + break; + case 's': + write(pic, va_arg(ap, pic_value), file, WRITE_MODE, OP_WRITE); + break; + } + break; + } + } + exit: xfflush(pic, file); - return obj; } -pic_value -pic_display(pic_state *pic, pic_value obj) +void +pic_fprintf(pic_state *pic, pic_value port, const char *fmt, ...) { - return pic_fdisplay(pic, obj, pic_stdout(pic)->file); -} + va_list ap; -pic_value -pic_fdisplay(pic_state *pic, pic_value obj, xFILE *file) -{ - write(pic, obj, file, DISPLAY_MODE, OP_WRITE); - xfflush(pic, file); - return obj; + va_start(ap, fmt); + pic_vfprintf(pic, port, fmt, ap); + va_end(ap); } void pic_printf(pic_state *pic, const char *fmt, ...) { - xFILE *file = pic_stdout(pic)->file; va_list ap; - pic_str *str; va_start(ap, fmt); - - str = pic_vformat(pic, fmt, ap); - + pic_vfprintf(pic, pic_stdout(pic), fmt, ap); va_end(ap); - - xfprintf(pic, file, "%s", pic_str_cstr(pic, str)); - xfflush(pic, file); } static pic_value pic_write_write(pic_state *pic) { - pic_value v; - struct pic_port *port = pic_stdout(pic); + pic_value v, port = pic_stdout(pic); pic_get_args(pic, "o|p", &v, &port); - write(pic, v, port->file, WRITE_MODE, OP_WRITE); - return pic_undef_value(); + write(pic, v, pic_fileno(pic, port), WRITE_MODE, OP_WRITE); + return pic_undef_value(pic); } static pic_value pic_write_write_simple(pic_state *pic) { - pic_value v; - struct pic_port *port = pic_stdout(pic); + pic_value v, port = pic_stdout(pic); pic_get_args(pic, "o|p", &v, &port); - write(pic, v, port->file, WRITE_MODE, OP_WRITE_SIMPLE); - return pic_undef_value(); + write(pic, v, pic_fileno(pic, port), WRITE_MODE, OP_WRITE_SIMPLE); + return pic_undef_value(pic); } static pic_value pic_write_write_shared(pic_state *pic) { - pic_value v; - struct pic_port *port = pic_stdout(pic); + pic_value v, port = pic_stdout(pic); pic_get_args(pic, "o|p", &v, &port); - write(pic, v, port->file, WRITE_MODE, OP_WRITE_SHARED); - return pic_undef_value(); + write(pic, v, pic_fileno(pic, port), WRITE_MODE, OP_WRITE_SHARED); + return pic_undef_value(pic); } static pic_value pic_write_display(pic_state *pic) { - pic_value v; - struct pic_port *port = pic_stdout(pic); + pic_value v, port = pic_stdout(pic); pic_get_args(pic, "o|p", &v, &port); - write(pic, v, port->file, DISPLAY_MODE, OP_WRITE); - return pic_undef_value(); + write(pic, v, pic_fileno(pic, port), DISPLAY_MODE, OP_WRITE); + return pic_undef_value(pic); } void @@ -497,3 +503,5 @@ pic_init_write(pic_state *pic) pic_defun(pic, "write-shared", pic_write_write_shared); pic_defun(pic, "display", pic_write_display); } + +#endif diff --git a/src/main.c b/src/main.c index fa67bdad..9b45df9a 100644 --- a/src/main.c +++ b/src/main.c @@ -3,32 +3,13 @@ */ #include "picrin.h" - -void pic_init_contrib(pic_state *); -void pic_load_piclib(pic_state *); - -static pic_value -pic_libraries(pic_state *pic) -{ - pic_value libs = pic_nil_value(), lib, it; - - pic_get_args(pic, ""); - - pic_for_each (lib, pic->libs, it) { - libs = pic_cons(pic, pic_car(pic, lib), libs); - } - - return libs; -} +#include "picrin/extra.h" void pic_init_picrin(pic_state *pic) { - pic_add_feature(pic, "r7rs"); - - pic_deflibrary (pic, "(picrin library)") { - pic_defun(pic, "libraries", pic_libraries); - } + void pic_init_contrib(pic_state *); + void pic_load_piclib(pic_state *); pic_init_contrib(pic); pic_load_piclib(pic); @@ -42,7 +23,6 @@ int main(int argc, char *argv[], char **envp) { pic_state *pic; - struct pic_lib *PICRIN_MAIN; int status; pic = pic_open(pic_default_allocf, NULL); @@ -54,14 +34,12 @@ main(int argc, char *argv[], char **envp) pic_try { pic_init_picrin(pic); - PICRIN_MAIN = pic_find_library(pic, pic_read_cstr(pic, "(picrin main)")); - - pic_funcall(pic, PICRIN_MAIN, "main", pic_nil_value()); + pic_funcall(pic, "picrin.main", "main", 0); status = 0; } pic_catch { - pic_print_backtrace(pic, xstderr); + pic_print_error(pic, xstderr); status = 1; } diff --git a/t/issue/foo-map.scm b/t/issue/foo-map.scm new file mode 100644 index 00000000..e52fa3e5 --- /dev/null +++ b/t/issue/foo-map.scm @@ -0,0 +1,42 @@ +(import (scheme base) + (picrin test)) + +(test-begin) + +(define (char-inc c) + (integer->char (+ (char->integer c) 1))) + +(define (char-dec c) + (integer->char (- (char->integer c) 1))) + +(test "tsvcmxdmqr" + (string-map (lambda (c k) + ((if (eqv? k #\+) char-inc char-dec) c)) + "studlycnps xxx" + "+-+-+-+-+-")) + +(test "abcdefgh" + (begin + (define s "") + (string-for-each + (lambda (a b) + (set! s (string-append s (string a b)))) + "aceg hij" + "bdfh") + s)) + +(test #(#(1 6 9) #(2 7 10) #(3 8 11)) + (vector-map vector #(1 2 3 4 5) #(6 7 8) #(9 10 11 12))) + +(test "(1 4 1)(2 5 1)" + (call-with-port (open-output-string) + (lambda (port) + (parameterize ((current-output-port port)) + (vector-for-each + (lambda args (display args)) + #(1 2 3) + #(4 5) + #(1 1)) + (get-output-string port))))) + +(test-end)