diff --git a/Makefile b/Makefile index ea71bca4..9758d93a 100644 --- a/Makefile +++ b/Makefile @@ -12,6 +12,7 @@ PICRIN_LIBS = \ piclib/picrin/macro.scm\ piclib/picrin/record.scm\ piclib/picrin/array.scm\ + piclib/picrin/control.scm\ piclib/picrin/experimental/lambda.scm\ piclib/picrin/syntax-rules.scm\ piclib/picrin/test.scm @@ -33,7 +34,7 @@ all: bin/picrin include $(sort $(wildcard contrib/*/nitro.mk)) -debug: CFLAGS += -O0 -g -DDEBUG=1 +debug: CFLAGS += -O0 -g debug: bin/picrin bin/picrin: $(PICRIN_OBJS) $(CONTRIB_OBJS) lib/libbenz.a @@ -48,6 +49,10 @@ src/init_contrib.c: lib/libbenz.a: $(BENZ_OBJS) $(AR) $(ARFLAGS) $@ $(BENZ_OBJS) +extlib/benz/boot.o: extlib/benz/boot.c + cd extlib/benz; perl boot.c + $(CC) $(CFLAGS) -c -o $@ $< + $(BENZ_OBJS) $(PICRIN_OBJS) $(CONTRIB_OBJS): extlib/benz/include/picrin.h extlib/benz/include/picrin/*.h doc: docs/*.rst docs/contrib.rst @@ -64,15 +69,12 @@ docs/contrib.rst: $(CONTRIB_DOCS) run: bin/picrin bin/picrin -test: test-r7rs test-contribs test-nostdlib - -test-r7rs: bin/picrin t/r7rs-tests.scm - bin/picrin t/r7rs-tests.scm +test: test-contribs test-nostdlib test-contribs: bin/picrin $(CONTRIB_TESTS) test-nostdlib: - $(CC) -I extlib/benz/include -D'PIC_ENABLE_LIBC=0' -D'PIC_ENABLE_FLOAT=0'-nostdlib -fPIC -shared -std=c89 -ansi -pedantic -Wall -Wextra -o lib/libbenz.so $(BENZ_SRCS) + $(CC) -I extlib/benz/include -D'PIC_ENABLE_LIBC=0' -D'PIC_ENABLE_FLOAT=0' -D'PIC_ENABLE_STDIO=0' -nostdlib -fPIC -shared -std=c89 -ansi -pedantic -Wall -Wextra -o lib/libbenz.so $(BENZ_SRCS) etc/libc_polyfill.c -fno-stack-protector rm -f lib/libbenz.so install: all @@ -85,4 +87,4 @@ clean: rm -f $(PICRIN_OBJS) rm -f $(CONTRIB_OBJS) -.PHONY: all insall clean run test test-r7rs test-contribs doc $(CONTRIB_TESTS) +.PHONY: all install clean run test test-r7rs test-contribs doc $(CONTRIB_TESTS) diff --git a/contrib/03.callcc/nitro.mk b/contrib/03.callcc/nitro.mk deleted file mode 100644 index 60dbe96b..00000000 --- a/contrib/03.callcc/nitro.mk +++ /dev/null @@ -1,2 +0,0 @@ -CONTRIB_INITS += callcc -CONTRIB_SRCS += $(wildcard contrib/03.callcc/*.c) diff --git a/contrib/05.r7rs/nitro.mk b/contrib/05.r7rs/nitro.mk deleted file mode 100644 index 56bf8f2f..00000000 --- a/contrib/05.r7rs/nitro.mk +++ /dev/null @@ -1,24 +0,0 @@ -CONTRIB_INITS += r7rs - -CONTRIB_SRCS += \ - contrib/05.r7rs/src/r7rs.c\ - contrib/05.r7rs/src/file.c\ - contrib/05.r7rs/src/load.c\ - contrib/05.r7rs/src/mutable-string.c\ - contrib/05.r7rs/src/system.c\ - contrib/05.r7rs/src/time.c - -CONTRIB_LIBS += \ - contrib/05.r7rs/scheme/base.scm\ - contrib/05.r7rs/scheme/cxr.scm\ - contrib/05.r7rs/scheme/read.scm\ - contrib/05.r7rs/scheme/write.scm\ - contrib/05.r7rs/scheme/file.scm\ - contrib/05.r7rs/scheme/case-lambda.scm\ - contrib/05.r7rs/scheme/lazy.scm\ - contrib/05.r7rs/scheme/eval.scm\ - contrib/05.r7rs/scheme/inexact.scm\ - contrib/05.r7rs/scheme/load.scm\ - contrib/05.r7rs/scheme/process-context.scm\ - contrib/05.r7rs/scheme/time.scm\ - contrib/05.r7rs/scheme/r5rs.scm diff --git a/contrib/05.r7rs/scheme/case-lambda.scm b/contrib/05.r7rs/scheme/case-lambda.scm deleted file mode 100644 index fff2b26c..00000000 --- a/contrib/05.r7rs/scheme/case-lambda.scm +++ /dev/null @@ -1,29 +0,0 @@ -(define-library (scheme case-lambda) - (import (scheme base)) - - (define-syntax case-lambda - (syntax-rules () - ((case-lambda (params body0 ...) ...) - (lambda args - (let ((len (length args))) - (letrec-syntax - ((cl (syntax-rules ::: () - ((cl) - (error "no matching clause")) - ((cl ((p :::) . body) . rest) - (if (= len (length '(p :::))) - (apply (lambda (p :::) - . body) - args) - (cl . rest))) - ((cl ((p ::: . tail) . body) - . rest) - (if (>= len (length '(p :::))) - (apply - (lambda (p ::: . tail) - . body) - args) - (cl . rest)))))) - (cl (params body0 ...) ...))))))) - - (export case-lambda)) diff --git a/contrib/05.r7rs/scheme/eval.scm b/contrib/05.r7rs/scheme/eval.scm deleted file mode 100644 index 54574c03..00000000 --- a/contrib/05.r7rs/scheme/eval.scm +++ /dev/null @@ -1,17 +0,0 @@ -(define-library (scheme eval) - (import (picrin base)) - - (define environment - (let ((counter 0)) - (lambda specs - (let ((library-name `(picrin @@my-environment ,counter))) - (set! counter (+ counter 1)) - (eval - `(define-library ,library-name - ,@(map (lambda (spec) - `(import ,spec)) - specs)) - '(scheme base)) - library-name)))) - - (export environment eval)) diff --git a/contrib/05.r7rs/scheme/lazy.scm b/contrib/05.r7rs/scheme/lazy.scm deleted file mode 100644 index 70774f21..00000000 --- a/contrib/05.r7rs/scheme/lazy.scm +++ /dev/null @@ -1,42 +0,0 @@ -;;; Appendix A. Standard Libraries Lazy - -(define-library (scheme lazy) - (import (scheme base) - (picrin macro)) - - (define-record-type - (make-promise% done obj) - promise? - (done promise-done? promise-done!) - (obj promise-value promise-value!)) - - (define-syntax delay-force - (ir-macro-transformer - (lambda (form rename compare?) - (let ((expr (cadr form))) - `(make-promise% #f (lambda () ,expr)))))) - - (define-syntax delay - (ir-macro-transformer - (lambda (form rename compare?) - (let ((expr (cadr form))) - `(delay-force (make-promise% #t ,expr)))))) - - (define (promise-update! new old) - (promise-done! old (promise-done? new)) - (promise-value! old (promise-value new))) - - (define (force promise) - (if (promise-done? promise) - (promise-value promise) - (let ((promise* ((promise-value promise)))) - (unless (promise-done? promise) - (promise-update! promise* promise)) - (force promise)))) - - (define (make-promise obj) - (if (promise? obj) - obj - (make-promise% #t obj))) - - (export delay-force delay force make-promise promise?)) diff --git a/contrib/03.callcc/callcc.c b/contrib/10.callcc/callcc.c similarity index 93% rename from contrib/03.callcc/callcc.c rename to contrib/10.callcc/callcc.c index 7b6b9609..36ac9ed5 100644 --- a/contrib/03.callcc/callcc.c +++ b/contrib/10.callcc/callcc.c @@ -3,7 +3,7 @@ struct pic_fullcont { jmp_buf jmp; - pic_jmpbuf *prev_jmp; + struct pic_cont *prev_jmp; pic_checkpoint *cp; @@ -122,7 +122,7 @@ save_cont(pic_state *pic, struct pic_fullcont **c) cont = *c = pic_malloc(pic, sizeof(struct pic_fullcont)); - cont->prev_jmp = pic->jmp; + cont->prev_jmp = pic->cc; cont->cp = pic->cp; @@ -178,11 +178,10 @@ restore_cont(pic_state *pic, struct pic_fullcont *cont) if (&v > cont->stk_pos) native_stack_extend(pic, cont); } else { - if (&v > cont->stk_pos + cont->stk_len) native_stack_extend(pic, cont); + if (&v < cont->stk_pos + cont->stk_len) native_stack_extend(pic, cont); } - pic->jmp = cont->prev_jmp; - + pic->cc = cont->prev_jmp; pic->cp = cont->cp; pic->stbase = pic_realloc(pic, pic->stbase, sizeof(pic_value) * cont->st_len); @@ -247,7 +246,7 @@ pic_callcc_full(pic_state *pic, struct pic_proc *proc) struct pic_proc *c; struct pic_data *dat; - c = pic_make_proc(pic, cont_call, ""); + c = pic_make_proc(pic, cont_call); dat = pic_data_alloc(pic, &cont_type, cont); @@ -271,7 +270,7 @@ pic_callcc_full_trampoline(pic_state *pic, struct pic_proc *proc) struct pic_proc *c; struct pic_data *dat; - c = pic_make_proc(pic, cont_call, ""); + c = pic_make_proc(pic, cont_call); dat = pic_data_alloc(pic, &cont_type, cont); @@ -293,15 +292,11 @@ pic_callcc_callcc(pic_state *pic) } #define pic_redefun(pic, lib, name, func) \ - pic_set(pic, lib, name, pic_obj_value(pic_make_proc(pic, func, name))) + pic_set(pic, lib, name, pic_obj_value(pic_make_proc(pic, func))) void pic_init_callcc(pic_state *pic) { - pic_deflibrary (pic, "(picrin control)") { - pic_define(pic, "escape", pic_ref(pic, pic->PICRIN_BASE, "call-with-current-continuation")); - } - 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); diff --git a/contrib/10.callcc/nitro.mk b/contrib/10.callcc/nitro.mk new file mode 100644 index 00000000..0779aa0f --- /dev/null +++ b/contrib/10.callcc/nitro.mk @@ -0,0 +1,2 @@ +CONTRIB_INITS += callcc +CONTRIB_SRCS += $(wildcard contrib/10.callcc/*.c) diff --git a/contrib/10.optional/nitro.mk b/contrib/10.optional/nitro.mk deleted file mode 100644 index 9048a19f..00000000 --- a/contrib/10.optional/nitro.mk +++ /dev/null @@ -1,7 +0,0 @@ -CONTRIB_LIBS += $(wildcard contrib/10.optional/piclib/*.scm) -CONTRIB_TESTS += test-optional - -test-optional: bin/picrin - for test in `ls contrib/10.optional/t/*.scm`; do \ - bin/picrin $$test; \ - done diff --git a/contrib/10.partcont/nitro.mk b/contrib/10.partcont/nitro.mk deleted file mode 100644 index 454bd39d..00000000 --- a/contrib/10.partcont/nitro.mk +++ /dev/null @@ -1 +0,0 @@ -CONTRIB_LIBS += $(wildcard contrib/10.partcont/piclib/*.scm) diff --git a/contrib/10.pretty-print/nitro.mk b/contrib/10.pretty-print/nitro.mk deleted file mode 100644 index 28070d61..00000000 --- a/contrib/10.pretty-print/nitro.mk +++ /dev/null @@ -1 +0,0 @@ -CONTRIB_LIBS += contrib/10.pretty-print/pretty-print.scm diff --git a/contrib/10.srfi/nitro.mk b/contrib/10.srfi/nitro.mk deleted file mode 100644 index d8ac54ab..00000000 --- a/contrib/10.srfi/nitro.mk +++ /dev/null @@ -1,9 +0,0 @@ -CONTRIB_LIBS += \ - contrib/10.srfi/srfi/1.scm\ - contrib/10.srfi/srfi/8.scm\ - contrib/10.srfi/srfi/17.scm\ - contrib/10.srfi/srfi/26.scm\ - contrib/10.srfi/srfi/43.scm\ - contrib/10.srfi/srfi/60.scm\ - contrib/10.srfi/srfi/95.scm\ - contrib/10.srfi/srfi/111.scm diff --git a/contrib/20.for/nitro.mk b/contrib/20.for/nitro.mk deleted file mode 100644 index b2c2cbad..00000000 --- a/contrib/20.for/nitro.mk +++ /dev/null @@ -1,7 +0,0 @@ -CONTRIB_LIBS += $(wildcard contrib/20.for/piclib/*.scm) -CONTRIB_TESTS += test-for - -test-for: bin/picrin - for test in `ls contrib/20.for/t/*.scm`; do \ - bin/picrin "$$test"; \ - done diff --git a/contrib/05.r7rs/docs/doc.rst b/contrib/20.r7rs/docs/doc.rst similarity index 100% rename from contrib/05.r7rs/docs/doc.rst rename to contrib/20.r7rs/docs/doc.rst diff --git a/contrib/20.r7rs/nitro.mk b/contrib/20.r7rs/nitro.mk new file mode 100644 index 00000000..9ddf756f --- /dev/null +++ b/contrib/20.r7rs/nitro.mk @@ -0,0 +1,31 @@ +CONTRIB_INITS += r7rs + +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 + +CONTRIB_LIBS += \ + contrib/20.r7rs/scheme/base.scm\ + contrib/20.r7rs/scheme/cxr.scm\ + contrib/20.r7rs/scheme/read.scm\ + contrib/20.r7rs/scheme/write.scm\ + contrib/20.r7rs/scheme/file.scm\ + contrib/20.r7rs/scheme/case-lambda.scm\ + contrib/20.r7rs/scheme/lazy.scm\ + contrib/20.r7rs/scheme/eval.scm\ + contrib/20.r7rs/scheme/inexact.scm\ + contrib/20.r7rs/scheme/load.scm\ + contrib/20.r7rs/scheme/process-context.scm\ + contrib/20.r7rs/scheme/time.scm\ + contrib/20.r7rs/scheme/r5rs.scm + +CONTRIB_TESTS += test-r7rs + +test-r7rs: bin/picrin + for test in `ls contrib/20.r7rs/t/*.scm`; do \ + bin/picrin "$$test"; \ + done diff --git a/contrib/05.r7rs/scheme/base.scm b/contrib/20.r7rs/scheme/base.scm similarity index 99% rename from contrib/05.r7rs/scheme/base.scm rename to contrib/20.r7rs/scheme/base.scm index 08d438c0..927643aa 100644 --- a/contrib/05.r7rs/scheme/base.scm +++ b/contrib/20.r7rs/scheme/base.scm @@ -518,4 +518,6 @@ write-string write-u8 write-bytevector - flush-output-port)) + flush-output-port) + + (export features)) diff --git a/contrib/20.r7rs/scheme/case-lambda.scm b/contrib/20.r7rs/scheme/case-lambda.scm new file mode 100644 index 00000000..6a6ca432 --- /dev/null +++ b/contrib/20.r7rs/scheme/case-lambda.scm @@ -0,0 +1,26 @@ +(define-library (scheme case-lambda) + (import (scheme base)) + + (define (length+ list) + (if (pair? list) + (+ 1 (length+ (cdr list))) + 0)) + + (define-syntax case-lambda + (syntax-rules () + ((case-lambda (params body0 ...) ...) + (lambda args + (let ((len (length args))) + (letrec-syntax + ((cl (syntax-rules () + ((cl) + (error "no matching clause")) + ((cl (formal . body) . rest) + (if (if (list? 'formal) + (= len (length 'formal)) + (>= len (length+ 'formal))) + (apply (lambda formal . body) args) + (cl . rest)))))) + (cl (params body0 ...) ...))))))) + + (export case-lambda)) diff --git a/contrib/05.r7rs/scheme/cxr.scm b/contrib/20.r7rs/scheme/cxr.scm similarity index 100% rename from contrib/05.r7rs/scheme/cxr.scm rename to contrib/20.r7rs/scheme/cxr.scm diff --git a/contrib/20.r7rs/scheme/eval.scm b/contrib/20.r7rs/scheme/eval.scm new file mode 100644 index 00000000..b93764cd --- /dev/null +++ b/contrib/20.r7rs/scheme/eval.scm @@ -0,0 +1,15 @@ +(define-library (scheme eval) + (import (picrin base)) + + (define environment + (let ((counter 0)) + (lambda specs + (let ((library-name `(picrin @@my-environment ,(string->symbol (number->string counter))))) + (set! counter (+ counter 1)) + (eval + `(define-library ,library-name + ,@(map (lambda (spec) `(import ,spec)) specs)) + (library-environment (find-library '(scheme base)))) + (library-environment (find-library library-name)))))) + + (export environment eval)) diff --git a/contrib/05.r7rs/scheme/file.scm b/contrib/20.r7rs/scheme/file.scm similarity index 100% rename from contrib/05.r7rs/scheme/file.scm rename to contrib/20.r7rs/scheme/file.scm diff --git a/contrib/05.r7rs/scheme/inexact.scm b/contrib/20.r7rs/scheme/inexact.scm similarity index 100% rename from contrib/05.r7rs/scheme/inexact.scm rename to contrib/20.r7rs/scheme/inexact.scm diff --git a/contrib/20.r7rs/scheme/lazy.scm b/contrib/20.r7rs/scheme/lazy.scm new file mode 100644 index 00000000..7378c384 --- /dev/null +++ b/contrib/20.r7rs/scheme/lazy.scm @@ -0,0 +1,40 @@ +;;; Appendix A. Standard Libraries Lazy + +(define-library (scheme lazy) + (import (scheme base) + (picrin macro)) + + (define-record-type + (make-promise% done value) + promise? + (done promise-done? set-promise-done!) + (value promise-value set-promise-value!)) + + (define-syntax delay-force + (syntax-rules () + ((_ expr) + (make-promise% #f (lambda () expr))))) + + (define-syntax delay + (syntax-rules () + ((_ expr) + (delay-force (make-promise% #t expr))))) + + (define (force promise) + (if (promise-done? promise) + (promise-value promise) + (let ((new-promise ((promise-value promise)))) + (set-promise-done! promise (promise-done? new-promise)) + (set-promise-value! promise (promise-value new-promise)) + (force promise)))) + + (define (make-promise obj) + (if (promise? obj) + obj + (make-promise% #t obj))) + + (export delay-force + delay + force + make-promise + promise?)) diff --git a/contrib/05.r7rs/scheme/load.scm b/contrib/20.r7rs/scheme/load.scm similarity index 100% rename from contrib/05.r7rs/scheme/load.scm rename to contrib/20.r7rs/scheme/load.scm diff --git a/contrib/05.r7rs/scheme/process-context.scm b/contrib/20.r7rs/scheme/process-context.scm similarity index 100% rename from contrib/05.r7rs/scheme/process-context.scm rename to contrib/20.r7rs/scheme/process-context.scm diff --git a/contrib/05.r7rs/scheme/r5rs.scm b/contrib/20.r7rs/scheme/r5rs.scm similarity index 95% rename from contrib/05.r7rs/scheme/r5rs.scm rename to contrib/20.r7rs/scheme/r5rs.scm index 9baebe65..e054f3bb 100644 --- a/contrib/05.r7rs/scheme/r5rs.scm +++ b/contrib/20.r7rs/scheme/r5rs.scm @@ -7,7 +7,8 @@ (scheme cxr) (scheme lazy) (scheme eval) - (scheme load)) + (scheme load) + (picrin base)) (define-library (scheme null) (import (scheme base)) @@ -25,12 +26,12 @@ (define (null-environment n) (if (not (= n 5)) (error "unsupported environment version" n) - '(scheme null))) + (library-environment (find-library '(scheme null))))) (define (scheme-report-environment n) (if (not (= n 5)) (error "unsupported environment version" n) - '(scheme r5rs))) + (library-environment (find-library '(scheme r5rs))))) (export * + - / < <= = > >= abs acos and diff --git a/contrib/05.r7rs/scheme/read.scm b/contrib/20.r7rs/scheme/read.scm similarity index 100% rename from contrib/05.r7rs/scheme/read.scm rename to contrib/20.r7rs/scheme/read.scm diff --git a/contrib/05.r7rs/scheme/time.scm b/contrib/20.r7rs/scheme/time.scm similarity index 100% rename from contrib/05.r7rs/scheme/time.scm rename to contrib/20.r7rs/scheme/time.scm diff --git a/contrib/05.r7rs/scheme/write.scm b/contrib/20.r7rs/scheme/write.scm similarity index 100% rename from contrib/05.r7rs/scheme/write.scm rename to contrib/20.r7rs/scheme/write.scm diff --git a/contrib/05.r7rs/src/file.c b/contrib/20.r7rs/src/file.c similarity index 74% rename from contrib/05.r7rs/src/file.c rename to contrib/20.r7rs/src/file.c index ce9cb1b2..340a5e6d 100644 --- a/contrib/05.r7rs/src/file.c +++ b/contrib/20.r7rs/src/file.c @@ -4,6 +4,8 @@ #include "picrin.h" +#include + PIC_NORETURN static void file_error(pic_state *pic, const char *msg) { @@ -14,25 +16,6 @@ file_error(pic_state *pic, const char *msg) pic_raise(pic, pic_obj_value(e)); } -static pic_value -generic_open_file(pic_state *pic, const char *fname, char *mode, short flags) -{ - struct pic_port *port; - xFILE *file; - - file = xfopen(fname, mode); - if (! file) { - file_error(pic, "could not open file"); - } - - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); - port->file = file; - port->flags = flags; - port->status = PIC_PORT_OPEN; - - return pic_obj_value(port); -} - pic_value pic_file_open_input_file(pic_state *pic) { @@ -41,7 +24,7 @@ pic_file_open_input_file(pic_state *pic) pic_get_args(pic, "z", &fname); - return generic_open_file(pic, fname, "r", flags); + return pic_obj_value(pic_open_file(pic, fname, flags)); } pic_value @@ -52,7 +35,7 @@ pic_file_open_binary_input_file(pic_state *pic) pic_get_args(pic, "z", &fname); - return generic_open_file(pic, fname, "rb", flags); + return pic_obj_value(pic_open_file(pic, fname, flags)); } pic_value @@ -63,7 +46,7 @@ pic_file_open_output_file(pic_state *pic) pic_get_args(pic, "z", &fname); - return generic_open_file(pic, fname, "w", flags); + return pic_obj_value(pic_open_file(pic, fname, flags)); } pic_value @@ -74,7 +57,7 @@ pic_file_open_binary_output_file(pic_state *pic) pic_get_args(pic, "z", &fname); - return generic_open_file(pic, fname, "wb", flags); + return pic_obj_value(pic_open_file(pic, fname, flags)); } pic_value diff --git a/contrib/05.r7rs/src/load.c b/contrib/20.r7rs/src/load.c similarity index 61% rename from contrib/05.r7rs/src/load.c rename to contrib/20.r7rs/src/load.c index c887a1b2..f0d65b6e 100644 --- a/contrib/05.r7rs/src/load.c +++ b/contrib/20.r7rs/src/load.c @@ -8,17 +8,8 @@ void pic_load(pic_state *pic, const char *filename) { struct pic_port *port; - xFILE *file; - file = xfopen(filename, "r"); - if (file == NULL) { - pic_errorf(pic, "could not open file: %s", filename); - } - - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); - port->file = file; - port->flags = PIC_PORT_IN | PIC_PORT_TEXT; - port->status = PIC_PORT_OPEN; + port = pic_open_file(pic, filename, PIC_PORT_IN | PIC_PORT_TEXT); pic_load_port(pic, port); diff --git a/contrib/05.r7rs/src/mutable-string.c b/contrib/20.r7rs/src/mutable-string.c similarity index 100% rename from contrib/05.r7rs/src/mutable-string.c rename to contrib/20.r7rs/src/mutable-string.c diff --git a/contrib/05.r7rs/src/r7rs.c b/contrib/20.r7rs/src/r7rs.c similarity index 100% rename from contrib/05.r7rs/src/r7rs.c rename to contrib/20.r7rs/src/r7rs.c diff --git a/contrib/05.r7rs/src/system.c b/contrib/20.r7rs/src/system.c similarity index 100% rename from contrib/05.r7rs/src/system.c rename to contrib/20.r7rs/src/system.c diff --git a/contrib/05.r7rs/src/time.c b/contrib/20.r7rs/src/time.c similarity index 100% rename from contrib/05.r7rs/src/time.c rename to contrib/20.r7rs/src/time.c diff --git a/t/r7rs-tests.scm b/contrib/20.r7rs/t/r7rs.scm similarity index 99% rename from t/r7rs-tests.scm rename to contrib/20.r7rs/t/r7rs.scm index e1d82f48..e7adaf65 100644 --- a/t/r7rs-tests.scm +++ b/contrib/20.r7rs/t/r7rs.scm @@ -460,9 +460,9 @@ (syntax-rules () ((be-like-begin name) (define-syntax name - (syntax-rules () - ((name expr (... ...)) - (begin expr (... ...)))))))) + (syntax-rules ::: () + ((name expr :::) + (begin expr :::))))))) (be-like-begin sequence) (test 4 (sequence 1 2 3 4)) diff --git a/contrib/20.repl/nitro.mk b/contrib/20.repl/nitro.mk deleted file mode 100644 index f03e4ad7..00000000 --- a/contrib/20.repl/nitro.mk +++ /dev/null @@ -1,3 +0,0 @@ -CONTRIB_LIBS += contrib/20.repl/repl.scm -CONTRIB_SRCS += contrib/20.repl/repl.c -CONTRIB_INITS += repl diff --git a/contrib/30.main/nitro.mk b/contrib/30.main/nitro.mk deleted file mode 100644 index a425fdc0..00000000 --- a/contrib/30.main/nitro.mk +++ /dev/null @@ -1 +0,0 @@ -CONTRIB_LIBS += contrib/30.main/main.scm diff --git a/contrib/30.optional/nitro.mk b/contrib/30.optional/nitro.mk new file mode 100644 index 00000000..78b4ade3 --- /dev/null +++ b/contrib/30.optional/nitro.mk @@ -0,0 +1,7 @@ +CONTRIB_LIBS += $(wildcard contrib/30.optional/piclib/*.scm) +CONTRIB_TESTS += test-optional + +test-optional: bin/picrin + for test in `ls contrib/30.optional/t/*.scm`; do \ + bin/picrin $$test; \ + done diff --git a/contrib/10.optional/piclib/optional.scm b/contrib/30.optional/piclib/optional.scm similarity index 100% rename from contrib/10.optional/piclib/optional.scm rename to contrib/30.optional/piclib/optional.scm diff --git a/contrib/10.optional/t/test.scm b/contrib/30.optional/t/test.scm similarity index 100% rename from contrib/10.optional/t/test.scm rename to contrib/30.optional/t/test.scm diff --git a/contrib/10.partcont/docs/doc.rst b/contrib/30.partcont/docs/doc.rst similarity index 100% rename from contrib/10.partcont/docs/doc.rst rename to contrib/30.partcont/docs/doc.rst diff --git a/contrib/30.partcont/nitro.mk b/contrib/30.partcont/nitro.mk new file mode 100644 index 00000000..470c3cb0 --- /dev/null +++ b/contrib/30.partcont/nitro.mk @@ -0,0 +1 @@ +CONTRIB_LIBS += $(wildcard contrib/30.partcont/piclib/*.scm) diff --git a/contrib/10.partcont/piclib/partcont.scm b/contrib/30.partcont/piclib/partcont.scm similarity index 100% rename from contrib/10.partcont/piclib/partcont.scm rename to contrib/30.partcont/piclib/partcont.scm diff --git a/contrib/10.pretty-print/docs/doc.rst b/contrib/30.pretty-print/docs/doc.rst similarity index 100% rename from contrib/10.pretty-print/docs/doc.rst rename to contrib/30.pretty-print/docs/doc.rst diff --git a/contrib/30.pretty-print/nitro.mk b/contrib/30.pretty-print/nitro.mk new file mode 100644 index 00000000..3a0369fe --- /dev/null +++ b/contrib/30.pretty-print/nitro.mk @@ -0,0 +1 @@ +CONTRIB_LIBS += contrib/30.pretty-print/pretty-print.scm diff --git a/contrib/10.pretty-print/pretty-print.scm b/contrib/30.pretty-print/pretty-print.scm similarity index 100% rename from contrib/10.pretty-print/pretty-print.scm rename to contrib/30.pretty-print/pretty-print.scm diff --git a/contrib/10.random/nitro.mk b/contrib/30.random/nitro.mk similarity index 50% rename from contrib/10.random/nitro.mk rename to contrib/30.random/nitro.mk index e7ba691d..a392fd17 100644 --- a/contrib/10.random/nitro.mk +++ b/contrib/30.random/nitro.mk @@ -1,8 +1,8 @@ CONTRIB_INITS += random -CONTRIB_SRCS += $(wildcard contrib/10.random/src/*.c) +CONTRIB_SRCS += $(wildcard contrib/30.random/src/*.c) CONTRIB_TESTS += test-random test-random: bin/picrin - for test in `ls contrib/10.random/t/*.scm`; do \ + for test in `ls contrib/30.random/t/*.scm`; do \ bin/picrin $$test; \ done diff --git a/contrib/10.random/src/mt19937ar.c b/contrib/30.random/src/mt19937ar.c similarity index 100% rename from contrib/10.random/src/mt19937ar.c rename to contrib/30.random/src/mt19937ar.c diff --git a/contrib/10.random/src/random.c b/contrib/30.random/src/random.c similarity index 100% rename from contrib/10.random/src/random.c rename to contrib/30.random/src/random.c diff --git a/contrib/10.random/t/test.scm b/contrib/30.random/t/test.scm similarity index 100% rename from contrib/10.random/t/test.scm rename to contrib/30.random/t/test.scm diff --git a/contrib/10.readline/example/simple-repl.scm b/contrib/30.readline/example/simple-repl.scm similarity index 100% rename from contrib/10.readline/example/simple-repl.scm rename to contrib/30.readline/example/simple-repl.scm diff --git a/contrib/10.readline/nitro.mk b/contrib/30.readline/nitro.mk similarity index 77% rename from contrib/10.readline/nitro.mk rename to contrib/30.readline/nitro.mk index 51d296ea..ec69703a 100644 --- a/contrib/10.readline/nitro.mk +++ b/contrib/30.readline/nitro.mk @@ -1,7 +1,7 @@ libedit_exists := $(shell pkg-config libedit --exists; echo $$?) ifeq ($(libedit_exists),0) - CONTRIB_SRCS += contrib/10.readline/src/readline.c + CONTRIB_SRCS += contrib/30.readline/src/readline.c CONTRIB_INITS += readline CONTRIB_TESTS += test-readline LDFLAGS += `pkg-config libedit --libs` @@ -11,6 +11,6 @@ contrib/src/readline.o: contrib/src/readline.c $(CC) $(CFLAGS) -o $@ $< `pkg-config libedit --cflags` test-readline: bin/picrin - for test in `ls contrib/10.readline/t/*.scm`; do \ + for test in `ls contrib/30.readline/t/*.scm`; do \ bin/picrin $$test; \ done diff --git a/contrib/10.readline/src/readline.c b/contrib/30.readline/src/readline.c similarity index 100% rename from contrib/10.readline/src/readline.c rename to contrib/30.readline/src/readline.c diff --git a/contrib/10.readline/t/test.scm b/contrib/30.readline/t/test.scm similarity index 100% rename from contrib/10.readline/t/test.scm rename to contrib/30.readline/t/test.scm diff --git a/contrib/10.regexp/docs/doc.rst b/contrib/30.regexp/docs/doc.rst similarity index 100% rename from contrib/10.regexp/docs/doc.rst rename to contrib/30.regexp/docs/doc.rst diff --git a/contrib/10.regexp/nitro.mk b/contrib/30.regexp/nitro.mk similarity index 52% rename from contrib/10.regexp/nitro.mk rename to contrib/30.regexp/nitro.mk index 9fe45e2f..b96f5e59 100644 --- a/contrib/10.regexp/nitro.mk +++ b/contrib/30.regexp/nitro.mk @@ -1,8 +1,8 @@ -CONTRIB_SRCS += contrib/10.regexp/src/regexp.c +CONTRIB_SRCS += contrib/30.regexp/src/regexp.c CONTRIB_INITS += regexp CONTRIB_TESTS += test-regexp test-regexp: bin/picrin - for test in `ls contrib/10.regexp/t/*.scm`; do \ + for test in `ls contrib/30.regexp/t/*.scm`; do \ bin/picrin $$test; \ done diff --git a/contrib/10.regexp/src/regexp.c b/contrib/30.regexp/src/regexp.c similarity index 100% rename from contrib/10.regexp/src/regexp.c rename to contrib/30.regexp/src/regexp.c diff --git a/contrib/10.regexp/t/test.scm b/contrib/30.regexp/t/test.scm similarity index 100% rename from contrib/10.regexp/t/test.scm rename to contrib/30.regexp/t/test.scm diff --git a/contrib/40.class/nitro.mk b/contrib/40.class/nitro.mk deleted file mode 100644 index cec300c1..00000000 --- a/contrib/40.class/nitro.mk +++ /dev/null @@ -1 +0,0 @@ -CONTRIB_LIBS += $(wildcard contrib/40.class/piclib/picrin/*.scm) diff --git a/contrib/10.srfi/docs/doc.rst b/contrib/40.srfi/docs/doc.rst similarity index 88% rename from contrib/10.srfi/docs/doc.rst rename to contrib/40.srfi/docs/doc.rst index bc95b39f..1dfc7675 100644 --- a/contrib/10.srfi/docs/doc.rst +++ b/contrib/40.srfi/docs/doc.rst @@ -36,6 +36,11 @@ SRFI libraries Sorting and Marging. +- `(srfi 106) + `_ + + Basic socket interface + - `(srfi 111) `_ diff --git a/contrib/40.srfi/examples/106/simple-echo-client.scm b/contrib/40.srfi/examples/106/simple-echo-client.scm new file mode 100644 index 00000000..cfe22edf --- /dev/null +++ b/contrib/40.srfi/examples/106/simple-echo-client.scm @@ -0,0 +1,29 @@ +; A R7RS port of "simple echo client" example in SRFI 106 +; +; Copyright (C) Takashi Kato (2012). All Rights Reserved. +; +; Permission is hereby granted, free of charge, to any person obtaining a copy +; of this software and associated documentation files (the "Software"), to deal +; in the Software without restriction, including without limitation the rights +; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +; copies of the Software, and to permit persons to whom the Software is +; furnished to do so, subject to the following conditions: +; +; The above copyright notice and this permission notice shall be included in +; all copies or substantial portions of the Software. +; +; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +; SOFTWARE. + +(import (scheme base) + (srfi 106)) + +(define echo-client-socket (make-client-socket "localhost" "5000")) + +(socket-send echo-client-socket (string->utf8 "hello\r\n")) +(socket-recv echo-client-socket (string-length "hello\r\n")) diff --git a/contrib/40.srfi/examples/106/simple-echo-server.scm b/contrib/40.srfi/examples/106/simple-echo-server.scm new file mode 100644 index 00000000..0c37b66c --- /dev/null +++ b/contrib/40.srfi/examples/106/simple-echo-server.scm @@ -0,0 +1,47 @@ +; A R7RS port of "simple echo server" example in SRFI 106 +; +; Copyright (C) Takashi Kato (2012). All Rights Reserved. +; +; Permission is hereby granted, free of charge, to any person obtaining a copy +; of this software and associated documentation files (the "Software"), to deal +; in the Software without restriction, including without limitation the rights +; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +; copies of the Software, and to permit persons to whom the Software is +; furnished to do so, subject to the following conditions: +; +; The above copyright notice and this permission notice shall be included in +; all copies or substantial portions of the Software. +; +; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +; SOFTWARE. + +(import (scheme base) + (srfi 106)) + +(define echo-server-socket (make-server-socket "5000")) + +(define (server-run) + (define (get-line-from-binary-port bin) + (utf8->string + (call-with-port (open-output-bytevector) + (lambda (out) + (let loop ((b (read-u8 bin))) + (case b + ((10) (get-output-bytevector out)) + ((13) (loop (read-u8 bin))) + (else (write-u8 b out) (loop (read-u8 bin))))))))) + + (call-with-socket (socket-accept echo-server-socket) + (lambda (sock) + (let ((in (socket-input-port sock)) + (out (socket-output-port sock))) + (let loop ((r (get-line-from-binary-port in))) + (write-bytevector (string->utf8 (string-append r "\r\n")) out) + (loop (get-line-from-binary-port in))))))) + +(server-run) diff --git a/contrib/40.srfi/nitro.mk b/contrib/40.srfi/nitro.mk new file mode 100644 index 00000000..c5fcc36d --- /dev/null +++ b/contrib/40.srfi/nitro.mk @@ -0,0 +1,18 @@ +CONTRIB_INITS += socket +CONTRIB_LIBS += \ + contrib/40.srfi/srfi/1.scm\ + contrib/40.srfi/srfi/8.scm\ + contrib/40.srfi/srfi/17.scm\ + contrib/40.srfi/srfi/26.scm\ + contrib/40.srfi/srfi/43.scm\ + contrib/40.srfi/srfi/60.scm\ + contrib/40.srfi/srfi/95.scm\ + contrib/40.srfi/srfi/106.scm\ + contrib/40.srfi/srfi/111.scm +CONTRIB_SRCS += contrib/40.srfi/src/106.c +CONTRIB_TESTS += test-srfi + +test-srfi: bin/picrin + for test in `ls contrib/40.srfi/t/*.scm`; do \ + bin/picrin "$$test"; \ + done diff --git a/contrib/40.srfi/src/106.c b/contrib/40.srfi/src/106.c new file mode 100644 index 00000000..e31831a2 --- /dev/null +++ b/contrib/40.srfi/src/106.c @@ -0,0 +1,521 @@ +#include "picrin.h" + +#include +#include +#include +#include +#include +#include +#include +#include + +#ifndef EWOULDBLOCK +#define EWOULDBLOCK EAGAIN +#endif + +struct pic_socket_t { + int fd; +}; + +PIC_INLINE void +socket_close(struct pic_socket_t *sock) +{ + if (sock != NULL && sock->fd != -1) { + close(sock->fd); + sock->fd = -1; + } +} + +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"); + } +} + +static void +socket_dtor(pic_state *pic, void *data) +{ + struct pic_socket_t *sock; + + sock = data; + socket_close(sock); + pic_free(pic, 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)); +} + +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); + + 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)); + } + + sock = pic_malloc(pic, sizeof(struct pic_socket_t)); + sock->fd = -1; + + memset(&hints, 0, sizeof(struct addrinfo)); + hints.ai_family = family; + hints.ai_socktype = socktype; + hints.ai_flags = flags; + hints.ai_protocol = protocol; + + errno = 0; + + do { + result = getaddrinfo(node, service, &hints, &ai); + } while (result == EAI_AGAIN); + if (result) { + if (result == EAI_SYSTEM) { + pic_errorf(pic, "%s", strerror(errno)); + } + pic_errorf(pic, "%s", gai_strerror(result)); + } + + for (it = ai; it != NULL; it = it->ai_next) { + int fd; + + fd = socket(it->ai_family, it->ai_socktype, it->ai_protocol); + if (fd == -1) { + continue; + } + + if (it->ai_flags & AI_PASSIVE) { + int yes = 1; + if (setsockopt(fd, SOL_SOCKET, SO_REUSEADDR, &yes, sizeof(int)) == 0 && + bind(fd, it->ai_addr, it->ai_addrlen) == 0) { + if (it->ai_socktype == SOCK_STREAM || + it->ai_socktype == SOCK_SEQPACKET) { + /* TODO: Backlog should be configurable. */ + if (listen(fd, 8) == 0) { + sock->fd = fd; + break; + } + } else { + sock->fd = fd; + break; + } + } + } else { + if (connect(fd, it->ai_addr, it->ai_addrlen) == 0) { + sock->fd = fd; + break; + } + } + + close(fd); + } + + freeaddrinfo(ai); + + if (sock->fd == -1) { + pic_errorf(pic, "%s", strerror(errno)); + } + + return pic_obj_value(pic_data_alloc(pic, &socket_type, sock)); +} + +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); + + sock = pic_socket_data_ptr(obj); + ensure_socket_is_open(pic, sock); + + errno = 0; + while (1) { + struct sockaddr_storage addr; + socklen_t addrlen = sizeof(struct sockaddr_storage); + + fd = accept(sock->fd, (struct sockaddr *)&addr, &addrlen); + + if (fd < 0) { + if (errno == EINTR) { + continue; + } else if (errno == EAGAIN || errno == EWOULDBLOCK) { + continue; + } else { + pic_errorf(pic, "%s", strerror(errno)); + } + } else { + break; + } + } + + 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)); +} + +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; + struct pic_socket_t *sock; + + pic_get_args(pic, "ob|i", &obj, &bv, &flags); + validate_socket_object(pic, obj); + + 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) { + ssize_t len = send(sock->fd, cursor, remain, flags); + if (len < 0) { + if (errno == EINTR) { + continue; + } else if (errno == EAGAIN || errno == EWOULDBLOCK) { + break; + } else { + pic_errorf(pic, "%s", strerror(errno)); + } + } + cursor += len; + remain -= len; + written += len; + } + + return pic_int_value(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); + if (size < 0) { + pic_errorf(pic, "size must not be negative"); + } + + 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"); + } + + errno = 0; + do { + len = recv(sock->fd, buf, size, flags); + } while (len < 0 && (errno == EINTR || errno == EAGAIN || errno == EWOULDBLOCK)); + + if (len < 0) { + free(buf); + pic_errorf(pic, "%s", strerror(errno)); + } + + bv = pic_make_blob(pic, len); + memcpy(bv->data, buf, len); + free(buf); + + return pic_obj_value(bv); +} + +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); + + sock = pic_socket_data_ptr(obj); + if (sock->fd != -1) { + shutdown(sock->fd, how); + sock->fd = -1; + } + + return pic_undef_value(); +} + +static pic_value +pic_socket_socket_close(pic_state *pic) +{ + pic_value obj; + + pic_get_args(pic, "o", &obj); + validate_socket_object(pic, obj); + + socket_close(pic_socket_data_ptr(obj)); + + return pic_undef_value(); +} + +static int +xf_socket_read(pic_state PIC_UNUSED(*pic), void *cookie, char *ptr, int size) +{ + struct pic_socket_t *sock; + + sock = (struct pic_socket_t *)cookie; + + return recv(sock->fd, ptr, size, 0); +} + +static int +xf_socket_write(pic_state PIC_UNUSED(*pic), void *cookie, const char *ptr, int size) +{ + struct pic_socket_t *sock; + + sock = (struct pic_socket_t *)cookie; + + return send(sock->fd, ptr, size, 0); +} + +static long +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)) +{ + return 0; +} + +static struct pic_port * +make_socket_port(pic_state *pic, struct pic_socket_t *sock, short dir) +{ + struct pic_port *port; + + 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; +} + +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); + + sock = pic_socket_data_ptr(obj); + ensure_socket_is_open(pic, sock); + + return pic_obj_value(make_socket_port(pic, sock, PIC_PORT_IN)); +} + +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); + + sock = pic_socket_data_ptr(obj); + ensure_socket_is_open(pic, sock); + + return pic_obj_value(make_socket_port(pic, sock, PIC_PORT_OUT)); +} + +static pic_value +pic_socket_call_with_socket(pic_state *pic) +{ + pic_value obj, result; + struct pic_proc *proc; + struct pic_socket_t *sock; + + pic_get_args(pic, "ol", &obj, &proc); + validate_socket_object(pic, obj); + + sock = pic_socket_data_ptr(obj); + ensure_socket_is_open(pic, sock); + + result = pic_apply1(pic, proc, obj); + + socket_close(sock); + + return result; +} + +void +pic_init_socket(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); + +#ifdef AF_INET + pic_define_(pic, "*af-inet*", pic_int_value(AF_INET)); +#else + pic_define_(pic, "*af-inet*", pic_false_value()); +#endif +#ifdef AF_INET6 + pic_define_(pic, "*af-inet6*", pic_int_value(AF_INET6)); +#else + pic_define_(pic, "*af-inet6*", pic_false_value()); +#endif +#ifdef AF_UNSPEC + pic_define_(pic, "*af-unspec*", pic_int_value(AF_UNSPEC)); +#else + pic_define_(pic, "*af-unspec*", pic_false_value()); +#endif + +#ifdef SOCK_STREAM + pic_define_(pic, "*sock-stream*", pic_int_value(SOCK_STREAM)); +#else + pic_define_(pic, "*sock-stream*", pic_false_value()); +#endif +#ifdef SOCK_DGRAM + pic_define_(pic, "*sock-dgram*", pic_int_value(SOCK_DGRAM)); +#else + pic_define_(pic, "*sock-dgram*", pic_false_value()); +#endif + +#ifdef AI_CANONNAME + pic_define_(pic, "*ai-canonname*", pic_int_value(AI_CANONNAME)); +#else + pic_define_(pic, "*ai-canonname*", pic_false_value()); +#endif +#ifdef AI_NUMERICHOST + pic_define_(pic, "*ai-numerichost*", pic_int_value(AI_NUMERICHOST)); +#else + pic_define_(pic, "*ai-numerichost*", pic_false_value()); +#endif +/* 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)); +#else + pic_define_(pic, "*ai-v4mapped*", pic_false_value()); +#endif +#if defined(AI_ALL) && !defined(BSD) + pic_define_(pic, "*ai-all*", pic_int_value(AI_ALL)); +#else + pic_define_(pic, "*ai-all*", pic_false_value()); +#endif +#ifdef AI_ADDRCONFIG + pic_define_(pic, "*ai-addrconfig*", pic_int_value(AI_ADDRCONFIG)); +#else + pic_define_(pic, "*ai-addrconfig*", pic_false_value()); +#endif +#ifdef AI_PASSIVE + pic_define_(pic, "*ai-passive*", pic_int_value(AI_PASSIVE)); +#else + pic_define_(pic, "*ai-passive*", pic_false_value()); +#endif + +#ifdef IPPROTO_IP + pic_define_(pic, "*ipproto-ip*", pic_int_value(IPPROTO_IP)); +#else + pic_define_(pic, "*ipproto-ip*", pic_false_value()); +#endif +#ifdef IPPROTO_TCP + pic_define_(pic, "*ipproto-tcp*", pic_int_value(IPPROTO_TCP)); +#else + pic_define_(pic, "*ipproto-tcp*", pic_false_value()); +#endif +#ifdef IPPROTO_UDP + pic_define_(pic, "*ipproto-udp*", pic_int_value(IPPROTO_UDP)); +#else + pic_define_(pic, "*ipproto-udp*", pic_false_value()); +#endif + +#ifdef MSG_PEEK + pic_define_(pic, "*msg-peek*", pic_int_value(MSG_PEEK)); +#else + pic_define_(pic, "*msg-peek*", pic_false_value()); +#endif +#ifdef MSG_OOB + pic_define_(pic, "*msg-oob*", pic_int_value(MSG_OOB)); +#else + pic_define_(pic, "*msg-oob*", pic_false_value()); +#endif +#ifdef MSG_WAITALL + pic_define_(pic, "*msg-waitall*", pic_int_value(MSG_WAITALL)); +#else + pic_define_(pic, "*msg-waitall*", pic_false_value()); +#endif + +#ifdef SHUT_RD + pic_define_(pic, "*shut-rd*", pic_int_value(SHUT_RD)); +#else + pic_define_(pic, "*shut-rd*", pic_false_value()); +#endif +#ifdef SHUT_WR + pic_define_(pic, "*shut-wr*", pic_int_value(SHUT_WR)); +#else + pic_define_(pic, "*shut-wr*", pic_false_value()); +#endif +#ifdef SHUT_RDWR + pic_define_(pic, "*shut-rdwr*", pic_int_value(SHUT_RDWR)); +#else + pic_define_(pic, "*shut-rdwr*", pic_false_value()); +#endif + } +} diff --git a/contrib/10.srfi/srfi/1.scm b/contrib/40.srfi/srfi/1.scm similarity index 100% rename from contrib/10.srfi/srfi/1.scm rename to contrib/40.srfi/srfi/1.scm diff --git a/contrib/40.srfi/srfi/106.scm b/contrib/40.srfi/srfi/106.scm new file mode 100644 index 00000000..e224b603 --- /dev/null +++ b/contrib/40.srfi/srfi/106.scm @@ -0,0 +1,168 @@ +(define-library (srfi 106) + (import (scheme base) + (srfi 60) + (picrin optional)) + + ; TODO: Define assq-ref anywhere else. + (define (assq-ref alist key . opt) + (cond + ((assq key alist) => cdr) + (else (if (null? opt) #f (car opt))))) + + (define (socket-merge-flags flag . flags) + (if (null? flags) + flag + (apply socket-merge-flags (logior (or flag 0) (or (car flags) 0)) + (cdr flags)))) + + (define (socket-purge-flags base-flag . flags) + (if (null? flags) + base-flag + (apply socket-purge-flags (logxor (or base-flag 0) (or (car flags) 0)) + (cdr flags)))) + + (define (make-client-socket node service . args) + (let-optionals* args ((family *af-inet*) + (type *sock-stream*) + (flags (socket-merge-flags *ai-v4mapped* + *ai-addrconfig*)) + (protocol *ipproto-ip*)) + (make-socket node service family type flags protocol))) + + (define (make-server-socket service . args) + (let-optionals* args ((family *af-inet*) + (type *sock-stream*) + (flags *ai-passive*) + (protocol *ipproto-ip*)) + (make-socket #f service family type flags protocol))) + + (define %address-family `((inet . ,*af-inet*) + (inet6 . ,*af-inet6*) + (unspec . ,*af-unspec*))) + + (define %socket-domain `((stream . ,*sock-stream*) + (datagram . ,*sock-dgram*))) + + (define %address-info `((canoname . ,*ai-canonname*) + (numerichost . ,*ai-numerichost*) + (v4mapped . ,*ai-v4mapped*) + (all . ,*ai-all*) + (addrconfig . ,*ai-addrconfig*))) + + (define %ip-protocol `((ip . ,*ipproto-ip*) + (tcp . ,*ipproto-tcp*) + (udp . ,*ipproto-udp*))) + + (define %message-types `((none . 0) + (peek . ,*msg-peek*) + (oob . ,*msg-oob*) + (wait-all . ,*msg-waitall*))) + + (define-syntax address-family + (syntax-rules () + ((_ name) + (assq-ref %address-family 'name)))) + + (define-syntax socket-domain + (syntax-rules () + ((_ name) + (assq-ref %socket-domain 'name)))) + + (define-syntax address-info + (syntax-rules () + ((_ names ...) + (apply socket-merge-flags + (map (lambda (name) (assq-ref %address-info name)) + '(names ...)))))) + + (define-syntax ip-protocol + (syntax-rules () + ((_ name) + (assq-ref %ip-protocol 'name)))) + + (define-syntax message-type + (syntax-rules () + ((_ names ...) + (apply socket-merge-flags + (map (lambda (name) (assq-ref %message-types name)) + '(names ...)))))) + + (define (%shutdown-method names) + (define (state->method state) + (case state + ((read) *shut-rd*) + ((write) *shut-wr*) + ((read-write) *shut-rdwr*) + (else #f))) + (let loop ((names names) + (state 'none)) + (cond + ((null? names) (state->method state)) + ((eq? (car names) 'read) + (loop (cdr names) + (cond + ((eq? state 'none) 'read) + ((eq? state 'write) 'read-write) + (else state)))) + ((eq? (car names) 'write) + (loop (cdr names) + (cond + ((eq? state 'none) 'write) + ((eq? state 'read) 'read-write) + (else state)))) + (else (loop (cdr names) 'other))))) + + (define-syntax shutdown-method + (syntax-rules () + ((_ names ...) + (%shutdown-method '(names ...))))) + + ;; Constructors and predicate + (export make-client-socket + make-server-socket + socket?) + + ;; Socket operations + (export socket-accept + socket-send + socket-recv + socket-shutdown + socket-close) + + ;; Port conversion + (export socket-input-port + socket-output-port) + + ;; Control feature + (export call-with-socket) + + ;; Flag operations + (export address-family + socket-domain + address-info + ip-protocol + message-type + shutdown-method + socket-merge-flags + socket-purge-flags) + + ;; Constant values + (export *af-inet* + *af-inet6* + *af-unspec*) + (export *sock-stream* + *sock-dgram*) + (export *ai-canonname* + *ai-numerichost* + *ai-v4mapped* + *ai-all* + *ai-addrconfig*) + (export *ipproto-ip* + *ipproto-tcp* + *ipproto-udp*) + (export *msg-peek* + *msg-oob* + *msg-waitall*) + (export *shut-rd* + *shut-wr* + *shut-rdwr*)) diff --git a/contrib/10.srfi/srfi/111.scm b/contrib/40.srfi/srfi/111.scm similarity index 100% rename from contrib/10.srfi/srfi/111.scm rename to contrib/40.srfi/srfi/111.scm diff --git a/contrib/10.srfi/srfi/17.scm b/contrib/40.srfi/srfi/17.scm similarity index 100% rename from contrib/10.srfi/srfi/17.scm rename to contrib/40.srfi/srfi/17.scm diff --git a/contrib/10.srfi/srfi/26.scm b/contrib/40.srfi/srfi/26.scm similarity index 100% rename from contrib/10.srfi/srfi/26.scm rename to contrib/40.srfi/srfi/26.scm diff --git a/contrib/10.srfi/srfi/43.scm b/contrib/40.srfi/srfi/43.scm similarity index 100% rename from contrib/10.srfi/srfi/43.scm rename to contrib/40.srfi/srfi/43.scm diff --git a/contrib/10.srfi/srfi/60.scm b/contrib/40.srfi/srfi/60.scm similarity index 100% rename from contrib/10.srfi/srfi/60.scm rename to contrib/40.srfi/srfi/60.scm diff --git a/contrib/10.srfi/srfi/8.scm b/contrib/40.srfi/srfi/8.scm similarity index 100% rename from contrib/10.srfi/srfi/8.scm rename to contrib/40.srfi/srfi/8.scm diff --git a/contrib/10.srfi/srfi/95.scm b/contrib/40.srfi/srfi/95.scm similarity index 100% rename from contrib/10.srfi/srfi/95.scm rename to contrib/40.srfi/srfi/95.scm diff --git a/contrib/40.srfi/t/106.scm b/contrib/40.srfi/t/106.scm new file mode 100644 index 00000000..24c57503 --- /dev/null +++ b/contrib/40.srfi/t/106.scm @@ -0,0 +1,72 @@ +(import (scheme base) + (srfi 106) + (picrin test)) + +; The number 9600 has no meaning. I just borrowed from Rust. +(define *test-port* 9600) +(define (next-test-port) + (set! *test-port* (+ *test-port* 1)) + (number->string *test-port*)) + +(test #f (socket? '())) +(let* ((port (next-test-port)) + (server (make-server-socket port)) + (client (make-client-socket "127.0.0.1" port))) + (test #t (socket? server)) + (test #t (socket? client))) + +(let* ((port (next-test-port)) + (server (make-server-socket port)) + (client (make-client-socket "127.0.0.1" port))) + (test #t (socket? (socket-accept server)))) + +(let* ((port (next-test-port)) + (server (make-server-socket port)) + (client (make-client-socket "127.0.0.1" port)) + (conn (socket-accept server))) + (test 5 (socket-send conn (string->utf8 "hello"))) + (test "hello" (utf8->string (socket-recv client 5)))) + +(let* ((port (next-test-port)) + (sock (make-server-socket port))) + (test #t (port? (socket-input-port sock))) + (test #t (port? (socket-output-port sock)))) + +(test *ai-canonname* (socket-merge-flags *ai-canonname*)) +(test *ai-canonname* (socket-merge-flags *ai-canonname* *ai-canonname*)) +(test *ai-canonname* (socket-purge-flags *ai-canonname*)) +(test *ai-canonname* (socket-purge-flags (socket-merge-flags *ai-canonname* *ai-all*) + *ai-all*)) +(test *ai-canonname* (socket-purge-flags (socket-merge-flags *ai-all* *ai-canonname*) + *ai-all*)) + +(test *af-inet* (address-family inet)) +(test *af-inet6* (address-family inet6)) +(test *af-unspec* (address-family unspec)) + +(test *sock-stream* (socket-domain stream)) +(test *sock-dgram* (socket-domain datagram)) + +(test *ai-canonname* (address-info canoname)) +(test *ai-numerichost* (address-info numerichost)) +(test *ai-v4mapped* (address-info v4mapped)) +(test *ai-all* (address-info all)) +(test *ai-addrconfig* (address-info addrconfig)) +(test (socket-merge-flags *ai-v4mapped* *ai-addrconfig*) + (address-info v4mapped addrconfig)) + +(test *ipproto-ip* (ip-protocol ip)) +(test *ipproto-tcp* (ip-protocol tcp)) +(test *ipproto-udp* (ip-protocol udp)) + +(test 0 (message-type none)) +(test *msg-peek* (message-type peek)) +(test *msg-oob* (message-type oob)) +(test *msg-waitall* (message-type wait-all)) +(test (socket-merge-flags *msg-oob* *msg-waitall*) + (message-type oob wait-all)) + +(test *shut-rd* (shutdown-method read)) +(test *shut-wr* (shutdown-method write)) +(test *shut-rdwr* (shutdown-method read write)) +(test *shut-rdwr* (shutdown-method write read)) diff --git a/contrib/50.class/nitro.mk b/contrib/50.class/nitro.mk new file mode 100644 index 00000000..5fea2786 --- /dev/null +++ b/contrib/50.class/nitro.mk @@ -0,0 +1 @@ +CONTRIB_LIBS += $(wildcard contrib/50.class/piclib/picrin/*.scm) diff --git a/contrib/40.class/piclib/picrin/class.scm b/contrib/50.class/piclib/picrin/class.scm similarity index 100% rename from contrib/40.class/piclib/picrin/class.scm rename to contrib/50.class/piclib/picrin/class.scm diff --git a/contrib/20.for/docs/doc.rst b/contrib/50.for/docs/doc.rst similarity index 100% rename from contrib/20.for/docs/doc.rst rename to contrib/50.for/docs/doc.rst diff --git a/contrib/50.for/nitro.mk b/contrib/50.for/nitro.mk new file mode 100644 index 00000000..2ca63f23 --- /dev/null +++ b/contrib/50.for/nitro.mk @@ -0,0 +1,7 @@ +CONTRIB_LIBS += $(wildcard contrib/50.for/piclib/*.scm) +CONTRIB_TESTS += test-for + +test-for: bin/picrin + for test in `ls contrib/50.for/t/*.scm`; do \ + bin/picrin "$$test"; \ + done diff --git a/contrib/20.for/piclib/for.scm b/contrib/50.for/piclib/for.scm similarity index 100% rename from contrib/20.for/piclib/for.scm rename to contrib/50.for/piclib/for.scm diff --git a/contrib/20.for/t/test.scm b/contrib/50.for/t/test.scm similarity index 100% rename from contrib/20.for/t/test.scm rename to contrib/50.for/t/test.scm diff --git a/contrib/50.protocol/nitro.mk b/contrib/50.protocol/nitro.mk deleted file mode 100644 index 2db1bf31..00000000 --- a/contrib/50.protocol/nitro.mk +++ /dev/null @@ -1 +0,0 @@ -CONTRIB_LIBS += $(wildcard contrib/50.protocol/piclib/picrin/*.scm) diff --git a/contrib/60.repl/nitro.mk b/contrib/60.repl/nitro.mk new file mode 100644 index 00000000..c3844fe5 --- /dev/null +++ b/contrib/60.repl/nitro.mk @@ -0,0 +1,3 @@ +CONTRIB_LIBS += contrib/60.repl/repl.scm +CONTRIB_SRCS += contrib/60.repl/repl.c +CONTRIB_INITS += repl diff --git a/contrib/20.repl/repl.c b/contrib/60.repl/repl.c similarity index 100% rename from contrib/20.repl/repl.c rename to contrib/60.repl/repl.c diff --git a/contrib/20.repl/repl.scm b/contrib/60.repl/repl.scm similarity index 73% rename from contrib/20.repl/repl.scm rename to contrib/60.repl/repl.scm index 3afd70c8..aa7640cf 100644 --- a/contrib/20.repl/repl.scm +++ b/contrib/60.repl/repl.scm @@ -2,7 +2,8 @@ (import (scheme base) (scheme read) (scheme write) - (scheme eval)) + (scheme eval) + (picrin base)) (cond-expand ((library (picrin readline)) @@ -18,21 +19,24 @@ (define (add-history str) #f)))) - (eval - '(import (scheme base) - (scheme load) - (scheme process-context) - (scheme read) - (scheme write) - (scheme file) - (scheme inexact) - (scheme cxr) - (scheme lazy) - (scheme time) - (picrin macro) - (picrin array) - (picrin library)) - '(picrin user)) + (define user-env (library-environment (find-library '(picrin user)))) + + (begin + (current-library (find-library '(picrin user))) + (eval + '(import (scheme base) + (scheme load) + (scheme process-context) + (scheme read) + (scheme write) + (scheme file) + (scheme inexact) + (scheme cxr) + (scheme lazy) + (scheme time) + (picrin macro)) + user-env) + (current-library (find-library '(picrin repl)))) (define (repl) (let loop ((buf "")) @@ -62,7 +66,7 @@ (lambda (port) (let next ((expr (read port))) (unless (eof-object? expr) - (write (eval expr '(picrin user))) + (write (eval expr user-env)) (newline) (set! str "") (next (read port)))))))))) diff --git a/contrib/30.main/main.scm b/contrib/70.main/main.scm similarity index 93% rename from contrib/30.main/main.scm rename to contrib/70.main/main.scm index 92dba342..35ecd522 100644 --- a/contrib/30.main/main.scm +++ b/contrib/70.main/main.scm @@ -5,6 +5,7 @@ (scheme process-context) (scheme load) (scheme eval) + (picrin base) (picrin repl)) (define (print-help) @@ -40,7 +41,7 @@ (lambda (in) (let loop ((expr (read in))) (unless (eof-object? expr) - (eval expr '(picrin user)) + (eval expr (library-environment (find-library '(picrin user)))) (loop (read in))))))) (define (main) diff --git a/contrib/70.main/nitro.mk b/contrib/70.main/nitro.mk new file mode 100644 index 00000000..7d368032 --- /dev/null +++ b/contrib/70.main/nitro.mk @@ -0,0 +1 @@ +CONTRIB_LIBS += contrib/70.main/main.scm diff --git a/contrib/80.protocol/nitro.mk b/contrib/80.protocol/nitro.mk new file mode 100644 index 00000000..74b99f23 --- /dev/null +++ b/contrib/80.protocol/nitro.mk @@ -0,0 +1 @@ +CONTRIB_LIBS += $(wildcard contrib/80.protocol/piclib/picrin/*.scm) diff --git a/contrib/50.protocol/piclib/picrin/protocol.scm b/contrib/80.protocol/piclib/picrin/protocol.scm similarity index 100% rename from contrib/50.protocol/piclib/picrin/protocol.scm rename to contrib/80.protocol/piclib/picrin/protocol.scm diff --git a/docs/capi.rst b/docs/capi.rst index a2c31320..9297989b 100644 --- a/docs/capi.rst +++ b/docs/capi.rst @@ -8,12 +8,12 @@ Extension Library If you want to create a contribution library with C, the only thing you need to do is make a directory under contrib/. Below is a sample code of extension library. -* contrib/add/CMakeLists.txt +* contrib/add/nitro.mk .. sourcecode:: cmake - list(APPEND PICRIN_CONTRIB_INITS add) - list(APPEND PICRIN_CONTRIB_SOURCES ${PROJECT_SOURCE_DIR}/contrib/add/add.c) + CONTRIB_INITS += add + CONTRIB_SRCS += contrib/add/add.c * contrib/add/add.c diff --git a/etc/libc_polyfill.c b/etc/libc_polyfill.c new file mode 100644 index 00000000..af7c1864 --- /dev/null +++ b/etc/libc_polyfill.c @@ -0,0 +1,20 @@ +void abort() +{ + while (1); +} + +typedef char jmp_buf[1]; + +int setjmp(jmp_buf buf) +{ + (void)buf; + return 0; +} + +void longjmp(jmp_buf buf, int r) +{ + (void)buf; + (void)r; + while (1); +} + diff --git a/etc/mkloader.pl b/etc/mkloader.pl index 3f5bcb41..527efd7a 100755 --- a/etc/mkloader.pl +++ b/etc/mkloader.pl @@ -41,7 +41,9 @@ pic_load_piclib(pic_state *pic) EOL foreach my $file (@ARGV) { - print " pic_try {\n"; + print <err); } EOL } diff --git a/extlib/benz/README.md b/extlib/benz/README.md index 81722f44..67c7a32d 100644 --- a/extlib/benz/README.md +++ b/extlib/benz/README.md @@ -19,7 +19,7 @@ main(int argc, char *argv[]) pic_state *pic; pic_value expr; - pic = pic_open(argc, argv, NULL); + pic = pic_open(pic_default_allocf, NULL); while (1) { printf("> "); @@ -61,7 +61,7 @@ pic_value factorial(pic_state *pic) { int main(int argc, char *argv[]) { - pic_state *pic = pic_open(argc, argv, NULL); + pic_state *pic = pic_open(pic_default_allocf, NULL); pic_defun(pic, "fact", factorial); /* define fact procedure */ diff --git a/extlib/benz/bool.c b/extlib/benz/bool.c index 33b6d0bf..4315c3b1 100644 --- a/extlib/benz/bool.c +++ b/extlib/benz/bool.c @@ -4,89 +4,84 @@ #include "picrin.h" -static bool -str_equal_p(pic_state *pic, struct pic_string *str1, struct pic_string *str2) -{ - return pic_str_cmp(pic, str1, str2) == 0; -} +KHASH_DECLARE(m, void *, int) +KHASH_DEFINE2(m, void *, int, 0, kh_ptr_hash_func, kh_ptr_hash_equal) static bool -blob_equal_p(struct pic_blob *blob1, struct pic_blob *blob2) -{ - size_t i; - - if (blob1->len != blob2->len) { - return false; - } - for (i = 0; i < blob1->len; ++i) { - if (blob1->data[i] != blob2->data[i]) - return false; - } - return true; -} - -static bool -internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *xh, bool xh_initted_p) +internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, khash_t(m) *h) { pic_value local = pic_nil_value(); - size_t c; + size_t c = 0; if (depth > 10) { if (depth > 200) { pic_errorf(pic, "Stack overflow in equal\n"); } if (pic_pair_p(x) || pic_vec_p(x)) { - if (! xh_initted_p) { - xh_init_ptr(xh, 0); - xh_initted_p = true; - } - - if (xh_get_ptr(xh, pic_obj_ptr(x)) != NULL) { + int ret; + kh_put(m, h, pic_obj_ptr(x), &ret); + if (ret != 0) { return true; /* `x' was seen already. */ - } else { - xh_put_ptr(xh, pic_obj_ptr(x), NULL); } } } - c = 0; - LOOP: - if (pic_eqv_p(x, y)) + if (pic_eqv_p(x, y)) { return true; - - if (pic_type(x) != pic_type(y)) + } + if (pic_type(x) != pic_type(y)) { return false; + } switch (pic_type(x)) { - case PIC_TT_STRING: - return str_equal_p(pic, pic_str_ptr(x), pic_str_ptr(y)); + case PIC_TT_ID: { + struct pic_id *id1, *id2; - case PIC_TT_BLOB: - return blob_equal_p(pic_blob_ptr(x), pic_blob_ptr(y)); + id1 = pic_id_ptr(x); + id2 = pic_id_ptr(y); + return pic_resolve(pic, id1->var, id1->env) == pic_resolve(pic, id2->var, id2->env); + } + case PIC_TT_STRING: { + return pic_str_cmp(pic, pic_str_ptr(x), pic_str_ptr(y)) == 0; + } + case PIC_TT_BLOB: { + pic_blob *blob1, *blob2; + size_t i; + + blob1 = pic_blob_ptr(x); + blob2 = pic_blob_ptr(y); + + if (blob1->len != blob2->len) { + return false; + } + for (i = 0; i < blob1->len; ++i) { + if (blob1->data[i] != blob2->data[i]) + return false; + } + return true; + } case PIC_TT_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(local)) { local = x; } - if (internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, xh, xh_initted_p)) { - x = pic_cdr(pic, x); - y = pic_cdr(pic, y); - - c++; - - if (c == 2) { - c = 0; - local = pic_cdr(pic, local); - if (pic_eq_p(local, x)) { - return true; - } + x = pic_cdr(pic, x); + y = pic_cdr(pic, y); + c++; + if (c == 2) { + c = 0; + local = pic_cdr(pic, local); + if (pic_eq_p(local, x)) { + return true; } - goto LOOP; - } else { - return false; } + goto LOOP; /* tail-call optimization */ } case PIC_TT_VECTOR: { size_t i; @@ -99,7 +94,7 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash * return false; } for (i = 0; i < u->len; ++i) { - if (! internal_equal_p(pic, u->data[i], v->data[i], depth + 1, xh, xh_initted_p)) + if (! internal_equal_p(pic, u->data[i], v->data[i], depth + 1, h)) return false; } return true; @@ -112,9 +107,11 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash * bool pic_equal_p(pic_state *pic, pic_value x, pic_value y) { - xhash ht; + khash_t(m) h; - return internal_equal_p(pic, x, y, 0, &ht, false); + kh_init(m, &h); + + return internal_equal_p(pic, x, y, 0, &h); } static pic_value @@ -195,7 +192,7 @@ pic_init_bool(pic_state *pic) pic_defun(pic, "eqv?", pic_bool_eqv_p); pic_defun(pic, "equal?", pic_bool_equal_p); - pic_defun_vm(pic, "not", pic->rNOT, pic_bool_not); + pic_defun_vm(pic, "not", pic->uNOT, pic_bool_not); pic_defun(pic, "boolean?", pic_bool_boolean_p); pic_defun(pic, "boolean=?", pic_bool_boolean_eq_p); diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index 59eb736b..81e82626 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -8,338 +8,661 @@ use strict; my $src = <<'EOL'; -(define-library (picrin base) +(builtin:define-macro call-with-current-environment + (builtin:lambda (form env) + (list (cadr form) env))) - (define (memoize f) - "memoize on symbols" - (define cache (make-dictionary)) - (lambda (sym) - (define value (dictionary-ref cache sym)) - (if (not (undefined? value)) - value - (begin - (define val (f sym)) - (dictionary-set! cache sym val) - val)))) +(builtin:define here + (call-with-current-environment + (builtin:lambda (env) + env))) - (define (er-macro-transformer f) - (lambda (mac-env) - (lambda (expr use-env) +(builtin:define the ; synonym for #'var + (builtin:lambda (var) + (make-identifier var here))) - (define rename - (memoize - (lambda (sym) - (make-identifier sym mac-env)))) - (define (compare x y) - (if (not (symbol? x)) - #f - (if (not (symbol? y)) - #f - (identifier=? use-env x use-env y)))) +(builtin:define the-builtin-define (the (builtin:quote builtin:define))) +(builtin:define the-builtin-lambda (the (builtin:quote builtin:lambda))) +(builtin:define the-builtin-begin (the (builtin:quote builtin:begin))) +(builtin:define the-builtin-quote (the (builtin:quote builtin:quote))) +(builtin:define the-builtin-set! (the (builtin:quote builtin:set!))) +(builtin:define the-builtin-if (the (builtin:quote builtin:if))) +(builtin:define the-builtin-define-macro (the (builtin:quote builtin:define-macro))) - (f expr rename compare)))) +(builtin:define the-define (the (builtin:quote define))) +(builtin:define the-lambda (the (builtin:quote lambda))) +(builtin:define the-begin (the (builtin:quote begin))) +(builtin:define the-quote (the (builtin:quote quote))) +(builtin:define the-set! (the (builtin:quote set!))) +(builtin:define the-if (the (builtin:quote if))) +(builtin:define the-define-macro (the (builtin:quote define-macro))) - (define-syntax syntax-error - (er-macro-transformer - (lambda (expr rename compare) - (apply error (cdr expr))))) +(builtin:define-macro quote + (builtin:lambda (form env) + (builtin:if (= (length form) 2) + (list the-builtin-quote (cadr form)) + (error "illegal quote form" form)))) - (define-syntax define-auxiliary-syntax - (er-macro-transformer - (lambda (expr r c) - (list (r 'define-syntax) (cadr expr) - (list (r 'lambda) '_ - (list (r 'lambda) '_ - (list (r 'error) (list (r 'string-append) "invalid use of auxiliary syntax: '" (symbol->string (cadr expr)) "'")))))))) +(builtin:define-macro if + (builtin:lambda (form env) + ((builtin:lambda (len) + (builtin:if (= len 4) + (cons the-builtin-if (cdr form)) + (builtin:if (= len 3) + (list the-builtin-if (list-ref form 1) (list-ref form 2) #undefined) + (error "illegal if form" form)))) + (length form)))) - (define-auxiliary-syntax else) - (define-auxiliary-syntax =>) - (define-auxiliary-syntax unquote) - (define-auxiliary-syntax unquote-splicing) +(builtin:define-macro begin + (builtin:lambda (form env) + ((builtin:lambda (len) + (if (= len 1) + #undefined + (if (= len 2) + (cadr form) + (if (= len 3) + (cons the-builtin-begin (cdr form)) + (list the-builtin-begin + (cadr form) + (cons the-begin (cddr form))))))) + (length form)))) - (define-syntax let - (er-macro-transformer - (lambda (expr r compare) - (if (symbol? (cadr expr)) - (begin - (define name (car (cdr expr))) - (define bindings (car (cdr (cdr expr)))) - (define body (cdr (cdr (cdr expr)))) - (list (r 'let) '() - (list (r 'define) name - (cons (r 'lambda) (cons (map car bindings) body))) - (cons name (map cadr bindings)))) - (begin - (set! bindings (cadr expr)) - (set! body (cddr expr)) - (cons (cons (r 'lambda) (cons (map car bindings) body)) - (map cadr bindings))))))) +(builtin:define-macro set! + (builtin:lambda (form env) + (if (= (length form) 3) + (if (variable? (cadr form)) + (cons the-builtin-set! (cdr form)) + (error "illegal set! form" form)) + (error "illegal set! form" form)))) - (define-syntax cond - (er-macro-transformer - (lambda (expr r compare) - (let ((clauses (cdr expr))) - (if (null? clauses) - #f - (begin - (define clause (car clauses)) - (if (compare (r 'else) (car clause)) - (cons (r 'begin) (cdr clause)) - (if (if (>= (length clause) 2) - (compare (r '=>) (list-ref clause 1)) - #f) - (list (r 'let) (list (list (r 'x) (car clause))) - (list (r 'if) (r 'x) - (list (list-ref clause 2) (r 'x)) - (cons (r 'cond) (cdr clauses)))) - (list (r 'if) (car clause) - (cons (r 'begin) (cdr clause)) - (cons (r 'cond) (cdr clauses))))))))))) +(builtin:define check-formal + (builtin:lambda (formal) + (if (null? formal) + #t + (if (variable? formal) + #t + (if (pair? formal) + (if (variable? (car formal)) + (check-formal (cdr formal)) + #f) + #f))))) - (define-syntax and - (er-macro-transformer - (lambda (expr r compare) - (let ((exprs (cdr expr))) - (cond - ((null? exprs) - #t) - ((= (length exprs) 1) - (car exprs)) - (else - (list (r 'let) (list (list (r 'it) (car exprs))) - (list (r 'if) (r 'it) - (cons (r 'and) (cdr exprs)) - (r 'it))))))))) +(builtin:define-macro lambda + (builtin:lambda (form env) + (if (= (length form) 1) + (error "illegal lambda form" form) + (if (check-formal (cadr form)) + (list the-builtin-lambda (cadr form) (cons the-begin (cddr form))) + (error "illegal lambda form" form))))) - (define-syntax or - (er-macro-transformer - (lambda (expr r compare) - (let ((exprs (cdr expr))) - (cond - ((null? exprs) - #t) - ((= (length exprs) 1) - (car exprs)) - (else - (list (r 'let) (list (list (r 'it) (car exprs))) - (list (r 'if) (r 'it) - (r 'it) - (cons (r 'or) (cdr exprs)))))))))) +(builtin:define-macro define + (lambda (form env) + ((lambda (len) + (if (= len 1) + (error "illegal define form" form) + (if (variable? (cadr form)) + (if (= len 3) + (cons the-builtin-define (cdr form)) + (error "illegal define form" form)) + (if (pair? (cadr form)) + (list the-define + (car (cadr form)) + (cons the-lambda (cons (cdr (cadr form)) (cddr form)))) + (error "define: binding to non-varaible object" form))))) + (length form)))) - (define-syntax quasiquote - (er-macro-transformer - (lambda (form rename compare) +(builtin:define-macro define-macro + (lambda (form env) + (if (= (length form) 3) + (if (variable? (cadr form)) + (cons the-builtin-define-macro (cdr form)) + (error "define-macro: binding to non-variable object" form)) + (error "illegal define-macro form" form)))) - (define (quasiquote? form) - (and (pair? form) (compare (car form) (rename 'quasiquote)))) - (define (unquote? form) - (and (pair? form) (compare (car form) (rename 'unquote)))) +(define-macro syntax-error + (lambda (form _) + (apply error (cdr form)))) - (define (unquote-splicing? form) - (and (pair? form) (pair? (car form)) - (compare (car (car form)) (rename 'unquote-splicing)))) +(define-macro define-auxiliary-syntax + (lambda (form _) + (define message + (string-append + "invalid use of auxiliary syntax: '" (symbol->string (cadr form)) "'")) + (list + the-define-macro + (cadr form) + (list the-lambda '_ + (list (the 'error) message))))) - (define (qq depth expr) - (cond - ;; unquote - ((unquote? expr) - (if (= depth 1) - (car (cdr expr)) - (list (rename 'list) - (list (rename 'quote) (rename 'unquote)) - (qq (- depth 1) (car (cdr expr)))))) - ;; unquote-splicing - ((unquote-splicing? expr) - (if (= depth 1) - (list (rename 'append) - (car (cdr (car expr))) - (qq depth (cdr expr))) - (list (rename 'cons) - (list (rename 'list) - (list (rename 'quote) (rename 'unquote-splicing)) - (qq (- depth 1) (car (cdr (car expr))))) - (qq depth (cdr expr))))) - ;; quasiquote - ((quasiquote? expr) - (list (rename 'list) - (list (rename 'quote) (rename 'quasiquote)) - (qq (+ depth 1) (car (cdr expr))))) - ;; list - ((pair? expr) - (list (rename 'cons) - (qq depth (car expr)) - (qq depth (cdr expr)))) - ;; vector - ((vector? expr) - (list (rename 'list->vector) (qq depth (vector->list expr)))) - ;; simple datum - (else - (list (rename 'quote) expr)))) +(define-auxiliary-syntax else) +(define-auxiliary-syntax =>) +(define-auxiliary-syntax unquote) +(define-auxiliary-syntax unquote-splicing) +(define-auxiliary-syntax syntax-unquote) +(define-auxiliary-syntax syntax-unquote-splicing) - (let ((x (cadr form))) - (qq 1 x))))) +(define-macro let + (lambda (form env) + (if (variable? (cadr form)) + (list + (list the-lambda '() + (list the-define (cadr form) + (cons the-lambda + (cons (map car (car (cddr form))) + (cdr (cddr form))))) + (cons (cadr form) (map cadr (car (cddr form)))))) + (cons + (cons + the-lambda + (cons (map car (cadr form)) + (cddr form))) + (map cadr (cadr form)))))) - (define-syntax let* - (er-macro-transformer - (lambda (form r compare) - (let ((bindings (cadr form)) - (body (cddr form))) - (if (null? bindings) - `(,(r 'let) () ,@body) - `(,(r 'let) ((,(caar bindings) - ,@(cdar bindings))) - (,(r 'let*) (,@(cdr bindings)) - ,@body))))))) +(define-macro and + (lambda (form env) + (if (null? (cdr form)) + #t + (if (null? (cddr form)) + (cadr form) + (list the-if + (cadr form) + (cons (the 'and) (cddr form)) + #f))))) - (define-syntax letrec* - (er-macro-transformer - (lambda (form r compare) - (let ((bindings (cadr form)) - (body (cddr form))) - (let ((vars (map (lambda (v) `(,v #f)) (map car bindings))) - (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings))) - `(,(r 'let) (,@vars) - ,@initials +(define-macro or + (lambda (form env) + (if (null? (cdr form)) + #f + (let ((tmp (make-identifier 'it env))) + (list (the 'let) + (list (list tmp (cadr form))) + (list the-if + tmp + tmp + (cons (the 'or) (cddr form)))))))) + +(define-macro cond + (lambda (form env) + (let ((clauses (cdr form))) + (if (null? clauses) + #undefined + (let ((clause (car clauses))) + (if (and (variable? (car clause)) + (variable=? (the 'else) (make-identifier (car clause) env))) + (cons the-begin (cdr clause)) + (if (and (variable? (cadr clause)) + (variable=? (the '=>) (make-identifier (cadr clause) env))) + (let ((tmp (make-identifier 'tmp here))) + (list (the 'let) (list (list tmp (car clause))) + (list the-if tmp + (list (car (cddr clause)) tmp) + (cons (the 'cond) (cdr clauses))))) + (list the-if (car clause) + (cons the-begin (cdr clause)) + (cons (the 'cond) (cdr clauses)))))))))) + +(define-macro quasiquote + (lambda (form env) + + (define (quasiquote? form) + (and (pair? form) + (variable? (car form)) + (variable=? (the 'quasiquote) (make-identifier (car form) env)))) + + (define (unquote? form) + (and (pair? form) + (variable? (car form)) + (variable=? (the 'unquote) (make-identifier (car form) env)))) + + (define (unquote-splicing? form) + (and (pair? form) + (pair? (car form)) + (variable? (caar form)) + (variable=? (the 'unquote-splicing) (make-identifier (caar form) env)))) + + (define (qq depth expr) + (cond + ;; unquote + ((unquote? expr) + (if (= depth 1) + (car (cdr expr)) + (list (the 'list) + (list (the 'quote) (the 'unquote)) + (qq (- depth 1) (car (cdr expr)))))) + ;; unquote-splicing + ((unquote-splicing? expr) + (if (= depth 1) + (list (the 'append) + (car (cdr (car expr))) + (qq depth (cdr expr))) + (list (the 'cons) + (list (the 'list) + (list (the 'quote) (the 'unquote-splicing)) + (qq (- depth 1) (car (cdr (car expr))))) + (qq depth (cdr expr))))) + ;; quasiquote + ((quasiquote? expr) + (list (the 'list) + (list (the 'quote) (the 'quasiquote)) + (qq (+ depth 1) (car (cdr expr))))) + ;; list + ((pair? expr) + (list (the 'cons) + (qq depth (car expr)) + (qq depth (cdr expr)))) + ;; vector + ((vector? expr) + (list (the 'list->vector) (qq depth (vector->list expr)))) + ;; simple datum + (else + (list (the 'quote) expr)))) + + (let ((x (cadr form))) + (qq 1 x)))) + +(define-macro let* + (lambda (form env) + (let ((bindings (car (cdr form))) + (body (cdr (cdr form)))) + (if (null? bindings) + `(,(the 'let) () ,@body) + `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings)))) + (,(the 'let*) (,@(cdr bindings)) ,@body)))))) - (define-syntax letrec - (er-macro-transformer - (lambda (form rename compare) - `(,(rename 'letrec*) ,@(cdr form))))) +(define-macro letrec + (lambda (form env) + `(,(the 'letrec*) ,@(cdr form)))) - (define-syntax let*-values - (er-macro-transformer - (lambda (form r c) - (let ((formals (cadr form))) - (if (null? formals) - `(,(r 'let) () ,@(cddr form)) - `(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals)) - (,(r 'lambda) (,@(caar formals)) - (,(r 'let*-values) (,@(cdr formals)) - ,@(cddr form))))))))) +(define-macro letrec* + (lambda (form env) + (let ((bindings (car (cdr form))) + (body (cdr (cdr form)))) + (let ((variables (map (lambda (v) `(,v #f)) (map car bindings))) + (initials (map (lambda (v) `(,(the 'set!) ,@v)) bindings))) + `(,(the 'let) (,@variables) + ,@initials + ,@body))))) - (define-syntax let-values - (er-macro-transformer - (lambda (form r c) - `(,(r 'let*-values) ,@(cdr form))))) +(define-macro let-values + (lambda (form env) + `(,(the 'let*-values) ,@(cdr form)))) - (define-syntax define-values - (er-macro-transformer - (lambda (form r compare) - (let ((formal (cadr form)) - (exprs (cddr form))) - `(,(r 'begin) - ,@(let loop ((formal formal)) - (if (not (pair? formal)) - (if (symbol? formal) - `((,(r 'define) ,formal #f)) - '()) - `((,(r 'define) ,(car formal) #f) . ,(loop (cdr formal))))) - (,(r 'call-with-values) (,(r 'lambda) () ,@exprs) - (,(r 'lambda) ,(r 'args) - ,@(let loop ((formal formal) (args (r 'args))) - (if (not (pair? formal)) - (if (symbol? formal) - `((,(r 'set!) ,formal ,args)) - '()) - `((,(r 'set!) ,(car formal) (,(r 'car) ,args)) - ,@(loop (cdr formal) `(,(r 'cdr) ,args)))))))))))) +(define-macro let*-values + (lambda (form env) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + (if (null? formal) + `(,(the 'let) () ,@body) + `(,(the 'call-with-values) (,the-lambda () ,@(cdr (car formal))) + (,(the 'lambda) (,@(car (car formal))) + (,(the 'let*-values) (,@(cdr formal)) + ,@body))))))) - (define-syntax do - (er-macro-transformer - (lambda (form r compare) - (let ((bindings (car (cdr form))) - (finish (car (cdr (cdr form)))) - (body (cdr (cdr (cdr form))))) - `(,(r 'let) ,(r 'loop) ,(map (lambda (x) - (list (car x) (cadr x))) - bindings) - (,(r 'if) ,(car finish) - (,(r 'begin) ,@(cdr finish)) - (,(r 'begin) ,@body - (,(r 'loop) ,@(map (lambda (x) - (if (null? (cddr x)) - (car x) - (car (cddr x)))) - bindings))))))))) +(define-macro define-values + (lambda (form env) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + (let ((arguments (make-identifier 'arguments here))) + `(,the-begin + ,@(let loop ((formal formal)) + (if (pair? formal) + `((,the-define ,(car formal) #undefined) ,@(loop (cdr formal))) + (if (variable? formal) + `((,the-define ,formal #undefined)) + '()))) + (,(the 'call-with-values) (,the-lambda () ,@body) + (,the-lambda + ,arguments + ,@(let loop ((formal formal) (args arguments)) + (if (pair? formal) + `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args))) + (if (variable? formal) + `((,the-set! ,formal ,args)) + '())))))))))) - (define-syntax when - (er-macro-transformer - (lambda (expr rename compare) - (let ((test (cadr expr)) - (body (cddr expr))) - `(,(rename 'if) ,test - (,(rename 'begin) ,@body) - #f))))) +(define-macro do + (lambda (form env) + (let ((bindings (car (cdr form))) + (test (car (car (cdr (cdr form))))) + (cleanup (cdr (car (cdr (cdr form))))) + (body (cdr (cdr (cdr form))))) + (let ((loop (make-identifier 'loop here))) + `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindings) + (,the-if ,test + (,the-begin + ,@cleanup) + (,the-begin + ,@body + (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (car x) (car (cdr (cdr x))))) bindings))))))))) - (define-syntax unless - (er-macro-transformer - (lambda (expr rename compare) - (let ((test (cadr expr)) - (body (cddr expr))) - `(,(rename 'if) ,test - #f - (,(rename 'begin) ,@body)))))) +(define-macro when + (lambda (form env) + (let ((test (car (cdr form))) + (body (cdr (cdr form)))) + `(,the-if ,test + (,the-begin ,@body) + #undefined)))) - (define-syntax case - (er-macro-transformer - (lambda (expr r compare) - (let ((key (cadr expr)) - (clauses (cddr expr))) - `(,(r 'let) ((,(r 'key) ,key)) - ,(let loop ((clauses clauses)) - (if (null? clauses) - #f - (begin - (define clause (car clauses)) - `(,(r 'if) ,(if (compare (r 'else) (car clause)) - '#t - `(,(r 'or) - ,@(map (lambda (x) - `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x))) - (car clause)))) - ,(if (compare (r '=>) (list-ref clause 1)) - `(,(list-ref clause 2) ,(r 'key)) - `(,(r 'begin) ,@(cdr clause))) - ,(loop (cdr clauses))))))))))) +(define-macro unless + (lambda (form env) + (let ((test (car (cdr form))) + (body (cdr (cdr form)))) + `(,the-if ,test + #undefined + (,the-begin ,@body))))) - (define-syntax parameterize - (er-macro-transformer - (lambda (form r compare) - (let ((formal (cadr form)) - (body (cddr form))) - `(,(r 'with-parameter) - (lambda () - ,@formal - ,@body)))))) +(define-macro case + (lambda (form env) + (let ((key (car (cdr form))) + (clauses (cdr (cdr form)))) + (let ((the-key (make-identifier 'key here))) + `(,(the 'let) ((,the-key ,key)) + ,(let loop ((clauses clauses)) + (if (null? clauses) + #undefined + (let ((clause (car clauses))) + `(,the-if ,(if (and (variable? (car clause)) + (variable=? (the 'else) (make-identifier (car clause) env))) + #t + `(,(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause)))) + ,(if (and (variable? (cadr clause)) + (variable=? (the '=>) (make-identifier (cadr clause) env))) + `(,(car (cdr (cdr clause))) ,the-key) + `(,the-begin ,@(cdr clause))) + ,(loop (cdr clauses))))))))))) - (define-syntax letrec-syntax - (er-macro-transformer - (lambda (form r c) - (let ((formal (car (cdr form))) - (body (cdr (cdr form)))) - `(let () - ,@(map (lambda (x) - `(,(r 'define-syntax) ,(car x) ,(cadr x))) - formal) - ,@body))))) +(define-macro parameterize + (lambda (form env) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + `(,(the 'with-parameter) + (,(the 'lambda) () + ,@formal + ,@body))))) - (define-syntax let-syntax - (er-macro-transformer - (lambda (form r c) - `(,(r 'letrec-syntax) ,@(cdr form))))) +(define-macro syntax-quote + (lambda (form env) + (let ((renames '())) + (letrec + ((rename (lambda (var) + (let ((x (assq var renames))) + (if x + (cadr x) + (begin + (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames)) + (rename var)))))) + (walk (lambda (f form) + (cond + ((variable? form) + (f form)) + ((pair? form) + `(,(the 'cons) (walk f (car form)) (walk f (cdr form)))) + ((vector? form) + `(,(the 'list->vector) (walk f (vector->list form)))) + (else + `(,(the 'quote) ,form)))))) + (let ((form (walk rename (cadr form)))) + `(,(the 'let) + ,(map cdr renames) + ,form)))))) + +(define-macro syntax-quasiquote + (lambda (form env) + (let ((renames '())) + (letrec + ((rename (lambda (var) + (let ((x (assq var renames))) + (if x + (cadr x) + (begin + (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames)) + (rename var))))))) + + (define (syntax-quasiquote? form) + (and (pair? form) + (variable? (car form)) + (variable=? (the 'syntax-quasiquote) (make-identifier (car form) env)))) + + (define (syntax-unquote? form) + (and (pair? form) + (variable? (car form)) + (variable=? (the 'syntax-unquote) (make-identifier (car form) env)))) + + (define (syntax-unquote-splicing? form) + (and (pair? form) + (pair? (car form)) + (variable? (caar form)) + (variable=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env)))) + + (define (qq depth expr) + (cond + ;; syntax-unquote + ((syntax-unquote? expr) + (if (= depth 1) + (car (cdr expr)) + (list (the 'list) + (list (the 'quote) (the 'syntax-unquote)) + (qq (- depth 1) (car (cdr expr)))))) + ;; syntax-unquote-splicing + ((syntax-unquote-splicing? expr) + (if (= depth 1) + (list (the 'append) + (car (cdr (car expr))) + (qq depth (cdr expr))) + (list (the 'cons) + (list (the 'list) + (list (the 'quote) (the 'syntax-unquote-splicing)) + (qq (- depth 1) (car (cdr (car expr))))) + (qq depth (cdr expr))))) + ;; syntax-quasiquote + ((syntax-quasiquote? expr) + (list (the 'list) + (list (the 'quote) (the 'quasiquote)) + (qq (+ depth 1) (car (cdr expr))))) + ;; list + ((pair? expr) + (list (the 'cons) + (qq depth (car expr)) + (qq depth (cdr expr)))) + ;; vector + ((vector? expr) + (list (the 'list->vector) (qq depth (vector->list expr)))) + ;; variable + ((variable? expr) + (rename expr)) + ;; simple datum + (else + (list (the 'quote) expr)))) + + (let ((body (qq 1 (cadr form)))) + `(,(the 'let) + ,(map cdr renames) + ,body)))))) + +(define (transformer f) + (lambda (form env) + (let ((register1 (make-register)) + (register2 (make-register))) + (letrec + ((wrap (lambda (var1) + (let ((var2 (register1 var1))) + (if (undefined? var2) + (let ((var2 (make-identifier var1 env))) + (register1 var1 var2) + (register2 var2 var1) + var2) + var2)))) + (unwrap (lambda (var2) + (let ((var1 (register2 var2))) + (if (undefined? var1) + var2 + var1)))) + (walk (lambda (f form) + (cond + ((variable? form) + (f form)) + ((pair? form) + (cons (walk f (car form)) (walk f (cdr form)))) + ((vector? form) + (list->vector (walk f (vector->list form)))) + (else + form))))) + (let ((form (cdr form))) + (walk unwrap (apply f (walk wrap form)))))))) + +(define-macro define-syntax + (lambda (form env) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + (if (pair? formal) + `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body)) + `(,the-define-macro ,formal (,(the 'transformer) (,the-begin ,@body))))))) + +(define-macro letrec-syntax + (lambda (form env) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + `(let () + ,@(map (lambda (x) + `(,(the 'define-syntax) ,(car x) ,(cadr x))) + formal) + ,@body)))) + +(define-macro let-syntax + (lambda (form env) + `(,(the 'letrec-syntax) ,@(cdr form)))) + + +;;; library primitives + +(define-macro define-library + (lambda (form _) + (let ((name (cadr form)) + (body (cddr form))) + (let ((old-library (current-library)) + (new-library (or (find-library name) (make-library name)))) + (let ((env (library-environment new-library))) + (current-library new-library) + (for-each (lambda (expr) (eval expr env)) body) + (current-library old-library)))))) + +(define-macro cond-expand + (lambda (form _) + (letrec + ((test (lambda (form) + (or + (eq? form 'else) + (and (symbol? form) + (memq form (features))) + (and (pair? form) + (case (car form) + ((library) (find-library (cadr form))) + ((not) (not (test (cadr form)))) + ((and) (let loop ((form (cdr form))) + (or (null? form) + (and (test (car form)) (loop (cdr form)))))) + ((or) (let loop ((form (cdr form))) + (and (pair? form) + (or (test (car form)) (loop (cdr form)))))) + (else #f))))))) + (let loop ((clauses (cdr form))) + (if (null? clauses) + #undefined + (if (test (caar clauses)) + `(,the-begin ,@(cdar clauses)) + (loop (cdr clauses)))))))) + +(define-macro import + (lambda (form _) + (let ((caddr + (lambda (x) (car (cdr (cdr x))))) + (prefix + (lambda (prefix symbol) + (string->symbol + (string-append + (symbol->string prefix) + (symbol->string symbol)))))) + (letrec + ((extract + (lambda (spec) + (case (car spec) + ((only rename prefix except) + (extract (cadr spec))) + (else + (or (find-library spec) (error "library not found" spec)))))) + (collect + (lambda (spec) + (case (car spec) + ((only) + (let ((alist (collect (cadr spec)))) + (map (lambda (var) (assq var alist)) (cddr spec)))) + ((rename) + (let ((alist (collect (cadr spec)))) + (map (lambda (s) (or (assq (car s) (cddr spec)) s)) alist))) + ((prefix) + (let ((alist (collect (cadr spec)))) + (map (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist))) + ((except) + (let ((alist (collect (cadr spec)))) + (let loop ((alist alist)) + (if (null? alist) + '() + (if (memq (caar alist) (cddr spec)) + (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)))))))) + (letrec + ((import + (lambda (spec) + (let ((lib (extract spec)) + (alist (collect spec))) + (for-each + (lambda (slot) + (library-import lib (cdr slot) (car slot))) + alist))))) + (for-each import (cdr form))))))) + +(define-macro export + (lambda (form _) + (letrec + ((collect + (lambda (spec) + (cond + ((symbol? spec) + `(,spec . ,spec)) + ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename)) + `(,(list-ref spec 1) . ,(list-ref spec 2))) + (else + (error "malformed export"))))) + (export + (lambda (spec) + (let ((slot (collect spec))) + (library-export (car slot) (cdr slot)))))) + (for-each export (cdr form))))) + +(export define-library + cond-expand + import + export) + +(export let let* letrec letrec* + let-values let*-values define-values + quasiquote unquote unquote-splicing + and or + cond case else => + do when unless + parameterize + define-syntax + syntax-quote syntax-unquote + syntax-quasiquote syntax-unquote-splicing + let-syntax letrec-syntax + syntax-error) - (export let let* letrec letrec* - let-values let*-values define-values - quasiquote unquote unquote-splicing - and or - cond case else => - do when unless - parameterize - let-syntax letrec-syntax - syntax-error)) EOL @@ -393,147 +716,294 @@ EOL #endif const char pic_boot[][80] = { -"\n(define-library (picrin base)\n\n (define (memoize f)\n \"memoize on symbols\"\n ", -" (define cache (make-dictionary))\n (lambda (sym)\n (define value (dicti", -"onary-ref cache sym))\n (if (not (undefined? value))\n value\n ", -" (begin\n (define val (f sym))\n (dictionary-set! cache sy", -"m val)\n val))))\n\n (define (er-macro-transformer f)\n (lambda (mac-", -"env)\n (lambda (expr use-env)\n\n (define rename\n (memoize\n ", -" (lambda (sym)\n (make-identifier sym mac-env))))\n\n (de", -"fine (compare x y)\n (if (not (symbol? x))\n #f\n ", -" (if (not (symbol? y))\n #f\n (identifier=? use", -"-env x use-env y))))\n\n (f expr rename compare))))\n\n (define-syntax synta", -"x-error\n (er-macro-transformer\n (lambda (expr rename compare)\n (app", -"ly error (cdr expr)))))\n\n (define-syntax define-auxiliary-syntax\n (er-macro-", -"transformer\n (lambda (expr r c)\n (list (r 'define-syntax) (cadr expr)\n", -" (list (r 'lambda) '_\n (list (r 'lambda) '_\n ", -" (list (r 'error) (list (r 'string-append) \"invalid use of aux", -"iliary syntax: '\" (symbol->string (cadr expr)) \"'\"))))))))\n\n (define-auxiliary-", -"syntax else)\n (define-auxiliary-syntax =>)\n (define-auxiliary-syntax unquote)\n", -" (define-auxiliary-syntax unquote-splicing)\n\n (define-syntax let\n (er-macro", -"-transformer\n (lambda (expr r compare)\n (if (symbol? (cadr expr))\n ", -" (begin\n (define name (car (cdr expr)))\n (defi", -"ne bindings (car (cdr (cdr expr))))\n (define body (cdr (cdr (cdr", -" expr))))\n (list (r 'let) '()\n (list (r 'define) n", -"ame\n (cons (r 'lambda) (cons (map car bindings) body)))\n", -" (cons name (map cadr bindings))))\n (begin\n ", -" (set! bindings (cadr expr))\n (set! body (cddr expr))\n ", -" (cons (cons (r 'lambda) (cons (map car bindings) body))\n (ma", -"p cadr bindings)))))))\n\n (define-syntax cond\n (er-macro-transformer\n (la", -"mbda (expr r compare)\n (let ((clauses (cdr expr)))\n (if (null? cla", -"uses)\n #f\n (begin\n (define clause (car cla", -"uses))\n (if (compare (r 'else) (car clause))\n (c", -"ons (r 'begin) (cdr clause))\n (if (if (>= (length clause) 2)\n ", -" (compare (r '=>) (list-ref clause 1))\n ", -" #f)\n (list (r 'let) (list (list (r 'x) (car cla", -"use)))\n (list (r 'if) (r 'x)\n ", -" (list (list-ref clause 2) (r 'x))\n ", -" (cons (r 'cond) (cdr clauses))))\n (list (r 'if) (car clau", -"se)\n (cons (r 'begin) (cdr clause))\n ", -" (cons (r 'cond) (cdr clauses)))))))))))\n\n (define-syntax and\n (", -"er-macro-transformer\n (lambda (expr r compare)\n (let ((exprs (cdr expr", -")))\n (cond\n ((null? exprs)\n #t)\n ((= (length", -" exprs) 1)\n (car exprs))\n (else\n (list (r 'let) (li", -"st (list (r 'it) (car exprs)))\n (list (r 'if) (r 'it)\n ", -" (cons (r 'and) (cdr exprs))\n (r 'it)))))))))\n", -"\n (define-syntax or\n (er-macro-transformer\n (lambda (expr r compare)\n ", -" (let ((exprs (cdr expr)))\n (cond\n ((null? exprs)\n ", -" #t)\n ((= (length exprs) 1)\n (car exprs))\n (else\n ", -" (list (r 'let) (list (list (r 'it) (car exprs)))\n (list ", -"(r 'if) (r 'it)\n (r 'it)\n (cons (r '", -"or) (cdr exprs))))))))))\n\n (define-syntax quasiquote\n (er-macro-transformer\n", -" (lambda (form rename compare)\n\n (define (quasiquote? form)\n (", -"and (pair? form) (compare (car form) (rename 'quasiquote))))\n\n (define (un", -"quote? form)\n (and (pair? form) (compare (car form) (rename 'unquote))))", -"\n\n (define (unquote-splicing? form)\n (and (pair? form) (pair? (car", -" form))\n (compare (car (car form)) (rename 'unquote-splicing))))\n\n ", -" (define (qq depth expr)\n (cond\n ;; unquote\n ((un", -"quote? expr)\n (if (= depth 1)\n (car (cdr expr))\n ", -" (list (rename 'list)\n (list (rename 'quote) (rename '", -"unquote))\n (qq (- depth 1) (car (cdr expr))))))\n ;;", -" unquote-splicing\n ((unquote-splicing? expr)\n (if (= depth 1)", -"\n (list (rename 'append)\n (car (cdr (car expr)", -"))\n (qq depth (cdr expr)))\n (list (rename 'con", -"s)\n (list (rename 'list)\n (list (r", -"ename 'quote) (rename 'unquote-splicing))\n (qq (- dept", -"h 1) (car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ", -" ;; quasiquote\n ((quasiquote? expr)\n (list (rename 'list", -")\n (list (rename 'quote) (rename 'quasiquote))\n ", -"(qq (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n ", -" (list (rename 'cons)\n (qq depth (car expr))\n ", -" (qq depth (cdr expr))))\n ;; vector\n ((vector? expr)\n ", -" (list (rename 'list->vector) (qq depth (vector->list expr))))\n ;", -"; simple datum\n (else\n (list (rename 'quote) expr))))\n\n ", -" (let ((x (cadr form)))\n (qq 1 x)))))\n\n (define-syntax let*\n (er-mac", -"ro-transformer\n (lambda (form r compare)\n (let ((bindings (cadr form))", -"\n (body (cddr form)))\n (if (null? bindings)\n `(,", -"(r 'let) () ,@body)\n `(,(r 'let) ((,(caar bindings)\n ", -" ,@(cdar bindings)))\n (,(r 'let*) (,@(cdr bindings))\n ", -" ,@body)))))))\n\n (define-syntax letrec*\n (er-macro-transformer\n ", -" (lambda (form r compare)\n (let ((bindings (cadr form))\n (b", -"ody (cddr form)))\n (let ((vars (map (lambda (v) `(,v #f)) (map car bindi", -"ngs)))\n (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))\n", -" `(,(r 'let) (,@vars)\n ,@initials\n ,@body)))))", -")\n\n (define-syntax letrec\n (er-macro-transformer\n (lambda (form rename c", -"ompare)\n `(,(rename 'letrec*) ,@(cdr form)))))\n\n (define-syntax let*-valu", -"es\n (er-macro-transformer\n (lambda (form r c)\n (let ((formals (cadr", -" form)))\n (if (null? formals)\n `(,(r 'let) () ,@(cddr form))", -"\n `(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals))\n ", -" (,(r 'lambda) (,@(caar formals))\n (,(r 'let*-values) (,@", -"(cdr formals))\n ,@(cddr form)))))))))\n\n (define-syntax let-valu", -"es\n (er-macro-transformer\n (lambda (form r c)\n `(,(r 'let*-values) ", -",@(cdr form)))))\n\n (define-syntax define-values\n (er-macro-transformer\n ", -"(lambda (form r compare)\n (let ((formal (cadr form))\n (exprs ", -"(cddr form)))\n `(,(r 'begin)\n ,@(let loop ((formal formal))\n ", -" (if (not (pair? formal))\n (if (symbol? formal)", -"\n `((,(r 'define) ,formal #f))\n '(", -"))\n `((,(r 'define) ,(car formal) #f) . ,(loop (cdr formal)))", -"))\n (,(r 'call-with-values) (,(r 'lambda) () ,@exprs)\n (", -",(r 'lambda) ,(r 'args)\n ,@(let loop ((formal formal) (args (r 'a", -"rgs)))\n (if (not (pair? formal))\n (if ", -"(symbol? formal)\n `((,(r 'set!) ,formal ,args))\n ", -" '())\n `((,(r 'set!) ,(car formal) ", -"(,(r 'car) ,args))\n ,@(loop (cdr formal) `(,(r 'cdr) ,a", -"rgs))))))))))))\n\n (define-syntax do\n (er-macro-transformer\n (lambda (for", -"m r compare)\n (let ((bindings (car (cdr form)))\n (finish (ca", -"r (cdr (cdr form))))\n (body (cdr (cdr (cdr form)))))\n `(", -",(r 'let) ,(r 'loop) ,(map (lambda (x)\n (", -"list (car x) (cadr x)))\n bindings)\n ", -" (,(r 'if) ,(car finish)\n (,(r 'begin) ,@(cdr finish))\n ", -"(,(r 'begin) ,@body\n (,(r 'loop) ,@(map (lambda (x)\n ", -" (if (null? (cddr x))\n (ca", -"r x)\n (car (cddr x))))\n ", -" bindings)))))))))\n\n (define-syntax when\n (er-macro-transformer\n ", -" (lambda (expr rename compare)\n (let ((test (cadr expr))\n (", -"body (cddr expr)))\n `(,(rename 'if) ,test\n (,(rename 'begin", -") ,@body)\n #f)))))\n\n (define-syntax unless\n (er-macro-transform", -"er\n (lambda (expr rename compare)\n (let ((test (cadr expr))\n ", -" (body (cddr expr)))\n `(,(rename 'if) ,test\n #f\n ", -" (,(rename 'begin) ,@body))))))\n\n (define-syntax case\n (er-macro-transfo", -"rmer\n (lambda (expr r compare)\n (let ((key (cadr expr))\n (", -"clauses (cddr expr)))\n `(,(r 'let) ((,(r 'key) ,key))\n ,(let ", -"loop ((clauses clauses))\n (if (null? clauses)\n #", -"f\n (begin\n (define clause (car clauses))\n ", -" `(,(r 'if) ,(if (compare (r 'else) (car clause))\n ", -" '#t\n `(,(r 'or)\n ", -" ,@(map (lambda (x)\n ", -" `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))\n ", -" (car clause))))\n ,(if (com", -"pare (r '=>) (list-ref clause 1))\n `(,(list-ref claus", -"e 2) ,(r 'key))\n `(,(r 'begin) ,@(cdr clause)))\n ", -" ,(loop (cdr clauses)))))))))))\n\n (define-syntax parameterize\n", -" (er-macro-transformer\n (lambda (form r compare)\n (let ((formal (ca", -"dr form))\n (body (cddr form)))\n `(,(r 'with-parameter)\n ", -" (lambda ()\n ,@formal\n ,@body))))))\n\n (define-synt", -"ax letrec-syntax\n (er-macro-transformer\n (lambda (form r c)\n (let (", -"(formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(let", -" ()\n ,@(map (lambda (x)\n `(,(r 'define-syntax) ,(", -"car x) ,(cadr x)))\n formal)\n ,@body)))))\n\n (define", -"-syntax let-syntax\n (er-macro-transformer\n (lambda (form r c)\n `(,(", -"r 'letrec-syntax) ,@(cdr form)))))\n\n (export let let* letrec letrec*\n ", -"let-values let*-values define-values\n quasiquote unquote unquote-splici", -"ng\n and or\n cond case else =>\n do when unless\n ", -" parameterize\n let-syntax letrec-syntax\n syntax-error))\n\n", +"\n(builtin:define-macro call-with-current-environment\n (builtin:lambda (form env", +")\n (list (cadr form) env)))\n\n(builtin:define here\n (call-with-current-enviro", +"nment\n (builtin:lambda (env)\n env)))\n\n(builtin:define the ", +" ; synonym for #'var\n (builtin:lambda (var)\n (make-identifier var here)))", +"\n\n\n(builtin:define the-builtin-define (the (builtin:quote builtin:define)))\n(bui", +"ltin:define the-builtin-lambda (the (builtin:quote builtin:lambda)))\n(builtin:de", +"fine the-builtin-begin (the (builtin:quote builtin:begin)))\n(builtin:define the-", +"builtin-quote (the (builtin:quote builtin:quote)))\n(builtin:define the-builtin-s", +"et! (the (builtin:quote builtin:set!)))\n(builtin:define the-builtin-if (the (bui", +"ltin:quote builtin:if)))\n(builtin:define the-builtin-define-macro (the (builtin:", +"quote builtin:define-macro)))\n\n(builtin:define the-define (the (builtin:quote de", +"fine)))\n(builtin:define the-lambda (the (builtin:quote lambda)))\n(builtin:define", +" the-begin (the (builtin:quote begin)))\n(builtin:define the-quote (the (builtin:", +"quote quote)))\n(builtin:define the-set! (the (builtin:quote set!)))\n(builtin:def", +"ine the-if (the (builtin:quote if)))\n(builtin:define the-define-macro (the (buil", +"tin:quote define-macro)))\n\n(builtin:define-macro quote\n (builtin:lambda (form e", +"nv)\n (builtin:if (= (length form) 2)\n (list the-builtin-quote (cadr form", +"))\n (error \"illegal quote form\" form))))\n\n(builtin:define-macro if\n (built", +"in:lambda (form env)\n ((builtin:lambda (len)\n (builtin:if (= len 4)\n ", +" (cons the-builtin-if (cdr form))\n (builtin:if (= len 3)\n ", +" (list the-builtin-if (list-ref form 1) (list-ref form 2) #undefined)\n ", +" (error \"illegal if form\" form))))\n (length form))))\n\n(builtin:d", +"efine-macro begin\n (builtin:lambda (form env)\n ((builtin:lambda (len)\n ", +" (if (= len 1)\n #undefined\n (if (= len 2)\n (ca", +"dr form)\n (if (= len 3)\n (cons the-builtin-begin", +" (cdr form))\n (list the-builtin-begin\n ", +" (cadr form)\n (cons the-begin (cddr form)))))))\n (le", +"ngth form))))\n\n(builtin:define-macro set!\n (builtin:lambda (form env)\n (if (", +"= (length form) 3)\n (if (variable? (cadr form))\n (cons the-bui", +"ltin-set! (cdr form))\n (error \"illegal set! form\" form))\n (err", +"or \"illegal set! form\" form))))\n\n(builtin:define check-formal\n (builtin:lambda ", +"(formal)\n (if (null? formal)\n #t\n (if (variable? formal)\n ", +" #t\n (if (pair? formal)\n (if (variable? (car form", +"al))\n (check-formal (cdr formal))\n #f)\n ", +" #f)))))\n\n(builtin:define-macro lambda\n (builtin:lambda (form env)\n", +" (if (= (length form) 1)\n (error \"illegal lambda form\" form)\n (", +"if (check-formal (cadr form))\n (list the-builtin-lambda (cadr form) (", +"cons the-begin (cddr form)))\n (error \"illegal lambda form\" form)))))\n", +"\n(builtin:define-macro define\n (lambda (form env)\n ((lambda (len)\n (if", +" (= len 1)\n (error \"illegal define form\" form)\n (if (variabl", +"e? (cadr form))\n (if (= len 3)\n (cons the-builti", +"n-define (cdr form))\n (error \"illegal define form\" form))\n ", +" (if (pair? (cadr form))\n (list the-define\n ", +" (car (cadr form))\n (cons the-lambda (con", +"s (cdr (cadr form)) (cddr form))))\n (error \"define: binding to", +" non-varaible object\" form)))))\n (length form))))\n\n(builtin:define-macro def", +"ine-macro\n (lambda (form env)\n (if (= (length form) 3)\n (if (variable", +"? (cadr form))\n (cons the-builtin-define-macro (cdr form))\n ", +" (error \"define-macro: binding to non-variable object\" form))\n (error \"i", +"llegal define-macro form\" form))))\n\n\n(define-macro syntax-error\n (lambda (form ", +"_)\n (apply error (cdr form))))\n\n(define-macro define-auxiliary-syntax\n (lamb", +"da (form _)\n (define message\n (string-append\n \"invalid use of auxi", +"liary syntax: '\" (symbol->string (cadr form)) \"'\"))\n (list\n the-define-ma", +"cro\n (cadr form)\n (list the-lambda '_\n (list (the 'error) mess", +"age)))))\n\n(define-auxiliary-syntax else)\n(define-auxiliary-syntax =>)\n(define-au", +"xiliary-syntax unquote)\n(define-auxiliary-syntax unquote-splicing)\n(define-auxil", +"iary-syntax syntax-unquote)\n(define-auxiliary-syntax syntax-unquote-splicing)\n\n(", +"define-macro let\n (lambda (form env)\n (if (variable? (cadr form))\n (l", +"ist\n (list the-lambda '()\n (list the-define (cadr form)\n ", +" (cons the-lambda\n (cons (map car (c", +"ar (cddr form)))\n (cdr (cddr form)))))\n ", +" (cons (cadr form) (map cadr (car (cddr form))))))\n (cons\n (", +"cons\n the-lambda\n (cons (map car (cadr form))\n ", +"(cddr form)))\n (map cadr (cadr form))))))\n\n(define-macro and\n (lambda (", +"form env)\n (if (null? (cdr form))\n #t\n (if (null? (cddr form))\n", +" (cadr form)\n (list the-if\n (cadr form)\n ", +" (cons (the 'and) (cddr form))\n #f)))))\n\n(defin", +"e-macro or\n (lambda (form env)\n (if (null? (cdr form))\n #f\n (l", +"et ((tmp (make-identifier 'it env)))\n (list (the 'let)\n ", +"(list (list tmp (cadr form)))\n (list the-if\n ", +" tmp\n tmp\n (cons (the 'or) (cddr form)", +")))))))\n\n(define-macro cond\n (lambda (form env)\n (let ((clauses (cdr form)))", +"\n (if (null? clauses)\n #undefined\n (let ((clause (car cla", +"uses)))\n (if (and (variable? (car clause))\n (vari", +"able=? (the 'else) (make-identifier (car clause) env)))\n (cons th", +"e-begin (cdr clause))\n (if (and (variable? (cadr clause))\n ", +" (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ", +" (let ((tmp (make-identifier 'tmp here)))\n ", +" (list (the 'let) (list (list tmp (car clause)))\n (li", +"st the-if tmp\n (list (car (cddr clause)) tmp)\n ", +" (cons (the 'cond) (cdr clauses)))))\n ", +" (list the-if (car clause)\n (cons the-begin (cd", +"r clause))\n (cons (the 'cond) (cdr clauses))))))))))\n\n(", +"define-macro quasiquote\n (lambda (form env)\n\n (define (quasiquote? form)\n ", +" (and (pair? form)\n (variable? (car form))\n (variable=? (t", +"he 'quasiquote) (make-identifier (car form) env))))\n\n (define (unquote? form)", +"\n (and (pair? form)\n (variable? (car form))\n (variable=", +"? (the 'unquote) (make-identifier (car form) env))))\n\n (define (unquote-splic", +"ing? form)\n (and (pair? form)\n (pair? (car form))\n (var", +"iable? (caar form))\n (variable=? (the 'unquote-splicing) (make-identif", +"ier (caar form) env))))\n\n (define (qq depth expr)\n (cond\n ;; unquo", +"te\n ((unquote? expr)\n (if (= depth 1)\n (car (cdr expr))\n", +" (list (the 'list)\n (list (the 'quote) (the 'unquote", +"))\n (qq (- depth 1) (car (cdr expr))))))\n ;; unquote-spli", +"cing\n ((unquote-splicing? expr)\n (if (= depth 1)\n (list ", +"(the 'append)\n (car (cdr (car expr)))\n (qq dep", +"th (cdr expr)))\n (list (the 'cons)\n (list (the 'list", +")\n (list (the 'quote) (the 'unquote-splicing))\n ", +" (qq (- depth 1) (car (cdr (car expr)))))\n (qq dep", +"th (cdr expr)))))\n ;; quasiquote\n ((quasiquote? expr)\n (list ", +"(the 'list)\n (list (the 'quote) (the 'quasiquote))\n (q", +"q (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n (l", +"ist (the 'cons)\n (qq depth (car expr))\n (qq depth (cdr", +" expr))))\n ;; vector\n ((vector? expr)\n (list (the 'list->vect", +"or) (qq depth (vector->list expr))))\n ;; simple datum\n (else\n ", +" (list (the 'quote) expr))))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n(def", +"ine-macro let*\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n ", +" (body (cdr (cdr form))))\n (if (null? bindings)\n `(,(the 'l", +"et) () ,@body)\n `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindi", +"ngs))))\n (,(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n", +"(define-macro letrec\n (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form))))\n", +"\n(define-macro letrec*\n (lambda (form env)\n (let ((bindings (car (cdr form))", +")\n (body (cdr (cdr form))))\n (let ((variables (map (lambda (v)", +" `(,v #f)) (map car bindings)))\n (initials (map (lambda (v) `(,(the ", +"'set!) ,@v)) bindings)))\n `(,(the 'let) (,@variables)\n ,@initial", +"s\n ,@body)))))\n\n(define-macro let-values\n (lambda (form env)\n `(,(t", +"he 'let*-values) ,@(cdr form))))\n\n(define-macro let*-values\n (lambda (form env)", +"\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n ", +"(if (null? formal)\n `(,(the 'let) () ,@body)\n `(,(the 'call-wi", +"th-values) (,the-lambda () ,@(cdr (car formal)))\n (,(the 'lambda) (,@", +"(car (car formal)))\n (,(the 'let*-values) (,@(cdr formal))\n ", +" ,@body)))))))\n\n(define-macro define-values\n (lambda (form env)\n (let ((", +"formal (car (cdr form)))\n (body (cdr (cdr form))))\n (let ((argum", +"ents (make-identifier 'arguments here)))\n `(,the-begin\n ,@(let l", +"oop ((formal formal))\n (if (pair? formal)\n `((,the", +"-define ,(car formal) #undefined) ,@(loop (cdr formal)))\n (if (", +"variable? formal)\n `((,the-define ,formal #undefined))\n ", +" '())))\n (,(the 'call-with-values) (,the-lambda () ,@b", +"ody)\n (,the-lambda\n ,arguments\n ,@(let loop ((fo", +"rmal formal) (args arguments))\n (if (pair? formal)\n ", +" `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(t", +"he 'cdr) ,args)))\n (if (variable? formal)\n ", +" `((,the-set! ,formal ,args))\n '()))))))))))\n\n(define", +"-macro do\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n (", +"test (car (car (cdr (cdr form)))))\n (cleanup (cdr (car (cdr (cdr f", +"orm)))))\n (body (cdr (cdr (cdr form)))))\n (let ((loop (make-id", +"entifier 'loop here)))\n `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ", +",(cadr x))) bindings)\n (,the-if ,test\n (,the-begin\n ", +" ,@cleanup)\n (,the-begin\n ", +",@body\n (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (", +"car x) (car (cdr (cdr x))))) bindings)))))))))\n\n(define-macro when\n (lambda (fo", +"rm env)\n (let ((test (car (cdr form)))\n (body (cdr (cdr form))))\n ", +" `(,the-if ,test\n (,the-begin ,@body)\n #undefine", +"d))))\n\n(define-macro unless\n (lambda (form env)\n (let ((test (car (cdr form)", +"))\n (body (cdr (cdr form))))\n `(,the-if ,test\n #und", +"efined\n (,the-begin ,@body)))))\n\n(define-macro case\n (lambda (fo", +"rm env)\n (let ((key (car (cdr form)))\n (clauses (cdr (cdr form))", +"))\n (let ((the-key (make-identifier 'key here)))\n `(,(the 'let) ((,t", +"he-key ,key))\n ,(let loop ((clauses clauses))\n (if (null? c", +"lauses)\n #undefined\n (let ((clause (car clauses)", +"))\n `(,the-if ,(if (and (variable? (car clause))\n ", +" (variable=? (the 'else) (make-identifier (car clause) ", +"env)))\n #t\n `(", +",(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car cla", +"use))))\n ,(if (and (variable? (cadr clause))\n ", +" (variable=? (the '=>) (make-identifier (cadr cla", +"use) env)))\n `(,(car (cdr (cdr clause))) ,the-k", +"ey)\n `(,the-begin ,@(cdr clause)))\n ", +" ,(loop (cdr clauses)))))))))))\n\n(define-macro parameterize\n (l", +"ambda (form env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr", +" form))))\n `(,(the 'with-parameter)\n (,(the 'lambda) ()\n ,@f", +"ormal\n ,@body)))))\n\n(define-macro syntax-quote\n (lambda (form env)\n ", +"(let ((renames '()))\n (letrec\n ((rename (lambda (var)\n ", +" (let ((x (assq var renames)))\n (if x\n ", +" (cadr x)\n (begin\n ", +" (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier)", +" ',var ',env)) . ,renames))\n (rename var))))))\n ", +" (walk (lambda (f form)\n (cond\n ((vari", +"able? form)\n (f form))\n ((pair? form)\n ", +" `(,(the 'cons) (walk f (car form)) (walk f (cdr form))))\n ", +" ((vector? form)\n `(,(the 'list->vector) (walk", +" f (vector->list form))))\n (else\n `(,(the", +" 'quote) ,form))))))\n (let ((form (walk rename (cadr form))))\n `", +"(,(the 'let)\n ,(map cdr renames)\n ,form))))))\n\n(define-mac", +"ro syntax-quasiquote\n (lambda (form env)\n (let ((renames '()))\n (letrec", +"\n ((rename (lambda (var)\n (let ((x (assq var rename", +"s)))\n (if x\n (cadr x)\n ", +" (begin\n (set! renames `((,var ,(mak", +"e-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))\n ", +" (rename var)))))))\n\n (define (syntax-quasiquote? f", +"orm)\n (and (pair? form)\n (variable? (car form))\n ", +" (variable=? (the 'syntax-quasiquote) (make-identifier (car form) env))))\n\n", +" (define (syntax-unquote? form)\n (and (pair? form)\n ", +" (variable? (car form))\n (variable=? (the 'syntax-unquote) (make-", +"identifier (car form) env))))\n\n (define (syntax-unquote-splicing? form)\n ", +" (and (pair? form)\n (pair? (car form))\n (var", +"iable? (caar form))\n (variable=? (the 'syntax-unquote-splicing) (m", +"ake-identifier (caar form) env))))\n\n (define (qq depth expr)\n (c", +"ond\n ;; syntax-unquote\n ((syntax-unquote? expr)\n ", +"(if (= depth 1)\n (car (cdr expr))\n (list (the 'lis", +"t)\n (list (the 'quote) (the 'syntax-unquote))\n ", +" (qq (- depth 1) (car (cdr expr))))))\n ;; syntax-unquote-splic", +"ing\n ((syntax-unquote-splicing? expr)\n (if (= depth 1)\n ", +" (list (the 'append)\n (car (cdr (car expr)))\n ", +" (qq depth (cdr expr)))\n (list (the 'cons)\n ", +" (list (the 'list)\n (list (the 'quot", +"e) (the 'syntax-unquote-splicing))\n (qq (- depth 1) (", +"car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ", +" ;; syntax-quasiquote\n ((syntax-quasiquote? expr)\n (list (", +"the 'list)\n (list (the 'quote) (the 'quasiquote))\n ", +" (qq (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? e", +"xpr)\n (list (the 'cons)\n (qq depth (car expr))\n ", +" (qq depth (cdr expr))))\n ;; vector\n ((vector? e", +"xpr)\n (list (the 'list->vector) (qq depth (vector->list expr))))\n ", +" ;; variable\n ((variable? expr)\n (rename expr))\n ", +" ;; simple datum\n (else\n (list (the 'quote) expr))))\n\n", +" (let ((body (qq 1 (cadr form))))\n `(,(the 'let)\n ,(m", +"ap cdr renames)\n ,body))))))\n\n(define (transformer f)\n (lambda (form", +" env)\n (let ((register1 (make-register))\n (register2 (make-register)", +"))\n (letrec\n ((wrap (lambda (var1)\n (let ((var2 ", +"(register1 var1)))\n (if (undefined? var2)\n ", +" (let ((var2 (make-identifier var1 env)))\n (regi", +"ster1 var1 var2)\n (register2 var2 var1)\n ", +" var2)\n var2))))\n (unwrap (lambda ", +"(var2)\n (let ((var1 (register2 var2)))\n ", +" (if (undefined? var1)\n var2\n ", +" var1))))\n (walk (lambda (f form)\n (cond\n ", +" ((variable? form)\n (f form))\n ", +"((pair? form)\n (cons (walk f (car form)) (walk f (cdr form))", +"))\n ((vector? form)\n (list->vector (walk ", +"f (vector->list form))))\n (else\n form))))", +")\n (let ((form (cdr form)))\n (walk unwrap (apply f (walk wrap fo", +"rm))))))))\n\n(define-macro define-syntax\n (lambda (form env)\n (let ((formal (", +"car (cdr form)))\n (body (cdr (cdr form))))\n (if (pair? formal)\n ", +" `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body", +"))\n `(,the-define-macro ,formal (,(the 'transformer) (,the-begin ,@body", +")))))))\n\n(define-macro letrec-syntax\n (lambda (form env)\n (let ((formal (car", +" (cdr form)))\n (body (cdr (cdr form))))\n `(let ()\n ,@(ma", +"p (lambda (x)\n `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n ", +" formal)\n ,@body))))\n\n(define-macro let-syntax\n (lambda (fo", +"rm env)\n `(,(the 'letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(d", +"efine-macro define-library\n (lambda (form _)\n (let ((name (cadr form))\n ", +" (body (cddr form)))\n (let ((old-library (current-library))\n ", +" (new-library (or (find-library name) (make-library name))))\n (let ((env ", +"(library-environment new-library)))\n (current-library new-library)\n ", +" (for-each (lambda (expr) (eval expr env)) body)\n (current-library", +" old-library))))))\n\n(define-macro cond-expand\n (lambda (form _)\n (letrec\n ", +" ((test (lambda (form)\n (or\n (eq? form 'els", +"e)\n (and (symbol? form)\n (memq form (feat", +"ures)))\n (and (pair? form)\n (case (car fo", +"rm)\n ((library) (find-library (cadr form)))\n ", +" ((not) (not (test (cadr form))))\n ((and) (l", +"et loop ((form (cdr form)))\n (or (null? form)\n ", +" (and (test (car form)) (loop (cdr form)))))", +")\n ((or) (let loop ((form (cdr form)))\n ", +" (and (pair? form)\n (or (tes", +"t (car form)) (loop (cdr form))))))\n (else #f)))))))\n ", +" (let loop ((clauses (cdr form)))\n (if (null? clauses)\n #und", +"efined\n (if (test (caar clauses))\n `(,the-begin ,@(cda", +"r 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->string prefix)\n ", +" (symbol->string symbol))))))\n (letrec\n ((extract\n (l", +"ambda (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 (car spec)\n ", +" ((only)\n (let ((alist (collect (cadr spec))))\n ", +" (map (lambda (var) (assq var alist)) (cddr spec))))\n ((renam", +"e)\n (let ((alist (collect (cadr spec))))\n (map", +" (lambda (s) (or (assq (car s) (cddr spec)) s)) alist)))\n ((prefi", +"x)\n (let ((alist (collect (cadr spec))))\n (map", +" (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))\n ", +" ((except)\n (let ((alist (collect (cadr spec))))\n ", +" (let loop ((alist alist))\n (if (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 (le", +"trec\n ((import\n (lambda (spec)\n (let ((", +"lib (extract spec))\n (alist (collect spec)))\n ", +" (for-each\n (lambda (slot)\n (librar", +"y-import lib (cdr slot) (car slot)))\n alist)))))\n (f", +"or-each import (cdr form)))))))\n\n(define-macro export\n (lambda (form _)\n (le", +"trec\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 (coll", +"ect spec)))\n (library-export (car slot) (cdr slot))))))\n (for", +"-each export (cdr form)))))\n\n(export define-library\n cond-expand\n ", +"import\n export)\n\n(export let let* letrec letrec*\n let-values let*-", +"values define-values\n quasiquote unquote unquote-splicing\n and or\n", +" cond case else =>\n do when unless\n parameterize\n de", +"fine-syntax\n syntax-quote syntax-unquote\n syntax-quasiquote syntax", +"-unquote-splicing\n let-syntax letrec-syntax\n syntax-error)\n\n\n", "", "" }; diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 79d4126c..d9be026a 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -4,215 +4,391 @@ #include "picrin.h" -typedef xvect_t(pic_sym *) xvect; - -#define xv_push_sym(v, x) xv_push(pic_sym *, (v), (x)) - /** - * scope object + * macro expander */ +static pic_sym * +lookup(pic_state PIC_UNUSED(*pic), pic_value var, struct pic_env *env) +{ + khiter_t it; + + pic_assert_type(pic, var, var); + + while (env != NULL) { + it = kh_get(env, &env->map, pic_ptr(var)); + if (it != kh_end(&env->map)) { + return kh_val(&env->map, it); + } + env = env->up; + } + return NULL; +} + +pic_sym * +pic_resolve(pic_state *pic, pic_value var, struct pic_env *env) +{ + pic_sym *uid; + + assert(env != NULL); + + pic_assert_type(pic, var, var); + + while ((uid = lookup(pic, var, env)) == NULL) { + if (pic_sym_p(var)) { + break; + } + env = pic_id_ptr(var)->env; + var = pic_id_ptr(var)->var; + } + if (uid == NULL) { + while (env->up != NULL) { + env = env->up; + } + uid = pic_add_variable(pic, env, var); + } + return uid; +} + +static void +define_macro(pic_state *pic, pic_sym *uid, struct pic_proc *mac) +{ + if (pic_dict_has(pic, pic->macros, uid)) { + pic_warnf(pic, "redefining syntax variable: ~s", pic_obj_value(uid)); + } + pic_dict_set(pic, pic->macros, uid, pic_obj_value(mac)); +} + +static struct pic_proc * +find_macro(pic_state *pic, pic_sym *uid) +{ + if (! pic_dict_has(pic, pic->macros, uid)) { + return NULL; + } + return pic_proc_ptr(pic_dict_ref(pic, pic->macros, uid)); +} + +static void +shadow_macro(pic_state *pic, pic_sym *uid) +{ + if (pic_dict_has(pic, pic->macros, uid)) { + pic_dict_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_value var, struct pic_env *env) +{ + return pic_obj_value(pic_resolve(pic, var, env)); +} + +static pic_value +expand_quote(pic_state *pic, pic_value expr) +{ + return pic_cons(pic, pic_obj_value(pic->uQUOTE), 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_list1(pic, 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_variable(pic, in, pic_car(pic, a)); + } + if (pic_var_p(a)) { + pic_add_variable(pic, in, a); + } + + 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->uLAMBDA), formal, body); +} + +static pic_value +expand_define(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred) +{ + pic_sym *uid; + pic_value var, val; + + var = pic_cadr(pic, expr); + if ((uid = pic_find_variable(pic, env, var)) == NULL) { + uid = pic_add_variable(pic, env, var); + } else { + shadow_macro(pic, uid); + } + val = expand(pic, pic_list_ref(pic, expr, 2), env, deferred); + + return pic_list3(pic, pic_obj_value(pic->uDEFINE), pic_obj_value(uid), val); +} + +static pic_value +expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) +{ + pic_value var, val; + pic_sym *uid; + + var = pic_cadr(pic, expr); + if ((uid = pic_find_variable(pic, env, var)) == NULL) { + uid = pic_add_variable(pic, env, var); + } + + val = pic_eval(pic, pic_list_ref(pic, expr, 2), env); + if (! pic_proc_p(val)) { + pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); + } + + 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, expr, env); + } + case PIC_TT_PAIR: { + struct pic_proc *mac; + + if (! pic_list_p(expr)) { + pic_errorf(pic, "cannot expand improper list: ~s", expr); + } + + if (pic_var_p(pic_car(pic, expr))) { + pic_sym *functor; + + functor = pic_resolve(pic, pic_car(pic, expr), env); + + if (functor == pic->uDEFINE_MACRO) { + return expand_defmacro(pic, expr, env); + } + else if (functor == pic->uLAMBDA) { + return expand_defer(pic, expr, deferred); + } + else if (functor == pic->uDEFINE) { + return expand_define(pic, expr, env, deferred); + } + else if (functor == pic->uQUOTE) { + return expand_quote(pic, expr); + } + + if ((mac = find_macro(pic, functor)) != NULL) { + return expand_node(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; +} + +KHASH_DECLARE(a, pic_sym *, int) +KHASH_DEFINE2(a, pic_sym *, int, 0, kh_ptr_hash_func, kh_ptr_hash_equal) + typedef struct analyze_scope { int depth; - bool varg; - xvect args, locals, captures; /* rest args variable is counted as a local */ + pic_sym *rest; /* Nullable */ + khash_t(a) args, locals, captures; /* rest args variable is counted as a local */ pic_value defer; struct analyze_scope *up; } analyze_scope; -/** - * global analyzer state - */ - -typedef struct analyze_state { - pic_state *pic; - analyze_scope *scope; -} analyze_state; - -static bool push_scope(analyze_state *, pic_value); -static void pop_scope(analyze_state *); - -static analyze_state * -new_analyze_state(pic_state *pic) +static void +analyzer_scope_init(pic_state *pic, analyze_scope *scope, pic_value formal, analyze_scope *up) { - analyze_state *state; - pic_sym *sym; - xh_entry *it; + int ret; - state = pic_malloc(pic, sizeof(analyze_state)); - state->pic = pic; - state->scope = NULL; + kh_init(a, &scope->args); + kh_init(a, &scope->locals); + kh_init(a, &scope->captures); - /* push initial scope */ - push_scope(state, pic_nil_value()); - - pic_dict_for_each (sym, pic->globals, it) { - xv_push_sym(state->scope->locals, sym); + /* analyze formal */ + for (; pic_pair_p(formal); formal = pic_cdr(pic, formal)) { + kh_put(a, &scope->args, pic_sym_ptr(pic_car(pic, formal)), &ret); + } + if (pic_nil_p(formal)) { + scope->rest = NULL; + } + else { + scope->rest = pic_sym_ptr(formal); + kh_put(a, &scope->locals, pic_sym_ptr(formal), &ret); } - return state; + scope->up = up; + scope->depth = up ? up->depth + 1 : 0; + scope->defer = pic_nil_value(); } static void -destroy_analyze_state(analyze_state *state) +analyzer_scope_destroy(pic_state *pic, analyze_scope *scope) { - pop_scope(state); - pic_free(state->pic, state); + kh_destroy(a, &scope->args); + kh_destroy(a, &scope->locals); + kh_destroy(a, &scope->captures); } static bool -analyze_args(pic_state *pic, pic_value formals, bool *varg, xvect *args, xvect *locals) +search_scope(analyze_scope *scope, pic_sym *sym) { - pic_value v, t; - pic_sym *sym; - - for (v = formals; pic_pair_p(v); v = pic_cdr(pic, v)) { - t = pic_car(pic, v); - if (! pic_sym_p(t)) { - return false; - } - sym = pic_sym_ptr(t); - xv_push_sym(*args, sym); - } - if (pic_nil_p(v)) { - *varg = false; - } - else if (pic_sym_p(v)) { - *varg = true; - sym = pic_sym_ptr(v); - xv_push_sym(*locals, sym); - } - else { - return false; - } - - return true; -} - -static bool -push_scope(analyze_state *state, pic_value formals) -{ - pic_state *pic = state->pic; - analyze_scope *scope = pic_malloc(pic, sizeof(analyze_scope)); - bool varg; - - xv_init(scope->args); - xv_init(scope->locals); - xv_init(scope->captures); - - if (analyze_args(pic, formals, &varg, &scope->args, &scope->locals)) { - scope->up = state->scope; - scope->depth = scope->up ? scope->up->depth + 1 : 0; - scope->varg = varg; - scope->defer = pic_nil_value(); - - state->scope = scope; - - return true; - } - else { - xv_destroy(scope->args); - xv_destroy(scope->locals); - xv_destroy(scope->captures); - pic_free(pic, scope); - return false; - } -} - -static void -pop_scope(analyze_state *state) -{ - pic_state *pic = state->pic; - analyze_scope *scope; - - scope = state->scope; - xv_destroy(scope->args); - xv_destroy(scope->locals); - xv_destroy(scope->captures); - - scope = scope->up; - pic_free(state->pic, state->scope); - state->scope = scope; -} - -static bool -lookup_scope(analyze_scope *scope, pic_sym *sym) -{ - size_t i; - - /* args */ - for (i = 0; i < xv_size(scope->args); ++i) { - if (xv_A(scope->args, i) == sym) - return true; - } - /* locals */ - for (i = 0; i < xv_size(scope->locals); ++i) { - if (xv_A(scope->locals, i) == sym) - return true; - } - return false; + return kh_get(a, &scope->args, sym) != kh_end(&scope->args) || kh_get(a, &scope->locals, sym) != kh_end(&scope->locals) || scope->depth == 0; } static void capture_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) { - size_t i; + int ret; - for (i = 0; i < xv_size(scope->captures); ++i) { - if (xv_A(scope->captures, i) == sym) { - break; - } - } - if (i == xv_size(scope->captures)) { - xv_push_sym(scope->captures, sym); - } + kh_put(a, &scope->captures, sym, &ret); } static int -find_var(analyze_state *state, pic_sym *sym) +find_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) { - analyze_scope *scope = state->scope; int depth = 0; while (scope) { - if (lookup_scope(scope, sym)) { + if (search_scope(scope, sym)) { if (depth > 0) { - capture_var(state->pic, scope, sym); + capture_var(pic, scope, sym); } return depth; } depth++; scope = scope->up; } - return -1; + PIC_UNREACHABLE(); } static void -define_var(analyze_state *state, pic_sym *sym) +define_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) { - pic_state *pic = state->pic; - analyze_scope *scope = state->scope; + int ret; - if (lookup_scope(scope, sym)) { - pic_warnf(pic, "redefining variable: ~s", pic_obj_value(sym)); + if (search_scope(scope, sym)) { + if (scope->depth > 0 || pic_dict_has(pic, pic->globals, sym)) { + pic_warnf(pic, "redefining variable: ~s", pic_obj_value(sym)); + } return; } - xv_push_sym(scope->locals, sym); + kh_put(a, &scope->locals, sym, &ret); } -static pic_value analyze_node(analyze_state *, pic_value, bool); -static pic_value analyze_procedure(analyze_state *, pic_value, pic_value, pic_value); +static pic_value analyze_node(pic_state *, analyze_scope *, pic_value, bool); +static pic_value analyze_procedure(pic_state *, analyze_scope *, pic_value); static pic_value -analyze(analyze_state *state, pic_value obj, bool tailpos) +analyze(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) { - pic_state *pic = state->pic; size_t ai = pic_gc_arena_preserve(pic); pic_value res; pic_sym *tag; - res = analyze_node(state, obj, tailpos); + res = analyze_node(pic, scope, obj, tailpos); tag = pic_sym_ptr(pic_car(pic, res)); if (tailpos) { @@ -226,302 +402,186 @@ analyze(analyze_state *state, pic_value obj, bool tailpos) pic_gc_arena_restore(pic, ai); pic_gc_protect(pic, res); - pic_gc_protect(pic, state->scope->defer); + pic_gc_protect(pic, scope->defer); return res; } static pic_value -analyze_global_var(analyze_state *state, pic_sym *sym) +analyze_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) { - pic_state *pic = state->pic; - - return pic_list2(pic, pic_obj_value(pic->sGREF), pic_obj_value(sym)); -} - -static pic_value -analyze_local_var(analyze_state *state, pic_sym *sym) -{ - pic_state *pic = state->pic; - - return pic_list2(pic, pic_obj_value(pic->sLREF), pic_obj_value(sym)); -} - -static pic_value -analyze_free_var(analyze_state *state, pic_sym *sym, int depth) -{ - pic_state *pic = state->pic; - - return pic_list3(pic, pic_obj_value(pic->sCREF), pic_int_value(depth), pic_obj_value(sym)); -} - -static pic_value -analyze_var(analyze_state *state, pic_sym *sym) -{ - pic_state *pic = state->pic; int depth; - if ((depth = find_var(state, sym)) == -1) { - pic_errorf(pic, "unbound variable %s", pic_symbol_name(pic, sym)); - } + depth = find_var(pic, scope, sym); - if (depth == state->scope->depth) { - return analyze_global_var(state, sym); + if (depth == scope->depth) { + return pic_list2(pic, pic_obj_value(pic->sGREF), pic_obj_value(sym)); } else if (depth == 0) { - return analyze_local_var(state, sym); + return pic_list2(pic, pic_obj_value(pic->sLREF), pic_obj_value(sym)); } else { - return analyze_free_var(state, sym, depth); + return pic_list3(pic, pic_obj_value(pic->sCREF), pic_int_value(depth), pic_obj_value(sym)); } } static pic_value -analyze_defer(analyze_state *state, pic_value name, pic_value formal, pic_value body) +analyze_defer(pic_state *pic, analyze_scope *scope, pic_value form) { - pic_state *pic = state->pic; pic_sym *sNOWHERE = pic_intern_cstr(pic, "<>"); pic_value skel; skel = pic_list2(pic, pic_obj_value(pic->sGREF), pic_obj_value(sNOWHERE)); - pic_push(pic, pic_list4(pic, name, formal, body, skel), state->scope->defer); + pic_push(pic, pic_cons(pic, skel, form), scope->defer); return skel; } static void -analyze_deferred(analyze_state *state) +analyze_deferred(pic_state *pic, analyze_scope *scope) { - pic_state *pic = state->pic; - pic_value defer, val, name, formal, body, dst, it; + pic_value defer, it, skel, form, val; - pic_for_each (defer, pic_reverse(pic, state->scope->defer), it) { - name = pic_list_ref(pic, defer, 0); - formal = pic_list_ref(pic, defer, 1); - body = pic_list_ref(pic, defer, 2); - dst = pic_list_ref(pic, defer, 3); + pic_for_each (defer, pic_reverse(pic, scope->defer), it) { + skel = pic_car(pic, defer); + form = pic_cdr(pic, defer); - val = analyze_procedure(state, name, formal, body); + val = analyze_procedure(pic, scope, form); /* copy */ - pic_pair_ptr(dst)->car = pic_car(pic, val); - pic_pair_ptr(dst)->cdr = pic_cdr(pic, val); + pic_pair_ptr(skel)->car = pic_car(pic, val); + pic_pair_ptr(skel)->cdr = pic_cdr(pic, val); } - state->scope->defer = pic_nil_value(); + scope->defer = pic_nil_value(); } static pic_value -analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_value body_exprs) +analyze_procedure(pic_state *pic, analyze_scope *up, pic_value form) { - pic_state *pic = state->pic; - pic_value args, locals, varg, captures, body; + analyze_scope s, *scope = &s; + pic_value formals, body; + pic_value rest = pic_undef_value(); + pic_vec *args, *locals, *captures; + size_t i, j; - assert(pic_sym_p(name) || pic_false_p(name)); + formals = pic_list_ref(pic, form, 1); + body = pic_list_ref(pic, form, 2); - if (push_scope(state, formals)) { - analyze_scope *scope = state->scope; - size_t i; + analyzer_scope_init(pic, scope, formals, up); - args = pic_nil_value(); - for (i = xv_size(scope->args); i > 0; --i) { - pic_push(pic, pic_obj_value(xv_A(scope->args, i - 1)), args); + /* analyze body */ + body = analyze(pic, scope, body, true); + analyze_deferred(pic, scope); + + args = pic_make_vec(pic, kh_size(&scope->args)); + for (i = 0; pic_pair_p(formals); formals = pic_cdr(pic, formals), i++) { + args->data[i] = pic_car(pic, formals); + } + + if (scope->rest != NULL) { + rest = pic_obj_value(scope->rest); + } + + locals = pic_make_vec(pic, kh_size(&scope->locals)); + for (i = kh_begin(&scope->locals), j = 0; i < kh_end(&scope->locals); ++i) { + if (kh_exist(&scope->locals, i)) { + locals->data[j++] = pic_obj_value(kh_key(&scope->locals, i)); } + } - varg = scope->varg - ? pic_true_value() - : pic_false_value(); - - /* To know what kind of local variables are defined, analyze body at first. */ - body = analyze(state, pic_cons(pic, pic_obj_value(pic->rBEGIN), body_exprs), true); - - analyze_deferred(state); - - locals = pic_nil_value(); - for (i = xv_size(scope->locals); i > 0; --i) { - pic_push(pic, pic_obj_value(xv_A(scope->locals, i - 1)), locals); + captures = pic_make_vec(pic, kh_size(&scope->captures)); + for (i = kh_begin(&scope->captures), j = 0; i < kh_end(&scope->captures); ++i) { + if (kh_exist(&scope->captures, i)) { + captures->data[j++] = pic_obj_value(kh_key(&scope->captures, i)); } - - captures = pic_nil_value(); - for (i = xv_size(scope->captures); i > 0; --i) { - pic_push(pic, pic_obj_value(xv_A(scope->captures, i - 1)), captures); - } - - pop_scope(state); - } - else { - pic_errorf(pic, "invalid formal syntax: ~s", formals); } - return pic_list7(pic, pic_obj_value(pic->sLAMBDA), name, args, locals, varg, captures, body); + analyzer_scope_destroy(pic, scope); + + return pic_list6(pic, pic_obj_value(pic->sLAMBDA), rest, pic_obj_value(args), pic_obj_value(locals), pic_obj_value(captures), body); } static pic_value -analyze_lambda(analyze_state *state, pic_value obj) +analyze_define(pic_state *pic, analyze_scope *scope, pic_value obj) { - pic_state *pic = state->pic; - pic_value formals, body_exprs; - - if (pic_length(pic, obj) < 2) { - pic_errorf(pic, "syntax error"); - } - - formals = pic_list_ref(pic, obj, 1); - body_exprs = pic_list_tail(pic, obj, 2); - - return analyze_defer(state, pic_false_value(), formals, body_exprs); -} - -static pic_value -analyze_declare(analyze_state *state, pic_sym *var) -{ - define_var(state, var); - - return analyze_var(state, var); -} - -static pic_value -analyze_define(analyze_state *state, pic_value obj) -{ - pic_state *pic = state->pic; pic_value var, val; - pic_sym *sym; - if (pic_length(pic, obj) != 3) { - pic_errorf(pic, "syntax error"); - } + define_var(pic, scope, pic_sym_ptr(pic_list_ref(pic, obj, 1))); - var = pic_list_ref(pic, obj, 1); - if (! pic_sym_p(var)) { - pic_errorf(pic, "syntax error"); - } else { - sym = pic_sym_ptr(var); - } - var = analyze_declare(state, sym); - - if (pic_pair_p(pic_list_ref(pic, obj, 2)) - && pic_sym_p(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) - && pic_sym_ptr(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) == pic->rLAMBDA) { - pic_value formals, body_exprs; - - formals = pic_list_ref(pic, pic_list_ref(pic, obj, 2), 1); - body_exprs = pic_list_tail(pic, pic_list_ref(pic, obj, 2), 2); - - val = analyze_defer(state, pic_obj_value(sym), formals, body_exprs); - } else { - if (pic_length(pic, obj) != 3) { - pic_errorf(pic, "syntax error"); - } - val = analyze(state, pic_list_ref(pic, obj, 2), false); - } + var = analyze(pic, scope, pic_list_ref(pic, obj, 1), false); + val = analyze(pic, scope, pic_list_ref(pic, obj, 2), false); return pic_list3(pic, pic_obj_value(pic->sSETBANG), var, val); } static pic_value -analyze_if(analyze_state *state, pic_value obj, bool tailpos) +analyze_if(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) { - pic_state *pic = state->pic; pic_value cond, if_true, if_false; - if_false = pic_undef_value(); - switch (pic_length(pic, obj)) { - default: - pic_errorf(pic, "syntax error"); - case 4: - if_false = pic_list_ref(pic, obj, 3); - PIC_FALLTHROUGH; - case 3: - if_true = pic_list_ref(pic, obj, 2); - } + if_true = pic_list_ref(pic, obj, 2); + if_false = pic_list_ref(pic, obj, 3); - /* analyze in order */ - cond = analyze(state, pic_list_ref(pic, obj, 1), false); - if_true = analyze(state, if_true, tailpos); - if_false = analyze(state, if_false, tailpos); + cond = analyze(pic, scope, pic_list_ref(pic, obj, 1), false); + if_true = analyze(pic, scope, if_true, tailpos); + if_false = analyze(pic, scope, if_false, tailpos); return pic_list4(pic, pic_obj_value(pic->sIF), cond, if_true, if_false); } static pic_value -analyze_begin(analyze_state *state, pic_value obj, bool tailpos) +analyze_begin(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) { - pic_state *pic = state->pic; - pic_value seq; - bool tail; + pic_value beg1, beg2; - switch (pic_length(pic, obj)) { - case 1: - return analyze(state, pic_undef_value(), tailpos); - case 2: - return analyze(state, pic_list_ref(pic, obj, 1), tailpos); - default: - seq = pic_list1(pic, pic_obj_value(pic->sBEGIN)); - for (obj = pic_cdr(pic, obj); ! pic_nil_p(obj); obj = pic_cdr(pic, obj)) { - if (pic_nil_p(pic_cdr(pic, obj))) { - tail = tailpos; - } else { - tail = false; - } - seq = pic_cons(pic, analyze(state, pic_car(pic, obj), tail), seq); - } - return pic_reverse(pic, seq); - } + beg1 = pic_list_ref(pic, obj, 1); + beg2 = pic_list_ref(pic, obj, 2); + + beg1 = analyze(pic, scope, beg1, false); + beg2 = analyze(pic, scope, beg2, tailpos); + + return pic_list3(pic, pic_obj_value(pic->sBEGIN), beg1, beg2); } static pic_value -analyze_set(analyze_state *state, pic_value obj) +analyze_set(pic_state *pic, analyze_scope *scope, pic_value obj) { - pic_state *pic = state->pic; pic_value var, val; - if (pic_length(pic, obj) != 3) { - pic_errorf(pic, "syntax error"); - } - var = pic_list_ref(pic, obj, 1); - if (! pic_sym_p(var)) { - pic_errorf(pic, "syntax error"); - } - val = pic_list_ref(pic, obj, 2); - var = analyze(state, var, false); - val = analyze(state, val, false); + var = analyze(pic, scope, var, false); + val = analyze(pic, scope, val, false); return pic_list3(pic, pic_obj_value(pic->sSETBANG), var, val); } static pic_value -analyze_quote(analyze_state *state, pic_value obj) +analyze_quote(pic_state *pic, pic_value obj) { - pic_state *pic = state->pic; - - if (pic_length(pic, obj) != 2) { - pic_errorf(pic, "syntax error"); - } return pic_list2(pic, pic_obj_value(pic->sQUOTE), pic_list_ref(pic, obj, 1)); } #define ARGC_ASSERT_GE(n, name) do { \ if (pic_length(pic, obj) < (n) + 1) { \ pic_errorf(pic, \ - #name ": wrong number of arguments (%d for at least %d)", \ - pic_length(pic, obj) - 1, \ + #name ": wrong number of arguments (%d for at least %d)", \ + pic_length(pic, obj) - 1, \ n); \ } \ } while (0) -#define FOLD_ARGS(sym) do { \ - obj = analyze(state, pic_car(pic, args), false); \ - pic_for_each (arg, pic_cdr(pic, args), it) { \ - obj = pic_list3(pic, pic_obj_value(sym), obj, \ - analyze(state, arg, false)); \ - } \ +#define FOLD_ARGS(sym) do { \ + obj = analyze(pic, scope, pic_car(pic, args), false); \ + pic_for_each (arg, pic_cdr(pic, args), it) { \ + obj = pic_list3(pic, pic_obj_value(sym), obj, \ + analyze(pic, scope, arg, false)); \ + } \ } while (0) static pic_value -analyze_add(analyze_state *state, pic_value obj, bool tailpos) +analyze_add(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) { - pic_state *pic = state->pic; pic_value args, arg, it; ARGC_ASSERT_GE(0, "+"); @@ -529,7 +589,7 @@ analyze_add(analyze_state *state, pic_value obj, bool tailpos) case 1: return pic_list2(pic, pic_obj_value(pic->sQUOTE), pic_int_value(0)); case 2: - return analyze(state, pic_car(pic, pic_cdr(pic, obj)), tailpos); + return analyze(pic, scope, pic_car(pic, pic_cdr(pic, obj)), tailpos); default: args = pic_cdr(pic, obj); FOLD_ARGS(pic->sADD); @@ -538,16 +598,15 @@ analyze_add(analyze_state *state, pic_value obj, bool tailpos) } static pic_value -analyze_sub(analyze_state *state, pic_value obj) +analyze_sub(pic_state *pic, analyze_scope *scope, pic_value obj) { - pic_state *pic = state->pic; pic_value args, arg, it; ARGC_ASSERT_GE(1, "-"); switch (pic_length(pic, obj)) { case 2: return pic_list2(pic, pic_obj_value(pic->sMINUS), - analyze(state, pic_car(pic, pic_cdr(pic, obj)), false)); + analyze(pic, scope, pic_car(pic, pic_cdr(pic, obj)), false)); default: args = pic_cdr(pic, obj); FOLD_ARGS(pic->sSUB); @@ -556,9 +615,8 @@ analyze_sub(analyze_state *state, pic_value obj) } static pic_value -analyze_mul(analyze_state *state, pic_value obj, bool tailpos) +analyze_mul(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) { - pic_state *pic = state->pic; pic_value args, arg, it; ARGC_ASSERT_GE(0, "*"); @@ -566,7 +624,7 @@ analyze_mul(analyze_state *state, pic_value obj, bool tailpos) case 1: return pic_list2(pic, pic_obj_value(pic->sQUOTE), pic_int_value(1)); case 2: - return analyze(state, pic_car(pic, pic_cdr(pic, obj)), tailpos); + return analyze(pic, scope, pic_car(pic, pic_cdr(pic, obj)), tailpos); default: args = pic_cdr(pic, obj); FOLD_ARGS(pic->sMUL); @@ -575,9 +633,8 @@ analyze_mul(analyze_state *state, pic_value obj, bool tailpos) } static pic_value -analyze_div(analyze_state *state, pic_value obj) +analyze_div(pic_state *pic, analyze_scope *scope, pic_value obj) { - pic_state *pic = state->pic; pic_value args, arg, it; ARGC_ASSERT_GE(1, "/"); @@ -589,7 +646,7 @@ analyze_div(analyze_state *state, pic_value obj) #else obj = pic_list3(pic, pic_car(pic, obj), pic_int_value(1), pic_car(pic, args)); #endif - return analyze(state, obj, false); + return analyze(pic, scope, obj, false); default: args = pic_cdr(pic, obj); FOLD_ARGS(pic->sDIV); @@ -598,9 +655,8 @@ analyze_div(analyze_state *state, pic_value obj) } static pic_value -analyze_call(analyze_state *state, pic_value obj, bool tailpos) +analyze_call(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) { - pic_state *pic = state->pic; pic_value seq, elt, it; pic_sym *call; @@ -611,32 +667,30 @@ analyze_call(analyze_state *state, pic_value obj, bool tailpos) } seq = pic_list1(pic, pic_obj_value(call)); pic_for_each (elt, obj, it) { - seq = pic_cons(pic, analyze(state, elt, false), seq); + seq = pic_cons(pic, analyze(pic, scope, elt, false), seq); } return pic_reverse(pic, seq); } static pic_value -analyze_values(analyze_state *state, pic_value obj, bool tailpos) +analyze_values(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) { - pic_state *pic = state->pic; pic_value v, seq, it; if (! tailpos) { - return analyze_call(state, obj, false); + return analyze_call(pic, scope, obj, false); } seq = pic_list1(pic, pic_obj_value(pic->sRETURN)); pic_for_each (v, pic_cdr(pic, obj), it) { - seq = pic_cons(pic, analyze(state, v, false), seq); + seq = pic_cons(pic, analyze(pic, scope, v, false), seq); } return pic_reverse(pic, seq); } static pic_value -analyze_call_with_values(analyze_state *state, pic_value obj, bool tailpos) +analyze_call_with_values(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) { - pic_state *pic = state->pic; pic_value prod, cnsm; pic_sym *call; @@ -649,8 +703,8 @@ analyze_call_with_values(analyze_state *state, pic_value obj, bool tailpos) } else { call = pic->sTAILCALL_WITH_VALUES; } - prod = analyze(state, pic_list_ref(pic, obj, 1), false); - cnsm = analyze(state, pic_list_ref(pic, obj, 2), false); + prod = analyze(pic, scope, pic_list_ref(pic, obj, 1), false); + cnsm = analyze(pic, scope, pic_list_ref(pic, obj, 2), false); return pic_list3(pic, pic_obj_value(call), prod, cnsm); } @@ -667,25 +721,23 @@ analyze_call_with_values(analyze_state *state, pic_value obj, bool tailpos) } \ } while (0) -#define CONSTRUCT_OP1(op) \ - pic_list2(pic, \ - pic_obj_value(op), \ - analyze(state, pic_list_ref(pic, obj, 1), false)) +#define CONSTRUCT_OP1(op) \ + pic_list2(pic, \ + pic_obj_value(op), \ + analyze(pic, scope, pic_list_ref(pic, obj, 1), false)) -#define CONSTRUCT_OP2(op) \ - pic_list3(pic, \ - pic_obj_value(op), \ - analyze(state, pic_list_ref(pic, obj, 1), false), \ - analyze(state, pic_list_ref(pic, obj, 2), false)) +#define CONSTRUCT_OP2(op) \ + pic_list3(pic, \ + pic_obj_value(op), \ + analyze(pic, scope, pic_list_ref(pic, obj, 1), false), \ + analyze(pic, scope, pic_list_ref(pic, obj, 2), false)) static pic_value -analyze_node(analyze_state *state, pic_value obj, bool tailpos) +analyze_node(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) { - pic_state *pic = state->pic; - switch (pic_type(obj)) { case PIC_TT_SYMBOL: { - return analyze_var(state, pic_sym_ptr(obj)); + return analyze_var(pic, scope, pic_sym_ptr(obj)); } case PIC_TT_PAIR: { pic_value proc; @@ -698,94 +750,94 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos) if (pic_sym_p(proc)) { pic_sym *sym = pic_sym_ptr(proc); - if (sym == pic->rDEFINE) { - return analyze_define(state, obj); + if (sym == pic->uDEFINE) { + return analyze_define(pic, scope, obj); } - else if (sym == pic->rLAMBDA) { - return analyze_lambda(state, obj); + else if (sym == pic->uLAMBDA) { + return analyze_defer(pic, scope, obj); } - else if (sym == pic->rIF) { - return analyze_if(state, obj, tailpos); + else if (sym == pic->uIF) { + return analyze_if(pic, scope, obj, tailpos); } - else if (sym == pic->rBEGIN) { - return analyze_begin(state, obj, tailpos); + else if (sym == pic->uBEGIN) { + return analyze_begin(pic, scope, obj, tailpos); } - else if (sym == pic->rSETBANG) { - return analyze_set(state, obj); + else if (sym == pic->uSETBANG) { + return analyze_set(pic, scope, obj); } - else if (sym == pic->rQUOTE) { - return analyze_quote(state, obj); + else if (sym == pic->uQUOTE) { + return analyze_quote(pic, obj); } - else if (sym == pic->rCONS) { + else if (sym == pic->uCONS) { ARGC_ASSERT(2, "cons"); return CONSTRUCT_OP2(pic->sCONS); } - else if (sym == pic->rCAR) { + else if (sym == pic->uCAR) { ARGC_ASSERT(1, "car"); return CONSTRUCT_OP1(pic->sCAR); } - else if (sym == pic->rCDR) { + else if (sym == pic->uCDR) { ARGC_ASSERT(1, "cdr"); return CONSTRUCT_OP1(pic->sCDR); } - else if (sym == pic->rNILP) { + else if (sym == pic->uNILP) { ARGC_ASSERT(1, "nil?"); return CONSTRUCT_OP1(pic->sNILP); } - else if (sym == pic->rSYMBOLP) { + else if (sym == pic->uSYMBOLP) { ARGC_ASSERT(1, "symbol?"); return CONSTRUCT_OP1(pic->sSYMBOLP); } - else if (sym == pic->rPAIRP) { + else if (sym == pic->uPAIRP) { ARGC_ASSERT(1, "pair?"); return CONSTRUCT_OP1(pic->sPAIRP); } - else if (sym == pic->rADD) { - return analyze_add(state, obj, tailpos); + else if (sym == pic->uADD) { + return analyze_add(pic, scope, obj, tailpos); } - else if (sym == pic->rSUB) { - return analyze_sub(state, obj); + else if (sym == pic->uSUB) { + return analyze_sub(pic, scope, obj); } - else if (sym == pic->rMUL) { - return analyze_mul(state, obj, tailpos); + else if (sym == pic->uMUL) { + return analyze_mul(pic, scope, obj, tailpos); } - else if (sym == pic->rDIV) { - return analyze_div(state, obj); + else if (sym == pic->uDIV) { + return analyze_div(pic, scope, obj); } - else if (sym == pic->rEQ) { + else if (sym == pic->uEQ) { ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sEQ); } - else if (sym == pic->rLT) { + else if (sym == pic->uLT) { ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sLT); } - else if (sym == pic->rLE) { + else if (sym == pic->uLE) { ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sLE); } - else if (sym == pic->rGT) { + else if (sym == pic->uGT) { ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sGT); } - else if (sym == pic->rGE) { + else if (sym == pic->uGE) { ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sGE); } - else if (sym == pic->rNOT) { + else if (sym == pic->uNOT) { ARGC_ASSERT(1, "not"); return CONSTRUCT_OP1(pic->sNOT); } - else if (sym == pic->rVALUES) { - return analyze_values(state, obj, tailpos); + else if (sym == pic->uVALUES) { + return analyze_values(pic, scope, obj, tailpos); } - else if (sym == pic->rCALL_WITH_VALUES) { - return analyze_call_with_values(state, obj, tailpos); + else if (sym == pic->uCALL_WITH_VALUES) { + return analyze_call_with_values(pic, scope, obj, tailpos); } } fallback: - return analyze_call(state, obj, tailpos); + return analyze_call(pic, scope, obj, tailpos); } default: return pic_list2(pic, pic_obj_value(pic->sQUOTE), obj); @@ -795,27 +847,22 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos) pic_value pic_analyze(pic_state *pic, pic_value obj) { - analyze_state *state; + analyze_scope s, *scope = &s; - state = new_analyze_state(pic); + analyzer_scope_init(pic, scope, pic_nil_value(), NULL); - obj = analyze(state, obj, true); + obj = analyze(pic, scope, obj, true); - analyze_deferred(state); + analyze_deferred(pic, scope); - destroy_analyze_state(state); + analyzer_scope_destroy(pic, scope); return obj; } -/** - * scope object - */ - typedef struct codegen_context { - pic_sym *name; /* rest args variable is counted as a local */ - bool varg; - xvect args, locals, captures; + pic_sym *rest; + pic_vec *args, *locals, *captures; /* actual bit code sequence */ pic_code *code; size_t clen, ccapa; @@ -832,169 +879,17 @@ typedef struct codegen_context { struct codegen_context *up; } codegen_context; -/** - * global codegen state - */ - -typedef struct codegen_state { - pic_state *pic; - codegen_context *cxt; -} codegen_state; - -static void push_codegen_context(codegen_state *, pic_value, pic_value, pic_value, bool, pic_value); -static struct pic_irep *pop_codegen_context(codegen_state *); - -static codegen_state * -new_codegen_state(pic_state *pic) -{ - codegen_state *state; - - state = pic_malloc(pic, sizeof(codegen_state)); - state->pic = pic; - state->cxt = NULL; - - push_codegen_context(state, pic_false_value(), pic_nil_value(), pic_nil_value(), false, pic_nil_value()); - - return state; -} - -static struct pic_irep * -destroy_codegen_state(codegen_state *state) -{ - pic_state *pic = state->pic; - struct pic_irep *irep; - - irep = pop_codegen_context(state); - pic_free(pic, state); - - return irep; -} +static void create_activation(pic_state *, codegen_context *); static void -emit_n(codegen_state *state, enum pic_opcode insn) +codegen_context_init(pic_state *pic, codegen_context *cxt, codegen_context *up, pic_sym *rest, pic_vec *args, pic_vec *locals, pic_vec *captures) { - pic_state *pic = state->pic; - codegen_context *cxt = state->cxt; + cxt->up = up; + cxt->rest = rest; - if (cxt->clen >= cxt->ccapa) { - cxt->ccapa *= 2; - cxt->code = pic_realloc(pic, cxt->code, sizeof(pic_code) * cxt->ccapa); - } - cxt->code[cxt->clen].insn = insn; - cxt->clen++; -} - -static void -emit_i(codegen_state *state, enum pic_opcode insn, int i) -{ - pic_state *pic = state->pic; - codegen_context *cxt = state->cxt; - - if (cxt->clen >= cxt->ccapa) { - cxt->ccapa *= 2; - cxt->code = pic_realloc(pic, cxt->code, sizeof(pic_code) * cxt->ccapa); - } - cxt->code[cxt->clen].insn = insn; - cxt->code[cxt->clen].u.i = i; - cxt->clen++; -} - -static void -emit_c(codegen_state *state, enum pic_opcode insn, char c) -{ - pic_state *pic = state->pic; - codegen_context *cxt = state->cxt; - - if (cxt->clen >= cxt->ccapa) { - cxt->ccapa *= 2; - cxt->code = pic_realloc(pic, cxt->code, sizeof(pic_code) * cxt->ccapa); - } - cxt->code[cxt->clen].insn = insn; - cxt->code[cxt->clen].u.c = c; - cxt->clen++; -} - -static void -emit_r(codegen_state *state, enum pic_opcode insn, int d, int i) -{ - pic_state *pic = state->pic; - codegen_context *cxt = state->cxt; - - if (cxt->clen >= cxt->ccapa) { - cxt->ccapa *= 2; - cxt->code = pic_realloc(pic, cxt->code, sizeof(pic_code) * cxt->ccapa); - } - cxt->code[cxt->clen].insn = insn; - cxt->code[cxt->clen].u.r.depth = d; - cxt->code[cxt->clen].u.r.idx = i; - cxt->clen++; -} - -static void -create_activation(codegen_state *state) -{ - pic_state *pic = state->pic; - codegen_context *cxt = state->cxt; - size_t i, n; - xhash regs; - size_t offset; - - xh_init_ptr(®s, sizeof(size_t)); - - offset = 1; - for (i = 0; i < xv_size(cxt->args); ++i) { - n = i + offset; - xh_put_ptr(®s, xv_A(cxt->args, i), &n); - } - offset += i; - for (i = 0; i < xv_size(cxt->locals); ++i) { - n = i + offset; - xh_put_ptr(®s, xv_A(cxt->locals, i), &n); - } - - for (i = 0; i < xv_size(cxt->captures); ++i) { - n = xh_val(xh_get_ptr(®s, xv_A(cxt->captures, i)), size_t); - if (n <= xv_size(cxt->args) || (cxt->varg && n == xv_size(cxt->args) + 1)) { - /* copy arguments to capture variable area */ - emit_i(state, OP_LREF, (int)n); - } else { - /* otherwise, just extend the stack */ - emit_n(state, OP_PUSHUNDEF); - } - } - - xh_destroy(®s); -} - -static void -push_codegen_context(codegen_state *state, pic_value name, pic_value args, pic_value locals, bool varg, pic_value captures) -{ - pic_state *pic = state->pic; - codegen_context *cxt; - pic_value var, it; - - assert(pic_sym_p(name) || pic_false_p(name)); - - cxt = pic_malloc(pic, sizeof(codegen_context)); - cxt->up = state->cxt; - cxt->name = pic_false_p(name) - ? pic_intern_cstr(pic, "(anonymous lambda)") - : pic_sym_ptr(name); - cxt->varg = varg; - - xv_init(cxt->args); - xv_init(cxt->locals); - xv_init(cxt->captures); - - pic_for_each (var, args, it) { - xv_push_sym(cxt->args, pic_sym_ptr(var)); - } - pic_for_each (var, locals, it) { - xv_push_sym(cxt->locals, pic_sym_ptr(var)); - } - pic_for_each (var, captures, it) { - xv_push_sym(cxt->captures, pic_sym_ptr(var)); - } + cxt->args = args; + cxt->locals = locals; + cxt->captures = captures; cxt->code = pic_calloc(pic, PIC_ISEQ_SIZE, sizeof(pic_code)); cxt->clen = 0; @@ -1012,88 +907,149 @@ push_codegen_context(codegen_state *state, pic_value name, pic_value args, pic_v cxt->slen = 0; cxt->scapa = PIC_SYMS_SIZE; - state->cxt = cxt; - - create_activation(state); + create_activation(pic, cxt); } static struct pic_irep * -pop_codegen_context(codegen_state *state) +codegen_context_destroy(pic_state *pic, codegen_context *cxt) { - pic_state *pic = state->pic; - codegen_context *cxt = state->cxt; struct pic_irep *irep; /* create irep */ irep = (struct pic_irep *)pic_obj_alloc(pic, sizeof(struct pic_irep), PIC_TT_IREP); - irep->name = state->cxt->name; - irep->varg = state->cxt->varg; - irep->argc = (int)xv_size(state->cxt->args) + 1; - irep->localc = (int)xv_size(state->cxt->locals); - irep->capturec = (int)xv_size(state->cxt->captures); - irep->code = pic_realloc(pic, state->cxt->code, sizeof(pic_code) * state->cxt->clen); - irep->clen = state->cxt->clen; - irep->irep = pic_realloc(pic, state->cxt->irep, sizeof(struct pic_irep *) * state->cxt->ilen); - irep->ilen = state->cxt->ilen; - irep->pool = pic_realloc(pic, state->cxt->pool, sizeof(pic_value) * state->cxt->plen); - irep->plen = state->cxt->plen; - irep->syms = pic_realloc(pic, state->cxt->syms, sizeof(pic_sym *) * state->cxt->slen); - irep->slen = state->cxt->slen; - - /* finalize */ - xv_destroy(cxt->args); - xv_destroy(cxt->locals); - xv_destroy(cxt->captures); - - /* destroy context */ - cxt = cxt->up; - pic_free(pic, state->cxt); - state->cxt = cxt; + irep->varg = cxt->rest != NULL; + irep->argc = (int)cxt->args->len + 1; + irep->localc = (int)cxt->locals->len; + irep->capturec = (int)cxt->captures->len; + irep->code = pic_realloc(pic, cxt->code, sizeof(pic_code) * cxt->clen); + irep->clen = cxt->clen; + irep->irep = pic_realloc(pic, cxt->irep, sizeof(struct pic_irep *) * cxt->ilen); + irep->ilen = cxt->ilen; + irep->pool = pic_realloc(pic, cxt->pool, sizeof(pic_value) * cxt->plen); + irep->plen = cxt->plen; + irep->syms = pic_realloc(pic, cxt->syms, sizeof(pic_sym *) * cxt->slen); + irep->slen = cxt->slen; return irep; } -static int -index_capture(codegen_state *state, pic_sym *sym, int depth) +static void +emit_n(pic_state *pic, codegen_context *cxt, enum pic_opcode insn) +{ + if (cxt->clen >= cxt->ccapa) { + cxt->ccapa *= 2; + cxt->code = pic_realloc(pic, cxt->code, sizeof(pic_code) * cxt->ccapa); + } + cxt->code[cxt->clen].insn = insn; + cxt->clen++; +} + +static void +emit_i(pic_state *pic, codegen_context *cxt, enum pic_opcode insn, int i) +{ + if (cxt->clen >= cxt->ccapa) { + cxt->ccapa *= 2; + cxt->code = pic_realloc(pic, cxt->code, sizeof(pic_code) * cxt->ccapa); + } + cxt->code[cxt->clen].insn = insn; + cxt->code[cxt->clen].u.i = i; + cxt->clen++; +} + +static void +emit_c(pic_state *pic, codegen_context *cxt, enum pic_opcode insn, char c) +{ + if (cxt->clen >= cxt->ccapa) { + cxt->ccapa *= 2; + cxt->code = pic_realloc(pic, cxt->code, sizeof(pic_code) * cxt->ccapa); + } + cxt->code[cxt->clen].insn = insn; + cxt->code[cxt->clen].u.c = c; + cxt->clen++; +} + +static void +emit_r(pic_state *pic, codegen_context *cxt, enum pic_opcode insn, int d, int i) +{ + if (cxt->clen >= cxt->ccapa) { + cxt->ccapa *= 2; + cxt->code = pic_realloc(pic, cxt->code, sizeof(pic_code) * cxt->ccapa); + } + cxt->code[cxt->clen].insn = insn; + cxt->code[cxt->clen].u.r.depth = d; + cxt->code[cxt->clen].u.r.idx = i; + cxt->clen++; +} + +static void +create_activation(pic_state *pic, codegen_context *cxt) +{ + size_t i, n; + size_t offset; + struct pic_reg *regs; + + regs = pic_make_reg(pic); + + offset = 1; + for (i = 0; i < cxt->args->len; ++i) { + n = i + offset; + pic_reg_set(pic, regs, pic_sym_ptr(cxt->args->data[i]), pic_size_value(n)); + } + offset += i; + for (i = 0; i < cxt->locals->len; ++i) { + n = i + offset; + pic_reg_set(pic, regs, pic_sym_ptr(cxt->locals->data[i]), pic_size_value(n)); + } + + for (i = 0; i < cxt->captures->len; ++i) { + n = (size_t)pic_int(pic_reg_ref(pic, regs, pic_sym_ptr(cxt->captures->data[i]))); + if (n <= cxt->args->len || cxt->rest == pic_sym_ptr(cxt->captures->data[i])) { + /* copy arguments to capture variable area */ + emit_i(pic, cxt, OP_LREF, (int)n); + } else { + /* otherwise, just extend the stack */ + emit_n(pic, cxt, OP_PUSHUNDEF); + } + } +} + +static int +index_capture(codegen_context *cxt, pic_sym *sym, int depth) { - codegen_context *cxt = state->cxt; size_t i; while (depth-- > 0) { cxt = cxt->up; } - for (i = 0; i < xv_size(cxt->captures); ++i) { - if (xv_A(cxt->captures, i) == sym) + for (i = 0; i < cxt->captures->len; ++i) { + if (pic_sym_ptr(cxt->captures->data[i]) == sym) return (int)i; } return -1; } static int -index_local(codegen_state *state, pic_sym *sym) +index_local(codegen_context *cxt, pic_sym *sym) { - codegen_context *cxt = state->cxt; size_t i, offset; offset = 1; - for (i = 0; i < xv_size(cxt->args); ++i) { - if (xv_A(cxt->args, i) == sym) + for (i = 0; i < cxt->args->len; ++i) { + if (pic_sym_ptr(cxt->args->data[i]) == sym) return (int)(i + offset); } offset += i; - for (i = 0; i < xv_size(cxt->locals); ++i) { - if (xv_A(cxt->locals, i) == sym) + for (i = 0; i < cxt->locals->len; ++i) { + if (pic_sym_ptr(cxt->locals->data[i]) == sym) return (int)(i + offset); } return -1; } static int -index_symbol(codegen_state *state, pic_sym *sym) +index_symbol(pic_state *pic, codegen_context *cxt, pic_sym *sym) { - pic_state *pic = state->pic; - codegen_context *cxt = state->cxt; size_t i; for (i = 0; i < cxt->slen; ++i) { @@ -1109,18 +1065,16 @@ index_symbol(codegen_state *state, pic_sym *sym) return i; } -static struct pic_irep *codegen_lambda(codegen_state *, pic_value); +static struct pic_irep *codegen_lambda(pic_state *, codegen_context *, pic_value); static void -codegen(codegen_state *state, pic_value obj) +codegen(pic_state *pic, codegen_context *cxt, pic_value obj) { - pic_state *pic = state->pic; - codegen_context *cxt = state->cxt; pic_sym *sym; sym = pic_sym_ptr(pic_car(pic, obj)); if (sym == pic->sGREF) { - emit_i(state, OP_GREF, index_symbol(state, pic_sym_ptr(pic_list_ref(pic, obj, 1)))); + emit_i(pic, cxt, OP_GREF, index_symbol(pic, cxt, pic_sym_ptr(pic_list_ref(pic, obj, 1)))); return; } else if (sym == pic->sCREF) { pic_sym *name; @@ -1128,31 +1082,31 @@ codegen(codegen_state *state, pic_value obj) depth = pic_int(pic_list_ref(pic, obj, 1)); name = pic_sym_ptr(pic_list_ref(pic, obj, 2)); - emit_r(state, OP_CREF, depth, index_capture(state, name, depth)); + emit_r(pic, cxt, OP_CREF, depth, index_capture(cxt, name, depth)); return; } else if (sym == pic->sLREF) { pic_sym *name; int i; name = pic_sym_ptr(pic_list_ref(pic, obj, 1)); - if ((i = index_capture(state, name, 0)) != -1) { - emit_i(state, OP_LREF, i + (int)xv_size(cxt->args) + (int)xv_size(cxt->locals) + 1); + if ((i = index_capture(cxt, name, 0)) != -1) { + emit_i(pic, cxt, OP_LREF, i + (int)cxt->args->len + (int)cxt->locals->len + 1); return; } - emit_i(state, OP_LREF, index_local(state, name)); + emit_i(pic, cxt, OP_LREF, index_local(cxt, name)); return; } else if (sym == pic->sSETBANG) { pic_value var, val; pic_sym *type; val = pic_list_ref(pic, obj, 2); - codegen(state, val); + codegen(pic, cxt, val); var = pic_list_ref(pic, obj, 1); type = pic_sym_ptr(pic_list_ref(pic, var, 0)); if (type == pic->sGREF) { - emit_i(state, OP_GSET, index_symbol(state, pic_sym_ptr(pic_list_ref(pic, var, 1)))); - emit_n(state, OP_PUSHUNDEF); + emit_i(pic, cxt, OP_GSET, index_symbol(pic, cxt, pic_sym_ptr(pic_list_ref(pic, var, 1)))); + emit_n(pic, cxt, OP_PUSHUNDEF); return; } else if (type == pic->sCREF) { @@ -1161,8 +1115,8 @@ codegen(codegen_state *state, pic_value obj) depth = pic_int(pic_list_ref(pic, var, 1)); name = pic_sym_ptr(pic_list_ref(pic, var, 2)); - emit_r(state, OP_CSET, depth, index_capture(state, name, depth)); - emit_n(state, OP_PUSHUNDEF); + emit_r(pic, cxt, OP_CSET, depth, index_capture(cxt, name, depth)); + emit_n(pic, cxt, OP_PUSHUNDEF); return; } else if (type == pic->sLREF) { @@ -1170,13 +1124,13 @@ codegen(codegen_state *state, pic_value obj) int i; name = pic_sym_ptr(pic_list_ref(pic, var, 1)); - if ((i = index_capture(state, name, 0)) != -1) { - emit_i(state, OP_LSET, i + (int)xv_size(cxt->args) + (int)xv_size(cxt->locals) + 1); - emit_n(state, OP_PUSHUNDEF); + if ((i = index_capture(cxt, name, 0)) != -1) { + emit_i(pic, cxt, OP_LSET, i + (int)cxt->args->len + (int)cxt->locals->len + 1); + emit_n(pic, cxt, OP_PUSHUNDEF); return; } - emit_i(state, OP_LSET, index_local(state, name)); - emit_n(state, OP_PUSHUNDEF); + emit_i(pic, cxt, OP_LSET, index_local(cxt, name)); + emit_n(pic, cxt, OP_PUSHUNDEF); return; } } @@ -1188,31 +1142,31 @@ codegen(codegen_state *state, pic_value obj) cxt->irep = pic_realloc(pic, cxt->irep, sizeof(struct pic_irep *) * cxt->icapa); } k = (int)cxt->ilen++; - emit_i(state, OP_LAMBDA, k); + emit_i(pic, cxt, OP_LAMBDA, k); - cxt->irep[k] = codegen_lambda(state, obj); + cxt->irep[k] = codegen_lambda(pic, cxt, obj); return; } else if (sym == pic->sIF) { int s, t; - codegen(state, pic_list_ref(pic, obj, 1)); + codegen(pic, cxt, pic_list_ref(pic, obj, 1)); s = (int)cxt->clen; - emit_n(state, OP_JMPIF); + emit_n(pic, cxt, OP_JMPIF); /* if false branch */ - codegen(state, pic_list_ref(pic, obj, 3)); + codegen(pic, cxt, pic_list_ref(pic, obj, 3)); t = (int)cxt->clen; - emit_n(state, OP_JMP); + emit_n(pic, cxt, OP_JMP); cxt->code[s].u.i = (int)cxt->clen - s; /* if true branch */ - codegen(state, pic_list_ref(pic, obj, 2)); + codegen(pic, cxt, pic_list_ref(pic, obj, 2)); cxt->code[t].u.i = (int)cxt->clen - t; return; } @@ -1222,9 +1176,9 @@ codegen(codegen_state *state, pic_value obj) pic_for_each (elt, pic_cdr(pic, obj), it) { if (i++ != 0) { - emit_n(state, OP_POP); + emit_n(pic, cxt, OP_POP); } - codegen(state, elt); + codegen(pic, cxt, elt); } return; } @@ -1234,16 +1188,16 @@ codegen(codegen_state *state, pic_value obj) obj = pic_list_ref(pic, obj, 1); switch (pic_type(obj)) { case PIC_TT_BOOL: - emit_n(state, (pic_true_p(obj) ? OP_PUSHTRUE : OP_PUSHFALSE)); + emit_n(pic, cxt, (pic_true_p(obj) ? OP_PUSHTRUE : OP_PUSHFALSE)); return; case PIC_TT_INT: - emit_i(state, OP_PUSHINT, pic_int(obj)); + emit_i(pic, cxt, OP_PUSHINT, pic_int(obj)); return; case PIC_TT_NIL: - emit_n(state, OP_PUSHNIL); + emit_n(pic, cxt, OP_PUSHNIL); return; case PIC_TT_CHAR: - emit_c(state, OP_PUSHCHAR, pic_char(obj)); + emit_c(pic, cxt, OP_PUSHCHAR, pic_char(obj)); return; default: if (cxt->plen >= cxt->pcapa) { @@ -1252,103 +1206,103 @@ codegen(codegen_state *state, pic_value obj) } pidx = (int)cxt->plen++; cxt->pool[pidx] = obj; - emit_i(state, OP_PUSHCONST, pidx); + emit_i(pic, cxt, OP_PUSHCONST, pidx); return; } } else if (sym == pic->sCONS) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - emit_n(state, OP_CONS); + codegen(pic, cxt, pic_list_ref(pic, obj, 1)); + codegen(pic, cxt, pic_list_ref(pic, obj, 2)); + emit_n(pic, cxt, OP_CONS); return; } else if (sym == pic->sCAR) { - codegen(state, pic_list_ref(pic, obj, 1)); - emit_n(state, OP_CAR); + codegen(pic, cxt, pic_list_ref(pic, obj, 1)); + emit_n(pic, cxt, OP_CAR); return; } else if (sym == pic->sCDR) { - codegen(state, pic_list_ref(pic, obj, 1)); - emit_n(state, OP_CDR); + codegen(pic, cxt, pic_list_ref(pic, obj, 1)); + emit_n(pic, cxt, OP_CDR); return; } else if (sym == pic->sNILP) { - codegen(state, pic_list_ref(pic, obj, 1)); - emit_n(state, OP_NILP); + codegen(pic, cxt, pic_list_ref(pic, obj, 1)); + emit_n(pic, cxt, OP_NILP); return; } else if (sym == pic->sSYMBOLP) { - codegen(state, pic_list_ref(pic, obj, 1)); - emit_n(state, OP_SYMBOLP); + codegen(pic, cxt, pic_list_ref(pic, obj, 1)); + emit_n(pic, cxt, OP_SYMBOLP); return; } else if (sym == pic->sPAIRP) { - codegen(state, pic_list_ref(pic, obj, 1)); - emit_n(state, OP_PAIRP); + codegen(pic, cxt, pic_list_ref(pic, obj, 1)); + emit_n(pic, cxt, OP_PAIRP); return; } else if (sym == pic->sADD) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - emit_n(state, OP_ADD); + codegen(pic, cxt, pic_list_ref(pic, obj, 1)); + codegen(pic, cxt, pic_list_ref(pic, obj, 2)); + emit_n(pic, cxt, OP_ADD); return; } else if (sym == pic->sSUB) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - emit_n(state, OP_SUB); + codegen(pic, cxt, pic_list_ref(pic, obj, 1)); + codegen(pic, cxt, pic_list_ref(pic, obj, 2)); + emit_n(pic, cxt, OP_SUB); return; } else if (sym == pic->sMUL) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - emit_n(state, OP_MUL); + codegen(pic, cxt, pic_list_ref(pic, obj, 1)); + codegen(pic, cxt, pic_list_ref(pic, obj, 2)); + emit_n(pic, cxt, OP_MUL); return; } else if (sym == pic->sDIV) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - emit_n(state, OP_DIV); + codegen(pic, cxt, pic_list_ref(pic, obj, 1)); + codegen(pic, cxt, pic_list_ref(pic, obj, 2)); + emit_n(pic, cxt, OP_DIV); return; } else if (sym == pic->sMINUS) { - codegen(state, pic_list_ref(pic, obj, 1)); - emit_n(state, OP_MINUS); + codegen(pic, cxt, pic_list_ref(pic, obj, 1)); + emit_n(pic, cxt, OP_MINUS); return; } else if (sym == pic->sEQ) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - emit_n(state, OP_EQ); + codegen(pic, cxt, pic_list_ref(pic, obj, 1)); + codegen(pic, cxt, pic_list_ref(pic, obj, 2)); + emit_n(pic, cxt, OP_EQ); return; } else if (sym == pic->sLT) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - emit_n(state, OP_LT); + codegen(pic, cxt, pic_list_ref(pic, obj, 1)); + codegen(pic, cxt, pic_list_ref(pic, obj, 2)); + emit_n(pic, cxt, OP_LT); return; } else if (sym == pic->sLE) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - emit_n(state, OP_LE); + codegen(pic, cxt, pic_list_ref(pic, obj, 1)); + codegen(pic, cxt, pic_list_ref(pic, obj, 2)); + emit_n(pic, cxt, OP_LE); return; } else if (sym == pic->sGT) { - codegen(state, pic_list_ref(pic, obj, 2)); - codegen(state, pic_list_ref(pic, obj, 1)); - emit_n(state, OP_LT); + codegen(pic, cxt, pic_list_ref(pic, obj, 2)); + codegen(pic, cxt, pic_list_ref(pic, obj, 1)); + emit_n(pic, cxt, OP_LT); return; } else if (sym == pic->sGE) { - codegen(state, pic_list_ref(pic, obj, 2)); - codegen(state, pic_list_ref(pic, obj, 1)); - emit_n(state, OP_LE); + codegen(pic, cxt, pic_list_ref(pic, obj, 2)); + codegen(pic, cxt, pic_list_ref(pic, obj, 1)); + emit_n(pic, cxt, OP_LE); return; } else if (sym == pic->sNOT) { - codegen(state, pic_list_ref(pic, obj, 1)); - emit_n(state, OP_NOT); + codegen(pic, cxt, pic_list_ref(pic, obj, 1)); + emit_n(pic, cxt, OP_NOT); return; } else if (sym == pic->sCALL || sym == pic->sTAILCALL) { @@ -1356,19 +1310,19 @@ codegen(codegen_state *state, pic_value obj) pic_value elt, it; pic_for_each (elt, pic_cdr(pic, obj), it) { - codegen(state, elt); + codegen(pic, cxt, elt); } - emit_i(state, (sym == pic->sCALL ? OP_CALL : OP_TAILCALL), len - 1); + emit_i(pic, cxt, (sym == pic->sCALL ? OP_CALL : OP_TAILCALL), len - 1); return; } else if (sym == pic->sCALL_WITH_VALUES || sym == pic->sTAILCALL_WITH_VALUES) { /* stack consumer at first */ - codegen(state, pic_list_ref(pic, obj, 2)); - codegen(state, pic_list_ref(pic, obj, 1)); + codegen(pic, cxt, pic_list_ref(pic, obj, 2)); + codegen(pic, cxt, pic_list_ref(pic, obj, 1)); /* call producer */ - emit_i(state, OP_CALL, 1); + emit_i(pic, cxt, OP_CALL, 1); /* call consumer */ - emit_i(state, (sym == pic->sCALL_WITH_VALUES ? OP_CALL : OP_TAILCALL), -1); + emit_i(pic, cxt, (sym == pic->sCALL_WITH_VALUES ? OP_CALL : OP_TAILCALL), -1); return; } else if (sym == pic->sRETURN) { @@ -1376,51 +1330,55 @@ codegen(codegen_state *state, pic_value obj) pic_value elt, it; pic_for_each (elt, pic_cdr(pic, obj), it) { - codegen(state, elt); + codegen(pic, cxt, elt); } - emit_i(state, OP_RET, len - 1); + emit_i(pic, cxt, OP_RET, len - 1); return; } pic_errorf(pic, "codegen: unknown AST type ~s", obj); } static struct pic_irep * -codegen_lambda(codegen_state *state, pic_value obj) +codegen_lambda(pic_state *pic, codegen_context *up, pic_value obj) { - pic_state *pic = state->pic; - pic_value name, args, locals, closes, body; - bool varg; + codegen_context c, *cxt = &c; + pic_value rest_opt, body; + pic_sym *rest = NULL; + pic_vec *args, *locals, *captures; - name = pic_list_ref(pic, obj, 1); - args = pic_list_ref(pic, obj, 2); - locals = pic_list_ref(pic, obj, 3); - varg = pic_true_p(pic_list_ref(pic, obj, 4)); - closes = pic_list_ref(pic, obj, 5); - body = pic_list_ref(pic, obj, 6); + rest_opt = pic_list_ref(pic, obj, 1); + if (pic_sym_p(rest_opt)) { + rest = pic_sym_ptr(rest_opt); + } + args = pic_vec_ptr(pic_list_ref(pic, obj, 2)); + locals = pic_vec_ptr(pic_list_ref(pic, obj, 3)); + captures = pic_vec_ptr(pic_list_ref(pic, obj, 4)); + body = pic_list_ref(pic, obj, 5); /* inner environment */ - push_codegen_context(state, name, args, locals, varg, closes); + codegen_context_init(pic, cxt, up, rest, args, locals, captures); { /* body */ - codegen(state, body); + codegen(pic, cxt, body); } - return pop_codegen_context(state); + return codegen_context_destroy(pic, cxt); } struct pic_irep * pic_codegen(pic_state *pic, pic_value obj) { - codegen_state *state; + pic_vec *empty = pic_make_vec(pic, 0); + codegen_context c, *cxt = &c; - state = new_codegen_state(pic); + codegen_context_init(pic, cxt, NULL, NULL, empty, empty, empty); - codegen(state, obj); + codegen(pic, cxt, obj); - return destroy_codegen_state(state); + return codegen_context_destroy(pic, cxt); } struct pic_proc * -pic_compile(pic_state *pic, pic_value obj, struct pic_lib *lib) +pic_compile(pic_state *pic, pic_value obj, struct pic_env *env) { struct pic_irep *irep; size_t ai = pic_gc_arena_preserve(pic); @@ -1429,17 +1387,17 @@ pic_compile(pic_state *pic, pic_value obj, struct pic_lib *lib) fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); fprintf(stdout, "# input expression\n"); - pic_debug(pic, obj); + pic_write(pic, obj); fprintf(stdout, "\n"); fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); #endif - /* macroexpand */ - obj = pic_macroexpand(pic, obj, lib); + /* expand */ + obj = pic_expand(pic, obj, env); #if DEBUG - fprintf(stdout, "## macroexpand completed\n"); - pic_debug(pic, obj); + fprintf(stdout, "## expand completed\n"); + pic_write(pic, obj); fprintf(stdout, "\n"); fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); #endif @@ -1448,7 +1406,7 @@ pic_compile(pic_state *pic, pic_value obj, struct pic_lib *lib) obj = pic_analyze(pic, obj); #if DEBUG fprintf(stdout, "## analyzer completed\n"); - pic_debug(pic, obj); + pic_write(pic, obj); fprintf(stdout, "\n"); fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); #endif diff --git a/extlib/benz/cont.c b/extlib/benz/cont.c index 4b213f52..fe9947a3 100644 --- a/extlib/benz/cont.c +++ b/extlib/benz/cont.c @@ -31,7 +31,7 @@ pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, st } here = pic->cp; - pic->cp = pic_malloc(pic, sizeof(pic_checkpoint)); + 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; @@ -51,9 +51,6 @@ pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, st void pic_save_point(pic_state *pic, struct pic_cont *cont) { - cont->jmp.prev = pic->jmp; - pic->jmp = &cont->jmp; - /* save runtime context */ cont->cp = pic->cp; cont->sp_offset = pic->sp - pic->stbase; @@ -62,24 +59,16 @@ pic_save_point(pic_state *pic, struct pic_cont *cont) cont->arena_idx = pic->arena_idx; cont->ip = pic->ip; cont->ptable = pic->ptable; - + cont->prev = pic->cc; cont->results = pic_undef_value(); + cont->id = pic->ccnt++; + + pic->cc = cont; } void pic_load_point(pic_state *pic, struct pic_cont *cont) { - pic_jmpbuf *jmp; - - for (jmp = pic->jmp; jmp != NULL; jmp = jmp->prev) { - if (jmp == &cont->jmp) { - break; - } - } - if (jmp == NULL) { - pic_errorf(pic, "calling dead escape continuation"); - } - pic_wind(pic, pic->cp, cont->cp); /* load runtime context */ @@ -95,18 +84,32 @@ pic_load_point(pic_state *pic, struct pic_cont *cont) static pic_value cont_call(pic_state *pic) { + struct pic_proc *self = pic_get_proc(pic); size_t argc; pic_value *argv; - struct pic_data *e; + int id; + struct pic_cont *cc, *cont; pic_get_args(pic, "*", &argc, &argv); - e = pic_data_ptr(pic_proc_env_ref(pic, pic_get_proc(pic), "escape")); - ((struct pic_cont *)e->data)->results = pic_list_by_array(pic, argc, argv); + id = pic_int(pic_proc_env_ref(pic, self, "id")); - pic_load_point(pic, e->data); + /* check if continuation is alive */ + for (cc = pic->cc; cc != NULL; cc = cc->prev) { + if (cc->id == id) { + break; + } + } + if (cc == NULL) { + pic_errorf(pic, "calling dead escape continuation"); + } - PIC_LONGJMP(pic, ((struct pic_cont *)e->data)->jmp.buf, 1); + cont = pic_data_ptr(pic_proc_env_ref(pic, self, "escape"))->data; + cont->results = pic_list_by_array(pic, argc, argv); + + pic_load_point(pic, cont); + + PIC_LONGJMP(pic, cont->jmp, 1); PIC_UNREACHABLE(); } @@ -114,16 +117,17 @@ cont_call(pic_state *pic) struct pic_proc * pic_make_cont(pic_state *pic, struct pic_cont *cont) { - static const pic_data_type cont_type = { "cont", pic_free, NULL }; + 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, ""); + 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; } @@ -131,21 +135,21 @@ pic_make_cont(pic_state *pic, struct pic_cont *cont) pic_value pic_callcc(pic_state *pic, struct pic_proc *proc) { - struct pic_cont *cont = pic_malloc(pic, sizeof(struct pic_cont)); + struct pic_cont cont; - pic_save_point(pic, cont); + pic_save_point(pic, &cont); - if (PIC_SETJMP(pic, cont->jmp.buf)) { - pic->jmp = pic->jmp->prev; + if (PIC_SETJMP(pic, cont.jmp)) { + pic->cc = pic->cc->prev; - return pic_values_by_list(pic, cont->results); + return pic_values_by_list(pic, cont.results); } else { pic_value val; - val = pic_apply1(pic, proc, pic_obj_value(pic_make_cont(pic, cont))); + val = pic_apply1(pic, proc, pic_obj_value(pic_make_cont(pic, &cont))); - pic->jmp = pic->jmp->prev; + pic->cc = pic->cc->prev; return val; } @@ -288,6 +292,6 @@ pic_init_cont(pic_state *pic) pic_defun(pic, "call/cc", pic_cont_callcc); pic_defun(pic, "dynamic-wind", pic_cont_dynamic_wind); - pic_defun_vm(pic, "values", pic->rVALUES, pic_cont_values); - pic_defun_vm(pic, "call-with-values", pic->rCALL_WITH_VALUES, pic_cont_call_with_values); + pic_defun_vm(pic, "values", pic->uVALUES, pic_cont_values); + pic_defun_vm(pic, "call-with-values", pic->uCALL_WITH_VALUES, pic_cont_call_with_values); } diff --git a/extlib/benz/data.c b/extlib/benz/data.c index 00042286..c61989df 100644 --- a/extlib/benz/data.c +++ b/extlib/benz/data.c @@ -4,11 +4,12 @@ struct pic_data * pic_data_alloc(pic_state *pic, const pic_data_type *type, void *userdata) { struct pic_data *data; + struct pic_dict *storage = pic_make_dict(pic); data = (struct pic_data *)pic_obj_alloc(pic, sizeof(struct pic_data), PIC_TT_DATA); data->type = type; data->data = userdata; - xh_init_str(&data->storage, sizeof(pic_value)); + data->storage = storage; return data; } diff --git a/extlib/benz/debug.c b/extlib/benz/debug.c index d61e9380..040b12a8 100644 --- a/extlib/benz/debug.c +++ b/extlib/benz/debug.c @@ -17,7 +17,7 @@ pic_get_backtrace(pic_state *pic) struct pic_proc *proc = pic_proc_ptr(ci->fp[0]); trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " at ")); - trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, pic_symbol_name(pic, pic_proc_name(proc)))); + trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, "(anonymous lambda)")); if (pic_proc_func_p(proc)) { trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " (native function)\n")); @@ -38,22 +38,26 @@ pic_print_backtrace(pic_state *pic, xFILE *file) assert(! pic_invalid_p(pic->err)); if (! pic_error_p(pic->err)) { - xfprintf(file, "raise: "); + xfprintf(pic, file, "raise: "); pic_fwrite(pic, pic->err, file); } else { struct pic_error *e; + pic_value elem, it; e = pic_error_ptr(pic->err); if (e->type != pic_intern_cstr(pic, "")) { pic_fwrite(pic, pic_obj_value(e->type), file); - xfprintf(file, " "); + xfprintf(pic, file, " "); } - xfprintf(file, "error: "); + xfprintf(pic, file, "error: "); pic_fwrite(pic, pic_obj_value(e->msg), file); - xfprintf(file, "\n"); - /* TODO: print error irritants */ + pic_for_each (elem, e->irrs, it) { /* print error irritants */ + xfprintf(pic, file, " "); + pic_fwrite(pic, elem, file); + } + xfprintf(pic, file, "\n"); - xfputs(pic_str_cstr(pic, e->stack), file); + xfputs(pic, pic_str_cstr(pic, e->stack), file); } } diff --git a/extlib/benz/dict.c b/extlib/benz/dict.c index ca5d042d..0c333811 100644 --- a/extlib/benz/dict.c +++ b/extlib/benz/dict.c @@ -4,13 +4,15 @@ #include "picrin.h" +KHASH_DEFINE(dict, pic_sym *, pic_value, kh_ptr_hash_func, kh_ptr_hash_equal) + struct pic_dict * pic_make_dict(pic_state *pic) { struct pic_dict *dict; dict = (struct pic_dict *)pic_obj_alloc(pic, sizeof(struct pic_dict), PIC_TT_DICT); - xh_init_ptr(&dict->hash, sizeof(pic_value)); + kh_init(dict, &dict->hash); return dict; } @@ -18,41 +20,50 @@ pic_make_dict(pic_state *pic) pic_value pic_dict_ref(pic_state *pic, struct pic_dict *dict, pic_sym *key) { - xh_entry *e; + khash_t(dict) *h = &dict->hash; + khiter_t it; - e = xh_get_ptr(&dict->hash, key); - if (! e) { + it = kh_get(dict, h, key); + if (it == kh_end(h)) { pic_errorf(pic, "element not found for a key: ~s", pic_obj_value(key)); } - return xh_val(e, pic_value); + return kh_val(h, it); } void pic_dict_set(pic_state PIC_UNUSED(*pic), struct pic_dict *dict, pic_sym *key, pic_value val) { - xh_put_ptr(&dict->hash, key, &val); + khash_t(dict) *h = &dict->hash; + int ret; + khiter_t it; + + it = kh_put(dict, h, key, &ret); + kh_val(h, it) = val; } size_t pic_dict_size(pic_state PIC_UNUSED(*pic), struct pic_dict *dict) { - return dict->hash.count; + return kh_size(&dict->hash); } bool pic_dict_has(pic_state PIC_UNUSED(*pic), struct pic_dict *dict, pic_sym *key) { - return xh_get_ptr(&dict->hash, key) != NULL; + return kh_get(dict, &dict->hash, key) != kh_end(&dict->hash); } void pic_dict_del(pic_state *pic, struct pic_dict *dict, pic_sym *key) { - if (xh_get_ptr(&dict->hash, key) == NULL) { + khash_t(dict) *h = &dict->hash; + khiter_t it; + + it = kh_get(dict, h, key); + if (it == kh_end(h)) { pic_errorf(pic, "no slot named ~s found in dictionary", pic_obj_value(key)); } - - xh_del_ptr(&dict->hash, key); + kh_del(dict, h, it); } static pic_value @@ -146,43 +157,41 @@ pic_dict_dictionary_map(pic_state *pic) struct pic_proc *proc; size_t argc, i; pic_value *args; - pic_value arg, ret; - xh_entry **it; + pic_value arg_list, ret = pic_nil_value(); pic_get_args(pic, "l*", &proc, &argc, &args); - it = pic_malloc(pic, argc * sizeof(xh_entry)); - for (i = 0; i < argc; ++i) { - if (! pic_dict_p(args[i])) { - pic_free(pic, it); - pic_errorf(pic, "expected dict, but got %s", pic_type_repr(pic_type(args[i]))); - } - it[i] = xh_begin(&pic_dict_ptr(args[i])->hash); - } + if (argc != 0) { + khiter_t it[argc]; + khash_t(dict) *kh[argc]; + + for (i = 0; i < argc; ++i) { + if (! pic_dict_p(args[i])) { + pic_errorf(pic, "expected dict, but got %s", pic_type_repr(pic_type(args[i]))); + } + kh[i] = &pic_dict_ptr(args[i])->hash; + it[i] = kh_begin(kh[i]); + } - pic_try { - ret = pic_nil_value(); do { - arg = pic_nil_value(); + arg_list = pic_nil_value(); for (i = 0; i < argc; ++i) { - if (it[i] == NULL) { + while (it[i] != kh_end(kh[i])) { /* find next available */ + if (kh_exist(kh[i], it[i])) + break; + it[i]++; + } + if (it[i] == kh_end(kh[i])) { break; } - pic_push(pic, pic_obj_value(xh_key(it[i], pic_sym *)), arg); - it[i] = xh_next(it[i]); + pic_push(pic, pic_obj_value(kh_key(kh[i], it[i]++)), arg_list); } if (i != argc) { break; } - pic_push(pic, pic_apply(pic, proc, pic_reverse(pic, arg)), ret); + pic_push(pic, pic_apply(pic, proc, pic_reverse(pic, arg_list)), ret); } while (1); } - pic_catch { - pic_free(pic, it); - pic_raise(pic, pic->err); - } - - pic_free(pic, it); return pic_reverse(pic, ret); } @@ -193,42 +202,41 @@ pic_dict_dictionary_for_each(pic_state *pic) struct pic_proc *proc; size_t argc, i; pic_value *args; - pic_value arg; - xh_entry **it; + pic_value arg_list; pic_get_args(pic, "l*", &proc, &argc, &args); - it = pic_malloc(pic, argc * sizeof(xh_entry)); - for (i = 0; i < argc; ++i) { - if (! pic_dict_p(args[i])) { - pic_free(pic, it); - pic_errorf(pic, "expected dict, but got %s", pic_type_repr(pic_type(args[i]))); - } - it[i] = xh_begin(&pic_dict_ptr(args[i])->hash); - } + if (argc != 0) { + khiter_t it[argc]; + khash_t(dict) *kh[argc]; + + for (i = 0; i < argc; ++i) { + if (! pic_dict_p(args[i])) { + pic_errorf(pic, "expected dict, but got %s", pic_type_repr(pic_type(args[i]))); + } + kh[i] = &pic_dict_ptr(args[i])->hash; + it[i] = kh_begin(kh[i]); + } - pic_try { do { - arg = pic_nil_value(); + arg_list = pic_nil_value(); for (i = 0; i < argc; ++i) { - if (it[i] == NULL) { + while (it[i] != kh_end(kh[i])) { /* find next available */ + if (kh_exist(kh[i], it[i])) + break; + it[i]++; + } + if (it[i] == kh_end(kh[i])) { break; } - pic_push(pic, pic_obj_value(xh_key(it[i], pic_sym *)), arg); - it[i] = xh_next(it[i]); + pic_push(pic, pic_obj_value(kh_key(kh[i], it[i]++)), arg_list); } if (i != argc) { break; } - pic_void(pic_apply(pic, proc, pic_reverse(pic, arg))); + pic_void(pic_apply(pic, proc, pic_reverse(pic, arg_list))); } while (1); } - pic_catch { - pic_free(pic, it); - pic_raise(pic, pic->err); - } - - pic_free(pic, it); return pic_undef_value(); } @@ -238,16 +246,17 @@ pic_dict_dictionary_to_alist(pic_state *pic) { struct pic_dict *dict; pic_value item, alist = pic_nil_value(); - xh_entry *it; + pic_sym *sym; + khiter_t it; pic_get_args(pic, "d", &dict); - for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) { - item = pic_cons(pic, pic_obj_value(xh_key(it, pic_sym *)), xh_val(it, pic_value)); + 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); } - return pic_reverse(pic, alist); + return alist; } static pic_value @@ -273,16 +282,17 @@ pic_dict_dictionary_to_plist(pic_state *pic) { struct pic_dict *dict; pic_value plist = pic_nil_value(); - xh_entry *it; + pic_sym *sym; + khiter_t it; pic_get_args(pic, "d", &dict); - for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) { - pic_push(pic, pic_obj_value(xh_key(it, pic_sym *)), plist); - pic_push(pic, xh_val(it, pic_value), plist); + 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); } - return pic_reverse(pic, plist); + return plist; } static pic_value diff --git a/extlib/benz/error.c b/extlib/benz/error.c index 6fa5309d..1386ab63 100644 --- a/extlib/benz/error.c +++ b/extlib/benz/error.c @@ -27,7 +27,7 @@ pic_warnf(pic_state *pic, const char *fmt, ...) err_line = pic_xvformat(pic, fmt, ap); va_end(ap); - xfprintf(pic_stderr(pic)->file, "warn: %s\n", pic_str_cstr(pic, pic_str_ptr(pic_car(pic, err_line)))); + xfprintf(pic, pic_stderr(pic)->file, "warn: %s\n", pic_str_cstr(pic, pic_str_ptr(pic_car(pic, err_line)))); } void diff --git a/extlib/benz/eval.c b/extlib/benz/eval.c index 1006df50..c81da246 100644 --- a/extlib/benz/eval.c +++ b/extlib/benz/eval.c @@ -5,28 +5,25 @@ #include "picrin.h" pic_value -pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib) +pic_eval(pic_state *pic, pic_value program, struct pic_env *env) { struct pic_proc *proc; - proc = pic_compile(pic, program, lib); + proc = pic_compile(pic, program, env); - return pic_apply(pic, proc, pic_nil_value()); + return pic_apply0(pic, proc); } static pic_value pic_eval_eval(pic_state *pic) { - pic_value program, spec; - struct pic_lib *lib; + pic_value program, env; - pic_get_args(pic, "oo", &program, &spec); + pic_get_args(pic, "oo", &program, &env); - lib = pic_find_library(pic, spec); - if (lib == NULL) { - pic_errorf(pic, "no library found: ~s", spec); - } - return pic_eval(pic, program, lib); + pic_assert_type(pic, env, env); + + return pic_eval(pic, program, pic_env_ptr(env)); } void diff --git a/extlib/benz/xfile.c b/extlib/benz/file.c similarity index 55% rename from extlib/benz/xfile.c rename to extlib/benz/file.c index b28bf060..640a6edb 100644 --- a/extlib/benz/xfile.c +++ b/extlib/benz/file.c @@ -1,83 +1,13 @@ #include "picrin.h" -static int file_read(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(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(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; - } - return fseek(cookie, pos, whence); -} - -static int file_close(void *cookie) { - return fclose(cookie); -} - -xFILE *xfopen(const char *name, const char *mode) { - FILE *fp; - - if ((fp = fopen(name, mode)) == NULL) { - return NULL; - } - - switch (*mode) { - case 'r': - return xfunopen(fp, file_read, NULL, file_seek, file_close); - default: - return xfunopen(fp, NULL, file_write, file_seek, file_close); - } -} - -#define FILE_VTABLE { 0, file_read, file_write, file_seek, file_close } - -xFILE x_iob[XOPEN_MAX] = { - { { 0 }, 0, NULL, NULL, FILE_VTABLE, X_READ }, - { { 0 }, 0, NULL, NULL, FILE_VTABLE, X_WRITE | X_LNBUF }, - { { 0 }, 0, NULL, NULL, FILE_VTABLE, X_WRITE | X_UNBUF } -}; - -xFILE *xfunopen(void *cookie, int (*read)(void *, char *, int), int (*write)(void *, const char *, int), long (*seek)(void *, long, int), int (*close)(void *)) { +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; - for (fp = x_iob; fp < x_iob + XOPEN_MAX; fp++) + for (fp = pic->files; fp < pic->files + XOPEN_MAX; fp++) if ((fp->flag & (X_READ | X_WRITE)) == 0) break; /* found free slot */ - if (fp >= x_iob + XOPEN_MAX) /* no free slots */ + if (fp >= pic->files + XOPEN_MAX) /* no free slots */ return NULL; fp->cnt = 0; @@ -93,18 +23,15 @@ xFILE *xfunopen(void *cookie, int (*read)(void *, char *, int), int (*write)(voi return fp; } -int xfclose(xFILE *fp) { - extern void free(void *); /* FIXME */ - - xfflush(fp); +int xfclose(pic_state *pic, xFILE *fp) { + xfflush(pic, fp); fp->flag = 0; if (fp->base != fp->buf) - free(fp->base); - return fp->vtable.close(fp->vtable.cookie); + pic_free(pic, fp->base); + return fp->vtable.close(pic, fp->vtable.cookie); } -int x_fillbuf(xFILE *fp) { - extern void *malloc(size_t); /* FIXME */ +int x_fillbuf(pic_state *pic, xFILE *fp) { int bufsize; if ((fp->flag & (X_READ|X_EOF|X_ERR)) != X_READ) @@ -112,7 +39,7 @@ int x_fillbuf(xFILE *fp) { if (fp->base == NULL) { if ((fp->flag & X_UNBUF) == 0) { /* no buffer yet */ - if ((fp->base = malloc(XBUFSIZ)) == NULL) { + if ((fp->base = pic_malloc(pic, XBUFSIZ)) == NULL) { /* can't get buffer, try unbuffered */ fp->flag |= X_UNBUF; } @@ -124,7 +51,7 @@ int x_fillbuf(xFILE *fp) { bufsize = (fp->flag & X_UNBUF) ? sizeof(fp->buf) : XBUFSIZ; fp->ptr = fp->base; - fp->cnt = fp->vtable.read(fp->vtable.cookie, fp->ptr, bufsize); + fp->cnt = fp->vtable.read(pic, fp->vtable.cookie, fp->ptr, bufsize); if (--fp->cnt < 0) { if (fp->cnt == -1) @@ -138,8 +65,7 @@ int x_fillbuf(xFILE *fp) { return (unsigned char) *fp->ptr++; } -int x_flushbuf(int x, xFILE *fp) { - extern void *malloc(size_t); /* FIXME */ +int x_flushbuf(pic_state *pic, int x, xFILE *fp) { int num_written=0, bufsize=0; char c = x; @@ -147,7 +73,7 @@ int x_flushbuf(int x, xFILE *fp) { return EOF; if (fp->base == NULL && ((fp->flag & X_UNBUF) == 0)) { /* no buffer yet */ - if ((fp->base = malloc(XBUFSIZ)) == NULL) { + if ((fp->base = pic_malloc(pic, XBUFSIZ)) == NULL) { /* couldn't allocate a buffer, so try unbuffered */ fp->flag |= X_UNBUF; } else { @@ -161,7 +87,7 @@ int x_flushbuf(int x, xFILE *fp) { fp->cnt = 0; if (x == EOF) return EOF; - num_written = fp->vtable.write(fp->vtable.cookie, (const char *) &c, 1); + num_written = fp->vtable.write(pic, fp->vtable.cookie, (const char *) &c, 1); bufsize = 1; } else { /* buffered write */ @@ -172,14 +98,14 @@ int x_flushbuf(int x, xFILE *fp) { bufsize = (int)(fp->ptr - fp->base); while(bufsize - num_written > 0) { int t; - t = fp->vtable.write(fp->vtable.cookie, fp->base + num_written, bufsize - num_written); + t = fp->vtable.write(pic, fp->vtable.cookie, fp->base + num_written, bufsize - num_written); if (t < 0) break; num_written += t; } fp->ptr = fp->base; - fp->cnt = BUFSIZ - 1; + fp->cnt = XBUFSIZ - 1; } if (num_written == bufsize) { @@ -190,7 +116,7 @@ int x_flushbuf(int x, xFILE *fp) { } } -int xfflush(xFILE *f) { +int xfflush(pic_state *pic, xFILE *f) { int retval; int i; @@ -198,48 +124,48 @@ int xfflush(xFILE *f) { if (f == NULL) { /* flush all output streams */ for (i = 0; i < XOPEN_MAX; i++) { - if ((x_iob[i].flag & X_WRITE) && (xfflush(&x_iob[i]) == -1)) + if ((pic->files[i].flag & X_WRITE) && (xfflush(pic, &pic->files[i]) == -1)) retval = -1; } } else { if ((f->flag & X_WRITE) == 0) return -1; - x_flushbuf(EOF, f); + x_flushbuf(pic, EOF, f); if (f->flag & X_ERR) retval = -1; } return retval; } -int xfputc(int x, xFILE *fp) { - return xputc(x, fp); +int xfputc(pic_state *pic, int x, xFILE *fp) { + return xputc(pic, x, fp); } -int xfgetc(xFILE *fp) { - return xgetc(fp); +int xfgetc(pic_state *pic, xFILE *fp) { + return xgetc(pic, fp); } -int xfputs(const char *s, xFILE *stream) { +int xfputs(pic_state *pic, const char *s, xFILE *stream) { const char *ptr = s; while(*ptr != '\0') { - if (xputc(*ptr, stream) == EOF) + if (xputc(pic, *ptr, stream) == EOF) return EOF; ++ptr; } return (int)(ptr - s); } -char *xfgets(char *s, int size, xFILE *stream) { +char *xfgets(pic_state *pic, char *s, int size, xFILE *stream) { int c; char *buf; - xfflush(NULL); + xfflush(pic, NULL); if (size == 0) { return NULL; } buf = s; - while (--size > 0 && (c = xgetc(stream)) != EOF) { + while (--size > 0 && (c = xgetc(pic, stream)) != EOF) { if ((*buf++ = c) == '\n') break; } @@ -248,28 +174,28 @@ char *xfgets(char *s, int size, xFILE *stream) { return (c == EOF && buf == s) ? NULL : s; } -int xputs(const char *s) { +int xputs(pic_state *pic, const char *s) { int i = 1; while(*s != '\0') { - if (xputchar(*s++) == EOF) + if (xputchar(pic, *s++) == EOF) return EOF; i++; } - if (xputchar('\n') == EOF) { + if (xputchar(pic, '\n') == EOF) { return EOF; } return i; } -char *xgets(char *s) { +char *xgets(pic_state *pic, char *s) { int c; char *buf; - xfflush(NULL); + xfflush(pic, NULL); buf = s; - while ((c = xgetchar()) != EOF && c != '\n') { + while ((c = xgetchar(pic)) != EOF && c != '\n') { *buf++ = c; } *buf = '\0'; @@ -287,7 +213,7 @@ int xungetc(int c, xFILE *fp) { return *--fp->ptr = uc; } -size_t xfread(void *ptr, size_t size, size_t count, xFILE *fp) { +size_t xfread(pic_state *pic, void *ptr, size_t size, size_t count, xFILE *fp) { char *bptr = ptr; long nbytes; int c; @@ -298,7 +224,7 @@ size_t xfread(void *ptr, size_t size, size_t count, xFILE *fp) { fp->ptr += fp->cnt; bptr += fp->cnt; nbytes -= fp->cnt; - if ((c = x_fillbuf(fp)) == EOF) { + if ((c = x_fillbuf(pic, fp)) == EOF) { return (size * count - nbytes) / size; } else { xungetc(c, fp); @@ -310,7 +236,7 @@ size_t xfread(void *ptr, size_t size, size_t count, xFILE *fp) { return count; } -size_t xfwrite(const void *ptr, size_t size, size_t count, xFILE *fp) { +size_t xfwrite(pic_state *pic, const void *ptr, size_t size, size_t count, xFILE *fp) { const char *bptr = ptr; long nbytes; @@ -320,7 +246,7 @@ size_t xfwrite(const void *ptr, size_t size, size_t count, xFILE *fp) { fp->ptr += fp->cnt; bptr += fp->cnt; nbytes -= fp->cnt; - if (x_flushbuf(EOF, fp) == EOF) { + if (x_flushbuf(pic, EOF, fp) == EOF) { return (size * count - nbytes) / size; } } @@ -330,50 +256,50 @@ size_t xfwrite(const void *ptr, size_t size, size_t count, xFILE *fp) { return count; } -long xfseek(xFILE *fp, long offset, int whence) { +long xfseek(pic_state *pic, xFILE *fp, long offset, int whence) { long s; - xfflush(fp); + xfflush(pic, fp); fp->ptr = fp->base; fp->cnt = 0; - if ((s = fp->vtable.seek(fp->vtable.cookie, offset, whence)) != 0) + if ((s = fp->vtable.seek(pic, fp->vtable.cookie, offset, whence)) != 0) return s; fp->flag &= ~X_EOF; return 0; } -long xftell(xFILE *fp) { - return xfseek(fp, 0, XSEEK_CUR); +long xftell(pic_state *pic, xFILE *fp) { + return xfseek(pic, fp, 0, XSEEK_CUR); } -void xrewind(xFILE *fp) { - xfseek(fp, 0, XSEEK_SET); +void xrewind(pic_state *pic, xFILE *fp) { + xfseek(pic, fp, 0, XSEEK_SET); xclearerr(fp); } -int xprintf(const char *fmt, ...) { +int xprintf(pic_state *pic, const char *fmt, ...) { va_list ap; int n; va_start(ap, fmt); - n = xvfprintf(xstdout, fmt, ap); + n = xvfprintf(pic, xstdout, fmt, ap); va_end(ap); return n; } -int xfprintf(xFILE *stream, const char *fmt, ...) { +int xfprintf(pic_state *pic, xFILE *stream, const char *fmt, ...) { va_list ap; int n; va_start(ap, fmt); - n = xvfprintf(stream, fmt, ap); + n = xvfprintf(pic, stream, fmt, ap); va_end(ap); return n; } -static int print_int(xFILE *stream, long x, int base) { +static int print_int(pic_state *pic, xFILE *stream, long x, int base) { static const char digits[] = "0123456789abcdef"; char buf[20]; int i, c, neg; @@ -395,12 +321,12 @@ static int print_int(xFILE *stream, long x, int base) { c = i; while (i-- > 0) { - xputc(buf[i], stream); + xputc(pic, buf[i], stream); } return c; } -int xvfprintf(xFILE *stream, const char *fmt, va_list ap) { +int xvfprintf(pic_state *pic, xFILE *stream, const char *fmt, va_list ap) { const char *p; char *sval; int ival; @@ -412,7 +338,7 @@ int xvfprintf(xFILE *stream, const char *fmt, va_list ap) { for (p = fmt; *p; p++) { if (*p != '%') { - xputc(*p, stream); + xputc(pic, *p, stream); cnt++; continue; } @@ -420,42 +346,42 @@ int xvfprintf(xFILE *stream, const char *fmt, va_list ap) { case 'd': case 'i': ival = va_arg(ap, int); - cnt += print_int(stream, ival, 10); + cnt += print_int(pic, stream, ival, 10); break; #if PIC_ENABLE_FLOAT case 'f': dval = va_arg(ap, double); - cnt += print_int(stream, dval, 10); - xputc('.', stream); + cnt += print_int(pic, stream, dval, 10); + xputc(pic, '.', stream); cnt++; if ((ival = fabs((dval - floor(dval)) * 1e4) + 0.5) == 0) { - cnt += xfputs("0000", stream); + cnt += xfputs(pic, "0000", stream); } else { int i; for (i = 0; i < 3 - (int)log10(ival); ++i) { - xputc('0', stream); + xputc(pic, '0', stream); cnt++; } - cnt += print_int(stream, ival, 10); + cnt += print_int(pic, stream, ival, 10); } break; #endif case 's': sval = va_arg(ap, char*); - cnt += xfputs(sval, stream); + cnt += xfputs(pic, sval, stream); break; case 'p': vp = va_arg(ap, void*); - cnt += xfputs("0x", stream); - cnt += print_int(stream, (long)vp, 16); + cnt += xfputs(pic, "0x", stream); + cnt += print_int(pic, stream, (long)vp, 16); break; case '%': - xputc(*(p-1), stream); + xputc(pic, *(p-1), stream); cnt++; break; default: - xputc('%', stream); - xputc(*(p-1), stream); + xputc(pic, '%', stream); + xputc(pic, *(p-1), stream); cnt += 2; break; } diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index 93650e52..b441d786 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -329,20 +329,6 @@ gc_unmark(union header *p) p->s.mark = PIC_GC_UNMARK; } -static void -gc_mark_checkpoint(pic_state *pic, pic_checkpoint *cp) -{ - if (cp->prev) { - gc_mark_object(pic, (struct pic_object *)cp->prev); - } - if (cp->in) { - gc_mark_object(pic, (struct pic_object *)cp->in); - } - if (cp->out) { - gc_mark_object(pic, (struct pic_object *)cp->out); - } -} - static void gc_mark_object(pic_state *pic, struct pic_object *obj) { @@ -380,7 +366,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) gc_mark_object(pic, (struct pic_object *)proc->u.i.cxt); } } else { - gc_mark_object(pic, (struct pic_object *)proc->u.f.name); if (proc->u.f.env) { gc_mark_object(pic, (struct pic_object *)proc->u.f.env); } @@ -411,14 +396,26 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) case PIC_TT_BLOB: { break; } + case PIC_TT_ID: { + struct pic_id *id = (struct pic_id *)obj; + gc_mark(pic, id->var); + gc_mark_object(pic, (struct pic_object *)id->env); + break; + } case PIC_TT_ENV: { struct pic_env *env = (struct pic_env *)obj; + khash_t(env) *h = &env->map; + khiter_t it; if (env->up) { gc_mark_object(pic, (struct pic_object *)env->up); } - gc_mark(pic, env->defer); - gc_mark_object(pic, (struct pic_object *)env->map); + for (it = kh_begin(h); it != kh_end(h); ++it) { + if (kh_exist(h, it)) { + gc_mark_object(pic, kh_key(h, it)); + gc_mark_object(pic, (struct pic_object *)kh_val(h, it)); + } + } break; } case PIC_TT_LIB: { @@ -432,8 +429,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) struct pic_irep *irep = (struct pic_irep *)obj; size_t i; - gc_mark_object(pic, (struct pic_object *)irep->name); - for (i = 0; i < irep->ilen; ++i) { gc_mark_object(pic, (struct pic_object *)irep->irep[i]); } @@ -447,11 +442,8 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) } case PIC_TT_DATA: { struct pic_data *data = (struct pic_data *)obj; - xh_entry *it; - for (it = xh_begin(&data->storage); it != NULL; it = xh_next(it)) { - gc_mark(pic, xh_val(it, pic_value)); - } + gc_mark_object(pic, (struct pic_object *)data->storage); if (data->type->mark) { data->type->mark(pic, data->data, gc_mark); } @@ -459,11 +451,12 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) } case PIC_TT_DICT: { struct pic_dict *dict = (struct pic_dict *)obj; - xh_entry *it; + pic_sym *sym; + khiter_t it; - for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) { - gc_mark_object(pic, (struct pic_object *)xh_key(it, pic_sym *)); - gc_mark(pic, xh_val(it, pic_value)); + pic_dict_for_each (sym, dict, it) { + gc_mark_object(pic, (struct pic_object *)sym); + gc_mark(pic, pic_dict_ref(pic, dict, sym)); } break; } @@ -474,9 +467,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) break; } case PIC_TT_SYMBOL: { - struct pic_symbol *sym = (struct pic_symbol *)obj; - - gc_mark_object(pic, (struct pic_object *)sym->str); break; } case PIC_TT_REG: { @@ -486,6 +476,20 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) pic->regs = reg; break; } + case PIC_TT_CP: { + struct pic_checkpoint *cp = (struct pic_checkpoint *)obj; + + if (cp->prev) { + gc_mark_object(pic, (struct pic_object *)cp->prev); + } + if (cp->in) { + gc_mark_object(pic, (struct pic_object *)cp->in); + } + if (cp->out) { + gc_mark_object(pic, (struct pic_object *)cp->out); + } + break; + } case PIC_TT_NIL: case PIC_TT_BOOL: #if PIC_ENABLE_FLOAT @@ -519,7 +523,9 @@ gc_mark_global_symbols(pic_state *pic) { M(sDEFINE); M(sLAMBDA); M(sIF); M(sBEGIN); M(sQUOTE); M(sSETBANG); M(sQUASIQUOTE); M(sUNQUOTE); M(sUNQUOTE_SPLICING); - M(sDEFINE_SYNTAX); M(sIMPORT); M(sEXPORT); + M(sSYNTAX_QUOTE); M(sSYNTAX_QUASIQUOTE); M(sSYNTAX_UNQUOTE); + M(sSYNTAX_UNQUOTE_SPLICING); + M(sDEFINE_MACRO); M(sIMPORT); M(sEXPORT); M(sDEFINE_LIBRARY); M(sCOND_EXPAND); M(sAND); M(sOR); M(sELSE); M(sLIBRARY); M(sONLY); M(sRENAME); M(sPREFIX); M(sEXCEPT); @@ -531,15 +537,15 @@ gc_mark_global_symbols(pic_state *pic) M(sCALL); M(sTAILCALL); M(sCALL_WITH_VALUES); M(sTAILCALL_WITH_VALUES); M(sGREF); M(sLREF); M(sCREF); M(sRETURN); - M(rDEFINE); M(rLAMBDA); M(rIF); M(rBEGIN); M(rQUOTE); M(rSETBANG); - M(rDEFINE_SYNTAX); M(rIMPORT); M(rEXPORT); - M(rDEFINE_LIBRARY); - M(rCOND_EXPAND); - M(rCONS); M(rCAR); M(rCDR); M(rNILP); - M(rSYMBOLP); M(rPAIRP); - M(rADD); M(rSUB); M(rMUL); M(rDIV); - M(rEQ); M(rLT); M(rLE); M(rGT); M(rGE); M(rNOT); - M(rVALUES); M(rCALL_WITH_VALUES); + M(uDEFINE); M(uLAMBDA); M(uIF); M(uBEGIN); M(uQUOTE); M(uSETBANG); + M(uDEFINE_MACRO); M(uIMPORT); M(uEXPORT); + M(uDEFINE_LIBRARY); + M(uCOND_EXPAND); + M(uCONS); M(uCAR); M(uCDR); M(uNILP); + M(uSYMBOLP); M(uPAIRP); + M(uADD); M(uSUB); M(uMUL); M(uDIV); + M(uEQ); M(uLT); M(uLE); M(uGT); M(uGE); M(uNOT); + M(uVALUES); M(uCALL_WITH_VALUES); } static void @@ -554,7 +560,7 @@ gc_mark_phase(pic_state *pic) /* checkpoint */ if (pic->cp) { - gc_mark_checkpoint(pic, pic->cp); + gc_mark_object(pic, (struct pic_object *)pic->cp); } /* stack */ @@ -606,17 +612,6 @@ gc_mark_phase(pic_state *pic) /* library table */ gc_mark(pic, pic->libs); - /* standard I/O ports */ - if (pic->xSTDIN) { - gc_mark_object(pic, (struct pic_object *)pic->xSTDIN); - } - if (pic->xSTDOUT) { - gc_mark_object(pic, (struct pic_object *)pic->xSTDOUT); - } - if (pic->xSTDERR) { - gc_mark_object(pic, (struct pic_object *)pic->xSTDERR); - } - /* parameter table */ gc_mark(pic, pic->ptable); @@ -624,16 +619,20 @@ gc_mark_phase(pic_state *pic) do { struct pic_object *key; pic_value val; - xh_entry *it; + khiter_t it; + khash_t(reg) *h; struct pic_reg *reg; j = 0; reg = pic->regs; while (reg != NULL) { - for (it = xh_begin(®->hash); it != NULL; it = xh_next(it)) { - key = xh_key(it, struct pic_object *); - val = xh_val(it, pic_value); + h = ®->hash; + for (it = kh_begin(h); it != kh_end(h); ++it) { + if (! kh_exist(h, it)) + continue; + key = kh_key(h, it); + val = kh_val(h, it); if (gc_obj_is_marked(key) && gc_value_need_mark(val)) { gc_mark(pic, val); ++j; @@ -681,7 +680,12 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) case PIC_TT_ERROR: { break; } + case PIC_TT_ID: { + break; + } case PIC_TT_ENV: { + struct pic_env *env = (struct pic_env *)obj; + kh_destroy(env, &env->map); break; } case PIC_TT_LIB: { @@ -697,24 +701,30 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) } case PIC_TT_DATA: { struct pic_data *data = (struct pic_data *)obj; - data->type->dtor(pic, data->data); - xh_destroy(&data->storage); + if (data->type->dtor) { + data->type->dtor(pic, data->data); + } break; } case PIC_TT_DICT: { struct pic_dict *dict = (struct pic_dict *)obj; - xh_destroy(&dict->hash); + kh_destroy(dict, &dict->hash); break; } case PIC_TT_RECORD: { break; } case PIC_TT_SYMBOL: { + pic_sym *sym = (pic_sym *)obj; + pic_free(pic, (void *)sym->cstr); break; } case PIC_TT_REG: { struct pic_reg *reg = (struct pic_reg *)obj; - xh_destroy(®->hash); + kh_destroy(reg, ®->hash); + break; + } + case PIC_TT_CP: { break; } case PIC_TT_NIL: @@ -734,26 +744,18 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) static void gc_sweep_symbols(pic_state *pic) { - xh_entry *it; - xvect_t(xh_entry *) xv; - size_t i; - char *cstr; + khash_t(s) *h = &pic->syms; + khiter_t it; + pic_sym *sym; - xv_init(xv); - - for (it = xh_begin(&pic->syms); it != NULL; it = xh_next(it)) { - if (! gc_obj_is_marked((struct pic_object *)xh_val(it, pic_sym *))) { - xv_push(xh_entry *, xv, it); + for (it = kh_begin(h); it != kh_end(h); ++it) { + if (! kh_exist(h, it)) + continue; + sym = kh_val(h, it); + if (! gc_obj_is_marked((struct pic_object *)sym)) { + kh_del(s, h, it); } } - - for (i = 0; i < xv_size(xv); ++i) { - cstr = xh_key(xv_A(xv, i), char *); - - xh_del_str(&pic->syms, cstr); - - pic_free(pic, cstr); - } } static void @@ -811,14 +813,17 @@ static void gc_sweep_phase(pic_state *pic) { struct heap_page *page = pic->heap->pages; - xh_entry *it, *next; + khiter_t it; + khash_t(reg) *h; /* registries */ while (pic->regs != NULL) { - for (it = xh_begin(&pic->regs->hash); it != NULL; it = next) { - next = xh_next(it); - if (! gc_obj_is_marked(xh_key(it, struct pic_object *))) { - xh_del_ptr(&pic->regs->hash, xh_key(it, struct pic_object *)); + h = &pic->regs->hash; + for (it = kh_begin(h); it != kh_end(h); ++it) { + if (! kh_exist(h, it)) + continue; + if (! gc_obj_is_marked(kh_key(h, it))) { + kh_del(reg, h, it); } } pic->regs = pic->regs->prev; diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index 5b1bd3f3..7479ab60 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -33,27 +33,24 @@ extern "C" { #include #include "picrin/config.h" -#include "picrin/util.h" + #include "picrin/compat.h" - -#if PIC_ENABLE_FLOAT -# include -#endif - -#include "picrin/xvect.h" -#include "picrin/xhash.h" -#include "picrin/xfile.h" +#include "picrin/kvec.h" +#include "picrin/khash.h" #include "picrin/value.h" -typedef struct pic_code pic_code; +typedef struct pic_state pic_state; -typedef struct pic_jmpbuf { - PIC_JMPBUF buf; - struct pic_jmpbuf *prev; -} pic_jmpbuf; +#include "picrin/irep.h" +#include "picrin/file.h" +#include "picrin/read.h" +#include "picrin/gc.h" + +KHASH_DECLARE(s, const char *, pic_sym *); typedef struct pic_checkpoint { + PIC_OBJECT_HEADER struct pic_proc *in; struct pic_proc *out; int depth; @@ -72,14 +69,16 @@ typedef struct { typedef void *(*pic_allocf)(void *, size_t); -typedef struct { +struct pic_state { int argc; char **argv, **envp; pic_allocf allocf; + void *userdata; - pic_jmpbuf *jmp; pic_checkpoint *cp; + struct pic_cont *cc; + int ccnt; pic_value *sp; pic_value *stbase, *stend; @@ -98,7 +97,9 @@ typedef struct { pic_sym *sDEFINE, *sLAMBDA, *sIF, *sBEGIN, *sQUOTE, *sSETBANG; pic_sym *sQUASIQUOTE, *sUNQUOTE, *sUNQUOTE_SPLICING; - pic_sym *sDEFINE_SYNTAX, *sIMPORT, *sEXPORT; + pic_sym *sSYNTAX_QUOTE, *sSYNTAX_QUASIQUOTE, *sSYNTAX_UNQUOTE; + pic_sym *sSYNTAX_UNQUOTE_SPLICING; + pic_sym *sDEFINE_MACRO, *sIMPORT, *sEXPORT; pic_sym *sDEFINE_LIBRARY; pic_sym *sCOND_EXPAND, *sAND, *sOR, *sELSE, *sLIBRARY; pic_sym *sONLY, *sRENAME, *sPREFIX, *sEXCEPT; @@ -111,28 +112,31 @@ typedef struct { pic_sym *sCALL, *sTAILCALL, *sRETURN; pic_sym *sCALL_WITH_VALUES, *sTAILCALL_WITH_VALUES; - pic_sym *rDEFINE, *rLAMBDA, *rIF, *rBEGIN, *rQUOTE, *rSETBANG; - pic_sym *rDEFINE_SYNTAX, *rIMPORT, *rEXPORT; - pic_sym *rDEFINE_LIBRARY; - pic_sym *rCOND_EXPAND; - pic_sym *rCONS, *rCAR, *rCDR, *rNILP; - pic_sym *rSYMBOLP, *rPAIRP; - pic_sym *rADD, *rSUB, *rMUL, *rDIV; - pic_sym *rEQ, *rLT, *rLE, *rGT, *rGE, *rNOT; - pic_sym *rVALUES, *rCALL_WITH_VALUES; + pic_sym *uDEFINE, *uLAMBDA, *uIF, *uBEGIN, *uQUOTE, *uSETBANG; + pic_sym *uDEFINE_MACRO, *uIMPORT, *uEXPORT; + pic_sym *uDEFINE_LIBRARY; + pic_sym *uCOND_EXPAND; + pic_sym *uCONS, *uCAR, *uCDR, *uNILP; + pic_sym *uSYMBOLP, *uPAIRP; + pic_sym *uADD, *uSUB, *uMUL, *uDIV; + pic_sym *uEQ, *uLT, *uLE, *uGT, *uGE, *uNOT; + pic_sym *uVALUES, *uCALL_WITH_VALUES; struct pic_lib *PICRIN_BASE; struct pic_lib *PICRIN_USER; pic_value features; - xhash syms; /* name to symbol */ + khash_t(s) syms; /* name to symbol */ + int ucnt; struct pic_dict *globals; struct pic_dict *macros; pic_value libs; struct pic_reg *attrs; - struct pic_reader *reader; + pic_reader reader; + xFILE files[XOPEN_MAX]; + pic_code iseq[2]; /* for pic_apply_trampoline */ bool gc_enable; struct pic_heap *heap; @@ -140,14 +144,10 @@ typedef struct { size_t arena_size, arena_idx; struct pic_reg *regs; - struct pic_port *xSTDIN, *xSTDOUT, *xSTDERR; - pic_value err; - pic_code *iseq; /* for pic_apply_trampoline */ - char *native_stack_start; -} pic_state; +}; typedef pic_value (*pic_func_t)(pic_state *); @@ -170,19 +170,13 @@ void pic_gc_arena_restore(pic_state *, size_t); pic_gc_arena_restore(pic, ai); \ } while (0) -pic_state *pic_open(int argc, char *argv[], char **envp, pic_allocf); void *pic_default_allocf(void *, size_t); +pic_state *pic_open(pic_allocf, void *); void pic_close(pic_state *); +void pic_set_argv(pic_state *, int argc, char *argv[], char **envp); void pic_add_feature(pic_state *, const char *); -void pic_define(pic_state *, const char *, pic_value); -void pic_define_noexport(pic_state *, const char *, pic_value); -void pic_defun(pic_state *, const char *, pic_func_t); - -struct pic_proc *pic_make_var(pic_state *, pic_value, struct pic_proc *); -void pic_defvar(pic_state *, const char *, pic_value, struct pic_proc *); - struct pic_proc *pic_get_proc(pic_state *); int pic_get_args(pic_state *, const char *, ...); @@ -193,8 +187,6 @@ bool pic_equal_p(pic_state *, pic_value, pic_value); pic_sym *pic_intern(pic_state *, pic_str *); pic_sym *pic_intern_cstr(pic_state *, const char *); const char *pic_symbol_name(pic_state *, pic_sym *); -pic_sym *pic_gensym(pic_state *, pic_sym *); -bool pic_interned_p(pic_state *, pic_sym *); pic_value pic_read(pic_state *, struct pic_port *); pic_value pic_read_cstr(pic_state *, const char *); @@ -202,9 +194,21 @@ pic_value pic_read_cstr(pic_state *, const char *); void pic_load_port(pic_state *, struct pic_port *); void pic_load_cstr(pic_state *, const char *); -pic_value pic_funcall(pic_state *pic, struct pic_lib *, const char *, pic_list); +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 '_' will not perform 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 *); + 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_list); +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); pic_value pic_apply(pic_state *, struct pic_proc *, pic_value); pic_value pic_apply0(pic_state *, struct pic_proc *); @@ -214,9 +218,10 @@ pic_value pic_apply3(pic_state *, struct pic_proc *, pic_value, pic_value, pic_v 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_trampoline(pic_state *, struct pic_proc *, pic_value); -pic_value pic_eval(pic_state *, pic_value, struct pic_lib *); -struct pic_proc *pic_compile(pic_state *, pic_value, struct pic_lib *); -pic_value pic_macroexpand(pic_state *, pic_value, struct pic_lib *); +pic_value pic_eval(pic_state *, pic_value, struct pic_env *); +struct pic_proc *pic_compile(pic_state *, pic_value, struct pic_env *); + +struct pic_proc *pic_make_var(pic_state *, pic_value, struct pic_proc *); struct pic_lib *pic_make_library(pic_state *, pic_value); struct pic_lib *pic_find_library(pic_state *, pic_value); @@ -232,8 +237,7 @@ struct pic_lib *pic_find_library(pic_state *, pic_value); ((pic->lib = pic->prev_lib), \ (pic->prev_lib = NULL))) -void pic_import(pic_state *, pic_value); -void pic_import_library(pic_state *, struct pic_lib *); +void pic_import(pic_state *, struct pic_lib *); void pic_export(pic_state *, pic_sym *); PIC_NORETURN void pic_panic(pic_state *, const char *); @@ -253,11 +257,12 @@ struct pic_port *pic_stderr(pic_state *); 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 *); #if DEBUG -# define pic_debug(pic,obj) pic_fwrite(pic,obj,pic->xSTDERR->file) +# define pic_debug(pic,obj) pic_fwrite(pic,obj,xstderr) # define pic_fdebug(pic,obj,file) pic_fwrite(pic,obj,file) #endif @@ -266,18 +271,14 @@ pic_value pic_fdisplay(pic_state *, pic_value, xFILE *); #include "picrin/data.h" #include "picrin/dict.h" #include "picrin/error.h" -#include "picrin/gc.h" -#include "picrin/irep.h" #include "picrin/lib.h" #include "picrin/macro.h" #include "picrin/pair.h" #include "picrin/port.h" #include "picrin/proc.h" -#include "picrin/read.h" #include "picrin/record.h" #include "picrin/string.h" #include "picrin/symbol.h" -#include "picrin/read.h" #include "picrin/vector.h" #include "picrin/reg.h" diff --git a/extlib/benz/include/picrin/compat.h b/extlib/benz/include/picrin/compat.h index cca83d95..ff7268c3 100644 --- a/extlib/benz/include/picrin/compat.h +++ b/extlib/benz/include/picrin/compat.h @@ -9,6 +9,77 @@ extern "C" { #endif +#if __STDC_VERSION__ >= 199901L +# include +#else +# define bool char +# define true 1 +# define false 0 +#endif + +#if __STDC_VERSION__ >= 199901L +# include +#elif ! defined(offsetof) +# define offsetof(s,m) ((size_t)&(((s *)NULL)->m)) +#endif + +#if __STDC_VERSION__ >= 201112L +# include +# define PIC_NORETURN noreturn +#elif __GNUC__ || __clang__ +# define PIC_NORETURN __attribute__((noreturn)) +#else +# define PIC_NORETURN +#endif + +#if __STDC_VERSION__ >= 199901L +# define PIC_INLINE static inline +#elif __GNUC__ || __clang__ +# define PIC_INLINE static __inline__ +#else +# define PIC_INLINE static +#endif + +#define PIC_FALLTHROUGH ((void)0) + +#if __GNUC__ || __clang__ +# define PIC_UNUSED(v) __attribute__((unused)) v +#else +# define PIC_UNUSED(v) v +#endif + +#define PIC_GENSYM2_(x,y) PIC_G##x##_##y##_ +#define PIC_GENSYM1_(x,y) PIC_GENSYM2_(x,y) +#if defined(__COUNTER__) +# define PIC_GENSYM(x) PIC_GENSYM1_(__COUNTER__,x) +#else +# define PIC_GENSYM(x) PIC_GENSYM1_(__LINE__,x) +#endif + +#if __GNUC__ +# define GCC_VERSION (__GNUC__ * 10000 \ + + __GNUC_MINOR__ * 100 \ + + __GNUC_PATCHLEVEL__) +#endif +#if GCC_VERSION >= 40500 || __clang__ +# define PIC_UNREACHABLE() (__builtin_unreachable()) +#else +# define PIC_UNREACHABLE() (assert(false)) +#endif +#if __GNUC__ +# undef GCC_VERSION +#endif + +#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); \ + (a) = (b); \ + (b) = tmp; \ + } while (0) + + #if PIC_ENABLE_LIBC #include @@ -134,6 +205,14 @@ strcpy(char *dst, const char *src) #endif +#if PIC_ENABLE_FLOAT +# include +#endif + +#if PIC_ENABLE_STDIO +# include +#endif + #if defined(__cplusplus) } #endif diff --git a/extlib/benz/include/picrin/config.h b/extlib/benz/include/picrin/config.h index b30bc398..30c89e2d 100644 --- a/extlib/benz/include/picrin/config.h +++ b/extlib/benz/include/picrin/config.h @@ -17,6 +17,9 @@ /** 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) */ @@ -93,6 +96,10 @@ # error cannot disable float support when nan boxing is on #endif +#ifndef PIC_ENABLE_STDIO +# define PIC_ENABLE_STDIO 1 +#endif + #ifndef PIC_JMPBUF # include # define PIC_JMPBUF jmp_buf diff --git a/extlib/benz/include/picrin/cont.h b/extlib/benz/include/picrin/cont.h index 303ea0f9..439f6aeb 100644 --- a/extlib/benz/include/picrin/cont.h +++ b/extlib/benz/include/picrin/cont.h @@ -10,20 +10,21 @@ extern "C" { #endif struct pic_cont { - pic_jmpbuf jmp; + 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 ptable; - pic_value results; + + struct pic_cont *prev; }; void pic_save_point(pic_state *, struct pic_cont *); diff --git a/extlib/benz/include/picrin/data.h b/extlib/benz/include/picrin/data.h index 38a20c3d..f527eee7 100644 --- a/extlib/benz/include/picrin/data.h +++ b/extlib/benz/include/picrin/data.h @@ -18,7 +18,7 @@ typedef struct { struct pic_data { PIC_OBJECT_HEADER const pic_data_type *type; - xhash storage; /* const char * to pic_value table */ + struct pic_dict *storage; void *data; }; diff --git a/extlib/benz/include/picrin/dict.h b/extlib/benz/include/picrin/dict.h index 4a3bd7ce..8b53dba4 100644 --- a/extlib/benz/include/picrin/dict.h +++ b/extlib/benz/include/picrin/dict.h @@ -9,9 +9,11 @@ extern "C" { #endif +KHASH_DECLARE(dict, pic_sym *, pic_value) + struct pic_dict { PIC_OBJECT_HEADER - xhash hash; + khash_t(dict) hash; }; #define pic_dict_p(v) (pic_type(v) == PIC_TT_DICT) @@ -19,9 +21,11 @@ struct pic_dict { struct pic_dict *pic_make_dict(pic_state *); -#define pic_dict_for_each(sym, dict, it) \ - for (it = xh_begin(&(dict)->hash); it != NULL; it = xh_next(it)) \ - if ((sym = xh_key(it, pic_sym *)), true) +#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); diff --git a/extlib/benz/include/picrin/error.h b/extlib/benz/include/picrin/error.h index 1435faa3..b8de3442 100644 --- a/extlib/benz/include/picrin/error.h +++ b/extlib/benz/include/picrin/error.h @@ -30,21 +30,21 @@ struct pic_error *pic_make_error(pic_state *, pic_sym *, const char *, pic_list) pic_catch_(PIC_GENSYM(label)) #define pic_try_(cont, handler) \ do { \ - struct pic_cont *cont = pic_malloc(pic, sizeof(struct pic_cont)); \ - pic_save_point(pic, cont); \ - if (PIC_SETJMP(pic, cont->jmp.buf) == 0) { \ + 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, "(native-exception-handler)"); \ - pic_proc_env_set(pic, handler, "cont", pic_obj_value(pic_make_cont(pic, cont))); \ + 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->jmp = pic->jmp->prev; \ + pic->cc = pic->cc->prev; \ } else { \ - pic->jmp = pic->jmp->prev; \ + pic->cc = pic->cc->prev; \ goto label; \ } \ } while (0); \ diff --git a/extlib/benz/include/picrin/file.h b/extlib/benz/include/picrin/file.h new file mode 100644 index 00000000..b07e1a27 --- /dev/null +++ b/extlib/benz/include/picrin/file.h @@ -0,0 +1,104 @@ +#ifndef PICRIN_FILE_H +#define PICRIN_FILE_H + +#if defined(__cplusplus) +extern "C" { +#endif + +#ifndef EOF +# define EOF (-1) +#endif + +#define XBUFSIZ 1024 +#define XOPEN_MAX 1024 + +typedef struct { + /* buffer */ + char buf[1]; /* fallback buffer */ + long cnt; /* characters left */ + char *ptr; /* next character position */ + char *base; /* location of the buffer */ + /* operators */ + struct { + void *cookie; + int (*read)(pic_state *, void *, char *, int); + int (*write)(pic_state *, void *, const char *, int); + long (*seek)(pic_state *, void *, long, int); + int (*close)(pic_state *, void *); + } vtable; + int flag; /* mode of the file access */ +} xFILE; + +#define xstdin (&pic->files[0]) +#define xstdout (&pic->files[1]) +#define xstderr (&pic->files[2]) + +extern const xFILE x_iob[XOPEN_MAX]; + +enum _flags { + X_READ = 01, + X_WRITE = 02, + X_UNBUF = 04, + X_EOF = 010, + X_ERR = 020, + X_LNBUF = 040 +}; + +#define xclearerr(p) ((p)->flag &= ~(X_EOF | X_ERR)) +#define xfeof(p) (((p)->flag & X_EOF) != 0) +#define xferror(p) (((p)->flag & X_ERR) != 0) +#define xfileno(p) ((p)->fd) + +#define xgetc(pic, p) \ + ((--(p)->cnt >= 0) \ + ? (unsigned char) *(p)->ptr++ \ + : x_fillbuf((pic), p)) +#define xputc(pic, x, p) \ + ((--(p)->cnt >= 0 && !(((p)->flag & X_LNBUF) && (x) == '\n')) \ + ? *(p)->ptr++ = (x) \ + : x_flushbuf((pic), (x), (p))) +#define xgetchar(pic) xgetc((pic), xstdin) +#define xputchar(pic, x) xputc((pic), (x), xstdout) + +/* resource aquisition */ +xFILE *xfunopen(pic_state *, void *cookie, int (*read)(pic_state *, void *, char *, int), int (*write)(pic_state *, void *, const char *, int), long (*seek)(pic_state *, void *, long, int), int (*close)(pic_state *, void *)); +int xfclose(pic_state *, xFILE *); + +/* buffer management */ +int x_fillbuf(pic_state *, xFILE *); +int x_flushbuf(pic_state *, int, xFILE *); +int xfflush(pic_state *, xFILE *); + +/* direct IO */ +size_t xfread(pic_state *, void *, size_t, size_t, xFILE *); +size_t xfwrite(pic_state *, const void *, size_t, size_t, xFILE *); + +enum { + XSEEK_CUR, + XSEEK_END, + XSEEK_SET +}; + +/* indicator positioning */ +long xfseek(pic_state *, xFILE *, long, int); +long xftell(pic_state *, xFILE *); +void xrewind(pic_state *, xFILE *); + +/* character IO */ +int xfputc(pic_state *, int, xFILE *); +int xfgetc(pic_state *, xFILE *); +int xfputs(pic_state *, const char *, xFILE *); +char *xfgets(pic_state *, char *, int, xFILE *); +int xputs(pic_state *, const char *); +int xungetc(int, xFILE *); + +/* formatted I/O */ +int xprintf(pic_state *, const char *, ...); +int xfprintf(pic_state *, xFILE *, const char *, ...); +int xvfprintf(pic_state *, xFILE *, const char *, va_list); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/irep.h b/extlib/benz/include/picrin/irep.h index 319d1b31..200278ed 100644 --- a/extlib/benz/include/picrin/irep.h +++ b/extlib/benz/include/picrin/irep.h @@ -49,7 +49,7 @@ enum pic_opcode { OP_STOP }; -struct pic_code { +typedef struct { enum pic_opcode insn; union { int i; @@ -59,7 +59,7 @@ struct pic_code { int idx; } r; } u; -}; +} pic_code; #define PIC_INIT_CODE_I(code, op, ival) do { \ code.insn = op; \ @@ -68,7 +68,6 @@ struct pic_code { struct pic_irep { PIC_OBJECT_HEADER - pic_sym *name; pic_code *code; int argc, localc, capturec; bool varg; @@ -78,6 +77,8 @@ struct pic_irep { size_t clen, ilen, plen, slen; }; +pic_sym *pic_resolve(pic_state *, pic_value, struct pic_env *); +pic_value pic_expand(pic_state *, pic_value, struct pic_env *); pic_value pic_analyze(pic_state *, pic_value); struct pic_irep *pic_codegen(pic_state *, pic_value); diff --git a/extlib/benz/include/picrin/khash.h b/extlib/benz/include/picrin/khash.h new file mode 100644 index 00000000..78d0feef --- /dev/null +++ b/extlib/benz/include/picrin/khash.h @@ -0,0 +1,263 @@ +/* The MIT License + + Copyright (c) 2015 by Yuichi Nishiwaki + Copyright (c) 2008, 2009, 2011 by Attractive Chaos + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS + BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN + ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN + CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + SOFTWARE. +*/ + +#ifndef AC_KHASH_H +#define AC_KHASH_H + +#include + +#if UINT_MAX == 0xffffffffu +typedef unsigned int khint32_t; +#elif ULONG_MAX == 0xffffffffu +typedef unsigned long khint32_t; +#endif + +#if ULONG_MAX == ULLONG_MAX +typedef unsigned long khint64_t; +#else +typedef unsigned long long khint64_t; +#endif + +typedef khint32_t khint_t; +typedef khint_t khiter_t; + +#define ac_isempty(flag, i) ((flag[i>>4]>>((i&0xfU)<<1))&2) +#define ac_isdel(flag, i) ((flag[i>>4]>>((i&0xfU)<<1))&1) +#define ac_iseither(flag, i) ((flag[i>>4]>>((i&0xfU)<<1))&3) +#define ac_set_isdel_false(flag, i) (flag[i>>4]&=~(1ul<<((i&0xfU)<<1))) +#define ac_set_isempty_false(flag, i) (flag[i>>4]&=~(2ul<<((i&0xfU)<<1))) +#define ac_set_isboth_false(flag, i) (flag[i>>4]&=~(3ul<<((i&0xfU)<<1))) +#define ac_set_isdel_true(flag, i) (flag[i>>4]|=1ul<<((i&0xfU)<<1)) + +#define ac_roundup32(x) \ + (--(x), (x)|=(x)>>1, (x)|=(x)>>2, (x)|=(x)>>4, (x)|=(x)>>8, (x)|=(x)>>16, ++(x)) + +PIC_INLINE khint_t ac_X31_hash_string(const char *s) +{ + khint_t h = (khint_t)*s; + if (h) for (++s ; *s; ++s) h = (h << 5) - h + (khint_t)*s; + return h; +} +PIC_INLINE khint_t ac_Wang_hash(khint_t key) +{ + key += ~(key << 15); + key ^= (key >> 10); + key += (key << 3); + key ^= (key >> 6); + key += ~(key << 11); + key ^= (key >> 16); + return key; +} + +#define ac_fsize(m) ((m) < 16? 1 : (m)>>4) +#define ac_hash_upper(x) ((((x) * 2) * 77 / 100 + 1) / 2) + +#define KHASH_DECLARE(name, khkey_t, khval_t) \ + typedef struct { \ + khint_t n_buckets, size, n_occupied, upper_bound; \ + khint32_t *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_clear_##name(kh_##name##_t *h); \ + khint_t kh_get_##name(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); + +#define KHASH_DEFINE(name, khkey_t, khval_t, hash_func, hash_equal) \ + KHASH_DEFINE2(name, khkey_t, khval_t, 1, hash_func, hash_equal) +#define KHASH_DEFINE2(name, khkey_t, khval_t, kh_is_map, hash_func, hash_equal) \ + void kh_init_##name(kh_##name##_t *h) { \ + memset(h, 0, sizeof(kh_##name##_t)); \ + } \ + void kh_destroy_##name(pic_state *pic, kh_##name##_t *h) \ + { \ + pic_free(pic, h->flags); \ + pic_free(pic, (void *)h->keys); \ + pic_free(pic, (void *)h->vals); \ + } \ + void kh_clear_##name(kh_##name##_t *h) \ + { \ + if (h->flags) { \ + memset(h->flags, 0xaa, ac_fsize(h->n_buckets) * sizeof(khint32_t)); \ + h->size = h->n_occupied = 0; \ + } \ + } \ + khint_t kh_get_##name(const kh_##name##_t *h, khkey_t key) \ + { \ + if (h->n_buckets) { \ + khint_t k, i, last, mask, step = 0; \ + mask = h->n_buckets - 1; \ + k = hash_func(key); i = k & mask; \ + last = i; \ + while (!ac_isempty(h->flags, i) && (ac_isdel(h->flags, i) || !hash_equal(h->keys[i], key))) { \ + i = (i + (++step)) & mask; \ + if (i == last) return h->n_buckets; \ + } \ + 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) \ + { /* This function uses 0.25*n_buckets bytes of working space instead of [sizeof(key_t+val_t)+.25]*n_buckets. */ \ + khint32_t *new_flags = 0; \ + khint_t j = 1; \ + { \ + ac_roundup32(new_n_buckets); \ + if (new_n_buckets < 4) new_n_buckets = 4; \ + if (h->size >= ac_hash_upper(new_n_buckets)) j = 0; /* requested size is too small */ \ + else { /* hash table size to be changed (shrink or expand); rehash */ \ + new_flags = pic_malloc(pic, ac_fsize(new_n_buckets) * sizeof(khint32_t)); \ + memset(new_flags, 0xaa, ac_fsize(new_n_buckets) * sizeof(khint32_t)); \ + if (h->n_buckets < new_n_buckets) { /* expand */ \ + h->keys = pic_realloc(pic, (void *)h->keys, new_n_buckets * sizeof(khkey_t)); \ + if (kh_is_map) { \ + h->vals = pic_realloc(pic, (void *)h->vals, new_n_buckets * sizeof(khval_t)); \ + } \ + } /* otherwise shrink */ \ + } \ + } \ + if (j) { /* rehashing is needed */ \ + for (j = 0; j != h->n_buckets; ++j) { \ + if (ac_iseither(h->flags, j) == 0) { \ + khkey_t key = h->keys[j]; \ + khval_t val; \ + khint_t 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; \ + k = hash_func(key); \ + i = k & new_mask; \ + while (!ac_isempty(new_flags, i)) i = (i + (++step)) & new_mask; \ + ac_set_isempty_false(new_flags, i); \ + if (i < h->n_buckets && ac_iseither(h->flags, i) == 0) { /* kick out the existing element */ \ + { khkey_t tmp = h->keys[i]; h->keys[i] = key; key = tmp; } \ + if (kh_is_map) { khval_t tmp = h->vals[i]; h->vals[i] = val; val = tmp; } \ + ac_set_isdel_true(h->flags, i); /* mark it as deleted in the old hash table */ \ + } else { /* write the element and jump out of the loop */ \ + h->keys[i] = key; \ + if (kh_is_map) h->vals[i] = val; \ + break; \ + } \ + } \ + } \ + } \ + if (h->n_buckets > new_n_buckets) { /* shrink the hash table */ \ + h->keys = pic_realloc(pic, (void *)h->keys, new_n_buckets * sizeof(khkey_t)); \ + if (kh_is_map) h->vals = pic_realloc(pic, (void *)h->vals, new_n_buckets * sizeof(khval_t)); \ + } \ + pic_free(pic, h->flags); /* free the working space */ \ + h->flags = new_flags; \ + h->n_buckets = new_n_buckets; \ + h->n_occupied = h->size; \ + 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) \ + { \ + khint_t 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 */ \ + } else { \ + kh_resize_##name(pic, h, h->n_buckets + 1); /* expand the hash table */ \ + } \ + } /* TODO: to implement automatically shrinking; resize() already support shrinking */ \ + { \ + khint_t 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 { \ + last = i; \ + while (!ac_isempty(h->flags, i) && (ac_isdel(h->flags, i) || !hash_equal(h->keys[i], key))) { \ + if (ac_isdel(h->flags, i)) site = i; \ + i = (i + (++step)) & mask; \ + if (i == last) { x = site; break; } \ + } \ + if (x == h->n_buckets) { \ + if (ac_isempty(h->flags, i) && site != h->n_buckets) x = site; \ + else x = i; \ + } \ + } \ + } \ + if (ac_isempty(h->flags, x)) { /* not present at all */ \ + h->keys[x] = key; \ + ac_set_isboth_false(h->flags, x); \ + ++h->size; ++h->n_occupied; \ + *ret = 1; \ + } else if (ac_isdel(h->flags, x)) { /* deleted */ \ + h->keys[x] = key; \ + ac_set_isboth_false(h->flags, x); \ + ++h->size; \ + *ret = 2; \ + } 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) \ + { \ + if (x != h->n_buckets && !ac_iseither(h->flags, x)) { \ + ac_set_isdel_true(h->flags, x); \ + --h->size; \ + } \ + } + +/* --- BEGIN OF HASH FUNCTIONS --- */ + +#define kh_ptr_hash_func(key) (khint32_t)(long)(key) +#define kh_ptr_hash_equal(a, b) ((a) == (b)) +#define kh_int_hash_func(key) (khint32_t)(key) +#define kh_int_hash_equal(a, b) ((a) == (b)) +#define kh_int64_hash_func(key) (khint32_t)((key)>>33^(key)^(key)<<11) +#define kh_int64_hash_equal(a, b) ((a) == (b)) +#define kh_str_hash_func(key) ac_X31_hash_string(key) +#define kh_str_hash_equal(a, b) (strcmp(a, b) == 0) +#define kh_int_hash_func2(k) ac_Wang_hash((khint_t)key) + +/* --- END OF HASH FUNCTIONS --- */ + +#define khash_t(name) kh_##name##_t +#define kh_init(name, h) kh_init_##name(h) +#define kh_destroy(name, h) kh_destroy_##name(pic, h) +#define kh_clear(name, h) kh_clear_##name(h) +#define kh_resize(name, h, s) kh_resize_##name(pic, h, s) +#define kh_put(name, h, k, r) kh_put_##name(pic, h, k, r) +#define kh_get(name, h, k) kh_get_##name(h, k) +#define kh_del(name, h, k) kh_del_##name(h, k) + +#define kh_exist(h, x) (!ac_iseither((h)->flags, (x))) +#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_end(h) ((h)->n_buckets) +#define kh_size(h) ((h)->size) +#define kh_n_buckets(h) ((h)->n_buckets) + +#endif /* AC_KHASH_H */ diff --git a/extlib/benz/include/picrin/kvec.h b/extlib/benz/include/picrin/kvec.h new file mode 100644 index 00000000..cea48ee4 --- /dev/null +++ b/extlib/benz/include/picrin/kvec.h @@ -0,0 +1,67 @@ +/* The MIT License + + Copyright (c) 2015, by Yuichi Nishiwaki + Copyright (c) 2008, by Attractive Chaos + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS + BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN + ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN + CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + SOFTWARE. +*/ + +#ifndef AC_KVEC_H +#define AC_KVEC_H + +#define kv_roundup32(x) (--(x), (x)|=(x)>>1, (x)|=(x)>>2, (x)|=(x)>>4, (x)|=(x)>>8, (x)|=(x)>>16, ++(x)) + +#define kvec_t(type) struct { size_t n, m; type *a; } +#define kv_init(v) ((v).n = (v).m = 0, (v).a = 0) +#define kv_destroy(v) pic_free((pic), (v).a) +#define kv_A(v, i) ((v).a[(i)]) +#define kv_pop(v) ((v).a[--(v).n]) +#define kv_size(v) ((v).n) +#define kv_max(v) ((v).m) + +#define kv_resize(type, v, s) ((v).m = (s), (v).a = (type*)pic_realloc((pic), (v).a, sizeof(type) * (v).m)) + +#define kv_copy(type, v1, v0) do { \ + if ((v1).m < (v0).n) kv_resize((pic), type, v1, (v0).n); \ + (v1).n = (v0).n; \ + memcpy((v1).a, (v0).a, sizeof(type) * (v0).n); \ + } while (0) \ + +#define kv_push(type, v, x) do { \ + if ((v).n == (v).m) { \ + (v).m = (v).m? (v).m<<1 : 2; \ + (v).a = (type*)pic_realloc((pic), (v).a, sizeof(type) * (v).m); \ + } \ + (v).a[(v).n++] = (x); \ + } while (0) + +#define kv_pushp(type, v) \ + (((v).n == (v).m)? \ + ((v).m = ((v).m? (v).m<<1 : 2), \ + (v).a = (type*)pic_realloc((pic), (v).a, sizeof(type) * (v).m), 0) \ + : 0), ((v).a + ((v).n++)) + +#define kv_a(type, v, i) \ + (((v).m <= (size_t)(i)? \ + ((v).m = (v).n = (i) + 1, kv_roundup32((v).m), \ + (v).a = (type*)pic_realloc((pic), (v).a, sizeof(type) * (v).m), 0) \ + : (v).n <= (size_t)(i)? (v).n = (i) + 1 \ + : 0), (v).a[(i)]) + +#endif diff --git a/extlib/benz/include/picrin/lib.h b/extlib/benz/include/picrin/lib.h index c2d0b420..50cd45fe 100644 --- a/extlib/benz/include/picrin/lib.h +++ b/extlib/benz/include/picrin/lib.h @@ -16,6 +16,7 @@ struct pic_lib { 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) diff --git a/extlib/benz/include/picrin/macro.h b/extlib/benz/include/picrin/macro.h index 7d150777..65b8e3bd 100644 --- a/extlib/benz/include/picrin/macro.h +++ b/extlib/benz/include/picrin/macro.h @@ -9,24 +9,37 @@ extern "C" { #endif +KHASH_DECLARE(env, void *, pic_sym *) + +struct pic_id { + PIC_OBJECT_HEADER + pic_value var; + struct pic_env *env; +}; + struct pic_env { PIC_OBJECT_HEADER - struct pic_dict *map; - pic_value defer; + khash_t(env) map; struct pic_env *up; }; +#define pic_id_p(v) (pic_type(v) == PIC_TT_ID) +#define pic_id_ptr(v) ((struct pic_id *)pic_ptr(v)) + #define pic_env_p(v) (pic_type(v) == PIC_TT_ENV) #define pic_env_ptr(v) ((struct pic_env *)pic_ptr(v)) -bool pic_identifier_p(pic_state *pic, pic_value obj); -bool pic_identifier_eq_p(pic_state *, struct pic_env *, pic_sym *, struct pic_env *, pic_sym *); - +struct pic_id *pic_make_id(pic_state *, pic_value, struct pic_env *); struct pic_env *pic_make_env(pic_state *, struct pic_env *); -pic_sym *pic_add_rename(pic_state *, struct pic_env *, pic_sym *); -pic_sym *pic_find_rename(pic_state *, struct pic_env *, pic_sym *); -void pic_put_rename(pic_state *, struct pic_env *, pic_sym *, pic_sym *); +pic_sym *pic_uniq(pic_state *, pic_value); + +pic_sym *pic_add_variable(pic_state *, struct pic_env *, pic_value); +void pic_put_variable(pic_state *, struct pic_env *, pic_value, pic_sym *); +pic_sym *pic_find_variable(pic_state *, struct pic_env *, pic_value); + +bool pic_var_p(pic_value); +pic_sym *pic_var_name(pic_state *, pic_value); #if defined(__cplusplus) } diff --git a/extlib/benz/include/picrin/port.h b/extlib/benz/include/picrin/port.h index 98dcff83..c806ba8e 100644 --- a/extlib/benz/include/picrin/port.h +++ b/extlib/benz/include/picrin/port.h @@ -13,19 +13,14 @@ enum pic_port_flag { PIC_PORT_IN = 1, PIC_PORT_OUT = 2, PIC_PORT_TEXT = 4, - PIC_PORT_BINARY = 8 -}; - -enum pic_port_status { - PIC_PORT_OPEN, - PIC_PORT_CLOSE + PIC_PORT_BINARY = 8, + PIC_PORT_OPEN = 16 }; struct pic_port { PIC_OBJECT_HEADER xFILE *file; int flags; - int status; }; #define pic_port_p(v) (pic_type(v) == PIC_TT_PORT) @@ -37,6 +32,7 @@ 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) diff --git a/extlib/benz/include/picrin/proc.h b/extlib/benz/include/picrin/proc.h index bf1a0a4e..e5cc2bdb 100644 --- a/extlib/benz/include/picrin/proc.h +++ b/extlib/benz/include/picrin/proc.h @@ -26,7 +26,6 @@ struct pic_proc { union { struct { pic_func_t func; - pic_sym *name; struct pic_dict *env; } f; struct { @@ -45,10 +44,9 @@ struct pic_proc { #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, const char *); +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 *); -pic_sym *pic_proc_name(struct pic_proc *); 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 *); diff --git a/extlib/benz/include/picrin/read.h b/extlib/benz/include/picrin/read.h index a3f01100..27c715bb 100644 --- a/extlib/benz/include/picrin/read.h +++ b/extlib/benz/include/picrin/read.h @@ -9,20 +9,22 @@ extern "C" { #endif +KHASH_DECLARE(read, int, pic_value) + typedef pic_value (*pic_reader_t)(pic_state *, struct pic_port *port, int c); -struct pic_reader { +typedef struct { enum pic_typecase { PIC_CASE_DEFAULT, PIC_CASE_FOLD } typecase; - xhash labels; + khash_t(read) labels; pic_reader_t table[256]; pic_reader_t dispatch[256]; -}; +} pic_reader; -struct pic_reader *pic_reader_open(pic_state *); -void pic_reader_close(pic_state *, struct pic_reader *); +void pic_reader_init(pic_state *); +void pic_reader_destroy(pic_state *); #if defined(__cplusplus) } diff --git a/extlib/benz/include/picrin/reg.h b/extlib/benz/include/picrin/reg.h index d9622c06..c64c548f 100644 --- a/extlib/benz/include/picrin/reg.h +++ b/extlib/benz/include/picrin/reg.h @@ -9,9 +9,11 @@ extern "C" { #endif +KHASH_DECLARE(reg, void *, pic_value) + struct pic_reg { PIC_OBJECT_HEADER - xhash hash; + khash_t(reg) hash; struct pic_reg *prev; /* for GC */ }; diff --git a/extlib/benz/include/picrin/symbol.h b/extlib/benz/include/picrin/symbol.h index bb588d0d..601802c8 100644 --- a/extlib/benz/include/picrin/symbol.h +++ b/extlib/benz/include/picrin/symbol.h @@ -11,7 +11,7 @@ extern "C" { struct pic_symbol { PIC_OBJECT_HEADER - pic_str *str; + const char *cstr; }; #define pic_sym_p(v) (pic_type(v) == PIC_TT_SYMBOL) diff --git a/extlib/benz/include/picrin/util.h b/extlib/benz/include/picrin/util.h deleted file mode 100644 index 5c831bad..00000000 --- a/extlib/benz/include/picrin/util.h +++ /dev/null @@ -1,78 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_UTIL_H -#define PICRIN_UTIL_H - -#if defined(__cplusplus) -extern "C" { -#endif - -#if __STDC_VERSION__ >= 199901L -# include -#else -# define bool char -# define true 1 -# define false 0 -#endif - -#if __STDC_VERSION__ >= 199901L -# include -#elif ! defined(offsetof) -# define offsetof(s,m) ((size_t)&(((s *)NULL)->m)) -#endif - -#if __STDC_VERSION__ >= 201112L -# include -# define PIC_NORETURN noreturn -#elif __GNUC__ || __clang__ -# define PIC_NORETURN __attribute__((noreturn)) -#else -# define PIC_NORETURN -#endif - -#if __STDC_VERSION__ >= 199901L -# define PIC_INLINE static inline -#elif __GNUC__ || __clang__ -# define PIC_INLINE static __inline__ -#else -# define PIC_INLINE static -#endif - -#define PIC_FALLTHROUGH ((void)0) - -#if __GNUC__ || __clang__ -# define PIC_UNUSED(v) __attribute__((unused)) v -#else -# define PIC_UNUSED(v) v -#endif - -#define PIC_GENSYM2_(x,y) PIC_G##x##_##y##_ -#define PIC_GENSYM1_(x,y) PIC_GENSYM2_(x,y) -#if defined(__COUNTER__) -# define PIC_GENSYM(x) PIC_GENSYM1_(__COUNTER__,x) -#else -# define PIC_GENSYM(x) PIC_GENSYM1_(__LINE__,x) -#endif - -#if GCC_VERSION >= 40500 || __clang__ -# define PIC_UNREACHABLE() (__builtin_unreachable()) -#else -# define PIC_UNREACHABLE() (assert(false)) -#endif - -#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); \ - (a) = (b); \ - (b) = tmp; \ - } while (0) - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/value.h b/extlib/benz/include/picrin/value.h index d69eaf59..507832bb 100644 --- a/extlib/benz/include/picrin/value.h +++ b/extlib/benz/include/picrin/value.h @@ -157,14 +157,16 @@ enum pic_tt { PIC_TT_PROC, PIC_TT_PORT, PIC_TT_ERROR, - PIC_TT_CXT, + PIC_TT_ID, PIC_TT_ENV, PIC_TT_LIB, - PIC_TT_IREP, PIC_TT_DATA, PIC_TT_DICT, PIC_TT_REG, - PIC_TT_RECORD + PIC_TT_RECORD, + PIC_TT_CXT, + PIC_TT_IREP, + PIC_TT_CP }; #define PIC_OBJECT_HEADER \ @@ -183,6 +185,7 @@ struct pic_blob; struct pic_proc; struct pic_port; struct pic_error; +struct pic_env; /* set aliases to basic types */ typedef pic_value pic_list; @@ -314,6 +317,8 @@ pic_type_repr(enum pic_tt tt) return "port"; case PIC_TT_ERROR: return "error"; + case PIC_TT_ID: + return "id"; case PIC_TT_CXT: return "cxt"; case PIC_TT_PROC: @@ -332,6 +337,8 @@ pic_type_repr(enum pic_tt tt) return "reg"; case PIC_TT_RECORD: return "record"; + case PIC_TT_CP: + return "checkpoint"; } PIC_UNREACHABLE(); } diff --git a/extlib/benz/include/picrin/xfile.h b/extlib/benz/include/picrin/xfile.h deleted file mode 100644 index eff7d269..00000000 --- a/extlib/benz/include/picrin/xfile.h +++ /dev/null @@ -1,111 +0,0 @@ -#ifndef XFILE_H -#define XFILE_H - -#if defined(__cplusplus) -extern "C" { -#endif - -#include - -#ifndef NULL -# define NULL 0 -#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)(void *, char *, int); - int (*write)(void *, const char *, int); - long (*seek)(void *, long, int); - int (*close)(void *); - } vtable; - int flag; /* mode of the file access */ -} xFILE; - -extern xFILE x_iob[XOPEN_MAX]; - -#define xstdin (x_iob[0].vtable.cookie || (x_iob[0].vtable.cookie = stdin ), &x_iob[0]) -#define xstdout (x_iob[1].vtable.cookie || (x_iob[1].vtable.cookie = stdout), &x_iob[1]) -#define xstderr (x_iob[2].vtable.cookie || (x_iob[2].vtable.cookie = stderr), &x_iob[2]) - -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(p) \ - ((--(p)->cnt >= 0) \ - ? (unsigned char) *(p)->ptr++ \ - : x_fillbuf(p)) -#define xputc(x, p) \ - ((--(p)->cnt >= 0 && !(((p)->flag & X_LNBUF) && (x) == '\n')) \ - ? *(p)->ptr++ = (x) \ - : x_flushbuf(x, (p))) -#define xgetchar() xgetc(xstdin) -#define xputchar(x) xputc((x), xstdout) - -/* resource aquisition */ -xFILE *xfunopen(void *cookie, int (*read)(void *, char *, int), int (*write)(void *, const char *, int), long (*seek)(void *, long, int), int (*close)(void *)); -xFILE *xfopen(const char *, const char *); -int xfclose(xFILE *); - -/* buffer management */ -int x_fillbuf(xFILE *); -int x_flushbuf(int, xFILE *); -int xfflush(xFILE *); - -/* direct IO */ -size_t xfread(void *, size_t, size_t, xFILE *); -size_t xfwrite(const void *, size_t, size_t, xFILE *); - -enum { - XSEEK_CUR, - XSEEK_END, - XSEEK_SET -}; - -/* indicator positioning */ -long xfseek(xFILE *, long, int); -long xftell(xFILE *); -void xrewind(xFILE *); - -/* character IO */ -int xfputc(int, xFILE *); -int xfgetc(xFILE *); -int xfputs(const char *, xFILE *); -char *xfgets(char *, int, xFILE *); -int xputs(const char *); -int xungetc(int, xFILE *); - -/* formatted I/O */ -int xprintf(const char *, ...); -int xfprintf(xFILE *, const char *, ...); -int xvfprintf(xFILE *, const char *, va_list); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/xhash.h b/extlib/benz/include/picrin/xhash.h deleted file mode 100644 index 253c25f2..00000000 --- a/extlib/benz/include/picrin/xhash.h +++ /dev/null @@ -1,416 +0,0 @@ -#ifndef XHASH_H -#define XHASH_H - -/* - * Copyright (c) 2013-2014 by Yuichi Nishiwaki - */ - -#if defined(__cplusplus) -extern "C" { -#endif - -#define XHASH_ALLOCATOR pic->allocf - -/* simple object to object hash table */ - -#define XHASH_INIT_SIZE 11 -#define XHASH_RESIZE_RATIO(x) ((x) * 3 / 4) - -#define XHASH_ALIGNMENT 3 /* quad word alignment */ -#define XHASH_MASK (~(size_t)((1 << XHASH_ALIGNMENT) - 1)) -#define XHASH_ALIGN(i) ((((i) - 1) & XHASH_MASK) + (1 << XHASH_ALIGNMENT)) - -typedef struct xh_entry { - struct xh_entry *next; - int hash; - struct xh_entry *fw, *bw; - const void *key; - void *val; -} xh_entry; - -#define xh_key(e,type) (*(type *)((e)->key)) -#define xh_val(e,type) (*(type *)((e)->val)) - -typedef int (*xh_hashf)(const void *, void *); -typedef int (*xh_equalf)(const void *, const void *, void *); -typedef void *(*xh_allocf)(void *, size_t); - -typedef struct xhash { - xh_allocf allocf; - xh_entry **buckets; - size_t size, count, kwidth, vwidth; - size_t koffset, voffset; - xh_hashf hashf; - xh_equalf equalf; - xh_entry *head, *tail; - void *data; -} xhash; - -/** Protected Methods: - * static inline void xh_init_(xhash *x, size_t, size_t, xh_hashf, xh_equalf, void *); - * static inline xh_entry *xh_get_(xhash *x, const void *key); - * static inline xh_entry *xh_put_(xhash *x, const void *key, void *val); - * static inline void xh_del_(xhash *x, const void *key); - */ - -/* string map */ -PIC_INLINE xh_entry *xh_get_str(xhash *x, const char *key); -PIC_INLINE xh_entry *xh_put_str(xhash *x, const char *key, void *); -PIC_INLINE void xh_del_str(xhash *x, const char *key); - -/* object map */ -PIC_INLINE xh_entry *xh_get_ptr(xhash *x, const void *key); -PIC_INLINE xh_entry *xh_put_ptr(xhash *x, const void *key, void *); -PIC_INLINE void xh_del_ptr(xhash *x, const void *key); - -/* int map */ -PIC_INLINE xh_entry *xh_get_int(xhash *x, int key); -PIC_INLINE xh_entry *xh_put_int(xhash *x, int key, void *); -PIC_INLINE void xh_del_int(xhash *x, int key); - -PIC_INLINE size_t xh_size(xhash *x); -PIC_INLINE void xh_clear(xhash *x); -PIC_INLINE void xh_destroy(xhash *x); - -PIC_INLINE xh_entry *xh_begin(xhash *x); -PIC_INLINE xh_entry *xh_next(xh_entry *e); - - -PIC_INLINE void -xh_bucket_alloc(xhash *x, size_t newsize) -{ - x->size = newsize; - x->buckets = x->allocf(NULL, (x->size + 1) * sizeof(xh_entry *)); - memset(x->buckets, 0, (x->size + 1) * sizeof(xh_entry *)); -} - -PIC_INLINE void -xh_init_(xhash *x, xh_allocf allocf, size_t kwidth, size_t vwidth, xh_hashf hashf, xh_equalf equalf, void *data) -{ - x->allocf = allocf; - x->size = 0; - x->buckets = NULL; - x->count = 0; - x->kwidth = kwidth; - x->vwidth = vwidth; - x->koffset = XHASH_ALIGN(sizeof(xh_entry)); - x->voffset = XHASH_ALIGN(sizeof(xh_entry)) + XHASH_ALIGN(kwidth); - x->hashf = hashf; - x->equalf = equalf; - x->head = NULL; - x->tail = NULL; - x->data = data; - - xh_bucket_alloc(x, XHASH_INIT_SIZE); -} - -PIC_INLINE xh_entry * -xh_get_(xhash *x, const void *key) -{ - int hash; - size_t idx; - xh_entry *e; - - hash = x->hashf(key, x->data); - idx = ((unsigned)hash) % x->size; - for (e = x->buckets[idx]; e; e = e->next) { - if (e->hash == hash && x->equalf(key, e->key, x->data)) - break; - } - return e; -} - -PIC_INLINE void -xh_resize_(xhash *x, size_t newsize) -{ - xhash y; - xh_entry *it; - size_t idx; - - xh_init_(&y, x->allocf, x->kwidth, x->vwidth, x->hashf, x->equalf, x->data); - xh_bucket_alloc(&y, newsize); - - for (it = xh_begin(x); it != NULL; it = xh_next(it)) { - idx = ((unsigned)it->hash) % y.size; - /* reuse entry object */ - it->next = y.buckets[idx]; - y.buckets[idx] = it; - y.count++; - } - - y.head = x->head; - y.tail = x->tail; - - x->allocf(x->buckets, 0); - - /* copy all members from y to x */ - memcpy(x, &y, sizeof(xhash)); -} - -PIC_INLINE xh_entry * -xh_put_(xhash *x, const void *key, void *val) -{ - int hash; - size_t idx; - xh_entry *e; - - if ((e = xh_get_(x, key))) { - memcpy(e->val, val, x->vwidth); - return e; - } - - if (x->count + 1 > XHASH_RESIZE_RATIO(x->size)) { - xh_resize_(x, x->size * 2 + 1); - } - - hash = x->hashf(key, x->data); - idx = ((unsigned)hash) % x->size; - e = x->allocf(NULL, x->voffset + x->vwidth); - e->next = x->buckets[idx]; - e->hash = hash; - e->key = ((char *)e) + x->koffset; - e->val = ((char *)e) + x->voffset; - memcpy((void *)e->key, key, x->kwidth); - memcpy(e->val, val, x->vwidth); - - if (x->head == NULL) { - x->head = x->tail = e; - e->fw = e->bw = NULL; - } else { - x->tail->bw = e; - e->fw = x->tail; - e->bw = NULL; - x->tail = e; - } - - x->count++; - - return x->buckets[idx] = e; -} - -PIC_INLINE void -xh_del_(xhash *x, const void *key) -{ - int hash; - size_t idx; - xh_entry *p, *q, *r; - - hash = x->hashf(key, x->data); - idx = ((unsigned)hash) % x->size; - if (x->buckets[idx]->hash == hash && x->equalf(key, x->buckets[idx]->key, x->data)) { - q = x->buckets[idx]; - if (q->fw == NULL) { - x->head = q->bw; - } else { - q->fw->bw = q->bw; - } - if (q->bw == NULL) { - x->tail = q->fw; - } else { - q->bw->fw = q->fw; - } - r = q->next; - x->allocf(q, 0); - x->buckets[idx] = r; - } - else { - for (p = x->buckets[idx]; ; p = p->next) { - if (p->next->hash == hash && x->equalf(key, p->next->key, x->data)) - break; - } - q = p->next; - if (q->fw == NULL) { - x->head = q->bw; - } else { - q->fw->bw = q->bw; - } - if (q->bw == NULL) { - x->tail = q->fw; - } else { - q->bw->fw = q->fw; - } - r = q->next; - x->allocf(q, 0); - p->next = r; - } - - x->count--; -} - -PIC_INLINE size_t -xh_size(xhash *x) -{ - return x->count; -} - -PIC_INLINE void -xh_clear(xhash *x) -{ - size_t i; - xh_entry *e, *d; - - for (i = 0; i < x->size; ++i) { - e = x->buckets[i]; - while (e) { - d = e->next; - x->allocf(e, 0); - e = d; - } - x->buckets[i] = NULL; - } - - x->head = x->tail = NULL; - x->count = 0; -} - -PIC_INLINE void -xh_destroy(xhash *x) -{ - xh_clear(x); - x->allocf(x->buckets, 0); -} - -/* string map */ - -PIC_INLINE int -xh_str_hash(const void *key, void *data) -{ - const char *str = *(const char **)key; - int hash = 0; - - (void)data; - - while (*str) { - hash = hash * 31 + *str++; - } - return hash; -} - -PIC_INLINE int -xh_str_equal(const void *key1, const void *key2, void *data) -{ - const char *s1 = *(const char **)key1, *s2 = *(const char **)key2; - - (void)data; - - return strcmp(s1, s2) == 0; -} - -#define xh_init_str(x, width) \ - xh_init_(x, XHASH_ALLOCATOR, sizeof(const char *), width, xh_str_hash, xh_str_equal, NULL); - -PIC_INLINE xh_entry * -xh_get_str(xhash *x, const char *key) -{ - return xh_get_(x, &key); -} - -PIC_INLINE xh_entry * -xh_put_str(xhash *x, const char *key, void *val) -{ - return xh_put_(x, &key, val); -} - -PIC_INLINE void -xh_del_str(xhash *x, const char *key) -{ - xh_del_(x, &key); -} - -/* object map */ - -PIC_INLINE int -xh_ptr_hash(const void *key, void *data) -{ - (void)data; - - return (int)(size_t)*(const void **)key; -} - -PIC_INLINE int -xh_ptr_equal(const void *key1, const void *key2, void *data) -{ - (void) data; - - return *(const void **)key1 == *(const void **)key2; -} - -#define xh_init_ptr(x, width) \ - xh_init_(x, XHASH_ALLOCATOR, sizeof(const void *), width, xh_ptr_hash, xh_ptr_equal, NULL); - -PIC_INLINE xh_entry * -xh_get_ptr(xhash *x, const void *key) -{ - return xh_get_(x, &key); -} - -PIC_INLINE xh_entry * -xh_put_ptr(xhash *x, const void *key, void *val) -{ - return xh_put_(x, &key, val); -} - -PIC_INLINE void -xh_del_ptr(xhash *x, const void *key) -{ - xh_del_(x, &key); -} - -/* int map */ - -PIC_INLINE int -xh_int_hash(const void *key, void *data) -{ - (void)data; - - return *(int *)key; -} - -PIC_INLINE int -xh_int_equal(const void *key1, const void *key2, void *data) -{ - (void)data; - - return *(int *)key1 == *(int *)key2; -} - -#define xh_init_int(x, width) \ - xh_init_(x, XHASH_ALLOCATOR, sizeof(int), width, xh_int_hash, xh_int_equal, NULL); - -PIC_INLINE xh_entry * -xh_get_int(xhash *x, int key) -{ - return xh_get_(x, &key); -} - -PIC_INLINE xh_entry * -xh_put_int(xhash *x, int key, void *val) -{ - return xh_put_(x, &key, val); -} - -PIC_INLINE void -xh_del_int(xhash *x, int key) -{ - xh_del_(x, &key); -} - -/** iteration */ - -PIC_INLINE xh_entry * -xh_begin(xhash *x) -{ - return x->head; -} - -PIC_INLINE xh_entry * -xh_next(xh_entry *e) -{ - return e->bw; -} - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/extlib/benz/include/picrin/xvect.h b/extlib/benz/include/picrin/xvect.h deleted file mode 100644 index 44db4d8e..00000000 --- a/extlib/benz/include/picrin/xvect.h +++ /dev/null @@ -1,76 +0,0 @@ -#ifndef XVECT_H__ -#define XVECT_H__ - -/* The MIT License - - Copyright (c) 2008, by Attractive Chaos - Copyright (c) 2014, by Yuichi Nishiwaki - - Permission is hereby granted, free of charge, to any person obtaining - a copy of this software and associated documentation files (the - "Software"), to deal in the Software without restriction, including - without limitation the rights to use, copy, modify, merge, publish, - distribute, sublicense, and/or sell copies of the Software, and to - permit persons to whom the Software is furnished to do so, subject to - the following conditions: - - The above copyright notice and this permission notice shall be - included in all copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS - BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN - ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN - CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - SOFTWARE. -*/ - -#define xv_realloc(P,Z) pic_realloc(pic,P,Z) -#define xv_free(P) pic_free(pic,P) - -#define xv_roundup32(x) \ - (--(x), (x)|=(x)>>1, (x)|=(x)>>2, (x)|=(x)>>4, (x)|=(x)>>8, (x)|=(x)>>16, ++(x)) - -#define xvect_t(type) struct { size_t n, m; type *a; } -#define xv_init(v) ((v).n = (v).m = 0, (v).a = 0) -#define xv_destroy(v) xv_free((v).a) -#define xv_A(v, i) ((v).a[(i)]) -#define xv_pop(v) ((v).a[--(v).n]) -#define xv_size(v) ((v).n) -#define xv_max(v) ((v).m) - -#define xv_resize(type, v, s) \ - ((v).m = (s), (v).a = (type*)xv_realloc((v).a, sizeof(type) * (v).m)) - -#define xv_copy(type, v1, v0) \ - do { \ - if ((v1).m < (v0).n) xv_resize(type, v1, (v0).n); \ - (v1).n = (v0).n; \ - memcpy((v1).a, (v0).a, sizeof(type) * (v0).n); \ - } while (0) \ - -#define xv_push(type, v, x) \ - do { \ - if ((v).n == (v).m) { \ - (v).m = (v).m? (v).m<<1 : (size_t)2; \ - (v).a = (type*)xv_realloc((v).a, sizeof(type) * (v).m); \ - } \ - (v).a[(v).n++] = (x); \ - } while (0) - -#define xv_pushp(type, v) \ - (((v).n == (v).m)? \ - ((v).m = ((v).m? (v).m<<1 : (size_t)2), \ - (v).a = (type*)xv_realloc((v).a, sizeof(type) * (v).m), 0) \ - : 0), ((v).a + ((v).n++)) - -#define xv_a(type, v, i) \ - (((v).m <= (size_t)(i)? \ - ((v).m = (v).n = (i) + 1, xv_roundup32((v).m), \ - (v).a = (type*)xv_realloc((v).a, sizeof(type) * (v).m), 0) \ - : (v).n <= (size_t)(i)? (v).n = (i) + 1 \ - : (size_t)0), (v).a[(i)]) - -#endif diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index 8e6516ad..53cf51d6 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -9,10 +9,10 @@ setup_default_env(pic_state *pic, struct pic_env *env) { void pic_define_syntactic_keyword(pic_state *, struct pic_env *, pic_sym *, pic_sym *); - pic_define_syntactic_keyword(pic, env, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY); - pic_define_syntactic_keyword(pic, env, pic->sIMPORT, pic->rIMPORT); - pic_define_syntactic_keyword(pic, env, pic->sEXPORT, pic->rEXPORT); - pic_define_syntactic_keyword(pic, env, pic->sCOND_EXPAND, pic->rCOND_EXPAND); + pic_define_syntactic_keyword(pic, env, pic->sDEFINE_LIBRARY, pic->uDEFINE_LIBRARY); + pic_define_syntactic_keyword(pic, env, pic->sIMPORT, pic->uIMPORT); + pic_define_syntactic_keyword(pic, env, pic->sEXPORT, pic->uEXPORT); + pic_define_syntactic_keyword(pic, env, pic->sCOND_EXPAND, pic->uCOND_EXPAND); } struct pic_lib * @@ -54,271 +54,159 @@ pic_find_library(pic_state *pic, pic_value spec) return pic_lib_ptr(pic_cdr(pic, v)); } -static void -import_table(pic_state *pic, pic_value spec, struct pic_dict *imports) +void +pic_import(pic_state *pic, struct pic_lib *lib) { - struct pic_lib *lib; - struct pic_dict *table; - pic_value val, tmp, prefix, it; - pic_sym *sym, *id, *tag, *nick; - xh_entry *iter; + pic_sym *name, *realname, *uid; + khiter_t it; - table = pic_make_dict(pic); + pic_dict_for_each (name, lib->exports, it) { + realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, name)); - if (pic_pair_p(spec) && pic_sym_p(pic_car(pic, spec))) { - - tag = pic_sym_ptr(pic_car(pic, spec)); - - if (tag == pic->sONLY) { - import_table(pic, pic_cadr(pic, spec), table); - - pic_for_each (val, pic_cddr(pic, spec), it) { - pic_dict_set(pic, imports, pic_sym_ptr(val), pic_dict_ref(pic, table, pic_sym_ptr(val))); - } - return; - } - if (tag == pic->sRENAME) { - import_table(pic, pic_cadr(pic, spec), imports); - - pic_for_each (val, pic_cddr(pic, spec), it) { - tmp = pic_dict_ref(pic, imports, pic_sym_ptr(pic_car(pic, val))); - pic_dict_del(pic, imports, pic_sym_ptr(pic_car(pic, val))); - pic_dict_set(pic, imports, pic_sym_ptr(pic_cadr(pic, val)), tmp); - } - return; - } - if (tag == pic->sPREFIX) { - import_table(pic, pic_cadr(pic, spec), table); - - prefix = pic_list_ref(pic, spec, 2); - pic_dict_for_each (sym, table, iter) { - id = pic_intern(pic, pic_format(pic, "~s~s", prefix, pic_obj_value(sym))); - pic_dict_set(pic, imports, id, pic_dict_ref(pic, table, sym)); - } - return; - } - if (tag == pic->sEXCEPT) { - import_table(pic, pic_cadr(pic, spec), imports); - pic_for_each (val, pic_cddr(pic, spec), it) { - pic_dict_del(pic, imports, pic_sym_ptr(val)); - } - return; - } - } - lib = pic_find_library(pic, spec); - if (! lib) { - pic_errorf(pic, "library not found: ~a", spec); - } - pic_dict_for_each (nick, lib->exports, iter) { - pic_sym *realname, *rename; - - realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, nick)); - - if ((rename = pic_find_rename(pic, lib->env, realname)) == NULL) { + if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(realname))) == NULL) { pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname)); } - pic_dict_set(pic, imports, nick, pic_obj_value(rename)); + pic_put_variable(pic, pic->lib->env, pic_obj_value(name), uid); } } -static void -import(pic_state *pic, pic_value spec) -{ - struct pic_dict *imports; - pic_sym *sym; - xh_entry *it; - - imports = pic_make_dict(pic); - - import_table(pic, spec, imports); - - pic_dict_for_each (sym, imports, it) { - pic_put_rename(pic, pic->lib->env, sym, pic_sym_ptr(pic_dict_ref(pic, imports, sym))); - } -} - -static void -export(pic_state *pic, pic_value spec) -{ - pic_sym *sRENAME = pic_intern_cstr(pic, "rename"); - pic_value a, b; - - if (pic_sym_p(spec)) { /* (export a) */ - a = b = spec; - } else { /* (export (rename a b)) */ - if (! pic_list_p(spec)) - goto fail; - if (! (pic_length(pic, spec) == 3)) - goto fail; - if (! pic_eq_p(pic_car(pic, spec), pic_obj_value(sRENAME))) - goto fail; - if (! pic_sym_p(a = pic_list_ref(pic, spec, 1))) - goto fail; - if (! pic_sym_p(b = pic_list_ref(pic, spec, 2))) - goto fail; - } - -#if DEBUG - printf("* exporting %s as %s\n", pic_symbol_name(pic, pic_sym_ptr(b)), pic_symbol_name(pic, pic_sym_ptr(a))); -#endif - - pic_dict_set(pic, pic->lib->exports, pic_sym_ptr(b), a); - - return; - - fail: - pic_errorf(pic, "illegal export spec: ~s", spec); -} - void -pic_import(pic_state *pic, pic_value spec) +pic_export(pic_state *pic, pic_sym *name) { - import(pic, spec); + pic_dict_set(pic, pic->lib->exports, name, pic_obj_value(name)); } -void -pic_import_library(pic_state *pic, struct pic_lib *lib) +static pic_value +pic_lib_make_library(pic_state *pic) { - import(pic, lib->name); + pic_value name; + + pic_get_args(pic, "o", &name); + + return pic_obj_value(pic_make_library(pic, name)); } -void -pic_export(pic_state *pic, pic_sym *sym) +static pic_value +pic_lib_find_library(pic_state *pic) { - export(pic, pic_obj_value(sym)); -} + pic_value name; + struct pic_lib *lib; -static bool -condexpand(pic_state *pic, pic_value clause) -{ - pic_sym *tag; - pic_value c, feature, it; + pic_get_args(pic, "o", &name); - if (pic_eq_p(clause, pic_obj_value(pic->sELSE))) { - return true; + if ((lib = pic_find_library(pic, name)) == NULL) { + return pic_false_value(); } - if (pic_sym_p(clause)) { - pic_for_each (feature, pic->features, it) { - if(pic_eq_p(feature, clause)) - return true; - } - return false; + return pic_obj_value(lib); +} + +static pic_value +pic_lib_current_library(pic_state *pic) +{ + pic_value lib; + size_t n; + + n = pic_get_args(pic, "|o", &lib); + + if (n == 0) { + return pic_obj_value(pic->lib); + } + else { + pic_assert_type(pic, lib, lib); + + pic->lib = pic_lib_ptr(lib); + + return pic_undef_value(); + } +} + +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; + + pic_get_args(pic, "om|m", &lib_opt, &name, &alias); + + pic_assert_type(pic, lib_opt, lib); + + if (alias == NULL) { + alias = name; } - if (! (pic_pair_p(clause) && pic_sym_p(pic_car(pic, clause)))) { - pic_errorf(pic, "invalid 'cond-expand' clause ~s", clause); + lib = pic_lib_ptr(lib_opt); + + if (! pic_dict_has(pic, lib->exports, name)) { + pic_errorf(pic, "attempted to import undefined variable '~s'", pic_obj_value(name)); } else { - tag = pic_sym_ptr(pic_car(pic, clause)); + realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, name)); } - if (tag == pic->sLIBRARY) { - return pic_find_library(pic, pic_list_ref(pic, clause, 1)) != NULL; - } - if (tag == pic->sNOT) { - return ! condexpand(pic, pic_list_ref(pic, clause, 1)); - } - if (tag == pic->sAND) { - pic_for_each (c, pic_cdr(pic, clause), it) { - if (! condexpand(pic, c)) - return false; - } - return true; - } - if (tag == pic->sOR) { - pic_for_each (c, pic_cdr(pic, clause), it) { - if (condexpand(pic, c)) - return true; - } - return false; - } - - pic_errorf(pic, "unknown 'cond-expand' directive ~s", clause); -} - -static pic_value -pic_lib_condexpand(pic_state *pic) -{ - pic_value *clauses; - size_t argc, i; - - pic_get_args(pic, "*", &argc, &clauses); - - for (i = 0; i < argc; i++) { - if (condexpand(pic, pic_car(pic, clauses[i]))) { - return pic_cons(pic, pic_obj_value(pic->rBEGIN), pic_cdr(pic, clauses[i])); - } + if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(realname))) == NULL) { + pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname)); + } else { + pic_put_variable(pic, pic->lib->env, pic_obj_value(alias), uid); } return pic_undef_value(); } static pic_value -pic_lib_import(pic_state *pic) +pic_lib_library_export(pic_state *pic) { - size_t argc, i; - pic_value *argv; + pic_sym *name, *alias = NULL; - pic_get_args(pic, "*", &argc, &argv); + pic_get_args(pic, "m|m", &name, &alias); - for (i = 0; i < argc; ++i) { - import(pic, argv[i]); + if (alias == NULL) { + alias = name; } + pic_dict_set(pic, pic->lib->exports, alias, pic_obj_value(name)); + return pic_undef_value(); } static pic_value -pic_lib_export(pic_state *pic) +pic_lib_library_exports(pic_state *pic) { - size_t argc, i; - pic_value *argv; + pic_value lib, exports = pic_nil_value(); + pic_sym *sym; + khiter_t it; - pic_get_args(pic, "*", &argc, &argv); + pic_get_args(pic, "o", &lib); - for (i = 0; i < argc; ++i) { - export(pic, argv[i]); + pic_assert_type(pic, lib, lib); + + pic_dict_for_each (sym, pic_lib_ptr(lib)->exports, it) { + pic_push(pic, pic_obj_value(sym), exports); } - return pic_undef_value(); + return exports; } static pic_value -pic_lib_define_library(pic_state *pic) +pic_lib_library_environment(pic_state *pic) { - struct pic_lib *lib, *prev = pic->lib; - size_t argc, i; - pic_value spec, *argv; + pic_value lib; - pic_get_args(pic, "o*", &spec, &argc, &argv); + pic_get_args(pic, "o", &lib); - if ((lib = pic_find_library(pic, spec)) == NULL) { - lib = pic_make_library(pic, spec); - } + pic_assert_type(pic, lib, lib); - pic_try { - pic->lib = lib; - - for (i = 0; i < argc; ++i) { - pic_void(pic_eval(pic, argv[i], pic->lib)); - } - - pic->lib = prev; - } - pic_catch { - pic->lib = prev; /* restores pic->lib even if an error occured */ - pic_raise(pic, pic->err); - } - - return pic_undef_value(); + return pic_obj_value(pic_lib_ptr(lib)->env); } void pic_init_lib(pic_state *pic) { - void pic_defmacro(pic_state *, pic_sym *, pic_sym *, pic_func_t); + pic_defun(pic, "make-library", pic_lib_make_library); + pic_defun(pic, "find-library", pic_lib_find_library); + pic_defun(pic, "library-exports", pic_lib_library_exports); + pic_defun(pic, "library-environment", pic_lib_library_environment); - pic_defmacro(pic, pic->sCOND_EXPAND, pic->rCOND_EXPAND, pic_lib_condexpand); - pic_defmacro(pic, pic->sIMPORT, pic->rIMPORT, pic_lib_import); - pic_defmacro(pic, pic->sEXPORT, pic->rEXPORT, pic_lib_export); - pic_defmacro(pic, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY, pic_lib_define_library); + pic_defun(pic, "current-library", pic_lib_current_library); + pic_defun(pic, "library-import", pic_lib_library_import); + pic_defun(pic, "library-export", pic_lib_library_export); } diff --git a/extlib/benz/load.c b/extlib/benz/load.c index 53220101..cd609afe 100644 --- a/extlib/benz/load.c +++ b/extlib/benz/load.c @@ -8,18 +8,12 @@ void pic_load_port(pic_state *pic, struct pic_port *port) { pic_value form; + size_t ai = pic_gc_arena_preserve(pic); - pic_try { - size_t ai = pic_gc_arena_preserve(pic); + while (! pic_eof_p(form = pic_read(pic, port))) { + pic_eval(pic, form, pic->lib->env); - while (! pic_eof_p(form = pic_read(pic, port))) { - pic_eval(pic, form, pic->lib); - - pic_gc_arena_restore(pic, ai); - } - } - pic_catch { - pic_errorf(pic, "load error: %s", pic_errmsg(pic)); + pic_gc_arena_restore(pic, ai); } } @@ -28,7 +22,13 @@ pic_load_cstr(pic_state *pic, const char *src) { struct pic_port *port = pic_open_input_string(pic, src); - pic_load_port(pic, port); + pic_try { + pic_load_port(pic, port); + } + pic_catch { + pic_close_port(pic, port); + pic_raise(pic, pic->err); + } pic_close_port(pic, port); } diff --git a/extlib/benz/macro.c b/extlib/benz/macro.c index a36a8c8c..cac07fd5 100644 --- a/extlib/benz/macro.c +++ b/extlib/benz/macro.c @@ -4,434 +4,99 @@ #include "picrin.h" -pic_sym * -pic_add_rename(pic_state *pic, struct pic_env *env, pic_sym *sym) +KHASH_DEFINE(env, void *, pic_sym *, kh_ptr_hash_func, kh_ptr_hash_equal) + +bool +pic_var_p(pic_value obj) { - pic_sym *rename = pic_gensym(pic, sym); - - pic_put_rename(pic, env, sym, rename); - - return rename; + return pic_sym_p(obj) || pic_id_p(obj); } -void -pic_put_rename(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *rename) +struct pic_id * +pic_make_id(pic_state *pic, pic_value var, struct pic_env *env) { - pic_dict_set(pic, env->map, sym, pic_obj_value(rename)); -} + struct pic_id *id; -pic_sym * -pic_find_rename(pic_state *pic, struct pic_env *env, pic_sym *sym) -{ - if (! pic_dict_has(pic, env->map, sym)) { - return NULL; - } - return pic_sym_ptr(pic_dict_ref(pic, env->map, sym)); -} + assert(pic_var_p(var)); -static void -define_macro(pic_state *pic, pic_sym *rename, struct pic_proc *mac) -{ - pic_dict_set(pic, pic->macros, rename, pic_obj_value(mac)); -} - -static struct pic_proc * -find_macro(pic_state *pic, pic_sym *rename) -{ - if (! pic_dict_has(pic, pic->macros, rename)) { - return NULL; - } - return pic_proc_ptr(pic_dict_ref(pic, pic->macros, rename)); -} - -static pic_sym * -make_identifier(pic_state *pic, pic_sym *sym, struct pic_env *env) -{ - pic_sym *rename; - - while (true) { - if ((rename = pic_find_rename(pic, env, sym)) != NULL) { - return rename; - } - if (! env->up) - break; - env = env->up; - } - if (! pic_interned_p(pic, sym)) { - return sym; - } - else { - return pic_gensym(pic, sym); - } -} - -static pic_value macroexpand(pic_state *, pic_value, struct pic_env *); -static pic_value macroexpand_lambda(pic_state *, pic_value, struct pic_env *); - -static pic_value -macroexpand_symbol(pic_state *pic, pic_sym *sym, struct pic_env *env) -{ - return pic_obj_value(make_identifier(pic, sym, env)); -} - -static pic_value -macroexpand_quote(pic_state *pic, pic_value expr) -{ - return pic_cons(pic, pic_obj_value(pic->rQUOTE), pic_cdr(pic, expr)); -} - -static pic_value -macroexpand_list(pic_state *pic, pic_value obj, struct pic_env *env) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value x, head, tail; - - if (pic_pair_p(obj)) { - head = macroexpand(pic, pic_car(pic, obj), env); - tail = macroexpand_list(pic, pic_cdr(pic, obj), env); - x = pic_cons(pic, head, tail); - } else { - x = macroexpand(pic, obj, env); - } - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, x); - return x; -} - -static pic_value -macroexpand_defer(pic_state *pic, pic_value expr, struct pic_env *env) -{ - pic_value skel = pic_list1(pic, pic_invalid_value()); /* (#) */ - - pic_push(pic, pic_cons(pic, expr, skel), env->defer); - - return skel; -} - -static void -macroexpand_deferred(pic_state *pic, struct pic_env *env) -{ - pic_value defer, val, src, dst, it; - - pic_for_each (defer, pic_reverse(pic, env->defer), it) { - src = pic_car(pic, defer); - dst = pic_cdr(pic, defer); - - val = macroexpand_lambda(pic, src, env); - - /* copy */ - pic_pair_ptr(dst)->car = pic_car(pic, val); - pic_pair_ptr(dst)->cdr = pic_cdr(pic, val); - } - - env->defer = pic_nil_value(); -} - -static pic_value -macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_env *env) -{ - pic_value formal, body; - struct pic_env *in; - pic_value a; - - if (pic_length(pic, expr) < 2) { - pic_errorf(pic, "syntax error"); - } - - in = pic_make_env(pic, env); - - for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) { - pic_value v = pic_car(pic, a); - - if (! pic_sym_p(v)) { - pic_errorf(pic, "syntax error"); - } - pic_add_rename(pic, in, pic_sym_ptr(v)); - } - if (pic_sym_p(a)) { - pic_add_rename(pic, in, pic_sym_ptr(a)); - } - else if (! pic_nil_p(a)) { - pic_errorf(pic, "syntax error"); - } - - formal = macroexpand_list(pic, pic_cadr(pic, expr), in); - body = macroexpand_list(pic, pic_cddr(pic, expr), in); - - macroexpand_deferred(pic, in); - - return pic_cons(pic, pic_obj_value(pic->rLAMBDA), pic_cons(pic, formal, body)); -} - -static pic_value -macroexpand_define(pic_state *pic, pic_value expr, struct pic_env *env) -{ - pic_sym *sym, *rename; - pic_value var, val; - - while (pic_length(pic, expr) >= 2 && pic_pair_p(pic_cadr(pic, expr))) { - var = pic_car(pic, pic_cadr(pic, expr)); - val = pic_cdr(pic, pic_cadr(pic, expr)); - - expr = pic_list3(pic, pic_obj_value(pic->rDEFINE), var, pic_cons(pic, pic_obj_value(pic->rLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr)))); - } - - if (pic_length(pic, expr) != 3) { - pic_errorf(pic, "syntax error"); - } - - var = pic_cadr(pic, expr); - if (! pic_sym_p(var)) { - pic_errorf(pic, "binding to non-symbol object"); - } - sym = pic_sym_ptr(var); - if ((rename = pic_find_rename(pic, env, sym)) == NULL) { - rename = pic_add_rename(pic, env, sym); - } - val = macroexpand(pic, pic_list_ref(pic, expr, 2), env); - - return pic_list3(pic, pic_obj_value(pic->rDEFINE), pic_obj_value(rename), val); -} - -static pic_value -macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_env *env) -{ - pic_value var, val; - pic_sym *sym, *rename; - - if (pic_length(pic, expr) != 3) { - pic_errorf(pic, "syntax error"); - } - - var = pic_cadr(pic, expr); - if (! pic_sym_p(var)) { - pic_errorf(pic, "binding to non-symbol object"); - } - sym = pic_sym_ptr(var); - if ((rename = pic_find_rename(pic, env, sym)) == NULL) { - rename = pic_add_rename(pic, env, sym); - } else { - pic_warnf(pic, "redefining syntax variable: ~s", pic_obj_value(sym)); - } - - val = pic_cadr(pic, pic_cdr(pic, expr)); - - pic_try { - val = pic_eval(pic, val, pic->lib); - } pic_catch { - pic_errorf(pic, "macroexpand error while definition: %s", pic_errmsg(pic)); - } - - if (! pic_proc_p(val)) { - pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); - } - - val = pic_apply1(pic, pic_proc_ptr(val), pic_obj_value(env)); - - if (! pic_proc_p(val)) { - pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); - } - - define_macro(pic, rename, pic_proc_ptr(val)); - - return pic_undef_value(); -} - -static pic_value -macroexpand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct pic_env *env) -{ - pic_value v, args; - -#if DEBUG - puts("before expand-1:"); - pic_debug(pic, expr); - puts(""); -#endif - - args = pic_list2(pic, expr, pic_obj_value(env)); - - pic_try { - v = pic_apply(pic, mac, args); - } pic_catch { - pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic)); - } - -#if DEBUG - puts("after expand-1:"); - pic_debug(pic, v); - puts(""); -#endif - - return v; -} - -static pic_value -macroexpand_node(pic_state *pic, pic_value expr, struct pic_env *env) -{ - switch (pic_type(expr)) { - case PIC_TT_SYMBOL: { - return macroexpand_symbol(pic, pic_sym_ptr(expr), env); - } - case PIC_TT_PAIR: { - pic_value car; - struct pic_proc *mac; - - if (! pic_list_p(expr)) { - pic_errorf(pic, "cannot macroexpand improper list: ~s", expr); - } - - car = macroexpand(pic, pic_car(pic, expr), env); - if (pic_sym_p(car)) { - pic_sym *tag = pic_sym_ptr(car); - - if (tag == pic->rDEFINE_SYNTAX) { - return macroexpand_defsyntax(pic, expr, env); - } - else if (tag == pic->rLAMBDA) { - return macroexpand_defer(pic, expr, env); - } - else if (tag == pic->rDEFINE) { - return macroexpand_define(pic, expr, env); - } - else if (tag == pic->rQUOTE) { - return macroexpand_quote(pic, expr); - } - - if ((mac = find_macro(pic, tag)) != NULL) { - return macroexpand_node(pic, macroexpand_macro(pic, mac, expr, env), env); - } - } - - return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), env)); - } - default: - return expr; - } -} - -static pic_value -macroexpand(pic_state *pic, pic_value expr, struct pic_env *env) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value v; - -#if DEBUG - printf("[macroexpand] expanding... "); - pic_debug(pic, expr); - puts(""); -#endif - - v = macroexpand_node(pic, expr, env); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, v); - return v; -} - -pic_value -pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib) -{ - struct pic_lib *prev; - pic_value v; - -#if DEBUG - puts("before expand:"); - pic_debug(pic, expr); - puts(""); -#endif - - /* change library for macro-expansion time processing */ - prev = pic->lib; - pic->lib = lib; - - lib->env->defer = pic_nil_value(); /* the last expansion could fail and leave defer field old */ - - v = macroexpand(pic, expr, lib->env); - - macroexpand_deferred(pic, lib->env); - - pic->lib = prev; - -#if DEBUG - puts("after expand:"); - pic_debug(pic, v); - puts(""); -#endif - - return v; + id = (struct pic_id *)pic_obj_alloc(pic, sizeof(struct pic_id), PIC_TT_ID); + id->var = var; + id->env = env; + return id; } struct pic_env * pic_make_env(pic_state *pic, struct pic_env *up) { struct pic_env *env; - struct pic_dict *map; - - map = pic_make_dict(pic); env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV); env->up = up; - env->defer = pic_nil_value(); - env->map = map; - + kh_init(env, &env->map); return env; } -static pic_value -defmacro_call(pic_state *pic) +pic_sym * +pic_var_name(pic_state PIC_UNUSED(*pic), pic_value var) { - struct pic_proc *self = pic_get_proc(pic); - pic_value args, tmp, proc; + assert(pic_var_p(var)); - pic_get_args(pic, "oo", &args, &tmp); + while (pic_id_p(var)) { + var = pic_id_ptr(var)->var; + } + return pic_sym_ptr(var); +} - proc = pic_attr_ref(pic, pic_obj_value(self), "@@transformer"); +pic_sym * +pic_uniq(pic_state *pic, pic_value var) +{ + pic_str *str; - return pic_apply_trampoline(pic, pic_proc_ptr(proc), pic_cdr(pic, args)); + assert(pic_var_p(var)); + + str = pic_format(pic, "%s.%d", pic_symbol_name(pic, pic_var_name(pic, var)), pic->ucnt++); + + return pic_intern(pic, str); +} + +pic_sym * +pic_add_variable(pic_state *pic, struct pic_env *env, pic_value var) +{ + pic_sym *uid; + + assert(pic_var_p(var)); + + uid = pic_uniq(pic, var); + + pic_put_variable(pic, env, var, uid); + + return uid; } void -pic_defmacro(pic_state *pic, pic_sym *name, pic_sym *id, pic_func_t func) +pic_put_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var, pic_sym *uid) { - struct pic_proc *proc, *trans; + khiter_t it; + int ret; - trans = pic_make_proc(pic, func, pic_symbol_name(pic, name)); + assert(pic_var_p(var)); - pic_put_rename(pic, pic->lib->env, name, id); - - proc = pic_make_proc(pic, defmacro_call, "defmacro_call"); - pic_attr_set(pic, pic_obj_value(proc), "@@transformer", pic_obj_value(trans)); - - /* symbol registration */ - define_macro(pic, id, proc); - - /* auto export! */ - pic_export(pic, name); + it = kh_put(env, &env->map, pic_ptr(var), &ret); + kh_val(&env->map, it) = uid; } -bool -pic_identifier_p(pic_state *pic, pic_value obj) +pic_sym * +pic_find_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var) { - return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym_ptr(obj)); -} + khiter_t it; -bool -pic_identifier_eq_p(pic_state *pic, struct pic_env *env1, pic_sym *sym1, struct pic_env *env2, pic_sym *sym2) -{ - pic_sym *a, *b; + assert(pic_var_p(var)); - a = make_identifier(pic, sym1, env1); - if (a != make_identifier(pic, sym1, env1)) { - a = sym1; + it = kh_get(env, &env->map, pic_ptr(var)); + if (it == kh_end(&env->map)) { + return NULL; } - - b = make_identifier(pic, sym2, env2); - if (b != make_identifier(pic, sym2, env2)) { - b = sym2; - } - - return pic_eq_p(pic_obj_value(a), pic_obj_value(b)); + return kh_val(&env->map, it); } static pic_value @@ -441,40 +106,83 @@ pic_macro_identifier_p(pic_state *pic) pic_get_args(pic, "o", &obj); - return pic_bool_value(pic_identifier_p(pic, obj)); + return pic_bool_value(pic_id_p(obj)); } static pic_value pic_macro_make_identifier(pic_state *pic) { - pic_value obj; - pic_sym *sym; + pic_value var, env; - pic_get_args(pic, "mo", &sym, &obj); + pic_get_args(pic, "oo", &var, &env); - pic_assert_type(pic, obj, env); + pic_assert_type(pic, var, var); + pic_assert_type(pic, env, env); - return pic_obj_value(make_identifier(pic, sym, pic_env_ptr(obj))); + return pic_obj_value(pic_make_id(pic, var, pic_env_ptr(env))); } static pic_value -pic_macro_identifier_eq_p(pic_state *pic) +pic_macro_identifier_variable(pic_state *pic) { - pic_sym *sym1, *sym2; - pic_value env1, env2; + pic_value id; - pic_get_args(pic, "omom", &env1, &sym1, &env2, &sym2); + pic_get_args(pic, "o", &id); - pic_assert_type(pic, env1, env); - pic_assert_type(pic, env2, env); + pic_assert_type(pic, id, id); - return pic_bool_value(pic_identifier_eq_p(pic, pic_env_ptr(env1), sym1, pic_env_ptr(env2), sym2)); + return pic_id_ptr(id)->var; +} + +static pic_value +pic_macro_identifier_environment(pic_state *pic) +{ + pic_value id; + + pic_get_args(pic, "o", &id); + + pic_assert_type(pic, id, id); + + return pic_obj_value(pic_id_ptr(id)->env); +} + +static pic_value +pic_macro_variable_p(pic_state *pic) +{ + pic_value obj; + + pic_get_args(pic, "o", &obj); + + return pic_bool_value(pic_var_p(obj)); +} + +static pic_value +pic_macro_variable_eq_p(pic_state *pic) +{ + size_t argc, i; + pic_value *argv; + + pic_get_args(pic, "*", &argc, &argv); + + for (i = 0; i < argc; ++i) { + if (! pic_var_p(argv[i])) { + return pic_false_value(); + } + if (! pic_equal_p(pic, argv[i], argv[0])) { + return pic_false_value(); + } + } + return pic_true_value(); } void pic_init_macro(pic_state *pic) { - pic_defun(pic, "identifier?", pic_macro_identifier_p); - pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p); pic_defun(pic, "make-identifier", pic_macro_make_identifier); + pic_defun(pic, "identifier?", pic_macro_identifier_p); + pic_defun(pic, "identifier-variable", pic_macro_identifier_variable); + pic_defun(pic, "identifier-environment", pic_macro_identifier_environment); + + pic_defun(pic, "variable?", pic_macro_variable_p); + pic_defun(pic, "variable=?", pic_macro_variable_eq_p); } diff --git a/extlib/benz/number.c b/extlib/benz/number.c index 80c7fab9..52eed9b3 100644 --- a/extlib/benz/number.c +++ b/extlib/benz/number.c @@ -574,7 +574,7 @@ pic_number_number_to_string(pic_state *pic) else { struct pic_port *port = pic_open_output_string(pic); - xfprintf(port->file, "%f", f); + xfprintf(pic, port->file, "%f", f); str = pic_get_output_string(pic, port); @@ -816,17 +816,17 @@ pic_init_number(pic_state *pic) pic_defun(pic, "inexact?", pic_number_inexact_p); pic_gc_arena_restore(pic, ai); - pic_defun_vm(pic, "=", pic->rEQ, pic_number_eq); - pic_defun_vm(pic, "<", pic->rLT, pic_number_lt); - pic_defun_vm(pic, ">", pic->rGT, pic_number_gt); - pic_defun_vm(pic, "<=", pic->rLE, pic_number_le); - pic_defun_vm(pic, ">=", pic->rGE, pic_number_ge); + pic_defun_vm(pic, "=", pic->uEQ, pic_number_eq); + pic_defun_vm(pic, "<", pic->uLT, pic_number_lt); + pic_defun_vm(pic, ">", pic->uGT, pic_number_gt); + pic_defun_vm(pic, "<=", pic->uLE, pic_number_le); + pic_defun_vm(pic, ">=", pic->uGE, pic_number_ge); pic_gc_arena_restore(pic, ai); - pic_defun_vm(pic, "+", pic->rADD, pic_number_add); - pic_defun_vm(pic, "-", pic->rSUB, pic_number_sub); - pic_defun_vm(pic, "*", pic->rMUL, pic_number_mul); - pic_defun_vm(pic, "/", pic->rDIV, pic_number_div); + pic_defun_vm(pic, "+", pic->uADD, pic_number_add); + pic_defun_vm(pic, "-", pic->uSUB, pic_number_sub); + pic_defun_vm(pic, "*", pic->uMUL, pic_number_mul); + pic_defun_vm(pic, "/", pic->uDIV, pic_number_div); pic_gc_arena_restore(pic, ai); pic_defun(pic, "abs", pic_number_abs); diff --git a/extlib/benz/pair.c b/extlib/benz/pair.c index b3da3b6d..91ecf3eb 100644 --- a/extlib/benz/pair.c +++ b/extlib/benz/pair.c @@ -762,11 +762,11 @@ pic_init_pair(pic_state *pic) { void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t); - pic_defun_vm(pic, "pair?", pic->rPAIRP, pic_pair_pair_p); - pic_defun_vm(pic, "cons", pic->rCONS, pic_pair_cons); - pic_defun_vm(pic, "car", pic->rCAR, pic_pair_car); - pic_defun_vm(pic, "cdr", pic->rCDR, pic_pair_cdr); - pic_defun_vm(pic, "null?", pic->rNILP, pic_pair_null_p); + pic_defun_vm(pic, "pair?", pic->uPAIRP, pic_pair_pair_p); + pic_defun_vm(pic, "cons", pic->uCONS, pic_pair_cons); + pic_defun_vm(pic, "car", pic->uCAR, pic_pair_car); + pic_defun_vm(pic, "cdr", pic->uCDR, pic_pair_cdr); + pic_defun_vm(pic, "null?", pic->uNILP, pic_pair_null_p); pic_defun(pic, "set-car!", pic_pair_set_car); pic_defun(pic, "set-cdr!", pic_pair_set_cdr); diff --git a/extlib/benz/port.c b/extlib/benz/port.c index 5b04f89b..bc5ab406 100644 --- a/extlib/benz/port.c +++ b/extlib/benz/port.c @@ -14,56 +14,171 @@ pic_eof_object() return v; } -struct pic_port * -pic_stdin(pic_state *pic) +static pic_value +pic_assert_port(pic_state *pic) { - pic_value obj; + struct pic_port *port; - obj = pic_funcall(pic, pic->PICRIN_BASE, "current-input-port", pic_nil_value()); + pic_get_args(pic, "p", &port); - return pic_port_ptr(obj); + return pic_obj_value(port); +} + +/* current-(input|output|error)-port */ + +#if PIC_ENABLE_STDIO + +static int +file_read(pic_state PIC_UNUSED(*pic), void *cookie, char *ptr, int size) { + FILE *file = cookie; + int r; + + size = 1; /* override size */ + + r = (int)fread(ptr, 1, (size_t)size, file); + if (r < size && ferror(file)) { + return -1; + } + if (r == 0 && feof(file)) { + clearerr(file); + } + return r; +} + +static int +file_write(pic_state PIC_UNUSED(*pic), void *cookie, const char *ptr, int size) { + FILE *file = cookie; + int r; + + r = (int)fwrite(ptr, 1, (size_t)size, file); + if (r < size) { + return -1; + } + fflush(cookie); + return r; +} + +static long +file_seek(pic_state PIC_UNUSED(*pic), void *cookie, long pos, int whence) { + switch (whence) { + case XSEEK_CUR: + whence = SEEK_CUR; + break; + case XSEEK_SET: + whence = SEEK_SET; + break; + case XSEEK_END: + whence = SEEK_END; + break; + } + if (fseek(cookie, pos, whence) == 0) { + return ftell(cookie); + } + return -1; +} + +static int +file_close(pic_state PIC_UNUSED(*pic), void *cookie) { + return fclose(cookie); +} + +static xFILE * +file_open(pic_state *pic, const char *name, const char *mode) { + FILE *fp; + + if ((fp = fopen(name, mode)) == NULL) { + return NULL; + } + + switch (*mode) { + case 'r': + return xfunopen(pic, fp, file_read, NULL, file_seek, file_close); + default: + return xfunopen(pic, fp, NULL, file_write, file_seek, file_close); + } } struct pic_port * -pic_stdout(pic_state *pic) -{ - pic_value obj; +pic_open_file(pic_state *pic, const char *name, int flags) { + struct pic_port *port; + xFILE *file; + char mode = 'r'; - obj = pic_funcall(pic, pic->PICRIN_BASE, "current-output-port", pic_nil_value()); + if ((flags & PIC_PORT_IN) == 0) { + mode = 'w'; + } + if ((file = file_open(pic, name, &mode)) == NULL) { + pic_str *msg = pic_format(pic, "could not open file '%s'", name); + pic_raise(pic, pic_obj_value(pic_make_error(pic, pic->sFILE, pic_str_cstr(pic, msg), pic_nil_value()))); + } - return pic_port_ptr(obj); + port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); + port->file = file; + port->flags = flags | PIC_PORT_OPEN; + + return port; } -struct pic_port * -pic_stderr(pic_state *pic) -{ - pic_value obj; +#else - obj = pic_funcall(pic, pic->PICRIN_BASE, "current-error-port", pic_nil_value()); +/* null file */ - return pic_port_ptr(obj); +static int +null_read(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie), char PIC_UNUSED(*ptr), int PIC_UNUSED(size)) { + return 0; } -struct pic_port * -pic_make_standard_port(pic_state *pic, xFILE *file, short dir) +static int +null_write(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie), const char PIC_UNUSED(*ptr), int size) { + return size; +} + +static long +null_seek(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie), long PIC_UNUSED(pos), int PIC_UNUSED(whence)) { + return 0; +} + +static int +null_close(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie)) { + return 0; +} + +#endif + +static void +pic_define_standard_port(pic_state *pic, const char *name, xFILE *file, int dir) { struct pic_port *port; port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); port->file = file; - port->flags = dir | PIC_PORT_TEXT; - port->status = PIC_PORT_OPEN; - return port; + port->flags = dir | PIC_PORT_TEXT | PIC_PORT_OPEN; + + pic_defvar(pic, name, pic_obj_value(port), pic_make_proc(pic, pic_assert_port)); } +#define DEFINE_STANDARD_PORT_ACCESSOR(name, var) \ + struct pic_port * \ + name(pic_state *pic) \ + { \ + pic_value obj; \ + \ + obj = pic_funcall0(pic, pic->PICRIN_BASE, var); \ + \ + return pic_port_ptr(obj); \ + } + +DEFINE_STANDARD_PORT_ACCESSOR(pic_stdin, "current-input-port") +DEFINE_STANDARD_PORT_ACCESSOR(pic_stdout, "current-output-port") +DEFINE_STANDARD_PORT_ACCESSOR(pic_stderr, "current-error-port") + struct strfile { - pic_state *pic; char *buf; long pos, end, capa; }; static int -string_read(void *cookie, char *ptr, int size) +string_read(pic_state PIC_UNUSED(*pic), void *cookie, char *ptr, int size) { struct strfile *m = cookie; @@ -75,13 +190,13 @@ string_read(void *cookie, char *ptr, int size) } static int -string_write(void *cookie, const char *ptr, int size) +string_write(pic_state *pic, void *cookie, const char *ptr, int size) { struct strfile *m = cookie; if (m->pos + size >= m->capa) { m->capa = (m->pos + size) * 2; - m->buf = pic_realloc(m->pic, m->buf, (size_t)m->capa); + m->buf = pic_realloc(pic, m->buf, (size_t)m->capa); } memcpy(m->buf + m->pos, ptr, size); m->pos += size; @@ -91,7 +206,7 @@ string_write(void *cookie, const char *ptr, int size) } static long -string_seek(void *cookie, long pos, int whence) +string_seek(pic_state PIC_UNUSED(*pic), void *cookie, long pos, int whence) { struct strfile *m = cookie; @@ -111,12 +226,12 @@ string_seek(void *cookie, long pos, int whence) } static int -string_close(void *cookie) +string_close(pic_state *pic, void *cookie) { struct strfile *m = cookie; - pic_free(m->pic, m->buf); - pic_free(m->pic, m); + pic_free(pic, m->buf); + pic_free(pic, m); return 0; } @@ -127,7 +242,6 @@ string_open(pic_state *pic, const char *data, size_t size) xFILE *file; m = pic_malloc(pic, sizeof(struct strfile)); - m->pic = pic; m->buf = pic_malloc(pic, size); m->pos = 0; m->end = size; @@ -136,13 +250,13 @@ string_open(pic_state *pic, const char *data, size_t size) if (data != NULL) { memcpy(m->buf, data, size); - file = xfunopen(m, string_read, NULL, string_seek, string_close); + file = xfunopen(pic, m, string_read, NULL, string_seek, string_close); } else { - file = xfunopen(m, NULL, string_write, string_seek, string_close); + file = xfunopen(pic, m, NULL, string_write, string_seek, string_close); } if (file == NULL) { - string_close(m); + string_close(pic, m); pic_error(pic, "could not open new output string/bytevector port", pic_nil_value()); } return file; @@ -155,8 +269,7 @@ pic_open_input_string(pic_state *pic, const char *str) port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); port->file = string_open(pic, str, strlen(str)); - port->flags = PIC_PORT_IN | PIC_PORT_TEXT; - port->status = PIC_PORT_OPEN; + port->flags = PIC_PORT_IN | PIC_PORT_TEXT | PIC_PORT_OPEN; return port; } @@ -168,8 +281,7 @@ pic_open_output_string(pic_state *pic) port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); port->file = string_open(pic, NULL, 0); - port->flags = PIC_PORT_OUT | PIC_PORT_TEXT; - port->status = PIC_PORT_OPEN; + port->flags = PIC_PORT_OUT | PIC_PORT_TEXT | PIC_PORT_OPEN; return port; } @@ -183,7 +295,7 @@ pic_get_output_string(pic_state *pic, struct pic_port *port) pic_errorf(pic, "get-output-string: port is not made by open-output-string"); } - xfflush(port->file); + xfflush(pic, port->file); s = port->file->vtable.cookie; @@ -193,10 +305,13 @@ pic_get_output_string(pic_state *pic, struct pic_port *port) void pic_close_port(pic_state *pic, struct pic_port *port) { - if (xfclose(port->file) == EOF) { + if ((port->flags & PIC_PORT_OPEN) == 0) { + return; + } + if (xfclose(pic, port->file) == EOF) { pic_errorf(pic, "close-port: failure"); } - port->status = PIC_PORT_CLOSE; + port->flags &= ~PIC_PORT_OPEN; } static pic_value @@ -315,7 +430,7 @@ pic_port_port_open_p(pic_state *pic) pic_get_args(pic, "p", &port); - return pic_bool_value(port->status == PIC_PORT_OPEN); + return pic_bool_value(port->flags & PIC_PORT_OPEN); } static pic_value @@ -330,7 +445,7 @@ pic_port_close_port(pic_state *pic) return pic_undef_value(); } -#define assert_port_profile(port, flgs, stat, caller) do { \ +#define assert_port_profile(port, flgs, caller) do { \ if ((port->flags & (flgs)) != (flgs)) { \ switch (flgs) { \ case PIC_PORT_IN: \ @@ -347,13 +462,8 @@ pic_port_close_port(pic_state *pic) pic_errorf(pic, caller ": expected output/binary port"); \ } \ } \ - if (port->status != stat) { \ - switch (stat) { \ - case PIC_PORT_OPEN: \ - pic_errorf(pic, caller ": expected open port"); \ - case PIC_PORT_CLOSE: \ - pic_errorf(pic, caller ": expected close port"); \ - } \ + if ((port->flags & PIC_PORT_OPEN) == 0) { \ + pic_errorf(pic, caller ": expected open port"); \ } \ } while (0) @@ -389,7 +499,7 @@ pic_port_get_output_string(pic_state *pic) pic_get_args(pic, "|p", &port); - assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "get-output-string"); + assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, "get-output-string"); return pic_obj_value(pic_get_output_string(pic, port)); } @@ -404,8 +514,7 @@ pic_port_open_input_blob(pic_state *pic) port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); port->file = string_open(pic, (const char *)blob->data, blob->len); - port->flags = PIC_PORT_IN | PIC_PORT_BINARY; - port->status = PIC_PORT_OPEN; + port->flags = PIC_PORT_IN | PIC_PORT_BINARY | PIC_PORT_OPEN; return pic_obj_value(port); } @@ -419,8 +528,7 @@ pic_port_open_output_bytevector(pic_state *pic) port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); port->file = string_open(pic, NULL, 0); - port->flags = PIC_PORT_OUT | PIC_PORT_BINARY; - port->status = PIC_PORT_OPEN; + port->flags = PIC_PORT_OUT | PIC_PORT_BINARY | PIC_PORT_OPEN; return pic_obj_value(port); } @@ -434,13 +542,13 @@ pic_port_get_output_bytevector(pic_state *pic) pic_get_args(pic, "|p", &port); - assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "get-output-bytevector"); + assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, "get-output-bytevector"); if (port->file->vtable.write != string_write) { pic_errorf(pic, "get-output-bytevector: port is not made by open-output-bytevector"); } - xfflush(port->file); + xfflush(pic, port->file); s = port->file->vtable.cookie; @@ -458,9 +566,9 @@ pic_port_read_char(pic_state *pic) pic_get_args(pic, "|p", &port); - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-char"); + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, "read-char"); - if ((c = xfgetc(port->file)) == EOF) { + if ((c = xfgetc(pic, port->file)) == EOF) { return pic_eof_object(); } else { @@ -476,9 +584,9 @@ pic_port_peek_char(pic_state *pic) pic_get_args(pic, "|p", &port); - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "peek-char"); + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, "peek-char"); - if ((c = xfgetc(port->file)) == EOF) { + if ((c = xfgetc(pic, port->file)) == EOF) { return pic_eof_object(); } else { @@ -493,23 +601,25 @@ pic_port_read_line(pic_state *pic) int c; struct pic_port *port = pic_stdin(pic), *buf; struct pic_string *str; + pic_value res = pic_eof_object(); pic_get_args(pic, "|p", &port); - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-line"); + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, "read-line"); buf = pic_open_output_string(pic); - while ((c = xfgetc(port->file)) != EOF && c != '\n') { - xfputc(c, buf->file); + while ((c = xfgetc(pic, port->file)) != EOF && c != '\n') { + xfputc(pic, c, buf->file); } str = pic_get_output_string(pic, buf); if (pic_str_len(str) == 0 && c == EOF) { - return pic_eof_object(); - } - else { - return pic_obj_value(str); + /* EOF */ + } else { + res = pic_obj_value(str); } + pic_close_port(pic, buf); + return res; } static pic_value @@ -517,7 +627,7 @@ pic_port_char_ready_p(pic_state *pic) { struct pic_port *port = pic_stdin(pic); - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "char-ready?"); + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, "char-ready?"); pic_get_args(pic, "|p", &port); @@ -530,28 +640,29 @@ pic_port_read_string(pic_state *pic){ pic_str *str; int k, i; int c; + pic_value res = pic_eof_object(); pic_get_args(pic, "i|p", &k, &port); - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-stritg"); + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, "read-stritg"); c = EOF; buf = pic_open_output_string(pic); for(i = 0; i < k; ++i) { - if((c = xfgetc(port->file)) == EOF){ + if((c = xfgetc(pic, port->file)) == EOF){ break; } - xfputc(c, buf->file); + xfputc(pic, c, buf->file); } str = pic_get_output_string(pic, buf); if (pic_str_len(str) == 0 && c == EOF) { - return pic_eof_object(); + /* EOF */ + } else { + res = pic_obj_value(str); } - else { - return pic_obj_value(str); - } - + pic_close_port(pic, buf); + return res; } static pic_value @@ -560,8 +671,8 @@ pic_port_read_byte(pic_state *pic){ int c; pic_get_args(pic, "|p", &port); - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-u8"); - if ((c = xfgetc(port->file)) == EOF) { + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, "read-u8"); + if ((c = xfgetc(pic, port->file)) == EOF) { return pic_eof_object(); } @@ -576,9 +687,9 @@ pic_port_peek_byte(pic_state *pic) pic_get_args(pic, "|p", &port); - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "peek-u8"); + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, "peek-u8"); - c = xfgetc(port->file); + c = xfgetc(pic, port->file); if (c == EOF) { return pic_eof_object(); } @@ -595,7 +706,7 @@ pic_port_byte_ready_p(pic_state *pic) pic_get_args(pic, "|p", &port); - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "u8-ready?"); + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, "u8-ready?"); return pic_true_value(); /* FIXME: always returns #t */ } @@ -610,11 +721,11 @@ pic_port_read_blob(pic_state *pic) pic_get_args(pic, "k|p", &k, &port); - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector"); + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, "read-bytevector"); blob = pic_make_blob(pic, k); - i = xfread(blob->data, sizeof(char), k, port->file); + i = xfread(pic, blob->data, sizeof(char), k, port->file); if (i == 0) { return pic_eof_object(); } @@ -644,7 +755,7 @@ pic_port_read_blob_ip(pic_state *pic) end = bv->len; } - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector!"); + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, "read-bytevector!"); if (end < start) { pic_errorf(pic, "read-bytevector!: end index must be greater than or equal to start index"); @@ -653,7 +764,7 @@ pic_port_read_blob_ip(pic_state *pic) len = end - start; buf = pic_calloc(pic, len, sizeof(char)); - i = xfread(buf, sizeof(char), len, port->file); + i = xfread(pic, buf, sizeof(char), len, port->file); memcpy(bv->data + start, buf, i); pic_free(pic, buf); @@ -672,9 +783,9 @@ pic_port_newline(pic_state *pic) pic_get_args(pic, "|p", &port); - assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "newline"); + assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, "newline"); - xfputs("\n", port->file); + xfputs(pic, "\n", port->file); return pic_undef_value(); } @@ -686,9 +797,9 @@ pic_port_write_char(pic_state *pic) pic_get_args(pic, "c|p", &c, &port); - assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "write-char"); + assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, "write-char"); - xfputc(c, port->file); + xfputc(pic, c, port->file); return pic_undef_value(); } @@ -709,10 +820,10 @@ pic_port_write_string(pic_state *pic) end = INT_MAX; } - assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "write-string"); + assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, "write-string"); for (i = start; i < end && str[i] != '\0'; ++i) { - xfputc(str[i], port->file); + xfputc(pic, str[i], port->file); } return pic_undef_value(); } @@ -725,9 +836,9 @@ pic_port_write_byte(pic_state *pic) pic_get_args(pic, "i|p", &i, &port); - assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "write-u8"); + assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, "write-u8"); - xfputc(i, port->file); + xfputc(pic, i, port->file); return pic_undef_value(); } @@ -749,10 +860,10 @@ pic_port_write_blob(pic_state *pic) end = blob->len; } - assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "write-bytevector"); + assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, "write-bytevector"); for (i = start; i < end; ++i) { - xfputc(blob->data[i], port->file); + xfputc(pic, blob->data[i], port->file); } return pic_undef_value(); } @@ -764,18 +875,40 @@ pic_port_flush(pic_state *pic) pic_get_args(pic, "|p", &port); - assert_port_profile(port, PIC_PORT_OUT, PIC_PORT_OPEN, "flush-output-port"); + assert_port_profile(port, PIC_PORT_OUT, "flush-output-port"); - xfflush(port->file); + xfflush(pic, port->file); return pic_undef_value(); } void pic_init_port(pic_state *pic) { - pic_defvar(pic, "current-input-port", pic_obj_value(pic->xSTDIN), NULL); - pic_defvar(pic, "current-output-port", pic_obj_value(pic->xSTDOUT), NULL); - pic_defvar(pic, "current-error-port", pic_obj_value(pic->xSTDERR), NULL); +#if PIC_ENABLE_STDIO +# define FILE_VTABLE { 0, file_read, file_write, file_seek, file_close } +#else +# define FILE_VTABLE { 0, null_read, null_write, null_seek, null_close } +#endif + + static const xFILE skel[3] = { + { { 0 }, 0, NULL, NULL, FILE_VTABLE, X_READ }, + { { 0 }, 0, NULL, NULL, FILE_VTABLE, X_WRITE | X_LNBUF }, + { { 0 }, 0, NULL, NULL, FILE_VTABLE, X_WRITE | X_UNBUF } + }; + + pic->files[0] = skel[0]; + pic->files[1] = skel[1]; + pic->files[2] = skel[2]; + +#if PIC_ENABLE_STDIO + pic->files[0].vtable.cookie = stdin; + pic->files[1].vtable.cookie = stdout; + pic->files[2].vtable.cookie = stderr; +#endif + + pic_define_standard_port(pic, "current-input-port", xstdin, PIC_PORT_IN); + pic_define_standard_port(pic, "current-output-port", xstdout, PIC_PORT_OUT); + pic_define_standard_port(pic, "current-error-port", xstderr, PIC_PORT_OUT); pic_defun(pic, "call-with-port", pic_port_call_with_port); diff --git a/extlib/benz/proc.c b/extlib/benz/proc.c index 9e5713c1..ea8d71d1 100644 --- a/extlib/benz/proc.c +++ b/extlib/benz/proc.c @@ -5,19 +5,13 @@ #include "picrin.h" struct pic_proc * -pic_make_proc(pic_state *pic, pic_func_t func, const char *name) +pic_make_proc(pic_state *pic, pic_func_t func) { struct pic_proc *proc; - pic_sym *sym; - - assert(name != NULL); - - sym = pic_intern_cstr(pic, name); proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC); proc->tag = PIC_PROC_TAG_FUNC; proc->u.f.func = func; - proc->u.f.name = sym; proc->u.f.env = NULL; return proc; } @@ -34,18 +28,6 @@ pic_make_proc_irep(pic_state *pic, struct pic_irep *irep, struct pic_context *cx return proc; } -pic_sym * -pic_proc_name(struct pic_proc *proc) -{ - switch (proc->tag) { - case PIC_PROC_TAG_FUNC: - return proc->u.f.name; - case PIC_PROC_TAG_IREP: - return proc->u.i.irep->name; - } - PIC_UNREACHABLE(); -} - struct pic_dict * pic_proc_env(pic_state *pic, struct pic_proc *proc) { diff --git a/extlib/benz/read.c b/extlib/benz/read.c index 8320af38..e37ca94c 100644 --- a/extlib/benz/read.c +++ b/extlib/benz/read.c @@ -4,6 +4,8 @@ #include "picrin.h" +KHASH_DEFINE(read, int, pic_value, kh_int_hash_func, kh_int_hash_equal) + static pic_value read(pic_state *pic, struct pic_port *port, int c); static pic_value read_nullable(pic_state *pic, struct pic_port *port, int c); @@ -18,39 +20,39 @@ read_error(pic_state *pic, const char *msg) } static int -skip(struct pic_port *port, int c) +skip(pic_state *pic, struct pic_port *port, int c) { while (isspace(c)) { - c = xfgetc(port->file); + c = xfgetc(pic, port->file); } return c; } static int -next(struct pic_port *port) +next(pic_state *pic, struct pic_port *port) { - return xfgetc(port->file); + return xfgetc(pic, port->file); } static int -peek(struct pic_port *port) +peek(pic_state *pic, struct pic_port *port) { int c; - xungetc((c = xfgetc(port->file)), port->file); + xungetc((c = xfgetc(pic, port->file)), port->file); return c; } static bool -expect(struct pic_port *port, const char *str) +expect(pic_state *pic, struct pic_port *port, const char *str) { int c; while ((c = (int)*str++) != 0) { - if (c != peek(port)) + if (c != peek(pic, port)) return false; - next(port); + next(pic, port); } return true; @@ -79,7 +81,7 @@ strcaseeq(const char *s1, const char *s2) static int case_fold(pic_state *pic, int c) { - if (pic->reader->typecase == PIC_CASE_FOLD) { + if (pic->reader.typecase == PIC_CASE_FOLD) { c = tolower(c); } return c; @@ -89,7 +91,7 @@ static pic_value read_comment(pic_state PIC_UNUSED(*pic), struct pic_port *port, int c) { do { - c = next(port); + c = next(pic, port); } while (! (c == EOF || c == '\n')); return pic_invalid_value(); @@ -101,11 +103,11 @@ read_block_comment(pic_state PIC_UNUSED(*pic), struct pic_port *port, int PIC_UN int x, y; int i = 1; - y = next(port); + y = next(pic, port); while (y != EOF && i > 0) { x = y; - y = next(port); + y = next(pic, port); if (x == '|' && y == '#') { i--; } @@ -120,7 +122,7 @@ read_block_comment(pic_state PIC_UNUSED(*pic), struct pic_port *port, int PIC_UN static pic_value read_datum_comment(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) { - read(pic, port, next(port)); + read(pic, port, next(pic, port)); return pic_invalid_value(); } @@ -128,16 +130,16 @@ read_datum_comment(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) static pic_value read_directive(pic_state *pic, struct pic_port *port, int c) { - switch (peek(port)) { + switch (peek(pic, port)) { case 'n': - if (expect(port, "no-fold-case")) { - pic->reader->typecase = PIC_CASE_DEFAULT; + if (expect(pic, port, "no-fold-case")) { + pic->reader.typecase = PIC_CASE_DEFAULT; return pic_invalid_value(); } break; case 'f': - if (expect(port, "fold-case")) { - pic->reader->typecase = PIC_CASE_FOLD; + if (expect(pic, port, "fold-case")) { + pic->reader.typecase = PIC_CASE_FOLD; return pic_invalid_value(); } break; @@ -146,26 +148,16 @@ read_directive(pic_state *pic, struct pic_port *port, int c) return read_comment(pic, port, c); } -static pic_value -read_eval(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) -{ - pic_value form; - - form = read(pic, port, next(port)); - - return pic_eval(pic, form, pic->lib); -} - static pic_value read_quote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) { - return pic_list2(pic, pic_obj_value(pic->sQUOTE), read(pic, port, next(port))); + return pic_list2(pic, pic_obj_value(pic->sQUOTE), read(pic, port, next(pic, port))); } static pic_value read_quasiquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) { - return pic_list2(pic, pic_obj_value(pic->sQUASIQUOTE), read(pic, port, next(port))); + return pic_list2(pic, pic_obj_value(pic->sQUASIQUOTE), read(pic, port, next(pic, port))); } static pic_value @@ -173,11 +165,35 @@ read_unquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) { pic_sym *tag = pic->sUNQUOTE; - if (peek(port) == '@') { + if (peek(pic, port) == '@') { tag = pic->sUNQUOTE_SPLICING; - next(port); + next(pic, port); } - return pic_list2(pic, pic_obj_value(tag), read(pic, port, next(port))); + return pic_list2(pic, pic_obj_value(tag), read(pic, port, next(pic, port))); +} + +static pic_value +read_syntax_quote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) +{ + return pic_list2(pic, pic_obj_value(pic->sSYNTAX_QUOTE), read(pic, port, next(pic, port))); +} + +static pic_value +read_syntax_quasiquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) +{ + return pic_list2(pic, pic_obj_value(pic->sSYNTAX_QUASIQUOTE), read(pic, port, next(pic, port))); +} + +static pic_value +read_syntax_unquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) +{ + pic_sym *tag = pic->sSYNTAX_UNQUOTE; + + if (peek(pic, port) == '@') { + tag = pic->sSYNTAX_UNQUOTE_SPLICING; + next(pic, port); + } + return pic_list2(pic, pic_obj_value(tag), read(pic, port, next(pic, port))); } static pic_value @@ -192,8 +208,8 @@ read_symbol(pic_state *pic, struct pic_port *port, int c) buf[0] = case_fold(pic, c); buf[1] = 0; - while (! isdelim(peek(port))) { - c = next(port); + while (! isdelim(peek(pic, port))) { + c = next(pic, port); len += 1; buf = pic_realloc(pic, buf, len + 1); buf[len - 1] = case_fold(pic, c); @@ -216,8 +232,8 @@ read_uinteger(pic_state *pic, struct pic_port *port, int c) } u = c - '0'; - while (isdigit(c = peek(port))) { - u = u * 10 + next(port) - '0'; + while (isdigit(c = peek(pic, port))) { + u = u * 10 + next(pic, port) - '0'; } return u; @@ -228,19 +244,19 @@ read_suffix(pic_state *pic, struct pic_port *port) { int c, s = 1; - c = peek(port); + c = peek(pic, port); if (c != 'e' && c != 'E') { return 0; } - next(port); + next(pic, port); - switch ((c = next(port))) { + switch ((c = next(pic, port))) { case '-': s = -1; case '+': - c = next(port); + c = next(pic, port); default: return s * read_uinteger(pic, port, c); } @@ -257,13 +273,13 @@ read_unsigned(pic_state *pic, struct pic_port *port, int c) u = read_uinteger(pic, port, c); - switch (peek(port)) { + switch (peek(pic, port)) { #if PIC_ENABLE_FLOAT case '.': - next(port); + next(pic, port); g = 0, e = 0; - while (isdigit(c = peek(port))) { - g = g * 10 + (next(port) - '0'); + while (isdigit(c = peek(pic, port))) { + g = g * 10 + (next(pic, port) - '0'); e++; } f = u + g * pow(10, -e); @@ -334,8 +350,8 @@ read_minus(pic_state *pic, struct pic_port *port, int c) { pic_value sym; - if (isdigit(peek(port))) { - return negate(read_unsigned(pic, port, next(port))); + if (isdigit(peek(pic, port))) { + return negate(read_unsigned(pic, port, next(pic, port))); } else { sym = read_symbol(pic, port, c); @@ -356,8 +372,8 @@ read_plus(pic_state *pic, struct pic_port *port, int c) { pic_value sym; - if (isdigit(peek(port))) { - return read_unsigned(pic, port, next(port)); + if (isdigit(peek(pic, port))) { + return read_unsigned(pic, port, next(pic, port)); } else { sym = read_symbol(pic, port, c); @@ -376,8 +392,8 @@ read_plus(pic_state *pic, struct pic_port *port, int c) static pic_value read_true(pic_state *pic, struct pic_port *port, int c) { - if ((c = peek(port)) == 'r') { - if (! expect(port, "rue")) { + if ((c = peek(pic, port)) == 'r') { + if (! expect(pic, port, "rue")) { read_error(pic, "unexpected character while reading #true"); } } else if (! isdelim(c)) { @@ -390,8 +406,8 @@ read_true(pic_state *pic, struct pic_port *port, int c) static pic_value read_false(pic_state *pic, struct pic_port *port, int c) { - if ((c = peek(port)) == 'a') { - if (! expect(port, "alse")) { + if ((c = peek(pic, port)) == 'a') { + if (! expect(pic, port, "alse")) { read_error(pic, "unexpected character while reading #false"); } } else if (! isdelim(c)) { @@ -404,29 +420,29 @@ read_false(pic_state *pic, struct pic_port *port, int c) static pic_value read_char(pic_state *pic, struct pic_port *port, int c) { - c = next(port); + c = next(pic, port); - if (! isdelim(peek(port))) { + if (! isdelim(peek(pic, port))) { switch (c) { default: read_error(pic, "unexpected character after char literal"); - case 'a': c = '\a'; if (! expect(port, "lerm")) goto fail; break; - case 'b': c = '\b'; if (! expect(port, "ackspace")) goto fail; break; - case 'd': c = 0x7F; if (! expect(port, "elete")) goto fail; break; - case 'e': c = 0x1B; if (! expect(port, "scape")) goto fail; break; + case 'a': c = '\a'; if (! expect(pic, port, "lerm")) goto fail; break; + case 'b': c = '\b'; if (! expect(pic, port, "ackspace")) goto fail; break; + case 'd': c = 0x7F; if (! expect(pic, port, "elete")) goto fail; break; + case 'e': c = 0x1B; if (! expect(pic, port, "scape")) goto fail; break; case 'n': - if ((c = peek(port)) == 'e') { + if ((c = peek(pic, port)) == 'e') { c = '\n'; - if (! expect(port, "ewline")) + if (! expect(pic, port, "ewline")) goto fail; } else { c = '\0'; - if (! expect(port, "ull")) + if (! expect(pic, port, "ull")) goto fail; } break; - case 'r': c = '\r'; if (! expect(port, "eturn")) goto fail; break; - case 's': c = ' '; if (! expect(port, "pace")) goto fail; break; - case 't': c = '\t'; if (! expect(port, "ab")) goto fail; break; + case 'r': c = '\r'; if (! expect(pic, port, "eturn")) goto fail; break; + case 's': c = ' '; if (! expect(pic, port, "pace")) goto fail; break; + case 't': c = '\t'; if (! expect(pic, port, "ab")) goto fail; break; } } @@ -449,9 +465,9 @@ read_string(pic_state *pic, struct pic_port *port, int c) /* TODO: intraline whitespaces */ - while ((c = next(port)) != '"') { + while ((c = next(pic, port)) != '"') { if (c == '\\') { - switch (c = next(port)) { + switch (c = next(pic, port)) { case 'a': c = '\a'; break; case 'b': c = '\b'; break; case 't': c = '\t'; break; @@ -484,9 +500,9 @@ read_pipe(pic_state *pic, struct pic_port *port, int c) size = 256; buf = pic_malloc(pic, size); cnt = 0; - while ((c = next(port)) != '|') { + while ((c = next(pic, port)) != '|') { if (c == '\\') { - switch ((c = next(port))) { + switch ((c = next(pic, port))) { case 'a': c = '\a'; break; case 'b': c = '\b'; break; case 't': c = '\t'; break; @@ -494,7 +510,7 @@ read_pipe(pic_state *pic, struct pic_port *port, int c) case 'r': c = '\r'; break; case 'x': i = 0; - while ((HEX_BUF[i++] = (char)next(port)) != ';') { + while ((HEX_BUF[i++] = (char)next(pic, port)) != ';') { if (i >= sizeof HEX_BUF) read_error(pic, "expected ';'"); } @@ -525,7 +541,7 @@ read_blob(pic_state *pic, struct pic_port *port, int c) nbits = 0; - while (isdigit(c = next(port))) { + while (isdigit(c = next(pic, port))) { nbits = 10 * nbits + c - '0'; } @@ -539,8 +555,8 @@ read_blob(pic_state *pic, struct pic_port *port, int c) len = 0; dat = NULL; - c = next(port); - while ((c = skip(port, c)) != ')') { + c = next(pic, port); + while ((c = skip(pic, port, c)) != ')') { n = read_uinteger(pic, port, c); if (n < 0 || (1 << nbits) <= n) { read_error(pic, "invalid element in bytevector literal"); @@ -548,7 +564,7 @@ read_blob(pic_state *pic, struct pic_port *port, int c) len += 1; dat = pic_realloc(pic, dat, len); dat[len - 1] = (unsigned char)n; - c = next(port); + c = next(pic, port); } blob = pic_make_blob(pic, len); @@ -563,8 +579,8 @@ read_blob(pic_state *pic, struct pic_port *port, int c) static pic_value read_undef_or_blob(pic_state *pic, struct pic_port *port, int c) { - if ((c = peek(port)) == 'n') { - if (! expect(port, "ndefined")) { + if ((c = peek(pic, port)) == 'n') { + if (! expect(pic, port, "ndefined")) { read_error(pic, "unexpected character while reading #undefined"); } return pic_undef_value(); @@ -583,16 +599,16 @@ read_pair(pic_state *pic, struct pic_port *port, int c) retry: - c = skip(port, ' '); + c = skip(pic, port, ' '); if (c == tCLOSE) { return pic_nil_value(); } - if (c == '.' && isdelim(peek(port))) { - cdr = read(pic, port, next(port)); + if (c == '.' && isdelim(peek(pic, port))) { + cdr = read(pic, port, next(pic, port)); closing: - if ((c = skip(port, ' ')) != tCLOSE) { + if ((c = skip(pic, port, ' ')) != tCLOSE) { if (pic_invalid_p(read_nullable(pic, port, c))) { goto closing; } @@ -625,17 +641,19 @@ read_vector(pic_state *pic, struct pic_port *port, int c) static pic_value read_label_set(pic_state *pic, struct pic_port *port, int i) { + khash_t(read) *h = &pic->reader.labels; pic_value val; - int c; + int c, ret; + khiter_t it; - switch ((c = skip(port, ' '))) { + it = kh_put(read, h, i, &ret); + + switch ((c = skip(pic, port, ' '))) { case '(': { pic_value tmp; - val = pic_cons(pic, pic_undef_value(), pic_undef_value()); - - xh_put_int(&pic->reader->labels, i, &val); + kh_val(h, it) = val = pic_cons(pic, pic_undef_value(), pic_undef_value()); tmp = read(pic, port, c); pic_pair_ptr(val)->car = pic_car(pic, tmp); @@ -647,7 +665,7 @@ read_label_set(pic_state *pic, struct pic_port *port, int i) { bool vect; - if (peek(port) == '(') { + if (peek(pic, port) == '(') { vect = true; } else { vect = false; @@ -656,9 +674,7 @@ read_label_set(pic_state *pic, struct pic_port *port, int i) if (vect) { pic_vec *tmp; - val = pic_obj_value(pic_make_vec(pic, 0)); - - xh_put_int(&pic->reader->labels, i, &val); + kh_val(h, it) = val = pic_obj_value(pic_make_vec(pic, 0)); tmp = pic_vec_ptr(read(pic, port, c)); PIC_SWAP(pic_value *, tmp->data, pic_vec_ptr(val)->data); @@ -671,9 +687,7 @@ read_label_set(pic_state *pic, struct pic_port *port, int i) } default: { - val = read(pic, port, c); - - xh_put_int(&pic->reader->labels, i, &val); + kh_val(h, it) = val = read(pic, port, c); return val; } @@ -683,13 +697,14 @@ read_label_set(pic_state *pic, struct pic_port *port, int i) static pic_value read_label_ref(pic_state *pic, struct pic_port PIC_UNUSED(*port), int i) { - xh_entry *e; + khash_t(read) *h = &pic->reader.labels; + khiter_t it; - e = xh_get_int(&pic->reader->labels, i); - if (! e) { + it = kh_get(read, h, i); + if (it == kh_end(h)) { read_error(pic, "label of given index not defined"); } - return xh_val(e, pic_value); + return kh_val(h, it); } static pic_value @@ -700,7 +715,7 @@ read_label(pic_state *pic, struct pic_port *port, int c) i = 0; do { i = i * 10 + c - '0'; - } while (isdigit(c = next(port))); + } while (isdigit(c = next(pic, port))); if (c == '=') { return read_label_set(pic, port, i); @@ -720,33 +735,33 @@ read_unmatch(pic_state *pic, struct pic_port PIC_UNUSED(*port), int PIC_UNUSED(c static pic_value read_dispatch(pic_state *pic, struct pic_port *port, int c) { - c = next(port); + c = next(pic, port); if (c == EOF) { read_error(pic, "unexpected EOF"); } - if (pic->reader->dispatch[c] == NULL) { + if (pic->reader.dispatch[c] == NULL) { read_error(pic, "invalid character at the seeker head"); } - return pic->reader->dispatch[c](pic, port, c); + return pic->reader.dispatch[c](pic, port, c); } static pic_value read_nullable(pic_state *pic, struct pic_port *port, int c) { - c = skip(port, c); + c = skip(pic, port, c); if (c == EOF) { read_error(pic, "unexpected EOF"); } - if (pic->reader->table[c] == NULL) { + if (pic->reader.table[c] == NULL) { read_error(pic, "invalid character at the seeker head"); } - return pic->reader->table[c](pic, port, c); + return pic->reader.table[c](pic, port, c); } static pic_value @@ -758,7 +773,7 @@ read(pic_state *pic, struct pic_port *port, int c) val = read_nullable(pic, port, c); if (pic_invalid_p(val)) { - c = next(port); + c = next(pic, port); goto retry; } @@ -766,7 +781,7 @@ read(pic_state *pic, struct pic_port *port, int c) } static void -reader_table_init(struct pic_reader *reader) +reader_table_init(pic_reader *reader) { int c; @@ -799,10 +814,12 @@ reader_table_init(struct pic_reader *reader) reader->dispatch[';'] = read_datum_comment; reader->dispatch['t'] = read_true; reader->dispatch['f'] = read_false; + reader->dispatch['\''] = read_syntax_quote; + reader->dispatch['`'] = read_syntax_quasiquote; + reader->dispatch[','] = read_syntax_unquote; reader->dispatch['\\'] = read_char; reader->dispatch['('] = read_vector; reader->dispatch['u'] = read_undef_or_blob; - reader->dispatch['.'] = read_eval; /* read labels */ for (c = '0'; c <= '9'; ++c) { @@ -810,44 +827,39 @@ reader_table_init(struct pic_reader *reader) } } -struct pic_reader * -pic_reader_open(pic_state *pic) +void +pic_reader_init(pic_state *pic) { - struct pic_reader *reader; int c; - reader = pic_malloc(pic, sizeof(struct pic_reader)); - reader->typecase = PIC_CASE_DEFAULT; - xh_init_int(&reader->labels, sizeof(pic_value)); + pic->reader.typecase = PIC_CASE_DEFAULT; + kh_init(read, &pic->reader.labels); for (c = 0; c < 256; ++c) { - reader->table[c] = NULL; + pic->reader.table[c] = NULL; } for (c = 0; c < 256; ++c) { - reader->dispatch[c] = NULL; + pic->reader.dispatch[c] = NULL; } - reader_table_init(reader); - - return reader; + reader_table_init(&pic->reader); } void -pic_reader_close(pic_state *pic, struct pic_reader *reader) +pic_reader_destroy(pic_state *pic) { - xh_destroy(&reader->labels); - pic_free(pic, reader); + kh_destroy(read, &pic->reader.labels); } pic_value pic_read(pic_state *pic, struct pic_port *port) { pic_value val; - int c = next(port); + int c = next(pic, port); retry: - c = skip(port, c); + c = skip(pic, port, c); if (c == EOF) { return pic_eof_object(); @@ -856,7 +868,7 @@ pic_read(pic_state *pic, struct pic_port *port) val = read_nullable(pic, port, c); if (pic_invalid_p(val)) { - c = next(port); + c = next(pic, port); goto retry; } @@ -869,7 +881,13 @@ pic_read_cstr(pic_state *pic, const char *str) struct pic_port *port = pic_open_input_string(pic, str); pic_value form; - form = pic_read(pic, port); + pic_try { + form = pic_read(pic, port); + } + pic_catch { + pic_close_port(pic, port); + pic_raise(pic, pic->err); + } pic_close_port(pic, port); diff --git a/extlib/benz/record.c b/extlib/benz/record.c index 55c98f14..dfa21908 100644 --- a/extlib/benz/record.c +++ b/extlib/benz/record.c @@ -30,7 +30,7 @@ pic_value pic_record_ref(pic_state *pic, struct pic_record *rec, pic_sym *slot) { if (! pic_dict_has(pic, rec->data, slot)) { - pic_errorf(pic, "slot named ~s is not found for record: ~s", pic_obj_value(slot), rec); + pic_errorf(pic, "slot named ~s is not found for record: ~s", pic_obj_value(slot), pic_obj_value(rec)); } return pic_dict_ref(pic, rec->data, slot); } diff --git a/extlib/benz/reg.c b/extlib/benz/reg.c index b23da584..d72aceaf 100644 --- a/extlib/benz/reg.c +++ b/extlib/benz/reg.c @@ -4,6 +4,8 @@ #include "picrin.h" +KHASH_DEFINE(reg, void *, pic_value, kh_ptr_hash_func, kh_ptr_hash_equal) + struct pic_reg * pic_make_reg(pic_state *pic) { @@ -11,7 +13,7 @@ pic_make_reg(pic_state *pic) reg = (struct pic_reg *)pic_obj_alloc(pic, sizeof(struct pic_reg), PIC_TT_REG); reg->prev = NULL; - xh_init_ptr(®->hash, sizeof(pic_value)); + kh_init(reg, ®->hash); return reg; } @@ -19,35 +21,44 @@ pic_make_reg(pic_state *pic) pic_value pic_reg_ref(pic_state *pic, struct pic_reg *reg, void *key) { - xh_entry *e; + khash_t(reg) *h = ®->hash; + khiter_t it; - e = xh_get_ptr(®->hash, key); - if (! e) { + it = kh_get(reg, h, key); + if (it == kh_end(h)) { pic_errorf(pic, "element not found for a key: ~s", pic_obj_value(key)); } - return xh_val(e, pic_value); + return kh_val(h, it); } void pic_reg_set(pic_state PIC_UNUSED(*pic), struct pic_reg *reg, void *key, pic_value val) { - xh_put_ptr(®->hash, key, &val); + khash_t(reg) *h = ®->hash; + int ret; + khiter_t it; + + it = kh_put(reg, h, key, &ret); + kh_val(h, it) = val; } bool pic_reg_has(pic_state PIC_UNUSED(*pic), struct pic_reg *reg, void *key) { - return xh_get_ptr(®->hash, key) != NULL; + return kh_get(reg, ®->hash, key) != kh_end(®->hash); } void pic_reg_del(pic_state *pic, struct pic_reg *reg, void *key) { - if (xh_get_ptr(®->hash, key) == NULL) { - pic_errorf(pic, "no slot named ~s found in registry", pic_obj_value(key)); - } + khash_t(reg) *h = ®->hash; + khiter_t it; - xh_del_ptr(®->hash, key); + it = kh_get(reg, h, key); + if (it == kh_end(h)) { + pic_errorf(pic, "no slot named ~s found in register", pic_obj_value(key)); + } + kh_del(reg, h, it); } @@ -85,7 +96,7 @@ reg_call(pic_state *pic) 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 a registory", key); + pic_errorf(pic, "attempted to set a non-object key '~s' in a register", key); } reg = pic_reg_ptr(pic_proc_env_ref(pic, self, "reg")); @@ -98,7 +109,7 @@ reg_call(pic_state *pic) } static pic_value -pic_reg_make_registry(pic_state *pic) +pic_reg_make_register(pic_state *pic) { struct pic_reg *reg; struct pic_proc *proc; @@ -107,7 +118,7 @@ pic_reg_make_registry(pic_state *pic) reg = pic_make_reg(pic); - proc = pic_make_proc(pic, reg_call, ""); + proc = pic_make_proc(pic, reg_call); pic_proc_env_set(pic, proc, "reg", pic_obj_value(reg)); @@ -117,5 +128,5 @@ pic_reg_make_registry(pic_state *pic) void pic_init_reg(pic_state *pic) { - pic_defun(pic, "make-registry", pic_reg_make_registry); + pic_defun(pic, "make-register", pic_reg_make_register); } diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 0caa2a6b..70e09571 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -4,6 +4,14 @@ #include "picrin.h" +void +pic_set_argv(pic_state *pic, int argc, char *argv[], char **envp) +{ + pic->argc = argc; + pic->argv = argv; + pic->envp = envp; +} + void pic_add_feature(pic_state *pic, const char *feature) { @@ -91,25 +99,38 @@ pic_init_features(pic_state *pic) #endif } +static pic_value +pic_features(pic_state *pic) +{ + pic_get_args(pic, ""); + + return pic->features; +} + #define DONE pic_gc_arena_restore(pic, ai); +#define define_builtin_syntax(uid, name) \ + pic_define_syntactic_keyword_(pic, pic->lib->env, pic_intern_cstr(pic, name), uid) + static void pic_init_core(pic_state *pic) { - void pic_define_syntactic_keyword(pic_state *, struct pic_env *, pic_sym *, pic_sym *); + void pic_define_syntactic_keyword_(pic_state *, struct pic_env *, pic_sym *, pic_sym *); pic_init_features(pic); pic_deflibrary (pic, "(picrin base)") { size_t ai = pic_gc_arena_preserve(pic); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->rDEFINE); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->rSETBANG); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->rQUOTE); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->rLAMBDA); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->rIF); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->rBEGIN); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX); + define_builtin_syntax(pic->uDEFINE, "builtin:define"); + define_builtin_syntax(pic->uSETBANG, "builtin:set!"); + define_builtin_syntax(pic->uQUOTE, "builtin:quote"); + define_builtin_syntax(pic->uLAMBDA, "builtin:lambda"); + define_builtin_syntax(pic->uIF, "builtin:if"); + define_builtin_syntax(pic->uBEGIN, "builtin:begin"); + define_builtin_syntax(pic->uDEFINE_MACRO, "builtin:define-macro"); + + pic_defun(pic, "features", pic_features); pic_init_undef(pic); DONE; pic_init_bool(pic); DONE; @@ -138,11 +159,11 @@ pic_init_core(pic_state *pic) pic_load_cstr(pic, &pic_boot[0][0]); } - pic_import_library(pic, pic->PICRIN_BASE); + pic_import(pic, pic->PICRIN_BASE); } pic_state * -pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) +pic_open(pic_allocf allocf, void *userdata) { struct pic_port *pic_make_standard_port(pic_state *, xFILE *, short); char t; @@ -159,19 +180,23 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) /* allocator */ pic->allocf = allocf; + /* user data */ + pic->userdata = userdata; + /* turn off GC */ pic->gc_enable = false; - /* jmp */ - pic->jmp = NULL; + /* continuation chain */ + pic->cc = NULL; + pic->ccnt = 0; /* root block */ pic->cp = NULL; /* command line */ - pic->argc = argc; - pic->argv = argv; - pic->envp = envp; + pic->argc = 0; + pic->argv = NULL; + pic->envp = NULL; /* prepare VM stack */ pic->stbase = pic->sp = allocf(NULL, PIC_STACK_SIZE * sizeof(pic_value)); @@ -206,13 +231,6 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) goto EXIT_ARENA; } - /* trampoline iseq */ - pic->iseq = allocf(NULL, 2 * sizeof(pic_code)); - - if (! pic->iseq) { - goto EXIT_ISEQ; - } - /* memory heap */ pic->heap = pic_heap_open(pic); @@ -220,7 +238,10 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) pic->regs = NULL; /* symbol table */ - xh_init_str(&pic->syms, sizeof(pic_sym *)); + kh_init(s, &pic->syms); + + /* unique symbol count */ + pic->ucnt = 0; /* global variables */ pic->globals = NULL; @@ -241,10 +262,8 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) /* raised error object */ pic->err = pic_invalid_value(); - /* standard ports */ - pic->xSTDIN = NULL; - pic->xSTDOUT = NULL; - pic->xSTDERR = NULL; + /* file pool */ + memset(pic->files, 0, sizeof pic->files); /* parameter table */ pic->ptable = pic_nil_value(); @@ -254,7 +273,7 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) ai = pic_gc_arena_preserve(pic); -#define S(slot,name) pic->slot = pic_intern_cstr(pic, name); +#define S(slot,name) pic->slot = pic_intern_cstr(pic, name) S(sDEFINE, "define"); S(sLAMBDA, "lambda"); @@ -265,7 +284,11 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) S(sQUASIQUOTE, "quasiquote"); S(sUNQUOTE, "unquote"); S(sUNQUOTE_SPLICING, "unquote-splicing"); - S(sDEFINE_SYNTAX, "define-syntax"); + S(sSYNTAX_QUOTE, "syntax-quote"); + S(sSYNTAX_QUASIQUOTE, "syntax-quasiquote"); + S(sSYNTAX_UNQUOTE, "syntax-unquote"); + S(sSYNTAX_UNQUOTE_SPLICING, "syntax-unquote-splicing"); + S(sDEFINE_MACRO, "define-macro"); S(sIMPORT, "import"); S(sEXPORT, "export"); S(sDEFINE_LIBRARY, "define-library"); @@ -308,37 +331,37 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) pic_gc_arena_restore(pic, ai); -#define R(slot,name) pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name)); +#define U(slot,name) pic->slot = pic_uniq(pic, pic_obj_value(pic_intern_cstr(pic, name))) - R(rDEFINE, "define"); - R(rLAMBDA, "lambda"); - R(rIF, "if"); - R(rBEGIN, "begin"); - R(rSETBANG, "set!"); - R(rQUOTE, "quote"); - R(rDEFINE_SYNTAX, "define-syntax"); - R(rIMPORT, "import"); - R(rEXPORT, "export"); - R(rDEFINE_LIBRARY, "define-library"); - R(rCOND_EXPAND, "cond-expand"); - R(rCONS, "cons"); - R(rCAR, "car"); - R(rCDR, "cdr"); - R(rNILP, "null?"); - R(rSYMBOLP, "symbol?"); - R(rPAIRP, "pair?"); - R(rADD, "+"); - R(rSUB, "-"); - R(rMUL, "*"); - R(rDIV, "/"); - R(rEQ, "="); - R(rLT, "<"); - R(rLE, "<="); - R(rGT, ">"); - R(rGE, ">="); - R(rNOT, "not"); - R(rVALUES, "values"); - R(rCALL_WITH_VALUES, "call-with-values"); + U(uDEFINE, "define"); + U(uLAMBDA, "lambda"); + U(uIF, "if"); + U(uBEGIN, "begin"); + U(uSETBANG, "set!"); + U(uQUOTE, "quote"); + U(uDEFINE_MACRO, "define-macro"); + U(uIMPORT, "import"); + U(uEXPORT, "export"); + U(uDEFINE_LIBRARY, "define-library"); + U(uCOND_EXPAND, "cond-expand"); + U(uCONS, "cons"); + U(uCAR, "car"); + U(uCDR, "cdr"); + U(uNILP, "null?"); + U(uSYMBOLP, "symbol?"); + U(uPAIRP, "pair?"); + U(uADD, "+"); + U(uSUB, "-"); + U(uMUL, "*"); + U(uDIV, "/"); + U(uEQ, "="); + U(uLT, "<"); + U(uLE, "<="); + U(uGT, ">"); + U(uGE, ">="); + U(uNOT, "not"); + U(uVALUES, "values"); + U(uCALL_WITH_VALUES, "call-with-values"); pic_gc_arena_restore(pic, ai); /* root tables */ @@ -347,21 +370,16 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) pic->attrs = pic_make_reg(pic); /* root block */ - pic->cp = pic_malloc(pic, sizeof(pic_checkpoint)); + pic->cp = (pic_checkpoint *)pic_obj_alloc(pic, sizeof(pic_checkpoint), PIC_TT_CP); pic->cp->prev = NULL; pic->cp->depth = 0; pic->cp->in = pic->cp->out = NULL; /* reader */ - pic->reader = pic_reader_open(pic); - - /* standard I/O */ - pic->xSTDIN = pic_make_standard_port(pic, xstdin, PIC_PORT_IN); - pic->xSTDOUT = pic_make_standard_port(pic, xstdout, PIC_PORT_OUT); - pic->xSTDERR = pic_make_standard_port(pic, xstderr, PIC_PORT_OUT); + pic_reader_init(pic); /* parameter table */ - pic->ptable = pic_cons(pic, pic_obj_value(pic_make_dict(pic)), pic->ptable); + pic->ptable = pic_cons(pic, pic_obj_value(pic_make_reg(pic)), pic->ptable); /* standard libraries */ pic->PICRIN_BASE = pic_make_library(pic, pic_read_cstr(pic, "(picrin base)")); @@ -380,8 +398,6 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) return pic; - EXIT_ISEQ: - allocf(pic->arena, 0); EXIT_ARENA: allocf(pic->xp, 0); EXIT_XP: @@ -397,22 +413,9 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) void pic_close(pic_state *pic) { - xh_entry *it; + khash_t(s) *h = &pic->syms; pic_allocf allocf = pic->allocf; - /* invoke exit handlers */ - while (pic->cp) { - if (pic->cp->out) { - pic_apply0(pic, pic->cp->out); - } - pic->cp = pic->cp->prev; - } - - /* free symbol names */ - for (it = xh_begin(&pic->syms); it != NULL; it = xh_next(it)) { - allocf(xh_key(it, char *), 0); - } - /* clear out root objects */ pic->sp = pic->stbase; pic->ci = pic->cibase; @@ -422,29 +425,28 @@ pic_close(pic_state *pic) pic->globals = NULL; pic->macros = NULL; pic->attrs = NULL; - xh_clear(&pic->syms); pic->features = pic_nil_value(); pic->libs = pic_nil_value(); /* free all heap objects */ pic_gc_run(pic); + /* flush all xfiles */ + xfflush(pic, NULL); + /* free heaps */ pic_heap_close(pic, pic->heap); /* free reader struct */ - pic_reader_close(pic, pic->reader); + pic_reader_destroy(pic); /* free runtime context */ allocf(pic->stbase, 0); allocf(pic->cibase, 0); allocf(pic->xpbase, 0); - /* free trampoline iseq */ - allocf(pic->iseq, 0); - /* free global stacks */ - xh_destroy(&pic->syms); + kh_destroy(s, h); /* free GC arena */ allocf(pic->arena, 0); diff --git a/extlib/benz/string.c b/extlib/benz/string.c index 1e1e083c..9d1060c3 100644 --- a/extlib/benz/string.c +++ b/extlib/benz/string.c @@ -310,7 +310,7 @@ pic_xvfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap) while ((c = *fmt++)) { switch (c) { default: - xfputc(c, file); + xfputc(pic, c, file); break; case '%': c = *fmt++; @@ -318,26 +318,26 @@ pic_xvfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap) goto exit; switch (c) { default: - xfputc(c, file); + xfputc(pic, c, file); break; case '%': - xfputc('%', file); + xfputc(pic, '%', file); break; case 'c': - xfprintf(file, "%c", va_arg(ap, int)); + xfprintf(pic, file, "%c", va_arg(ap, int)); break; case 's': - xfprintf(file, "%s", va_arg(ap, const char *)); + xfprintf(pic, file, "%s", va_arg(ap, const char *)); break; case 'd': - xfprintf(file, "%d", va_arg(ap, int)); + xfprintf(pic, file, "%d", va_arg(ap, int)); break; case 'p': - xfprintf(file, "%p", va_arg(ap, void *)); + xfprintf(pic, file, "%p", va_arg(ap, void *)); break; #if PIC_ENABLE_FLOAT case 'f': - xfprintf(file, "%f", va_arg(ap, double)); + xfprintf(pic, file, "%f", va_arg(ap, double)); break; #endif } @@ -348,13 +348,13 @@ pic_xvfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap) goto exit; switch (c) { default: - xfputc(c, file); + xfputc(pic, c, file); break; case '~': - xfputc('~', file); + xfputc(pic, '~', file); break; case '%': - xfputc('\n', file); + xfputc(pic, '\n', file); break; case 'a': irrs = pic_cons(pic, pic_fdisplay(pic, va_arg(ap, pic_value), file), irrs); diff --git a/extlib/benz/symbol.c b/extlib/benz/symbol.c index 8298465d..fcb5fb2d 100644 --- a/extlib/benz/symbol.c +++ b/extlib/benz/symbol.c @@ -4,67 +4,45 @@ #include "picrin.h" -pic_sym * -pic_make_symbol(pic_state *pic, pic_str *str) -{ - pic_sym *sym; - - sym = (pic_sym *)pic_obj_alloc(pic, sizeof(struct pic_symbol), PIC_TT_SYMBOL); - sym->str = str; - return sym; -} +KHASH_DEFINE(s, const char *, pic_sym *, kh_str_hash_func, kh_str_hash_equal) pic_sym * pic_intern(pic_state *pic, pic_str *str) { - xh_entry *e; - pic_sym *sym; - char *cstr; + return pic_intern_cstr(pic, pic_str_cstr(pic, str)); +} - e = xh_get_str(&pic->syms, pic_str_cstr(pic, str)); - if (e) { - sym = xh_val(e, pic_sym *); +pic_sym * +pic_intern_cstr(pic_state *pic, const char *cstr) +{ + khash_t(s) *h = &pic->syms; + pic_sym *sym; + khiter_t it; + int ret; + char *copy; + + it = kh_put(s, h, cstr, &ret); + if (ret == 0) { /* if exists */ + sym = kh_val(h, it); pic_gc_protect(pic, pic_obj_value(sym)); return sym; } - cstr = pic_malloc(pic, pic_str_len(str) + 1); - strcpy(cstr, pic_str_cstr(pic, str)); + copy = pic_malloc(pic, strlen(cstr) + 1); + strcpy(copy, cstr); + kh_key(h, it) = copy; + + sym = (pic_sym *)pic_obj_alloc(pic, sizeof(pic_sym), PIC_TT_SYMBOL); + sym->cstr = copy; + kh_val(h, it) = sym; - sym = pic_make_symbol(pic, str); - xh_put_str(&pic->syms, cstr, &sym); return sym; } -pic_sym * -pic_intern_cstr(pic_state *pic, const char *str) -{ - return pic_intern(pic, pic_make_str(pic, str, strlen(str))); -} - -pic_sym * -pic_gensym(pic_state *pic, pic_sym *base) -{ - return pic_make_symbol(pic, base->str); -} - -bool -pic_interned_p(pic_state *pic, pic_sym *sym) -{ - xh_entry *e; - - e = xh_get_str(&pic->syms, pic_str_cstr(pic, sym->str)); - if (e) { - return sym == xh_val(e, pic_sym *); - } else { - return false; - } -} - const char * -pic_symbol_name(pic_state *pic, pic_sym *sym) +pic_symbol_name(pic_state PIC_UNUSED(*pic), pic_sym *sym) { - return pic_str_cstr(pic, sym->str); + return sym->cstr; } static pic_value @@ -103,7 +81,7 @@ pic_symbol_symbol_to_string(pic_state *pic) pic_get_args(pic, "m", &sym); - return pic_obj_value(sym->str); + return pic_obj_value(pic_make_str_cstr(pic, sym->cstr)); } static pic_value @@ -121,7 +99,7 @@ pic_init_symbol(pic_state *pic) { void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t); - pic_defun_vm(pic, "symbol?", pic->rSYMBOLP, pic_symbol_symbol_p); + pic_defun_vm(pic, "symbol?", pic->uSYMBOLP, pic_symbol_symbol_p); pic_defun(pic, "symbol->string", pic_symbol_symbol_to_string); pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol); diff --git a/extlib/benz/var.c b/extlib/benz/var.c index 5fd44c0b..b1b6f66c 100644 --- a/extlib/benz/var.c +++ b/extlib/benz/var.c @@ -61,7 +61,7 @@ pic_make_var(pic_state *pic, pic_value init, struct pic_proc *conv) { struct pic_proc *var; - var = pic_make_proc(pic, var_call, ""); + var = pic_make_proc(pic, var_call); if (conv != NULL) { pic_proc_env_set(pic, var, "conv", pic_obj_value(conv)); diff --git a/extlib/benz/vm.c b/extlib/benz/vm.c index 7a062019..0ccec5ba 100644 --- a/extlib/benz/vm.c +++ b/extlib/benz/vm.c @@ -82,11 +82,7 @@ pic_get_args(pic_state *pic, const char *format, ...) /* check argc. */ if (argc < paramc || (paramc + optc < argc && ! rest)) { - pic_errorf(pic, "%s: wrong number of arguments (%d for %s%d)", - pic_symbol_name(pic, pic_proc_name(pic_proc_ptr(GET_OPERAND(pic, 0)))) , - argc, - rest? "at least " : "", - paramc); + pic_errorf(pic, "pic_get_args: wrong number of arguments (%d for %s%d)", argc, rest? "at least " : "", paramc); } /* start dispatching */ @@ -393,112 +389,6 @@ pic_get_args(pic_state *pic, const char *format, ...) return argc; } -void -pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *rsym) -{ - pic_put_rename(pic, env, sym, rsym); - - if (pic->lib && pic->lib->env == env) { - pic_export(pic, sym); - } -} - -void -pic_define_noexport(pic_state *pic, const char *name, pic_value val) -{ - pic_sym *sym, *rename; - - sym = pic_intern_cstr(pic, name); - - if ((rename = pic_find_rename(pic, pic->lib->env, sym)) == NULL) { - rename = pic_add_rename(pic, pic->lib->env, sym); - } else { - pic_warnf(pic, "redefining global"); - } - - pic_dict_set(pic, pic->globals, rename, val); -} - -void -pic_define(pic_state *pic, const char *name, pic_value val) -{ - pic_define_noexport(pic, name, val); - - pic_export(pic, pic_intern_cstr(pic, name)); -} - -pic_value -pic_ref(pic_state *pic, struct pic_lib *lib, const char *name) -{ - pic_sym *sym, *rename; - - sym = pic_intern_cstr(pic, name); - - if ((rename = pic_find_rename(pic, lib->env, sym)) == NULL) { - pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); - } - - return pic_dict_ref(pic, pic->globals, rename); -} - -void -pic_set(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val) -{ - pic_sym *sym, *rename; - - sym = pic_intern_cstr(pic, name); - - if ((rename = pic_find_rename(pic, lib->env, sym)) == NULL) { - pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); - } - - pic_dict_set(pic, pic->globals, rename, val); -} - -pic_value -pic_funcall(pic_state *pic, struct pic_lib *lib, const char *name, pic_list args) -{ - pic_value proc; - - proc = pic_ref(pic, lib, name); - - pic_assert_type(pic, proc, proc); - - return pic_apply(pic, pic_proc_ptr(proc), args); -} - -void -pic_defun(pic_state *pic, const char *name, pic_func_t cfunc) -{ - struct pic_proc *proc; - - proc = pic_make_proc(pic, cfunc, name); - pic_define(pic, name, pic_obj_value(proc)); -} - -void -pic_defun_vm(pic_state *pic, const char *name, pic_sym *rename, pic_func_t func) -{ - struct pic_proc *proc; - pic_sym *sym; - - proc = pic_make_proc(pic, func, name); - - sym = pic_intern_cstr(pic, name); - - pic_put_rename(pic, pic->lib->env, sym, rename); - - pic_dict_set(pic, pic->globals, rename, pic_obj_value(proc)); - - pic_export(pic, sym); -} - -void -pic_defvar(pic_state *pic, const char *name, pic_value init, struct pic_proc *conv) -{ - pic_define(pic, name, pic_obj_value(pic_make_var(pic, init, conv))); -} - static void vm_push_cxt(pic_state *pic) { @@ -558,42 +448,6 @@ vm_get_irep(pic_state *pic) return irep; } -pic_value -pic_apply0(pic_state *pic, struct pic_proc *proc) -{ - return pic_apply(pic, proc, pic_nil_value()); -} - -pic_value -pic_apply1(pic_state *pic, struct pic_proc *proc, pic_value arg1) -{ - return pic_apply(pic, proc, pic_list1(pic, arg1)); -} - -pic_value -pic_apply2(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2) -{ - return pic_apply(pic, proc, pic_list2(pic, arg1, arg2)); -} - -pic_value -pic_apply3(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2, pic_value arg3) -{ - return pic_apply(pic, proc, pic_list3(pic, arg1, arg2, arg3)); -} - -pic_value -pic_apply4(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4) -{ - return pic_apply(pic, proc, pic_list4(pic, arg1, arg2, arg3, arg4)); -} - -pic_value -pic_apply5(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4, pic_value arg5) -{ - return pic_apply(pic, proc, pic_list5(pic, arg1, arg2, arg3, arg4, arg5)); -} - #if VM_DEBUG # define OPCODE_EXEC_HOOK pic_dump_code(c) #else @@ -775,7 +629,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) sym = irep->syms[c.u.i]; if (! pic_dict_has(pic, pic->globals, sym)) { - pic_errorf(pic, "logic flaw; reference to uninitialized global variable: %s", pic_symbol_name(pic, sym)); + pic_errorf(pic, "uninitialized global variable: %s", pic_symbol_name(pic, sym)); } PUSH(pic_dict_ref(pic, pic->globals, sym)); NEXT; @@ -1214,3 +1068,185 @@ pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args) return pic_car(pic, args); } } + +pic_value +pic_apply0(pic_state *pic, struct pic_proc *proc) +{ + return pic_apply(pic, proc, pic_nil_value()); +} + +pic_value +pic_apply1(pic_state *pic, struct pic_proc *proc, pic_value arg1) +{ + return pic_apply(pic, proc, pic_list1(pic, arg1)); +} + +pic_value +pic_apply2(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2) +{ + return pic_apply(pic, proc, pic_list2(pic, arg1, arg2)); +} + +pic_value +pic_apply3(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2, pic_value arg3) +{ + return pic_apply(pic, proc, pic_list3(pic, arg1, arg2, arg3)); +} + +pic_value +pic_apply4(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4) +{ + return pic_apply(pic, proc, pic_list4(pic, arg1, arg2, arg3, arg4)); +} + +pic_value +pic_apply5(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4, pic_value arg5) +{ + return pic_apply(pic, proc, pic_list5(pic, arg1, arg2, arg3, arg4, arg5)); +} + +void +pic_define_syntactic_keyword_(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *uid) +{ + pic_put_variable(pic, env, pic_obj_value(sym), uid); +} + +void +pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *uid) +{ + pic_define_syntactic_keyword_(pic, env, sym, uid); + + if (pic->lib && pic->lib->env == env) { + pic_export(pic, sym); + } +} + +void +pic_defun_vm(pic_state *pic, const char *name, pic_sym *uid, pic_func_t func) +{ + struct pic_proc *proc; + pic_sym *sym; + + proc = pic_make_proc(pic, func); + + sym = pic_intern_cstr(pic, name); + + pic_put_variable(pic, pic->lib->env, pic_obj_value(sym), uid); + + pic_dict_set(pic, pic->globals, uid, pic_obj_value(proc)); + + pic_export(pic, sym); +} + +void +pic_define_(pic_state *pic, const char *name, pic_value val) +{ + pic_sym *sym, *uid; + + sym = pic_intern_cstr(pic, name); + + if ((uid = pic_find_variable(pic, pic->lib->env, pic_obj_value(sym))) == NULL) { + uid = pic_add_variable(pic, pic->lib->env, pic_obj_value(sym)); + } else { + pic_warnf(pic, "redefining global"); + } + + pic_dict_set(pic, pic->globals, uid, val); +} + +void +pic_define(pic_state *pic, const char *name, pic_value val) +{ + pic_define_(pic, name, val); + pic_export(pic, pic_intern_cstr(pic, name)); +} + +void +pic_defun_(pic_state *pic, const char *name, pic_func_t cfunc) +{ + pic_define_(pic, name, pic_obj_value(pic_make_proc(pic, cfunc))); +} + +void +pic_defun(pic_state *pic, const char *name, pic_func_t cfunc) +{ + pic_defun_(pic, name, cfunc); + pic_export(pic, pic_intern_cstr(pic, name)); +} + +void +pic_defvar_(pic_state *pic, const char *name, pic_value init, struct pic_proc *conv) +{ + pic_define_(pic, name, pic_obj_value(pic_make_var(pic, init, conv))); +} + +void +pic_defvar(pic_state *pic, const char *name, pic_value init, struct pic_proc *conv) +{ + pic_defvar_(pic, name, init, conv); + pic_export(pic, pic_intern_cstr(pic, name)); +} + +pic_value +pic_ref(pic_state *pic, struct pic_lib *lib, const char *name) +{ + pic_sym *sym, *uid; + + sym = pic_intern_cstr(pic, name); + + if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(sym))) == NULL) { + pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); + } + + return pic_dict_ref(pic, pic->globals, uid); +} + +void +pic_set(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val) +{ + pic_sym *sym, *uid; + + sym = pic_intern_cstr(pic, name); + + if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(sym))) == NULL) { + pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); + } + + pic_dict_set(pic, pic->globals, uid, val); +} + +pic_value +pic_funcall(pic_state *pic, struct pic_lib *lib, const char *name, pic_list args) +{ + pic_value proc; + + proc = pic_ref(pic, lib, name); + + pic_assert_type(pic, proc, proc); + + return pic_apply(pic, pic_proc_ptr(proc), args); +} + +pic_value +pic_funcall0(pic_state *pic, struct pic_lib *lib, const char *name) +{ + return pic_funcall(pic, lib, name, pic_nil_value()); +} + +pic_value +pic_funcall1(pic_state *pic, struct pic_lib *lib, const char *name, pic_value arg0) +{ + return pic_funcall(pic, lib, name, pic_list1(pic, arg0)); +} + +pic_value +pic_funcall2(pic_state *pic, struct pic_lib *lib, const char *name, pic_value arg0, pic_value arg1) +{ + return pic_funcall(pic, lib, name, pic_list2(pic, arg0, arg1)); +} + +pic_value +pic_funcall3(pic_state *pic, struct pic_lib *lib, const char *name, pic_value arg0, pic_value arg1, pic_value arg2) +{ + return pic_funcall(pic, lib, name, pic_list3(pic, arg0, arg1, arg2)); +} diff --git a/extlib/benz/write.c b/extlib/benz/write.c index 73ee11f5..124ae7b4 100644 --- a/extlib/benz/write.c +++ b/extlib/benz/write.c @@ -4,115 +4,127 @@ #include "picrin.h" -static bool -is_tagged(pic_state *pic, pic_sym *tag, pic_value pair) -{ - return pic_pair_p(pic_cdr(pic, pair)) - && pic_nil_p(pic_cddr(pic, pair)) - && pic_eq_p(pic_car(pic, pair), pic_obj_value(tag)); -} - -static bool -is_quote(pic_state *pic, pic_value pair) -{ - return is_tagged(pic, pic->sQUOTE, pair); -} - -static bool -is_unquote(pic_state *pic, pic_value pair) -{ - return is_tagged(pic, pic->sUNQUOTE, pair); -} - -static bool -is_unquote_splicing(pic_state *pic, pic_value pair) -{ - return is_tagged(pic, pic->sUNQUOTE_SPLICING, pair); -} - -static bool -is_quasiquote(pic_state *pic, pic_value pair) -{ - return is_tagged(pic, pic->sQUASIQUOTE, pair); -} +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) struct writer_control { pic_state *pic; xFILE *file; int mode; - xhash labels; /* object -> int */ - xhash visited; /* object -> int */ + int op; + khash_t(l) labels; /* object -> int */ + khash_t(v) visited; /* object -> int */ int cnt; }; #define WRITE_MODE 1 #define DISPLAY_MODE 2 +#define OP_WRITE 1 +#define OP_WRITE_SHARED 2 +#define OP_WRITE_SIMPLE 3 + static void -writer_control_init(struct writer_control *p, pic_state *pic, xFILE *file, int mode) +writer_control_init(struct writer_control *p, pic_state *pic, xFILE *file, int mode, int op) { p->pic = pic; p->file = file; p->mode = mode; + p->op = op; p->cnt = 0; - xh_init_ptr(&p->labels, sizeof(int)); - xh_init_ptr(&p->visited, sizeof(int)); + kh_init(l, &p->labels); + kh_init(v, &p->visited); } static void writer_control_destroy(struct writer_control *p) { - xh_destroy(&p->labels); - xh_destroy(&p->visited); + pic_state *pic = p->pic; + kh_destroy(l, &p->labels); + kh_destroy(v, &p->visited); } static void -traverse_shared(struct writer_control *p, pic_value obj) +write_blob(pic_state *pic, pic_blob *blob, xFILE *file) { - xh_entry *e; size_t i; - int c; - switch (pic_type(obj)) { - case PIC_TT_PAIR: - case PIC_TT_VECTOR: - e = xh_get_ptr(&p->labels, pic_obj_ptr(obj)); - if (e == NULL) { - c = -1; - xh_put_ptr(&p->labels, pic_obj_ptr(obj), &c); - } - else if (xh_val(e, int) == -1) { - c = p->cnt++; - xh_put_ptr(&p->labels, pic_obj_ptr(obj), &c); - break; - } - else { - break; + xfprintf(pic, file, "#u8("); + for (i = 0; i < blob->len; ++i) { + xfprintf(pic, file, "%d", blob->data[i]); + if (i + 1 < blob->len) { + xfprintf(pic, file, " "); } + } + xfprintf(pic, file, ")"); +} - if (pic_pair_p(obj)) { - traverse_shared(p, pic_car(p->pic, obj)); - traverse_shared(p, pic_cdr(p->pic, obj)); - } - else { - for (i = 0; i < pic_vec_ptr(obj)->len; ++i) { - traverse_shared(p, pic_vec_ptr(obj)->data[i]); - } - } - break; - default: - /* pass */ - break; +static void +write_char(pic_state *pic, char c, xFILE *file, int mode) +{ + if (mode == DISPLAY_MODE) { + xfputc(pic, c, file); + return; + } + switch (c) { + default: xfprintf(pic, file, "#\\%c", c); break; + case '\a': xfprintf(pic, file, "#\\alarm"); break; + case '\b': xfprintf(pic, file, "#\\backspace"); break; + case 0x7f: xfprintf(pic, file, "#\\delete"); break; + case 0x1b: xfprintf(pic, file, "#\\escape"); break; + case '\n': xfprintf(pic, file, "#\\newline"); break; + case '\r': xfprintf(pic, file, "#\\return"); break; + case ' ': xfprintf(pic, file, "#\\space"); break; + case '\t': xfprintf(pic, file, "#\\tab"); break; } } +static void +write_str(pic_state *pic, pic_str *str, xFILE *file, int mode) +{ + size_t i; + const char *cstr = pic_str_cstr(pic, str); + + if (mode == DISPLAY_MODE) { + xfprintf(pic, file, "%s", pic_str_cstr(pic, str)); + return; + } + xfprintf(pic, file, "\""); + for (i = 0; i < pic_str_len(str); ++i) { + if (cstr[i] == '"' || cstr[i] == '\\') { + xfputc(pic, '\\', file); + } + xfputc(pic, cstr[i], file); + } + xfprintf(pic, file, "\""); +} + +#if PIC_ENABLE_FLOAT +static void +write_float(pic_state *pic, double f, xFILE *file) +{ + if (isnan(f)) { + xfprintf(pic, file, signbit(f) ? "-nan.0" : "+nan.0"); + } else if (isinf(f)) { + xfprintf(pic, file, signbit(f) ? "-inf.0" : "+inf.0"); + } else { + xfprintf(pic, file, "%f", f); + } +} +#endif + static void write_core(struct writer_control *p, pic_value); static void -write_pair(struct writer_control *p, struct pic_pair *pair) +write_pair_help(struct writer_control *p, struct pic_pair *pair) { - xh_entry *e; - int c; + pic_state *pic = p->pic; + khash_t(l) *lh = &p->labels; + khash_t(v) *vh = &p->visited; + khiter_t it; + int ret; write_core(p, pair->car); @@ -122,279 +134,273 @@ write_pair(struct writer_control *p, struct pic_pair *pair) else if (pic_pair_p(pair->cdr)) { /* shared objects */ - if ((e = xh_get_ptr(&p->labels, pic_obj_ptr(pair->cdr))) && xh_val(e, int) != -1) { - xfprintf(p->file, " . "); + if ((it = kh_get(l, lh, pic_ptr(pair->cdr))) != kh_end(lh) && kh_val(lh, it) != -1) { + xfprintf(pic, p->file, " . "); - if ((xh_get_ptr(&p->visited, pic_obj_ptr(pair->cdr)))) { - xfprintf(p->file, "#%d#", xh_val(e, int)); + kh_put(v, vh, pic_ptr(pair->cdr), &ret); + if (ret == 0) { /* if exists */ + xfprintf(pic, p->file, "#%d#", kh_val(lh, it)); return; } - else { - xfprintf(p->file, "#%d=", xh_val(e, int)); - c = 1; - xh_put_ptr(&p->visited, pic_obj_ptr(pair->cdr), &c); - } + xfprintf(pic, p->file, "#%d=", kh_val(lh, it)); } else { - xfprintf(p->file, " "); + xfprintf(pic, p->file, " "); } - write_pair(p, pic_pair_ptr(pair->cdr)); + 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 { - xfprintf(p->file, " . "); + xfprintf(pic, p->file, " . "); write_core(p, pair->cdr); } } static void -write_str(pic_state *pic, struct pic_string *str, xFILE *file) +write_pair(struct writer_control *p, struct pic_pair *pair) { - size_t i; - const char *cstr = pic_str_cstr(pic, str); + pic_state *pic = p->pic; + xFILE *file = p->file; + pic_sym *tag; - for (i = 0; i < pic_str_len(str); ++i) { - if (cstr[i] == '"' || cstr[i] == '\\') { - xfputc('\\', file); + 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) { + xfprintf(pic, file, "'"); + write_core(p, pic_car(pic, pair->cdr)); + return; + } + else if (tag == pic->sUNQUOTE) { + xfprintf(pic, file, ","); + write_core(p, pic_car(pic, pair->cdr)); + return; + } + else if (tag == pic->sUNQUOTE_SPLICING) { + xfprintf(pic, file, ",@"); + write_core(p, pic_car(pic, pair->cdr)); + return; + } + else if (tag == pic->sQUASIQUOTE) { + xfprintf(pic, file, "`"); + write_core(p, pic_car(pic, pair->cdr)); + return; + } + else if (tag == pic->sSYNTAX_QUOTE) { + xfprintf(pic, file, "#'"); + write_core(p, pic_car(pic, pair->cdr)); + return; + } + else if (tag == pic->sSYNTAX_UNQUOTE) { + xfprintf(pic, file, "#,"); + write_core(p, pic_car(pic, pair->cdr)); + return; + } + else if (tag == pic->sSYNTAX_UNQUOTE_SPLICING) { + xfprintf(pic, file, "#,@"); + write_core(p, pic_car(pic, pair->cdr)); + return; + } + else if (tag == pic->sSYNTAX_QUASIQUOTE) { + xfprintf(pic, file, "#`"); + write_core(p, pic_car(pic, pair->cdr)); + return; } - xfputc(cstr[i], file); } + xfprintf(pic, file, "("); + write_pair_help(p, pair); + xfprintf(pic, file, ")"); } static void -write_record(pic_state *pic, struct pic_record *rec, xFILE *file) +write_vec(struct writer_control *p, pic_vec *vec) { - pic_sym *sWRITER = pic_intern_cstr(pic, "writer"); - pic_value type, writer, str; + pic_state *pic = p->pic; + xFILE *file = p->file; + size_t i; -#if DEBUG - - xfprintf(file, "#", rec); - -#else - - type = pic_record_type(pic, rec); - if (! pic_record_p(type)) { - pic_errorf(pic, "\"@@type\" property of record object is not of record type"); + xfprintf(pic, file, "#("); + for (i = 0; i < vec->len; ++i) { + write_core(p, vec->data[i]); + if (i + 1 < vec->len) { + xfprintf(pic, file, " "); + } } - writer = pic_record_ref(pic, pic_record_ptr(type), sWRITER); - if (! pic_proc_p(writer)) { - pic_errorf(pic, "\"writer\" property of record type object is not a procedure"); - } - str = pic_apply1(pic, pic_proc_ptr(writer), pic_obj_value(rec)); - if (! pic_str_p(str)) { - pic_errorf(pic, "return value from writer procedure is not of string type"); - } - xfprintf(file, "%s", pic_str_cstr(pic, pic_str_ptr(str))); + xfprintf(pic, file, ")"); +} -#endif +static void +write_dict(struct writer_control *p, struct pic_dict *dict) +{ + pic_state *pic = p->pic; + xFILE *file = p->file; + pic_sym *sym; + khiter_t it; + + 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)); + } + xfprintf(pic, file, ")"); } static void write_core(struct writer_control *p, pic_value obj) { pic_state *pic = p->pic; + khash_t(l) *lh = &p->labels; + khash_t(v) *vh = &p->visited; xFILE *file = p->file; - size_t i; - xh_entry *e, *it; - int c; -#if PIC_ENABLE_FLOAT - double f; -#endif + khiter_t it; + int ret; /* shared objects */ - if (pic_vtype(obj) == PIC_VTYPE_HEAP - && (e = xh_get_ptr(&p->labels, pic_obj_ptr(obj))) - && xh_val(e, int) != -1) { - if ((xh_get_ptr(&p->visited, pic_obj_ptr(obj)))) { - xfprintf(file, "#%d#", xh_val(e, int)); + 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)); return; } - else { - xfprintf(file, "#%d=", xh_val(e, int)); - c = 1; - xh_put_ptr(&p->visited, pic_obj_ptr(obj), &c); - } + xfprintf(pic, file, "#%d=", kh_val(lh, it)); } switch (pic_type(obj)) { case PIC_TT_UNDEF: - xfprintf(file, "#undefined"); + xfprintf(pic, file, "#undefined"); break; case PIC_TT_NIL: - xfprintf(file, "()"); + xfprintf(pic, file, "()"); break; case PIC_TT_BOOL: - if (pic_true_p(obj)) - xfprintf(file, "#t"); - else - xfprintf(file, "#f"); + xfprintf(pic, file, pic_true_p(obj) ? "#t" : "#f"); break; - case PIC_TT_PAIR: - if (is_quote(pic, obj)) { - xfprintf(file, "'"); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - else if (is_unquote(pic, obj)) { - xfprintf(file, ","); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - else if (is_unquote_splicing(pic, obj)) { - xfprintf(file, ",@"); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - else if (is_quasiquote(pic, obj)) { - xfprintf(file, "`"); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - xfprintf(file, "("); - write_pair(p, pic_pair_ptr(obj)); - xfprintf(file, ")"); + case PIC_TT_ID: + xfprintf(pic, file, "#", pic_symbol_name(pic, pic_var_name(pic, obj))); break; - case PIC_TT_SYMBOL: - xfprintf(file, "%s", pic_symbol_name(pic, pic_sym_ptr(obj))); + case PIC_TT_EOF: + xfprintf(pic, file, "#.(eof-object)"); break; - case PIC_TT_CHAR: - if (p->mode == DISPLAY_MODE) { - xfputc(pic_char(obj), file); - break; - } - switch (pic_char(obj)) { - default: xfprintf(file, "#\\%c", pic_char(obj)); break; - case '\a': xfprintf(file, "#\\alarm"); break; - case '\b': xfprintf(file, "#\\backspace"); break; - case 0x7f: xfprintf(file, "#\\delete"); break; - case 0x1b: xfprintf(file, "#\\escape"); break; - case '\n': xfprintf(file, "#\\newline"); break; - case '\r': xfprintf(file, "#\\return"); break; - case ' ': xfprintf(file, "#\\space"); break; - case '\t': xfprintf(file, "#\\tab"); break; - } + case PIC_TT_INT: + xfprintf(pic, file, "%d", pic_int(obj)); break; #if PIC_ENABLE_FLOAT case PIC_TT_FLOAT: - f = pic_float(obj); - if (isnan(f)) { - xfprintf(file, signbit(f) ? "-nan.0" : "+nan.0"); - } else if (isinf(f)) { - xfprintf(file, signbit(f) ? "-inf.0" : "+inf.0"); - } else { - xfprintf(file, "%f", pic_float(obj)); - } + write_float(pic, pic_float(obj), file); break; #endif - case PIC_TT_INT: - xfprintf(file, "%d", pic_int(obj)); - break; - case PIC_TT_EOF: - xfprintf(file, "#.(eof-object)"); - break; - case PIC_TT_STRING: - if (p->mode == DISPLAY_MODE) { - xfprintf(file, "%s", pic_str_cstr(pic, pic_str_ptr(obj))); - break; - } - xfprintf(file, "\""); - write_str(pic, pic_str_ptr(obj), file); - xfprintf(file, "\""); - break; - case PIC_TT_VECTOR: - xfprintf(file, "#("); - for (i = 0; i < pic_vec_ptr(obj)->len; ++i) { - write_core(p, pic_vec_ptr(obj)->data[i]); - if (i + 1 < pic_vec_ptr(obj)->len) { - xfprintf(file, " "); - } - } - xfprintf(file, ")"); + case PIC_TT_SYMBOL: + xfprintf(pic, file, "%s", pic_symbol_name(pic, pic_sym_ptr(obj))); break; case PIC_TT_BLOB: - xfprintf(file, "#u8("); - for (i = 0; i < pic_blob_ptr(obj)->len; ++i) { - xfprintf(file, "%d", pic_blob_ptr(obj)->data[i]); - if (i + 1 < pic_blob_ptr(obj)->len) { - xfprintf(file, " "); - } - } - xfprintf(file, ")"); + write_blob(pic, pic_blob_ptr(obj), file); + break; + case PIC_TT_CHAR: + write_char(pic, pic_char(obj), file, p->mode); + break; + case PIC_TT_STRING: + write_str(pic, pic_str_ptr(obj), file, p->mode); + break; + case PIC_TT_PAIR: + write_pair(p, pic_pair_ptr(obj)); + break; + case PIC_TT_VECTOR: + write_vec(p, pic_vec_ptr(obj)); break; case PIC_TT_DICT: - xfprintf(file, "#.(dictionary"); - for (it = xh_begin(&pic_dict_ptr(obj)->hash); it != NULL; it = xh_next(it)) { - xfprintf(file, " '%s ", pic_symbol_name(pic, xh_key(it, pic_sym *))); - write_core(p, xh_val(it, pic_value)); - } - xfprintf(file, ")"); - break; - case PIC_TT_RECORD: - write_record(pic, pic_record_ptr(obj), file); + write_dict(p, pic_dict_ptr(obj)); break; default: - xfprintf(file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj)); + xfprintf(pic, file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_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); + } + } +} + +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 */ + size_t 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) +write(pic_state *pic, pic_value obj, xFILE *file, int mode, int op) { struct writer_control p; - writer_control_init(&p, pic, file, WRITE_MODE); + writer_control_init(&p, pic, file, mode, op); - traverse_shared(&p, obj); /* FIXME */ + traverse(&p, obj); write_core(&p, obj); writer_control_destroy(&p); } -static void -write_simple(pic_state *pic, pic_value obj, xFILE *file) -{ - struct writer_control p; - - writer_control_init(&p, pic, file, WRITE_MODE); - - /* no traverse here! */ - - write_core(&p, obj); - - writer_control_destroy(&p); -} - -static void -write_shared(pic_state *pic, pic_value obj, xFILE *file) -{ - struct writer_control p; - - writer_control_init(&p, pic, file, WRITE_MODE); - - traverse_shared(&p, obj); - - write_core(&p, obj); - - writer_control_destroy(&p); -} - -static void -display(pic_state *pic, pic_value obj, xFILE *file) -{ - struct writer_control p; - - writer_control_init(&p, pic, file, DISPLAY_MODE); - - traverse_shared(&p, obj); /* FIXME */ - - write_core(&p, obj); - - writer_control_destroy(&p); -} pic_value pic_write(pic_state *pic, pic_value obj) @@ -405,8 +411,8 @@ pic_write(pic_state *pic, pic_value obj) pic_value pic_fwrite(pic_state *pic, pic_value obj, xFILE *file) { - write(pic, obj, file); - xfflush(file); + write(pic, obj, file, WRITE_MODE, OP_WRITE); + xfflush(pic, file); return obj; } @@ -419,8 +425,8 @@ pic_display(pic_state *pic, pic_value obj) pic_value pic_fdisplay(pic_state *pic, pic_value obj, xFILE *file) { - display(pic, obj, file); - xfflush(file); + write(pic, obj, file, DISPLAY_MODE, OP_WRITE); + xfflush(pic, file); return obj; } @@ -437,8 +443,8 @@ pic_printf(pic_state *pic, const char *fmt, ...) va_end(ap); - xfprintf(file, "%s", pic_str_cstr(pic, str)); - xfflush(file); + xfprintf(pic, file, "%s", pic_str_cstr(pic, str)); + xfflush(pic, file); } static pic_value @@ -448,7 +454,7 @@ pic_write_write(pic_state *pic) struct pic_port *port = pic_stdout(pic); pic_get_args(pic, "o|p", &v, &port); - write(pic, v, port->file); + write(pic, v, port->file, WRITE_MODE, OP_WRITE); return pic_undef_value(); } @@ -459,7 +465,7 @@ pic_write_write_simple(pic_state *pic) struct pic_port *port = pic_stdout(pic); pic_get_args(pic, "o|p", &v, &port); - write_simple(pic, v, port->file); + write(pic, v, port->file, WRITE_MODE, OP_WRITE_SIMPLE); return pic_undef_value(); } @@ -470,7 +476,7 @@ pic_write_write_shared(pic_state *pic) struct pic_port *port = pic_stdout(pic); pic_get_args(pic, "o|p", &v, &port); - write_shared(pic, v, port->file); + write(pic, v, port->file, WRITE_MODE, OP_WRITE_SHARED); return pic_undef_value(); } @@ -481,7 +487,7 @@ pic_write_display(pic_state *pic) struct pic_port *port = pic_stdout(pic); pic_get_args(pic, "o|p", &v, &port); - display(pic, v, port->file); + write(pic, v, port->file, DISPLAY_MODE, OP_WRITE); return pic_undef_value(); } diff --git a/piclib/picrin/array.scm b/piclib/picrin/array.scm index 5ae0c107..6412d136 100644 --- a/piclib/picrin/array.scm +++ b/piclib/picrin/array.scm @@ -93,19 +93,6 @@ (define (array-for-each proc ary) (for-each proc (array->list ary))) - (define-record-writer ( array) - (let ((port (open-output-string))) - (display "#.(array" port) - (array-for-each - (lambda (obj) - (display " " port) - (write obj port)) - array) - (display ")" port) - (let ((str (get-output-string port))) - (close-port port) - str))) - (export make-array array array? diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm index c81744a2..f0d988a5 100644 --- a/piclib/picrin/base.scm +++ b/piclib/picrin/base.scm @@ -6,11 +6,16 @@ quote set! begin - define-syntax) + define-macro) (export syntax-error + define-syntax let-syntax - letrec-syntax) + letrec-syntax + syntax-quote + syntax-quasiquote + syntax-unquote + syntax-unquote-splicing) (export let let* @@ -239,9 +244,19 @@ (export make-parameter parameterize) - (export identifier? - identifier=? - make-identifier) + (export make-identifier + identifier? + identifier-variable + identifier-environment + + variable? + variable=?) + + (export make-library + find-library + current-library + library-exports + library-environment) (export call-with-current-continuation call/cc @@ -270,4 +285,6 @@ write-shared display) - (export eval)) + (export eval) + + (export features)) diff --git a/piclib/picrin/control.scm b/piclib/picrin/control.scm new file mode 100644 index 00000000..51c6c7e7 --- /dev/null +++ b/piclib/picrin/control.scm @@ -0,0 +1,6 @@ +(define-library (picrin control) + (import (picrin base)) + + (define escape call/cc) ; create a new global variable slot + + (export escape)) diff --git a/piclib/picrin/experimental/lambda.scm b/piclib/picrin/experimental/lambda.scm index 5f6ac0ab..8bbcce40 100644 --- a/piclib/picrin/experimental/lambda.scm +++ b/piclib/picrin/experimental/lambda.scm @@ -1,49 +1,37 @@ (define-library (picrin experimental lambda) - (import (scheme base) - (picrin base) + (import (picrin base) (picrin macro)) - (define-syntax destructuring-bind - (ir-macro-transformer - (lambda (form inject compare) - (let ((formal (car (cdr form))) - (value (car (cdr (cdr form)))) - (body (cdr (cdr (cdr form))))) - (cond - ((symbol? formal) - `(let ((,formal ,value)) - ,@body)) - ((pair? formal) - `(let ((value# ,value)) - (destructuring-bind ,(car formal) (car value#) - (destructuring-bind ,(cdr formal) (cdr value#) - ,@body)))) - ((vector? formal) - ;; TODO - (error "fixme")) - (else - `(if (equal? ,value ',formal) - (begin - ,@body) - (error "match failure" ,value ',formal)))))))) + (define-syntax (destructuring-let formal value . body) + (cond + ((variable? formal) + #`(let ((#,formal #,value)) + #,@body)) + ((pair? formal) + #`(let ((value #,value)) + (destructuring-let #,(car formal) (car value) + (destructuring-let #,(cdr formal) (cdr value) + #,@body)))) + ((vector? formal) + ;; TODO + (error "fixme")) + (else + #`(if (equal? #,value '#,formal) + (begin + #,@body) + (error "match failure" #,value '#,formal))))) - (define-syntax destructuring-lambda - (ir-macro-transformer - (lambda (form inject compare) - (let ((args (car (cdr form))) - (body (cdr (cdr form)))) - `(lambda formal# (destructuring-bind ,args formal# ,@body)))))) + (define-syntax (destructuring-lambda formal . body) + #`(lambda args + (destructuring-let #,formal args #,@body))) - (define-syntax destructuring-define - (ir-macro-transformer - (lambda (form inject compare) - (let ((maybe-formal (cadr form))) - (if (symbol? maybe-formal) - `(define ,@(cdr form)) - `(destructuring-define ,(car maybe-formal) - (destructuring-lambda ,(cdr maybe-formal) - ,@(cddr form)))))))) + (define-syntax (destructuring-define formal . body) + (if (variable? formal) + #`(define #,formal #,@body) + #`(destructuring-define #,(car formal) + (destructuring-lambda #,(cdr formal) + #,@body)))) - (export (rename destructuring-bind bind) + (export (rename destructuring-let let) (rename destructuring-lambda lambda) (rename destructuring-define define))) diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm index e11d4eb7..d116a04a 100644 --- a/piclib/picrin/macro.scm +++ b/piclib/picrin/macro.scm @@ -1,141 +1,180 @@ (define-library (picrin macro) (import (picrin base)) - (export identifier? - identifier=? + ;; macro primitives + + (export define-macro make-identifier + identifier? + identifier-variable + identifier-environment + variable? + variable=?) + + ;; simple macro + + (export define-syntax + syntax-quote + syntax-quasiquote + syntax-unquote + syntax-unquote-splicing) + + ;; misc transformers + + (export call-with-current-environment make-syntactic-closure close-syntax - capture-syntactic-environment + strip-syntax sc-macro-transformer rsc-macro-transformer er-macro-transformer - ir-macro-transformer - ;; strip-syntax - define-macro) + ir-macro-transformer) - ;; assumes no derived expressions are provided yet - (define (walk proc expr) - "walk on symbols" - (if (null? expr) - '() - (if (pair? expr) - (cons (walk proc (car expr)) - (walk proc (cdr expr))) - (if (vector? expr) - (list->vector (walk proc (vector->list expr))) - (if (symbol? expr) - (proc expr) - expr))))) + (define-macro call-with-current-environment + (lambda (form env) + `(,(cadr form) ',env))) + + + ;; syntactic closure - (define (memoize f) - "memoize on symbols" - (define cache (make-dictionary)) - (lambda (sym) - (define value (dictionary-ref cache sym)) - (if (not (undefined? value)) - value - (begin - (define val (f sym)) - (dictionary-set! cache sym val) - val)))) (define (make-syntactic-closure env free form) - - (define resolve - (memoize - (lambda (sym) - (make-identifier sym env)))) - - (walk - (lambda (sym) - (if (memq sym free) - sym - (resolve sym))) - form)) + (letrec + ((wrap (let ((register (make-register))) + (lambda (var) + (let ((id (register var))) + (if (undefined? id) + (let ((id (make-identifier var env))) + (register var id) + id) + id))))) + (walk (lambda (f form) + (cond + ((variable? form) + (f form)) + ((pair? form) + (cons (walk f (car form)) (walk f (cdr form)))) + ((vector? form) + (list->vector (walk f (vector->list form)))) + (else + form))))) + (letrec + ((f (lambda (var) + (let loop ((free free)) + (if (null? free) + (wrap free) + (if (variable=? var (car free)) + var + (loop (cdr free)))))))) + (walk f form)))) (define (close-syntax form env) (make-syntactic-closure env '() form)) - (define-syntax capture-syntactic-environment - (lambda (mac-env) - (lambda (form use-env) - (list (cadr form) (list (make-identifier 'quote mac-env) mac-env))))) + (define (strip-syntax form) + (letrec + ((unwrap (lambda (var) + (identifier-variable var))) + (walk (lambda (f form) + (cond + ((variable? form) + (f form)) + ((pair? form) + (cons (walk f (car form)) (walk f (cdr form)))) + ((vector? form) + (list->vector (walk f (vector->list form)))) + (else + form))))) + (walk unwrap form))) - (define (sc-macro-transformer f) - (lambda (mac-env) - (lambda (expr use-env) - (make-syntactic-closure mac-env '() (f expr use-env))))) - (define (rsc-macro-transformer f) - (lambda (mac-env) - (lambda (expr use-env) - (make-syntactic-closure use-env '() (f expr mac-env))))) + ;; transformers - (define (er-macro-transformer f) - (lambda (mac-env) - (lambda (expr use-env) - (define rename - (memoize - (lambda (sym) - (make-identifier sym mac-env)))) + (define (sc-transformer f) + (lambda (form use-env mac-env) + (make-syntactic-closure mac-env '() (f form use-env)))) - (define (compare x y) - (if (not (symbol? x)) - #f - (if (not (symbol? y)) - #f - (identifier=? use-env x use-env y)))) + (define (rsc-transformer f) + (lambda (form use-env mac-env) + (make-syntactic-closure use-env '() (f form mac-env)))) - (f expr rename compare)))) + (define (er-transformer f) + (lambda (form use-env mac-env) + (letrec + ((rename (let ((register (make-register))) + (lambda (var) + (let ((id (register var))) + (if (undefined? id) + (let ((id (make-identifier var mac-env))) + (register var id) + id) + id))))) + (compare (lambda (x y) + (variable=? + (make-identifier x use-env) + (make-identifier y use-env))))) + (f form rename compare)))) - (define (ir-macro-transformer f) - (lambda (mac-env) - (lambda (expr use-env) + (define (ir-transformer f) + (lambda (form use-env mac-env) + (let ((register1 (make-register)) + (register2 (make-register))) + (letrec + ((inject (lambda (var1) + (let ((var2 (register1 var1))) + (if (undefined? var2) + (let ((var2 (make-identifier var1 use-env))) + (register1 var1 var2) + (register2 var2 var1) + var2) + var2)))) + (rename (let ((register (make-register))) + (lambda (var) + (let ((id (register var))) + (if (undefined? id) + (let ((id (make-identifier var mac-env))) + (register var id) + id) + id))))) + (flip (lambda (var2) ; unwrap if injected, wrap if not injected + (let ((var1 (register2 var2))) + (if (undefined? var1) + (rename var2) + var1)))) + (walk (lambda (f form) + (cond + ((variable? form) + (f form)) + ((pair? form) + (cons (walk f (car form)) (walk f (cdr form)))) + ((vector? form) + (list->vector (walk f (vector->list form)))) + (else + form)))) + (compare (lambda (x y) + (variable=? + (make-identifier x mac-env) + (make-identifier y mac-env))))) + (walk flip (f (walk inject form) inject compare)))))) - (define icache* (make-dictionary)) + (define-macro sc-macro-transformer + (lambda (f mac-env) + #`(lambda (form use-env) + ((sc-transformer #,(cadr f)) form use-env #,mac-env)))) - (define inject - (memoize - (lambda (sym) - (define id (make-identifier sym use-env)) - (dictionary-set! icache* id sym) - id))) + (define-macro rsc-macro-transformer + (lambda (f mac-env) + #`(lambda (form use-env) + ((rsc-transformer #,(cadr f)) form use-env #,mac-env)))) - (define rename - (memoize - (lambda (sym) - (make-identifier sym mac-env)))) + (define-macro er-macro-transformer + (lambda (f mac-env) + #`(lambda (form use-env) + ((er-transformer #,(cadr f)) form use-env #,mac-env)))) - (define (compare x y) - (if (not (symbol? x)) - #f - (if (not (symbol? y)) - #f - (identifier=? mac-env x mac-env y)))) - - (walk (lambda (sym) - (let ((value (dictionary-ref icache* sym))) - (if (undefined? value) - (rename sym) - value))) - (f (walk inject expr) inject compare))))) - - ;; (define (strip-syntax form) - ;; (walk ungensym form)) - - (define-syntax define-macro - (er-macro-transformer - (lambda (expr r c) - (define formal (car (cdr expr))) - (define body (cdr (cdr expr))) - (if (symbol? formal) - (list (r 'define-syntax) formal - (list (r 'lambda) (list (r 'form) '_ '_) - (list (r 'apply) (car body) (list (r 'cdr) (r 'form))))) - (list (r 'define-macro) (car formal) - (cons (r 'lambda) - (cons (cdr formal) - body)))))))) + (define-macro ir-macro-transformer + (lambda (f mac-env) + #`(lambda (form use-env) + ((ir-transformer #,(cadr f)) form use-env #,mac-env))))) diff --git a/piclib/picrin/record.scm b/piclib/picrin/record.scm index 7559cbbe..20d75f77 100644 --- a/piclib/picrin/record.scm +++ b/piclib/picrin/record.scm @@ -2,108 +2,58 @@ (import (picrin base) (picrin macro)) - ;; define-record-writer + ;; record meta type - (define (set-record-writer! record-type writer) - (record-set! record-type 'writer writer)) - - (define-syntax define-record-writer - (er-macro-transformer - (lambda (form r compare) - (let ((formal (cadr form))) - (if (pair? formal) - `(,(r 'set-record-writer!) ,(car formal) - (,(r 'lambda) (,(cadr formal)) - ,@(cddr form))) - `(,(r 'set-record-writer!) ,formal - ,@(cddr form))))))) - - ;; define-record-type - - (define ((default-record-writer ctor) obj) - (let ((port (open-output-string))) - (display "#.(" port) - (display (car ctor) port) - (for-each - (lambda (field) - (display " " port) - (write (record-ref obj field) port)) - (cdr ctor)) - (display ")" port) - (get-output-string port))) - - (define ((boot-make-record-type ) name ctor) + (define ((boot-make-record-type ) name) (let ((rectype (make-record ))) (record-set! rectype 'name name) - (record-set! rectype 'writer (default-record-writer ctor)) rectype)) (define - (let (( - ((boot-make-record-type #t) 'record-type '(record-type name writer)))) + (let (( ((boot-make-record-type #t) 'record-type))) (record-set! '@@type ) )) (define make-record-type (boot-make-record-type )) - (define-syntax define-record-constructor - (ir-macro-transformer - (lambda (form inject compare?) - (let ((rectype (car (cdr form))) - (name (car (cdr (cdr form)))) - (fields (cdr (cdr (cdr form))))) - `(define (,name ,@fields) - (let ((record (make-record ,rectype))) - ,@(map (lambda (field) - `(record-set! record ',field ,field)) - fields) - record)))))) + ;; define-record-type - (define-syntax define-record-predicate - (ir-macro-transformer - (lambda (form inject compare?) - (let ((rectype (car (cdr form))) - (name (car (cdr (cdr form))))) - `(define (,name obj) - (and (record? obj) - (eq? (record-type obj) - ,rectype))))))) + (define-syntax (define-record-constructor type name . fields) + (let ((record #'record)) + #`(define (#,name . #,fields) + (let ((#,record (make-record #,type))) + #,@(map (lambda (field) #`(record-set! #,record '#,field #,field)) fields) + #,record)))) - (define-syntax define-record-field - (ir-macro-transformer - (lambda (form inject compare?) - (let ((pred (car (cdr form))) - (field-name (car (cdr (cdr form)))) - (accessor (car (cdr (cdr (cdr form))))) - (modifier? (cdr (cdr (cdr (cdr form)))))) - (if (null? modifier?) - `(define (,accessor record) - (if (,pred record) - (record-ref record ',field-name) - (error (string-append (symbol->string ',accessor) ": wrong record type") record))) - `(begin - (define (,accessor record) - (if (,pred record) - (record-ref record ',field-name) - (error (string-append (symbol->string ',accessor) ": wrong record type") record))) - (define (,(car modifier?) record val) - (if (,pred record) - (record-set! record ',field-name val) - (error (string-append (symbol->string ',(car modifier?)) ": wrong record type") record))))))))) + (define-syntax (define-record-predicate type name) + #`(define (#,name obj) + (and (record? obj) + (eq? (record-type obj) #,type)))) - (define-syntax define-record-type - (ir-macro-transformer - (lambda (form inject compare?) - (let ((name (car (cdr form))) - (ctor (car (cdr (cdr form)))) - (pred (car (cdr (cdr (cdr form))))) - (fields (cdr (cdr (cdr (cdr form)))))) - `(begin - (define ,name (make-record-type ',name ',ctor)) - (define-record-constructor ,name ,@ctor) - (define-record-predicate ,name ,pred) - ,@(map (lambda (field) `(define-record-field ,pred ,@field)) - fields)))))) + (define-syntax (define-record-accessor pred field accessor) + #`(define (#,accessor record) + (if (#,pred record) + (record-ref record '#,field) + (error (string-append (symbol->string '#,accessor) ": wrong record type") record)))) - (export define-record-type - define-record-writer)) + (define-syntax (define-record-modifier pred field modifier) + #`(define (#,modifier record val) + (if (#,pred record) + (record-set! record '#,field val) + (error (string-append (symbol->string '#,modifier) ": wrong record type") record)))) + + (define-syntax (define-record-field pred field accessor . modifier-opt) + (if (null? modifier-opt) + #`(define-record-accessor #,pred #,field #,accessor) + #`(begin + (define-record-accessor #,pred #,field #,accessor) + (define-record-modifier #,pred #,field #,(car modifier-opt))))) + + (define-syntax (define-record-type name ctor pred . fields) + #`(begin + (define #,name (make-record-type '#,name)) + (define-record-constructor #,name #,@ctor) + (define-record-predicate #,name #,pred) + #,@(map (lambda (field) #`(define-record-field #,pred #,@field)) fields))) + + (export define-record-type)) diff --git a/piclib/picrin/syntax-rules.scm b/piclib/picrin/syntax-rules.scm index 6eeef05b..3e5496a3 100644 --- a/piclib/picrin/syntax-rules.scm +++ b/piclib/picrin/syntax-rules.scm @@ -1,348 +1,243 @@ (define-library (picrin syntax-rules) (import (picrin base) - (picrin control) (picrin macro)) - (define-syntax define-auxiliary-syntax - (er-macro-transformer - (lambda (expr r c) - (list (r 'define-syntax) (cadr expr) - (list (r 'lambda) '_ - (list (r 'lambda) '_ - (list (r 'error) (list (r 'string-append) "invalid use of auxiliary syntax: '" (symbol->string (cadr expr)) "'")))))))) + (define-syntax (define-auxiliary-syntax var) + #`(define-macro #,var + (lambda _ + (error "invalid use of auxiliary syntax" '#,var)))) (define-auxiliary-syntax _) (define-auxiliary-syntax ...) - (define (walk proc expr) - (cond - ((null? expr) - '()) - ((pair? expr) - (cons (walk proc (car expr)) - (walk proc (cdr expr)))) - ((vector? expr) - (list->vector (map proc (vector->list expr)))) - (else - (proc expr)))) + (define (succ n) + (+ n 1)) - (define (flatten expr) - (let ((list '())) - (walk - (lambda (x) - (set! list (cons x list))) - expr) - (reverse list))) + (define (pred n) + (if (= n 0) + 0 + (- n 1))) - (define (reverse* l) - ;; (reverse* '(a b c d . e)) => (e d c b a) - (let loop ((a '()) - (d l)) - (if (pair? d) - (loop (cons (car d) a) (cdr d)) - (cons d a)))) - - (define (every? pred l) - (if (null? l) + (define (every? args) + (if (null? args) #t - (and (pred (car l)) (every? pred (cdr l))))) + (if (car args) + (every? (cdr args)) + #f))) - (define-syntax syntax-rules - (er-macro-transformer - (lambda (form r compare) - (define _define (r 'define)) - (define _let (r 'let)) - (define _if (r 'if)) - (define _begin (r 'begin)) - (define _lambda (r 'lambda)) - (define _set! (r 'set!)) - (define _not (r 'not)) - (define _and (r 'and)) - (define _car (r 'car)) - (define _cdr (r 'cdr)) - (define _cons (r 'cons)) - (define _pair? (r 'pair?)) - (define _null? (r 'null?)) - (define _symbol? (r 'symbol?)) - (define _vector? (r 'vector?)) - (define _eqv? (r 'eqv?)) - (define _string=? (r 'string=?)) - (define _map (r 'map)) - (define _vector->list (r 'vector->list)) - (define _list->vector (r 'list->vector)) - (define _quote (r 'quote)) - (define _quasiquote (r 'quasiquote)) - (define _unquote (r 'unquote)) - (define _unquote-splicing (r 'unquote-splicing)) - (define _syntax-error (r 'syntax-error)) - (define _escape (r 'escape)) - (define _er-macro-transformer (r 'er-macro-transformer)) + (define (filter f list) + (if (null? list) + '() + (if (f (car list)) + (cons (car list) + (filter f (cdr list))) + (filter f (cdr list))))) - (define (var->sym v) - (let loop ((cnt 0) - (v v)) - (if (symbol? v) - (string->symbol - (string-append (symbol->string v) "/" (number->string cnt))) - (loop (+ 1 cnt) (car v))))) + (define (take-tail n list) + (let drop ((n (- (length list) n)) (list list)) + (if (= n 0) + list + (drop (- n 1) (cdr list))))) - (define push-var list) + (define (drop-tail n list) + (let take ((n (- (length list) n)) (list list)) + (if (= n 0) + '() + (cons (car list) (take (- n 1) (cdr list)))))) - (define (compile-match ellipsis literals pattern) - (letrec ((compile-match-base - (lambda (pattern) - (cond ((member pattern literals compare) - (values - `(,_if (,_and (,_symbol? expr) (cmp expr (rename ',pattern))) - #f - (exit #f)) - '())) - ((compare pattern (r '_)) (values #f '())) - ((and ellipsis (compare pattern ellipsis)) - (values `(,_syntax-error "invalid pattern") '())) - ((symbol? pattern) - (values `(,_set! ,(var->sym pattern) expr) (list pattern))) - ((pair? pattern) - (compile-match-list pattern)) - ((vector? pattern) - (compile-match-vector pattern)) - ((string? pattern) - (values - `(,_if (,_not (,_string=? ',pattern expr)) - (exit #f)) - '())) - (else - (values - `(,_if (,_not (,_eqv? ',pattern expr)) - (exit #f)) - '()))))) + (define (map-keys f assoc) + (map (lambda (s) `(,(f (car s)) . ,(cdr s))) assoc)) - (compile-match-list - (lambda (pattern) - (let loop ((pattern pattern) - (matches '()) - (vars '()) - (accessor 'expr)) - (cond ;; (hoge) - ((not (pair? (cdr pattern))) - (let*-values (((match1 vars1) (compile-match-base (car pattern))) - ((match2 vars2) (compile-match-base (cdr pattern)))) - (values - `(,_begin ,@(reverse matches) - (,_if (,_pair? ,accessor) - (,_begin - (,_let ((expr (,_car ,accessor))) - ,match1) - (,_let ((expr (,_cdr ,accessor))) - ,match2)) - (exit #f))) - (append vars (append vars1 vars2))))) - ;; (hoge ... rest args) - ((and ellipsis (compare (cadr pattern) ellipsis)) - (let-values (((match-r vars-r) (compile-match-list-reverse pattern))) - (values - `(,_begin ,@(reverse matches) - (,_let ((expr (,_let loop ((a ()) - (d ,accessor)) - (,_if (,_pair? d) - (loop (,_cons (,_car d) a) (,_cdr d)) - (,_cons d a))))) - ,match-r)) - (append vars vars-r)))) - (else - (let-values (((match1 vars1) (compile-match-base (car pattern)))) - (loop (cdr pattern) - (cons `(,_if (,_pair? ,accessor) - (,_let ((expr (,_car ,accessor))) - ,match1) - (exit #f)) - matches) - (append vars vars1) - `(,_cdr ,accessor)))))))) + (define (map-values f assoc) + (map (lambda (s) `(,(car s) . ,(f (cdr s)))) assoc)) - (compile-match-list-reverse - (lambda (pattern) - (let loop ((pattern (reverse* pattern)) - (matches '()) - (vars '()) - (accessor 'expr)) - (cond ((and ellipsis (compare (car pattern) ellipsis)) - (let-values (((match1 vars1) (compile-match-ellipsis (cadr pattern)))) - (values - `(,_begin ,@(reverse matches) - (,_let ((expr ,accessor)) - ,match1)) - (append vars vars1)))) - (else - (let-values (((match1 vars1) (compile-match-base (car pattern)))) - (loop (cdr pattern) - (cons `(,_let ((expr (,_car ,accessor))) ,match1) matches) - (append vars vars1) - `(,_cdr ,accessor)))))))) + ;; TODO + ;; - placeholder + ;; - vector + ;; - (... template) pattern - (compile-match-ellipsis - (lambda (pattern) - (let-values (((match vars) (compile-match-base pattern))) - (values - `(,_let loop ((expr expr)) - (,_if (,_not (,_null? expr)) - (,_let ,(map (lambda (var) `(,(var->sym var) '())) vars) - (,_let ((expr (,_car expr))) - ,match) - ,@(map - (lambda (var) - `(,_set! ,(var->sym (push-var var)) - (,_cons ,(var->sym var) ,(var->sym (push-var var))))) - vars) - (loop (,_cdr expr))))) - (map push-var vars))))) + ;; p ::= constant + ;; | var + ;; | (p ... . p) (in input pattern, tail p should be a proper list) + ;; | (p . p) - (compile-match-vector - (lambda (pattern) - (let-values (((match vars) (compile-match-base (vector->list pattern)))) - (values - `(,_if (,_vector? expr) - (,_let ((expr (,_vector->list expr))) - ,match) - (exit #f)) - vars))))) + (define (compile ellipsis literals rules) - (let-values (((match vars) (compile-match-base (cdr pattern)))) - (values `(,_let ((expr (,_cdr expr))) - ,match - #t) - vars)))) + (define (constant? obj) + (and (not (pair? obj)) + (not (variable? obj)))) -;;; compile expand - (define (compile-expand ellipsis reserved template) - (letrec ((compile-expand-base - (lambda (template ellipsis-valid) - (cond ((member template reserved eq?) - (values (var->sym template) (list template))) - ((symbol? template) - (values `(rename ',template) '())) - ((pair? template) - (compile-expand-list template ellipsis-valid)) - ((vector? template) - (compile-expand-vector template ellipsis-valid)) - (else - (values `',template '()))))) + (define (literal? obj) + (and (variable? obj) + (memq obj literals))) - (compile-expand-list - (lambda (template ellipsis-valid) - (let loop ((template template) - (expands '()) - (vars '())) - (cond ;; (... hoge) - ((and ellipsis-valid - (pair? template) - (compare (car template) ellipsis)) - (if (and (pair? (cdr template)) (null? (cddr template))) - (compile-expand-base (cadr template) #f) - (values '(,_syntax-error "invalid template") '()))) - ;; hoge - ((not (pair? template)) - (let-values (((expand1 vars1) - (compile-expand-base template ellipsis-valid))) - (values - `(,_quasiquote (,@(reverse expands) . (,_unquote ,expand1))) - (append vars vars1)))) - ;; (a ... rest syms) - ((and ellipsis-valid - (pair? (cdr template)) - (compare (cadr template) ellipsis)) - (let-values (((expand1 vars1) - (compile-expand-base (car template) ellipsis-valid))) - (loop (cddr template) - (cons - `(,_unquote-splicing - (,_map (,_lambda ,(map var->sym vars1) ,expand1) - ,@(map (lambda (v) (var->sym (push-var v))) vars1))) - expands) - (append vars (map push-var vars1))))) - (else - (let-values (((expand1 vars1) - (compile-expand-base (car template) ellipsis-valid))) - (loop (cdr template) - (cons - `(,_unquote ,expand1) - expands) - (append vars vars1)))))))) + (define (many? pat) + (and (pair? pat) + (pair? (cdr pat)) + (variable? (cadr pat)) + (variable=? (cadr pat) ellipsis))) - (compile-expand-vector - (lambda (template ellipsis-valid) - (let-values (((expand1 vars1) - (compile-expand-base (vector->list template) ellipsis-valid))) - (values - `(,_list->vector ,expand1) - vars1))))) + (define (pattern-validator pat) ; pattern -> validator + (letrec + ((pattern-validator + (lambda (pat form) + (cond + ((constant? pat) + #`(equal? '#,pat #,form)) + ((literal? pat) + #`(and (variable? #,form) (variable=? #'#,pat #,form))) + ((variable? pat) + #t) + ((many? pat) + (let ((head #`(drop-tail #,(length (cddr pat)) #,form)) + (tail #`(take-tail #,(length (cddr pat)) #,form))) + #`(and (list? #,form) + (>= (length #,form) #,(length (cddr pat))) + (every? (map (lambda (#,'it) #,(pattern-validator (car pat) 'it)) #,head)) + #,(pattern-validator (cddr pat) tail)))) + ((pair? pat) + #`(and (pair? #,form) + #,(pattern-validator (car pat) #`(car #,form)) + #,(pattern-validator (cdr pat) #`(cdr #,form)))) + (else + #f))))) + (pattern-validator pat 'it))) - (compile-expand-base template ellipsis))) + (define (pattern-variables pat) ; pattern -> (freevar) + (cond + ((constant? pat) + '()) + ((literal? pat) + '()) + ((variable? pat) + `(,pat)) + ((many? pat) + (append (pattern-variables (car pat)) + (pattern-variables (cddr pat)))) + ((pair? pat) + (append (pattern-variables (car pat)) + (pattern-variables (cdr pat)))))) - (define (check-vars vars-pattern vars-template) - ;;fixme - #t) + (define (pattern-levels pat) ; pattern -> ((var * int)) + (cond + ((constant? pat) + '()) + ((literal? pat) + '()) + ((variable? pat) + `((,pat . 0))) + ((many? pat) + (append (map-values succ (pattern-levels (car pat))) + (pattern-levels (cddr pat)))) + ((pair? pat) + (append (pattern-levels (car pat)) + (pattern-levels (cdr pat)))))) - (define (compile-rule ellipsis literals rule) - (let ((pattern (car rule)) - (template (cadr rule))) - (let*-values (((match vars-match) - (compile-match ellipsis literals pattern)) - ((expand vars-expand) - (compile-expand ellipsis (flatten vars-match) template))) - (if (check-vars vars-match vars-expand) - (list vars-match match expand) - 'mismatch)))) + (define (pattern-selectors pat) ; pattern -> ((var * selector)) + (letrec + ((pattern-selectors + (lambda (pat form) + (cond + ((constant? pat) + '()) + ((literal? pat) + '()) + ((variable? pat) + `((,pat . ,form))) + ((many? pat) + (let ((head #`(drop-tail #,(length (cddr pat)) #,form)) + (tail #`(take-tail #,(length (cddr pat)) #,form))) + (let ((envs (pattern-selectors (car pat) 'it))) + (append + (map-values (lambda (s) #`(map (lambda (#,'it) #,s) #,head)) envs) + (pattern-selectors (cddr pat) tail))))) + ((pair? pat) + (append (pattern-selectors (car pat) #`(car #,form)) + (pattern-selectors (cdr pat) #`(cdr #,form)))))))) + (pattern-selectors pat 'it))) - (define (expand-clauses clauses rename) - (cond ((null? clauses) - `(,_quote (syntax-error "no matching pattern"))) - ((compare (car clauses) 'mismatch) - `(,_syntax-error "invalid rule")) - (else - (let ((vars (list-ref (car clauses) 0)) - (match (list-ref (car clauses) 1)) - (expand (list-ref (car clauses) 2))) - `(,_let ,(map (lambda (v) (list (var->sym v) '())) vars) - (,_let ((result (,_escape (,_lambda (exit) ,match)))) - (,_if result - ,expand - ,(expand-clauses (cdr clauses) rename)))))))) + (define (template-representation pat levels selectors) + (cond + ((constant? pat) + pat) + ((variable? pat) + (let ((it (assq pat levels))) + (if it + (if (= 0 (cdr it)) + (cdr (assq pat selectors)) + (error "unmatched pattern variable level" pat)) + #`(#,'rename '#,pat)))) + ((many? pat) + (letrec* + ((inner-pat + (car pat)) + (inner-levels + (map (lambda (s) `(,(car s) . ,(pred (cdr s)))) levels)) + (inner-freevars + (filter (lambda (v) (assq v levels)) (pattern-variables inner-pat))) + (inner-vars + ;; select only vars declared with ellipsis + (filter (lambda (v) (> (cdr (assq v levels)) 0)) inner-freevars)) + (inner-tmps + (map (lambda (v) #'it) inner-vars)) + (inner-selectors + ;; first env '(map cons ...)' shadows second env 'selectors' + (append (map cons inner-vars inner-tmps) selectors)) + (inner-rep + (template-representation inner-pat inner-levels inner-selectors)) + (sorted-selectors + (map (lambda (v) (assq v selectors)) inner-vars)) + (list-of-selectors + ;; ((a . xs) (b . ys) (c . zs)) -> (xs ys zs) + (map cdr sorted-selectors))) + (let ((rep1 #`(map (lambda #,inner-tmps #,inner-rep) #,@list-of-selectors)) + (rep2 (template-representation (cddr pat) levels selectors))) + #`(append #,rep1 #,rep2)))) + ((pair? pat) + #`(cons #,(template-representation (car pat) levels selectors) + #,(template-representation (cdr pat) levels selectors))))) - (define (normalize-form form) - (if (and (list? form) (>= (length form) 2)) - (let ((ellipsis '...) - (literals (cadr form)) - (rules (cddr form))) + (define (compile-rule pattern template) + (let ((levels + (pattern-levels pattern)) + (selectors + (pattern-selectors pattern))) + (template-representation template levels selectors))) - (when (symbol? literals) - (set! ellipsis literals) - (set! literals (car rules)) - (set! rules (cdr rules))) + (define (compile-rules rules) + (if (null? rules) + #`(error "unmatch") + (let ((pattern (car (car rules))) + (template (cadr (car rules)))) + #`(if #,(pattern-validator pattern) + #,(compile-rule pattern template) + #,(compile-rules (cdr rules)))))) - (if (and (symbol? ellipsis) - (list? literals) - (every? symbol? literals) - (list? rules) - (every? (lambda (l) (and (list? l) (= (length l) 2))) rules)) - (if (member ellipsis literals compare) - `(syntax-rules #f ,literals ,@rules) - `(syntax-rules ,ellipsis ,literals ,@rules)) - #f)) - #f)) + (define (compile rules) + #`(call-with-current-environment + (lambda (env) + (letrec + ((#,'rename (let ((reg (make-register))) + (lambda (x) + (if (undefined? (reg x)) + (let ((id (make-identifier x env))) + (reg x id) + id) + (reg x)))))) + (lambda #,'it + #,(compile-rules rules)))))) - (let ((form (normalize-form form))) - (if form - (let ((ellipsis (list-ref form 1)) - (literals (list-ref form 2)) - (rules (list-tail form 3))) - (let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule)) - rules))) - `(,_er-macro-transformer - (,_lambda (expr rename cmp) - ,(expand-clauses clauses r))))) + (let ((rules (map-keys cdr rules))) ; TODO: check pattern head is a variable + (compile rules))) + + (define-syntax (syntax-rules . args) + (if (list? (car args)) + #`(syntax-rules ... #,@args) + (let ((ellipsis (car args)) + (literals (car (cdr args))) + (rules (cdr (cdr args)))) + (compile ellipsis literals rules)))) - `(,_syntax-error "malformed syntax-rules")))))) (export syntax-rules _ diff --git a/src/main.c b/src/main.c index fbdae10c..a20c52fe 100644 --- a/src/main.c +++ b/src/main.c @@ -7,14 +7,6 @@ void pic_init_contrib(pic_state *); void pic_load_piclib(pic_state *); -static pic_value -pic_features(pic_state *pic) -{ - pic_get_args(pic, ""); - - return pic->features; -} - static pic_value pic_libraries(pic_state *pic) { @@ -38,10 +30,6 @@ pic_init_picrin(pic_state *pic) pic_defun(pic, "libraries", pic_libraries); } - pic_deflibrary (pic, "(scheme base)") { - pic_defun(pic, "features", pic_features); - } - pic_init_contrib(pic); pic_load_piclib(pic); } @@ -53,13 +41,14 @@ main(int argc, char *argv[], char **envp) struct pic_lib *PICRIN_MAIN; int status = 0; - pic = pic_open(argc, argv, envp, pic_default_allocf); - - pic_init_picrin(pic); - - PICRIN_MAIN = pic_find_library(pic, pic_read_cstr(pic, "(picrin main)")); + pic = pic_open(pic_default_allocf, NULL); + pic_set_argv(pic, argc, argv, 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_catch { diff --git a/t/ir-macro.scm b/t/ir-macro.scm index a68806d6..ebb26faf 100644 --- a/t/ir-macro.scm +++ b/t/ir-macro.scm @@ -1,7 +1,10 @@ (import (scheme base) - (picrin macro)) + (picrin macro) + (picrin test)) -(define-syntax aif +(test-begin) + +(define-macro aif (ir-macro-transformer (lambda (form inject cmp) (let ((it (inject 'it)) @@ -11,11 +14,12 @@ `(let ((,it ,expr)) (if ,it ,then ,else)))))) -(aif (member 'b '(a b c)) (car it) #f) +(test 'b + (aif (member 'b '(a b c)) (car it) #f)) ;;; test hygiene begin -(define-syntax mif +(define-macro mif (ir-macro-transformer (lambda (form inject cmp) (let ((expr (car (cdr form))) @@ -24,12 +28,14 @@ `(let ((it ,expr)) (if it ,then ,else)))))) -(let ((if 42)) - (mif 1 2 3)) +(test 2 + (let ((if 42)) + (mif 1 2 3))) ; => 2 -(let ((it 42)) - (mif 1 it 2)) +(test 42 + (let ((it 42)) + (mif 1 it 2))) ; => 42 ;;; end @@ -38,10 +44,10 @@ ;;; test core syntax begin -(mif 'a 'b 'c) +(test 'b (mif 'a 'b 'c)) ; => b -(define-syntax loop +(define-macro loop (ir-macro-transformer (lambda (expr inject cmp) (let ((body (cdr expr))) @@ -51,14 +57,16 @@ ,@body (f)))))))) (define a 1) -(loop - (if (= a 2) (exit #f)) - (set! a 2)) +(test #f + (loop + (if (= a 2) (exit #f)) + (set! a 2))) ; => #f -(loop - (define a 1) - (if (= a 1) (exit #f))) +(test #f + (loop + (define a 1) + (if (= a 1) (exit #f)))) ; => #f -;;; end +(test-end) diff --git a/t/parameterize.scm b/t/parameterize.scm index 4d0a8571..e5454136 100644 --- a/t/parameterize.scm +++ b/t/parameterize.scm @@ -1,12 +1,15 @@ (import (scheme base) - (scheme write)) + (picrin test)) -; expects "piece by piece by piece.\n" -(write - (parameterize - ((current-output-port (open-output-string))) - (display "piece") - (display " by piece ") - (display "by piece.") - (newline) - (get-output-string))) +(test-begin) + +(test "piece by piece by piece.\n" + (parameterize + ((current-output-port (open-output-string))) + (display "piece") + (display " by piece ") + (display "by piece.") + (newline) + (get-output-string))) + +(test-end) diff --git a/t/syntax-rules.scm b/t/syntax-rules.scm new file mode 100644 index 00000000..12b16a95 --- /dev/null +++ b/t/syntax-rules.scm @@ -0,0 +1,40 @@ +(import (picrin base) + (picrin syntax-rules) + (picrin test)) + +(test-begin) + +(define-syntax extract? + (syntax-rules () + ((_ symb body _cont-t _cont-f) + (letrec-syntax + ((tr + (syntax-rules (symb) + ((_ x symb tail (cont-head symb-l . cont-args) cont-false) + (cont-head (x . symb-l) . cont-args)) + ((_ d (x . y) tail . rest) ; if body is a composite form, + (tr x x (y . tail) . rest)) ; look inside + ((_ d1 d2 () cont-t (cont-head symb-l . cont-args)) + (cont-head (symb . symb-l) . cont-args)) + ((_ d1 d2 (x . y) . rest) + (tr x x y . rest))))) + (tr body body () _cont-t _cont-f))))) + +(define-syntax extract + (syntax-rules () + ((_ symb body cont) + (extract? symb body cont cont)))) + +(define-syntax mbi-dirty-v1 + (syntax-rules () + ((_ _val _body) + (let-syntax + ((cont + (syntax-rules () + ((_ (symb) val body) + (let ((symb val)) body))))) + (extract i _body (cont () _val _body)))))) + +(test 11 (mbi-dirty-v1 10 (+ i 1))) + +(test-end)