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

Merge pull request #332 from picrin-scheme/moving-gc 

towards moving gc
This commit is contained in:
Yuichi Nishiwaki 2016-02-23 14:22:27 +09:00
parent 2fec4a3879 a96e5a0beb
commit 8421cfb00a
88 changed files with 5706 additions and 7201 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
Makefile
View File

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

137
contrib/10.callcc/callcc.c
View File

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

4
contrib/10.macro/macro.scm
View File

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

121
contrib/10.math/math.c
View File

@ -1,4 +1,5 @@
#include "picrin.h"
#include "picrin/extra.h"
#include <math.h>
@ -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);
}

1
contrib/20.r7rs/nitro.mk
View File

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

71
contrib/20.r7rs/scheme/base.scm
View File

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

11
contrib/20.r7rs/scheme/eval.scm
View File

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

4
contrib/20.r7rs/scheme/r5rs.scm
View File

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

64
contrib/20.r7rs/src/file.c
View File

@ -3,61 +3,45 @@
*/
#include "picrin.h"
#include "picrin/extra.h"
#include <stdio.h>
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);
}

22
contrib/20.r7rs/src/load.c
View File

@ -3,29 +3,37 @@
*/
#include "picrin.h"
#include "picrin/extra.h"
#include <stdio.h>
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);
}

93
contrib/20.r7rs/src/mutable-string.c
View File

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

4
contrib/20.r7rs/src/r7rs.c
View File

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

65
contrib/20.r7rs/src/system.c
View File

@ -5,6 +5,7 @@
#include <stdlib.h>
#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);
}

17
contrib/20.r7rs/src/time.c
View File

@ -5,6 +5,7 @@
#include <time.h>
#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);
}

2
contrib/20.r7rs/t/r7rs.scm
View File

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

9
contrib/30.random/src/random.c
View File

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

107
contrib/30.readline/src/readline.c
View File

@ -6,6 +6,7 @@
forget to use the C++ extern "C" to get it to compile.
*/
#include "picrin.h"
#include "picrin/extra.h"
#include <editline/readline.h>
@ -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);
}

93
contrib/30.regexp/src/regexp.c
View File

@ -1,4 +1,5 @@
#include "picrin.h"
#include "picrin/extra.h"
#include <regex.h>
@ -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), &regexp_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->reg, errbuf, sizeof errbuf);
regexp_dtor(pic, &reg->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, &regexp_type, reg));
return pic_data_value(pic, reg, &regexp_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, &regexp_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", &reg, &input);
pic_get_args(pic, "uz", &reg, &regexp_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->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->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", &reg, &input);
pic_get_args(pic, "uz", &reg, &regexp_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->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", &reg, &input, &txt);
pic_get_args(pic, "uzs", &reg, &regexp_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->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);
}

258
contrib/40.srfi/src/106.c
View File

@ -1,4 +1,5 @@
#include "picrin.h"
#include "picrin/extra.h"
#include <errno.h>
#include <netdb.h>
@ -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
}
}

2
contrib/40.srfi/srfi/106.scm
View File

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

11
contrib/60.repl/repl.c
View File

@ -1,21 +1,20 @@
#include "picrin.h"
#include "picrin/extra.h"
#include <unistd.h>
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);
}

42
contrib/60.repl/repl.scm
View File

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

2
contrib/70.main/main.scm
View File

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

7
docs/capi.rst
View File

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

7
etc/mkloader.pl
View File

@ -12,6 +12,7 @@ print <<EOL;
*/
#include "picrin.h"
#include "picrin/extra.h"
EOL
@ -53,16 +54,12 @@ EOL
pic_catch {
/* error! */
xfputs(pic, "fatal error: failure in loading $dirname/$basename\\n", xstderr);
pic_raise(pic, pic->err);
pic_raise(pic, pic_err(pic));
}
EOL
}
print <<EOL;
#if DEBUG
puts("successfully loaded stdlib");
#endif
}
EOL

8
extlib/benz/README.md
View File

@ -10,6 +10,7 @@ Originally, Benz used to be the core component of [Picrin Scheme](https://github
#include <stdio.h>
#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

179
extlib/benz/blob.c
View File

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

155
extlib/benz/bool.c
View File

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

126
extlib/benz/boot.c
View File

@ -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",
"",
""
};

29
extlib/benz/char.c
View File

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

277
extlib/benz/cont.c
View File

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

26
extlib/benz/data.c
View File

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

69
extlib/benz/debug.c
View File

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

173
extlib/benz/dict.c
View File

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

197
extlib/benz/error.c
View File

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

766
extlib/benz/eval.c
View File

File diff suppressed because it is too large Load Diff

285
extlib/benz/file.c
View File

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

363
extlib/benz/gc.c
View File

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

30
extlib/benz/include/picconf.h Normal file
View File

@ -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 */

418
extlib/benz/include/picrin.h
View File

@ -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 <limits.h>
#include <stdarg.h>
#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 <stdint.h>
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)
}

27
extlib/benz/include/picrin/blob.h
View File

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

153
extlib/benz/include/picrin/config.h
View File

@ -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 <setjmp.h>
# define PIC_JMPBUF jmp_buf
#endif
#ifndef PIC_SETJMP
# include <setjmp.h>
# define PIC_SETJMP(pic, buf) setjmp(buf)
#endif
#ifndef PIC_LONGJMP
# include <setjmp.h>
# 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 <stdio.h>
# define GC_STRESS 0
# define VM_DEBUG 1
# define GC_DEBUG 0
# define GC_DEBUG_DETAIL 0
#endif

54
extlib/benz/include/picrin/cont.h
View File

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

37
extlib/benz/include/picrin/data.h
View File

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

40
extlib/benz/include/picrin/dict.h
View File

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

64
extlib/benz/include/picrin/error.h
View File

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

124
extlib/benz/include/picrin/extra.h Normal file
View File

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

104
extlib/benz/include/picrin/file.h
View File

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

42
extlib/benz/include/picrin/irep.h
View File

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

26
extlib/benz/include/picrin/lib.h
View File

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

38
extlib/benz/include/picrin/macro.h
View File

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

215
extlib/benz/include/picrin/opcode.h
View File

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

97
extlib/benz/include/picrin/pair.h
View File

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

42
extlib/benz/include/picrin/port.h
View File

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

42
extlib/benz/include/picrin/private/file.h Normal file
View File

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

9
extlib/benz/include/picrin/gc.h → extlib/benz/include/picrin/private/gc.h
View File

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

52
extlib/benz/include/picrin/khash.h → extlib/benz/include/picrin/private/khash.h
View File

@ -24,13 +24,8 @@
SOFTWARE.
*/
#ifndef AC_KHASH_H
#define AC_KHASH_H
#include <stddef.h>
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)

198
extlib/benz/include/picrin/private/object.h Normal file
View File

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

88
extlib/benz/include/picrin/private/state.h Normal file
View File

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

85
extlib/benz/include/picrin/private/vm.h Normal file
View File

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

59
extlib/benz/include/picrin/proc.h
View File

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

33
extlib/benz/include/picrin/read.h
View File

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

30
extlib/benz/include/picrin/record.h
View File

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

134
extlib/benz/include/picrin/compat.h → extlib/benz/include/picrin/setup.h
View File

@ -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 <setjmp.h>
# define PIC_JMPBUF jmp_buf
#endif
#ifndef PIC_SETJMP
# include <setjmp.h>
# define PIC_SETJMP(pic, buf) setjmp(buf)
#endif
#ifndef PIC_LONGJMP
# include <setjmp.h>
# 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 <stdbool.h>
#else
@ -20,7 +89,7 @@ extern "C" {
#if __STDC_VERSION__ >= 199901L
# include <stddef.h>
#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 <string.h>
#include <ctype.h>
@ -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 <stdio.h>
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

42
extlib/benz/include/picrin/string.h
View File

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

46
extlib/benz/include/picrin/symbol.h
View File

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

598
extlib/benz/include/picrin/type.h
View File

@ -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 <stdint.h>
/**
* 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

27
extlib/benz/include/picrin/vector.h
View File

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

34
extlib/benz/include/picrin/weak.h
View File

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

358
extlib/benz/lib.c
View File

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

17
extlib/benz/load.c
View File

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

365
extlib/benz/macro.c
View File

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

132
extlib/benz/number.c
View File

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

634
extlib/benz/pair.c
View File

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

898
extlib/benz/port.c
View File

File diff suppressed because it is too large Load Diff

812
extlib/benz/proc.c
View File

File diff suppressed because it is too large Load Diff

614
extlib/benz/read.c
View File

File diff suppressed because it is too large Load Diff

33
extlib/benz/record.c
View File

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

250
extlib/benz/state.c
View File

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

534
extlib/benz/string.c
View File

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

112
extlib/benz/symbol.c
View File

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

261
extlib/benz/value.c Normal file
View File

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

67
extlib/benz/var.c
View File

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

291
extlib/benz/vector.c
View File

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

121
extlib/benz/weak.c
View File

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

518
extlib/benz/write.c
View File

@ -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, "#<identifier %s>", 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, "#<identifier %s>", 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

32
src/main.c
View File

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

42
t/issue/foo-map.scm Normal file
View File

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