From 483edb57087c956c035b477e7529cb2906894733 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Jun 2015 22:37:05 +0900 Subject: [PATCH 001/125] flush all xFILEs at exit --- extlib/benz/state.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 0caa2a6b..8ab9e296 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -429,6 +429,9 @@ pic_close(pic_state *pic) /* free all heap objects */ pic_gc_run(pic); + /* flush all xfiles */ + xfflush(NULL); + /* free heaps */ pic_heap_close(pic, pic->heap); From 4445a170587d83a3e9957ec87b08749a482e089e Mon Sep 17 00:00:00 2001 From: Richard Hopkins Date: Thu, 11 Jun 2015 22:25:15 +0100 Subject: [PATCH 002/125] insall -> install for PHONY target in Makefile --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index ea71bca4..06891f47 100644 --- a/Makefile +++ b/Makefile @@ -85,4 +85,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) From 2816f206fb5908f98f4fb20ac6fe01da3a6d376b Mon Sep 17 00:00:00 2001 From: OGINO Masanori Date: Fri, 12 Jun 2015 18:59:59 +0900 Subject: [PATCH 003/125] Define GCC_VERSION in util.h temporarily. Signed-off-by: OGINO Masanori --- extlib/benz/include/picrin/util.h | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/extlib/benz/include/picrin/util.h b/extlib/benz/include/picrin/util.h index 5c831bad..ad816c70 100644 --- a/extlib/benz/include/picrin/util.h +++ b/extlib/benz/include/picrin/util.h @@ -56,11 +56,19 @@ extern "C" { # 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) From 617dbdb1bc2323910ba7e5890c6a47b36974b9b1 Mon Sep 17 00:00:00 2001 From: "Sunrim KIM (keen)" <3han5chou7@gmail.com> Date: Sat, 13 Jun 2015 05:33:49 +0900 Subject: [PATCH 004/125] update C API doc --- docs/capi.rst | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) 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 From 2f4eeefb0516b32287b969fc171cae2e9e3d48de Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 15 Jun 2015 02:14:00 +0900 Subject: [PATCH 005/125] don't compile with DEBUG=1 even if the build was in debug mode --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 06891f47..287e43b3 100644 --- a/Makefile +++ b/Makefile @@ -33,7 +33,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 From 6c1abe32fed4faa19ec9b6a7aebe86da3cf10b4d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Jun 2015 02:28:32 +0900 Subject: [PATCH 006/125] s/registry/register/g --- extlib/benz/reg.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extlib/benz/reg.c b/extlib/benz/reg.c index b23da584..7ba1499a 100644 --- a/extlib/benz/reg.c +++ b/extlib/benz/reg.c @@ -44,7 +44,7 @@ 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)); + pic_errorf(pic, "no slot named ~s found in register", pic_obj_value(key)); } xh_del_ptr(®->hash, key); @@ -85,7 +85,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 +98,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; @@ -117,5 +117,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); } From c3a6bffa61c40f6dd6bdc66ac457b5e3431fa4eb Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 13 Jun 2015 13:05:28 +0900 Subject: [PATCH 007/125] run perl boot.c when running make --- Makefile | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Makefile b/Makefile index 287e43b3..7bbbf99e 100644 --- a/Makefile +++ b/Makefile @@ -48,6 +48,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 From 9ace96dd19dc7617e04647d38a69f24645c7a53f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 15 Jun 2015 02:03:13 +0900 Subject: [PATCH 008/125] rewrite scheme/lazy.scm with syntax-rules --- contrib/05.r7rs/scheme/lazy.scm | 40 ++++++++++++++++----------------- 1 file changed, 19 insertions(+), 21 deletions(-) diff --git a/contrib/05.r7rs/scheme/lazy.scm b/contrib/05.r7rs/scheme/lazy.scm index 70774f21..7378c384 100644 --- a/contrib/05.r7rs/scheme/lazy.scm +++ b/contrib/05.r7rs/scheme/lazy.scm @@ -5,38 +5,36 @@ (picrin macro)) (define-record-type - (make-promise% done obj) - promise? - (done promise-done? promise-done!) - (obj promise-value promise-value!)) + (make-promise% done value) + promise? + (done promise-done? set-promise-done!) + (value promise-value set-promise-value!)) (define-syntax delay-force - (ir-macro-transformer - (lambda (form rename compare?) - (let ((expr (cadr form))) - `(make-promise% #f (lambda () ,expr)))))) + (syntax-rules () + ((_ expr) + (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))) + (syntax-rules () + ((_ expr) + (delay-force (make-promise% #t expr))))) (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)))) + (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?)) + (export delay-force + delay + force + make-promise + promise?)) From 015971ffc44da5c9b141b04f0108b9d7e51ca883 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 15 Jun 2015 02:22:55 +0900 Subject: [PATCH 009/125] remove define-record-writer --- extlib/benz/write.c | 32 -------------------------------- piclib/picrin/array.scm | 13 ------------- piclib/picrin/record.scm | 38 ++++---------------------------------- 3 files changed, 4 insertions(+), 79 deletions(-) diff --git a/extlib/benz/write.c b/extlib/benz/write.c index 73ee11f5..4c9d7333 100644 --- a/extlib/benz/write.c +++ b/extlib/benz/write.c @@ -162,35 +162,6 @@ write_str(pic_state *pic, struct pic_string *str, xFILE *file) } } -static void -write_record(pic_state *pic, struct pic_record *rec, xFILE *file) -{ - pic_sym *sWRITER = pic_intern_cstr(pic, "writer"); - pic_value type, writer, str; - -#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"); - } - 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))); - -#endif -} - static void write_core(struct writer_control *p, pic_value obj) { @@ -331,9 +302,6 @@ write_core(struct writer_control *p, pic_value obj) } xfprintf(file, ")"); break; - case PIC_TT_RECORD: - write_record(pic, pic_record_ptr(obj), file); - break; default: xfprintf(file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj)); break; 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/record.scm b/piclib/picrin/record.scm index 7559cbbe..fccc1bd4 100644 --- a/piclib/picrin/record.scm +++ b/piclib/picrin/record.scm @@ -2,45 +2,16 @@ (import (picrin base) (picrin macro)) - ;; define-record-writer - - (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)))) + ((boot-make-record-type #t) 'record-type))) (record-set! '@@type ) )) @@ -99,11 +70,10 @@ (pred (car (cdr (cdr (cdr form))))) (fields (cdr (cdr (cdr (cdr form)))))) `(begin - (define ,name (make-record-type ',name ',ctor)) + (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 - define-record-writer)) + (export define-record-type)) From 454146ab5225a7bda229b3835f3e0be39c6f1797 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Jun 2015 01:06:56 +0900 Subject: [PATCH 010/125] s/rXXX/uXXX/g --- extlib/benz/bool.c | 2 +- extlib/benz/codegen.c | 52 ++++++++++++------------ extlib/benz/cont.c | 4 +- extlib/benz/gc.c | 18 ++++----- extlib/benz/include/picrin.h | 18 ++++----- extlib/benz/lib.c | 18 ++++----- extlib/benz/macro.c | 16 ++++---- extlib/benz/number.c | 18 ++++----- extlib/benz/pair.c | 10 ++--- extlib/benz/state.c | 76 ++++++++++++++++++------------------ extlib/benz/symbol.c | 2 +- 11 files changed, 117 insertions(+), 117 deletions(-) diff --git a/extlib/benz/bool.c b/extlib/benz/bool.c index 33b6d0bf..9a1e02ef 100644 --- a/extlib/benz/bool.c +++ b/extlib/benz/bool.c @@ -195,7 +195,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/codegen.c b/extlib/benz/codegen.c index 79d4126c..d2d0fbe2 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -331,7 +331,7 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v : 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); + body = analyze(state, pic_cons(pic, pic_obj_value(pic->uBEGIN), body_exprs), true); analyze_deferred(state); @@ -399,7 +399,7 @@ analyze_define(analyze_state *state, pic_value obj) 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_sym_ptr(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) == pic->uLAMBDA) { pic_value formals, body_exprs; formals = pic_list_ref(pic, pic_list_ref(pic, obj, 2), 1); @@ -698,88 +698,88 @@ 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) { + if (sym == pic->uDEFINE) { return analyze_define(state, obj); } - else if (sym == pic->rLAMBDA) { + else if (sym == pic->uLAMBDA) { return analyze_lambda(state, obj); } - else if (sym == pic->rIF) { + else if (sym == pic->uIF) { return analyze_if(state, obj, tailpos); } - else if (sym == pic->rBEGIN) { + else if (sym == pic->uBEGIN) { return analyze_begin(state, obj, tailpos); } - else if (sym == pic->rSETBANG) { + else if (sym == pic->uSETBANG) { return analyze_set(state, obj); } - else if (sym == pic->rQUOTE) { + else if (sym == pic->uQUOTE) { return analyze_quote(state, 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) { + else if (sym == pic->uADD) { return analyze_add(state, obj, tailpos); } - else if (sym == pic->rSUB) { + else if (sym == pic->uSUB) { return analyze_sub(state, obj); } - else if (sym == pic->rMUL) { + else if (sym == pic->uMUL) { return analyze_mul(state, obj, tailpos); } - else if (sym == pic->rDIV) { + else if (sym == pic->uDIV) { return analyze_div(state, 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) { + else if (sym == pic->uVALUES) { return analyze_values(state, obj, tailpos); } - else if (sym == pic->rCALL_WITH_VALUES) { + else if (sym == pic->uCALL_WITH_VALUES) { return analyze_call_with_values(state, obj, tailpos); } } diff --git a/extlib/benz/cont.c b/extlib/benz/cont.c index 4b213f52..79fc747d 100644 --- a/extlib/benz/cont.c +++ b/extlib/benz/cont.c @@ -288,6 +288,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/gc.c b/extlib/benz/gc.c index 93650e52..1ada79bc 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -531,15 +531,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_SYNTAX); 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 diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index 5b1bd3f3..f23de1b3 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -111,15 +111,15 @@ 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_SYNTAX, *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; diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index 8e6516ad..985f414c 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 * @@ -245,7 +245,7 @@ pic_lib_condexpand(pic_state *pic) 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])); + return pic_cons(pic, pic_obj_value(pic->sBEGIN), pic_cdr(pic, clauses[i])); } } @@ -317,8 +317,8 @@ pic_init_lib(pic_state *pic) { void pic_defmacro(pic_state *, pic_sym *, pic_sym *, pic_func_t); - 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_defmacro(pic, pic->sCOND_EXPAND, pic->uCOND_EXPAND, pic_lib_condexpand); + pic_defmacro(pic, pic->sIMPORT, pic->uIMPORT, pic_lib_import); + pic_defmacro(pic, pic->sEXPORT, pic->uEXPORT, pic_lib_export); + pic_defmacro(pic, pic->sDEFINE_LIBRARY, pic->uDEFINE_LIBRARY, pic_lib_define_library); } diff --git a/extlib/benz/macro.c b/extlib/benz/macro.c index a36a8c8c..6560f06c 100644 --- a/extlib/benz/macro.c +++ b/extlib/benz/macro.c @@ -77,7 +77,7 @@ macroexpand_symbol(pic_state *pic, pic_sym *sym, struct pic_env *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)); + return pic_cons(pic, pic_obj_value(pic->uQUOTE), pic_cdr(pic, expr)); } static pic_value @@ -161,7 +161,7 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_env *env) macroexpand_deferred(pic, in); - return pic_cons(pic, pic_obj_value(pic->rLAMBDA), pic_cons(pic, formal, body)); + return pic_cons(pic, pic_obj_value(pic->uLAMBDA), pic_cons(pic, formal, body)); } static pic_value @@ -174,7 +174,7 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_env *env) 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)))); + expr = pic_list3(pic, pic_obj_value(pic->uDEFINE), var, pic_cons(pic, pic_obj_value(pic->uLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr)))); } if (pic_length(pic, expr) != 3) { @@ -191,7 +191,7 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_env *env) } val = macroexpand(pic, pic_list_ref(pic, expr, 2), env); - return pic_list3(pic, pic_obj_value(pic->rDEFINE), pic_obj_value(rename), val); + return pic_list3(pic, pic_obj_value(pic->uDEFINE), pic_obj_value(rename), val); } static pic_value @@ -285,16 +285,16 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_env *env) if (pic_sym_p(car)) { pic_sym *tag = pic_sym_ptr(car); - if (tag == pic->rDEFINE_SYNTAX) { + if (tag == pic->uDEFINE_SYNTAX) { return macroexpand_defsyntax(pic, expr, env); } - else if (tag == pic->rLAMBDA) { + else if (tag == pic->uLAMBDA) { return macroexpand_defer(pic, expr, env); } - else if (tag == pic->rDEFINE) { + else if (tag == pic->uDEFINE) { return macroexpand_define(pic, expr, env); } - else if (tag == pic->rQUOTE) { + else if (tag == pic->uQUOTE) { return macroexpand_quote(pic, expr); } diff --git a/extlib/benz/number.c b/extlib/benz/number.c index 80c7fab9..a0cf35ba 100644 --- a/extlib/benz/number.c +++ b/extlib/benz/number.c @@ -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/state.c b/extlib/benz/state.c index 8ab9e296..85c35d5c 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -103,13 +103,13 @@ pic_init_core(pic_state *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); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->uDEFINE); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->uSETBANG); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->uQUOTE); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->uLAMBDA); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->uIF); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->uBEGIN); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->uDEFINE_SYNTAX); pic_init_undef(pic); DONE; pic_init_bool(pic); DONE; @@ -254,7 +254,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"); @@ -308,37 +308,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_gensym(pic, 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_SYNTAX, "define-syntax"); + 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 */ diff --git a/extlib/benz/symbol.c b/extlib/benz/symbol.c index 8298465d..9f716ae9 100644 --- a/extlib/benz/symbol.c +++ b/extlib/benz/symbol.c @@ -121,7 +121,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); From 3a59a959609ba702b0f550b0b07365deae0719b4 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Jun 2015 02:16:38 +0900 Subject: [PATCH 011/125] [WIP] replace macro expander remove define-syntax, add define-macro instead saner display when writing identifiers --- extlib/benz/gc.c | 21 +- extlib/benz/include/picrin.h | 7 +- extlib/benz/include/picrin/macro.h | 25 ++- extlib/benz/include/picrin/value.h | 3 + extlib/benz/lib.c | 8 +- extlib/benz/macro.c | 331 +++++++++++++++++------------ extlib/benz/state.c | 11 +- extlib/benz/symbol.c | 21 +- extlib/benz/vm.c | 30 +-- extlib/benz/write.c | 3 + 10 files changed, 266 insertions(+), 194 deletions(-) diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index 1ada79bc..11ee202e 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -411,14 +411,24 @@ 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; + xh_entry *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 = xh_begin(&env->map); it != NULL; it = xh_next(it)) { + gc_mark_object(pic, xh_key(it, struct pic_object *)); + gc_mark_object(pic, xh_val(it, struct pic_object *)); + } break; } case PIC_TT_LIB: { @@ -519,7 +529,7 @@ 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(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); @@ -532,7 +542,7 @@ gc_mark_global_symbols(pic_state *pic) M(sGREF); M(sLREF); M(sCREF); M(sRETURN); M(uDEFINE); M(uLAMBDA); M(uIF); M(uBEGIN); M(uQUOTE); M(uSETBANG); - M(uDEFINE_SYNTAX); M(uIMPORT); M(uEXPORT); + M(uDEFINE_MACRO); M(uIMPORT); M(uEXPORT); M(uDEFINE_LIBRARY); M(uCOND_EXPAND); M(uCONS); M(uCAR); M(uCDR); M(uNILP); @@ -681,7 +691,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; + xh_destroy(&env->map); break; } case PIC_TT_LIB: { diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index f23de1b3..c6e9595d 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -98,7 +98,7 @@ typedef struct { pic_sym *sDEFINE, *sLAMBDA, *sIF, *sBEGIN, *sQUOTE, *sSETBANG; pic_sym *sQUASIQUOTE, *sUNQUOTE, *sUNQUOTE_SPLICING; - pic_sym *sDEFINE_SYNTAX, *sIMPORT, *sEXPORT; + pic_sym *sDEFINE_MACRO, *sIMPORT, *sEXPORT; pic_sym *sDEFINE_LIBRARY; pic_sym *sCOND_EXPAND, *sAND, *sOR, *sELSE, *sLIBRARY; pic_sym *sONLY, *sRENAME, *sPREFIX, *sEXCEPT; @@ -112,7 +112,7 @@ typedef struct { pic_sym *sCALL_WITH_VALUES, *sTAILCALL_WITH_VALUES; pic_sym *uDEFINE, *uLAMBDA, *uIF, *uBEGIN, *uQUOTE, *uSETBANG; - pic_sym *uDEFINE_SYNTAX, *uIMPORT, *uEXPORT; + pic_sym *uDEFINE_MACRO, *uIMPORT, *uEXPORT; pic_sym *uDEFINE_LIBRARY; pic_sym *uCOND_EXPAND; pic_sym *uCONS, *uCAR, *uCDR, *uNILP; @@ -127,6 +127,7 @@ typedef struct { pic_value features; xhash syms; /* name to symbol */ + int ucnt; struct pic_dict *globals; struct pic_dict *macros; pic_value libs; @@ -193,8 +194,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 *); diff --git a/extlib/benz/include/picrin/macro.h b/extlib/benz/include/picrin/macro.h index 7d150777..28ce8208 100644 --- a/extlib/benz/include/picrin/macro.h +++ b/extlib/benz/include/picrin/macro.h @@ -9,24 +9,35 @@ extern "C" { #endif +struct pic_id { + PIC_OBJECT_HEADER + pic_value var; + struct pic_env *env; +}; + struct pic_env { PIC_OBJECT_HEADER - struct pic_dict *map; + xhash map; pic_value defer; 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); + +pic_sym *pic_var_name(pic_state *, pic_value); #if defined(__cplusplus) } diff --git a/extlib/benz/include/picrin/value.h b/extlib/benz/include/picrin/value.h index d69eaf59..7868429c 100644 --- a/extlib/benz/include/picrin/value.h +++ b/extlib/benz/include/picrin/value.h @@ -157,6 +157,7 @@ enum pic_tt { PIC_TT_PROC, PIC_TT_PORT, PIC_TT_ERROR, + PIC_TT_ID, PIC_TT_CXT, PIC_TT_ENV, PIC_TT_LIB, @@ -314,6 +315,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: diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index 985f414c..545052c7 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -110,14 +110,14 @@ import_table(pic_state *pic, pic_value spec, struct pic_dict *imports) pic_errorf(pic, "library not found: ~a", spec); } pic_dict_for_each (nick, lib->exports, iter) { - pic_sym *realname, *rename; + pic_sym *realname, *uid; 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_dict_set(pic, imports, nick, pic_obj_value(uid)); } } @@ -133,7 +133,7 @@ import(pic_state *pic, pic_value spec) 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))); + pic_put_variable(pic, pic->lib->env, pic_obj_value(sym), pic_sym_ptr(pic_dict_ref(pic, imports, sym))); } } diff --git a/extlib/benz/macro.c b/extlib/benz/macro.c index 6560f06c..a4b9d98a 100644 --- a/extlib/benz/macro.c +++ b/extlib/benz/macro.c @@ -4,74 +4,155 @@ #include "picrin.h" -pic_sym * -pic_add_rename(pic_state *pic, struct pic_env *env, pic_sym *sym) +static 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; + + assert(pic_var_p(var)); + + 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; + + env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV); + env->up = up; + env->defer = pic_nil_value(); + xh_init_ptr(&env->map, sizeof(pic_sym *)); + return env; } pic_sym * -pic_find_rename(pic_state *pic, struct pic_env *env, pic_sym *sym) +pic_var_name(pic_state PIC_UNUSED(*pic), pic_value var) { - if (! pic_dict_has(pic, env->map, sym)) { - return NULL; + assert(pic_var_p(var)); + + while (pic_id_p(var)) { + var = pic_id_ptr(var)->var; } - return pic_sym_ptr(pic_dict_ref(pic, env->map, sym)); + return pic_sym_ptr(var); } -static void -define_macro(pic_state *pic, pic_sym *rename, struct pic_proc *mac) +pic_sym * +pic_uniq(pic_state *pic, pic_value var) { - pic_dict_set(pic, pic->macros, rename, pic_obj_value(mac)); -} + pic_str *str; -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)); + 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); } static pic_sym * -make_identifier(pic_state *pic, pic_sym *sym, struct pic_env *env) +lookup(pic_state PIC_UNUSED(*pic), pic_value var, struct pic_env *env) { - pic_sym *rename; + xh_entry *e; - while (true) { - if ((rename = pic_find_rename(pic, env, sym)) != NULL) { - return rename; + assert(pic_var_p(var)); + + while (env != NULL) { + if ((e = xh_get_ptr(&env->map, pic_ptr(var))) != NULL) { + return xh_val(e, pic_sym *); } - if (! env->up) - break; env = env->up; } - if (! pic_interned_p(pic, sym)) { - return sym; + return NULL; +} + +static pic_sym * +resolve(pic_state *pic, pic_value var, struct pic_env *env) +{ + pic_sym *uid; + + assert(pic_var_p(var)); + + while ((uid = lookup(pic, var, env)) == NULL) { + if (pic_sym_p(var)) { + return NULL; + } + env = pic_id_ptr(var)->env; + var = pic_id_ptr(var)->var; } - else { - return pic_gensym(pic, sym); + return uid; +} + +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_put_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var, pic_sym *uid) +{ + assert(pic_var_p(var)); + + xh_put_ptr(&env->map, pic_ptr(var), &uid); +} + +pic_sym * +pic_find_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var) +{ + xh_entry *e; + + assert(pic_var_p(var)); + + if ((e = xh_get_ptr(&env->map, pic_ptr(var))) == NULL) { + return NULL; } + return xh_val(e, pic_sym *); +} + +static void +define_macro(pic_state *pic, pic_sym *uid, struct pic_proc *mac) +{ + 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 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) +macroexpand_var(pic_state *pic, pic_value var, struct pic_env *env) { - return pic_obj_value(make_identifier(pic, sym, env)); + pic_sym *uid; + + if ((uid = resolve(pic, var, env)) == NULL) { + pic_errorf(pic, "unbound variable found: ~s", var); + } + return pic_obj_value(uid); } static pic_value @@ -142,15 +223,15 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_env *env) 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); + pic_value var = pic_car(pic, a); - if (! pic_sym_p(v)) { + if (! pic_var_p(var)) { pic_errorf(pic, "syntax error"); } - pic_add_rename(pic, in, pic_sym_ptr(v)); + pic_add_variable(pic, in, var); } - if (pic_sym_p(a)) { - pic_add_rename(pic, in, pic_sym_ptr(a)); + if (pic_var_p(a)) { + pic_add_variable(pic, in, a); } else if (! pic_nil_p(a)) { pic_errorf(pic, "syntax error"); @@ -167,14 +248,14 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_env *env) static pic_value macroexpand_define(pic_state *pic, pic_value expr, struct pic_env *env) { - pic_sym *sym, *rename; + pic_sym *uid; 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->uDEFINE), var, pic_cons(pic, pic_obj_value(pic->uLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr)))); + expr = pic_list3(pic, pic_obj_value(pic->uDEFINE), var, pic_cons(pic, pic_obj_value(pic->sLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr)))); } if (pic_length(pic, expr) != 3) { @@ -182,37 +263,35 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_env *env) } var = pic_cadr(pic, expr); - if (! pic_sym_p(var)) { - pic_errorf(pic, "binding to non-symbol object"); + if (! pic_var_p(var)) { + pic_errorf(pic, "binding to non-variable object"); } - sym = pic_sym_ptr(var); - if ((rename = pic_find_rename(pic, env, sym)) == NULL) { - rename = pic_add_rename(pic, env, sym); + if ((uid = pic_find_variable(pic, env, var)) == NULL) { + uid = pic_add_variable(pic, env, var); } val = macroexpand(pic, pic_list_ref(pic, expr, 2), env); - return pic_list3(pic, pic_obj_value(pic->uDEFINE), pic_obj_value(rename), val); + return pic_list3(pic, pic_obj_value(pic->uDEFINE), pic_obj_value(uid), val); } static pic_value -macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_env *env) +macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) { pic_value var, val; - pic_sym *sym, *rename; + pic_sym *uid; 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"); + if (! pic_var_p(var)) { + pic_errorf(pic, "binding to non-variable object"); } - sym = pic_sym_ptr(var); - if ((rename = pic_find_rename(pic, env, sym)) == NULL) { - rename = pic_add_rename(pic, env, sym); + if ((uid = pic_find_variable(pic, env, var)) == NULL) { + uid = pic_add_variable(pic, env, var); } else { - pic_warnf(pic, "redefining syntax variable: ~s", pic_obj_value(sym)); + pic_warnf(pic, "redefining syntax variable: ~s", var); } val = pic_cadr(pic, pic_cdr(pic, expr)); @@ -227,13 +306,7 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_env *env) 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)); + define_macro(pic, uid, pic_proc_ptr(val)); return pic_undef_value(); } @@ -241,7 +314,7 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_env *env) static pic_value macroexpand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct pic_env *env) { - pic_value v, args; + pic_value v; #if DEBUG puts("before expand-1:"); @@ -249,10 +322,8 @@ macroexpand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct p puts(""); #endif - args = pic_list2(pic, expr, pic_obj_value(env)); - pic_try { - v = pic_apply(pic, mac, args); + v = pic_apply2(pic, mac, expr, pic_obj_value(env)); } pic_catch { pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic)); } @@ -270,40 +341,44 @@ static pic_value macroexpand_node(pic_state *pic, pic_value expr, struct pic_env *env) { switch (pic_type(expr)) { + case PIC_TT_ID: case PIC_TT_SYMBOL: { - return macroexpand_symbol(pic, pic_sym_ptr(expr), env); + return macroexpand_var(pic, 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 (pic_var_p(pic_car(pic, expr))) { + pic_sym *functor; - if (tag == pic->uDEFINE_SYNTAX) { - return macroexpand_defsyntax(pic, expr, env); + if ((functor = resolve(pic, pic_car(pic, expr), env)) == NULL) { + goto call; } - else if (tag == pic->uLAMBDA) { + + if (functor == pic->uDEFINE_MACRO) { + return macroexpand_defmacro(pic, expr, env); + } + else if (functor == pic->uLAMBDA) { return macroexpand_defer(pic, expr, env); } - else if (tag == pic->uDEFINE) { + else if (functor == pic->uDEFINE) { return macroexpand_define(pic, expr, env); } - else if (tag == pic->uQUOTE) { + else if (functor == pic->uQUOTE) { return macroexpand_quote(pic, expr); } - if ((mac = find_macro(pic, tag)) != NULL) { + if ((mac = find_macro(pic, functor)) != NULL) { return macroexpand_node(pic, macroexpand_macro(pic, mac, expr, env), env); } } + call: - return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), env)); + return macroexpand_list(pic, expr, env); } default: return expr; @@ -362,22 +437,6 @@ pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib) return v; } -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; - - return env; -} - static pic_value defmacro_call(pic_state *pic) { @@ -398,7 +457,7 @@ pic_defmacro(pic_state *pic, pic_sym *name, pic_sym *id, pic_func_t func) trans = pic_make_proc(pic, func, pic_symbol_name(pic, name)); - pic_put_rename(pic, pic->lib->env, name, id); + pic_put_variable(pic, pic->lib->env, pic_obj_value(name), id); proc = pic_make_proc(pic, defmacro_call, "defmacro_call"); pic_attr_set(pic, pic_obj_value(proc), "@@transformer", pic_obj_value(trans)); @@ -410,30 +469,6 @@ pic_defmacro(pic_state *pic, pic_sym *name, pic_sym *id, pic_func_t func) pic_export(pic, name); } -bool -pic_identifier_p(pic_state *pic, pic_value obj) -{ - return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym_ptr(obj)); -} - -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; - - a = make_identifier(pic, sym1, env1); - if (a != make_identifier(pic, sym1, env1)) { - a = sym1; - } - - 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)); -} - static pic_value pic_macro_identifier_p(pic_state *pic) { @@ -441,40 +476,62 @@ 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_variable_p(pic_state *pic) { - pic_sym *sym1, *sym2; - pic_value env1, env2; + pic_value obj; - pic_get_args(pic, "omom", &env1, &sym1, &env2, &sym2); + pic_get_args(pic, "o", &obj); - pic_assert_type(pic, env1, env); - pic_assert_type(pic, env2, env); + return pic_bool_value(pic_var_p(obj)); +} - return pic_bool_value(pic_identifier_eq_p(pic, pic_env_ptr(env1), sym1, pic_env_ptr(env2), sym2)); +static pic_value +pic_macro_variable_eq_p(pic_state *pic) +{ + pic_value var1, var2; + pic_sym *uid1, *uid2; + + pic_get_args(pic, "oo", &var1, &var2); + + pic_assert_type(pic, var1, var); + pic_assert_type(pic, var2, var); + + if (pic_eq_p(var1, var2)) { + return pic_true_value(); + } + + uid1 = resolve(pic, var1, NULL); + uid2 = resolve(pic, var2, NULL); + + if (uid1 || uid2) { + return pic_bool_value(uid1 == uid2); + } + return pic_false_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, "variable?", pic_macro_variable_p); + pic_defun(pic, "variable=?", pic_macro_variable_eq_p); } diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 85c35d5c..c7f965e0 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -109,7 +109,7 @@ pic_init_core(pic_state *pic) pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->uLAMBDA); pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->uIF); pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->uBEGIN); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->uDEFINE_SYNTAX); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_MACRO, pic->uDEFINE_MACRO); pic_init_undef(pic); DONE; pic_init_bool(pic); DONE; @@ -222,6 +222,9 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) /* symbol table */ xh_init_str(&pic->syms, sizeof(pic_sym *)); + /* unique symbol count */ + pic->ucnt = 0; + /* global variables */ pic->globals = NULL; @@ -265,7 +268,7 @@ 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(sDEFINE_MACRO, "define-macro"); S(sIMPORT, "import"); S(sEXPORT, "export"); S(sDEFINE_LIBRARY, "define-library"); @@ -308,7 +311,7 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) pic_gc_arena_restore(pic, ai); -#define U(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))) U(uDEFINE, "define"); U(uLAMBDA, "lambda"); @@ -316,7 +319,7 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) U(uBEGIN, "begin"); U(uSETBANG, "set!"); U(uQUOTE, "quote"); - U(uDEFINE_SYNTAX, "define-syntax"); + U(uDEFINE_MACRO, "define-macro"); U(uIMPORT, "import"); U(uEXPORT, "export"); U(uDEFINE_LIBRARY, "define-library"); diff --git a/extlib/benz/symbol.c b/extlib/benz/symbol.c index 9f716ae9..ce70edb0 100644 --- a/extlib/benz/symbol.c +++ b/extlib/benz/symbol.c @@ -4,7 +4,7 @@ #include "picrin.h" -pic_sym * +static pic_sym * pic_make_symbol(pic_state *pic, pic_str *str) { pic_sym *sym; @@ -42,25 +42,6 @@ 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) { diff --git a/extlib/benz/vm.c b/extlib/benz/vm.c index 7a062019..c3e6de16 100644 --- a/extlib/benz/vm.c +++ b/extlib/benz/vm.c @@ -394,9 +394,9 @@ pic_get_args(pic_state *pic, const char *format, ...) } void -pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *rsym) +pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *uid) { - pic_put_rename(pic, env, sym, rsym); + pic_put_variable(pic, env, pic_obj_value(sym), uid); if (pic->lib && pic->lib->env == env) { pic_export(pic, sym); @@ -406,17 +406,17 @@ pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym, void pic_define_noexport(pic_state *pic, const char *name, pic_value val) { - pic_sym *sym, *rename; + pic_sym *sym, *uid; 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); + 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, rename, val); + pic_dict_set(pic, pic->globals, uid, val); } void @@ -430,29 +430,29 @@ pic_define(pic_state *pic, const char *name, pic_value val) pic_value pic_ref(pic_state *pic, struct pic_lib *lib, const char *name) { - pic_sym *sym, *rename; + pic_sym *sym, *uid; sym = pic_intern_cstr(pic, name); - if ((rename = pic_find_rename(pic, lib->env, sym)) == NULL) { + 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, rename); + 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, *rename; + pic_sym *sym, *uid; sym = pic_intern_cstr(pic, name); - if ((rename = pic_find_rename(pic, lib->env, sym)) == NULL) { + 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, rename, val); + pic_dict_set(pic, pic->globals, uid, val); } pic_value @@ -477,7 +477,7 @@ pic_defun(pic_state *pic, const char *name, pic_func_t cfunc) } void -pic_defun_vm(pic_state *pic, const char *name, pic_sym *rename, pic_func_t func) +pic_defun_vm(pic_state *pic, const char *name, pic_sym *uid, pic_func_t func) { struct pic_proc *proc; pic_sym *sym; @@ -486,9 +486,9 @@ pic_defun_vm(pic_state *pic, const char *name, pic_sym *rename, pic_func_t func) sym = pic_intern_cstr(pic, name); - pic_put_rename(pic, pic->lib->env, sym, rename); + pic_put_variable(pic, pic->lib->env, pic_obj_value(sym), uid); - pic_dict_set(pic, pic->globals, rename, pic_obj_value(proc)); + pic_dict_set(pic, pic->globals, uid, pic_obj_value(proc)); pic_export(pic, sym); } diff --git a/extlib/benz/write.c b/extlib/benz/write.c index 4c9d7333..374d54e2 100644 --- a/extlib/benz/write.c +++ b/extlib/benz/write.c @@ -302,6 +302,9 @@ write_core(struct writer_control *p, pic_value obj) } xfprintf(file, ")"); break; + case PIC_TT_ID: + xfprintf(file, "#", pic_symbol_name(pic, pic_var_name(pic, obj))); + break; default: xfprintf(file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj)); break; From 6d80b580608a379f8849b688b5e08b343b4ef427 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 15 Jun 2015 01:02:53 +0900 Subject: [PATCH 012/125] assume all symbols are bound at the toplevel --- extlib/benz/macro.c | 37 +++++++++++++++++-------------------- 1 file changed, 17 insertions(+), 20 deletions(-) diff --git a/extlib/benz/macro.c b/extlib/benz/macro.c index a4b9d98a..8a47e816 100644 --- a/extlib/benz/macro.c +++ b/extlib/benz/macro.c @@ -80,14 +80,21 @@ resolve(pic_state *pic, pic_value var, struct pic_env *env) pic_sym *uid; assert(pic_var_p(var)); + assert(env != NULL); while ((uid = lookup(pic, var, env)) == NULL) { if (pic_sym_p(var)) { - return NULL; + 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; } @@ -147,12 +154,7 @@ static pic_value macroexpand_lambda(pic_state *, pic_value, struct pic_env *); static pic_value macroexpand_var(pic_state *pic, pic_value var, struct pic_env *env) { - pic_sym *uid; - - if ((uid = resolve(pic, var, env)) == NULL) { - pic_errorf(pic, "unbound variable found: ~s", var); - } - return pic_obj_value(uid); + return pic_obj_value(resolve(pic, var, env)); } static pic_value @@ -355,9 +357,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_env *env) if (pic_var_p(pic_car(pic, expr))) { pic_sym *functor; - if ((functor = resolve(pic, pic_car(pic, expr), env)) == NULL) { - goto call; - } + functor = resolve(pic, pic_car(pic, expr), env); if (functor == pic->uDEFINE_MACRO) { return macroexpand_defmacro(pic, expr, env); @@ -376,8 +376,6 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_env *env) return macroexpand_node(pic, macroexpand_macro(pic, mac, expr, env), env); } } - call: - return macroexpand_list(pic, expr, env); } default: @@ -506,22 +504,21 @@ static pic_value pic_macro_variable_eq_p(pic_state *pic) { pic_value var1, var2; - pic_sym *uid1, *uid2; pic_get_args(pic, "oo", &var1, &var2); pic_assert_type(pic, var1, var); pic_assert_type(pic, var2, var); - if (pic_eq_p(var1, var2)) { - return pic_true_value(); + if (pic_sym_p(var1) && pic_sym_p(var2)) { + return pic_bool_value(pic_eq_p(var1, var2)); } + if (pic_id_p(var1) && pic_id_p(var2)) { + struct pic_id *id1, *id2; - uid1 = resolve(pic, var1, NULL); - uid2 = resolve(pic, var2, NULL); - - if (uid1 || uid2) { - return pic_bool_value(uid1 == uid2); + id1 = pic_id_ptr(var1); + id2 = pic_id_ptr(var2); + return pic_bool_value(resolve(pic, id1->var, id1->env) == resolve(pic, id2->var, id2->env)); } return pic_false_value(); } From 181d120f09f1b72880807bbc7717e7d9830af2e2 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Jun 2015 15:18:03 +0900 Subject: [PATCH 013/125] reader support of (#' #` #, #,@) --- extlib/benz/gc.c | 2 ++ extlib/benz/include/picrin.h | 2 ++ extlib/benz/read.c | 27 +++++++++++++++++++++++++++ extlib/benz/state.c | 4 ++++ 4 files changed, 35 insertions(+) diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index 11ee202e..9d5d759f 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -529,6 +529,8 @@ 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(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); diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index c6e9595d..f2e72af8 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -98,6 +98,8 @@ typedef struct { pic_sym *sDEFINE, *sLAMBDA, *sIF, *sBEGIN, *sQUOTE, *sSETBANG; pic_sym *sQUASIQUOTE, *sUNQUOTE, *sUNQUOTE_SPLICING; + 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; diff --git a/extlib/benz/read.c b/extlib/benz/read.c index 8320af38..a5f45299 100644 --- a/extlib/benz/read.c +++ b/extlib/benz/read.c @@ -180,6 +180,30 @@ read_unquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) return pic_list2(pic, pic_obj_value(tag), read(pic, port, next(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(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(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(port) == '@') { + tag = pic->sSYNTAX_UNQUOTE_SPLICING; + next(port); + } + return pic_list2(pic, pic_obj_value(tag), read(pic, port, next(port))); +} + static pic_value read_symbol(pic_state *pic, struct pic_port *port, int c) { @@ -799,6 +823,9 @@ 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; diff --git a/extlib/benz/state.c b/extlib/benz/state.c index c7f965e0..65c0bcf5 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -268,6 +268,10 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) S(sQUASIQUOTE, "quasiquote"); S(sUNQUOTE, "unquote"); S(sUNQUOTE_SPLICING, "unquote-splicing"); + S(sSYNTAX_QUOTE, "syntax-quote"); + S(sSYNTAX_QUASIQUOTE, "syntax-quasiquote"); + S(sSYNTAX_UNQUOTE, "syntax-unquote"); + S(sSYNTAX_UNQUOTE_SPLICING, "syntax-unquote-splicing"); S(sDEFINE_MACRO, "define-macro"); S(sIMPORT, "import"); S(sEXPORT, "export"); From 25c0eb125eb7c98b2cf8324e07f75d2e48852ef6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Jun 2015 16:08:38 +0900 Subject: [PATCH 014/125] add identifier-variable and identifier-environment --- extlib/benz/macro.c | 28 +++++++++++++++++++++++++++- piclib/picrin/base.scm | 10 +++++++--- 2 files changed, 34 insertions(+), 4 deletions(-) diff --git a/extlib/benz/macro.c b/extlib/benz/macro.c index 8a47e816..057e7dac 100644 --- a/extlib/benz/macro.c +++ b/extlib/benz/macro.c @@ -490,6 +490,30 @@ pic_macro_make_identifier(pic_state *pic) return pic_obj_value(pic_make_id(pic, var, pic_env_ptr(env))); } +static pic_value +pic_macro_identifier_variable(pic_state *pic) +{ + pic_value id; + + pic_get_args(pic, "o", &id); + + pic_assert_type(pic, id, id); + + 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) { @@ -526,8 +550,10 @@ pic_macro_variable_eq_p(pic_state *pic) void pic_init_macro(pic_state *pic) { - pic_defun(pic, "identifier?", pic_macro_identifier_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/piclib/picrin/base.scm b/piclib/picrin/base.scm index c81744a2..f2fbfbf6 100644 --- a/piclib/picrin/base.scm +++ b/piclib/picrin/base.scm @@ -239,9 +239,13 @@ (export make-parameter parameterize) - (export identifier? - identifier=? - make-identifier) + (export make-identifier + identifier? + identifier-variable + identifier-environment + + variable? + variable=?) (export call-with-current-continuation call/cc From a10ac3b77026644ec54cebcd4c05f1f41f14e090 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Jun 2015 19:41:59 +0900 Subject: [PATCH 015/125] rewrite boot.c. add syntax-quote family [boot.c] (cond) should be expanded into #undefined update boot.c [boot.c] bugfix boot.c bugfix --- extlib/benz/boot.c | 1040 +++++++++++++++++++++++----------------- piclib/picrin/base.scm | 9 +- 2 files changed, 611 insertions(+), 438 deletions(-) diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index 59eb736b..b4a29fa7 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -10,326 +10,434 @@ my $src = <<'EOL'; (define-library (picrin base) - (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-macro call-with-current-environment + (lambda (form env) + (list (cadr form) env))) - (define (er-macro-transformer f) - (lambda (mac-env) - (lambda (expr use-env) + (define here + (call-with-current-environment + (lambda (env) + env))) - (define rename - (memoize - (lambda (sym) - (make-identifier sym mac-env)))) + (define (the var) ; synonym for #'var + (make-identifier var here)) - (define (compare x y) - (if (not (symbol? x)) - #f - (if (not (symbol? y)) - #f - (identifier=? use-env x use-env y)))) + (define the-define (the 'define)) + (define the-lambda (the 'lambda)) + (define the-begin (the 'begin)) + (define the-quote (the 'quote)) + (define the-set! (the 'set!)) + (define the-if (the 'if)) + (define the-define-macro (the 'define-macro)) - (f expr rename compare)))) + (define-macro syntax-error + (lambda (form _) + (apply error (cdr form)))) - (define-syntax syntax-error - (er-macro-transformer - (lambda (expr rename compare) - (apply error (cdr expr))))) - - (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-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-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) - (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))))))) + (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 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))))))))))) + (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 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))))))))) + (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-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)))))))))) + (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-syntax quasiquote - (er-macro-transformer - (lambda (form rename compare) + (define-macro quasiquote + (lambda (form env) - (define (quasiquote? form) - (and (pair? form) (compare (car form) (rename 'quasiquote)))) + (define (quasiquote? form) + (and (pair? form) + (variable? (car form)) + (variable=? (the 'quasiquote) (make-identifier (car form) env)))) - (define (unquote? form) - (and (pair? form) (compare (car form) (rename 'unquote)))) + (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)) - (compare (car (car form)) (rename 'unquote-splicing)))) + (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 (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 (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))))) + (let ((x (cadr form))) + (qq 1 x)))) - (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 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 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 - ,@body)))))) + (define-macro letrec + (lambda (form env) + `(,(the 'letrec*) ,@(cdr form)))) - (define-syntax letrec - (er-macro-transformer - (lambda (form rename compare) - `(,(rename '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-syntax let-values - (er-macro-transformer - (lambda (form r c) - `(,(r '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-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-syntax when - (er-macro-transformer - (lambda (expr rename compare) - (let ((test (cadr expr)) - (body (cddr expr))) - `(,(rename 'if) ,test - (,(rename 'begin) ,@body) - #f))))) - - (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-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-syntax parameterize - (er-macro-transformer - (lambda (form r compare) - (let ((formal (cadr form)) - (body (cddr form))) - `(,(r 'with-parameter) - (lambda () - ,@formal - ,@body)))))) - - (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) + (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-syntax - (er-macro-transformer - (lambda (form r c) - `(,(r 'letrec-syntax) ,@(cdr form))))) + (define-macro let-values + (lambda (form env) + `(,(the 'let*-values) ,@(cdr form)))) + + (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-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-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-macro when + (lambda (form env) + (let ((test (car (cdr form))) + (body (cdr (cdr form)))) + `(,the-if ,test + (,the-begin ,@body) + #undefined)))) + + (define-macro unless + (lambda (form env) + (let ((test (car (cdr form))) + (body (cdr (cdr form)))) + `(,the-if ,test + #undefined + (,the-begin ,@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-macro parameterize + (lambda (form env) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + `(,(the 'with-parameter) + (,(the 'lambda) () + ,@formal + ,@body))))) + + (define-macro syntax-quote + (lambda (form env) + (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))))) + (list the-quote (walk wrap (cadr form)))))) + + (define-macro syntax-quasiquote + (lambda (form env) + (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)))))) + + (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) + (list (the 'quote) (wrap expr))) + ;; simple datum + (else + (list (the 'quote) expr)))) + + (let ((x (cadr form))) + (qq 1 x))))) + + (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)))) (export let let* letrec letrec* let-values let*-values define-values @@ -338,6 +446,9 @@ my $src = <<'EOL'; cond case else => do when unless parameterize + define-syntax + syntax-quote syntax-unquote + syntax-quasiquote syntax-unquote-splicing let-syntax letrec-syntax syntax-error)) @@ -393,147 +504,204 @@ 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(define-library (picrin base)\n\n (define-macro call-with-current-environment\n ", +" (lambda (form env)\n (list (cadr form) env)))\n\n (define here\n (call-wi", +"th-current-environment\n (lambda (env)\n env)))\n\n (define (the var) ", +" ; synonym for #'var\n (make-identifier var here))\n\n (define ", +"the-define (the 'define))\n (define the-lambda (the 'lambda))\n (define the-begi", +"n (the 'begin))\n (define the-quote (the 'quote))\n (define the-set! (the 'set!)", +")\n (define the-if (the 'if))\n (define the-define-macro (the 'define-macro))\n\n ", +" (define-macro syntax-error\n (lambda (form _)\n (apply error (cdr form)))", +")\n\n (define-macro define-auxiliary-syntax\n (lambda (form _)\n (define me", +"ssage\n (string-append\n \"invalid use of auxiliary syntax: '\" (symb", +"ol->string (cadr form)) \"'\"))\n (list\n the-define-macro\n (cadr f", +"orm)\n (list the-lambda '_\n (list (the 'error) message)))))\n\n ", +"(define-auxiliary-syntax else)\n (define-auxiliary-syntax =>)\n (define-auxiliar", +"y-syntax unquote)\n (define-auxiliary-syntax unquote-splicing)\n (define-auxilia", +"ry-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 ", +" (list\n (list the-lambda '()\n (list the-define (c", +"adr form)\n (cons the-lambda\n (", +"cons (map car (car (cddr form)))\n (cdr (cddr f", +"orm)))))\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 'a", +"nd) (cddr form))\n #f)))))\n\n (define-macro or\n (lambda (fo", +"rm env)\n (if (null? (cdr form))\n #f\n (let ((tmp (make-ide", +"ntifier 'it env)))\n (list (the 'let)\n (list (list tm", +"p (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 (c", +"ar clauses)))\n (if (and (variable? (car clause))\n ", +" (variable=? (the 'else) (make-identifier (car clause) env)))\n ", +" (cons the-begin (cdr clause))\n (if (and (variable? (cadr cl", +"ause))\n (variable=? (the '=>) (make-identifier (cadr c", +"lause) env)))\n (let ((tmp (make-identifier 'tmp here)))\n ", +" (list (the 'let) (list (list tmp (car clause)))\n ", +" (list the-if tmp\n (list (c", +"ar (cddr clause)) tmp)\n (cons (the 'cond) (cd", +"r clauses)))))\n (list the-if (car clause)\n ", +" (cons the-begin (cdr 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 (varia", +"ble? (car form))\n (variable=? (the 'quasiquote) (make-identifier (ca", +"r form) env))))\n\n (define (unquote? form)\n (and (pair? form)\n ", +" (variable? (car form))\n (variable=? (the 'unquote) (make-ident", +"ifier (car form) env))))\n\n (define (unquote-splicing? form)\n (and (p", +"air? form)\n (pair? (car form))\n (variable? (caar form))\n", +" (variable=? (the 'unquote-splicing) (make-identifier (caar form) en", +"v))))\n\n (define (qq depth expr)\n (cond\n ;; unquote\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-sp", +"licing\n ((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 'quote) (the 'unquote-spl", +"icing))\n (qq (- depth 1) (car (cdr (car expr)))))\n ", +" (qq depth (cdr expr)))))\n ;; quasiquote\n ((quasiq", +"uote? expr)\n (list (the 'list)\n (list (the 'quote) (the ", +"'quasiquote))\n (qq (+ depth 1) (car (cdr expr)))))\n ;; li", +"st\n ((pair? expr)\n (list (the 'cons)\n (qq depth ", +"(car expr))\n (qq depth (cdr expr))))\n ;; vector\n ", +"((vector? expr)\n (list (the 'list->vector) (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 (define-macro let*\n (", +"lambda (form env)\n (let ((bindings (car (cdr form)))\n (body ", +"(cdr (cdr form))))\n (if (null? bindings)\n `(,(the 'let) () ,@b", +"ody)\n `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))\n", +" (,(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n (d", +"efine-macro letrec\n (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form)))", +")\n\n (define-macro letrec*\n (lambda (form env)\n (let ((bindings (car (cd", +"r form)))\n (body (cdr (cdr form))))\n (let ((variables (map", +" (lambda (v) `(,v #f)) (map car bindings)))\n (initials (map (lambd", +"a (v) `(,(the 'set!) ,@v)) bindings)))\n `(,(the 'let) (,@variables)\n ", +" ,@initials\n ,@body)))))\n\n (define-macro let-values\n (lam", +"bda (form env)\n `(,(the '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-with-values) (,the-lambda () ,@(cdr (car f", +"ormal)))\n (,(the 'lambda) (,@(car (car formal)))\n (,(", +"the 'let*-values) (,@(cdr formal))\n ,@body)))))))\n\n (define-macr", +"o define-values\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", +" (body (cdr (cdr form))))\n (let ((arguments (make-identifier 'a", +"rguments here)))\n `(,the-begin\n ,@(let loop ((formal formal)", +")\n (if (pair? formal)\n `((,the-define ,(car fo", +"rmal) #undefined) ,@(loop (cdr formal)))\n (if (variable? form", +"al)\n `((,the-define ,formal #undefined))\n ", +" '())))\n (,(the 'call-with-values) (,the-lambda () ,@body)\n ", +" (,the-lambda\n ,arguments\n ,@(let loop ((form", +"al formal) (args arguments))\n (if (pair? formal)\n ", +" `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,", +"(the '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 (cd", +"r (car (cdr (cdr form)))))\n (body (cdr (cdr (cdr form)))))\n ", +" (let ((loop (make-identifier '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 ", +" #undefined))))\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", +" #undefined\n (,the-begin ,@body)))))\n\n (defin", +"e-macro case\n (lambda (form env)\n (let ((key (car (cdr form)))\n ", +" (clauses (cdr (cdr form))))\n (let ((the-key (make-identifier 'key ", +"here)))\n `(,(the 'let) ((,the-key ,key))\n ,(let loop ((claus", +"es clauses))\n (if (null? clauses)\n #undefined\n ", +" (let ((clause (car clauses)))\n `(,the-if ,(", +"if (and (variable? (car clause))\n (varia", +"ble=? (the 'else) (make-identifier (car clause) env)))\n ", +" #t\n `(,(the 'or) ,@(map (lambda (x", +") `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))\n ", +" ,(if (and (variable? (cadr clause))\n ", +" (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ", +" `(,(car (cdr (cdr clause))) ,the-key)\n ", +" `(,the-begin ,@(cdr clause)))\n ,", +"(loop (cdr clauses)))))))))))\n\n (define-macro parameterize\n (lambda (form en", +"v)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n", +" `(,(the 'with-parameter)\n (,(the 'lambda) ()\n ,@forma", +"l\n ,@body)))))\n\n (define-macro syntax-quote\n (lambda (form env)\n ", +" (letrec\n ((wrap (let ((register (make-register)))\n ", +" (lambda (var)\n (let ((id (register var)))\n ", +" (if (undefined? id)\n (let ((id (make-identifier", +" var env)))\n (register var id)\n ", +" id)\n id)))))\n (walk (lambda (f form)", +"\n (cond\n ((variable? form)\n ", +" (f form))\n ((pair? form)\n (cons (wal", +"k f (car form)) (walk f (cdr form))))\n ((vector? form)\n ", +" (list->vector (walk f (vector->list form))))\n ", +"(else\n form)))))\n (list the-quote (walk wrap (cadr fo", +"rm))))))\n\n (define-macro syntax-quasiquote\n (lambda (form env)\n (letrec", +"\n ((wrap (let ((register (make-register)))\n (lambda (", +"var)\n (let ((id (register var)))\n (if ", +"(undefined? id)\n (let ((id (make-identifier var env)))", +"\n (register var id)\n id)", +"\n id))))))\n\n (define (syntax-quasiquote? form)\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 (va", +"riable? (car form))\n (variable=? (the 'syntax-unquote) (make-ident", +"ifier (car form) env))))\n\n (define (syntax-unquote-splicing? form)\n ", +" (and (pair? form)\n (pair? (car form))\n (variable", +"? (caar form))\n (variable=? (the 'syntax-unquote-splicing) (make-i", +"dentifier (caar form) env))))\n\n (define (qq depth expr)\n (cond\n ", +" ;; syntax-unquote\n ((syntax-unquote? expr)\n (if (", +"= depth 1)\n (car (cdr expr))\n (list (the 'list)\n ", +" (list (the 'quote) (the 'syntax-unquote))\n ", +" (qq (- depth 1) (car (cdr expr))))))\n ;; syntax-unquote-splicing\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 'quote) (t", +"he '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? expr)\n", +" (list (the 'cons)\n (qq depth (car expr))\n ", +" (qq depth (cdr expr))))\n ;; vector\n ((vector? expr)\n", +" (list (the 'list->vector) (qq depth (vector->list expr))))\n ", +" ;; variable\n ((variable? expr)\n (list (the 'quote) (wrap ", +"expr)))\n ;; simple datum\n (else\n (list (the 'quot", +"e) expr))))\n\n (let ((x (cadr form)))\n (qq 1 x)))))\n\n (define (t", +"ransformer 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 (register1 var1 var2)\n ", +" (register2 var2 var1)\n var2)\n ", +" var2))))\n (unwrap (lambda (var2)\n ", +" (let ((var1 (register2 var2)))\n (if (undefined? var", +"1)\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 form))))))))\n\n (define-macro define-syntax\n (lambda (form env)\n (l", +"et ((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 'transforme", +"r) (,the-begin ,@body)))))))\n\n (define-macro letrec-syntax\n (lambda (form en", +"v)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n", +" `(let ()\n ,@(map (lambda (x)\n `(,(the 'defi", +"ne-syntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n", +"\n (define-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax)", +" ,@(cdr form))))\n\n (export let let* letrec letrec*\n let-values let*-va", +"lues define-values\n quasiquote unquote unquote-splicing\n and o", +"r\n cond case else =>\n do when unless\n parameterize\n ", +" define-syntax\n syntax-quote syntax-unquote\n syntax-qua", +"siquote syntax-unquote-splicing\n let-syntax letrec-syntax\n syn", +"tax-error))\n\n", "", "" }; diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm index f2fbfbf6..66ad69e5 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* From 4d9f5bfbcf3a7e47b4949be4e1b49f5853cd1898 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Jun 2015 19:42:29 +0900 Subject: [PATCH 016/125] rewrite macro.scm. build sc/er macro transformers on picrin's macro system [macro.scm] cleanup --- piclib/picrin/macro.scm | 263 +++++++++++++++++++++++----------------- 1 file changed, 151 insertions(+), 112 deletions(-) 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))))) From d741efe2943ed098caaff21143fbfa5942787a4c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 15 Jun 2015 02:37:36 +0900 Subject: [PATCH 017/125] rewrite (picrin record) and (picrin experimental lambda) --- piclib/picrin/experimental/lambda.scm | 67 ++++++++----------- piclib/picrin/record.scm | 96 +++++++++++---------------- 2 files changed, 66 insertions(+), 97 deletions(-) diff --git a/piclib/picrin/experimental/lambda.scm b/piclib/picrin/experimental/lambda.scm index 5f6ac0ab..1fdfeb39 100644 --- a/piclib/picrin/experimental/lambda.scm +++ b/piclib/picrin/experimental/lambda.scm @@ -3,47 +3,36 @@ (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/record.scm b/piclib/picrin/record.scm index fccc1bd4..20d75f77 100644 --- a/piclib/picrin/record.scm +++ b/piclib/picrin/record.scm @@ -2,7 +2,7 @@ (import (picrin base) (picrin macro)) - ;; define-record-type + ;; record meta type (define ((boot-make-record-type ) name) (let ((rectype (make-record ))) @@ -10,70 +10,50 @@ rectype)) (define - (let (( - ((boot-make-record-type #t) 'record-type))) + (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)) - (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)))) + + (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)) From 43f1f6bb70dc38d72423fcc4a4e17817cd80ecde Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 13 Jun 2015 15:49:57 +0900 Subject: [PATCH 018/125] [WIP] syntax-rules: rewrite syntax-rules.scm [syntax-rules] bugfix s/generate-representation/template-representation/g [WIP] rewrite syntax-rules [syntax-rules] bugfix s/generate-representation/template-representation/g [syntax-rules] bugfix --- piclib/picrin/syntax-rules.scm | 478 +++++++++++---------------------- 1 file changed, 162 insertions(+), 316 deletions(-) diff --git a/piclib/picrin/syntax-rules.scm b/piclib/picrin/syntax-rules.scm index 6eeef05b..4584d7f2 100644 --- a/piclib/picrin/syntax-rules.scm +++ b/piclib/picrin/syntax-rules.scm @@ -1,348 +1,194 @@ (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 (map-keys f assoc) + (map (lambda (s) `(,(f (car s)) . ,(cdr s))) assoc)) - (define push-var list) + (define (map-values f assoc) + (map (lambda (s) `(,(car s) . ,(f (cdr s)))) assoc)) - (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)) - '()))))) + ;; TODO + ;; - constants + ;; - literals + ;; - custom ellipsis + ;; - splicing + ;; - placeholder + ;; - vector - (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)))))))) + ;; p ::= () + ;; | var + ;; | (p . p) + ;; | (p ...) - (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)))))))) + (define (compile ellipsis literals rules) - (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))))) + (define (many? pat) + (and (pair? pat) + (pair? (cdr pat)) + (variable? (cadr pat)) + (variable=? (cadr pat) ellipsis) + (eq? (cddr pat) '()))) - (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 (pattern-validator pat) ; pattern -> validator + (letrec + ((pattern-validator + (lambda (pat form) + (cond + ((null? pat) + #`(null? #,form)) + ((variable? pat) + #t) + ((many? pat) + (let ((validator (pattern-validator (car pat) 'it))) + #`(and (list? #,form) + (every? (map (lambda (#,'it) #,validator) #,form))))) + ((pair? pat) + #`(and (pair? #,form) + #,(pattern-validator (car pat) #`(car #,form)) + #,(pattern-validator (cdr pat) #`(cdr #,form)))) + (else + #f))))) + (pattern-validator pat 'it))) - (let-values (((match vars) (compile-match-base (cdr pattern)))) - (values `(,_let ((expr (,_cdr expr))) - ,match - #t) - vars)))) + (define (pattern-variables pat) ; pattern -> (freevar) + (cond + ((null? pat) + '()) + ((variable? pat) + `(,pat)) + ((many? pat) + (pattern-variables (car pat))) + ((pair? pat) + (append (pattern-variables (car pat)) + (pattern-variables (cdr pat)))))) -;;; 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 (pattern-levels pat) ; pattern -> ((var * int)) + (cond + ((null? pat) + '()) + ((variable? pat) + `((,pat . 0))) + ((many? pat) + (map-values succ (pattern-levels (car pat)))) + ((pair? pat) + (append (pattern-levels (car pat)) + (pattern-levels (cdr pat)))))) - (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 (pattern-selectors pat) ; pattern -> ((var * selector)) + (letrec + ((pattern-selectors + (lambda (pat form) + (cond + ((null? pat) + '()) + ((variable? pat) + `((,pat . ,form))) + ((many? pat) + (let ((envs (pattern-selectors (car pat) 'it))) + (map-values (lambda (s) #`(map (lambda (#,'it) #,s) #,form)) envs))) + ((pair? pat) + (append (pattern-selectors (car pat) #`(car #,form)) + (pattern-selectors (cdr pat) #`(cdr #,form)))))))) + (pattern-selectors pat 'it))) - (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 (template-representation pat levels selectors) + (cond + ((null? pat) + '()) + ((variable? pat) + (let ((it (assq pat levels))) + (if it + (if (= 0 (cdr it)) + (cdr (assq pat selectors)) + (error "unmatched pattern variable level" pat)) + #`'#,pat))) + ((many? pat) + (letrec* + ((inner-pat + (car pat)) + (inner-vars + (filter (lambda (v) (assq v levels)) (pattern-variables inner-pat))) + (inner-tmps + (map (lambda (v) #'it) inner-vars)) + (inner-levels + (map (lambda (s) `(,(car s) . ,(pred (cdr s)))) levels)) + (inner-selectors + (map cons inner-vars inner-tmps)) + (inner-rep + (template-representation inner-pat inner-levels inner-selectors)) + (filtered-selectors + (map (lambda (v) (assq v selectors)) inner-vars)) + ;; ((a . (x1 x2)) (b . (y1 y2 y3)) (c . z1)) -> ((x1 x2) (y1 y2 y3) (z1)) + (list-of-selectors + (map (lambda (x) (if (list? x) x (list x))) (map cdr filtered-selectors)))) + #`(map (lambda #,inner-tmps #,inner-rep) #,@list-of-selectors))) + ((pair? pat) + #`(cons #,(template-representation (car pat) levels selectors) + #,(template-representation (cdr pat) levels selectors))))) - (compile-expand-base template ellipsis))) + (define (compile-rule pattern template) + (let ((levels + (pattern-levels pattern)) + (selectors + (pattern-selectors pattern))) + (template-representation template levels selectors))) - (define (check-vars vars-pattern vars-template) - ;;fixme - #t) + (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)))))) - (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 (compile rules) + #`(lambda #,'it + #,(compile-rules rules))) - (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)))))))) + (let ((rules (map-keys cdr rules))) ; TODO: check pattern head is a variable + (compile rules))) - (define (normalize-form form) - (if (and (list? form) (>= (length form) 2)) - (let ((ellipsis '...) - (literals (cadr form)) - (rules (cddr form))) + (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)))) - (when (symbol? literals) - (set! ellipsis literals) - (set! literals (car rules)) - (set! 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)) - - (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))))) - - `(,_syntax-error "malformed syntax-rules")))))) (export syntax-rules _ From 86ba26b02e195745c6e0798b99f538de838ac36d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 13 Jun 2015 15:57:02 +0900 Subject: [PATCH 019/125] syntax-rules: custom ellipsis support already done --- piclib/picrin/syntax-rules.scm | 1 - 1 file changed, 1 deletion(-) diff --git a/piclib/picrin/syntax-rules.scm b/piclib/picrin/syntax-rules.scm index 4584d7f2..092cf779 100644 --- a/piclib/picrin/syntax-rules.scm +++ b/piclib/picrin/syntax-rules.scm @@ -42,7 +42,6 @@ ;; TODO ;; - constants ;; - literals - ;; - custom ellipsis ;; - splicing ;; - placeholder ;; - vector From dfcf8c73bd98e979ab148f96458510b68dc12220 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 13 Jun 2015 18:23:46 +0900 Subject: [PATCH 020/125] syntax-rules: constant pattern support --- piclib/picrin/syntax-rules.scm | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/piclib/picrin/syntax-rules.scm b/piclib/picrin/syntax-rules.scm index 092cf779..2ed3f38c 100644 --- a/piclib/picrin/syntax-rules.scm +++ b/piclib/picrin/syntax-rules.scm @@ -40,19 +40,22 @@ (map (lambda (s) `(,(car s) . ,(f (cdr s)))) assoc)) ;; TODO - ;; - constants ;; - literals ;; - splicing ;; - placeholder ;; - vector - ;; p ::= () + ;; p ::= constant ;; | var ;; | (p . p) ;; | (p ...) (define (compile ellipsis literals rules) + (define (constant? obj) + (and (not (pair? obj)) + (not (variable? obj)))) + (define (many? pat) (and (pair? pat) (pair? (cdr pat)) @@ -65,8 +68,8 @@ ((pattern-validator (lambda (pat form) (cond - ((null? pat) - #`(null? #,form)) + ((constant? pat) + #`(equal? '#,pat #,form)) ((variable? pat) #t) ((many? pat) @@ -83,7 +86,7 @@ (define (pattern-variables pat) ; pattern -> (freevar) (cond - ((null? pat) + ((constant? pat) '()) ((variable? pat) `(,pat)) @@ -95,7 +98,7 @@ (define (pattern-levels pat) ; pattern -> ((var * int)) (cond - ((null? pat) + ((constant? pat) '()) ((variable? pat) `((,pat . 0))) @@ -110,7 +113,7 @@ ((pattern-selectors (lambda (pat form) (cond - ((null? pat) + ((constant? pat) '()) ((variable? pat) `((,pat . ,form))) @@ -124,8 +127,8 @@ (define (template-representation pat levels selectors) (cond - ((null? pat) - '()) + ((constant? pat) + pat) ((variable? pat) (let ((it (assq pat levels))) (if it From 691d0ad698e7639f7cad1f430f103b58c7d106db Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 15 Jun 2015 02:53:39 +0900 Subject: [PATCH 021/125] syntax-rules: literal support --- piclib/picrin/syntax-rules.scm | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/piclib/picrin/syntax-rules.scm b/piclib/picrin/syntax-rules.scm index 2ed3f38c..2ae4f3bb 100644 --- a/piclib/picrin/syntax-rules.scm +++ b/piclib/picrin/syntax-rules.scm @@ -40,7 +40,6 @@ (map (lambda (s) `(,(car s) . ,(f (cdr s)))) assoc)) ;; TODO - ;; - literals ;; - splicing ;; - placeholder ;; - vector @@ -56,6 +55,10 @@ (and (not (pair? obj)) (not (variable? obj)))) + (define (literal? obj) + (and (variable? obj) + (memq obj literals))) + (define (many? pat) (and (pair? pat) (pair? (cdr pat)) @@ -70,6 +73,8 @@ (cond ((constant? pat) #`(equal? '#,pat #,form)) + ((literal? pat) + #`(variable=? #'#,pat #,form)) ((variable? pat) #t) ((many? pat) @@ -88,6 +93,8 @@ (cond ((constant? pat) '()) + ((literal? pat) + '()) ((variable? pat) `(,pat)) ((many? pat) @@ -100,6 +107,8 @@ (cond ((constant? pat) '()) + ((literal? pat) + '()) ((variable? pat) `((,pat . 0))) ((many? pat) @@ -115,6 +124,8 @@ (cond ((constant? pat) '()) + ((literal? pat) + '()) ((variable? pat) `((,pat . ,form))) ((many? pat) From af598858583daac985e3d8f33bcace76c123831f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 15 Jun 2015 02:12:56 +0900 Subject: [PATCH 022/125] syntax-rules: support splicing in template --- piclib/picrin/syntax-rules.scm | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/piclib/picrin/syntax-rules.scm b/piclib/picrin/syntax-rules.scm index 2ae4f3bb..ee80f4cc 100644 --- a/piclib/picrin/syntax-rules.scm +++ b/piclib/picrin/syntax-rules.scm @@ -49,6 +49,12 @@ ;; | (p . p) ;; | (p ...) + ;; only template supports (p ... . p) pattern + ;; tp := constant + ;; | var + ;; | (p . p) + ;; | (p ... . p) + (define (compile ellipsis literals rules) (define (constant? obj) @@ -63,8 +69,7 @@ (and (pair? pat) (pair? (cdr pat)) (variable? (cadr pat)) - (variable=? (cadr pat) ellipsis) - (eq? (cddr pat) '()))) + (variable=? (cadr pat) ellipsis))) (define (pattern-validator pat) ; pattern -> validator (letrec @@ -166,7 +171,9 @@ ;; ((a . (x1 x2)) (b . (y1 y2 y3)) (c . z1)) -> ((x1 x2) (y1 y2 y3) (z1)) (list-of-selectors (map (lambda (x) (if (list? x) x (list x))) (map cdr filtered-selectors)))) - #`(map (lambda #,inner-tmps #,inner-rep) #,@list-of-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))))) From 3ed24ae1fb9bf9aebd5d24b22b15d4ad8674ad5c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 15 Jun 2015 02:13:22 +0900 Subject: [PATCH 023/125] syntax-rules: hygienic syntax-rules --- piclib/picrin/syntax-rules.scm | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/piclib/picrin/syntax-rules.scm b/piclib/picrin/syntax-rules.scm index ee80f4cc..55076e7c 100644 --- a/piclib/picrin/syntax-rules.scm +++ b/piclib/picrin/syntax-rules.scm @@ -151,7 +151,7 @@ (if (= 0 (cdr it)) (cdr (assq pat selectors)) (error "unmatched pattern variable level" pat)) - #`'#,pat))) + #`(#,'rename '#,pat)))) ((many? pat) (letrec* ((inner-pat @@ -195,8 +195,18 @@ #,(compile-rules (cdr rules)))))) (define (compile rules) - #`(lambda #,'it - #,(compile-rules 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 ((rules (map-keys cdr rules))) ; TODO: check pattern head is a variable (compile rules))) From 867afc9b6f1c79c82d7c23145248d18ac1230675 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 15 Jun 2015 16:24:23 +0900 Subject: [PATCH 024/125] [bugfix] syntax-rules: ellipsis pattern representation broken --- piclib/picrin/syntax-rules.scm | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/piclib/picrin/syntax-rules.scm b/piclib/picrin/syntax-rules.scm index 55076e7c..ee190a62 100644 --- a/piclib/picrin/syntax-rules.scm +++ b/piclib/picrin/syntax-rules.scm @@ -156,21 +156,25 @@ (letrec* ((inner-pat (car pat)) - (inner-vars - (filter (lambda (v) (assq v levels)) (pattern-variables inner-pat))) - (inner-tmps - (map (lambda (v) #'it) inner-vars)) (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 - (map cons inner-vars inner-tmps)) + ;; 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)) - (filtered-selectors + (sorted-selectors (map (lambda (v) (assq v selectors)) inner-vars)) - ;; ((a . (x1 x2)) (b . (y1 y2 y3)) (c . z1)) -> ((x1 x2) (y1 y2 y3) (z1)) (list-of-selectors - (map (lambda (x) (if (list? x) x (list x))) (map cdr filtered-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)))) From 84a3eaee35e322039e4439dee112a25367818320 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Jun 2015 01:52:18 +0900 Subject: [PATCH 025/125] change eval interface: eval takes an expression and an environment macroexpand should be done in the context in which the expansion is running. As of now I only changed c interface of eval but should change the scheme interface as well ASAP. --- extlib/benz/codegen.c | 4 ++-- extlib/benz/eval.c | 8 ++++---- extlib/benz/include/picrin.h | 6 +++--- extlib/benz/include/picrin/value.h | 1 + extlib/benz/lib.c | 2 +- extlib/benz/load.c | 2 +- extlib/benz/macro.c | 18 ++++++------------ extlib/benz/read.c | 2 +- 8 files changed, 19 insertions(+), 24 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index d2d0fbe2..5d34c05a 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -1420,7 +1420,7 @@ pic_codegen(pic_state *pic, pic_value obj) } 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); @@ -1436,7 +1436,7 @@ pic_compile(pic_state *pic, pic_value obj, struct pic_lib *lib) #endif /* macroexpand */ - obj = pic_macroexpand(pic, obj, lib); + obj = pic_macroexpand(pic, obj, env); #if DEBUG fprintf(stdout, "## macroexpand completed\n"); pic_debug(pic, obj); diff --git a/extlib/benz/eval.c b/extlib/benz/eval.c index 1006df50..34941a61 100644 --- a/extlib/benz/eval.c +++ b/extlib/benz/eval.c @@ -5,13 +5,13 @@ #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 @@ -26,7 +26,7 @@ pic_eval_eval(pic_state *pic) if (lib == NULL) { pic_errorf(pic, "no library found: ~s", spec); } - return pic_eval(pic, program, lib); + return pic_eval(pic, program, lib->env); } void diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index f2e72af8..24637fb9 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -215,9 +215,9 @@ 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 *); +pic_value pic_macroexpand(pic_state *, pic_value, struct pic_env *); struct pic_lib *pic_make_library(pic_state *, pic_value); struct pic_lib *pic_find_library(pic_state *, pic_value); diff --git a/extlib/benz/include/picrin/value.h b/extlib/benz/include/picrin/value.h index 7868429c..703bcb8e 100644 --- a/extlib/benz/include/picrin/value.h +++ b/extlib/benz/include/picrin/value.h @@ -184,6 +184,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; diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index 545052c7..245e4780 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -299,7 +299,7 @@ pic_lib_define_library(pic_state *pic) pic->lib = lib; for (i = 0; i < argc; ++i) { - pic_void(pic_eval(pic, argv[i], pic->lib)); + pic_void(pic_eval(pic, argv[i], pic->lib->env)); } pic->lib = prev; diff --git a/extlib/benz/load.c b/extlib/benz/load.c index 53220101..309a1bd8 100644 --- a/extlib/benz/load.c +++ b/extlib/benz/load.c @@ -13,7 +13,7 @@ pic_load_port(pic_state *pic, struct pic_port *port) size_t ai = pic_gc_arena_preserve(pic); while (! pic_eof_p(form = pic_read(pic, port))) { - pic_eval(pic, form, pic->lib); + pic_eval(pic, form, pic->lib->env); pic_gc_arena_restore(pic, ai); } diff --git a/extlib/benz/macro.c b/extlib/benz/macro.c index 057e7dac..8bc3c4bc 100644 --- a/extlib/benz/macro.c +++ b/extlib/benz/macro.c @@ -299,7 +299,7 @@ macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) val = pic_cadr(pic, pic_cdr(pic, expr)); pic_try { - val = pic_eval(pic, val, pic->lib); + val = pic_eval(pic, val, env); } pic_catch { pic_errorf(pic, "macroexpand error while definition: %s", pic_errmsg(pic)); } @@ -403,9 +403,8 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_env *env) } pic_value -pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib) +pic_macroexpand(pic_state *pic, pic_value expr, struct pic_env *env) { - struct pic_lib *prev; pic_value v; #if DEBUG @@ -414,17 +413,12 @@ pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib) puts(""); #endif - /* change library for macro-expansion time processing */ - prev = pic->lib; - pic->lib = lib; + /* expansion can fail with non-local exit so env->defer should be cleared every time */ + env->defer = pic_nil_value(); - lib->env->defer = pic_nil_value(); /* the last expansion could fail and leave defer field old */ + v = macroexpand(pic, expr, env); - v = macroexpand(pic, expr, lib->env); - - macroexpand_deferred(pic, lib->env); - - pic->lib = prev; + macroexpand_deferred(pic, env); #if DEBUG puts("after expand:"); diff --git a/extlib/benz/read.c b/extlib/benz/read.c index a5f45299..df1712c1 100644 --- a/extlib/benz/read.c +++ b/extlib/benz/read.c @@ -153,7 +153,7 @@ read_eval(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) form = read(pic, port, next(port)); - return pic_eval(pic, form, pic->lib); + return pic_eval(pic, form, pic->lib->env); } static pic_value From 84bb7e9ffc70e9cfd9a66cdf4e8353da4da20465 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Jun 2015 01:58:50 +0900 Subject: [PATCH 026/125] =?UTF-8?q?[bugfix]=20syntax-rules:=20don't=20comp?= =?UTF-8?q?are=20with=20variable=3D=3F=20a=20value=20of=20other=20type=20t?= =?UTF-8?q?han=20variable?= --- piclib/picrin/syntax-rules.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/piclib/picrin/syntax-rules.scm b/piclib/picrin/syntax-rules.scm index ee190a62..4d26bdca 100644 --- a/piclib/picrin/syntax-rules.scm +++ b/piclib/picrin/syntax-rules.scm @@ -79,7 +79,7 @@ ((constant? pat) #`(equal? '#,pat #,form)) ((literal? pat) - #`(variable=? #'#,pat #,form)) + #`(and (variable? #,form) (variable=? #'#,pat #,form))) ((variable? pat) #t) ((many? pat) From 02d75b4283c62701384c2d2826363bd69e3122bd Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Jun 2015 02:42:21 +0900 Subject: [PATCH 027/125] syntax-rules: as of now we have no plan to add (... template) pattern support --- t/r7rs-tests.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index e1d82f48..e7adaf65 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.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)) From dbba29a5a8115cb61a761acdea2131a6ddf3e4f9 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Jun 2015 19:08:34 +0900 Subject: [PATCH 028/125] syntax-rules: support tail pattern --- piclib/picrin/syntax-rules.scm | 43 +++++++++++++++++++++++----------- 1 file changed, 29 insertions(+), 14 deletions(-) diff --git a/piclib/picrin/syntax-rules.scm b/piclib/picrin/syntax-rules.scm index 4d26bdca..3e5496a3 100644 --- a/piclib/picrin/syntax-rules.scm +++ b/piclib/picrin/syntax-rules.scm @@ -33,6 +33,18 @@ (filter f (cdr list))) (filter f (cdr list))))) + (define (take-tail n list) + (let drop ((n (- (length list) n)) (list list)) + (if (= n 0) + list + (drop (- n 1) (cdr 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 (map-keys f assoc) (map (lambda (s) `(,(f (car s)) . ,(cdr s))) assoc)) @@ -40,20 +52,14 @@ (map (lambda (s) `(,(car s) . ,(f (cdr s)))) assoc)) ;; TODO - ;; - splicing ;; - placeholder ;; - vector + ;; - (... template) pattern ;; p ::= constant ;; | var + ;; | (p ... . p) (in input pattern, tail p should be a proper list) ;; | (p . p) - ;; | (p ...) - - ;; only template supports (p ... . p) pattern - ;; tp := constant - ;; | var - ;; | (p . p) - ;; | (p ... . p) (define (compile ellipsis literals rules) @@ -83,9 +89,12 @@ ((variable? pat) #t) ((many? pat) - (let ((validator (pattern-validator (car pat) 'it))) + (let ((head #`(drop-tail #,(length (cddr pat)) #,form)) + (tail #`(take-tail #,(length (cddr pat)) #,form))) #`(and (list? #,form) - (every? (map (lambda (#,'it) #,validator) #,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)) @@ -103,7 +112,8 @@ ((variable? pat) `(,pat)) ((many? pat) - (pattern-variables (car pat))) + (append (pattern-variables (car pat)) + (pattern-variables (cddr pat)))) ((pair? pat) (append (pattern-variables (car pat)) (pattern-variables (cdr pat)))))) @@ -117,7 +127,8 @@ ((variable? pat) `((,pat . 0))) ((many? pat) - (map-values succ (pattern-levels (car pat)))) + (append (map-values succ (pattern-levels (car pat))) + (pattern-levels (cddr pat)))) ((pair? pat) (append (pattern-levels (car pat)) (pattern-levels (cdr pat)))))) @@ -134,8 +145,12 @@ ((variable? pat) `((,pat . ,form))) ((many? pat) - (let ((envs (pattern-selectors (car pat) 'it))) - (map-values (lambda (s) #`(map (lambda (#,'it) #,s) #,form)) envs))) + (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)))))))) From 2c269b4f0e505227795fdbfd47d5c1626ad76c8d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Jun 2015 19:10:24 +0900 Subject: [PATCH 029/125] syntax-quote and syntax-quasiquote should create identifiers at runtime, not at compile time --- extlib/benz/boot.c | 322 +++++++++++++++++++++++---------------------- 1 file changed, 166 insertions(+), 156 deletions(-) diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index b4a29fa7..c2c895ad 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -294,97 +294,102 @@ my $src = <<'EOL'; (define-macro syntax-quote (lambda (form env) - (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))))) - (list the-quote (walk wrap (cadr form)))))) + (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) - (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)))))) + (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-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? 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 (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) - (list (the 'quote) (wrap expr))) - ;; simple datum - (else - (list (the 'quote) expr)))) + (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 ((x (cadr form))) - (qq 1 x))))) + (let ((body (qq 1 (cadr form)))) + `(,(the 'let) + ,(map cdr renames) + ,body)))))) (define (transformer f) (lambda (form env) @@ -629,79 +634,84 @@ const char pic_boot[][80] = { "v)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n", " `(,(the 'with-parameter)\n (,(the 'lambda) ()\n ,@forma", "l\n ,@body)))))\n\n (define-macro syntax-quote\n (lambda (form env)\n ", -" (letrec\n ((wrap (let ((register (make-register)))\n ", -" (lambda (var)\n (let ((id (register var)))\n ", -" (if (undefined? id)\n (let ((id (make-identifier", -" var env)))\n (register var id)\n ", -" id)\n id)))))\n (walk (lambda (f form)", -"\n (cond\n ((variable? form)\n ", -" (f form))\n ((pair? form)\n (cons (wal", -"k f (car form)) (walk f (cdr form))))\n ((vector? form)\n ", -" (list->vector (walk f (vector->list form))))\n ", -"(else\n form)))))\n (list the-quote (walk wrap (cadr fo", -"rm))))))\n\n (define-macro syntax-quasiquote\n (lambda (form env)\n (letrec", -"\n ((wrap (let ((register (make-register)))\n (lambda (", -"var)\n (let ((id (register var)))\n (if ", -"(undefined? id)\n (let ((id (make-identifier var env)))", -"\n (register var id)\n id)", -"\n id))))))\n\n (define (syntax-quasiquote? form)\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 (va", -"riable? (car form))\n (variable=? (the 'syntax-unquote) (make-ident", -"ifier (car form) env))))\n\n (define (syntax-unquote-splicing? form)\n ", -" (and (pair? form)\n (pair? (car form))\n (variable", -"? (caar form))\n (variable=? (the 'syntax-unquote-splicing) (make-i", -"dentifier (caar form) env))))\n\n (define (qq depth expr)\n (cond\n ", -" ;; syntax-unquote\n ((syntax-unquote? expr)\n (if (", -"= depth 1)\n (car (cdr expr))\n (list (the 'list)\n ", -" (list (the 'quote) (the 'syntax-unquote))\n ", -" (qq (- depth 1) (car (cdr expr))))))\n ;; syntax-unquote-splicing\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 'quote) (t", -"he '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? expr)\n", -" (list (the 'cons)\n (qq depth (car expr))\n ", -" (qq depth (cdr expr))))\n ;; vector\n ((vector? expr)\n", -" (list (the 'list->vector) (qq depth (vector->list expr))))\n ", -" ;; variable\n ((variable? expr)\n (list (the 'quote) (wrap ", -"expr)))\n ;; simple datum\n (else\n (list (the 'quot", -"e) expr))))\n\n (let ((x (cadr form)))\n (qq 1 x)))))\n\n (define (t", -"ransformer 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 (register1 var1 var2)\n ", -" (register2 var2 var1)\n var2)\n ", -" var2))))\n (unwrap (lambda (var2)\n ", -" (let ((var1 (register2 var2)))\n (if (undefined? var", -"1)\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 form))))))))\n\n (define-macro define-syntax\n (lambda (form env)\n (l", -"et ((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 'transforme", -"r) (,the-begin ,@body)))))))\n\n (define-macro letrec-syntax\n (lambda (form en", -"v)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n", -" `(let ()\n ,@(map (lambda (x)\n `(,(the 'defi", -"ne-syntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n", -"\n (define-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax)", -" ,@(cdr form))))\n\n (export let let* letrec letrec*\n let-values let*-va", -"lues define-values\n quasiquote unquote unquote-splicing\n and o", -"r\n cond case else =>\n do when unless\n parameterize\n ", -" define-syntax\n syntax-quote syntax-unquote\n syntax-qua", -"siquote syntax-unquote-splicing\n let-syntax letrec-syntax\n syn", -"tax-error))\n\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 (re", +"name var))))))\n (walk (lambda (f form)\n (cond\n ", +" ((variable? form)\n (f form))\n ", +" ((pair? form)\n `(,(the 'cons) (walk f (car fo", +"rm)) (walk f (cdr form))))\n ((vector? form)\n ", +" `(,(the 'list->vector) (walk f (vector->list form))))\n ", +" (else\n `(,(the 'quote) ,form))))))\n (let ((fo", +"rm (walk rename (cadr form))))\n `(,(the 'let)\n ,(map cdr", +" renames)\n ,form))))))\n\n (define-macro syntax-quasiquote\n (lamb", +"da (form env)\n (let ((renames '()))\n (letrec\n ((rename (l", +"ambda (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\n (define (syntax-quasiquote? form)\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 ", +" (variable? (caar form))\n (variable=? (the 'syntax-unqu", +"ote-splicing) (make-identifier (caar form) env))))\n\n (define (qq depth ", +"expr)\n (cond\n ;; syntax-unquote\n ((syntax-unq", +"uote? expr)\n (if (= depth 1)\n (car (cdr expr))\n ", +" (list (the 'list)\n (list (the 'quote) (the", +" 'syntax-unquote))\n (qq (- depth 1) (car (cdr expr))))))\n", +" ;; syntax-unquote-splicing\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 'quote) (the 'syntax-unquote-spli", +"cing))\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 (+ de", +"pth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\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 'quo", +"te) expr))))\n\n (let ((body (qq 1 (cadr form))))\n `(,(the 'le", +"t)\n ,(map cdr renames)\n ,body))))))\n\n (define (transf", +"ormer f)\n (lambda (form env)\n (let ((register1 (make-register))\n ", +" (register2 (make-register)))\n (letrec\n ((wrap (lambda (var", +"1)\n (let ((var2 (register1 var1)))\n (i", +"f (undefined? var2)\n (let ((var2 (make-identifier var1", +" env)))\n (register1 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 ((var", +"iable? 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 (vec", +"tor->list form))))\n (else\n form)))))\n", +" (let ((form (cdr form)))\n (walk unwrap (apply f (walk wrap ", +"form))))))))\n\n (define-macro define-syntax\n (lambda (form env)\n (let ((", +"formal (car (cdr form)))\n (body (cdr (cdr form))))\n (if (pai", +"r? 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 ,@(map (lambda (x)\n `(,(the 'define-sy", +"ntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n\n (d", +"efine-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@(c", +"dr form))))\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 ", +" define-syntax\n syntax-quote syntax-unquote\n syntax-quasiquo", +"te syntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-e", +"rror))\n\n", "", "" }; From 1570bd1cd4bb4892e1e4ab2dd926874ff09d58e1 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Jun 2015 19:10:49 +0900 Subject: [PATCH 030/125] syntax-rules: rewrite case-lambda.scm. (p ... . var) pattern is not supported --- contrib/05.r7rs/scheme/case-lambda.scm | 25 +++++++++++-------------- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/contrib/05.r7rs/scheme/case-lambda.scm b/contrib/05.r7rs/scheme/case-lambda.scm index fff2b26c..6a6ca432 100644 --- a/contrib/05.r7rs/scheme/case-lambda.scm +++ b/contrib/05.r7rs/scheme/case-lambda.scm @@ -1,28 +1,25 @@ (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 (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 (formal . body) . rest) + (if (if (list? 'formal) + (= len (length 'formal)) + (>= len (length+ 'formal))) + (apply (lambda formal . body) args) (cl . rest)))))) (cl (params body0 ...) ...))))))) From 2e5b66fabd5b73bb89436f35307b3be8f8ec6f22 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Jun 2015 20:19:04 +0900 Subject: [PATCH 031/125] s/macroexpand/expand/g --- extlib/benz/codegen.c | 6 +-- extlib/benz/include/picrin.h | 2 +- extlib/benz/macro.c | 72 ++++++++++++++++++------------------ 3 files changed, 40 insertions(+), 40 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 5d34c05a..fb7fb59d 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -1435,10 +1435,10 @@ pic_compile(pic_state *pic, pic_value obj, struct pic_env *env) fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); #endif - /* macroexpand */ - obj = pic_macroexpand(pic, obj, env); + /* expand */ + obj = pic_expand(pic, obj, env); #if DEBUG - fprintf(stdout, "## macroexpand completed\n"); + fprintf(stdout, "## expand completed\n"); pic_debug(pic, obj); fprintf(stdout, "\n"); fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index 24637fb9..f6fb2800 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -216,8 +216,8 @@ pic_value pic_apply4(pic_state *, struct pic_proc *, pic_value, pic_value, pic_v 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_env *); +pic_value pic_expand(pic_state *, pic_value, struct pic_env *); struct pic_proc *pic_compile(pic_state *, pic_value, struct pic_env *); -pic_value pic_macroexpand(pic_state *, pic_value, struct pic_env *); struct pic_lib *pic_make_library(pic_state *, pic_value); struct pic_lib *pic_find_library(pic_state *, pic_value); diff --git a/extlib/benz/macro.c b/extlib/benz/macro.c index 8bc3c4bc..1263a6ff 100644 --- a/extlib/benz/macro.c +++ b/extlib/benz/macro.c @@ -148,33 +148,33 @@ find_macro(pic_state *pic, pic_sym *uid) return pic_proc_ptr(pic_dict_ref(pic, pic->macros, uid)); } -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 expand(pic_state *, pic_value, struct pic_env *); +static pic_value expand_lambda(pic_state *, pic_value, struct pic_env *); static pic_value -macroexpand_var(pic_state *pic, pic_value var, struct pic_env *env) +expand_var(pic_state *pic, pic_value var, struct pic_env *env) { return pic_obj_value(resolve(pic, var, env)); } static pic_value -macroexpand_quote(pic_state *pic, pic_value expr) +expand_quote(pic_state *pic, pic_value expr) { return pic_cons(pic, pic_obj_value(pic->uQUOTE), pic_cdr(pic, expr)); } static pic_value -macroexpand_list(pic_state *pic, pic_value obj, struct pic_env *env) +expand_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); + head = expand(pic, pic_car(pic, obj), env); + tail = expand_list(pic, pic_cdr(pic, obj), env); x = pic_cons(pic, head, tail); } else { - x = macroexpand(pic, obj, env); + x = expand(pic, obj, env); } pic_gc_arena_restore(pic, ai); @@ -183,7 +183,7 @@ macroexpand_list(pic_state *pic, pic_value obj, struct pic_env *env) } static pic_value -macroexpand_defer(pic_state *pic, pic_value expr, struct pic_env *env) +expand_defer(pic_state *pic, pic_value expr, struct pic_env *env) { pic_value skel = pic_list1(pic, pic_invalid_value()); /* (#) */ @@ -193,7 +193,7 @@ macroexpand_defer(pic_state *pic, pic_value expr, struct pic_env *env) } static void -macroexpand_deferred(pic_state *pic, struct pic_env *env) +expand_deferred(pic_state *pic, struct pic_env *env) { pic_value defer, val, src, dst, it; @@ -201,7 +201,7 @@ macroexpand_deferred(pic_state *pic, struct pic_env *env) src = pic_car(pic, defer); dst = pic_cdr(pic, defer); - val = macroexpand_lambda(pic, src, env); + val = expand_lambda(pic, src, env); /* copy */ pic_pair_ptr(dst)->car = pic_car(pic, val); @@ -212,7 +212,7 @@ macroexpand_deferred(pic_state *pic, struct pic_env *env) } static pic_value -macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_env *env) +expand_lambda(pic_state *pic, pic_value expr, struct pic_env *env) { pic_value formal, body; struct pic_env *in; @@ -239,16 +239,16 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_env *env) pic_errorf(pic, "syntax error"); } - formal = macroexpand_list(pic, pic_cadr(pic, expr), in); - body = macroexpand_list(pic, pic_cddr(pic, expr), in); + formal = expand_list(pic, pic_cadr(pic, expr), in); + body = expand_list(pic, pic_cddr(pic, expr), in); - macroexpand_deferred(pic, in); + expand_deferred(pic, in); return pic_cons(pic, pic_obj_value(pic->uLAMBDA), pic_cons(pic, formal, body)); } static pic_value -macroexpand_define(pic_state *pic, pic_value expr, struct pic_env *env) +expand_define(pic_state *pic, pic_value expr, struct pic_env *env) { pic_sym *uid; pic_value var, val; @@ -271,13 +271,13 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_env *env) if ((uid = pic_find_variable(pic, env, var)) == NULL) { uid = pic_add_variable(pic, env, var); } - val = macroexpand(pic, pic_list_ref(pic, expr, 2), env); + val = expand(pic, pic_list_ref(pic, expr, 2), env); return pic_list3(pic, pic_obj_value(pic->uDEFINE), pic_obj_value(uid), val); } static pic_value -macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) +expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) { pic_value var, val; pic_sym *uid; @@ -301,7 +301,7 @@ macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) pic_try { val = pic_eval(pic, val, env); } pic_catch { - pic_errorf(pic, "macroexpand error while definition: %s", pic_errmsg(pic)); + pic_errorf(pic, "expand error while definition: %s", pic_errmsg(pic)); } if (! pic_proc_p(val)) { @@ -314,7 +314,7 @@ macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) } static pic_value -macroexpand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct pic_env *env) +expand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct pic_env *env) { pic_value v; @@ -327,7 +327,7 @@ macroexpand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct p pic_try { v = pic_apply2(pic, mac, expr, pic_obj_value(env)); } pic_catch { - pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic)); + pic_errorf(pic, "expand error while application: %s", pic_errmsg(pic)); } #if DEBUG @@ -340,18 +340,18 @@ macroexpand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct p } static pic_value -macroexpand_node(pic_state *pic, pic_value expr, struct pic_env *env) +expand_node(pic_state *pic, pic_value expr, struct pic_env *env) { switch (pic_type(expr)) { case PIC_TT_ID: case PIC_TT_SYMBOL: { - return macroexpand_var(pic, expr, env); + return expand_var(pic, expr, env); } case PIC_TT_PAIR: { struct pic_proc *mac; if (! pic_list_p(expr)) { - pic_errorf(pic, "cannot macroexpand improper list: ~s", expr); + pic_errorf(pic, "cannot expand improper list: ~s", expr); } if (pic_var_p(pic_car(pic, expr))) { @@ -360,23 +360,23 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_env *env) functor = resolve(pic, pic_car(pic, expr), env); if (functor == pic->uDEFINE_MACRO) { - return macroexpand_defmacro(pic, expr, env); + return expand_defmacro(pic, expr, env); } else if (functor == pic->uLAMBDA) { - return macroexpand_defer(pic, expr, env); + return expand_defer(pic, expr, env); } else if (functor == pic->uDEFINE) { - return macroexpand_define(pic, expr, env); + return expand_define(pic, expr, env); } else if (functor == pic->uQUOTE) { - return macroexpand_quote(pic, expr); + return expand_quote(pic, expr); } if ((mac = find_macro(pic, functor)) != NULL) { - return macroexpand_node(pic, macroexpand_macro(pic, mac, expr, env), env); + return expand_node(pic, expand_macro(pic, mac, expr, env), env); } } - return macroexpand_list(pic, expr, env); + return expand_list(pic, expr, env); } default: return expr; @@ -384,18 +384,18 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_env *env) } static pic_value -macroexpand(pic_state *pic, pic_value expr, struct pic_env *env) +expand(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... "); + printf("[expand] expanding... "); pic_debug(pic, expr); puts(""); #endif - v = macroexpand_node(pic, expr, env); + v = expand_node(pic, expr, env); pic_gc_arena_restore(pic, ai); pic_gc_protect(pic, v); @@ -403,7 +403,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_env *env) } pic_value -pic_macroexpand(pic_state *pic, pic_value expr, struct pic_env *env) +pic_expand(pic_state *pic, pic_value expr, struct pic_env *env) { pic_value v; @@ -416,9 +416,9 @@ pic_macroexpand(pic_state *pic, pic_value expr, struct pic_env *env) /* expansion can fail with non-local exit so env->defer should be cleared every time */ env->defer = pic_nil_value(); - v = macroexpand(pic, expr, env); + v = expand(pic, expr, env); - macroexpand_deferred(pic, env); + expand_deferred(pic, env); #if DEBUG puts("after expand:"); From 85e8d1511b931c684c31985c86767655ee6cc621 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Jun 2015 20:57:18 +0900 Subject: [PATCH 032/125] remove defer property from pic_env explicitly pass deferred lambda list to expand functions --- extlib/benz/gc.c | 1 - extlib/benz/include/picrin/macro.h | 1 - extlib/benz/macro.c | 64 +++++++++++++++--------------- 3 files changed, 32 insertions(+), 34 deletions(-) diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index 9d5d759f..5ed749b7 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -424,7 +424,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) if (env->up) { gc_mark_object(pic, (struct pic_object *)env->up); } - gc_mark(pic, env->defer); for (it = xh_begin(&env->map); it != NULL; it = xh_next(it)) { gc_mark_object(pic, xh_key(it, struct pic_object *)); gc_mark_object(pic, xh_val(it, struct pic_object *)); diff --git a/extlib/benz/include/picrin/macro.h b/extlib/benz/include/picrin/macro.h index 28ce8208..6a7b2ab3 100644 --- a/extlib/benz/include/picrin/macro.h +++ b/extlib/benz/include/picrin/macro.h @@ -18,7 +18,6 @@ struct pic_id { struct pic_env { PIC_OBJECT_HEADER xhash map; - pic_value defer; struct pic_env *up; }; diff --git a/extlib/benz/macro.c b/extlib/benz/macro.c index 1263a6ff..6363486c 100644 --- a/extlib/benz/macro.c +++ b/extlib/benz/macro.c @@ -30,7 +30,6 @@ pic_make_env(pic_state *pic, struct pic_env *up) env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV); env->up = up; - env->defer = pic_nil_value(); xh_init_ptr(&env->map, sizeof(pic_sym *)); return env; } @@ -148,7 +147,7 @@ find_macro(pic_state *pic, pic_sym *uid) return pic_proc_ptr(pic_dict_ref(pic, pic->macros, uid)); } -static pic_value expand(pic_state *, pic_value, struct pic_env *); +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 @@ -164,17 +163,17 @@ expand_quote(pic_state *pic, pic_value expr) } static pic_value -expand_list(pic_state *pic, pic_value obj, struct pic_env *env) +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); - tail = expand_list(pic, pic_cdr(pic, obj), env); + 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); + x = expand(pic, obj, env, deferred); } pic_gc_arena_restore(pic, ai); @@ -183,32 +182,32 @@ expand_list(pic_state *pic, pic_value obj, struct pic_env *env) } static pic_value -expand_defer(pic_state *pic, pic_value expr, struct pic_env *env) +expand_defer(pic_state *pic, pic_value expr, pic_value deferred) { pic_value skel = pic_list1(pic, pic_invalid_value()); /* (#) */ - pic_push(pic, pic_cons(pic, expr, skel), env->defer); + pic_set_car(pic, deferred, pic_acons(pic, expr, skel, pic_car(pic, deferred))); return skel; } static void -expand_deferred(pic_state *pic, struct pic_env *env) +expand_deferred(pic_state *pic, pic_value deferred, struct pic_env *env) { pic_value defer, val, src, dst, it; - pic_for_each (defer, pic_reverse(pic, env->defer), 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_pair_ptr(dst)->car = pic_car(pic, val); - pic_pair_ptr(dst)->cdr = pic_cdr(pic, val); + pic_set_car(pic, dst, pic_car(pic, val)); + pic_set_cdr(pic, dst, pic_cdr(pic, val)); } - - env->defer = pic_nil_value(); } static pic_value @@ -216,7 +215,7 @@ expand_lambda(pic_state *pic, pic_value expr, struct pic_env *env) { pic_value formal, body; struct pic_env *in; - pic_value a; + pic_value a, deferred; if (pic_length(pic, expr) < 2) { pic_errorf(pic, "syntax error"); @@ -239,16 +238,18 @@ expand_lambda(pic_state *pic, pic_value expr, struct pic_env *env) pic_errorf(pic, "syntax error"); } - formal = expand_list(pic, pic_cadr(pic, expr), in); - body = expand_list(pic, pic_cddr(pic, expr), in); + deferred = pic_list1(pic, pic_nil_value()); - expand_deferred(pic, in); + formal = expand_list(pic, pic_cadr(pic, expr), in, deferred); + body = expand_list(pic, pic_cddr(pic, expr), in, deferred); + + expand_deferred(pic, deferred, in); return pic_cons(pic, pic_obj_value(pic->uLAMBDA), pic_cons(pic, formal, body)); } static pic_value -expand_define(pic_state *pic, pic_value expr, struct pic_env *env) +expand_define(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred) { pic_sym *uid; pic_value var, val; @@ -271,7 +272,7 @@ expand_define(pic_state *pic, pic_value expr, struct pic_env *env) if ((uid = pic_find_variable(pic, env, var)) == NULL) { uid = pic_add_variable(pic, env, var); } - val = expand(pic, pic_list_ref(pic, expr, 2), env); + 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); } @@ -340,7 +341,7 @@ expand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct pic_en } static pic_value -expand_node(pic_state *pic, pic_value expr, struct pic_env *env) +expand_node(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred) { switch (pic_type(expr)) { case PIC_TT_ID: @@ -363,20 +364,20 @@ expand_node(pic_state *pic, pic_value expr, struct pic_env *env) return expand_defmacro(pic, expr, env); } else if (functor == pic->uLAMBDA) { - return expand_defer(pic, expr, env); + return expand_defer(pic, expr, deferred); } else if (functor == pic->uDEFINE) { - return expand_define(pic, expr, env); + 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, expand_macro(pic, mac, expr, env), env); + return expand_node(pic, expand_macro(pic, mac, expr, env), env, deferred); } } - return expand_list(pic, expr, env); + return expand_list(pic, expr, env, deferred); } default: return expr; @@ -384,7 +385,7 @@ expand_node(pic_state *pic, pic_value expr, struct pic_env *env) } static pic_value -expand(pic_state *pic, pic_value expr, struct pic_env *env) +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; @@ -395,7 +396,7 @@ expand(pic_state *pic, pic_value expr, struct pic_env *env) puts(""); #endif - v = expand_node(pic, expr, env); + v = expand_node(pic, expr, env, deferred); pic_gc_arena_restore(pic, ai); pic_gc_protect(pic, v); @@ -405,7 +406,7 @@ expand(pic_state *pic, pic_value expr, struct pic_env *env) pic_value pic_expand(pic_state *pic, pic_value expr, struct pic_env *env) { - pic_value v; + pic_value v, deferred; #if DEBUG puts("before expand:"); @@ -413,12 +414,11 @@ pic_expand(pic_state *pic, pic_value expr, struct pic_env *env) puts(""); #endif - /* expansion can fail with non-local exit so env->defer should be cleared every time */ - env->defer = pic_nil_value(); + deferred = pic_list1(pic, pic_nil_value()); - v = expand(pic, expr, env); + v = expand(pic, expr, env, deferred); - expand_deferred(pic, env); + expand_deferred(pic, deferred, env); #if DEBUG puts("after expand:"); From cf66d600bbd36e1eceab2ce2614bd31f21c09928 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Jun 2015 21:01:46 +0900 Subject: [PATCH 033/125] move macroexpander to codegen.c --- extlib/benz/codegen.c | 341 ++++++++++++++++++++++++++ extlib/benz/include/picrin/macro.h | 1 + extlib/benz/macro.c | 373 +---------------------------- extlib/benz/vm.c | 32 +++ 4 files changed, 376 insertions(+), 371 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index fb7fb59d..371b0ee8 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -4,6 +4,347 @@ #include "picrin.h" +/** + * macro expander + */ + +static pic_sym * +lookup(pic_state PIC_UNUSED(*pic), pic_value var, struct pic_env *env) +{ + xh_entry *e; + + assert(pic_var_p(var)); + + while (env != NULL) { + if ((e = xh_get_ptr(&env->map, pic_ptr(var))) != NULL) { + return xh_val(e, pic_sym *); + } + env = env->up; + } + return NULL; +} + +static pic_sym * +resolve(pic_state *pic, pic_value var, struct pic_env *env) +{ + pic_sym *uid; + + assert(pic_var_p(var)); + assert(env != NULL); + + 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) +{ + 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 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(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; + + 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 var = pic_car(pic, a); + + if (! pic_var_p(var)) { + pic_errorf(pic, "syntax error"); + } + pic_add_variable(pic, in, var); + } + if (pic_var_p(a)) { + pic_add_variable(pic, in, a); + } + else if (! pic_nil_p(a)) { + pic_errorf(pic, "syntax error"); + } + + deferred = pic_list1(pic, pic_nil_value()); + + formal = expand_list(pic, pic_cadr(pic, expr), in, deferred); + body = expand_list(pic, pic_cddr(pic, expr), in, deferred); + + expand_deferred(pic, deferred, in); + + return pic_cons(pic, pic_obj_value(pic->uLAMBDA), pic_cons(pic, 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; + + 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->uDEFINE), var, pic_cons(pic, pic_obj_value(pic->sLAMBDA), 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_var_p(var)) { + pic_errorf(pic, "binding to non-variable object"); + } + if ((uid = pic_find_variable(pic, env, var)) == NULL) { + uid = pic_add_variable(pic, env, var); + } + 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; + + if (pic_length(pic, expr) != 3) { + pic_errorf(pic, "syntax error"); + } + + var = pic_cadr(pic, expr); + if (! pic_var_p(var)) { + pic_errorf(pic, "binding to non-variable object"); + } + if ((uid = pic_find_variable(pic, env, var)) == NULL) { + uid = pic_add_variable(pic, env, var); + } else { + pic_warnf(pic, "redefining syntax variable: ~s", var); + } + + val = pic_cadr(pic, pic_cdr(pic, expr)); + + pic_try { + val = pic_eval(pic, val, env); + } pic_catch { + pic_errorf(pic, "expand error while definition: %s", pic_errmsg(pic)); + } + + 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_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct pic_env *env) +{ + pic_value v; + +#if DEBUG + puts("before expand-1:"); + pic_debug(pic, expr); + puts(""); +#endif + + pic_try { + v = pic_apply2(pic, mac, expr, pic_obj_value(env)); + } pic_catch { + pic_errorf(pic, "expand error while application: %s", pic_errmsg(pic)); + } + +#if DEBUG + puts("after expand-1:"); + pic_debug(pic, v); + puts(""); +#endif + + return v; +} + +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 = 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, expand_macro(pic, mac, expr, 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; + +#if DEBUG + printf("[expand] expanding... "); + pic_debug(pic, expr); + puts(""); +#endif + + 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; +} + typedef xvect_t(pic_sym *) xvect; #define xv_push_sym(v, x) xv_push(pic_sym *, (v), (x)) diff --git a/extlib/benz/include/picrin/macro.h b/extlib/benz/include/picrin/macro.h index 6a7b2ab3..f6baebbb 100644 --- a/extlib/benz/include/picrin/macro.h +++ b/extlib/benz/include/picrin/macro.h @@ -36,6 +36,7 @@ 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/macro.c b/extlib/benz/macro.c index 6363486c..944c971d 100644 --- a/extlib/benz/macro.c +++ b/extlib/benz/macro.c @@ -4,7 +4,7 @@ #include "picrin.h" -static bool +bool pic_var_p(pic_value obj) { return pic_sym_p(obj) || pic_id_p(obj); @@ -57,46 +57,6 @@ pic_uniq(pic_state *pic, pic_value var) return pic_intern(pic, str); } -static pic_sym * -lookup(pic_state PIC_UNUSED(*pic), pic_value var, struct pic_env *env) -{ - xh_entry *e; - - assert(pic_var_p(var)); - - while (env != NULL) { - if ((e = xh_get_ptr(&env->map, pic_ptr(var))) != NULL) { - return xh_val(e, pic_sym *); - } - env = env->up; - } - return NULL; -} - -static pic_sym * -resolve(pic_state *pic, pic_value var, struct pic_env *env) -{ - pic_sym *uid; - - assert(pic_var_p(var)); - assert(env != NULL); - - 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; -} - pic_sym * pic_add_variable(pic_state *pic, struct pic_env *env, pic_value var) { @@ -132,335 +92,6 @@ pic_find_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var return xh_val(e, pic_sym *); } -static void -define_macro(pic_state *pic, pic_sym *uid, struct pic_proc *mac) -{ - 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 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(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; - - 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 var = pic_car(pic, a); - - if (! pic_var_p(var)) { - pic_errorf(pic, "syntax error"); - } - pic_add_variable(pic, in, var); - } - if (pic_var_p(a)) { - pic_add_variable(pic, in, a); - } - else if (! pic_nil_p(a)) { - pic_errorf(pic, "syntax error"); - } - - deferred = pic_list1(pic, pic_nil_value()); - - formal = expand_list(pic, pic_cadr(pic, expr), in, deferred); - body = expand_list(pic, pic_cddr(pic, expr), in, deferred); - - expand_deferred(pic, deferred, in); - - return pic_cons(pic, pic_obj_value(pic->uLAMBDA), pic_cons(pic, 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; - - 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->uDEFINE), var, pic_cons(pic, pic_obj_value(pic->sLAMBDA), 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_var_p(var)) { - pic_errorf(pic, "binding to non-variable object"); - } - if ((uid = pic_find_variable(pic, env, var)) == NULL) { - uid = pic_add_variable(pic, env, var); - } - 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; - - if (pic_length(pic, expr) != 3) { - pic_errorf(pic, "syntax error"); - } - - var = pic_cadr(pic, expr); - if (! pic_var_p(var)) { - pic_errorf(pic, "binding to non-variable object"); - } - if ((uid = pic_find_variable(pic, env, var)) == NULL) { - uid = pic_add_variable(pic, env, var); - } else { - pic_warnf(pic, "redefining syntax variable: ~s", var); - } - - val = pic_cadr(pic, pic_cdr(pic, expr)); - - pic_try { - val = pic_eval(pic, val, env); - } pic_catch { - pic_errorf(pic, "expand error while definition: %s", pic_errmsg(pic)); - } - - 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_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct pic_env *env) -{ - pic_value v; - -#if DEBUG - puts("before expand-1:"); - pic_debug(pic, expr); - puts(""); -#endif - - pic_try { - v = pic_apply2(pic, mac, expr, pic_obj_value(env)); - } pic_catch { - pic_errorf(pic, "expand error while application: %s", pic_errmsg(pic)); - } - -#if DEBUG - puts("after expand-1:"); - pic_debug(pic, v); - puts(""); -#endif - - return v; -} - -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 = 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, expand_macro(pic, mac, expr, 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; - -#if DEBUG - printf("[expand] expanding... "); - pic_debug(pic, expr); - puts(""); -#endif - - 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; -} - -static pic_value -defmacro_call(pic_state *pic) -{ - struct pic_proc *self = pic_get_proc(pic); - pic_value args, tmp, proc; - - pic_get_args(pic, "oo", &args, &tmp); - - proc = pic_attr_ref(pic, pic_obj_value(self), "@@transformer"); - - return pic_apply_trampoline(pic, pic_proc_ptr(proc), pic_cdr(pic, args)); -} - -void -pic_defmacro(pic_state *pic, pic_sym *name, pic_sym *id, pic_func_t func) -{ - struct pic_proc *proc, *trans; - - trans = pic_make_proc(pic, func, pic_symbol_name(pic, name)); - - pic_put_variable(pic, pic->lib->env, pic_obj_value(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); -} - static pic_value pic_macro_identifier_p(pic_state *pic) { @@ -536,7 +167,7 @@ pic_macro_variable_eq_p(pic_state *pic) id1 = pic_id_ptr(var1); id2 = pic_id_ptr(var2); - return pic_bool_value(resolve(pic, id1->var, id1->env) == resolve(pic, id2->var, id2->env)); + return pic_bool_value(pic_eq_p(pic_expand(pic, id1->var, id1->env), pic_expand(pic, id2->var, id2->env))); } return pic_false_value(); } diff --git a/extlib/benz/vm.c b/extlib/benz/vm.c index c3e6de16..791529d0 100644 --- a/extlib/benz/vm.c +++ b/extlib/benz/vm.c @@ -499,6 +499,38 @@ pic_defvar(pic_state *pic, const char *name, pic_value init, struct pic_proc *co pic_define(pic, name, pic_obj_value(pic_make_var(pic, init, conv))); } +static pic_value +defmacro_call(pic_state *pic) +{ + struct pic_proc *self = pic_get_proc(pic); + pic_value args, tmp, proc; + + pic_get_args(pic, "oo", &args, &tmp); + + proc = pic_attr_ref(pic, pic_obj_value(self), "@@transformer"); + + return pic_apply_trampoline(pic, pic_proc_ptr(proc), pic_cdr(pic, args)); +} + +void +pic_defmacro(pic_state *pic, pic_sym *name, pic_sym *id, pic_func_t func) +{ + struct pic_proc *proc, *trans; + + trans = pic_make_proc(pic, func, pic_symbol_name(pic, name)); + + pic_put_variable(pic, pic->lib->env, pic_obj_value(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 */ + pic_dict_set(pic, pic->macros, id, pic_obj_value(proc)); + + /* auto export! */ + pic_export(pic, name); +} + static void vm_push_cxt(pic_state *pic) { From 7dd0e01b7024cfc16495c943ad0434a64370d1af Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Jun 2015 21:13:41 +0900 Subject: [PATCH 034/125] support (equal? identifier1 identifier2) --- extlib/benz/bool.c | 8 ++++++++ extlib/benz/macro.c | 26 +++++++++++--------------- 2 files changed, 19 insertions(+), 15 deletions(-) diff --git a/extlib/benz/bool.c b/extlib/benz/bool.c index 9a1e02ef..603c0db7 100644 --- a/extlib/benz/bool.c +++ b/extlib/benz/bool.c @@ -104,6 +104,14 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash * } return true; } + case PIC_TT_ID: { + struct pic_id *id1, *id2; + + id1 = pic_id_ptr(x); + id2 = pic_id_ptr(y); + + return pic_eq_p(pic_expand(pic, id1->var, id1->env), pic_expand(pic, id2->var, id2->env)); + } default: return false; } diff --git a/extlib/benz/macro.c b/extlib/benz/macro.c index 944c971d..71b70a55 100644 --- a/extlib/benz/macro.c +++ b/extlib/benz/macro.c @@ -152,24 +152,20 @@ pic_macro_variable_p(pic_state *pic) static pic_value pic_macro_variable_eq_p(pic_state *pic) { - pic_value var1, var2; + size_t argc, i; + pic_value *argv; - pic_get_args(pic, "oo", &var1, &var2); + pic_get_args(pic, "*", &argc, &argv); - pic_assert_type(pic, var1, var); - pic_assert_type(pic, var2, var); - - if (pic_sym_p(var1) && pic_sym_p(var2)) { - return pic_bool_value(pic_eq_p(var1, var2)); + 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(); + } } - if (pic_id_p(var1) && pic_id_p(var2)) { - struct pic_id *id1, *id2; - - id1 = pic_id_ptr(var1); - id2 = pic_id_ptr(var2); - return pic_bool_value(pic_eq_p(pic_expand(pic, id1->var, id1->env), pic_expand(pic, id2->var, id2->env))); - } - return pic_false_value(); + return pic_true_value(); } void From a88b5e193f66c8955c7d2cbfaab42ff7ade3cead Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Jun 2015 21:39:41 +0900 Subject: [PATCH 035/125] remove #. reader --- extlib/benz/read.c | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/extlib/benz/read.c b/extlib/benz/read.c index df1712c1..6dbea00a 100644 --- a/extlib/benz/read.c +++ b/extlib/benz/read.c @@ -146,16 +146,6 @@ 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->env); -} - static pic_value read_quote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) { @@ -829,7 +819,6 @@ reader_table_init(struct pic_reader *reader) 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) { From eef74604d0566671ff1c4eb8363ea919d2cf73d6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Jun 2015 22:51:05 +0900 Subject: [PATCH 036/125] add library operators --- extlib/benz/include/picrin/lib.h | 1 + extlib/benz/lib.c | 59 ++++++++++++++++++++++++++++++++ piclib/picrin/base.scm | 5 +++ 3 files changed, 65 insertions(+) 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/lib.c b/extlib/benz/lib.c index 245e4780..cc1eb503 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -312,6 +312,60 @@ pic_lib_define_library(pic_state *pic) return pic_undef_value(); } +static pic_value +pic_lib_make_library(pic_state *pic) +{ + pic_value name; + + pic_get_args(pic, "o", &name); + + return pic_obj_value(pic_make_library(pic, name)); +} + +static pic_value +pic_lib_find_library(pic_state *pic) +{ + pic_value name; + struct pic_lib *lib; + + pic_get_args(pic, "o", &name); + + if ((lib = pic_find_library(pic, name)) == NULL) { + return pic_false_value(); + } + return pic_obj_value(lib); +} + +static pic_value +pic_lib_library_exports(pic_state *pic) +{ + pic_value lib, exports = pic_nil_value(); + pic_sym *sym; + xh_entry *it; + + pic_get_args(pic, "o", &lib); + + 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 exports; +} + +static pic_value +pic_lib_library_environment(pic_state *pic) +{ + pic_value lib; + + pic_get_args(pic, "o", &lib); + + pic_assert_type(pic, lib, lib); + + return pic_obj_value(pic_lib_ptr(lib)->env); +} + void pic_init_lib(pic_state *pic) { @@ -321,4 +375,9 @@ pic_init_lib(pic_state *pic) pic_defmacro(pic, pic->sIMPORT, pic->uIMPORT, pic_lib_import); pic_defmacro(pic, pic->sEXPORT, pic->uEXPORT, pic_lib_export); pic_defmacro(pic, pic->sDEFINE_LIBRARY, pic->uDEFINE_LIBRARY, pic_lib_define_library); + + 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); } diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm index 66ad69e5..edbac8c1 100644 --- a/piclib/picrin/base.scm +++ b/piclib/picrin/base.scm @@ -252,6 +252,11 @@ variable? variable=?) + (export make-library + find-library + library-exports + library-environment) + (export call-with-current-continuation call/cc dynamic-wind From 4f69cb8ec3db6e46ee85075b44e22cb5a5175516 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 16 Jun 2015 22:51:49 +0900 Subject: [PATCH 037/125] eval procedure now takes environment object for the second argument --- contrib/05.r7rs/scheme/eval.scm | 10 ++++------ contrib/05.r7rs/scheme/r5rs.scm | 7 ++++--- contrib/20.repl/repl.scm | 5 +++-- extlib/benz/eval.c | 13 +++++-------- 4 files changed, 16 insertions(+), 19 deletions(-) diff --git a/contrib/05.r7rs/scheme/eval.scm b/contrib/05.r7rs/scheme/eval.scm index 54574c03..b93764cd 100644 --- a/contrib/05.r7rs/scheme/eval.scm +++ b/contrib/05.r7rs/scheme/eval.scm @@ -4,14 +4,12 @@ (define environment (let ((counter 0)) (lambda specs - (let ((library-name `(picrin @@my-environment ,counter))) + (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)) - '(scheme base)) - 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/r5rs.scm b/contrib/05.r7rs/scheme/r5rs.scm index 9baebe65..e054f3bb 100644 --- a/contrib/05.r7rs/scheme/r5rs.scm +++ b/contrib/05.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/20.repl/repl.scm b/contrib/20.repl/repl.scm index 3afd70c8..ad1c2e19 100644 --- a/contrib/20.repl/repl.scm +++ b/contrib/20.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)) @@ -32,7 +33,7 @@ (picrin macro) (picrin array) (picrin library)) - '(picrin user)) + (library-environment (find-library '(picrin user)))) (define (repl) (let loop ((buf "")) diff --git a/extlib/benz/eval.c b/extlib/benz/eval.c index 34941a61..c81da246 100644 --- a/extlib/benz/eval.c +++ b/extlib/benz/eval.c @@ -17,16 +17,13 @@ pic_eval(pic_state *pic, pic_value program, struct pic_env *env) 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->env); + pic_assert_type(pic, env, env); + + return pic_eval(pic, program, pic_env_ptr(env)); } void From 490c97cd814476224bbcce974dae8c7df7d56870 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Jun 2015 00:03:52 +0900 Subject: [PATCH 038/125] add library-name and current-library --- extlib/benz/lib.c | 34 ++++++++++++++++++++++++++++++++++ piclib/picrin/base.scm | 2 ++ 2 files changed, 36 insertions(+) diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index cc1eb503..893cc36e 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -336,6 +336,38 @@ pic_lib_find_library(pic_state *pic) 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_name(pic_state *pic) +{ + pic_value lib; + + pic_get_args(pic, "o", &lib); + + pic_assert_type(pic, lib, lib); + + return pic_lib_ptr(lib)->name; +} + static pic_value pic_lib_library_exports(pic_state *pic) { @@ -378,6 +410,8 @@ pic_init_lib(pic_state *pic) pic_defun(pic, "make-library", pic_lib_make_library); pic_defun(pic, "find-library", pic_lib_find_library); + pic_defun(pic, "current-library", pic_lib_current_library); + pic_defun(pic, "library-name", pic_lib_library_name); pic_defun(pic, "library-exports", pic_lib_library_exports); pic_defun(pic, "library-environment", pic_lib_library_environment); } diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm index edbac8c1..224043fb 100644 --- a/piclib/picrin/base.scm +++ b/piclib/picrin/base.scm @@ -254,6 +254,8 @@ (export make-library find-library + current-library + library-name library-exports library-environment) From 62b7c1a0f95ead14752b8278a7b9d4f6b75e9875 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Jun 2015 00:11:02 +0900 Subject: [PATCH 039/125] warn macro redefinition only when transformer object slot is being overwritten --- extlib/benz/codegen.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 371b0ee8..8052873f 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -51,6 +51,9 @@ resolve(pic_state *pic, pic_value var, struct pic_env *env) 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)); } @@ -209,8 +212,6 @@ expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) } if ((uid = pic_find_variable(pic, env, var)) == NULL) { uid = pic_add_variable(pic, env, var); - } else { - pic_warnf(pic, "redefining syntax variable: ~s", var); } val = pic_cadr(pic, pic_cdr(pic, expr)); From 63d3510de8210643483196ddd5d16adfae5a0ffc Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Jun 2015 00:13:00 +0900 Subject: [PATCH 040/125] move features procedure defun to state.c benz --- contrib/05.r7rs/scheme/base.scm | 4 +++- extlib/benz/state.c | 10 ++++++++++ piclib/picrin/base.scm | 4 +++- src/main.c | 12 ------------ 4 files changed, 16 insertions(+), 14 deletions(-) diff --git a/contrib/05.r7rs/scheme/base.scm b/contrib/05.r7rs/scheme/base.scm index 08d438c0..927643aa 100644 --- a/contrib/05.r7rs/scheme/base.scm +++ b/contrib/05.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/extlib/benz/state.c b/extlib/benz/state.c index 65c0bcf5..39b506ce 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -91,6 +91,14 @@ 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); static void @@ -111,6 +119,8 @@ pic_init_core(pic_state *pic) pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->uBEGIN); pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_MACRO, pic->uDEFINE_MACRO); + pic_defun(pic, "features", pic_features); + pic_init_undef(pic); DONE; pic_init_bool(pic); DONE; pic_init_pair(pic); DONE; diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm index 224043fb..a9d6d7fa 100644 --- a/piclib/picrin/base.scm +++ b/piclib/picrin/base.scm @@ -286,4 +286,6 @@ write-shared display) - (export eval)) + (export eval) + + (export features)) diff --git a/src/main.c b/src/main.c index fbdae10c..a4a330ef 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); } From fa1c61963352be46eefb46831098f862f5d7936f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Jun 2015 00:14:12 +0900 Subject: [PATCH 041/125] define define-library and cond-expand in scheme --- extlib/benz/boot.c | 1319 +++++++++++++++++++++++--------------------- extlib/benz/lib.c | 96 ---- 2 files changed, 683 insertions(+), 732 deletions(-) diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index c2c895ad..2bb39ea8 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -8,454 +8,492 @@ use strict; my $src = <<'EOL'; -(define-library (picrin base) +(define-macro call-with-current-environment + (lambda (form env) + (list (cadr form) env))) - (define-macro call-with-current-environment - (lambda (form env) - (list (cadr form) env))) +(define here + (call-with-current-environment + (lambda (env) + env))) - (define here - (call-with-current-environment - (lambda (env) - env))) +(define (the var) ; synonym for #'var + (make-identifier var here)) - (define (the var) ; synonym for #'var - (make-identifier var here)) +(define the-define (the 'define)) +(define the-lambda (the 'lambda)) +(define the-begin (the 'begin)) +(define the-quote (the 'quote)) +(define the-set! (the 'set!)) +(define the-if (the 'if)) +(define the-define-macro (the 'define-macro)) - (define the-define (the 'define)) - (define the-lambda (the 'lambda)) - (define the-begin (the 'begin)) - (define the-quote (the 'quote)) - (define the-set! (the 'set!)) - (define the-if (the 'if)) - (define the-define-macro (the 'define-macro)) +(define-macro syntax-error + (lambda (form _) + (apply error (cdr form)))) - (define-macro syntax-error - (lambda (form _) - (apply error (cdr form)))) +(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-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-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) - (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) +(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-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-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-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-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 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 cond - (lambda (form env) - (let ((clauses (cdr form))) +(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-macro letrec + (lambda (form env) + `(,(the 'letrec*) ,@(cdr 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-macro let-values + (lambda (form env) + `(,(the 'let*-values) ,@(cdr form)))) + +(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-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-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-macro when + (lambda (form env) + (let ((test (car (cdr form))) + (body (cdr (cdr form)))) + `(,the-if ,test + (,the-begin ,@body) + #undefined)))) + +(define-macro unless + (lambda (form env) + (let ((test (car (cdr form))) + (body (cdr (cdr form)))) + `(,the-if ,test + #undefined + (,the-begin ,@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-macro parameterize + (lambda (form env) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + `(,(the 'with-parameter) + (,(the 'lambda) () + ,@formal + ,@body))))) + +(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)))) + +(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) + +(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 - (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)))))))))) + (if (test (caar clauses)) + `(,the-begin ,@(cdar clauses)) + (loop (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-macro letrec - (lambda (form env) - `(,(the 'letrec*) ,@(cdr 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-macro let-values - (lambda (form env) - `(,(the 'let*-values) ,@(cdr form)))) - - (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-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-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-macro when - (lambda (form env) - (let ((test (car (cdr form))) - (body (cdr (cdr form)))) - `(,the-if ,test - (,the-begin ,@body) - #undefined)))) - - (define-macro unless - (lambda (form env) - (let ((test (car (cdr form))) - (body (cdr (cdr form)))) - `(,the-if ,test - #undefined - (,the-begin ,@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-macro parameterize - (lambda (form env) - (let ((formal (car (cdr form))) - (body (cdr (cdr form)))) - `(,(the 'with-parameter) - (,(the 'lambda) () - ,@formal - ,@body))))) - - (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)))) - - (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 define-library + cond-expand) EOL @@ -509,209 +547,218 @@ EOL #endif const char pic_boot[][80] = { -"\n(define-library (picrin base)\n\n (define-macro call-with-current-environment\n ", -" (lambda (form env)\n (list (cadr form) env)))\n\n (define here\n (call-wi", -"th-current-environment\n (lambda (env)\n env)))\n\n (define (the var) ", -" ; synonym for #'var\n (make-identifier var here))\n\n (define ", -"the-define (the 'define))\n (define the-lambda (the 'lambda))\n (define the-begi", -"n (the 'begin))\n (define the-quote (the 'quote))\n (define the-set! (the 'set!)", -")\n (define the-if (the 'if))\n (define the-define-macro (the 'define-macro))\n\n ", -" (define-macro syntax-error\n (lambda (form _)\n (apply error (cdr form)))", -")\n\n (define-macro define-auxiliary-syntax\n (lambda (form _)\n (define me", -"ssage\n (string-append\n \"invalid use of auxiliary syntax: '\" (symb", -"ol->string (cadr form)) \"'\"))\n (list\n the-define-macro\n (cadr f", -"orm)\n (list the-lambda '_\n (list (the 'error) message)))))\n\n ", -"(define-auxiliary-syntax else)\n (define-auxiliary-syntax =>)\n (define-auxiliar", -"y-syntax unquote)\n (define-auxiliary-syntax unquote-splicing)\n (define-auxilia", -"ry-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 ", -" (list\n (list the-lambda '()\n (list the-define (c", -"adr form)\n (cons the-lambda\n (", -"cons (map car (car (cddr form)))\n (cdr (cddr f", -"orm)))))\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 'a", -"nd) (cddr form))\n #f)))))\n\n (define-macro or\n (lambda (fo", -"rm env)\n (if (null? (cdr form))\n #f\n (let ((tmp (make-ide", -"ntifier 'it env)))\n (list (the 'let)\n (list (list tm", -"p (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 (c", -"ar clauses)))\n (if (and (variable? (car clause))\n ", +"\n(define-macro call-with-current-environment\n (lambda (form env)\n (list (cad", +"r form) env)))\n\n(define here\n (call-with-current-environment\n (lambda (env)\n ", +" env)))\n\n(define (the var) ; synonym for #'var\n (make-id", +"entifier var here))\n\n(define the-define (the 'define))\n(define the-lambda (the '", +"lambda))\n(define the-begin (the 'begin))\n(define the-quote (the 'quote))\n(define", +" the-set! (the 'set!))\n(define the-if (the 'if))\n(define the-define-macro (the '", +"define-macro))\n\n(define-macro syntax-error\n (lambda (form _)\n (apply error (", +"cdr form))))\n\n(define-macro define-auxiliary-syntax\n (lambda (form _)\n (defi", +"ne message\n (string-append\n \"invalid use of auxiliary syntax: '\" (sym", +"bol->string (cadr form)) \"'\"))\n (list\n the-define-macro\n (cadr form)\n", +" (list the-lambda '_\n (list (the 'error) message)))))\n\n(define-aux", +"iliary-syntax else)\n(define-auxiliary-syntax =>)\n(define-auxiliary-syntax unquot", +"e)\n(define-auxiliary-syntax unquote-splicing)\n(define-auxiliary-syntax syntax-un", +"quote)\n(define-auxiliary-syntax syntax-unquote-splicing)\n\n(define-macro let\n (l", +"ambda (form env)\n (if (variable? (cadr form))\n (list\n (list th", +"e-lambda '()\n (list the-define (cadr form)\n (c", +"ons the-lambda\n (cons (map car (car (cddr form)))\n ", +" (cdr (cddr form)))))\n (cons (cadr for", +"m) (map cadr (car (cddr form))))))\n (cons\n (cons\n the-la", +"mbda\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 (nu", +"ll? (cdr form))\n #t\n (if (null? (cddr form))\n (cadr for", +"m)\n (list the-if\n (cadr form)\n (con", +"s (the 'and) (cddr form))\n #f)))))\n\n(define-macro or\n (lambda ", +"(form env)\n (if (null? (cdr form))\n #f\n (let ((tmp (make-identi", +"fier '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-macr", +"o cond\n (lambda (form env)\n (let ((clauses (cdr form)))\n (if (null? cla", +"uses)\n #undefined\n (let ((clause (car clauses)))\n (", +"if (and (variable? (car clause))\n (variable=? (the 'else) (m", +"ake-identifier (car clause) env)))\n (cons the-begin (cdr clause))", +"\n (if (and (variable? (cadr clause))\n (va", +"riable=? (the '=>) (make-identifier (cadr clause) env)))\n (le", +"t ((tmp (make-identifier 'tmp here)))\n (list (the 'let) (li", +"st (list tmp (car clause)))\n (list 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 (cdr clause))\n ", +" (cons (the 'cond) (cdr clauses))))))))))\n\n(define-macro quasiquo", +"te\n (lambda (form env)\n\n (define (quasiquote? form)\n (and (pair? form)\n", +" (variable? (car form))\n (variable=? (the 'quasiquote) (make", +"-identifier (car form) env))))\n\n (define (unquote? form)\n (and (pair? fo", +"rm)\n (variable? (car form))\n (variable=? (the 'unquote) (mak", +"e-identifier (car form) env))))\n\n (define (unquote-splicing? form)\n (and", +" (pair? form)\n (pair? (car form))\n (variable? (caar form))\n ", +" (variable=? (the 'unquote-splicing) (make-identifier (caar form) env))", +"))\n\n (define (qq depth expr)\n (cond\n ;; unquote\n ((unquote? ", +"expr)\n (if (= depth 1)\n (car (cdr expr))\n (list (th", +"e 'list)\n (list (the 'quote) (the 'unquote))\n ", +"(qq (- depth 1) (car (cdr expr))))))\n ;; unquote-splicing\n ((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 'quote) (the 'unquote-splicing))\n (qq (- ", +"depth 1) (car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ", +" ;; quasiquote\n ((quasiquote? expr)\n (list (the 'list)\n ", +" (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) (car (c", +"dr expr)))))\n ;; list\n ((pair? expr)\n (list (the 'cons)\n ", +" (qq depth (car expr))\n (qq depth (cdr expr))))\n ;; v", +"ector\n ((vector? expr)\n (list (the 'list->vector) (qq depth (vector", +"->list expr))))\n ;; simple datum\n (else\n (list (the 'quote) e", +"xpr))))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n(define-macro let*\n (lam", +"bda (form env)\n (let ((bindings (car (cdr form)))\n (body (cdr (c", +"dr form))))\n (if (null? bindings)\n `(,(the 'let) () ,@body)\n ", +" `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))\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 b", +"indings)))\n (initials (map (lambda (v) `(,(the 'set!) ,@v)) bindings", +")))\n `(,(the 'let) (,@variables)\n ,@initials\n ,@body)))", +"))\n\n(define-macro let-values\n (lambda (form env)\n `(,(the 'let*-values) ,@(c", +"dr form))))\n\n(define-macro let*-values\n (lambda (form env)\n (let ((formal (c", +"ar (cdr form)))\n (body (cdr (cdr form))))\n (if (null? formal)\n ", +" `(,(the 'let) () ,@body)\n `(,(the 'call-with-values) (,the-lamb", +"da () ,@(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 ((arguments (make-identifier", +" 'arguments here)))\n `(,the-begin\n ,@(let loop ((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 () ,@body)\n (,the", +"-lambda\n ,arguments\n ,@(let loop ((formal formal) (args ar", +"guments))\n (if (pair? formal)\n `((,the-set! ,(", +"car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args)))\n ", +" (if (variable? formal)\n `((,the-set! ,fo", +"rmal ,args))\n '()))))))))))\n\n(define-macro do\n (lambda (", +"form env)\n (let ((bindings (car (cdr form)))\n (test (car (car (c", +"dr (cdr form)))))\n (cleanup (cdr (car (cdr (cdr form)))))\n (b", +"ody (cdr (cdr (cdr form)))))\n (let ((loop (make-identifier 'loop here))", +")\n `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindings)", +"\n (,the-if ,test\n (,the-begin\n ,@c", +"leanup)\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 (form env)\n (let ((te", +"st (car (cdr form)))\n (body (cdr (cdr form))))\n `(,the-if ,test\n ", +" (,the-begin ,@body)\n #undefined))))\n\n(define-macro ", +"unless\n (lambda (form env)\n (let ((test (car (cdr form)))\n (body (c", +"dr (cdr form))))\n `(,the-if ,test\n #undefined\n ", +" (,the-begin ,@body)))))\n\n(define-macro case\n (lambda (form env)\n (let ((ke", +"y (car (cdr form)))\n (clauses (cdr (cdr form))))\n (let ((the-k", +"ey (make-identifier 'key here)))\n `(,(the 'let) ((,the-key ,key))\n ", +" ,(let loop ((clauses clauses))\n (if (null? clauses)\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 ", -" (cons the-begin (cdr clause))\n (if (and (variable? (cadr cl", -"ause))\n (variable=? (the '=>) (make-identifier (cadr c", -"lause) env)))\n (let ((tmp (make-identifier 'tmp here)))\n ", -" (list (the 'let) (list (list tmp (car clause)))\n ", -" (list the-if tmp\n (list (c", -"ar (cddr clause)) tmp)\n (cons (the 'cond) (cd", -"r clauses)))))\n (list the-if (car clause)\n ", -" (cons the-begin (cdr 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 (varia", -"ble? (car form))\n (variable=? (the 'quasiquote) (make-identifier (ca", -"r form) env))))\n\n (define (unquote? form)\n (and (pair? form)\n ", -" (variable? (car form))\n (variable=? (the 'unquote) (make-ident", -"ifier (car form) env))))\n\n (define (unquote-splicing? form)\n (and (p", -"air? form)\n (pair? (car form))\n (variable? (caar form))\n", -" (variable=? (the 'unquote-splicing) (make-identifier (caar form) en", -"v))))\n\n (define (qq depth expr)\n (cond\n ;; unquote\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-sp", -"licing\n ((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 'quote) (the 'unquote-spl", -"icing))\n (qq (- depth 1) (car (cdr (car expr)))))\n ", -" (qq depth (cdr expr)))))\n ;; quasiquote\n ((quasiq", -"uote? expr)\n (list (the 'list)\n (list (the 'quote) (the ", -"'quasiquote))\n (qq (+ depth 1) (car (cdr expr)))))\n ;; li", -"st\n ((pair? expr)\n (list (the 'cons)\n (qq depth ", -"(car expr))\n (qq depth (cdr expr))))\n ;; vector\n ", -"((vector? expr)\n (list (the 'list->vector) (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 (define-macro let*\n (", -"lambda (form env)\n (let ((bindings (car (cdr form)))\n (body ", -"(cdr (cdr form))))\n (if (null? bindings)\n `(,(the 'let) () ,@b", -"ody)\n `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))\n", -" (,(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n (d", -"efine-macro letrec\n (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form)))", -")\n\n (define-macro letrec*\n (lambda (form env)\n (let ((bindings (car (cd", -"r form)))\n (body (cdr (cdr form))))\n (let ((variables (map", -" (lambda (v) `(,v #f)) (map car bindings)))\n (initials (map (lambd", -"a (v) `(,(the 'set!) ,@v)) bindings)))\n `(,(the 'let) (,@variables)\n ", -" ,@initials\n ,@body)))))\n\n (define-macro let-values\n (lam", -"bda (form env)\n `(,(the '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-with-values) (,the-lambda () ,@(cdr (car f", -"ormal)))\n (,(the 'lambda) (,@(car (car formal)))\n (,(", -"the 'let*-values) (,@(cdr formal))\n ,@body)))))))\n\n (define-macr", -"o define-values\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", -" (body (cdr (cdr form))))\n (let ((arguments (make-identifier 'a", -"rguments here)))\n `(,the-begin\n ,@(let loop ((formal formal)", -")\n (if (pair? formal)\n `((,the-define ,(car fo", -"rmal) #undefined) ,@(loop (cdr formal)))\n (if (variable? form", -"al)\n `((,the-define ,formal #undefined))\n ", -" '())))\n (,(the 'call-with-values) (,the-lambda () ,@body)\n ", -" (,the-lambda\n ,arguments\n ,@(let loop ((form", -"al formal) (args arguments))\n (if (pair? formal)\n ", -" `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,", -"(the '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 (cd", -"r (car (cdr (cdr form)))))\n (body (cdr (cdr (cdr form)))))\n ", -" (let ((loop (make-identifier '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 ", -" #undefined))))\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", -" #undefined\n (,the-begin ,@body)))))\n\n (defin", -"e-macro case\n (lambda (form env)\n (let ((key (car (cdr form)))\n ", -" (clauses (cdr (cdr form))))\n (let ((the-key (make-identifier 'key ", -"here)))\n `(,(the 'let) ((,the-key ,key))\n ,(let loop ((claus", -"es clauses))\n (if (null? clauses)\n #undefined\n ", -" (let ((clause (car clauses)))\n `(,the-if ,(", -"if (and (variable? (car clause))\n (varia", -"ble=? (the 'else) (make-identifier (car clause) env)))\n ", -" #t\n `(,(the 'or) ,@(map (lambda (x", -") `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))\n ", -" ,(if (and (variable? (cadr clause))\n ", -" (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ", -" `(,(car (cdr (cdr clause))) ,the-key)\n ", -" `(,the-begin ,@(cdr clause)))\n ,", -"(loop (cdr clauses)))))))))))\n\n (define-macro parameterize\n (lambda (form en", -"v)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n", -" `(,(the 'with-parameter)\n (,(the 'lambda) ()\n ,@forma", -"l\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 (re", -"name var))))))\n (walk (lambda (f form)\n (cond\n ", -" ((variable? form)\n (f form))\n ", -" ((pair? form)\n `(,(the 'cons) (walk f (car fo", -"rm)) (walk f (cdr form))))\n ((vector? form)\n ", -" `(,(the 'list->vector) (walk f (vector->list form))))\n ", -" (else\n `(,(the 'quote) ,form))))))\n (let ((fo", -"rm (walk rename (cadr form))))\n `(,(the 'let)\n ,(map cdr", -" renames)\n ,form))))))\n\n (define-macro syntax-quasiquote\n (lamb", -"da (form env)\n (let ((renames '()))\n (letrec\n ((rename (l", -"ambda (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\n (define (syntax-quasiquote? form)\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 ", -" (variable? (caar form))\n (variable=? (the 'syntax-unqu", -"ote-splicing) (make-identifier (caar form) env))))\n\n (define (qq depth ", -"expr)\n (cond\n ;; syntax-unquote\n ((syntax-unq", -"uote? expr)\n (if (= depth 1)\n (car (cdr expr))\n ", -" (list (the 'list)\n (list (the 'quote) (the", -" 'syntax-unquote))\n (qq (- depth 1) (car (cdr expr))))))\n", -" ;; syntax-unquote-splicing\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 'quote) (the 'syntax-unquote-spli", -"cing))\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 (+ de", -"pth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\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 'quo", -"te) expr))))\n\n (let ((body (qq 1 (cadr form))))\n `(,(the 'le", -"t)\n ,(map cdr renames)\n ,body))))))\n\n (define (transf", -"ormer f)\n (lambda (form env)\n (let ((register1 (make-register))\n ", -" (register2 (make-register)))\n (letrec\n ((wrap (lambda (var", -"1)\n (let ((var2 (register1 var1)))\n (i", -"f (undefined? var2)\n (let ((var2 (make-identifier var1", -" env)))\n (register1 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 ((var", -"iable? 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 (vec", -"tor->list form))))\n (else\n form)))))\n", -" (let ((form (cdr form)))\n (walk unwrap (apply f (walk wrap ", -"form))))))))\n\n (define-macro define-syntax\n (lambda (form env)\n (let ((", -"formal (car (cdr form)))\n (body (cdr (cdr form))))\n (if (pai", -"r? 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 ,@(map (lambda (x)\n `(,(the 'define-sy", -"ntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n\n (d", -"efine-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@(c", -"dr form))))\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 ", -" define-syntax\n syntax-quote syntax-unquote\n syntax-quasiquo", -"te syntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-e", -"rror))\n\n", +" #t\n `(,(the 'or) ,@(map (la", +"mbda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))\n ", +" ,(if (and (variable? (cadr clause))\n ", +" (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ", +" `(,(car (cdr (cdr clause))) ,the-key)\n ", +" `(,the-begin ,@(cdr clause)))\n ,(lo", +"op (cdr clauses)))))))))))\n\n(define-macro parameterize\n (lambda (form env)\n ", +"(let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(,(t", +"he 'with-parameter)\n (,(the 'lambda) ()\n ,@formal\n ,@body", +")))))\n\n(define-macro syntax-quote\n (lambda (form env)\n (let ((renames '()))\n", +" (letrec\n ((rename (lambda (var)\n (let ((x (as", +"sq var renames)))\n (if x\n (cadr ", +"x)\n (begin\n (set! renames ", +"`((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,ren", +"ames))\n (rename var))))))\n (walk (lambda (", +"f form)\n (cond\n ((variable? form)\n ", +" (f form))\n ((pair? form)\n `(,", +"(the 'cons) (walk f (car form)) (walk f (cdr form))))\n ((vect", +"or? 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-macro syntax-quasiquote\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 (beg", +"in\n (set! renames `((,var ,(make-identifier var env)", +" (,(the 'make-identifier) ',var ',env)) . ,renames))\n ", +" (rename var)))))))\n\n (define (syntax-quasiquote? form)\n (and (", +"pair? form)\n (variable? (car form))\n (variable=? (th", +"e 'syntax-quasiquote) (make-identifier (car form) env))))\n\n (define (synt", +"ax-unquote? form)\n (and (pair? form)\n (variable? (car for", +"m))\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 (variable? (caar form))\n ", +" (variable=? (the 'syntax-unquote-splicing) (make-identifier (caar ", +"form) env))))\n\n (define (qq depth expr)\n (cond\n ;; syn", +"tax-unquote\n ((syntax-unquote? expr)\n (if (= depth 1)\n ", +" (car (cdr expr))\n (list (the 'list)\n ", +" (list (the 'quote) (the 'syntax-unquote))\n (qq (- depth", +" 1) (car (cdr expr))))))\n ;; syntax-unquote-splicing\n ((synt", +"ax-unquote-splicing? expr)\n (if (= depth 1)\n (list (th", +"e 'append)\n (car (cdr (car expr)))\n (q", +"q depth (cdr expr)))\n (list (the 'cons)\n (li", +"st (the 'list)\n (list (the 'quote) (the 'syntax-unquo", +"te-splicing))\n (qq (- depth 1) (car (cdr (car expr)))", +"))\n (qq depth (cdr expr)))))\n ;; syntax-quasiquot", +"e\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? expr)\n (lis", +"t (the 'cons)\n (qq depth (car expr))\n (qq dept", +"h (cdr expr))))\n ;; vector\n ((vector? expr)\n (lis", +"t (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 ,(map cdr renames)\n ", +" ,body))))))\n\n(define (transformer f)\n (lambda (form env)\n (let ((regi", +"ster1 (make-register))\n (register2 (make-register)))\n (letrec\n ", +" ((wrap (lambda (var1)\n (let ((var2 (register1 var1)))\n ", +" (if (undefined? var2)\n (let ((var2 (m", +"ake-identifier var1 env)))\n (register1 var1 var2)\n ", +" (register2 var2 var1)\n var2)\n ", +" var2))))\n (unwrap (lambda (var2)\n ", +" (let ((var1 (register2 var2)))\n (if (undefined? var", +"1)\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 form))))))))\n\n(define-m", +"acro define-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", +" (body (cdr (cdr form))))\n (if (pair? formal)\n `(,(the 'def", +"ine-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body))\n `(,the-d", +"efine-macro ,formal (,(the 'transformer) (,the-begin ,@body)))))))\n\n(define-macr", +"o letrec-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", +" (body (cdr (cdr form))))\n `(let ()\n ,@(map (lambda (x)\n ", +" `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n formal)\n", +" ,@body))))\n\n(define-macro let-syntax\n (lambda (form env)\n `(,(the '", +"letrec-syntax) ,@(cdr form))))\n\n(export let let* letrec letrec*\n let-valu", +"es let*-values define-values\n quasiquote unquote unquote-splicing\n ", +" and or\n cond case else =>\n do when unless\n parameterize\n ", +" define-syntax\n syntax-quote syntax-unquote\n syntax-quasiquot", +"e syntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-error)", +"\n\n(define-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-lib", +"rary old-library))))))\n\n(define-macro cond-expand\n (lambda (form _)\n (letrec", +"\n ((test (lambda (form)\n (or\n (eq? form ", +"'else)\n (and (symbol? form)\n (memq form (", +"features)))\n (and (pair? form)\n (case (ca", +"r form)\n ((library) (find-library (cadr form)))\n ", +" ((not) (not (test (cadr form))))\n ((and", +") (let loop ((form (cdr form)))\n (or (null? for", +"m)\n (and (test (car form)) (loop (cdr form)", +")))))\n ((or) (let loop ((form (cdr form)))\n ", +" (and (pair? form)\n (or ", +"(test (car form)) (loop (cdr form))))))\n (else #f)))))))", +"\n (let loop ((clauses (cdr form)))\n (if (null? clauses)\n ", +"#undefined\n (if (test (caar clauses))\n `(,the-begin ,@", +"(cdar clauses))\n (loop (cdr clauses))))))))\n\n(export define-libra", +"ry\n cond-expand)\n\n", "", "" }; diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index 893cc36e..fc866aa4 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -188,70 +188,6 @@ pic_export(pic_state *pic, pic_sym *sym) export(pic, pic_obj_value(sym)); } -static bool -condexpand(pic_state *pic, pic_value clause) -{ - pic_sym *tag; - pic_value c, feature, it; - - if (pic_eq_p(clause, pic_obj_value(pic->sELSE))) { - return true; - } - if (pic_sym_p(clause)) { - pic_for_each (feature, pic->features, it) { - if(pic_eq_p(feature, clause)) - return true; - } - return false; - } - - if (! (pic_pair_p(clause) && pic_sym_p(pic_car(pic, clause)))) { - pic_errorf(pic, "invalid 'cond-expand' clause ~s", clause); - } else { - tag = pic_sym_ptr(pic_car(pic, clause)); - } - - 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->sBEGIN), pic_cdr(pic, clauses[i])); - } - } - - return pic_undef_value(); -} - static pic_value pic_lib_import(pic_state *pic) { @@ -282,36 +218,6 @@ pic_lib_export(pic_state *pic) return pic_undef_value(); } -static pic_value -pic_lib_define_library(pic_state *pic) -{ - struct pic_lib *lib, *prev = pic->lib; - size_t argc, i; - pic_value spec, *argv; - - pic_get_args(pic, "o*", &spec, &argc, &argv); - - if ((lib = pic_find_library(pic, spec)) == NULL) { - lib = pic_make_library(pic, spec); - } - - pic_try { - pic->lib = lib; - - for (i = 0; i < argc; ++i) { - pic_void(pic_eval(pic, argv[i], pic->lib->env)); - } - - 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(); -} - static pic_value pic_lib_make_library(pic_state *pic) { @@ -403,10 +309,8 @@ pic_init_lib(pic_state *pic) { void pic_defmacro(pic_state *, pic_sym *, pic_sym *, pic_func_t); - pic_defmacro(pic, pic->sCOND_EXPAND, pic->uCOND_EXPAND, pic_lib_condexpand); pic_defmacro(pic, pic->sIMPORT, pic->uIMPORT, pic_lib_import); pic_defmacro(pic, pic->sEXPORT, pic->uEXPORT, pic_lib_export); - pic_defmacro(pic, pic->sDEFINE_LIBRARY, pic->uDEFINE_LIBRARY, pic_lib_define_library); pic_defun(pic, "make-library", pic_lib_make_library); pic_defun(pic, "find-library", pic_lib_find_library); From 52b03d928cd201d5c9da5cf22e3c2e0c6c7574c1 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Jun 2015 00:59:19 +0900 Subject: [PATCH 042/125] define import in scheme --- extlib/benz/boot.c | 85 ++++++++++++++++++++++++++++++++++++++++++++-- extlib/benz/lib.c | 49 +++++++++++++++++--------- 2 files changed, 115 insertions(+), 19 deletions(-) diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index 2bb39ea8..9fc3cbfa 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -492,8 +492,61 @@ my $src = <<'EOL'; `(,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))))))) + (export define-library - cond-expand) + cond-expand + import) EOL @@ -757,8 +810,34 @@ const char pic_boot[][80] = { "(test (car form)) (loop (cdr form))))))\n (else #f)))))))", "\n (let loop ((clauses (cdr form)))\n (if (null? clauses)\n ", "#undefined\n (if (test (caar clauses))\n `(,the-begin ,@", -"(cdar clauses))\n (loop (cdr clauses))))))))\n\n(export define-libra", -"ry\n cond-expand)\n\n", +"(cdar clauses))\n (loop (cdr clauses))))))))\n\n(define-macro import", +"\n (lambda (form _)\n (let ((caddr\n (lambda (x) (car (cdr (cdr x))))", +")\n (prefix\n (lambda (prefix symbol)\n (string->sym", +"bol\n (string-append\n (symbol->string prefix)\n ", +" (symbol->string symbol))))))\n (letrec\n ((extract\n ", +" (lambda (spec)\n (case (car spec)\n ((only rename pr", +"efix 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 ((r", +"ename)\n (let ((alist (collect (cadr spec))))\n ", +"(map (lambda (s) (or (assq (car s) (cddr spec)) s)) alist)))\n ((p", +"refix)\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 s", +"pec))\n (loop (cdr alist))\n ", +" (cons (car alist) (loop (cdr alist))))))))\n (else\n ", +" (let ((lib (or (find-library spec) (error \"library not found\" spec))))\n ", +" (map (lambda (x) (cons x x)) (library-exports lib))))))))\n ", +" (letrec\n ((import\n (lambda (spec)\n (le", +"t ((lib (extract spec))\n (alist (collect spec)))\n ", +" (for-each\n (lambda (slot)\n (li", +"brary-import lib (cdr slot) (car slot)))\n alist)))))\n ", +" (for-each import (cdr form)))))))\n\n(export define-library\n cond-expand\n", +" import)\n\n", "", "" }; diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index fc866aa4..cf225211 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -188,21 +188,6 @@ pic_export(pic_state *pic, pic_sym *sym) export(pic, pic_obj_value(sym)); } -static pic_value -pic_lib_import(pic_state *pic) -{ - size_t argc, i; - pic_value *argv; - - pic_get_args(pic, "*", &argc, &argv); - - for (i = 0; i < argc; ++i) { - import(pic, argv[i]); - } - - return pic_undef_value(); -} - static pic_value pic_lib_export(pic_state *pic) { @@ -262,6 +247,38 @@ pic_lib_current_library(pic_state *pic) } } +static pic_value +pic_lib_library_import(pic_state *pic) +{ + pic_value lib_opt; + pic_sym *name, *realname, *uid, *alias = NULL; + struct pic_lib *lib; + + pic_get_args(pic, "om|m", &lib_opt, &name, &alias); + + pic_assert_type(pic, lib_opt, lib); + + if (alias == NULL) { + alias = name; + } + + 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 { + realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, name)); + } + + 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_library_name(pic_state *pic) { @@ -309,12 +326,12 @@ pic_init_lib(pic_state *pic) { void pic_defmacro(pic_state *, pic_sym *, pic_sym *, pic_func_t); - pic_defmacro(pic, pic->sIMPORT, pic->uIMPORT, pic_lib_import); pic_defmacro(pic, pic->sEXPORT, pic->uEXPORT, pic_lib_export); pic_defun(pic, "make-library", pic_lib_make_library); pic_defun(pic, "find-library", pic_lib_find_library); pic_defun(pic, "current-library", pic_lib_current_library); + pic_defun(pic, "library-import", pic_lib_library_import); pic_defun(pic, "library-name", pic_lib_library_name); pic_defun(pic, "library-exports", pic_lib_library_exports); pic_defun(pic, "library-environment", pic_lib_library_environment); From 29a966d678613e79b491fbc89c328518dda35bb0 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Jun 2015 01:42:44 +0900 Subject: [PATCH 043/125] define export in scheme --- extlib/benz/boot.c | 158 +++++++++++++++++++++++++++------------------ extlib/benz/lib.c | 41 ++++++------ 2 files changed, 114 insertions(+), 85 deletions(-) diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index 9fc3cbfa..d24bcf40 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -442,18 +442,8 @@ my $src = <<'EOL'; (lambda (form env) `(,(the 'letrec-syntax) ,@(cdr form)))) -(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) + +;;; library primitives (define-macro define-library (lambda (form _) @@ -544,9 +534,42 @@ my $src = <<'EOL'; 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) + 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) + EOL @@ -787,57 +810,64 @@ const char pic_boot[][80] = { " (body (cdr (cdr form))))\n `(let ()\n ,@(map (lambda (x)\n ", " `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n formal)\n", " ,@body))))\n\n(define-macro let-syntax\n (lambda (form env)\n `(,(the '", -"letrec-syntax) ,@(cdr form))))\n\n(export let let* letrec letrec*\n let-valu", -"es let*-values define-values\n quasiquote unquote unquote-splicing\n ", -" and or\n cond case else =>\n do when unless\n parameterize\n ", -" define-syntax\n syntax-quote syntax-unquote\n syntax-quasiquot", -"e syntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-error)", -"\n\n(define-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-lib", -"rary old-library))))))\n\n(define-macro cond-expand\n (lambda (form _)\n (letrec", -"\n ((test (lambda (form)\n (or\n (eq? form ", -"'else)\n (and (symbol? form)\n (memq form (", -"features)))\n (and (pair? form)\n (case (ca", -"r form)\n ((library) (find-library (cadr form)))\n ", -" ((not) (not (test (cadr form))))\n ((and", -") (let loop ((form (cdr form)))\n (or (null? for", -"m)\n (and (test (car form)) (loop (cdr form)", -")))))\n ((or) (let loop ((form (cdr form)))\n ", -" (and (pair? form)\n (or ", -"(test (car form)) (loop (cdr form))))))\n (else #f)))))))", -"\n (let loop ((clauses (cdr form)))\n (if (null? clauses)\n ", -"#undefined\n (if (test (caar clauses))\n `(,the-begin ,@", -"(cdar clauses))\n (loop (cdr clauses))))))))\n\n(define-macro import", -"\n (lambda (form _)\n (let ((caddr\n (lambda (x) (car (cdr (cdr x))))", -")\n (prefix\n (lambda (prefix symbol)\n (string->sym", -"bol\n (string-append\n (symbol->string prefix)\n ", -" (symbol->string symbol))))))\n (letrec\n ((extract\n ", -" (lambda (spec)\n (case (car spec)\n ((only rename pr", -"efix 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 ((r", -"ename)\n (let ((alist (collect (cadr spec))))\n ", -"(map (lambda (s) (or (assq (car s) (cddr spec)) s)) alist)))\n ((p", -"refix)\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 s", -"pec))\n (loop (cdr alist))\n ", -" (cons (car alist) (loop (cdr alist))))))))\n (else\n ", -" (let ((lib (or (find-library spec) (error \"library not found\" spec))))\n ", -" (map (lambda (x) (cons x x)) (library-exports lib))))))))\n ", -" (letrec\n ((import\n (lambda (spec)\n (le", -"t ((lib (extract spec))\n (alist (collect spec)))\n ", -" (for-each\n (lambda (slot)\n (li", -"brary-import lib (cdr slot) (car slot)))\n alist)))))\n ", -" (for-each import (cdr form)))))))\n\n(export define-library\n cond-expand\n", -" import)\n\n", +"letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(define-macro define-li", +"brary\n (lambda (form _)\n (let ((name (cadr form))\n (body (cddr form", +")))\n (let ((old-library (current-library))\n (new-library (or (fi", +"nd-library name) (make-library name))))\n (let ((env (library-environment ", +"new-library)))\n (current-library new-library)\n (for-each (lamb", +"da (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 'else)\n ", +"(and (symbol? form)\n (memq form (features)))\n ", +" (and (pair? form)\n (case (car form)\n ", +" ((library) (find-library (cadr form)))\n ((not) (", +"not (test (cadr form))))\n ((and) (let loop ((form (cdr f", +"orm)))\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 (test (car form)) (loop (", +"cdr form))))))\n (else #f)))))))\n (let loop ((clause", +"s (cdr form)))\n (if (null? clauses)\n #undefined\n (i", +"f (test (caar clauses))\n `(,the-begin ,@(cdar clauses))\n ", +" (loop (cdr clauses))))))))\n\n(define-macro import\n (lambda (form _)\n (", +"let ((caddr\n (lambda (x) (car (cdr (cdr x)))))\n (prefix\n ", +" (lambda (prefix symbol)\n (string->symbol\n (string", +"-append\n (symbol->string prefix)\n (symbol->string sy", +"mbol))))))\n (letrec\n ((extract\n (lambda (spec)\n ", +" (case (car spec)\n ((only rename prefix except)\n ", +" (extract (cadr spec)))\n (else\n (or (find-lib", +"rary 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 (va", +"r) (assq var alist)) (cddr spec))))\n ((rename)\n (", +"let ((alist (collect (cadr spec))))\n (map (lambda (s) (or (ass", +"q (car s) (cddr spec)) s)) alist)))\n ((prefix)\n (", +"let ((alist (collect (cadr spec))))\n (map (lambda (s) (cons (p", +"refix (caddr spec) (car s)) (cdr s))) alist)))\n ((except)\n ", +" (let ((alist (collect (cadr spec))))\n (let loop ((al", +"ist alist))\n (if (null? alist)\n '()\n", +" (if (memq (caar alist) (cddr spec))\n ", +" (loop (cdr alist))\n (cons (car alist) (loo", +"p (cdr alist))))))))\n (else\n (let ((lib (or (find", +"-library spec) (error \"library not found\" spec))))\n (map (lamb", +"da (x) (cons x x)) (library-exports lib))))))))\n (letrec\n ((im", +"port\n (lambda (spec)\n (let ((lib (extract spec))\n ", +" (alist (collect spec)))\n (for-each\n ", +" (lambda (slot)\n (library-import lib (cdr slo", +"t) (car slot)))\n alist)))))\n (for-each import (cdr f", +"orm)))))))\n\n(define-macro export\n (lambda (form _)\n (letrec\n ((collec", +"t\n (lambda (spec)\n (cond\n ((symbol? spec)\n ", +" `(,spec . ,spec))\n ((and (list? spec) (= (length spec) 3) (e", +"q? (car spec) 'rename))\n `(,(list-ref spec 1) . ,(list-ref spec 2))", +")\n (else\n (error \"malformed export\")))))\n (expo", +"rt\n (lambda (spec)\n (let ((slot (collect spec)))\n ", +" (library-export (car slot) (cdr slot))))))\n (for-each export (cdr for", +"m)))))\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 els", +"e =>\n do when unless\n parameterize\n define-syntax\n s", +"yntax-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/lib.c b/extlib/benz/lib.c index cf225211..81c98472 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -188,21 +188,6 @@ pic_export(pic_state *pic, pic_sym *sym) export(pic, pic_obj_value(sym)); } -static pic_value -pic_lib_export(pic_state *pic) -{ - size_t argc, i; - pic_value *argv; - - pic_get_args(pic, "*", &argc, &argv); - - for (i = 0; i < argc; ++i) { - export(pic, argv[i]); - } - - return pic_undef_value(); -} - static pic_value pic_lib_make_library(pic_state *pic) { @@ -279,6 +264,22 @@ pic_lib_library_import(pic_state *pic) return pic_undef_value(); } +static pic_value +pic_lib_library_export(pic_state *pic) +{ + pic_sym *name, *alias = NULL; + + pic_get_args(pic, "m|m", &name, &alias); + + 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_library_name(pic_state *pic) { @@ -324,15 +325,13 @@ pic_lib_library_environment(pic_state *pic) void pic_init_lib(pic_state *pic) { - void pic_defmacro(pic_state *, pic_sym *, pic_sym *, pic_func_t); - - pic_defmacro(pic, pic->sEXPORT, pic->uEXPORT, pic_lib_export); - pic_defun(pic, "make-library", pic_lib_make_library); pic_defun(pic, "find-library", pic_lib_find_library); - pic_defun(pic, "current-library", pic_lib_current_library); - pic_defun(pic, "library-import", pic_lib_library_import); pic_defun(pic, "library-name", pic_lib_library_name); pic_defun(pic, "library-exports", pic_lib_library_exports); pic_defun(pic, "library-environment", pic_lib_library_environment); + + 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); } From 1d1210db09056514baf142d4fb0735030217e08b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Jun 2015 01:52:20 +0900 Subject: [PATCH 044/125] cleanup lib.c --- extlib/benz/include/picrin.h | 3 +- extlib/benz/lib.c | 130 +++-------------------------------- extlib/benz/state.c | 2 +- 3 files changed, 11 insertions(+), 124 deletions(-) diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index f6fb2800..a063fa68 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -233,8 +233,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 *); diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index 81c98472..7ffa66fe 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -54,138 +54,26 @@ 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; + xh_entry *it; - table = pic_make_dict(pic); - - 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, *uid; - - realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, nick)); + pic_dict_for_each (name, lib->exports, it) { + realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, name)); 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(uid)); + 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_variable(pic, pic->lib->env, pic_obj_value(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); -} - -void -pic_import_library(pic_state *pic, struct pic_lib *lib) -{ - import(pic, lib->name); -} - -void -pic_export(pic_state *pic, pic_sym *sym) -{ - export(pic, pic_obj_value(sym)); + pic_dict_set(pic, pic->lib->exports, name, pic_obj_value(name)); } static pic_value diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 39b506ce..6e11f812 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -148,7 +148,7 @@ 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 * From 0fe4df3c15a1edc455b0d3a2c7605cbffcf3ea25 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Jun 2015 02:58:37 +0900 Subject: [PATCH 045/125] [bugfix] repl broken --- contrib/20.repl/repl.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/contrib/20.repl/repl.scm b/contrib/20.repl/repl.scm index ad1c2e19..920b3566 100644 --- a/contrib/20.repl/repl.scm +++ b/contrib/20.repl/repl.scm @@ -19,6 +19,8 @@ (define (add-history str) #f)))) + (define user-env (library-environment (find-library '(picrin user)))) + (eval '(import (scheme base) (scheme load) @@ -33,7 +35,7 @@ (picrin macro) (picrin array) (picrin library)) - (library-environment (find-library '(picrin user)))) + user-env) (define (repl) (let loop ((buf "")) @@ -63,7 +65,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)))))))))) From 61ff69b9688d059318a3086780faef4924732fbc Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 18 Jun 2015 22:59:22 +0900 Subject: [PATCH 046/125] remove pic->xSTDXX --- extlib/benz/gc.c | 11 ----------- extlib/benz/include/picrin.h | 5 +---- extlib/benz/port.c | 10 +++++++--- extlib/benz/state.c | 10 ---------- 4 files changed, 8 insertions(+), 28 deletions(-) diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index 5ed749b7..59ea6850 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -617,17 +617,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); diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index a063fa68..73504f87 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -143,12 +143,9 @@ 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; @@ -257,7 +254,7 @@ 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 diff --git a/extlib/benz/port.c b/extlib/benz/port.c index 5b04f89b..9100be4a 100644 --- a/extlib/benz/port.c +++ b/extlib/benz/port.c @@ -773,9 +773,13 @@ pic_port_flush(pic_state *pic) 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); + struct pic_port *xSTDIN = pic_make_standard_port(pic, xstdin, PIC_PORT_IN); + struct pic_port *xSTDOUT = pic_make_standard_port(pic, xstdout, PIC_PORT_OUT); + struct pic_port *xSTDERR = pic_make_standard_port(pic, xstderr, PIC_PORT_OUT); + + pic_defvar(pic, "current-input-port", pic_obj_value(xSTDIN), NULL); + pic_defvar(pic, "current-output-port", pic_obj_value(xSTDOUT), NULL); + pic_defvar(pic, "current-error-port", pic_obj_value(xSTDERR), NULL); pic_defun(pic, "call-with-port", pic_port_call_with_port); diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 6e11f812..64b58b25 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -254,11 +254,6 @@ 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; - /* parameter table */ pic->ptable = pic_nil_value(); @@ -372,11 +367,6 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) /* 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); - /* parameter table */ pic->ptable = pic_cons(pic, pic_obj_value(pic_make_dict(pic)), pic->ptable); From b4c3e2cc4f652715528be2cde1ad96646c753ac5 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 18 Jun 2015 23:15:09 +0900 Subject: [PATCH 047/125] small refactoring. use DEFINE_STANDARD_PORT_ACCESSOR macro to define pic_stdxx --- extlib/benz/include/picrin.h | 4 ++++ extlib/benz/port.c | 41 ++++++++++++------------------------ extlib/benz/vm.c | 6 ++++++ 3 files changed, 23 insertions(+), 28 deletions(-) diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index 73504f87..d0dedfa5 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -201,6 +201,10 @@ 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); +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_ref(pic_state *, struct pic_lib *, const char *); void pic_set(pic_state *, struct pic_lib *, const char *, pic_value); diff --git a/extlib/benz/port.c b/extlib/benz/port.c index 9100be4a..51fc5439 100644 --- a/extlib/benz/port.c +++ b/extlib/benz/port.c @@ -14,35 +14,20 @@ pic_eof_object() return v; } -struct pic_port * -pic_stdin(pic_state *pic) -{ - pic_value obj; +#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); \ + } - obj = pic_funcall(pic, pic->PICRIN_BASE, "current-input-port", pic_nil_value()); - - return pic_port_ptr(obj); -} - -struct pic_port * -pic_stdout(pic_state *pic) -{ - pic_value obj; - - obj = pic_funcall(pic, pic->PICRIN_BASE, "current-output-port", pic_nil_value()); - - return pic_port_ptr(obj); -} - -struct pic_port * -pic_stderr(pic_state *pic) -{ - pic_value obj; - - obj = pic_funcall(pic, pic->PICRIN_BASE, "current-error-port", pic_nil_value()); - - 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 pic_port * pic_make_standard_port(pic_state *pic, xFILE *file, short dir) diff --git a/extlib/benz/vm.c b/extlib/benz/vm.c index 791529d0..2f56467f 100644 --- a/extlib/benz/vm.c +++ b/extlib/benz/vm.c @@ -467,6 +467,12 @@ pic_funcall(pic_state *pic, struct pic_lib *lib, const char *name, pic_list args 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()); +} + void pic_defun(pic_state *pic, const char *name, pic_func_t cfunc) { From 0b66447e795c645df8a3386e5f595a91180a0d7f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 18 Jun 2015 23:26:31 +0900 Subject: [PATCH 048/125] remove port->status property --- contrib/05.r7rs/src/file.c | 3 +- contrib/05.r7rs/src/load.c | 3 +- extlib/benz/include/picrin/port.h | 9 +---- extlib/benz/port.c | 66 +++++++++++++------------------ 4 files changed, 32 insertions(+), 49 deletions(-) diff --git a/contrib/05.r7rs/src/file.c b/contrib/05.r7rs/src/file.c index ce9cb1b2..36e50e86 100644 --- a/contrib/05.r7rs/src/file.c +++ b/contrib/05.r7rs/src/file.c @@ -27,8 +27,7 @@ generic_open_file(pic_state *pic, const char *fname, char *mode, short flags) 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; + port->flags = flags | PIC_PORT_OPEN; return pic_obj_value(port); } diff --git a/contrib/05.r7rs/src/load.c b/contrib/05.r7rs/src/load.c index c887a1b2..385767d8 100644 --- a/contrib/05.r7rs/src/load.c +++ b/contrib/05.r7rs/src/load.c @@ -17,8 +17,7 @@ pic_load(pic_state *pic, const char *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->flags = PIC_PORT_IN | PIC_PORT_TEXT | PIC_PORT_OPEN; pic_load_port(pic, port); diff --git a/extlib/benz/include/picrin/port.h b/extlib/benz/include/picrin/port.h index 98dcff83..dfb664e6 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) diff --git a/extlib/benz/port.c b/extlib/benz/port.c index 51fc5439..a562b9f6 100644 --- a/extlib/benz/port.c +++ b/extlib/benz/port.c @@ -36,8 +36,7 @@ pic_make_standard_port(pic_state *pic, xFILE *file, short dir) 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; + port->flags = dir | PIC_PORT_TEXT | PIC_PORT_OPEN; return port; } @@ -140,8 +139,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; } @@ -153,8 +151,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; } @@ -181,7 +178,7 @@ pic_close_port(pic_state *pic, struct pic_port *port) if (xfclose(port->file) == EOF) { pic_errorf(pic, "close-port: failure"); } - port->status = PIC_PORT_CLOSE; + port->flags &= ~PIC_PORT_OPEN; } static pic_value @@ -300,7 +297,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 @@ -315,7 +312,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: \ @@ -332,13 +329,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) @@ -374,7 +366,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)); } @@ -389,8 +381,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); } @@ -404,8 +395,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); } @@ -419,7 +409,7 @@ 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"); @@ -443,7 +433,7 @@ 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) { return pic_eof_object(); @@ -461,7 +451,7 @@ 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) { return pic_eof_object(); @@ -481,7 +471,7 @@ pic_port_read_line(pic_state *pic) 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') { @@ -502,7 +492,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); @@ -518,7 +508,7 @@ pic_port_read_string(pic_state *pic){ 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); @@ -545,7 +535,7 @@ 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"); + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, "read-u8"); if ((c = xfgetc(port->file)) == EOF) { return pic_eof_object(); } @@ -561,7 +551,7 @@ 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); if (c == EOF) { @@ -580,7 +570,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 */ } @@ -595,7 +585,7 @@ 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); @@ -629,7 +619,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"); @@ -657,7 +647,7 @@ 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); return pic_undef_value(); @@ -671,7 +661,7 @@ 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); return pic_undef_value(); @@ -694,7 +684,7 @@ 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); @@ -710,7 +700,7 @@ 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); return pic_undef_value(); @@ -734,7 +724,7 @@ 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); @@ -749,7 +739,7 @@ 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); return pic_undef_value(); From f2e6feea7f60515fe6a25fb9a7e014043feb0e5b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 19 Jun 2015 00:02:24 +0900 Subject: [PATCH 049/125] assert value bound to current-(input|output|error)-port is port --- extlib/benz/port.c | 45 +++++++++++++++++++++++++++------------------ 1 file changed, 27 insertions(+), 18 deletions(-) diff --git a/extlib/benz/port.c b/extlib/benz/port.c index a562b9f6..c73cabd5 100644 --- a/extlib/benz/port.c +++ b/extlib/benz/port.c @@ -14,6 +14,30 @@ pic_eof_object() return v; } +static pic_value +pic_assert_port(pic_state *pic) +{ + struct pic_port *port; + + pic_get_args(pic, "p", &port); + + return pic_obj_value(port); +} + +/* current-(input|output|error)-port */ + +static void +pic_define_standard_port(pic_state *pic, const char *name, xFILE *file, int dir) +{ + struct pic_port *port; + + port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); + port->file = file; + port->flags = dir | PIC_PORT_TEXT | PIC_PORT_OPEN; + + pic_defvar(pic, name, pic_obj_value(port), pic_make_proc(pic, pic_assert_port, "pic_assert_port")); +} + #define DEFINE_STANDARD_PORT_ACCESSOR(name, var) \ struct pic_port * \ name(pic_state *pic) \ @@ -29,17 +53,6 @@ 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 pic_port * -pic_make_standard_port(pic_state *pic, xFILE *file, short dir) -{ - struct pic_port *port; - - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); - port->file = file; - port->flags = dir | PIC_PORT_TEXT | PIC_PORT_OPEN; - return port; -} - struct strfile { pic_state *pic; char *buf; @@ -748,13 +761,9 @@ pic_port_flush(pic_state *pic) void pic_init_port(pic_state *pic) { - struct pic_port *xSTDIN = pic_make_standard_port(pic, xstdin, PIC_PORT_IN); - struct pic_port *xSTDOUT = pic_make_standard_port(pic, xstdout, PIC_PORT_OUT); - struct pic_port *xSTDERR = pic_make_standard_port(pic, xstderr, PIC_PORT_OUT); - - pic_defvar(pic, "current-input-port", pic_obj_value(xSTDIN), NULL); - pic_defvar(pic, "current-output-port", pic_obj_value(xSTDOUT), NULL); - pic_defvar(pic, "current-error-port", pic_obj_value(xSTDERR), NULL); + 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); From d1aa42cd7aa4c3277bf95f84e6f9c4a436bef1cf Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 19 Jun 2015 01:04:04 +0900 Subject: [PATCH 050/125] [bugfix] double close should be safe --- extlib/benz/port.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extlib/benz/port.c b/extlib/benz/port.c index c73cabd5..5eed06cc 100644 --- a/extlib/benz/port.c +++ b/extlib/benz/port.c @@ -188,6 +188,9 @@ pic_get_output_string(pic_state *pic, struct pic_port *port) void pic_close_port(pic_state *pic, struct pic_port *port) { + if ((port->flags & PIC_PORT_OPEN) == 0) { + return; + } if (xfclose(port->file) == EOF) { pic_errorf(pic, "close-port: failure"); } From 2e59b6ab0423dfa0c65fab85a31bd7a1c6996c69 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 19 Jun 2015 01:11:04 +0900 Subject: [PATCH 051/125] rename xfile.[ch] to file.[ch] --- extlib/benz/{xfile.c => file.c} | 0 extlib/benz/include/picrin.h | 2 +- extlib/benz/include/picrin/{xfile.h => file.h} | 0 3 files changed, 1 insertion(+), 1 deletion(-) rename extlib/benz/{xfile.c => file.c} (100%) rename extlib/benz/include/picrin/{xfile.h => file.h} (100%) diff --git a/extlib/benz/xfile.c b/extlib/benz/file.c similarity index 100% rename from extlib/benz/xfile.c rename to extlib/benz/file.c diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index d0dedfa5..6bda3be1 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -42,7 +42,7 @@ extern "C" { #include "picrin/xvect.h" #include "picrin/xhash.h" -#include "picrin/xfile.h" +#include "picrin/file.h" #include "picrin/value.h" diff --git a/extlib/benz/include/picrin/xfile.h b/extlib/benz/include/picrin/file.h similarity index 100% rename from extlib/benz/include/picrin/xfile.h rename to extlib/benz/include/picrin/file.h From 3df7d1dd710f1626d5693bc5b9faac9d26d704dc Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 19 Jun 2015 02:05:56 +0900 Subject: [PATCH 052/125] use pic_malloc and pic_free in file.c --- extlib/benz/debug.c | 10 +- extlib/benz/error.c | 2 +- extlib/benz/file.c | 114 ++++++++++----------- extlib/benz/include/picrin.h | 5 +- extlib/benz/include/picrin/file.h | 58 +++++------ extlib/benz/number.c | 2 +- extlib/benz/port.c | 38 +++---- extlib/benz/read.c | 164 +++++++++++++++--------------- extlib/benz/state.c | 2 +- extlib/benz/string.c | 22 ++-- extlib/benz/write.c | 109 ++++++++++---------- 11 files changed, 261 insertions(+), 265 deletions(-) diff --git a/extlib/benz/debug.c b/extlib/benz/debug.c index d61e9380..55b652c2 100644 --- a/extlib/benz/debug.c +++ b/extlib/benz/debug.c @@ -38,7 +38,7 @@ 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; @@ -46,14 +46,14 @@ pic_print_backtrace(pic_state *pic, xFILE *file) 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"); + xfprintf(pic, file, "\n"); /* TODO: print error irritants */ - xfputs(pic_str_cstr(pic, e->stack), file); + xfputs(pic, pic_str_cstr(pic, e->stack), file); } } 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/file.c b/extlib/benz/file.c index b28bf060..7a4908f3 100644 --- a/extlib/benz/file.c +++ b/extlib/benz/file.c @@ -93,18 +93,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); + pic_free(pic, fp->base); return fp->vtable.close(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 +109,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; } @@ -138,8 +135,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 +143,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 { @@ -190,7 +186,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 +194,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 ((x_iob[i].flag & X_WRITE) && (xfflush(pic, &x_iob[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 +244,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 +283,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 +294,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 +306,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 +316,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,10 +326,10 @@ 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; @@ -344,36 +340,36 @@ long xfseek(xFILE *fp, long offset, int whence) { 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 +391,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 +408,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 +416,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/include/picrin.h b/extlib/benz/include/picrin.h index 6bda3be1..8eb641fe 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -42,7 +42,6 @@ extern "C" { #include "picrin/xvect.h" #include "picrin/xhash.h" -#include "picrin/file.h" #include "picrin/value.h" @@ -72,6 +71,8 @@ typedef struct { typedef void *(*pic_allocf)(void *, size_t); +typedef struct xFILE xFILE; + typedef struct { int argc; char **argv, **envp; @@ -254,6 +255,7 @@ 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 *); @@ -281,6 +283,7 @@ pic_value pic_fdisplay(pic_state *, pic_value, xFILE *); #include "picrin/read.h" #include "picrin/vector.h" #include "picrin/reg.h" +#include "picrin/file.h" #if defined(__cplusplus) } diff --git a/extlib/benz/include/picrin/file.h b/extlib/benz/include/picrin/file.h index eff7d269..189bd3de 100644 --- a/extlib/benz/include/picrin/file.h +++ b/extlib/benz/include/picrin/file.h @@ -1,5 +1,5 @@ -#ifndef XFILE_H -#define XFILE_H +#ifndef PICRIN_FILE_H +#define PICRIN_FILE_H #if defined(__cplusplus) extern "C" { @@ -7,10 +7,6 @@ extern "C" { #include -#ifndef NULL -# define NULL 0 -#endif - #ifndef EOF # define EOF (-1) #endif @@ -18,7 +14,7 @@ extern "C" { #define XBUFSIZ 1024 #define XOPEN_MAX 1024 -typedef struct { +struct xFILE { /* buffer */ char buf[1]; /* fallback buffer */ long cnt; /* characters left */ @@ -33,7 +29,7 @@ typedef struct { int (*close)(void *); } vtable; int flag; /* mode of the file access */ -} xFILE; +}; extern xFILE x_iob[XOPEN_MAX]; @@ -55,30 +51,30 @@ enum _flags { #define xferror(p) (((p)->flag & X_ERR) != 0) #define xfileno(p) ((p)->fd) -#define xgetc(p) \ +#define xgetc(pic, p) \ ((--(p)->cnt >= 0) \ ? (unsigned char) *(p)->ptr++ \ - : x_fillbuf(p)) -#define xputc(x, p) \ + : x_fillbuf((pic), p)) +#define xputc(pic, 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) + : x_flushbuf((pic), (x), (p))) +#define xgetchar(pic) xgetc((pic), xstdin) +#define xputchar(pic, x) xputc((pic), (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 *); +int xfclose(pic_state *, xFILE *); /* buffer management */ -int x_fillbuf(xFILE *); -int x_flushbuf(int, xFILE *); -int xfflush(xFILE *); +int x_fillbuf(pic_state *, xFILE *); +int x_flushbuf(pic_state *, int, xFILE *); +int xfflush(pic_state *, xFILE *); /* direct IO */ -size_t xfread(void *, size_t, size_t, xFILE *); -size_t xfwrite(const void *, size_t, size_t, xFILE *); +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, @@ -87,22 +83,22 @@ enum { }; /* indicator positioning */ -long xfseek(xFILE *, long, int); -long xftell(xFILE *); -void xrewind(xFILE *); +long xfseek(pic_state *, xFILE *, long, int); +long xftell(pic_state *, xFILE *); +void xrewind(pic_state *, 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 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(const char *, ...); -int xfprintf(xFILE *, const char *, ...); -int xvfprintf(xFILE *, const char *, va_list); +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) } diff --git a/extlib/benz/number.c b/extlib/benz/number.c index a0cf35ba..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); diff --git a/extlib/benz/port.c b/extlib/benz/port.c index 5eed06cc..8a0d7df4 100644 --- a/extlib/benz/port.c +++ b/extlib/benz/port.c @@ -178,7 +178,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; @@ -191,7 +191,7 @@ pic_close_port(pic_state *pic, struct pic_port *port) if ((port->flags & PIC_PORT_OPEN) == 0) { return; } - if (xfclose(port->file) == EOF) { + if (xfclose(pic, port->file) == EOF) { pic_errorf(pic, "close-port: failure"); } port->flags &= ~PIC_PORT_OPEN; @@ -431,7 +431,7 @@ pic_port_get_output_bytevector(pic_state *pic) 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; @@ -451,7 +451,7 @@ pic_port_read_char(pic_state *pic) 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 { @@ -469,7 +469,7 @@ pic_port_peek_char(pic_state *pic) 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 { @@ -490,8 +490,8 @@ pic_port_read_line(pic_state *pic) 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); @@ -529,10 +529,10 @@ pic_port_read_string(pic_state *pic){ 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); @@ -552,7 +552,7 @@ pic_port_read_byte(pic_state *pic){ pic_get_args(pic, "|p", &port); assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, "read-u8"); - if ((c = xfgetc(port->file)) == EOF) { + if ((c = xfgetc(pic, port->file)) == EOF) { return pic_eof_object(); } @@ -569,7 +569,7 @@ pic_port_peek_byte(pic_state *pic) 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(); } @@ -605,7 +605,7 @@ pic_port_read_blob(pic_state *pic) 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 +644,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); @@ -665,7 +665,7 @@ pic_port_newline(pic_state *pic) assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, "newline"); - xfputs("\n", port->file); + xfputs(pic, "\n", port->file); return pic_undef_value(); } @@ -679,7 +679,7 @@ pic_port_write_char(pic_state *pic) 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(); } @@ -703,7 +703,7 @@ pic_port_write_string(pic_state *pic) 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(); } @@ -718,7 +718,7 @@ pic_port_write_byte(pic_state *pic) 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(); } @@ -743,7 +743,7 @@ pic_port_write_blob(pic_state *pic) 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(); } @@ -757,7 +757,7 @@ pic_port_flush(pic_state *pic) assert_port_profile(port, PIC_PORT_OUT, "flush-output-port"); - xfflush(port->file); + xfflush(pic, port->file); return pic_undef_value(); } diff --git a/extlib/benz/read.c b/extlib/benz/read.c index 6dbea00a..45325ebf 100644 --- a/extlib/benz/read.c +++ b/extlib/benz/read.c @@ -18,39 +18,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; @@ -89,7 +89,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 +101,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 +120,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,15 +128,15 @@ 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")) { + 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")) { + if (expect(pic, port, "fold-case")) { pic->reader->typecase = PIC_CASE_FOLD; return pic_invalid_value(); } @@ -149,13 +149,13 @@ read_directive(pic_state *pic, struct pic_port *port, int c) 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 @@ -163,23 +163,23 @@ 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(port))); + 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(port))); + return pic_list2(pic, pic_obj_value(pic->sSYNTAX_QUASIQUOTE), read(pic, port, next(pic, port))); } static pic_value @@ -187,11 +187,11 @@ read_syntax_unquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) { pic_sym *tag = pic->sSYNTAX_UNQUOTE; - if (peek(port) == '@') { + if (peek(pic, port) == '@') { tag = pic->sSYNTAX_UNQUOTE_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 @@ -206,8 +206,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); @@ -230,8 +230,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; @@ -242,19 +242,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); } @@ -271,13 +271,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); @@ -348,8 +348,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); @@ -370,8 +370,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); @@ -390,8 +390,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)) { @@ -404,8 +404,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)) { @@ -418,29 +418,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; } } @@ -463,9 +463,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; @@ -498,9 +498,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; @@ -508,7 +508,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 ';'"); } @@ -539,7 +539,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'; } @@ -553,8 +553,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"); @@ -562,7 +562,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); @@ -577,8 +577,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(); @@ -597,16 +597,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; } @@ -642,7 +642,7 @@ read_label_set(pic_state *pic, struct pic_port *port, int i) pic_value val; int c; - switch ((c = skip(port, ' '))) { + switch ((c = skip(pic, port, ' '))) { case '(': { pic_value tmp; @@ -661,7 +661,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; @@ -714,7 +714,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); @@ -734,7 +734,7 @@ 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"); @@ -750,7 +750,7 @@ read_dispatch(pic_state *pic, struct pic_port *port, int 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"); @@ -772,7 +772,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; } @@ -860,10 +860,10 @@ 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(); @@ -872,7 +872,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; } diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 64b58b25..7a355e47 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -437,7 +437,7 @@ pic_close(pic_state *pic) pic_gc_run(pic); /* flush all xfiles */ - xfflush(NULL); + xfflush(pic, NULL); /* free heaps */ pic_heap_close(pic, pic->heap); 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/write.c b/extlib/benz/write.c index 374d54e2..e98e027c 100644 --- a/extlib/benz/write.c +++ b/extlib/benz/write.c @@ -111,6 +111,7 @@ static void write_core(struct writer_control *p, pic_value); static void write_pair(struct writer_control *p, struct pic_pair *pair) { + pic_state *pic = p->pic; xh_entry *e; int c; @@ -123,27 +124,27 @@ write_pair(struct writer_control *p, struct pic_pair *pair) /* shared objects */ if ((e = xh_get_ptr(&p->labels, pic_obj_ptr(pair->cdr))) && xh_val(e, int) != -1) { - xfprintf(p->file, " . "); + xfprintf(pic, p->file, " . "); if ((xh_get_ptr(&p->visited, pic_obj_ptr(pair->cdr)))) { - xfprintf(p->file, "#%d#", xh_val(e, int)); + xfprintf(pic, p->file, "#%d#", xh_val(e, int)); return; } else { - xfprintf(p->file, "#%d=", xh_val(e, int)); + xfprintf(pic, p->file, "#%d=", xh_val(e, int)); c = 1; xh_put_ptr(&p->visited, pic_obj_ptr(pair->cdr), &c); } } else { - xfprintf(p->file, " "); + xfprintf(pic, p->file, " "); } write_pair(p, pic_pair_ptr(pair->cdr)); return; } else { - xfprintf(p->file, " . "); + xfprintf(pic, p->file, " . "); write_core(p, pair->cdr); } } @@ -156,9 +157,9 @@ write_str(pic_state *pic, struct pic_string *str, xFILE *file) for (i = 0; i < pic_str_len(str); ++i) { if (cstr[i] == '"' || cstr[i] == '\\') { - xfputc('\\', file); + xfputc(pic, '\\', file); } - xfputc(cstr[i], file); + xfputc(pic, cstr[i], file); } } @@ -179,11 +180,11 @@ write_core(struct writer_control *p, pic_value obj) && (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)); + xfprintf(pic, file, "#%d#", xh_val(e, int)); return; } else { - xfprintf(file, "#%d=", xh_val(e, int)); + xfprintf(pic, file, "#%d=", xh_val(e, int)); c = 1; xh_put_ptr(&p->visited, pic_obj_ptr(obj), &c); } @@ -191,122 +192,122 @@ write_core(struct writer_control *p, pic_value obj) 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"); + xfprintf(pic, file, "#t"); else - xfprintf(file, "#f"); + xfprintf(pic, file, "#f"); break; case PIC_TT_PAIR: if (is_quote(pic, obj)) { - xfprintf(file, "'"); + xfprintf(pic, file, "'"); write_core(p, pic_list_ref(pic, obj, 1)); break; } else if (is_unquote(pic, obj)) { - xfprintf(file, ","); + xfprintf(pic, file, ","); write_core(p, pic_list_ref(pic, obj, 1)); break; } else if (is_unquote_splicing(pic, obj)) { - xfprintf(file, ",@"); + xfprintf(pic, file, ",@"); write_core(p, pic_list_ref(pic, obj, 1)); break; } else if (is_quasiquote(pic, obj)) { - xfprintf(file, "`"); + xfprintf(pic, file, "`"); write_core(p, pic_list_ref(pic, obj, 1)); break; } - xfprintf(file, "("); + xfprintf(pic, file, "("); write_pair(p, pic_pair_ptr(obj)); - xfprintf(file, ")"); + xfprintf(pic, file, ")"); break; case PIC_TT_SYMBOL: - xfprintf(file, "%s", pic_symbol_name(pic, pic_sym_ptr(obj))); + xfprintf(pic, file, "%s", pic_symbol_name(pic, pic_sym_ptr(obj))); break; case PIC_TT_CHAR: if (p->mode == DISPLAY_MODE) { - xfputc(pic_char(obj), file); + xfputc(pic, 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; + default: xfprintf(pic, file, "#\\%c", pic_char(obj)); 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; } break; #if PIC_ENABLE_FLOAT case PIC_TT_FLOAT: f = pic_float(obj); if (isnan(f)) { - xfprintf(file, signbit(f) ? "-nan.0" : "+nan.0"); + xfprintf(pic, file, signbit(f) ? "-nan.0" : "+nan.0"); } else if (isinf(f)) { - xfprintf(file, signbit(f) ? "-inf.0" : "+inf.0"); + xfprintf(pic, file, signbit(f) ? "-inf.0" : "+inf.0"); } else { - xfprintf(file, "%f", pic_float(obj)); + xfprintf(pic, file, "%f", pic_float(obj)); } break; #endif case PIC_TT_INT: - xfprintf(file, "%d", pic_int(obj)); + xfprintf(pic, file, "%d", pic_int(obj)); break; case PIC_TT_EOF: - xfprintf(file, "#.(eof-object)"); + xfprintf(pic, file, "#.(eof-object)"); break; case PIC_TT_STRING: if (p->mode == DISPLAY_MODE) { - xfprintf(file, "%s", pic_str_cstr(pic, pic_str_ptr(obj))); + xfprintf(pic, file, "%s", pic_str_cstr(pic, pic_str_ptr(obj))); break; } - xfprintf(file, "\""); + xfprintf(pic, file, "\""); write_str(pic, pic_str_ptr(obj), file); - xfprintf(file, "\""); + xfprintf(pic, file, "\""); break; case PIC_TT_VECTOR: - xfprintf(file, "#("); + xfprintf(pic, 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(pic, file, " "); } } - xfprintf(file, ")"); + xfprintf(pic, file, ")"); break; case PIC_TT_BLOB: - xfprintf(file, "#u8("); + xfprintf(pic, file, "#u8("); for (i = 0; i < pic_blob_ptr(obj)->len; ++i) { - xfprintf(file, "%d", pic_blob_ptr(obj)->data[i]); + xfprintf(pic, file, "%d", pic_blob_ptr(obj)->data[i]); if (i + 1 < pic_blob_ptr(obj)->len) { - xfprintf(file, " "); + xfprintf(pic, file, " "); } } - xfprintf(file, ")"); + xfprintf(pic, file, ")"); break; case PIC_TT_DICT: - xfprintf(file, "#.(dictionary"); + xfprintf(pic, 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 *))); + xfprintf(pic, file, " '%s ", pic_symbol_name(pic, xh_key(it, pic_sym *))); write_core(p, xh_val(it, pic_value)); } - xfprintf(file, ")"); + xfprintf(pic, file, ")"); break; case PIC_TT_ID: - xfprintf(file, "#", pic_symbol_name(pic, pic_var_name(pic, obj))); + xfprintf(pic, file, "#", pic_symbol_name(pic, pic_var_name(pic, 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; } } @@ -377,7 +378,7 @@ pic_value pic_fwrite(pic_state *pic, pic_value obj, xFILE *file) { write(pic, obj, file); - xfflush(file); + xfflush(pic, file); return obj; } @@ -391,7 +392,7 @@ pic_value pic_fdisplay(pic_state *pic, pic_value obj, xFILE *file) { display(pic, obj, file); - xfflush(file); + xfflush(pic, file); return obj; } @@ -408,8 +409,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 From e43a9c78818a64ca08504ff232891a1eab92e5e6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 19 Jun 2015 02:29:17 +0900 Subject: [PATCH 053/125] pass pic_state object to vtable functions --- extlib/benz/file.c | 24 ++++++++++++++---------- extlib/benz/include/picrin/file.h | 10 +++++----- extlib/benz/port.c | 18 ++++++++---------- 3 files changed, 27 insertions(+), 25 deletions(-) diff --git a/extlib/benz/file.c b/extlib/benz/file.c index 7a4908f3..23a78f45 100644 --- a/extlib/benz/file.c +++ b/extlib/benz/file.c @@ -1,6 +1,7 @@ #include "picrin.h" -static int file_read(void *cookie, char *ptr, int size) { +static int +file_read(pic_state PIC_UNUSED(*pic), void *cookie, char *ptr, int size) { FILE *file = cookie; int r; @@ -16,7 +17,8 @@ static int file_read(void *cookie, char *ptr, int size) { return r; } -static int file_write(void *cookie, const char *ptr, int size) { +static int +file_write(pic_state PIC_UNUSED(*pic), void *cookie, const char *ptr, int size) { FILE *file = cookie; int r; @@ -28,7 +30,8 @@ static int file_write(void *cookie, const char *ptr, int size) { return r; } -static long file_seek(void *cookie, long pos, int whence) { +static long +file_seek(pic_state PIC_UNUSED(*pic), void *cookie, long pos, int whence) { switch (whence) { case XSEEK_CUR: whence = SEEK_CUR; @@ -43,7 +46,8 @@ static long file_seek(void *cookie, long pos, int whence) { return fseek(cookie, pos, whence); } -static int file_close(void *cookie) { +static int +file_close(pic_state PIC_UNUSED(*pic), void *cookie) { return fclose(cookie); } @@ -70,7 +74,7 @@ xFILE x_iob[XOPEN_MAX] = { { { 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(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++) @@ -98,7 +102,7 @@ int xfclose(pic_state *pic, xFILE *fp) { fp->flag = 0; if (fp->base != fp->buf) pic_free(pic, fp->base); - return fp->vtable.close(fp->vtable.cookie); + return fp->vtable.close(pic, fp->vtable.cookie); } int x_fillbuf(pic_state *pic, xFILE *fp) { @@ -121,7 +125,7 @@ int x_fillbuf(pic_state *pic, 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) @@ -157,7 +161,7 @@ int x_flushbuf(pic_state *pic, 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 */ @@ -168,7 +172,7 @@ int x_flushbuf(pic_state *pic, 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; @@ -334,7 +338,7 @@ long xfseek(pic_state *pic, xFILE *fp, long offset, int whence) { 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; diff --git a/extlib/benz/include/picrin/file.h b/extlib/benz/include/picrin/file.h index 189bd3de..2b761184 100644 --- a/extlib/benz/include/picrin/file.h +++ b/extlib/benz/include/picrin/file.h @@ -23,10 +23,10 @@ struct xFILE { /* operators */ struct { void *cookie; - int (*read)(void *, char *, int); - int (*write)(void *, const char *, int); - long (*seek)(void *, long, int); - int (*close)(void *); + 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 */ }; @@ -63,7 +63,7 @@ enum _flags { #define xputchar(pic, x) xputc((pic), (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 *xfunopen(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 *xfopen(const char *, const char *); int xfclose(pic_state *, xFILE *); diff --git a/extlib/benz/port.c b/extlib/benz/port.c index 8a0d7df4..867626f8 100644 --- a/extlib/benz/port.c +++ b/extlib/benz/port.c @@ -54,13 +54,12 @@ 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; @@ -72,13 +71,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; @@ -88,7 +87,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; @@ -108,12 +107,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; } @@ -124,7 +123,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; @@ -139,7 +137,7 @@ string_open(pic_state *pic, const char *data, size_t size) } 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; From 78bd3047f80efecc45fef791930c768d6d516938 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 19 Jun 2015 03:06:57 +0900 Subject: [PATCH 054/125] don't use global mutable variable! --- contrib/05.r7rs/src/file.c | 2 +- contrib/05.r7rs/src/load.c | 2 +- extlib/benz/file.c | 16 ++++++++-------- extlib/benz/include/picrin.h | 11 ++++++----- extlib/benz/include/picrin/file.h | 16 ++++++++-------- extlib/benz/port.c | 4 ++-- extlib/benz/state.c | 6 ++++++ 7 files changed, 32 insertions(+), 25 deletions(-) diff --git a/contrib/05.r7rs/src/file.c b/contrib/05.r7rs/src/file.c index 36e50e86..c354c179 100644 --- a/contrib/05.r7rs/src/file.c +++ b/contrib/05.r7rs/src/file.c @@ -20,7 +20,7 @@ generic_open_file(pic_state *pic, const char *fname, char *mode, short flags) struct pic_port *port; xFILE *file; - file = xfopen(fname, mode); + file = xfopen(pic, fname, mode); if (! file) { file_error(pic, "could not open file"); } diff --git a/contrib/05.r7rs/src/load.c b/contrib/05.r7rs/src/load.c index 385767d8..8f519327 100644 --- a/contrib/05.r7rs/src/load.c +++ b/contrib/05.r7rs/src/load.c @@ -10,7 +10,7 @@ pic_load(pic_state *pic, const char *filename) struct pic_port *port; xFILE *file; - file = xfopen(filename, "r"); + file = xfopen(pic, filename, "r"); if (file == NULL) { pic_errorf(pic, "could not open file: %s", filename); } diff --git a/extlib/benz/file.c b/extlib/benz/file.c index 23a78f45..146f63e6 100644 --- a/extlib/benz/file.c +++ b/extlib/benz/file.c @@ -51,7 +51,7 @@ file_close(pic_state PIC_UNUSED(*pic), void *cookie) { return fclose(cookie); } -xFILE *xfopen(const char *name, const char *mode) { +xFILE *xfopen(pic_state *pic, const char *name, const char *mode) { FILE *fp; if ((fp = fopen(name, mode)) == NULL) { @@ -60,28 +60,28 @@ xFILE *xfopen(const char *name, const char *mode) { switch (*mode) { case 'r': - return xfunopen(fp, file_read, NULL, file_seek, file_close); + return xfunopen(pic, fp, file_read, NULL, file_seek, file_close); default: - return xfunopen(fp, NULL, file_write, file_seek, file_close); + return xfunopen(pic, 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] = { +const 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)(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 *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; @@ -198,7 +198,7 @@ int xfflush(pic_state *pic, xFILE *f) { if (f == NULL) { /* flush all output streams */ for (i = 0; i < XOPEN_MAX; i++) { - if ((x_iob[i].flag & X_WRITE) && (xfflush(pic, &x_iob[i]) == -1)) + if ((pic->files[i].flag & X_WRITE) && (xfflush(pic, &pic->files[i]) == -1)) retval = -1; } } else { diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index 8eb641fe..f250305a 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -46,6 +46,9 @@ extern "C" { #include "picrin/value.h" typedef struct pic_code pic_code; +typedef struct pic_state pic_state; + +#include "picrin/file.h" typedef struct pic_jmpbuf { PIC_JMPBUF buf; @@ -71,9 +74,7 @@ typedef struct { typedef void *(*pic_allocf)(void *, size_t); -typedef struct xFILE xFILE; - -typedef struct { +struct pic_state { int argc; char **argv, **envp; @@ -137,6 +138,7 @@ typedef struct { struct pic_reg *attrs; struct pic_reader *reader; + xFILE files[XOPEN_MAX]; bool gc_enable; struct pic_heap *heap; @@ -148,7 +150,7 @@ typedef struct { pic_code *iseq; /* for pic_apply_trampoline */ char *native_stack_start; -} pic_state; +}; typedef pic_value (*pic_func_t)(pic_state *); @@ -283,7 +285,6 @@ pic_value pic_fdisplay(pic_state *, pic_value, xFILE *); #include "picrin/read.h" #include "picrin/vector.h" #include "picrin/reg.h" -#include "picrin/file.h" #if defined(__cplusplus) } diff --git a/extlib/benz/include/picrin/file.h b/extlib/benz/include/picrin/file.h index 2b761184..22af7f8e 100644 --- a/extlib/benz/include/picrin/file.h +++ b/extlib/benz/include/picrin/file.h @@ -14,7 +14,7 @@ extern "C" { #define XBUFSIZ 1024 #define XOPEN_MAX 1024 -struct xFILE { +typedef struct { /* buffer */ char buf[1]; /* fallback buffer */ long cnt; /* characters left */ @@ -29,13 +29,13 @@ struct xFILE { int (*close)(pic_state *, void *); } vtable; int flag; /* mode of the file access */ -}; +} xFILE; -extern xFILE x_iob[XOPEN_MAX]; +#define xstdin (&pic->files[0]) +#define xstdout (&pic->files[1]) +#define xstderr (&pic->files[2]) -#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]) +extern const xFILE x_iob[XOPEN_MAX]; enum _flags { X_READ = 01, @@ -63,8 +63,8 @@ enum _flags { #define xputchar(pic, x) xputc((pic), (x), xstdout) /* resource aquisition */ -xFILE *xfunopen(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 *xfopen(const char *, const char *); +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 *)); +xFILE *xfopen(pic_state *, const char *, const char *); int xfclose(pic_state *, xFILE *); /* buffer management */ diff --git a/extlib/benz/port.c b/extlib/benz/port.c index 867626f8..c14ce632 100644 --- a/extlib/benz/port.c +++ b/extlib/benz/port.c @@ -131,9 +131,9 @@ 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) { diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 7a355e47..fc0877ff 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -254,6 +254,12 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) /* raised error object */ pic->err = pic_invalid_value(); + /* file pool */ + memcpy(pic->files, x_iob, sizeof pic->files); + pic->files[0].vtable.cookie = stdin; + pic->files[1].vtable.cookie = stdout; + pic->files[2].vtable.cookie = stderr; + /* parameter table */ pic->ptable = pic_nil_value(); From db0767c93185024341654fa84f2581995d081cb9 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 19 Jun 2015 03:10:11 +0900 Subject: [PATCH 055/125] don't malloc pic->iseq --- extlib/benz/include/picrin.h | 5 ++--- extlib/benz/include/picrin/irep.h | 4 ++-- extlib/benz/state.c | 12 ------------ 3 files changed, 4 insertions(+), 17 deletions(-) diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index f250305a..fcafe4c2 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -45,9 +45,9 @@ extern "C" { #include "picrin/value.h" -typedef struct pic_code pic_code; typedef struct pic_state pic_state; +#include "picrin/irep.h" #include "picrin/file.h" typedef struct pic_jmpbuf { @@ -139,6 +139,7 @@ struct pic_state { struct pic_reader *reader; xFILE files[XOPEN_MAX]; + pic_code iseq[2]; /* for pic_apply_trampoline */ bool gc_enable; struct pic_heap *heap; @@ -148,7 +149,6 @@ struct pic_state { pic_value err; - pic_code *iseq; /* for pic_apply_trampoline */ char *native_stack_start; }; @@ -272,7 +272,6 @@ pic_value pic_fdisplay(pic_state *, pic_value, xFILE *); #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" diff --git a/extlib/benz/include/picrin/irep.h b/extlib/benz/include/picrin/irep.h index 319d1b31..a71d14f6 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; \ diff --git a/extlib/benz/state.c b/extlib/benz/state.c index fc0877ff..3f6f5ba9 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -216,13 +216,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); @@ -393,8 +386,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: @@ -456,9 +447,6 @@ pic_close(pic_state *pic) allocf(pic->cibase, 0); allocf(pic->xpbase, 0); - /* free trampoline iseq */ - allocf(pic->iseq, 0); - /* free global stacks */ xh_destroy(&pic->syms); From 10f81512d85b064579456187d98c5daf5a08d4d2 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 19 Jun 2015 03:14:55 +0900 Subject: [PATCH 056/125] don't malloc pic_reader --- extlib/benz/include/picrin.h | 5 ++-- extlib/benz/include/picrin/read.h | 8 +++--- extlib/benz/read.c | 47 ++++++++++++++----------------- extlib/benz/state.c | 4 +-- 4 files changed, 29 insertions(+), 35 deletions(-) diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index fcafe4c2..a95a6935 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -49,6 +49,7 @@ typedef struct pic_state pic_state; #include "picrin/irep.h" #include "picrin/file.h" +#include "picrin/read.h" typedef struct pic_jmpbuf { PIC_JMPBUF buf; @@ -137,7 +138,7 @@ struct pic_state { 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 */ @@ -277,11 +278,9 @@ pic_value pic_fdisplay(pic_state *, pic_value, xFILE *); #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/read.h b/extlib/benz/include/picrin/read.h index a3f01100..d9b0bb6e 100644 --- a/extlib/benz/include/picrin/read.h +++ b/extlib/benz/include/picrin/read.h @@ -11,7 +11,7 @@ extern "C" { 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 @@ -19,10 +19,10 @@ struct pic_reader { xhash 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/read.c b/extlib/benz/read.c index 45325ebf..bcadecaa 100644 --- a/extlib/benz/read.c +++ b/extlib/benz/read.c @@ -79,7 +79,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; @@ -131,13 +131,13 @@ read_directive(pic_state *pic, struct pic_port *port, int c) switch (peek(pic, port)) { case 'n': if (expect(pic, port, "no-fold-case")) { - pic->reader->typecase = PIC_CASE_DEFAULT; + pic->reader.typecase = PIC_CASE_DEFAULT; return pic_invalid_value(); } break; case 'f': if (expect(pic, port, "fold-case")) { - pic->reader->typecase = PIC_CASE_FOLD; + pic->reader.typecase = PIC_CASE_FOLD; return pic_invalid_value(); } break; @@ -649,7 +649,7 @@ read_label_set(pic_state *pic, struct pic_port *port, int i) val = pic_cons(pic, pic_undef_value(), pic_undef_value()); - xh_put_int(&pic->reader->labels, i, &val); + xh_put_int(&pic->reader.labels, i, &val); tmp = read(pic, port, c); pic_pair_ptr(val)->car = pic_car(pic, tmp); @@ -672,7 +672,7 @@ read_label_set(pic_state *pic, struct pic_port *port, int i) val = pic_obj_value(pic_make_vec(pic, 0)); - xh_put_int(&pic->reader->labels, i, &val); + xh_put_int(&pic->reader.labels, i, &val); tmp = pic_vec_ptr(read(pic, port, c)); PIC_SWAP(pic_value *, tmp->data, pic_vec_ptr(val)->data); @@ -687,7 +687,7 @@ read_label_set(pic_state *pic, struct pic_port *port, int i) { val = read(pic, port, c); - xh_put_int(&pic->reader->labels, i, &val); + xh_put_int(&pic->reader.labels, i, &val); return val; } @@ -699,7 +699,7 @@ read_label_ref(pic_state *pic, struct pic_port PIC_UNUSED(*port), int i) { xh_entry *e; - e = xh_get_int(&pic->reader->labels, i); + e = xh_get_int(&pic->reader.labels, i); if (! e) { read_error(pic, "label of given index not defined"); } @@ -740,11 +740,11 @@ read_dispatch(pic_state *pic, struct pic_port *port, int c) 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 @@ -756,11 +756,11 @@ read_nullable(pic_state *pic, struct pic_port *port, int c) 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 @@ -780,7 +780,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; @@ -826,34 +826,29 @@ 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; + xh_init_int(&pic->reader.labels, sizeof(pic_value)); 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); + xh_destroy(&pic->reader.labels); } pic_value diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 3f6f5ba9..6c9545fb 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -364,7 +364,7 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) pic->cp->in = pic->cp->out = NULL; /* reader */ - pic->reader = pic_reader_open(pic); + pic_reader_init(pic); /* parameter table */ pic->ptable = pic_cons(pic, pic_obj_value(pic_make_dict(pic)), pic->ptable); @@ -440,7 +440,7 @@ pic_close(pic_state *pic) 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); From 19c09ba6433c3026b63934259a005e1709b8dffb Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 19 Jun 2015 03:23:07 +0900 Subject: [PATCH 057/125] move contents of util.h to compat.h --- extlib/benz/include/picrin.h | 7 +-- extlib/benz/include/picrin/compat.h | 75 +++++++++++++++++++++++++ extlib/benz/include/picrin/util.h | 86 ----------------------------- 3 files changed, 76 insertions(+), 92 deletions(-) delete mode 100644 extlib/benz/include/picrin/util.h diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index a95a6935..0c2ef296 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -33,13 +33,8 @@ 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" diff --git a/extlib/benz/include/picrin/compat.h b/extlib/benz/include/picrin/compat.h index cca83d95..24f82691 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,10 @@ strcpy(char *dst, const char *src) #endif +#if PIC_ENABLE_FLOAT +# include +#endif + #if defined(__cplusplus) } #endif diff --git a/extlib/benz/include/picrin/util.h b/extlib/benz/include/picrin/util.h deleted file mode 100644 index ad816c70..00000000 --- a/extlib/benz/include/picrin/util.h +++ /dev/null @@ -1,86 +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 __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 defined(__cplusplus) -} -#endif - -#endif From 4bc765da653cccd1e90a1ca55a896f04c10af662 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 19 Jun 2015 03:27:03 +0900 Subject: [PATCH 058/125] move include of gc.h --- extlib/benz/include/picrin.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index 0c2ef296..5deca03e 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -45,6 +45,7 @@ typedef struct pic_state pic_state; #include "picrin/irep.h" #include "picrin/file.h" #include "picrin/read.h" +#include "picrin/gc.h" typedef struct pic_jmpbuf { PIC_JMPBUF buf; @@ -267,7 +268,6 @@ 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/lib.h" #include "picrin/macro.h" #include "picrin/pair.h" From cf037f27dbe0aee6dca12fbdef9a91ffc4dbc4a4 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 19 Jun 2015 03:31:24 +0900 Subject: [PATCH 059/125] remove library-name --- extlib/benz/lib.c | 13 ------------- piclib/picrin/base.scm | 1 - 2 files changed, 14 deletions(-) diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index 7ffa66fe..227eea7f 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -168,18 +168,6 @@ pic_lib_library_export(pic_state *pic) return pic_undef_value(); } -static pic_value -pic_lib_library_name(pic_state *pic) -{ - pic_value lib; - - pic_get_args(pic, "o", &lib); - - pic_assert_type(pic, lib, lib); - - return pic_lib_ptr(lib)->name; -} - static pic_value pic_lib_library_exports(pic_state *pic) { @@ -215,7 +203,6 @@ pic_init_lib(pic_state *pic) { pic_defun(pic, "make-library", pic_lib_make_library); pic_defun(pic, "find-library", pic_lib_find_library); - pic_defun(pic, "library-name", pic_lib_library_name); pic_defun(pic, "library-exports", pic_lib_library_exports); pic_defun(pic, "library-environment", pic_lib_library_environment); diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm index a9d6d7fa..f0d988a5 100644 --- a/piclib/picrin/base.scm +++ b/piclib/picrin/base.scm @@ -255,7 +255,6 @@ (export make-library find-library current-library - library-name library-exports library-environment) From a0d6c5800c2d37a68c322d8e856f42e606978692 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 19 Jun 2015 05:00:36 +0900 Subject: [PATCH 060/125] add pic_open_file --- contrib/05.r7rs/src/file.c | 26 ++------ contrib/05.r7rs/src/load.c | 10 +-- extlib/benz/file.c | 74 --------------------- extlib/benz/include/picrin/file.h | 1 - extlib/benz/include/picrin/port.h | 1 + extlib/benz/port.c | 103 ++++++++++++++++++++++++++++++ extlib/benz/state.c | 5 +- 7 files changed, 110 insertions(+), 110 deletions(-) diff --git a/contrib/05.r7rs/src/file.c b/contrib/05.r7rs/src/file.c index c354c179..ba68780c 100644 --- a/contrib/05.r7rs/src/file.c +++ b/contrib/05.r7rs/src/file.c @@ -14,24 +14,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(pic, 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 | PIC_PORT_OPEN; - - return pic_obj_value(port); -} - pic_value pic_file_open_input_file(pic_state *pic) { @@ -40,7 +22,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 @@ -51,7 +33,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 @@ -62,7 +44,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 @@ -73,7 +55,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/05.r7rs/src/load.c index 8f519327..f0d65b6e 100644 --- a/contrib/05.r7rs/src/load.c +++ b/contrib/05.r7rs/src/load.c @@ -8,16 +8,8 @@ void pic_load(pic_state *pic, const char *filename) { struct pic_port *port; - xFILE *file; - file = xfopen(pic, 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 | PIC_PORT_OPEN; + port = pic_open_file(pic, filename, PIC_PORT_IN | PIC_PORT_TEXT); pic_load_port(pic, port); diff --git a/extlib/benz/file.c b/extlib/benz/file.c index 146f63e6..2a8b2c18 100644 --- a/extlib/benz/file.c +++ b/extlib/benz/file.c @@ -1,79 +1,5 @@ #include "picrin.h" -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; - } - return fseek(cookie, pos, whence); -} - -static int -file_close(pic_state PIC_UNUSED(*pic), void *cookie) { - return fclose(cookie); -} - -xFILE *xfopen(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); - } -} - -#define FILE_VTABLE { 0, file_read, file_write, file_seek, file_close } - -const 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(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; diff --git a/extlib/benz/include/picrin/file.h b/extlib/benz/include/picrin/file.h index 22af7f8e..a38c6a25 100644 --- a/extlib/benz/include/picrin/file.h +++ b/extlib/benz/include/picrin/file.h @@ -64,7 +64,6 @@ enum _flags { /* 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 *)); -xFILE *xfopen(pic_state *, const char *, const char *); int xfclose(pic_state *, xFILE *); /* buffer management */ diff --git a/extlib/benz/include/picrin/port.h b/extlib/benz/include/picrin/port.h index dfb664e6..c806ba8e 100644 --- a/extlib/benz/include/picrin/port.h +++ b/extlib/benz/include/picrin/port.h @@ -32,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/port.c b/extlib/benz/port.c index c14ce632..5fadc5d7 100644 --- a/extlib/benz/port.c +++ b/extlib/benz/port.c @@ -26,6 +26,93 @@ pic_assert_port(pic_state *pic) /* current-(input|output|error)-port */ +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; + } + return fseek(cookie, pos, whence); +} + +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_open_file(pic_state *pic, const char *name, int flags) { + struct pic_port *port; + xFILE *file; + char mode = 'r'; + + if ((flags & PIC_PORT_IN) == 0) { + mode = 'w'; + } + if ((file = file_open(pic, name, &mode)) == NULL) { + pic_errorf(pic, "could not open file '%s'", name); + } + + port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); + port->file = file; + port->flags = flags | PIC_PORT_OPEN; + + return port; +} + static void pic_define_standard_port(pic_state *pic, const char *name, xFILE *file, int dir) { @@ -762,6 +849,22 @@ pic_port_flush(pic_state *pic) void pic_init_port(pic_state *pic) { +#define FILE_VTABLE { 0, file_read, file_write, file_seek, file_close } + + 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]; + + pic->files[0].vtable.cookie = stdin; + pic->files[1].vtable.cookie = stdout; + pic->files[2].vtable.cookie = stderr; + 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); diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 6c9545fb..fec9536f 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -248,10 +248,7 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) pic->err = pic_invalid_value(); /* file pool */ - memcpy(pic->files, x_iob, sizeof pic->files); - pic->files[0].vtable.cookie = stdin; - pic->files[1].vtable.cookie = stdout; - pic->files[2].vtable.cookie = stderr; + memset(pic->files, 0, sizeof pic->files); /* parameter table */ pic->ptable = pic_nil_value(); From 20cb77bbbe0cb028201bb2c4c3b69483bd68e52a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 19 Jun 2015 05:13:57 +0900 Subject: [PATCH 061/125] file.h is now stdio.h-free --- contrib/05.r7rs/src/file.c | 2 ++ etc/mkloader.pl | 6 +++--- extlib/benz/file.c | 2 +- extlib/benz/include/picrin/file.h | 2 -- extlib/benz/port.c | 7 ++++++- 5 files changed, 12 insertions(+), 7 deletions(-) diff --git a/contrib/05.r7rs/src/file.c b/contrib/05.r7rs/src/file.c index ba68780c..340a5e6d 100644 --- a/contrib/05.r7rs/src/file.c +++ b/contrib/05.r7rs/src/file.c @@ -4,6 +4,8 @@ #include "picrin.h" +#include + PIC_NORETURN static void file_error(pic_state *pic, const char *msg) { diff --git a/etc/mkloader.pl b/etc/mkloader.pl index 3f5bcb41..602a8aae 100755 --- a/etc/mkloader.pl +++ b/etc/mkloader.pl @@ -50,9 +50,9 @@ foreach my $file (@ARGV) { } pic_catch { /* error! */ - fputs("fatal error: failure in loading $dirname/$basename\\n", stderr); - fputs(pic_errmsg(pic), stderr); - abort(); + xfputs(pic, "fatal error: failure in loading $dirname/$basename\\n", xstderr); + xfputs(pic, pic_errmsg(pic), xstderr); + pic_panic(pic, "load error"); } EOL } diff --git a/extlib/benz/file.c b/extlib/benz/file.c index 2a8b2c18..640a6edb 100644 --- a/extlib/benz/file.c +++ b/extlib/benz/file.c @@ -105,7 +105,7 @@ int x_flushbuf(pic_state *pic, int x, xFILE *fp) { } fp->ptr = fp->base; - fp->cnt = BUFSIZ - 1; + fp->cnt = XBUFSIZ - 1; } if (num_written == bufsize) { diff --git a/extlib/benz/include/picrin/file.h b/extlib/benz/include/picrin/file.h index a38c6a25..b07e1a27 100644 --- a/extlib/benz/include/picrin/file.h +++ b/extlib/benz/include/picrin/file.h @@ -5,8 +5,6 @@ extern "C" { #endif -#include - #ifndef EOF # define EOF (-1) #endif diff --git a/extlib/benz/port.c b/extlib/benz/port.c index 5fadc5d7..518b95b2 100644 --- a/extlib/benz/port.c +++ b/extlib/benz/port.c @@ -4,6 +4,8 @@ #include "picrin.h" +#include + pic_value pic_eof_object() { @@ -69,7 +71,10 @@ file_seek(pic_state PIC_UNUSED(*pic), void *cookie, long pos, int whence) { whence = SEEK_END; break; } - return fseek(cookie, pos, whence); + if (fseek(cookie, pos, whence) == 0) { + return ftell(cookie); + } + return -1; } static int From 3021e7f2b95c10750ab9571e9d1f2df67e4263f8 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 19 Jun 2015 14:03:52 +0900 Subject: [PATCH 062/125] add PIC_ENABLE_STDIO flag --- Makefile | 2 +- etc/libc_polyfill.c | 20 +++++++++++++++ extlib/benz/include/picrin/compat.h | 4 +++ extlib/benz/include/picrin/config.h | 7 ++++++ extlib/benz/port.c | 38 ++++++++++++++++++++++++++--- 5 files changed, 67 insertions(+), 4 deletions(-) create mode 100644 etc/libc_polyfill.c diff --git a/Makefile b/Makefile index 7bbbf99e..030a248e 100644 --- a/Makefile +++ b/Makefile @@ -76,7 +76,7 @@ test-r7rs: bin/picrin t/r7rs-tests.scm 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 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/extlib/benz/include/picrin/compat.h b/extlib/benz/include/picrin/compat.h index 24f82691..ff7268c3 100644 --- a/extlib/benz/include/picrin/compat.h +++ b/extlib/benz/include/picrin/compat.h @@ -209,6 +209,10 @@ strcpy(char *dst, const char *src) # 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/port.c b/extlib/benz/port.c index 518b95b2..5e75a464 100644 --- a/extlib/benz/port.c +++ b/extlib/benz/port.c @@ -4,8 +4,6 @@ #include "picrin.h" -#include - pic_value pic_eof_object() { @@ -28,6 +26,8 @@ pic_assert_port(pic_state *pic) /* 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; @@ -118,6 +118,32 @@ pic_open_file(pic_state *pic, const char *name, int flags) { return port; } +#else + +/* null file */ + +static int +null_read(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie), char PIC_UNUSED(*ptr), int PIC_UNUSED(size)) { + return 0; +} + +static int +null_write(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie), const char PIC_UNUSED(*ptr), int size) { + return size; +} + +static long +null_seek(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie), long PIC_UNUSED(pos), int PIC_UNUSED(whence)) { + return 0; +} + +static int +null_close(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie)) { + return 0; +} + +#endif + static void pic_define_standard_port(pic_state *pic, const char *name, xFILE *file, int dir) { @@ -854,7 +880,11 @@ pic_port_flush(pic_state *pic) void pic_init_port(pic_state *pic) { -#define FILE_VTABLE { 0, file_read, file_write, file_seek, file_close } +#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 }, @@ -866,9 +896,11 @@ pic_init_port(pic_state *pic) 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); From 7ec81ab1d567d3987dc9ad22135c24eae35a9a68 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 19 Jun 2015 17:31:47 +0900 Subject: [PATCH 063/125] add pic_resolve --- extlib/benz/bool.c | 2 +- extlib/benz/codegen.c | 8 ++++---- extlib/benz/include/picrin.h | 1 - extlib/benz/include/picrin/irep.h | 2 ++ 4 files changed, 7 insertions(+), 6 deletions(-) diff --git a/extlib/benz/bool.c b/extlib/benz/bool.c index 603c0db7..64fbd944 100644 --- a/extlib/benz/bool.c +++ b/extlib/benz/bool.c @@ -110,7 +110,7 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash * id1 = pic_id_ptr(x); id2 = pic_id_ptr(y); - return pic_eq_p(pic_expand(pic, id1->var, id1->env), pic_expand(pic, id2->var, id2->env)); + return pic_resolve(pic, id1->var, id1->env) == pic_resolve(pic, id2->var, id2->env); } default: return false; diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 8052873f..53ccbb8b 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -24,8 +24,8 @@ lookup(pic_state PIC_UNUSED(*pic), pic_value var, struct pic_env *env) return NULL; } -static pic_sym * -resolve(pic_state *pic, pic_value var, struct pic_env *env) +pic_sym * +pic_resolve(pic_state *pic, pic_value var, struct pic_env *env) { pic_sym *uid; @@ -72,7 +72,7 @@ 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(resolve(pic, var, env)); + return pic_obj_value(pic_resolve(pic, var, env)); } static pic_value @@ -275,7 +275,7 @@ expand_node(pic_state *pic, pic_value expr, struct pic_env *env, pic_value defer if (pic_var_p(pic_car(pic, expr))) { pic_sym *functor; - functor = resolve(pic, pic_car(pic, expr), env); + functor = pic_resolve(pic, pic_car(pic, expr), env); if (functor == pic->uDEFINE_MACRO) { return expand_defmacro(pic, expr, env); diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index 5deca03e..36049b05 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -217,7 +217,6 @@ pic_value pic_apply4(pic_state *, struct pic_proc *, pic_value, pic_value, pic_v 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_env *); -pic_value pic_expand(pic_state *, pic_value, struct pic_env *); struct pic_proc *pic_compile(pic_state *, pic_value, struct pic_env *); struct pic_lib *pic_make_library(pic_state *, pic_value); diff --git a/extlib/benz/include/picrin/irep.h b/extlib/benz/include/picrin/irep.h index a71d14f6..daa639cc 100644 --- a/extlib/benz/include/picrin/irep.h +++ b/extlib/benz/include/picrin/irep.h @@ -78,6 +78,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); From 32653df1781e2e3104ca76e366533bb98205cfe7 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 19 Jun 2015 21:21:04 +0900 Subject: [PATCH 064/125] cleanup --- extlib/benz/include/picrin.h | 17 +- extlib/benz/vm.c | 337 ++++++++++++++++------------------- 2 files changed, 165 insertions(+), 189 deletions(-) diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index 36049b05..373a3fa6 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -176,13 +176,6 @@ void pic_close(pic_state *); 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 *, ...); @@ -200,13 +193,17 @@ 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 *); +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_ref(pic_state *, struct pic_lib *, const char *); -void pic_set(pic_state *, struct pic_lib *, const char *, pic_value); pic_value pic_apply(pic_state *, struct pic_proc *, pic_value); pic_value pic_apply0(pic_state *, struct pic_proc *); @@ -219,6 +216,8 @@ pic_value pic_apply_trampoline(pic_state *, struct pic_proc *, pic_value); 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); diff --git a/extlib/benz/vm.c b/extlib/benz/vm.c index 2f56467f..6989c465 100644 --- a/extlib/benz/vm.c +++ b/extlib/benz/vm.c @@ -393,150 +393,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 *uid) -{ - pic_put_variable(pic, env, pic_obj_value(sym), uid); - - 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, *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_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, *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()); -} - -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 *uid, 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_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_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 pic_value -defmacro_call(pic_state *pic) -{ - struct pic_proc *self = pic_get_proc(pic); - pic_value args, tmp, proc; - - pic_get_args(pic, "oo", &args, &tmp); - - proc = pic_attr_ref(pic, pic_obj_value(self), "@@transformer"); - - return pic_apply_trampoline(pic, pic_proc_ptr(proc), pic_cdr(pic, args)); -} - -void -pic_defmacro(pic_state *pic, pic_sym *name, pic_sym *id, pic_func_t func) -{ - struct pic_proc *proc, *trans; - - trans = pic_make_proc(pic, func, pic_symbol_name(pic, name)); - - pic_put_variable(pic, pic->lib->env, pic_obj_value(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 */ - pic_dict_set(pic, pic->macros, id, pic_obj_value(proc)); - - /* auto export! */ - pic_export(pic, name); -} - static void vm_push_cxt(pic_state *pic) { @@ -596,42 +452,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 @@ -1252,3 +1072,160 @@ 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); + + 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, name); + + 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); + + pic_export(pic, sym); +} + +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, 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))); +} + +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)); +} From ad6833ac79c656c9e4cec0723cc647b9f6b10a48 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 19 Jun 2015 23:34:12 +0900 Subject: [PATCH 065/125] fix #230 --- extlib/benz/record.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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); } From 535cd0c21e31b9f6949cde9c59accd0ff6e5fa35 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 20 Jun 2015 02:32:25 +0900 Subject: [PATCH 066/125] don't reformat error message because it removes trace info --- extlib/benz/codegen.c | 30 ++---------------------------- extlib/benz/load.c | 14 ++++---------- 2 files changed, 6 insertions(+), 38 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 53ccbb8b..4d671af4 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -214,13 +214,7 @@ expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) uid = pic_add_variable(pic, env, var); } - val = pic_cadr(pic, pic_cdr(pic, expr)); - - pic_try { - val = pic_eval(pic, val, env); - } pic_catch { - pic_errorf(pic, "expand error while definition: %s", pic_errmsg(pic)); - } + 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); @@ -234,27 +228,7 @@ expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) static pic_value expand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct pic_env *env) { - pic_value v; - -#if DEBUG - puts("before expand-1:"); - pic_debug(pic, expr); - puts(""); -#endif - - pic_try { - v = pic_apply2(pic, mac, expr, pic_obj_value(env)); - } pic_catch { - pic_errorf(pic, "expand error while application: %s", pic_errmsg(pic)); - } - -#if DEBUG - puts("after expand-1:"); - pic_debug(pic, v); - puts(""); -#endif - - return v; + return pic_apply2(pic, mac, expr, pic_obj_value(env)); } static pic_value diff --git a/extlib/benz/load.c b/extlib/benz/load.c index 309a1bd8..2f3269d2 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->env); - - pic_gc_arena_restore(pic, ai); - } - } - pic_catch { - pic_errorf(pic, "load error: %s", pic_errmsg(pic)); + pic_gc_arena_restore(pic, ai); } } From a0323bd5fc9854db10e7211e18f449bd05650d95 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 20 Jun 2015 02:34:00 +0900 Subject: [PATCH 067/125] print error irritants --- extlib/benz/debug.c | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/extlib/benz/debug.c b/extlib/benz/debug.c index 55b652c2..2e7097cc 100644 --- a/extlib/benz/debug.c +++ b/extlib/benz/debug.c @@ -42,6 +42,7 @@ pic_print_backtrace(pic_state *pic, xFILE *file) 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, "")) { @@ -50,9 +51,12 @@ pic_print_backtrace(pic_state *pic, xFILE *file) } xfprintf(pic, file, "error: "); pic_fwrite(pic, pic_obj_value(e->msg), file); - xfprintf(pic, 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, pic_str_cstr(pic, e->stack), file); } From 9dbcb2a60562ab0ed16cd84fb0fc317384ae4c63 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 20 Jun 2015 02:34:46 +0900 Subject: [PATCH 068/125] [bugfix] repl failed to import default libraries --- contrib/20.repl/repl.scm | 31 ++++++++++++++++--------------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/contrib/20.repl/repl.scm b/contrib/20.repl/repl.scm index 920b3566..aa7640cf 100644 --- a/contrib/20.repl/repl.scm +++ b/contrib/20.repl/repl.scm @@ -21,21 +21,22 @@ (define user-env (library-environment (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) - (picrin array) - (picrin library)) - user-env) + (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 "")) From 6449731bf47d7a94eef47831a5932f3ed16e5fa8 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 20 Jun 2015 02:35:13 +0900 Subject: [PATCH 069/125] [bugfix] bin/picrin -e option broken --- contrib/30.main/main.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/contrib/30.main/main.scm b/contrib/30.main/main.scm index 92dba342..35ecd522 100644 --- a/contrib/30.main/main.scm +++ b/contrib/30.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) From 500113d1bbc4ff0984fd921149f9bf28d8b0c4ca Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 20 Jun 2015 03:42:56 +0900 Subject: [PATCH 070/125] renumber contribs --- contrib/03.callcc/nitro.mk | 2 -- contrib/05.r7rs/nitro.mk | 24 ------------------- contrib/{03.callcc => 10.callcc}/callcc.c | 0 contrib/10.callcc/nitro.mk | 2 ++ contrib/10.optional/nitro.mk | 7 ------ contrib/10.partcont/nitro.mk | 1 - contrib/10.pretty-print/nitro.mk | 1 - contrib/10.srfi/nitro.mk | 9 ------- contrib/20.for/nitro.mk | 7 ------ contrib/{05.r7rs => 20.r7rs}/docs/doc.rst | 0 contrib/20.r7rs/nitro.mk | 24 +++++++++++++++++++ contrib/{05.r7rs => 20.r7rs}/scheme/base.scm | 0 .../scheme/case-lambda.scm | 0 contrib/{05.r7rs => 20.r7rs}/scheme/cxr.scm | 0 contrib/{05.r7rs => 20.r7rs}/scheme/eval.scm | 0 contrib/{05.r7rs => 20.r7rs}/scheme/file.scm | 0 .../{05.r7rs => 20.r7rs}/scheme/inexact.scm | 0 contrib/{05.r7rs => 20.r7rs}/scheme/lazy.scm | 0 contrib/{05.r7rs => 20.r7rs}/scheme/load.scm | 0 .../scheme/process-context.scm | 0 contrib/{05.r7rs => 20.r7rs}/scheme/r5rs.scm | 0 contrib/{05.r7rs => 20.r7rs}/scheme/read.scm | 0 contrib/{05.r7rs => 20.r7rs}/scheme/time.scm | 0 contrib/{05.r7rs => 20.r7rs}/scheme/write.scm | 0 contrib/{05.r7rs => 20.r7rs}/src/file.c | 0 contrib/{05.r7rs => 20.r7rs}/src/load.c | 0 .../{05.r7rs => 20.r7rs}/src/mutable-string.c | 0 contrib/{05.r7rs => 20.r7rs}/src/r7rs.c | 0 contrib/{05.r7rs => 20.r7rs}/src/system.c | 0 contrib/{05.r7rs => 20.r7rs}/src/time.c | 0 contrib/20.repl/nitro.mk | 3 --- contrib/30.main/nitro.mk | 1 - contrib/30.optional/nitro.mk | 7 ++++++ .../piclib/optional.scm | 0 .../{10.optional => 30.optional}/t/test.scm | 0 .../{10.partcont => 30.partcont}/docs/doc.rst | 0 contrib/30.partcont/nitro.mk | 1 + .../piclib/partcont.scm | 0 .../docs/doc.rst | 0 contrib/30.pretty-print/nitro.mk | 1 + .../pretty-print.scm | 0 contrib/{10.random => 30.random}/nitro.mk | 4 ++-- .../{10.random => 30.random}/src/mt19937ar.c | 0 contrib/{10.random => 30.random}/src/random.c | 0 contrib/{10.random => 30.random}/t/test.scm | 0 .../example/simple-repl.scm | 0 contrib/{10.readline => 30.readline}/nitro.mk | 4 ++-- .../src/readline.c | 0 .../{10.readline => 30.readline}/t/test.scm | 0 contrib/{10.regexp => 30.regexp}/docs/doc.rst | 0 contrib/{10.regexp => 30.regexp}/nitro.mk | 4 ++-- contrib/{10.regexp => 30.regexp}/src/regexp.c | 0 contrib/{10.regexp => 30.regexp}/t/test.scm | 0 contrib/40.class/nitro.mk | 1 - contrib/{10.srfi => 40.srfi}/docs/doc.rst | 0 contrib/40.srfi/nitro.mk | 9 +++++++ contrib/{10.srfi => 40.srfi}/srfi/1.scm | 0 contrib/{10.srfi => 40.srfi}/srfi/111.scm | 0 contrib/{10.srfi => 40.srfi}/srfi/17.scm | 0 contrib/{10.srfi => 40.srfi}/srfi/26.scm | 0 contrib/{10.srfi => 40.srfi}/srfi/43.scm | 0 contrib/{10.srfi => 40.srfi}/srfi/60.scm | 0 contrib/{10.srfi => 40.srfi}/srfi/8.scm | 0 contrib/{10.srfi => 40.srfi}/srfi/95.scm | 0 contrib/50.class/nitro.mk | 1 + .../piclib/picrin/class.scm | 0 contrib/{20.for => 50.for}/docs/doc.rst | 0 contrib/50.for/nitro.mk | 7 ++++++ contrib/{20.for => 50.for}/piclib/for.scm | 0 contrib/{20.for => 50.for}/t/test.scm | 0 contrib/50.protocol/nitro.mk | 1 - contrib/60.repl/nitro.mk | 3 +++ contrib/{20.repl => 60.repl}/repl.c | 0 contrib/{20.repl => 60.repl}/repl.scm | 0 contrib/{30.main => 70.main}/main.scm | 0 contrib/70.main/nitro.mk | 1 + contrib/80.protocol/nitro.mk | 1 + .../piclib/picrin/protocol.scm | 0 78 files changed, 63 insertions(+), 63 deletions(-) delete mode 100644 contrib/03.callcc/nitro.mk delete mode 100644 contrib/05.r7rs/nitro.mk rename contrib/{03.callcc => 10.callcc}/callcc.c (100%) create mode 100644 contrib/10.callcc/nitro.mk delete mode 100644 contrib/10.optional/nitro.mk delete mode 100644 contrib/10.partcont/nitro.mk delete mode 100644 contrib/10.pretty-print/nitro.mk delete mode 100644 contrib/10.srfi/nitro.mk delete mode 100644 contrib/20.for/nitro.mk rename contrib/{05.r7rs => 20.r7rs}/docs/doc.rst (100%) create mode 100644 contrib/20.r7rs/nitro.mk rename contrib/{05.r7rs => 20.r7rs}/scheme/base.scm (100%) rename contrib/{05.r7rs => 20.r7rs}/scheme/case-lambda.scm (100%) rename contrib/{05.r7rs => 20.r7rs}/scheme/cxr.scm (100%) rename contrib/{05.r7rs => 20.r7rs}/scheme/eval.scm (100%) rename contrib/{05.r7rs => 20.r7rs}/scheme/file.scm (100%) rename contrib/{05.r7rs => 20.r7rs}/scheme/inexact.scm (100%) rename contrib/{05.r7rs => 20.r7rs}/scheme/lazy.scm (100%) rename contrib/{05.r7rs => 20.r7rs}/scheme/load.scm (100%) rename contrib/{05.r7rs => 20.r7rs}/scheme/process-context.scm (100%) rename contrib/{05.r7rs => 20.r7rs}/scheme/r5rs.scm (100%) rename contrib/{05.r7rs => 20.r7rs}/scheme/read.scm (100%) rename contrib/{05.r7rs => 20.r7rs}/scheme/time.scm (100%) rename contrib/{05.r7rs => 20.r7rs}/scheme/write.scm (100%) rename contrib/{05.r7rs => 20.r7rs}/src/file.c (100%) rename contrib/{05.r7rs => 20.r7rs}/src/load.c (100%) rename contrib/{05.r7rs => 20.r7rs}/src/mutable-string.c (100%) rename contrib/{05.r7rs => 20.r7rs}/src/r7rs.c (100%) rename contrib/{05.r7rs => 20.r7rs}/src/system.c (100%) rename contrib/{05.r7rs => 20.r7rs}/src/time.c (100%) delete mode 100644 contrib/20.repl/nitro.mk delete mode 100644 contrib/30.main/nitro.mk create mode 100644 contrib/30.optional/nitro.mk rename contrib/{10.optional => 30.optional}/piclib/optional.scm (100%) rename contrib/{10.optional => 30.optional}/t/test.scm (100%) rename contrib/{10.partcont => 30.partcont}/docs/doc.rst (100%) create mode 100644 contrib/30.partcont/nitro.mk rename contrib/{10.partcont => 30.partcont}/piclib/partcont.scm (100%) rename contrib/{10.pretty-print => 30.pretty-print}/docs/doc.rst (100%) create mode 100644 contrib/30.pretty-print/nitro.mk rename contrib/{10.pretty-print => 30.pretty-print}/pretty-print.scm (100%) rename contrib/{10.random => 30.random}/nitro.mk (50%) rename contrib/{10.random => 30.random}/src/mt19937ar.c (100%) rename contrib/{10.random => 30.random}/src/random.c (100%) rename contrib/{10.random => 30.random}/t/test.scm (100%) rename contrib/{10.readline => 30.readline}/example/simple-repl.scm (100%) rename contrib/{10.readline => 30.readline}/nitro.mk (77%) rename contrib/{10.readline => 30.readline}/src/readline.c (100%) rename contrib/{10.readline => 30.readline}/t/test.scm (100%) rename contrib/{10.regexp => 30.regexp}/docs/doc.rst (100%) rename contrib/{10.regexp => 30.regexp}/nitro.mk (52%) rename contrib/{10.regexp => 30.regexp}/src/regexp.c (100%) rename contrib/{10.regexp => 30.regexp}/t/test.scm (100%) delete mode 100644 contrib/40.class/nitro.mk rename contrib/{10.srfi => 40.srfi}/docs/doc.rst (100%) create mode 100644 contrib/40.srfi/nitro.mk rename contrib/{10.srfi => 40.srfi}/srfi/1.scm (100%) rename contrib/{10.srfi => 40.srfi}/srfi/111.scm (100%) rename contrib/{10.srfi => 40.srfi}/srfi/17.scm (100%) rename contrib/{10.srfi => 40.srfi}/srfi/26.scm (100%) rename contrib/{10.srfi => 40.srfi}/srfi/43.scm (100%) rename contrib/{10.srfi => 40.srfi}/srfi/60.scm (100%) rename contrib/{10.srfi => 40.srfi}/srfi/8.scm (100%) rename contrib/{10.srfi => 40.srfi}/srfi/95.scm (100%) create mode 100644 contrib/50.class/nitro.mk rename contrib/{40.class => 50.class}/piclib/picrin/class.scm (100%) rename contrib/{20.for => 50.for}/docs/doc.rst (100%) create mode 100644 contrib/50.for/nitro.mk rename contrib/{20.for => 50.for}/piclib/for.scm (100%) rename contrib/{20.for => 50.for}/t/test.scm (100%) delete mode 100644 contrib/50.protocol/nitro.mk create mode 100644 contrib/60.repl/nitro.mk rename contrib/{20.repl => 60.repl}/repl.c (100%) rename contrib/{20.repl => 60.repl}/repl.scm (100%) rename contrib/{30.main => 70.main}/main.scm (100%) create mode 100644 contrib/70.main/nitro.mk create mode 100644 contrib/80.protocol/nitro.mk rename contrib/{50.protocol => 80.protocol}/piclib/picrin/protocol.scm (100%) 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/03.callcc/callcc.c b/contrib/10.callcc/callcc.c similarity index 100% rename from contrib/03.callcc/callcc.c rename to contrib/10.callcc/callcc.c 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..eef49eac --- /dev/null +++ b/contrib/20.r7rs/nitro.mk @@ -0,0 +1,24 @@ +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 diff --git a/contrib/05.r7rs/scheme/base.scm b/contrib/20.r7rs/scheme/base.scm similarity index 100% rename from contrib/05.r7rs/scheme/base.scm rename to contrib/20.r7rs/scheme/base.scm diff --git a/contrib/05.r7rs/scheme/case-lambda.scm b/contrib/20.r7rs/scheme/case-lambda.scm similarity index 100% rename from contrib/05.r7rs/scheme/case-lambda.scm rename to contrib/20.r7rs/scheme/case-lambda.scm 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/05.r7rs/scheme/eval.scm b/contrib/20.r7rs/scheme/eval.scm similarity index 100% rename from contrib/05.r7rs/scheme/eval.scm rename to contrib/20.r7rs/scheme/eval.scm 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/05.r7rs/scheme/lazy.scm b/contrib/20.r7rs/scheme/lazy.scm similarity index 100% rename from contrib/05.r7rs/scheme/lazy.scm rename to contrib/20.r7rs/scheme/lazy.scm 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 100% rename from contrib/05.r7rs/scheme/r5rs.scm rename to contrib/20.r7rs/scheme/r5rs.scm 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 100% rename from contrib/05.r7rs/src/file.c rename to contrib/20.r7rs/src/file.c diff --git a/contrib/05.r7rs/src/load.c b/contrib/20.r7rs/src/load.c similarity index 100% rename from contrib/05.r7rs/src/load.c rename to contrib/20.r7rs/src/load.c 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/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 100% rename from contrib/10.srfi/docs/doc.rst rename to contrib/40.srfi/docs/doc.rst diff --git a/contrib/40.srfi/nitro.mk b/contrib/40.srfi/nitro.mk new file mode 100644 index 00000000..fbb9ae38 --- /dev/null +++ b/contrib/40.srfi/nitro.mk @@ -0,0 +1,9 @@ +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/111.scm 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/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/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 100% rename from contrib/20.repl/repl.scm rename to contrib/60.repl/repl.scm diff --git a/contrib/30.main/main.scm b/contrib/70.main/main.scm similarity index 100% rename from contrib/30.main/main.scm rename to contrib/70.main/main.scm 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 From 7d880f6f0043cb559968de321c0d282e817a3342 Mon Sep 17 00:00:00 2001 From: OGINO Masanori Date: Fri, 19 Sep 2014 21:06:46 +0900 Subject: [PATCH 071/125] Implement SRFI 106. Reference: http://srfi.schemers.org/srfi-106/ Signed-off-by: OGINO Masanori --- contrib/40.srfi/docs/doc.rst | 5 + .../examples/106/simple-echo-client.scm | 29 + .../examples/106/simple-echo-server.scm | 47 ++ contrib/40.srfi/nitro.mk | 9 + contrib/40.srfi/src/106.c | 521 ++++++++++++++++++ contrib/40.srfi/srfi/106.scm | 168 ++++++ contrib/40.srfi/t/106.scm | 72 +++ 7 files changed, 851 insertions(+) create mode 100644 contrib/40.srfi/examples/106/simple-echo-client.scm create mode 100644 contrib/40.srfi/examples/106/simple-echo-server.scm create mode 100644 contrib/40.srfi/src/106.c create mode 100644 contrib/40.srfi/srfi/106.scm create mode 100644 contrib/40.srfi/t/106.scm diff --git a/contrib/40.srfi/docs/doc.rst b/contrib/40.srfi/docs/doc.rst index bc95b39f..1dfc7675 100644 --- a/contrib/40.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 index fbb9ae38..c5fcc36d 100644 --- a/contrib/40.srfi/nitro.mk +++ b/contrib/40.srfi/nitro.mk @@ -1,3 +1,4 @@ +CONTRIB_INITS += socket CONTRIB_LIBS += \ contrib/40.srfi/srfi/1.scm\ contrib/40.srfi/srfi/8.scm\ @@ -6,4 +7,12 @@ CONTRIB_LIBS += \ 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..c90f5c9a --- /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/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/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)) From b0e6f144423689ab8baa9c5e74af8ee8eb908b74 Mon Sep 17 00:00:00 2001 From: OGINO Masanori Date: Mon, 22 Jun 2015 11:07:56 +0900 Subject: [PATCH 072/125] Move r7rs-tests.scm into a nitro. Signed-off-by: OGINO Masanori --- Makefile | 5 +---- contrib/20.r7rs/nitro.mk | 7 +++++++ t/r7rs-tests.scm => contrib/20.r7rs/t/r7rs.scm | 0 3 files changed, 8 insertions(+), 4 deletions(-) rename t/r7rs-tests.scm => contrib/20.r7rs/t/r7rs.scm (100%) diff --git a/Makefile b/Makefile index 030a248e..ccc08d82 100644 --- a/Makefile +++ b/Makefile @@ -68,10 +68,7 @@ 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) diff --git a/contrib/20.r7rs/nitro.mk b/contrib/20.r7rs/nitro.mk index eef49eac..9ddf756f 100644 --- a/contrib/20.r7rs/nitro.mk +++ b/contrib/20.r7rs/nitro.mk @@ -22,3 +22,10 @@ CONTRIB_LIBS += \ 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/t/r7rs-tests.scm b/contrib/20.r7rs/t/r7rs.scm similarity index 100% rename from t/r7rs-tests.scm rename to contrib/20.r7rs/t/r7rs.scm From e730a314f40b080d91ebb3f5209adfc12c6d127c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 22 Jun 2015 17:06:13 +0900 Subject: [PATCH 073/125] [bugfix] memory leak of pic_checkpoint --- extlib/benz/cont.c | 2 +- extlib/benz/gc.c | 33 ++++++++++++++++-------------- extlib/benz/include/picrin.h | 1 + extlib/benz/include/picrin/value.h | 9 +++++--- extlib/benz/state.c | 10 +-------- 5 files changed, 27 insertions(+), 28 deletions(-) diff --git a/extlib/benz/cont.c b/extlib/benz/cont.c index 79fc747d..df1beedb 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; diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index 59ea6850..d5cf55f0 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) { @@ -495,6 +481,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 @@ -565,7 +565,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 */ @@ -722,6 +722,9 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) xh_destroy(®->hash); break; } + case PIC_TT_CP: { + break; + } case PIC_TT_NIL: case PIC_TT_BOOL: #if PIC_ENABLE_FLOAT diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index 373a3fa6..01220cfd 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -53,6 +53,7 @@ typedef struct pic_jmpbuf { } pic_jmpbuf; typedef struct pic_checkpoint { + PIC_OBJECT_HEADER struct pic_proc *in; struct pic_proc *out; int depth; diff --git a/extlib/benz/include/picrin/value.h b/extlib/benz/include/picrin/value.h index 703bcb8e..507832bb 100644 --- a/extlib/benz/include/picrin/value.h +++ b/extlib/benz/include/picrin/value.h @@ -158,14 +158,15 @@ enum pic_tt { PIC_TT_PORT, PIC_TT_ERROR, PIC_TT_ID, - PIC_TT_CXT, 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 \ @@ -336,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/state.c b/extlib/benz/state.c index fec9536f..46e88ab7 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -355,7 +355,7 @@ 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; @@ -401,14 +401,6 @@ pic_close(pic_state *pic) xh_entry *it; 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); From aa7979733444ba74760e7ee6160096699ffc12e9 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 22 Jun 2015 17:41:17 +0900 Subject: [PATCH 074/125] fix #234 --- extlib/benz/codegen.c | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 4d671af4..845febd2 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -66,6 +66,14 @@ find_macro(pic_state *pic, pic_sym *uid) 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 *); @@ -190,6 +198,8 @@ expand_define(pic_state *pic, pic_value expr, struct pic_env *env, pic_value def } 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); From aae1b8792a025da225f6fc48f0be349b1d11bc2a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 23 Jun 2015 03:02:12 +0900 Subject: [PATCH 075/125] remove struct pic_picjmp --- contrib/10.callcc/callcc.c | 7 +++---- extlib/benz/cont.c | 33 +++++++++++++++--------------- extlib/benz/gc.c | 4 +++- extlib/benz/include/picrin.h | 7 +------ extlib/benz/include/picrin/cont.h | 7 ++++--- extlib/benz/include/picrin/error.h | 14 ++++++------- extlib/benz/state.c | 4 ++-- 7 files changed, 36 insertions(+), 40 deletions(-) diff --git a/contrib/10.callcc/callcc.c b/contrib/10.callcc/callcc.c index 7b6b9609..22287fea 100644 --- a/contrib/10.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; @@ -181,8 +181,7 @@ restore_cont(pic_state *pic, struct pic_fullcont *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); diff --git a/extlib/benz/cont.c b/extlib/benz/cont.c index df1beedb..698ae234 100644 --- a/extlib/benz/cont.c +++ b/extlib/benz/cont.c @@ -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,21 +59,23 @@ 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(); + + pic->cc = cont; } void pic_load_point(pic_state *pic, struct pic_cont *cont) { - pic_jmpbuf *jmp; + struct pic_cont *cc; - for (jmp = pic->jmp; jmp != NULL; jmp = jmp->prev) { - if (jmp == &cont->jmp) { + for (cc = pic->cc; cc != NULL; cc = cc->prev) { + if (cc == cont) { break; } } - if (jmp == NULL) { + if (cc == NULL) { pic_errorf(pic, "calling dead escape continuation"); } @@ -106,7 +105,7 @@ cont_call(pic_state *pic) pic_load_point(pic, e->data); - PIC_LONGJMP(pic, ((struct pic_cont *)e->data)->jmp.buf, 1); + PIC_LONGJMP(pic, ((struct pic_cont *)e->data)->jmp, 1); PIC_UNREACHABLE(); } @@ -114,7 +113,7 @@ 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; @@ -131,21 +130,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; } diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index d5cf55f0..a4f33668 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -702,7 +702,9 @@ 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); + if (data->type->dtor) { + data->type->dtor(pic, data->data); + } xh_destroy(&data->storage); break; } diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index 01220cfd..b28d286a 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -47,11 +47,6 @@ typedef struct pic_state pic_state; #include "picrin/read.h" #include "picrin/gc.h" -typedef struct pic_jmpbuf { - PIC_JMPBUF buf; - struct pic_jmpbuf *prev; -} pic_jmpbuf; - typedef struct pic_checkpoint { PIC_OBJECT_HEADER struct pic_proc *in; @@ -78,7 +73,7 @@ struct pic_state { pic_allocf allocf; - pic_jmpbuf *jmp; + struct pic_cont *cc; pic_checkpoint *cp; pic_value *sp; diff --git a/extlib/benz/include/picrin/cont.h b/extlib/benz/include/picrin/cont.h index 303ea0f9..10c394d4 100644 --- a/extlib/benz/include/picrin/cont.h +++ b/extlib/benz/include/picrin/cont.h @@ -10,7 +10,7 @@ extern "C" { #endif struct pic_cont { - pic_jmpbuf jmp; + PIC_JMPBUF jmp; pic_checkpoint *cp; @@ -18,12 +18,13 @@ struct pic_cont { 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/error.h b/extlib/benz/include/picrin/error.h index 1435faa3..b14ad963 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))); \ + 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); \ + 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/state.c b/extlib/benz/state.c index 46e88ab7..61dd2ae0 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -172,8 +172,8 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) /* turn off GC */ pic->gc_enable = false; - /* jmp */ - pic->jmp = NULL; + /* continuation chain */ + pic->cc = NULL; /* root block */ pic->cp = NULL; From 777ba0ff6a1b9f3cdf0cd5657acc92e05cd15f2e Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 23 Jun 2015 03:12:17 +0900 Subject: [PATCH 076/125] [bugfix] don't compare continuation objects by pointers. They may be reused when it reenters the same stack position. --- extlib/benz/cont.c | 37 ++++++++++++++++++------------- extlib/benz/include/picrin.h | 3 ++- extlib/benz/include/picrin/cont.h | 4 ++-- extlib/benz/state.c | 1 + 4 files changed, 26 insertions(+), 19 deletions(-) diff --git a/extlib/benz/cont.c b/extlib/benz/cont.c index 698ae234..132ed018 100644 --- a/extlib/benz/cont.c +++ b/extlib/benz/cont.c @@ -61,6 +61,7 @@ pic_save_point(pic_state *pic, struct pic_cont *cont) cont->ptable = pic->ptable; cont->prev = pic->cc; cont->results = pic_undef_value(); + cont->id = pic->ccnt++; pic->cc = cont; } @@ -68,17 +69,6 @@ pic_save_point(pic_state *pic, struct pic_cont *cont) void pic_load_point(pic_state *pic, struct pic_cont *cont) { - struct pic_cont *cc; - - for (cc = pic->cc; cc != NULL; cc = cc->prev) { - if (cc == cont) { - break; - } - } - if (cc == NULL) { - pic_errorf(pic, "calling dead escape continuation"); - } - pic_wind(pic, pic->cp, cont->cp); /* load runtime context */ @@ -94,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, 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(); } @@ -123,6 +127,7 @@ pic_make_cont(pic_state *pic, struct pic_cont *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; } diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index b28d286a..e5419c24 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -73,8 +73,9 @@ struct pic_state { pic_allocf allocf; - struct pic_cont *cc; pic_checkpoint *cp; + struct pic_cont *cc; + int ccnt; pic_value *sp; pic_value *stbase, *stend; diff --git a/extlib/benz/include/picrin/cont.h b/extlib/benz/include/picrin/cont.h index 10c394d4..439f6aeb 100644 --- a/extlib/benz/include/picrin/cont.h +++ b/extlib/benz/include/picrin/cont.h @@ -12,14 +12,14 @@ extern "C" { struct pic_cont { PIC_JMPBUF jmp; - pic_checkpoint *cp; + int id; + pic_checkpoint *cp; ptrdiff_t sp_offset; ptrdiff_t ci_offset; ptrdiff_t xp_offset; size_t arena_idx; pic_value ptable; - pic_code *ip; pic_value results; diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 61dd2ae0..141f76ec 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -174,6 +174,7 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) /* continuation chain */ pic->cc = NULL; + pic->ccnt = 0; /* root block */ pic->cp = NULL; From e2ad39074b9a67b8024d292c50abc0c830a6b1ef Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 23 Jun 2015 04:01:25 +0900 Subject: [PATCH 077/125] cleanup --- extlib/benz/include/picrin/error.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extlib/benz/include/picrin/error.h b/extlib/benz/include/picrin/error.h index b14ad963..15fd57b4 100644 --- a/extlib/benz/include/picrin/error.h +++ b/extlib/benz/include/picrin/error.h @@ -40,7 +40,7 @@ struct pic_error *pic_make_error(pic_state *, pic_sym *, const char *, pic_list) do { \ pic_push_handler(pic, handler); #define pic_catch_(label) \ - pic_pop_handler(pic); \ + pic_pop_handler(pic); \ } while (0); \ pic->cc = pic->cc->prev; \ } else { \ From f0434a8b378cc6287d3c459ee847cfd21f00786d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 23 Jun 2015 22:08:18 +0900 Subject: [PATCH 078/125] abandon xvect.h, move on to kvec.h --- extlib/benz/codegen.c | 118 ++++++++++++++--------------- extlib/benz/gc.c | 18 ++--- extlib/benz/include/picrin.h | 2 +- extlib/benz/include/picrin/kvec.h | 67 ++++++++++++++++ extlib/benz/include/picrin/xvect.h | 76 ------------------- 5 files changed, 132 insertions(+), 149 deletions(-) create mode 100644 extlib/benz/include/picrin/kvec.h delete mode 100644 extlib/benz/include/picrin/xvect.h diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 845febd2..721505a8 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -330,9 +330,9 @@ pic_expand(pic_state *pic, pic_value expr, struct pic_env *env) return v; } -typedef xvect_t(pic_sym *) xvect; +typedef kvec_t(pic_sym *) svec_t; -#define xv_push_sym(v, x) xv_push(pic_sym *, (v), (x)) +#define kv_push_sym(v, x) kv_push(pic_sym *, (v), (x)) /** * scope object @@ -341,7 +341,7 @@ typedef xvect_t(pic_sym *) xvect; typedef struct analyze_scope { int depth; bool varg; - xvect args, locals, captures; /* rest args variable is counted as a local */ + svec_t args, locals, captures; /* rest args variable is counted as a local */ pic_value defer; struct analyze_scope *up; } analyze_scope; @@ -373,7 +373,7 @@ new_analyze_state(pic_state *pic) push_scope(state, pic_nil_value()); pic_dict_for_each (sym, pic->globals, it) { - xv_push_sym(state->scope->locals, sym); + kv_push_sym(state->scope->locals, sym); } return state; @@ -387,7 +387,7 @@ destroy_analyze_state(analyze_state *state) } static bool -analyze_args(pic_state *pic, pic_value formals, bool *varg, xvect *args, xvect *locals) +analyze_args(pic_state *pic, pic_value formals, bool *varg, svec_t *args, svec_t *locals) { pic_value v, t; pic_sym *sym; @@ -398,7 +398,7 @@ analyze_args(pic_state *pic, pic_value formals, bool *varg, xvect *args, xvect * return false; } sym = pic_sym_ptr(t); - xv_push_sym(*args, sym); + kv_push_sym(*args, sym); } if (pic_nil_p(v)) { *varg = false; @@ -406,7 +406,7 @@ analyze_args(pic_state *pic, pic_value formals, bool *varg, xvect *args, xvect * else if (pic_sym_p(v)) { *varg = true; sym = pic_sym_ptr(v); - xv_push_sym(*locals, sym); + kv_push_sym(*locals, sym); } else { return false; @@ -422,9 +422,9 @@ push_scope(analyze_state *state, pic_value formals) analyze_scope *scope = pic_malloc(pic, sizeof(analyze_scope)); bool varg; - xv_init(scope->args); - xv_init(scope->locals); - xv_init(scope->captures); + kv_init(scope->args); + kv_init(scope->locals); + kv_init(scope->captures); if (analyze_args(pic, formals, &varg, &scope->args, &scope->locals)) { scope->up = state->scope; @@ -437,9 +437,9 @@ push_scope(analyze_state *state, pic_value formals) return true; } else { - xv_destroy(scope->args); - xv_destroy(scope->locals); - xv_destroy(scope->captures); + kv_destroy(scope->args); + kv_destroy(scope->locals); + kv_destroy(scope->captures); pic_free(pic, scope); return false; } @@ -452,9 +452,9 @@ pop_scope(analyze_state *state) analyze_scope *scope; scope = state->scope; - xv_destroy(scope->args); - xv_destroy(scope->locals); - xv_destroy(scope->captures); + kv_destroy(scope->args); + kv_destroy(scope->locals); + kv_destroy(scope->captures); scope = scope->up; pic_free(state->pic, state->scope); @@ -467,13 +467,13 @@ 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) + for (i = 0; i < kv_size(scope->args); ++i) { + if (kv_A(scope->args, i) == sym) return true; } /* locals */ - for (i = 0; i < xv_size(scope->locals); ++i) { - if (xv_A(scope->locals, i) == sym) + for (i = 0; i < kv_size(scope->locals); ++i) { + if (kv_A(scope->locals, i) == sym) return true; } return false; @@ -484,13 +484,13 @@ capture_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) { size_t i; - for (i = 0; i < xv_size(scope->captures); ++i) { - if (xv_A(scope->captures, i) == sym) { + for (i = 0; i < kv_size(scope->captures); ++i) { + if (kv_A(scope->captures, i) == sym) { break; } } - if (i == xv_size(scope->captures)) { - xv_push_sym(scope->captures, sym); + if (i == kv_size(scope->captures)) { + kv_push_sym(scope->captures, sym); } } @@ -524,7 +524,7 @@ define_var(analyze_state *state, pic_sym *sym) return; } - xv_push_sym(scope->locals, sym); + kv_push_sym(scope->locals, sym); } static pic_value analyze_node(analyze_state *, pic_value, bool); @@ -648,8 +648,8 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v size_t i; 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); + for (i = kv_size(scope->args); i > 0; --i) { + pic_push(pic, pic_obj_value(kv_A(scope->args, i - 1)), args); } varg = scope->varg @@ -662,13 +662,13 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v 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); + for (i = kv_size(scope->locals); i > 0; --i) { + pic_push(pic, pic_obj_value(kv_A(scope->locals, i - 1)), locals); } 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); + for (i = kv_size(scope->captures); i > 0; --i) { + pic_push(pic, pic_obj_value(kv_A(scope->captures, i - 1)), captures); } pop_scope(state); @@ -1141,7 +1141,7 @@ typedef struct codegen_context { pic_sym *name; /* rest args variable is counted as a local */ bool varg; - xvect args, locals, captures; + svec_t args, locals, captures; /* actual bit code sequence */ pic_code *code; size_t clen, ccapa; @@ -1268,19 +1268,19 @@ create_activation(codegen_state *state) xh_init_ptr(®s, sizeof(size_t)); offset = 1; - for (i = 0; i < xv_size(cxt->args); ++i) { + for (i = 0; i < kv_size(cxt->args); ++i) { n = i + offset; - xh_put_ptr(®s, xv_A(cxt->args, i), &n); + xh_put_ptr(®s, kv_A(cxt->args, i), &n); } offset += i; - for (i = 0; i < xv_size(cxt->locals); ++i) { + for (i = 0; i < kv_size(cxt->locals); ++i) { n = i + offset; - xh_put_ptr(®s, xv_A(cxt->locals, i), &n); + xh_put_ptr(®s, kv_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)) { + for (i = 0; i < kv_size(cxt->captures); ++i) { + n = xh_val(xh_get_ptr(®s, kv_A(cxt->captures, i)), size_t); + if (n <= kv_size(cxt->args) || (cxt->varg && n == kv_size(cxt->args) + 1)) { /* copy arguments to capture variable area */ emit_i(state, OP_LREF, (int)n); } else { @@ -1308,18 +1308,18 @@ push_codegen_context(codegen_state *state, pic_value name, pic_value args, pic_v : pic_sym_ptr(name); cxt->varg = varg; - xv_init(cxt->args); - xv_init(cxt->locals); - xv_init(cxt->captures); + kv_init(cxt->args); + kv_init(cxt->locals); + kv_init(cxt->captures); pic_for_each (var, args, it) { - xv_push_sym(cxt->args, pic_sym_ptr(var)); + kv_push_sym(cxt->args, pic_sym_ptr(var)); } pic_for_each (var, locals, it) { - xv_push_sym(cxt->locals, pic_sym_ptr(var)); + kv_push_sym(cxt->locals, pic_sym_ptr(var)); } pic_for_each (var, captures, it) { - xv_push_sym(cxt->captures, pic_sym_ptr(var)); + kv_push_sym(cxt->captures, pic_sym_ptr(var)); } cxt->code = pic_calloc(pic, PIC_ISEQ_SIZE, sizeof(pic_code)); @@ -1354,9 +1354,9 @@ pop_codegen_context(codegen_state *state) 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->argc = (int)kv_size(state->cxt->args) + 1; + irep->localc = (int)kv_size(state->cxt->locals); + irep->capturec = (int)kv_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); @@ -1367,9 +1367,9 @@ pop_codegen_context(codegen_state *state) irep->slen = state->cxt->slen; /* finalize */ - xv_destroy(cxt->args); - xv_destroy(cxt->locals); - xv_destroy(cxt->captures); + kv_destroy(cxt->args); + kv_destroy(cxt->locals); + kv_destroy(cxt->captures); /* destroy context */ cxt = cxt->up; @@ -1389,8 +1389,8 @@ index_capture(codegen_state *state, pic_sym *sym, int depth) cxt = cxt->up; } - for (i = 0; i < xv_size(cxt->captures); ++i) { - if (xv_A(cxt->captures, i) == sym) + for (i = 0; i < kv_size(cxt->captures); ++i) { + if (kv_A(cxt->captures, i) == sym) return (int)i; } return -1; @@ -1403,13 +1403,13 @@ index_local(codegen_state *state, pic_sym *sym) 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 < kv_size(cxt->args); ++i) { + if (kv_A(cxt->args, 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 < kv_size(cxt->locals); ++i) { + if (kv_A(cxt->locals, i) == sym) return (int)(i + offset); } return -1; @@ -1462,7 +1462,7 @@ codegen(codegen_state *state, pic_value obj) 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); + emit_i(state, OP_LREF, i + (int)kv_size(cxt->args) + (int)kv_size(cxt->locals) + 1); return; } emit_i(state, OP_LREF, index_local(state, name)); @@ -1497,7 +1497,7 @@ codegen(codegen_state *state, pic_value obj) 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_i(state, OP_LSET, i + (int)kv_size(cxt->args) + (int)kv_size(cxt->locals) + 1); emit_n(state, OP_PUSHUNDEF); return; } diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index a4f33668..9205abe2 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -745,25 +745,17 @@ static void gc_sweep_symbols(pic_state *pic) { xh_entry *it; - xvect_t(xh_entry *) xv; - size_t i; char *cstr; - 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); + cstr = xh_key(it, char *); + + xh_del_str(&pic->syms, cstr); + + pic_free(pic, cstr); } } - - 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 diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index e5419c24..54c8bf14 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -35,7 +35,7 @@ extern "C" { #include "picrin/config.h" #include "picrin/compat.h" -#include "picrin/xvect.h" +#include "picrin/kvec.h" #include "picrin/xhash.h" #include "picrin/value.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/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 From 07fc2bb98ea9c024579b8454bf7355a668f97af5 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 24 Jun 2015 01:13:18 +0900 Subject: [PATCH 079/125] cleanup --- extlib/benz/data.c | 3 ++- extlib/benz/dict.c | 12 +++++++----- extlib/benz/gc.c | 13 +++++-------- extlib/benz/include/picrin/data.h | 2 +- extlib/benz/write.c | 7 ++++--- 5 files changed, 19 insertions(+), 18 deletions(-) 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/dict.c b/extlib/benz/dict.c index ca5d042d..41a4fea9 100644 --- a/extlib/benz/dict.c +++ b/extlib/benz/dict.c @@ -238,12 +238,13 @@ pic_dict_dictionary_to_alist(pic_state *pic) { struct pic_dict *dict; pic_value item, alist = pic_nil_value(); + pic_sym *sym; xh_entry *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); } @@ -273,13 +274,14 @@ pic_dict_dictionary_to_plist(pic_state *pic) { struct pic_dict *dict; pic_value plist = pic_nil_value(); + pic_sym *sym; xh_entry *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_obj_value(sym), plist); + pic_push(pic, pic_dict_ref(pic, dict, sym), plist); } return pic_reverse(pic, plist); diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index 9205abe2..adf449ec 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -442,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); } @@ -454,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; + pic_sym *sym; xh_entry *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; } @@ -705,7 +703,6 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) if (data->type->dtor) { data->type->dtor(pic, data->data); } - xh_destroy(&data->storage); break; } case PIC_TT_DICT: { 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/write.c b/extlib/benz/write.c index e98e027c..c5ba08bb 100644 --- a/extlib/benz/write.c +++ b/extlib/benz/write.c @@ -169,6 +169,7 @@ write_core(struct writer_control *p, pic_value obj) pic_state *pic = p->pic; xFILE *file = p->file; size_t i; + pic_sym *sym; xh_entry *e, *it; int c; #if PIC_ENABLE_FLOAT @@ -297,9 +298,9 @@ write_core(struct writer_control *p, pic_value obj) break; case PIC_TT_DICT: xfprintf(pic, file, "#.(dictionary"); - for (it = xh_begin(&pic_dict_ptr(obj)->hash); it != NULL; it = xh_next(it)) { - xfprintf(pic, file, " '%s ", pic_symbol_name(pic, xh_key(it, pic_sym *))); - write_core(p, xh_val(it, pic_value)); + pic_dict_for_each (sym, pic_dict_ptr(obj), it) { + xfprintf(pic, file, " '%s ", pic_symbol_name(pic, sym)); + write_core(p, pic_dict_ref(pic, pic_dict_ptr(obj), sym)); } xfprintf(pic, file, ")"); break; From 324445f483fb17b49590d75273ca817dc70000cc Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 24 Jun 2015 01:54:46 +0900 Subject: [PATCH 080/125] fix #273 --- t/ir-macro.scm | 42 +++++++++++++++++++++++++----------------- 1 file changed, 25 insertions(+), 17 deletions(-) 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) From f5789c7c6f66758c99343a721f1c996dd4c44f2b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 24 Jun 2015 02:02:26 +0900 Subject: [PATCH 081/125] added c functions to define private varaibles. see discussion on #271 --- extlib/benz/include/picrin.h | 4 ++++ extlib/benz/vm.c | 27 +++++++++++++++++++++++---- 2 files changed, 27 insertions(+), 4 deletions(-) diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index e5419c24..c1b16cd9 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -193,6 +193,10 @@ void pic_load_cstr(pic_state *, const char *); 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); diff --git a/extlib/benz/vm.c b/extlib/benz/vm.c index 6989c465..f661f10a 100644 --- a/extlib/benz/vm.c +++ b/extlib/benz/vm.c @@ -1137,7 +1137,7 @@ pic_defun_vm(pic_state *pic, const char *name, pic_sym *uid, pic_func_t func) } void -pic_define(pic_state *pic, const char *name, pic_value val) +pic_define_(pic_state *pic, const char *name, pic_value val) { pic_sym *sym, *uid; @@ -1150,20 +1150,39 @@ pic_define(pic_state *pic, const char *name, pic_value val) } pic_dict_set(pic, pic->globals, uid, val); +} - pic_export(pic, sym); +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, 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, name))); + 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_define(pic, name, pic_obj_value(pic_make_var(pic, init, conv))); + pic_defvar_(pic, name, init, conv); + pic_export(pic, pic_intern_cstr(pic, name)); } pic_value From 0daa4febb002643bdf1c62dee388b688121aa01d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 24 Jun 2015 02:17:13 +0900 Subject: [PATCH 082/125] fix #270 --- extlib/benz/port.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extlib/benz/port.c b/extlib/benz/port.c index 5e75a464..f702be55 100644 --- a/extlib/benz/port.c +++ b/extlib/benz/port.c @@ -108,7 +108,8 @@ pic_open_file(pic_state *pic, const char *name, int flags) { mode = 'w'; } if ((file = file_open(pic, name, &mode)) == NULL) { - pic_errorf(pic, "could not open file '%s'", name); + 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()))); } port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); From f323e9d232b9e0e425b16edf1f57569e65b0f888 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 24 Jun 2015 16:02:46 +0900 Subject: [PATCH 083/125] [bugfix] call/cc will get caught in an infinite loop if the machine stack grows upward --- contrib/10.callcc/callcc.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/contrib/10.callcc/callcc.c b/contrib/10.callcc/callcc.c index 22287fea..2e2561fe 100644 --- a/contrib/10.callcc/callcc.c +++ b/contrib/10.callcc/callcc.c @@ -178,7 +178,7 @@ 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->cc = cont->prev_jmp; From f836c4db47939bffd79a6fb281ef9f175667240b Mon Sep 17 00:00:00 2001 From: OGINO Masanori Date: Wed, 24 Jun 2015 18:44:44 +0900 Subject: [PATCH 084/125] Correct visibility of symbols in (srfi 106). Signed-off-by: OGINO Masanori --- contrib/40.srfi/src/106.c | 100 +++++++++++++++++++------------------- 1 file changed, 50 insertions(+), 50 deletions(-) diff --git a/contrib/40.srfi/src/106.c b/contrib/40.srfi/src/106.c index c90f5c9a..e31831a2 100644 --- a/contrib/40.srfi/src/106.c +++ b/contrib/40.srfi/src/106.c @@ -400,122 +400,122 @@ 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); + pic_defun_(pic, "socket?", pic_socket_socket_p); + pic_defun_(pic, "make-socket", pic_socket_make_socket); + pic_defun_(pic, "socket-accept", pic_socket_socket_accept); + pic_defun_(pic, "socket-send", pic_socket_socket_send); + pic_defun_(pic, "socket-recv", pic_socket_socket_recv); + pic_defun_(pic, "socket-shutdown", pic_socket_socket_shutdown); + pic_defun_(pic, "socket-close", pic_socket_socket_close); + pic_defun_(pic, "socket-input-port", pic_socket_socket_input_port); + pic_defun_(pic, "socket-output-port", pic_socket_socket_output_port); + pic_defun_(pic, "call-with-socket", pic_socket_call_with_socket); #ifdef AF_INET - pic_define(pic, "*af-inet*", pic_int_value(AF_INET)); + pic_define_(pic, "*af-inet*", pic_int_value(AF_INET)); #else - pic_define(pic, "*af-inet*", pic_false_value()); + pic_define_(pic, "*af-inet*", pic_false_value()); #endif #ifdef AF_INET6 - pic_define(pic, "*af-inet6*", pic_int_value(AF_INET6)); + pic_define_(pic, "*af-inet6*", pic_int_value(AF_INET6)); #else - pic_define(pic, "*af-inet6*", pic_false_value()); + pic_define_(pic, "*af-inet6*", pic_false_value()); #endif #ifdef AF_UNSPEC - pic_define(pic, "*af-unspec*", pic_int_value(AF_UNSPEC)); + pic_define_(pic, "*af-unspec*", pic_int_value(AF_UNSPEC)); #else - pic_define(pic, "*af-unspec*", pic_false_value()); + pic_define_(pic, "*af-unspec*", pic_false_value()); #endif #ifdef SOCK_STREAM - pic_define(pic, "*sock-stream*", pic_int_value(SOCK_STREAM)); + pic_define_(pic, "*sock-stream*", pic_int_value(SOCK_STREAM)); #else - pic_define(pic, "*sock-stream*", pic_false_value()); + pic_define_(pic, "*sock-stream*", pic_false_value()); #endif #ifdef SOCK_DGRAM - pic_define(pic, "*sock-dgram*", pic_int_value(SOCK_DGRAM)); + pic_define_(pic, "*sock-dgram*", pic_int_value(SOCK_DGRAM)); #else - pic_define(pic, "*sock-dgram*", pic_false_value()); + pic_define_(pic, "*sock-dgram*", pic_false_value()); #endif #ifdef AI_CANONNAME - pic_define(pic, "*ai-canonname*", pic_int_value(AI_CANONNAME)); + pic_define_(pic, "*ai-canonname*", pic_int_value(AI_CANONNAME)); #else - pic_define(pic, "*ai-canonname*", pic_false_value()); + pic_define_(pic, "*ai-canonname*", pic_false_value()); #endif #ifdef AI_NUMERICHOST - pic_define(pic, "*ai-numerichost*", pic_int_value(AI_NUMERICHOST)); + pic_define_(pic, "*ai-numerichost*", pic_int_value(AI_NUMERICHOST)); #else - pic_define(pic, "*ai-numerichost*", pic_false_value()); + 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)); + pic_define_(pic, "*ai-v4mapped*", pic_int_value(AI_V4MAPPED)); #else - pic_define(pic, "*ai-v4mapped*", pic_false_value()); + 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)); + pic_define_(pic, "*ai-all*", pic_int_value(AI_ALL)); #else - pic_define(pic, "*ai-all*", pic_false_value()); + pic_define_(pic, "*ai-all*", pic_false_value()); #endif #ifdef AI_ADDRCONFIG - pic_define(pic, "*ai-addrconfig*", pic_int_value(AI_ADDRCONFIG)); + pic_define_(pic, "*ai-addrconfig*", pic_int_value(AI_ADDRCONFIG)); #else - pic_define(pic, "*ai-addrconfig*", pic_false_value()); + pic_define_(pic, "*ai-addrconfig*", pic_false_value()); #endif #ifdef AI_PASSIVE - pic_define(pic, "*ai-passive*", pic_int_value(AI_PASSIVE)); + pic_define_(pic, "*ai-passive*", pic_int_value(AI_PASSIVE)); #else - pic_define(pic, "*ai-passive*", pic_false_value()); + pic_define_(pic, "*ai-passive*", pic_false_value()); #endif #ifdef IPPROTO_IP - pic_define(pic, "*ipproto-ip*", pic_int_value(IPPROTO_IP)); + pic_define_(pic, "*ipproto-ip*", pic_int_value(IPPROTO_IP)); #else - pic_define(pic, "*ipproto-ip*", pic_false_value()); + pic_define_(pic, "*ipproto-ip*", pic_false_value()); #endif #ifdef IPPROTO_TCP - pic_define(pic, "*ipproto-tcp*", pic_int_value(IPPROTO_TCP)); + pic_define_(pic, "*ipproto-tcp*", pic_int_value(IPPROTO_TCP)); #else - pic_define(pic, "*ipproto-tcp*", pic_false_value()); + pic_define_(pic, "*ipproto-tcp*", pic_false_value()); #endif #ifdef IPPROTO_UDP - pic_define(pic, "*ipproto-udp*", pic_int_value(IPPROTO_UDP)); + pic_define_(pic, "*ipproto-udp*", pic_int_value(IPPROTO_UDP)); #else - pic_define(pic, "*ipproto-udp*", pic_false_value()); + pic_define_(pic, "*ipproto-udp*", pic_false_value()); #endif #ifdef MSG_PEEK - pic_define(pic, "*msg-peek*", pic_int_value(MSG_PEEK)); + pic_define_(pic, "*msg-peek*", pic_int_value(MSG_PEEK)); #else - pic_define(pic, "*msg-peek*", pic_false_value()); + pic_define_(pic, "*msg-peek*", pic_false_value()); #endif #ifdef MSG_OOB - pic_define(pic, "*msg-oob*", pic_int_value(MSG_OOB)); + pic_define_(pic, "*msg-oob*", pic_int_value(MSG_OOB)); #else - pic_define(pic, "*msg-oob*", pic_false_value()); + pic_define_(pic, "*msg-oob*", pic_false_value()); #endif #ifdef MSG_WAITALL - pic_define(pic, "*msg-waitall*", pic_int_value(MSG_WAITALL)); + pic_define_(pic, "*msg-waitall*", pic_int_value(MSG_WAITALL)); #else - pic_define(pic, "*msg-waitall*", pic_false_value()); + pic_define_(pic, "*msg-waitall*", pic_false_value()); #endif #ifdef SHUT_RD - pic_define(pic, "*shut-rd*", pic_int_value(SHUT_RD)); + pic_define_(pic, "*shut-rd*", pic_int_value(SHUT_RD)); #else - pic_define(pic, "*shut-rd*", pic_false_value()); + pic_define_(pic, "*shut-rd*", pic_false_value()); #endif #ifdef SHUT_WR - pic_define(pic, "*shut-wr*", pic_int_value(SHUT_WR)); + pic_define_(pic, "*shut-wr*", pic_int_value(SHUT_WR)); #else - pic_define(pic, "*shut-wr*", pic_false_value()); + pic_define_(pic, "*shut-wr*", pic_false_value()); #endif #ifdef SHUT_RDWR - pic_define(pic, "*shut-rdwr*", pic_int_value(SHUT_RDWR)); + pic_define_(pic, "*shut-rdwr*", pic_int_value(SHUT_RDWR)); #else - pic_define(pic, "*shut-rdwr*", pic_false_value()); + pic_define_(pic, "*shut-rdwr*", pic_false_value()); #endif } } From 5cf18228130e8116d060858c1f8302d9f9d07b58 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Jun 2015 05:56:15 +0900 Subject: [PATCH 085/125] use khash for dictionary impl --- extlib/benz/codegen.c | 2 +- extlib/benz/dict.c | 124 ++++++------ extlib/benz/gc.c | 4 +- extlib/benz/include/picrin.h | 1 + extlib/benz/include/picrin/dict.h | 12 +- extlib/benz/include/picrin/khash.h | 304 +++++++++++++++++++++++++++++ extlib/benz/lib.c | 4 +- extlib/benz/write.c | 3 +- 8 files changed, 386 insertions(+), 68 deletions(-) create mode 100644 extlib/benz/include/picrin/khash.h diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 721505a8..ae3688d8 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -363,7 +363,7 @@ new_analyze_state(pic_state *pic) { analyze_state *state; pic_sym *sym; - xh_entry *it; + khiter_t it; state = pic_malloc(pic, sizeof(analyze_state)); state->pic = pic; diff --git a/extlib/benz/dict.c b/extlib/benz/dict.c index 41a4fea9..2e019f87 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(); } @@ -239,7 +247,7 @@ pic_dict_dictionary_to_alist(pic_state *pic) struct pic_dict *dict; pic_value item, alist = pic_nil_value(); pic_sym *sym; - xh_entry *it; + khiter_t it; pic_get_args(pic, "d", &dict); @@ -275,7 +283,7 @@ pic_dict_dictionary_to_plist(pic_state *pic) struct pic_dict *dict; pic_value plist = pic_nil_value(); pic_sym *sym; - xh_entry *it; + khiter_t it; pic_get_args(pic, "d", &dict); diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index adf449ec..db86c873 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -452,7 +452,7 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) case PIC_TT_DICT: { struct pic_dict *dict = (struct pic_dict *)obj; pic_sym *sym; - xh_entry *it; + khiter_t it; pic_dict_for_each (sym, dict, it) { gc_mark_object(pic, (struct pic_object *)sym); @@ -707,7 +707,7 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) } 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: { diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index 54c8bf14..ef164f3a 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -36,6 +36,7 @@ extern "C" { #include "picrin/compat.h" #include "picrin/kvec.h" +#include "picrin/khash.h" #include "picrin/xhash.h" #include "picrin/value.h" 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/khash.h b/extlib/benz/include/picrin/khash.h new file mode 100644 index 00000000..b5416f1d --- /dev/null +++ b/extlib/benz/include/picrin/khash.h @@ -0,0 +1,304 @@ +/* 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 +#include + +/* compiler specific configuration */ + +#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_fsize(m) ((m) < 16? 1 : (m)>>4) + +#ifndef kroundup32 +#define kroundup32(x) (--(x), (x)|=(x)>>1, (x)|=(x)>>2, (x)|=(x)>>4, (x)|=(x)>>8, (x)|=(x)>>16, ++(x)) +#endif + +#ifndef kcalloc +#define kcalloc(N,Z) calloc(N,Z) +#endif +#ifndef kmalloc +#define kmalloc(Z) malloc(Z) +#endif +#ifndef krealloc +#define krealloc(P,Z) realloc(P,Z) +#endif +#ifndef kfree +#define kfree(P) free(P) +#endif + +static const double __ac_HASH_UPPER = 0.77; + +#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(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); \ + int kh_resize_##name(kh_##name##_t *h, khint_t new_n_buckets); \ + khint_t kh_put_##name(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(kh_##name##_t *h) \ + { \ + kfree((void *)h->keys); kfree(h->flags); \ + kfree((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; \ + } \ + int kh_resize_##name(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; \ + { \ + kroundup32(new_n_buckets); \ + if (new_n_buckets < 4) new_n_buckets = 4; \ + if (h->size >= (khint_t)(new_n_buckets * __ac_HASH_UPPER + 0.5)) j = 0; /* requested size is too small */ \ + else { /* hash table size to be changed (shrink or expand); rehash */ \ + new_flags = (khint32_t*)kmalloc(__ac_fsize(new_n_buckets) * sizeof(khint32_t)); \ + if (!new_flags) return -1; \ + memset(new_flags, 0xaa, __ac_fsize(new_n_buckets) * sizeof(khint32_t)); \ + if (h->n_buckets < new_n_buckets) { /* expand */ \ + khkey_t *new_keys = (khkey_t*)krealloc((void *)h->keys, new_n_buckets * sizeof(khkey_t)); \ + if (!new_keys) { kfree(new_flags); return -1; } \ + h->keys = new_keys; \ + if (kh_is_map) { \ + khval_t *new_vals = (khval_t*)krealloc((void *)h->vals, new_n_buckets * sizeof(khval_t)); \ + if (!new_vals) { kfree(new_flags); return -1; } \ + h->vals = new_vals; \ + } \ + } /* 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 = (khkey_t*)krealloc((void *)h->keys, new_n_buckets * sizeof(khkey_t)); \ + if (kh_is_map) h->vals = (khval_t*)krealloc((void *)h->vals, new_n_buckets * sizeof(khval_t)); \ + } \ + kfree(h->flags); /* free the working space */ \ + h->flags = new_flags; \ + h->n_buckets = new_n_buckets; \ + h->n_occupied = h->size; \ + h->upper_bound = (khint_t)(h->n_buckets * __ac_HASH_UPPER + 0.5); \ + } \ + return 0; \ + } \ + khint_t kh_put_##name(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)) { \ + if (kh_resize_##name(h, h->n_buckets - 1) < 0) { /* clear "deleted" elements */ \ + *ret = -1; return h->n_buckets; \ + } \ + } else if (kh_resize_##name(h, h->n_buckets + 1) < 0) { /* expand the hash table */ \ + *ret = -1; return h->n_buckets; \ + } \ + } /* 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)) +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; +} +#define kh_str_hash_func(key) __ac_X31_hash_string(key) +#define kh_str_hash_equal(a, b) (strcmp(a, b) == 0) + +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 kh_int_hash_func2(k) __ac_Wang_hash((khint_t)key) + +/* --- END OF HASH FUNCTIONS --- */ + +/* Other convenient macros... */ + +#define khash_t(name) kh_##name##_t +#define kh_init(name, h) kh_init_##name(h) +#define kh_destroy(name, h) kh_destroy_##name(h) +#define kh_clear(name, h) kh_clear_##name(h) +#define kh_resize(name, h, s) kh_resize_##name(h, s) +#define kh_put(name, h, k, r) kh_put_##name(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) + +#define kh_foreach(h, kvar, vvar, code) { khint_t __i; \ + for (__i = kh_begin(h); __i != kh_end(h); ++__i) { \ + if (!kh_exist(h,__i)) continue; \ + (kvar) = kh_key(h,__i); \ + (vvar) = kh_val(h,__i); \ + code; \ + } } +#define kh_foreach_value(h, vvar, code) { khint_t __i; \ + for (__i = kh_begin(h); __i != kh_end(h); ++__i) { \ + if (!kh_exist(h,__i)) continue; \ + (vvar) = kh_val(h,__i); \ + code; \ + } } + +#endif /* AC_KHASH_H */ diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index 227eea7f..53cf51d6 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -58,7 +58,7 @@ void pic_import(pic_state *pic, struct pic_lib *lib) { pic_sym *name, *realname, *uid; - xh_entry *it; + khiter_t it; pic_dict_for_each (name, lib->exports, it) { realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, name)); @@ -173,7 +173,7 @@ pic_lib_library_exports(pic_state *pic) { pic_value lib, exports = pic_nil_value(); pic_sym *sym; - xh_entry *it; + khiter_t it; pic_get_args(pic, "o", &lib); diff --git a/extlib/benz/write.c b/extlib/benz/write.c index c5ba08bb..39bc4058 100644 --- a/extlib/benz/write.c +++ b/extlib/benz/write.c @@ -170,7 +170,8 @@ write_core(struct writer_control *p, pic_value obj) xFILE *file = p->file; size_t i; pic_sym *sym; - xh_entry *e, *it; + xh_entry *e; + khiter_t it; int c; #if PIC_ENABLE_FLOAT double f; From 6b15304d856ab82270493260f49fc5c236624a4e Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Jun 2015 05:56:47 +0900 Subject: [PATCH 086/125] [bugfix] ptable consists of registers --- extlib/benz/state.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 141f76ec..558f4ba6 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -365,7 +365,7 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) 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)")); From 2e1280ce5ced6503a050b8e311c53ae010ee9630 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Jun 2015 06:12:53 +0900 Subject: [PATCH 087/125] don't use malloc/realloc/free in khash.h --- extlib/benz/include/picrin/khash.h | 195 ++++++++++++----------------- 1 file changed, 79 insertions(+), 116 deletions(-) diff --git a/extlib/benz/include/picrin/khash.h b/extlib/benz/include/picrin/khash.h index b5416f1d..e8a70714 100644 --- a/extlib/benz/include/picrin/khash.h +++ b/extlib/benz/include/picrin/khash.h @@ -27,11 +27,8 @@ #ifndef AC_KHASH_H #define AC_KHASH_H -#include #include -/* compiler specific configuration */ - #if UINT_MAX == 0xffffffffu typedef unsigned int khint32_t; #elif ULONG_MAX == 0xffffffffu @@ -47,34 +44,36 @@ typedef unsigned long long khint64_t; 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_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_fsize(m) ((m) < 16? 1 : (m)>>4) +#define ac_roundup32(x) \ + (--(x), (x)|=(x)>>1, (x)|=(x)>>2, (x)|=(x)>>4, (x)|=(x)>>8, (x)|=(x)>>16, ++(x)) -#ifndef kroundup32 -#define kroundup32(x) (--(x), (x)|=(x)>>1, (x)|=(x)>>2, (x)|=(x)>>4, (x)|=(x)>>8, (x)|=(x)>>16, ++(x)) -#endif +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; +} -#ifndef kcalloc -#define kcalloc(N,Z) calloc(N,Z) -#endif -#ifndef kmalloc -#define kmalloc(Z) malloc(Z) -#endif -#ifndef krealloc -#define krealloc(P,Z) realloc(P,Z) -#endif -#ifndef kfree -#define kfree(P) free(P) -#endif - -static const double __ac_HASH_UPPER = 0.77; +#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 { \ @@ -84,28 +83,29 @@ static const double __ac_HASH_UPPER = 0.77; khval_t *vals; \ } kh_##name##_t; \ void kh_init_##name(kh_##name##_t *h); \ - void kh_destroy_##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); \ - int kh_resize_##name(kh_##name##_t *h, khint_t new_n_buckets); \ - khint_t kh_put_##name(kh_##name##_t *h, khkey_t key, int *ret); \ + int 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) \ +#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(kh_##name##_t *h) \ + void kh_destroy_##name(pic_state *pic, kh_##name##_t *h) \ { \ - kfree((void *)h->keys); kfree(h->flags); \ - kfree((void *)h->vals); \ + 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)); \ + memset(h->flags, 0xaa, ac_fsize(h->n_buckets) * sizeof(khint32_t)); \ h->size = h->n_occupied = 0; \ } \ } \ @@ -114,58 +114,54 @@ static const double __ac_HASH_UPPER = 0.77; if (h->n_buckets) { \ khint_t k, i, last, mask, step = 0; \ mask = h->n_buckets - 1; \ - k = __hash_func(key); i = k & mask; \ + 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))) { \ + 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; \ + return ac_iseither(h->flags, i)? h->n_buckets : i; \ } else return 0; \ } \ - int kh_resize_##name(kh_##name##_t *h, khint_t new_n_buckets) \ + int 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; \ { \ - kroundup32(new_n_buckets); \ + ac_roundup32(new_n_buckets); \ if (new_n_buckets < 4) new_n_buckets = 4; \ - if (h->size >= (khint_t)(new_n_buckets * __ac_HASH_UPPER + 0.5)) j = 0; /* requested size is too small */ \ + 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 = (khint32_t*)kmalloc(__ac_fsize(new_n_buckets) * sizeof(khint32_t)); \ + new_flags = pic_malloc(pic, ac_fsize(new_n_buckets) * sizeof(khint32_t)); \ if (!new_flags) return -1; \ - memset(new_flags, 0xaa, __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 */ \ - khkey_t *new_keys = (khkey_t*)krealloc((void *)h->keys, new_n_buckets * sizeof(khkey_t)); \ - if (!new_keys) { kfree(new_flags); return -1; } \ - h->keys = new_keys; \ + h->keys = pic_realloc(pic, (void *)h->keys, new_n_buckets * sizeof(khkey_t)); \ if (kh_is_map) { \ - khval_t *new_vals = (khval_t*)krealloc((void *)h->vals, new_n_buckets * sizeof(khval_t)); \ - if (!new_vals) { kfree(new_flags); return -1; } \ - h->vals = new_vals; \ + 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) { \ + 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); \ + 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); \ + 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 */ \ + 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 */ \ + 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; \ @@ -175,54 +171,54 @@ static const double __ac_HASH_UPPER = 0.77; } \ } \ if (h->n_buckets > new_n_buckets) { /* shrink the hash table */ \ - h->keys = (khkey_t*)krealloc((void *)h->keys, new_n_buckets * sizeof(khkey_t)); \ - if (kh_is_map) h->vals = (khval_t*)krealloc((void *)h->vals, new_n_buckets * sizeof(khval_t)); \ + 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)); \ } \ - kfree(h->flags); /* free the working space */ \ + 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 = (khint_t)(h->n_buckets * __ac_HASH_UPPER + 0.5); \ + h->upper_bound = ac_hash_upper(h->n_buckets); \ } \ return 0; \ } \ - khint_t kh_put_##name(kh_##name##_t *h, khkey_t key, int *ret) \ + 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)) { \ - if (kh_resize_##name(h, h->n_buckets - 1) < 0) { /* clear "deleted" elements */ \ + if (kh_resize_##name(pic, h, h->n_buckets - 1) < 0) { /* clear "deleted" elements */ \ *ret = -1; return h->n_buckets; \ } \ - } else if (kh_resize_##name(h, h->n_buckets + 1) < 0) { /* expand the hash table */ \ + } else if (kh_resize_##name(pic, h, h->n_buckets + 1) < 0) { /* expand the hash table */ \ *ret = -1; return h->n_buckets; \ } \ } /* 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 */ \ + 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; \ + 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; \ + 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 */ \ + if (ac_isempty(h->flags, x)) { /* not present at all */ \ h->keys[x] = key; \ - __ac_set_isboth_false(h->flags, x); \ + ac_set_isboth_false(h->flags, x); \ ++h->size; ++h->n_occupied; \ *ret = 1; \ - } else if (__ac_isdel(h->flags, x)) { /* deleted */ \ + } else if (ac_isdel(h->flags, x)) { /* deleted */ \ h->keys[x] = key; \ - __ac_set_isboth_false(h->flags, x); \ + 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 */ \ @@ -230,8 +226,8 @@ static const double __ac_HASH_UPPER = 0.77; } \ 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); \ + if (x != h->n_buckets && !ac_iseither(h->flags, x)) { \ + ac_set_isdel_true(h->flags, x); \ --h->size; \ } \ } @@ -244,41 +240,22 @@ static const double __ac_HASH_UPPER = 0.77; #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)) -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; -} -#define kh_str_hash_func(key) __ac_X31_hash_string(key) +#define kh_str_hash_func(key) ac_X31_hash_string(key) #define kh_str_hash_equal(a, b) (strcmp(a, b) == 0) - -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 kh_int_hash_func2(k) __ac_Wang_hash((khint_t)key) +#define kh_int_hash_func2(k) ac_Wang_hash((khint_t)key) /* --- END OF HASH FUNCTIONS --- */ -/* Other convenient macros... */ - #define khash_t(name) kh_##name##_t #define kh_init(name, h) kh_init_##name(h) -#define kh_destroy(name, h) kh_destroy_##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(h, s) -#define kh_put(name, h, k, r) kh_put_##name(h, k, r) +#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_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]) @@ -287,18 +264,4 @@ PIC_INLINE khint_t __ac_Wang_hash(khint_t key) #define kh_size(h) ((h)->size) #define kh_n_buckets(h) ((h)->n_buckets) -#define kh_foreach(h, kvar, vvar, code) { khint_t __i; \ - for (__i = kh_begin(h); __i != kh_end(h); ++__i) { \ - if (!kh_exist(h,__i)) continue; \ - (kvar) = kh_key(h,__i); \ - (vvar) = kh_val(h,__i); \ - code; \ - } } -#define kh_foreach_value(h, vvar, code) { khint_t __i; \ - for (__i = kh_begin(h); __i != kh_end(h); ++__i) { \ - if (!kh_exist(h,__i)) continue; \ - (vvar) = kh_val(h,__i); \ - code; \ - } } - #endif /* AC_KHASH_H */ From d6edf4130506e3d975ab18d83710551c57c451a0 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Jun 2015 06:39:13 +0900 Subject: [PATCH 088/125] kh_resize operation never fail --- extlib/benz/include/picrin/khash.h | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/extlib/benz/include/picrin/khash.h b/extlib/benz/include/picrin/khash.h index e8a70714..78d0feef 100644 --- a/extlib/benz/include/picrin/khash.h +++ b/extlib/benz/include/picrin/khash.h @@ -86,7 +86,7 @@ PIC_INLINE khint_t ac_Wang_hash(khint_t key) 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); \ - int kh_resize_##name(pic_state *, kh_##name##_t *h, khint_t new_n_buckets); \ + 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); @@ -123,7 +123,7 @@ PIC_INLINE khint_t ac_Wang_hash(khint_t key) return ac_iseither(h->flags, i)? h->n_buckets : i; \ } else return 0; \ } \ - int kh_resize_##name(pic_state *pic, kh_##name##_t *h, khint_t new_n_buckets) \ + void kh_resize_##name(pic_state *pic, kh_##name##_t *h, 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; \ @@ -133,7 +133,6 @@ PIC_INLINE khint_t ac_Wang_hash(khint_t key) 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)); \ - if (!new_flags) return -1; \ 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)); \ @@ -180,18 +179,15 @@ PIC_INLINE khint_t ac_Wang_hash(khint_t key) h->n_occupied = h->size; \ h->upper_bound = ac_hash_upper(h->n_buckets); \ } \ - return 0; \ } \ 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)) { \ - if (kh_resize_##name(pic, h, h->n_buckets - 1) < 0) { /* clear "deleted" elements */ \ - *ret = -1; return h->n_buckets; \ - } \ - } else if (kh_resize_##name(pic, h, h->n_buckets + 1) < 0) { /* expand the hash table */ \ - *ret = -1; return h->n_buckets; \ + 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 */ \ { \ From 03a649ed23eb5c9c51d3973185377a1fafd6a6e2 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Jun 2015 06:44:45 +0900 Subject: [PATCH 089/125] use khash in equal? impl --- extlib/benz/bool.c | 119 ++++++++++++++++++++------------------------- 1 file changed, 54 insertions(+), 65 deletions(-) diff --git a/extlib/benz/bool.c b/extlib/benz/bool.c index 64fbd944..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,19 +94,11 @@ 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; } - case PIC_TT_ID: { - struct pic_id *id1, *id2; - - 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); - } default: return false; } @@ -120,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 From 0fb87449fc3e036be5f4ead4073c27f03f71e46d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Jun 2015 07:05:41 +0900 Subject: [PATCH 090/125] use khash for pic->syms --- extlib/benz/gc.c | 21 ++++++++++++--------- extlib/benz/include/picrin.h | 4 +++- extlib/benz/state.c | 17 ++++++++++------- extlib/benz/symbol.c | 16 +++++++++++----- 4 files changed, 36 insertions(+), 22 deletions(-) diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index db86c873..cbbf5253 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -741,16 +741,19 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) static void gc_sweep_symbols(pic_state *pic) { - xh_entry *it; - char *cstr; + khash_t(s) *h = &pic->syms; + khiter_t it; + pic_sym *sym; + const char *cstr; - 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 *))) { - cstr = xh_key(it, char *); - - xh_del_str(&pic->syms, cstr); - - pic_free(pic, cstr); + 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)) { + cstr = kh_key(h, it); + kh_del(s, h, it); + pic_free(pic, (void *)cstr); } } } diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index 5f6474d6..feac5362 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -48,6 +48,8 @@ typedef struct pic_state pic_state; #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; @@ -125,7 +127,7 @@ struct pic_state { 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; diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 558f4ba6..6c4fe6b8 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -224,7 +224,7 @@ 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; @@ -399,13 +399,17 @@ 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; + khiter_t it; pic_allocf allocf = pic->allocf; - /* free symbol names */ - for (it = xh_begin(&pic->syms); it != NULL; it = xh_next(it)) { - allocf(xh_key(it, char *), 0); + /* free all symbols */ + for (it = kh_begin(h); it != kh_end(h); ++it) { + if (kh_exist(h, it)) { + allocf((void *)kh_key(h, it), 0); + } } + kh_clear(s, h); /* clear out root objects */ pic->sp = pic->stbase; @@ -416,7 +420,6 @@ 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(); @@ -438,7 +441,7 @@ pic_close(pic_state *pic) allocf(pic->xpbase, 0); /* free global stacks */ - xh_destroy(&pic->syms); + kh_destroy(s, h); /* free GC arena */ allocf(pic->arena, 0); diff --git a/extlib/benz/symbol.c b/extlib/benz/symbol.c index ce70edb0..160d71ff 100644 --- a/extlib/benz/symbol.c +++ b/extlib/benz/symbol.c @@ -4,6 +4,8 @@ #include "picrin.h" +KHASH_DEFINE(s, const char *, pic_sym *, kh_str_hash_func, kh_str_hash_equal) + static pic_sym * pic_make_symbol(pic_state *pic, pic_str *str) { @@ -17,22 +19,26 @@ pic_make_symbol(pic_state *pic, pic_str *str) pic_sym * pic_intern(pic_state *pic, pic_str *str) { - xh_entry *e; + khash_t(s) *h = &pic->syms; pic_sym *sym; char *cstr; + khiter_t it; + int ret; - e = xh_get_str(&pic->syms, pic_str_cstr(pic, str)); - if (e) { - sym = xh_val(e, pic_sym *); + it = kh_put(s, h, pic_str_cstr(pic, str), &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)); + kh_key(h, it) = cstr; sym = pic_make_symbol(pic, str); - xh_put_str(&pic->syms, cstr, &sym); + kh_val(h, it) = sym; + return sym; } From 11ed51b23684431ad1876ac10f0d5492ad263ad7 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Jun 2015 07:14:29 +0900 Subject: [PATCH 091/125] use khash for registers --- extlib/benz/gc.c | 27 +++++++++++++++++---------- extlib/benz/include/picrin/reg.h | 4 +++- extlib/benz/reg.c | 31 +++++++++++++++++++++---------- 3 files changed, 41 insertions(+), 21 deletions(-) diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index cbbf5253..ff56d26d 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -622,16 +622,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; @@ -718,7 +722,7 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) } case PIC_TT_REG: { struct pic_reg *reg = (struct pic_reg *)obj; - xh_destroy(®->hash); + kh_destroy(reg, ®->hash); break; } case PIC_TT_CP: { @@ -813,14 +817,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/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/reg.c b/extlib/benz/reg.c index 7ba1499a..c5268b2e 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) { + khash_t(reg) *h = ®->hash; + khiter_t it; + + 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)); } - - xh_del_ptr(®->hash, key); + kh_del(reg, h, it); } From d500dd5d763723b80bf858d176f457ab8dbf8d8a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Jun 2015 07:19:11 +0900 Subject: [PATCH 092/125] don't use xhash in codegen --- extlib/benz/codegen.c | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index ae3688d8..daa2a234 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -1262,24 +1262,24 @@ create_activation(codegen_state *state) pic_state *pic = state->pic; codegen_context *cxt = state->cxt; size_t i, n; - xhash regs; size_t offset; + struct pic_reg *regs; - xh_init_ptr(®s, sizeof(size_t)); + regs = pic_make_reg(pic); offset = 1; for (i = 0; i < kv_size(cxt->args); ++i) { n = i + offset; - xh_put_ptr(®s, kv_A(cxt->args, i), &n); + pic_reg_set(pic, regs, kv_A(cxt->args, i), pic_size_value(n)); } offset += i; for (i = 0; i < kv_size(cxt->locals); ++i) { n = i + offset; - xh_put_ptr(®s, kv_A(cxt->locals, i), &n); + pic_reg_set(pic, regs, kv_A(cxt->locals, i), pic_size_value(n)); } for (i = 0; i < kv_size(cxt->captures); ++i) { - n = xh_val(xh_get_ptr(®s, kv_A(cxt->captures, i)), size_t); + n = (size_t)pic_int(pic_reg_ref(pic, regs, kv_A(cxt->captures, i))); if (n <= kv_size(cxt->args) || (cxt->varg && n == kv_size(cxt->args) + 1)) { /* copy arguments to capture variable area */ emit_i(state, OP_LREF, (int)n); @@ -1288,8 +1288,6 @@ create_activation(codegen_state *state) emit_n(state, OP_PUSHUNDEF); } } - - xh_destroy(®s); } static void From 5cbb44d6b823852b24db5f51e2c600330140a0bc Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Jun 2015 07:26:48 +0900 Subject: [PATCH 093/125] use khash for env --- extlib/benz/codegen.c | 7 ++++--- extlib/benz/gc.c | 13 ++++++++----- extlib/benz/include/picrin/macro.h | 4 +++- extlib/benz/macro.c | 17 ++++++++++++----- 4 files changed, 27 insertions(+), 14 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index daa2a234..3a0eb8c6 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -11,13 +11,14 @@ static pic_sym * lookup(pic_state PIC_UNUSED(*pic), pic_value var, struct pic_env *env) { - xh_entry *e; + khiter_t it; assert(pic_var_p(var)); while (env != NULL) { - if ((e = xh_get_ptr(&env->map, pic_ptr(var))) != NULL) { - return xh_val(e, pic_sym *); + it = kh_get(env, &env->map, pic_ptr(var)); + if (it != kh_end(&env->map)) { + return kh_val(&env->map, it); } env = env->up; } diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index ff56d26d..fd0b048e 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -405,14 +405,17 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) } case PIC_TT_ENV: { struct pic_env *env = (struct pic_env *)obj; - xh_entry *it; + khash_t(env) *h = &env->map; + khiter_t it; if (env->up) { gc_mark_object(pic, (struct pic_object *)env->up); } - for (it = xh_begin(&env->map); it != NULL; it = xh_next(it)) { - gc_mark_object(pic, xh_key(it, struct pic_object *)); - gc_mark_object(pic, xh_val(it, struct pic_object *)); + 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; } @@ -688,7 +691,7 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) } case PIC_TT_ENV: { struct pic_env *env = (struct pic_env *)obj; - xh_destroy(&env->map); + kh_destroy(env, &env->map); break; } case PIC_TT_LIB: { diff --git a/extlib/benz/include/picrin/macro.h b/extlib/benz/include/picrin/macro.h index f6baebbb..65b8e3bd 100644 --- a/extlib/benz/include/picrin/macro.h +++ b/extlib/benz/include/picrin/macro.h @@ -9,6 +9,8 @@ extern "C" { #endif +KHASH_DECLARE(env, void *, pic_sym *) + struct pic_id { PIC_OBJECT_HEADER pic_value var; @@ -17,7 +19,7 @@ struct pic_id { struct pic_env { PIC_OBJECT_HEADER - xhash map; + khash_t(env) map; struct pic_env *up; }; diff --git a/extlib/benz/macro.c b/extlib/benz/macro.c index 71b70a55..cac07fd5 100644 --- a/extlib/benz/macro.c +++ b/extlib/benz/macro.c @@ -4,6 +4,8 @@ #include "picrin.h" +KHASH_DEFINE(env, void *, pic_sym *, kh_ptr_hash_func, kh_ptr_hash_equal) + bool pic_var_p(pic_value obj) { @@ -30,7 +32,7 @@ pic_make_env(pic_state *pic, struct pic_env *up) env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV); env->up = up; - xh_init_ptr(&env->map, sizeof(pic_sym *)); + kh_init(env, &env->map); return env; } @@ -74,22 +76,27 @@ pic_add_variable(pic_state *pic, struct pic_env *env, pic_value var) void pic_put_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var, pic_sym *uid) { + khiter_t it; + int ret; + assert(pic_var_p(var)); - xh_put_ptr(&env->map, pic_ptr(var), &uid); + it = kh_put(env, &env->map, pic_ptr(var), &ret); + kh_val(&env->map, it) = uid; } pic_sym * pic_find_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var) { - xh_entry *e; + khiter_t it; assert(pic_var_p(var)); - if ((e = xh_get_ptr(&env->map, pic_ptr(var))) == NULL) { + it = kh_get(env, &env->map, pic_ptr(var)); + if (it == kh_end(&env->map)) { return NULL; } - return xh_val(e, pic_sym *); + return kh_val(&env->map, it); } static pic_value From 42794ebbffef6c69cf3c16cce1b982e0293e7570 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Jun 2015 07:34:10 +0900 Subject: [PATCH 094/125] use khash for reader --- extlib/benz/include/picrin/read.h | 4 +++- extlib/benz/read.c | 33 ++++++++++++++++--------------- 2 files changed, 20 insertions(+), 17 deletions(-) diff --git a/extlib/benz/include/picrin/read.h b/extlib/benz/include/picrin/read.h index d9b0bb6e..27c715bb 100644 --- a/extlib/benz/include/picrin/read.h +++ b/extlib/benz/include/picrin/read.h @@ -9,6 +9,8 @@ extern "C" { #endif +KHASH_DECLARE(read, int, pic_value) + typedef pic_value (*pic_reader_t)(pic_state *, struct pic_port *port, int c); typedef struct { @@ -16,7 +18,7 @@ typedef struct { 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; diff --git a/extlib/benz/read.c b/extlib/benz/read.c index bcadecaa..282775e8 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); @@ -639,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; + + 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); @@ -670,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); @@ -685,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; } @@ -697,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 @@ -832,7 +833,7 @@ pic_reader_init(pic_state *pic) int c; pic->reader.typecase = PIC_CASE_DEFAULT; - xh_init_int(&pic->reader.labels, sizeof(pic_value)); + kh_init(read, &pic->reader.labels); for (c = 0; c < 256; ++c) { pic->reader.table[c] = NULL; @@ -848,7 +849,7 @@ pic_reader_init(pic_state *pic) void pic_reader_destroy(pic_state *pic) { - xh_destroy(&pic->reader.labels); + kh_destroy(read, &pic->reader.labels); } pic_value From 9db8b33c61d99934c2533d33566a026e5bc53586 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Jun 2015 07:58:58 +0900 Subject: [PATCH 095/125] abandon xhash --- extlib/benz/include/picrin.h | 1 - extlib/benz/include/picrin/xhash.h | 416 ----------------------------- extlib/benz/write.c | 75 +++--- 3 files changed, 38 insertions(+), 454 deletions(-) delete mode 100644 extlib/benz/include/picrin/xhash.h diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index feac5362..e19ced8b 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -37,7 +37,6 @@ extern "C" { #include "picrin/compat.h" #include "picrin/kvec.h" #include "picrin/khash.h" -#include "picrin/xhash.h" #include "picrin/value.h" 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/write.c b/extlib/benz/write.c index 39bc4058..8eb08fd8 100644 --- a/extlib/benz/write.c +++ b/extlib/benz/write.c @@ -36,12 +36,17 @@ 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 */ + khash_t(l) labels; /* object -> int */ + khash_t(v) visited; /* object -> int */ int cnt; }; @@ -55,35 +60,36 @@ writer_control_init(struct writer_control *p, pic_state *pic, xFILE *file, int m p->file = file; p->mode = mode; 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) { - xh_entry *e; + pic_state *pic = p->pic; + khash_t(l) *h = &p->labels; + khiter_t it; size_t i; - int c; + int ret; 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); + it = kh_put(l, h, pic_obj_ptr(obj), &ret); + if (ret != 0) { + kh_val(h, it) = -1; } - else if (xh_val(e, int) == -1) { - c = p->cnt++; - xh_put_ptr(&p->labels, pic_obj_ptr(obj), &c); + else if (kh_val(h, it) == -1) { + kh_val(h, it) = p->cnt++; break; } else { @@ -112,8 +118,10 @@ static void write_pair(struct writer_control *p, struct pic_pair *pair) { pic_state *pic = p->pic; - xh_entry *e; - int c; + khash_t(l) *lh = &p->labels; + khash_t(v) *vh = &p->visited; + khiter_t it; + int ret; write_core(p, pair->car); @@ -123,18 +131,15 @@ 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) { + 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(pic, 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(pic, 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(pic, p->file, " "); @@ -167,29 +172,25 @@ 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; pic_sym *sym; - xh_entry *e; khiter_t it; - int c; + int ret; #if PIC_ENABLE_FLOAT double f; #endif /* 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(pic, 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(pic, 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)) { From 8f619fcc1804198c4e53bdba89cdb334cb9e2c7f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Jun 2015 15:38:23 +0900 Subject: [PATCH 096/125] add test case for #229 --- t/syntax-rules.scm | 40 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) create mode 100644 t/syntax-rules.scm 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) From dc71eba2966f5d51075030e8ef9aa0709c8dd00f Mon Sep 17 00:00:00 2001 From: OGINO Masanori Date: Thu, 25 Jun 2015 16:42:51 +0900 Subject: [PATCH 097/125] Refactor t/parameterize.scm with (picrin test). Signed-off-by: OGINO Masanori --- t/parameterize.scm | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) 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) From 3004f2106caee055a7476424e97b10f1069410d6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Jun 2015 17:19:34 +0900 Subject: [PATCH 098/125] write supports #' #` #, #,@ --- extlib/benz/write.c | 95 ++++++++++++++++++++------------------------- 1 file changed, 43 insertions(+), 52 deletions(-) diff --git a/extlib/benz/write.c b/extlib/benz/write.c index 8eb08fd8..b50206a3 100644 --- a/extlib/benz/write.c +++ b/extlib/benz/write.c @@ -4,38 +4,6 @@ #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) @@ -176,7 +144,7 @@ write_core(struct writer_control *p, pic_value obj) khash_t(v) *vh = &p->visited; xFILE *file = p->file; size_t i; - pic_sym *sym; + pic_sym *sym, *tag; khiter_t it; int ret; #if PIC_ENABLE_FLOAT @@ -207,25 +175,48 @@ write_core(struct writer_control *p, pic_value obj) xfprintf(pic, file, "#f"); break; case PIC_TT_PAIR: - if (is_quote(pic, obj)) { - xfprintf(pic, file, "'"); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - else if (is_unquote(pic, obj)) { - xfprintf(pic, file, ","); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - else if (is_unquote_splicing(pic, obj)) { - xfprintf(pic, file, ",@"); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - else if (is_quasiquote(pic, obj)) { - xfprintf(pic, file, "`"); - write_core(p, pic_list_ref(pic, obj, 1)); - break; + if (pic_pair_p(pic_cdr(pic, obj)) && pic_nil_p(pic_cddr(pic, obj)) && pic_sym_p(pic_car(pic, obj))) { + tag = pic_sym_ptr(pic_car(pic, obj)); + if (tag == pic->sQUOTE) { + xfprintf(pic, file, "'"); + write_core(p, pic_list_ref(pic, obj, 1)); + break; + } + else if (tag == pic->sUNQUOTE) { + xfprintf(pic, file, ","); + write_core(p, pic_list_ref(pic, obj, 1)); + break; + } + else if (tag == pic->sUNQUOTE_SPLICING) { + xfprintf(pic, file, ",@"); + write_core(p, pic_list_ref(pic, obj, 1)); + break; + } + else if (tag == pic->sQUASIQUOTE) { + xfprintf(pic, file, "`"); + write_core(p, pic_list_ref(pic, obj, 1)); + break; + } + else if (tag == pic->sSYNTAX_QUOTE) { + xfprintf(pic, file, "#'"); + write_core(p, pic_list_ref(pic, obj, 1)); + break; + } + else if (tag == pic->sSYNTAX_UNQUOTE) { + xfprintf(pic, file, "#,"); + write_core(p, pic_list_ref(pic, obj, 1)); + break; + } + else if (tag == pic->sSYNTAX_UNQUOTE_SPLICING) { + xfprintf(pic, file, "#,@"); + write_core(p, pic_list_ref(pic, obj, 1)); + break; + } + else if (tag == pic->sSYNTAX_QUASIQUOTE) { + xfprintf(pic, file, "#`"); + write_core(p, pic_list_ref(pic, obj, 1)); + break; + } } xfprintf(pic, file, "("); write_pair(p, pic_pair_ptr(obj)); From 37902d38f75cdc5b0b2a9584b9cde170cbe917e2 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Jun 2015 17:28:48 +0900 Subject: [PATCH 099/125] cleanup traverse_shared --- extlib/benz/write.c | 46 ++++++++++++++++++++++----------------------- 1 file changed, 23 insertions(+), 23 deletions(-) diff --git a/extlib/benz/write.c b/extlib/benz/write.c index b50206a3..2e370ac4 100644 --- a/extlib/benz/write.c +++ b/extlib/benz/write.c @@ -44,36 +44,36 @@ static void traverse_shared(struct writer_control *p, pic_value obj) { pic_state *pic = p->pic; - khash_t(l) *h = &p->labels; - khiter_t it; - size_t i; - int ret; switch (pic_type(obj)) { case PIC_TT_PAIR: - case PIC_TT_VECTOR: - it = kh_put(l, h, pic_obj_ptr(obj), &ret); - if (ret != 0) { - kh_val(h, it) = -1; - } - else if (kh_val(h, it) == -1) { - kh_val(h, it) = p->cnt++; - break; - } - else { - break; - } + case PIC_TT_VECTOR: { + khash_t(l) *h = &p->labels; + khiter_t it; + int ret; - 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]); + 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_shared(p, pic_car(pic, obj)); + traverse_shared(p, pic_cdr(pic, obj)); + } else { + /* vector */ + size_t i; + for (i = 0; i < pic_vec_ptr(obj)->len; ++i) { + traverse_shared(p, pic_vec_ptr(obj)->data[i]); + } } + } else if (kh_val(h, it) == -1) { + /* second time */ + kh_val(h, it) = p->cnt++; } break; + } default: /* pass */ break; From 032e40e963c0b2d76249b29820c2f2084a60bc29 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Jun 2015 17:50:20 +0900 Subject: [PATCH 100/125] cleanup write_core --- extlib/benz/write.c | 312 +++++++++++++++++++++++++------------------- 1 file changed, 178 insertions(+), 134 deletions(-) diff --git a/extlib/benz/write.c b/extlib/benz/write.c index 2e370ac4..9b799ca5 100644 --- a/extlib/benz/write.c +++ b/extlib/benz/write.c @@ -80,10 +80,79 @@ traverse_shared(struct writer_control *p, pic_value obj) } } +static void +write_blob(pic_state *pic, pic_blob *blob, xFILE *file) +{ + size_t i; + + 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, ")"); +} + +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) { pic_state *pic = p->pic; khash_t(l) *lh = &p->labels; @@ -113,7 +182,7 @@ write_pair(struct writer_control *p, struct pic_pair *pair) xfprintf(pic, p->file, " "); } - write_pair(p, pic_pair_ptr(pair->cdr)); + write_pair_help(p, pic_pair_ptr(pair->cdr)); return; } else { @@ -123,17 +192,91 @@ write_pair(struct writer_control *p, struct pic_pair *pair) } 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(pic, '\\', 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(pic, cstr[i], file); } + xfprintf(pic, file, "("); + write_pair_help(p, pair); + xfprintf(pic, file, ")"); +} + +static void +write_vec(struct writer_control *p, pic_vec *vec) +{ + pic_state *pic = p->pic; + xFILE *file = p->file; + size_t i; + + xfprintf(pic, file, "#("); + for (i = 0; i < vec->len; ++i) { + write_core(p, vec->data[i]); + if (i + 1 < vec->len) { + xfprintf(pic, file, " "); + } + } + xfprintf(pic, file, ")"); +} + +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 @@ -143,13 +286,8 @@ write_core(struct writer_control *p, pic_value obj) khash_t(l) *lh = &p->labels; khash_t(v) *vh = &p->visited; xFILE *file = p->file; - size_t i; - pic_sym *sym, *tag; khiter_t it; int ret; -#if PIC_ENABLE_FLOAT - double f; -#endif /* shared objects */ if (pic_vtype(obj) == PIC_VTYPE_HEAP && ((it = kh_get(l, lh, pic_ptr(obj))) != kh_end(lh)) && kh_val(lh, it) != -1) { @@ -169,136 +307,42 @@ write_core(struct writer_control *p, pic_value obj) xfprintf(pic, file, "()"); break; case PIC_TT_BOOL: - if (pic_true_p(obj)) - xfprintf(pic, file, "#t"); - else - xfprintf(pic, file, "#f"); + xfprintf(pic, file, pic_true_p(obj) ? "#t" : "#f"); break; - case PIC_TT_PAIR: - if (pic_pair_p(pic_cdr(pic, obj)) && pic_nil_p(pic_cddr(pic, obj)) && pic_sym_p(pic_car(pic, obj))) { - tag = pic_sym_ptr(pic_car(pic, obj)); - if (tag == pic->sQUOTE) { - xfprintf(pic, file, "'"); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - else if (tag == pic->sUNQUOTE) { - xfprintf(pic, file, ","); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - else if (tag == pic->sUNQUOTE_SPLICING) { - xfprintf(pic, file, ",@"); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - else if (tag == pic->sQUASIQUOTE) { - xfprintf(pic, file, "`"); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - else if (tag == pic->sSYNTAX_QUOTE) { - xfprintf(pic, file, "#'"); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - else if (tag == pic->sSYNTAX_UNQUOTE) { - xfprintf(pic, file, "#,"); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - else if (tag == pic->sSYNTAX_UNQUOTE_SPLICING) { - xfprintf(pic, file, "#,@"); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - else if (tag == pic->sSYNTAX_QUASIQUOTE) { - xfprintf(pic, file, "#`"); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - } - xfprintf(pic, file, "("); - write_pair(p, pic_pair_ptr(obj)); - xfprintf(pic, file, ")"); - break; - case PIC_TT_SYMBOL: - xfprintf(pic, file, "%s", pic_symbol_name(pic, pic_sym_ptr(obj))); - break; - case PIC_TT_CHAR: - if (p->mode == DISPLAY_MODE) { - xfputc(pic, pic_char(obj), file); - break; - } - switch (pic_char(obj)) { - default: xfprintf(pic, file, "#\\%c", pic_char(obj)); 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; - } - break; -#if PIC_ENABLE_FLOAT - case PIC_TT_FLOAT: - f = pic_float(obj); - 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", pic_float(obj)); - } - break; -#endif - case PIC_TT_INT: - xfprintf(pic, file, "%d", pic_int(obj)); + case PIC_TT_ID: + xfprintf(pic, file, "#", pic_symbol_name(pic, pic_var_name(pic, obj))); break; case PIC_TT_EOF: xfprintf(pic, file, "#.(eof-object)"); break; - case PIC_TT_STRING: - if (p->mode == DISPLAY_MODE) { - xfprintf(pic, file, "%s", pic_str_cstr(pic, pic_str_ptr(obj))); - break; - } - xfprintf(pic, file, "\""); - write_str(pic, pic_str_ptr(obj), file); - xfprintf(pic, file, "\""); + case PIC_TT_INT: + xfprintf(pic, file, "%d", pic_int(obj)); break; - case PIC_TT_VECTOR: - xfprintf(pic, 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(pic, file, " "); - } - } - xfprintf(pic, file, ")"); +#if PIC_ENABLE_FLOAT + case PIC_TT_FLOAT: + write_float(pic, pic_float(obj), file); + break; +#endif + case PIC_TT_SYMBOL: + xfprintf(pic, file, "%s", pic_symbol_name(pic, pic_sym_ptr(obj))); break; case PIC_TT_BLOB: - xfprintf(pic, file, "#u8("); - for (i = 0; i < pic_blob_ptr(obj)->len; ++i) { - xfprintf(pic, file, "%d", pic_blob_ptr(obj)->data[i]); - if (i + 1 < pic_blob_ptr(obj)->len) { - xfprintf(pic, file, " "); - } - } - xfprintf(pic, 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(pic, file, "#.(dictionary"); - pic_dict_for_each (sym, pic_dict_ptr(obj), it) { - xfprintf(pic, file, " '%s ", pic_symbol_name(pic, sym)); - write_core(p, pic_dict_ref(pic, pic_dict_ptr(obj), sym)); - } - xfprintf(pic, file, ")"); - break; - case PIC_TT_ID: - xfprintf(pic, file, "#", pic_symbol_name(pic, pic_var_name(pic, obj))); + write_dict(p, pic_dict_ptr(obj)); break; default: xfprintf(pic, file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj)); From cc9dd2aa30663401f610ea2cc59e6c73675f6b7f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Jun 2015 18:43:06 +0900 Subject: [PATCH 101/125] saner output from write No more insane output such as (#0=(1 2 3) #0#). --- extlib/benz/write.c | 90 ++++++++++++++++++++------------------------- 1 file changed, 40 insertions(+), 50 deletions(-) diff --git a/extlib/benz/write.c b/extlib/benz/write.c index 9b799ca5..33ad82f6 100644 --- a/extlib/benz/write.c +++ b/extlib/benz/write.c @@ -13,6 +13,7 @@ struct writer_control { pic_state *pic; xFILE *file; int mode; + int op; khash_t(l) labels; /* object -> int */ khash_t(v) visited; /* object -> int */ int cnt; @@ -21,12 +22,17 @@ struct writer_control { #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; kh_init(l, &p->labels); kh_init(v, &p->visited); @@ -45,6 +51,10 @@ traverse_shared(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: { @@ -68,6 +78,13 @@ traverse_shared(struct writer_control *p, pic_value obj) traverse_shared(p, pic_vec_ptr(obj)->data[i]); } } + + 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++; @@ -183,6 +200,13 @@ write_pair_help(struct writer_control *p, struct pic_pair *pair) } 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 { @@ -348,42 +372,21 @@ write_core(struct writer_control *p, pic_value 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 -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); - - traverse_shared(&p, obj); /* FIXME */ - - 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); + writer_control_init(&p, pic, file, mode, op); traverse_shared(&p, obj); @@ -392,19 +395,6 @@ write_shared(pic_state *pic, pic_value obj, xFILE *file) 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) @@ -415,7 +405,7 @@ pic_write(pic_state *pic, pic_value obj) pic_value pic_fwrite(pic_state *pic, pic_value obj, xFILE *file) { - write(pic, obj, file); + write(pic, obj, file, WRITE_MODE, OP_WRITE); xfflush(pic, file); return obj; } @@ -429,7 +419,7 @@ pic_display(pic_state *pic, pic_value obj) pic_value pic_fdisplay(pic_state *pic, pic_value obj, xFILE *file) { - display(pic, obj, file); + write(pic, obj, file, DISPLAY_MODE, OP_WRITE); xfflush(pic, file); return obj; } @@ -458,7 +448,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(); } @@ -469,7 +459,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(); } @@ -480,7 +470,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(); } @@ -491,7 +481,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(); } From b71c9dcbfffda2c4275036dcba5a271f41ef40ad Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Jun 2015 18:51:21 +0900 Subject: [PATCH 102/125] cosmetic changes --- extlib/benz/write.c | 103 ++++++++++++++++++++++---------------------- 1 file changed, 51 insertions(+), 52 deletions(-) diff --git a/extlib/benz/write.c b/extlib/benz/write.c index 33ad82f6..a7da49e6 100644 --- a/extlib/benz/write.c +++ b/extlib/benz/write.c @@ -46,57 +46,6 @@ writer_control_destroy(struct writer_control *p) kh_destroy(v, &p->visited); } -static void -traverse_shared(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: { - 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_shared(p, pic_car(pic, obj)); - traverse_shared(p, pic_cdr(pic, obj)); - } else { - /* vector */ - size_t i; - for (i = 0; i < pic_vec_ptr(obj)->len; ++i) { - traverse_shared(p, pic_vec_ptr(obj)->data[i]); - } - } - - 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: - /* pass */ - break; - } -} - static void write_blob(pic_state *pic, pic_blob *blob, xFILE *file) { @@ -381,6 +330,56 @@ write_core(struct writer_control *p, pic_value obj) } } +static void +traverse(struct writer_control *p, pic_value obj) +{ + pic_state *pic = p->pic; + + if (p->op == OP_WRITE_SIMPLE) { + return; + } + + switch (pic_type(obj)) { + case PIC_TT_PAIR: + case PIC_TT_VECTOR: { + 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 { + /* vector */ + size_t i; + for (i = 0; i < pic_vec_ptr(obj)->len; ++i) { + traverse(p, pic_vec_ptr(obj)->data[i]); + } + } + + if (p->op == OP_WRITE) { + it = kh_get(l, h, pic_ptr(obj)); + if (kh_val(h, it) == -1) { + kh_del(l, h, it); + } + } + } else if (kh_val(h, it) == -1) { + /* second time */ + kh_val(h, it) = p->cnt++; + } + break; + } + default: + break; + } +} + static void write(pic_state *pic, pic_value obj, xFILE *file, int mode, int op) { @@ -388,7 +387,7 @@ write(pic_state *pic, pic_value obj, xFILE *file, int mode, int op) writer_control_init(&p, pic, file, mode, op); - traverse_shared(&p, obj); + traverse(&p, obj); write_core(&p, obj); From df13e350448ded6e68fc5856e376a0710806581b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Jun 2015 22:29:27 +0900 Subject: [PATCH 103/125] fix dictionary conviersion procedures --- extlib/benz/dict.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extlib/benz/dict.c b/extlib/benz/dict.c index 2e019f87..0c333811 100644 --- a/extlib/benz/dict.c +++ b/extlib/benz/dict.c @@ -256,7 +256,7 @@ pic_dict_dictionary_to_alist(pic_state *pic) pic_push(pic, item, alist); } - return pic_reverse(pic, alist); + return alist; } static pic_value @@ -288,11 +288,11 @@ pic_dict_dictionary_to_plist(pic_state *pic) pic_get_args(pic, "d", &dict); pic_dict_for_each (sym, dict, it) { - pic_push(pic, pic_obj_value(sym), plist); 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 From 8587fe6dfc2a43626518a7db8d9f447841ae53d2 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 25 Jun 2015 22:33:17 +0900 Subject: [PATCH 104/125] fix benz's issue 29 --- extlib/benz/write.c | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/extlib/benz/write.c b/extlib/benz/write.c index a7da49e6..124ae7b4 100644 --- a/extlib/benz/write.c +++ b/extlib/benz/write.c @@ -341,7 +341,8 @@ traverse(struct writer_control *p, pic_value obj) switch (pic_type(obj)) { case PIC_TT_PAIR: - case PIC_TT_VECTOR: { + case PIC_TT_VECTOR: + case PIC_TT_DICT: { khash_t(l) *h = &p->labels; khiter_t it; int ret; @@ -355,12 +356,18 @@ traverse(struct writer_control *p, pic_value obj) /* pair */ traverse(p, pic_car(pic, obj)); traverse(p, pic_cdr(pic, obj)); - } else { + } 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) { From 33dfe2b5ccdee2a1ad94d5dac09c4b808b808380 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Jun 2015 02:09:06 +0900 Subject: [PATCH 105/125] change pic_open interface --- extlib/benz/README.md | 4 ++-- extlib/benz/include/picrin.h | 4 +++- extlib/benz/state.c | 19 +++++++++++++++---- src/main.c | 3 ++- 4 files changed, 22 insertions(+), 8 deletions(-) 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/include/picrin.h b/extlib/benz/include/picrin.h index e19ced8b..7479ab60 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -74,6 +74,7 @@ struct pic_state { char **argv, **envp; pic_allocf allocf; + void *userdata; pic_checkpoint *cp; struct pic_cont *cc; @@ -169,9 +170,10 @@ 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 *); diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 6c4fe6b8..7a419911 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) { @@ -152,7 +160,7 @@ pic_init_core(pic_state *pic) } 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; @@ -169,6 +177,9 @@ 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; @@ -180,9 +191,9 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) 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)); diff --git a/src/main.c b/src/main.c index a4a330ef..5de70fdd 100644 --- a/src/main.c +++ b/src/main.c @@ -41,7 +41,8 @@ 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 = pic_open(pic_default_allocf, NULL); + pic_set_argv(pic, argc, argv, envp); pic_init_picrin(pic); From d8e00f572564a108d0931673e87258c3614e7d98 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Jun 2015 02:32:59 +0900 Subject: [PATCH 106/125] don't malloc duplicated cstring --- extlib/benz/gc.c | 8 ++---- extlib/benz/include/picrin/symbol.h | 2 +- extlib/benz/state.c | 9 ------- extlib/benz/symbol.c | 41 +++++++++++------------------ 4 files changed, 19 insertions(+), 41 deletions(-) diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index fd0b048e..55e1c040 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -470,9 +470,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: { @@ -721,6 +718,8 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) break; } case PIC_TT_SYMBOL: { + pic_sym *sym = (pic_sym *)obj; + pic_free(pic, (void *)sym->cstr); break; } case PIC_TT_REG: { @@ -751,16 +750,13 @@ gc_sweep_symbols(pic_state *pic) khash_t(s) *h = &pic->syms; khiter_t it; pic_sym *sym; - const char *cstr; 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)) { - cstr = kh_key(h, it); kh_del(s, h, it); - pic_free(pic, (void *)cstr); } } } 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/state.c b/extlib/benz/state.c index 7a419911..f334a23c 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -411,17 +411,8 @@ void pic_close(pic_state *pic) { khash_t(s) *h = &pic->syms; - khiter_t it; pic_allocf allocf = pic->allocf; - /* free all symbols */ - for (it = kh_begin(h); it != kh_end(h); ++it) { - if (kh_exist(h, it)) { - allocf((void *)kh_key(h, it), 0); - } - } - kh_clear(s, h); - /* clear out root objects */ pic->sp = pic->stbase; pic->ci = pic->cibase; diff --git a/extlib/benz/symbol.c b/extlib/benz/symbol.c index 160d71ff..fcb5fb2d 100644 --- a/extlib/benz/symbol.c +++ b/extlib/benz/symbol.c @@ -6,52 +6,43 @@ KHASH_DEFINE(s, const char *, pic_sym *, kh_str_hash_func, kh_str_hash_equal) -static 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; -} - pic_sym * pic_intern(pic_state *pic, pic_str *str) +{ + return pic_intern_cstr(pic, pic_str_cstr(pic, str)); +} + +pic_sym * +pic_intern_cstr(pic_state *pic, const char *cstr) { khash_t(s) *h = &pic->syms; pic_sym *sym; - char *cstr; khiter_t it; int ret; + char *copy; - it = kh_put(s, h, pic_str_cstr(pic, str), &ret); + 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)); - kh_key(h, it) = cstr; + copy = pic_malloc(pic, strlen(cstr) + 1); + strcpy(copy, cstr); + kh_key(h, it) = copy; - sym = pic_make_symbol(pic, str); + sym = (pic_sym *)pic_obj_alloc(pic, sizeof(pic_sym), PIC_TT_SYMBOL); + sym->cstr = copy; kh_val(h, it) = 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))); -} - 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 @@ -90,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 From 087e65ef1c22084ae529bbaaebc1c46a8817bd54 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Jun 2015 13:18:22 +0900 Subject: [PATCH 107/125] don't define (picrin control escape) in callcc.c --- Makefile | 1 + contrib/10.callcc/callcc.c | 4 ---- piclib/picrin/control.scm | 6 ++++++ 3 files changed, 7 insertions(+), 4 deletions(-) create mode 100644 piclib/picrin/control.scm diff --git a/Makefile b/Makefile index ccc08d82..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 diff --git a/contrib/10.callcc/callcc.c b/contrib/10.callcc/callcc.c index 2e2561fe..d4bed2e8 100644 --- a/contrib/10.callcc/callcc.c +++ b/contrib/10.callcc/callcc.c @@ -297,10 +297,6 @@ pic_callcc_callcc(pic_state *pic) 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/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)) From 21c12e9fe59fa5169ca8a755e53fcd5381da91b2 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Jun 2015 13:19:38 +0900 Subject: [PATCH 108/125] [bugfix] remove import in (picrin experimental lambda) --- piclib/picrin/experimental/lambda.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/piclib/picrin/experimental/lambda.scm b/piclib/picrin/experimental/lambda.scm index 1fdfeb39..8bbcce40 100644 --- a/piclib/picrin/experimental/lambda.scm +++ b/piclib/picrin/experimental/lambda.scm @@ -1,6 +1,5 @@ (define-library (picrin experimental lambda) - (import (scheme base) - (picrin base) + (import (picrin base) (picrin macro)) (define-syntax (destructuring-let formal value . body) From fccb4b16ea895af6fcb21f2cbf9a92c1bb00b2b1 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Jun 2015 13:20:49 +0900 Subject: [PATCH 109/125] emit more friendly error message on error from piclib loader --- etc/mkloader.pl | 7 ++++--- src/main.c | 8 ++++---- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/etc/mkloader.pl b/etc/mkloader.pl index 602a8aae..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/src/main.c b/src/main.c index 5de70fdd..a20c52fe 100644 --- a/src/main.c +++ b/src/main.c @@ -44,11 +44,11 @@ main(int argc, char *argv[], char **envp) pic = pic_open(pic_default_allocf, NULL); pic_set_argv(pic, argc, argv, envp); - pic_init_picrin(pic); - - PICRIN_MAIN = pic_find_library(pic, pic_read_cstr(pic, "(picrin main)")); - 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 { From 8e905172240f27936885be9184f2a79363c9704d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Jun 2015 15:13:12 +0900 Subject: [PATCH 110/125] [bugfix] port should be closed properly --- extlib/benz/port.c | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/extlib/benz/port.c b/extlib/benz/port.c index f702be55..3ad3702c 100644 --- a/extlib/benz/port.c +++ b/extlib/benz/port.c @@ -601,6 +601,7 @@ 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); @@ -613,11 +614,12 @@ pic_port_read_line(pic_state *pic) 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 @@ -638,6 +640,7 @@ 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); @@ -654,12 +657,12 @@ pic_port_read_string(pic_state *pic){ 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 From 8b550de06a7a49c89521f8d0655b5ab3d24faa9b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 26 Jun 2015 23:45:56 +0900 Subject: [PATCH 111/125] [bugfix] port leaks --- extlib/benz/load.c | 8 +++++++- extlib/benz/read.c | 8 +++++++- 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/extlib/benz/load.c b/extlib/benz/load.c index 2f3269d2..cd609afe 100644 --- a/extlib/benz/load.c +++ b/extlib/benz/load.c @@ -22,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/read.c b/extlib/benz/read.c index 282775e8..e37ca94c 100644 --- a/extlib/benz/read.c +++ b/extlib/benz/read.c @@ -881,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); From 4a8e59e04b274a8654c7d14b3ad7bc2bd078f6d3 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 14:23:31 +0900 Subject: [PATCH 112/125] don't run malloc while anazlyze/codegen --- extlib/benz/codegen.c | 70 +++++++++++++++++-------------------------- 1 file changed, 27 insertions(+), 43 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 3a0eb8c6..442d000a 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -353,38 +353,33 @@ typedef struct analyze_scope { typedef struct analyze_state { pic_state *pic; - analyze_scope *scope; + analyze_scope s, *scope; } analyze_state; -static bool push_scope(analyze_state *, pic_value); +static bool push_scope(analyze_state *, analyze_scope *scope, pic_value); static void pop_scope(analyze_state *); -static analyze_state * -new_analyze_state(pic_state *pic) +static void +analyze_state_init(analyze_state *state, pic_state *pic) { - analyze_state *state; pic_sym *sym; khiter_t it; - state = pic_malloc(pic, sizeof(analyze_state)); state->pic = pic; state->scope = NULL; /* push initial scope */ - push_scope(state, pic_nil_value()); + push_scope(state, &state->s, pic_nil_value()); pic_dict_for_each (sym, pic->globals, it) { kv_push_sym(state->scope->locals, sym); } - - return state; } static void -destroy_analyze_state(analyze_state *state) +analyze_state_destroy(analyze_state *state) { pop_scope(state); - pic_free(state->pic, state); } static bool @@ -417,10 +412,9 @@ analyze_args(pic_state *pic, pic_value formals, bool *varg, svec_t *args, svec_t } static bool -push_scope(analyze_state *state, pic_value formals) +push_scope(analyze_state *state, analyze_scope *scope, pic_value formals) { pic_state *pic = state->pic; - analyze_scope *scope = pic_malloc(pic, sizeof(analyze_scope)); bool varg; kv_init(scope->args); @@ -441,7 +435,6 @@ push_scope(analyze_state *state, pic_value formals) kv_destroy(scope->args); kv_destroy(scope->locals); kv_destroy(scope->captures); - pic_free(pic, scope); return false; } } @@ -458,7 +451,6 @@ pop_scope(analyze_state *state) kv_destroy(scope->captures); scope = scope->up; - pic_free(state->pic, state->scope); state->scope = scope; } @@ -640,11 +632,12 @@ static pic_value analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_value body_exprs) { pic_state *pic = state->pic; + analyze_scope scope; pic_value args, locals, varg, captures, body; assert(pic_sym_p(name) || pic_false_p(name)); - if (push_scope(state, formals)) { + if (push_scope(state, &scope, formals)) { analyze_scope *scope = state->scope; size_t i; @@ -1122,15 +1115,15 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos) pic_value pic_analyze(pic_state *pic, pic_value obj) { - analyze_state *state; + analyze_state state; - state = new_analyze_state(pic); + analyze_state_init(&state, pic); - obj = analyze(state, obj, true); + obj = analyze(&state, obj, true); - analyze_deferred(state); + analyze_deferred(&state); - destroy_analyze_state(state); + analyze_state_destroy(&state); return obj; } @@ -1165,34 +1158,27 @@ typedef struct codegen_context { typedef struct codegen_state { pic_state *pic; - codegen_context *cxt; + codegen_context c, *cxt; } codegen_state; -static void push_codegen_context(codegen_state *, pic_value, pic_value, pic_value, bool, pic_value); +static void push_codegen_context(codegen_state *, codegen_context *, 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) +static void +codegen_state_init(codegen_state *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; + push_codegen_context(state, &state->c, pic_false_value(), pic_nil_value(), pic_nil_value(), false, pic_nil_value()); } static struct pic_irep * -destroy_codegen_state(codegen_state *state) +codegen_state_destroy(codegen_state *state) { - pic_state *pic = state->pic; struct pic_irep *irep; irep = pop_codegen_context(state); - pic_free(pic, state); return irep; } @@ -1292,15 +1278,13 @@ create_activation(codegen_state *state) } static void -push_codegen_context(codegen_state *state, pic_value name, pic_value args, pic_value locals, bool varg, pic_value captures) +push_codegen_context(codegen_state *state, codegen_context *cxt, 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)") @@ -1372,7 +1356,6 @@ pop_codegen_context(codegen_state *state) /* destroy context */ cxt = cxt->up; - pic_free(pic, state->cxt); state->cxt = cxt; return irep; @@ -1713,6 +1696,7 @@ static struct pic_irep * codegen_lambda(codegen_state *state, pic_value obj) { pic_state *pic = state->pic; + codegen_context cxt; pic_value name, args, locals, closes, body; bool varg; @@ -1724,7 +1708,7 @@ codegen_lambda(codegen_state *state, pic_value obj) body = pic_list_ref(pic, obj, 6); /* inner environment */ - push_codegen_context(state, name, args, locals, varg, closes); + push_codegen_context(state, &cxt, name, args, locals, varg, closes); { /* body */ codegen(state, body); @@ -1735,13 +1719,13 @@ codegen_lambda(codegen_state *state, pic_value obj) struct pic_irep * pic_codegen(pic_state *pic, pic_value obj) { - codegen_state *state; + codegen_state state; - state = new_codegen_state(pic); + codegen_state_init(&state, pic); - codegen(state, obj); + codegen(&state, obj); - return destroy_codegen_state(state); + return codegen_state_destroy(&state); } struct pic_proc * From 03792f85de183da55e0ba8f21950ae2c257968ee Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 15:30:17 +0900 Subject: [PATCH 113/125] fast compile --- extlib/benz/codegen.c | 212 ++++++++++++++++++------------------------ 1 file changed, 92 insertions(+), 120 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 442d000a..b928401f 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -331,9 +331,8 @@ pic_expand(pic_state *pic, pic_value expr, struct pic_env *env) return v; } -typedef kvec_t(pic_sym *) svec_t; - -#define kv_push_sym(v, x) kv_push(pic_sym *, (v), (x)) +KHASH_DECLARE(a, pic_sym *, int) +KHASH_DEFINE2(a, pic_sym *, int, 0, kh_ptr_hash_func, kh_ptr_hash_equal) /** * scope object @@ -341,8 +340,8 @@ typedef kvec_t(pic_sym *) svec_t; typedef struct analyze_scope { int depth; - bool varg; - svec_t 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; @@ -364,6 +363,7 @@ analyze_state_init(analyze_state *state, pic_state *pic) { pic_sym *sym; khiter_t it; + int ret; state->pic = pic; state->scope = NULL; @@ -372,7 +372,7 @@ analyze_state_init(analyze_state *state, pic_state *pic) push_scope(state, &state->s, pic_nil_value()); pic_dict_for_each (sym, pic->globals, it) { - kv_push_sym(state->scope->locals, sym); + kh_put(a, &state->scope->locals, sym, &ret); } } @@ -383,26 +383,24 @@ analyze_state_destroy(analyze_state *state) } static bool -analyze_args(pic_state *pic, pic_value formals, bool *varg, svec_t *args, svec_t *locals) +analyze_args(pic_state *pic, pic_value formals, analyze_scope *scope) { pic_value v, t; - pic_sym *sym; + int ret; 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); - kv_push_sym(*args, sym); + kh_put(a, &scope->args, pic_sym_ptr(t), &ret); } if (pic_nil_p(v)) { - *varg = false; + scope->rest = NULL; } else if (pic_sym_p(v)) { - *varg = true; - sym = pic_sym_ptr(v); - kv_push_sym(*locals, sym); + scope->rest = pic_sym_ptr(v); + kh_put(a, &scope->locals, pic_sym_ptr(v), &ret); } else { return false; @@ -415,16 +413,14 @@ static bool push_scope(analyze_state *state, analyze_scope *scope, pic_value formals) { pic_state *pic = state->pic; - bool varg; - kv_init(scope->args); - kv_init(scope->locals); - kv_init(scope->captures); + kh_init(a, &scope->args); + kh_init(a, &scope->locals); + kh_init(a, &scope->captures); - if (analyze_args(pic, formals, &varg, &scope->args, &scope->locals)) { + if (analyze_args(pic, formals, scope)) { scope->up = state->scope; scope->depth = scope->up ? scope->up->depth + 1 : 0; - scope->varg = varg; scope->defer = pic_nil_value(); state->scope = scope; @@ -432,9 +428,9 @@ push_scope(analyze_state *state, analyze_scope *scope, pic_value formals) return true; } else { - kv_destroy(scope->args); - kv_destroy(scope->locals); - kv_destroy(scope->captures); + kh_destroy(a, &scope->args); + kh_destroy(a, &scope->locals); + kh_destroy(a, &scope->captures); return false; } } @@ -446,9 +442,9 @@ pop_scope(analyze_state *state) analyze_scope *scope; scope = state->scope; - kv_destroy(scope->args); - kv_destroy(scope->locals); - kv_destroy(scope->captures); + kh_destroy(a, &scope->args); + kh_destroy(a, &scope->locals); + kh_destroy(a, &scope->captures); scope = scope->up; state->scope = scope; @@ -457,34 +453,15 @@ pop_scope(analyze_state *state) static bool lookup_scope(analyze_scope *scope, pic_sym *sym) { - size_t i; - - /* args */ - for (i = 0; i < kv_size(scope->args); ++i) { - if (kv_A(scope->args, i) == sym) - return true; - } - /* locals */ - for (i = 0; i < kv_size(scope->locals); ++i) { - if (kv_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); } static void capture_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) { - size_t i; + int ret; - for (i = 0; i < kv_size(scope->captures); ++i) { - if (kv_A(scope->captures, i) == sym) { - break; - } - } - if (i == kv_size(scope->captures)) { - kv_push_sym(scope->captures, sym); - } + kh_put(a, &scope->captures, sym, &ret); } static int @@ -511,13 +488,14 @@ define_var(analyze_state *state, 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)); return; } - kv_push_sym(scope->locals, sym); + kh_put(a, &scope->locals, sym, &ret); } static pic_value analyze_node(analyze_state *, pic_value, bool); @@ -633,36 +611,40 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v { pic_state *pic = state->pic; analyze_scope scope; - pic_value args, locals, varg, captures, body; + pic_value rest = pic_undef_value(), body; + pic_vec *args, *locals, *captures; assert(pic_sym_p(name) || pic_false_p(name)); if (push_scope(state, &scope, formals)) { analyze_scope *scope = state->scope; - size_t i; + size_t i, j; - args = pic_nil_value(); - for (i = kv_size(scope->args); i > 0; --i) { - pic_push(pic, pic_obj_value(kv_A(scope->args, i - 1)), args); - } - - varg = scope->varg - ? pic_true_value() - : pic_false_value(); - - /* To know what kind of local variables are defined, analyze body at first. */ + /* analyze body */ body = analyze(state, pic_cons(pic, pic_obj_value(pic->uBEGIN), body_exprs), true); - analyze_deferred(state); - locals = pic_nil_value(); - for (i = kv_size(scope->locals); i > 0; --i) { - pic_push(pic, pic_obj_value(kv_A(scope->locals, i - 1)), locals); + 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); } - captures = pic_nil_value(); - for (i = kv_size(scope->captures); i > 0; --i) { - pic_push(pic, pic_obj_value(kv_A(scope->captures, i - 1)), captures); + 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)); + } + } + + 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)); + } } pop_scope(state); @@ -671,7 +653,7 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v pic_errorf(pic, "invalid formal syntax: ~s", formals); } - return pic_list7(pic, pic_obj_value(pic->sLAMBDA), name, args, locals, varg, captures, body); + return pic_list7(pic, pic_obj_value(pic->sLAMBDA), name, rest, pic_obj_value(args), pic_obj_value(locals), pic_obj_value(captures), body); } static pic_value @@ -1134,8 +1116,8 @@ pic_analyze(pic_state *pic, pic_value obj) typedef struct codegen_context { pic_sym *name; /* rest args variable is counted as a local */ - bool varg; - svec_t args, locals, captures; + pic_sym *rest; + pic_vec *args, *locals, *captures; /* actual bit code sequence */ pic_code *code; size_t clen, ccapa; @@ -1161,16 +1143,18 @@ typedef struct codegen_state { codegen_context c, *cxt; } codegen_state; -static void push_codegen_context(codegen_state *, codegen_context *, pic_value, pic_value, pic_value, bool, pic_value); +static void push_codegen_context(codegen_state *, codegen_context *, pic_value, pic_sym *, pic_vec *, pic_vec *, pic_vec *); static struct pic_irep *pop_codegen_context(codegen_state *); static void codegen_state_init(codegen_state *state, pic_state *pic) { + pic_vec *empty = pic_make_vec(pic, 0); + state->pic = pic; state->cxt = NULL; - push_codegen_context(state, &state->c, pic_false_value(), pic_nil_value(), pic_nil_value(), false, pic_nil_value()); + push_codegen_context(state, &state->c, pic_false_value(), NULL, empty, empty, empty); } static struct pic_irep * @@ -1255,19 +1239,19 @@ create_activation(codegen_state *state) regs = pic_make_reg(pic); offset = 1; - for (i = 0; i < kv_size(cxt->args); ++i) { + for (i = 0; i < cxt->args->len; ++i) { n = i + offset; - pic_reg_set(pic, regs, kv_A(cxt->args, i), pic_size_value(n)); + pic_reg_set(pic, regs, pic_sym_ptr(cxt->args->data[i]), pic_size_value(n)); } offset += i; - for (i = 0; i < kv_size(cxt->locals); ++i) { + for (i = 0; i < cxt->locals->len; ++i) { n = i + offset; - pic_reg_set(pic, regs, kv_A(cxt->locals, i), pic_size_value(n)); + pic_reg_set(pic, regs, pic_sym_ptr(cxt->locals->data[i]), pic_size_value(n)); } - for (i = 0; i < kv_size(cxt->captures); ++i) { - n = (size_t)pic_int(pic_reg_ref(pic, regs, kv_A(cxt->captures, i))); - if (n <= kv_size(cxt->args) || (cxt->varg && n == kv_size(cxt->args) + 1)) { + 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(state, OP_LREF, (int)n); } else { @@ -1278,10 +1262,9 @@ create_activation(codegen_state *state) } static void -push_codegen_context(codegen_state *state, codegen_context *cxt, pic_value name, pic_value args, pic_value locals, bool varg, pic_value captures) +push_codegen_context(codegen_state *state, codegen_context *cxt, pic_value name, pic_sym *rest, pic_vec *args, pic_vec *locals, pic_vec *captures) { pic_state *pic = state->pic; - pic_value var, it; assert(pic_sym_p(name) || pic_false_p(name)); @@ -1289,21 +1272,11 @@ push_codegen_context(codegen_state *state, codegen_context *cxt, pic_value name, cxt->name = pic_false_p(name) ? pic_intern_cstr(pic, "(anonymous lambda)") : pic_sym_ptr(name); - cxt->varg = varg; + cxt->rest = rest; - kv_init(cxt->args); - kv_init(cxt->locals); - kv_init(cxt->captures); - - pic_for_each (var, args, it) { - kv_push_sym(cxt->args, pic_sym_ptr(var)); - } - pic_for_each (var, locals, it) { - kv_push_sym(cxt->locals, pic_sym_ptr(var)); - } - pic_for_each (var, captures, it) { - kv_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; @@ -1336,10 +1309,10 @@ pop_codegen_context(codegen_state *state) /* 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)kv_size(state->cxt->args) + 1; - irep->localc = (int)kv_size(state->cxt->locals); - irep->capturec = (int)kv_size(state->cxt->captures); + irep->varg = state->cxt->rest != NULL; + irep->argc = (int)state->cxt->args->len + 1; + irep->localc = (int)state->cxt->locals->len; + irep->capturec = (int)state->cxt->captures->len; 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); @@ -1349,11 +1322,6 @@ pop_codegen_context(codegen_state *state) irep->syms = pic_realloc(pic, state->cxt->syms, sizeof(pic_sym *) * state->cxt->slen); irep->slen = state->cxt->slen; - /* finalize */ - kv_destroy(cxt->args); - kv_destroy(cxt->locals); - kv_destroy(cxt->captures); - /* destroy context */ cxt = cxt->up; state->cxt = cxt; @@ -1371,8 +1339,8 @@ index_capture(codegen_state *state, pic_sym *sym, int depth) cxt = cxt->up; } - for (i = 0; i < kv_size(cxt->captures); ++i) { - if (kv_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; @@ -1385,13 +1353,13 @@ index_local(codegen_state *state, pic_sym *sym) size_t i, offset; offset = 1; - for (i = 0; i < kv_size(cxt->args); ++i) { - if (kv_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 < kv_size(cxt->locals); ++i) { - if (kv_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; @@ -1444,7 +1412,7 @@ codegen(codegen_state *state, pic_value obj) 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)kv_size(cxt->args) + (int)kv_size(cxt->locals) + 1); + emit_i(state, OP_LREF, i + (int)cxt->args->len + (int)cxt->locals->len + 1); return; } emit_i(state, OP_LREF, index_local(state, name)); @@ -1479,7 +1447,7 @@ codegen(codegen_state *state, pic_value obj) 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)kv_size(cxt->args) + (int)kv_size(cxt->locals) + 1); + emit_i(state, OP_LSET, i + (int)cxt->args->len + (int)cxt->locals->len + 1); emit_n(state, OP_PUSHUNDEF); return; } @@ -1697,18 +1665,22 @@ codegen_lambda(codegen_state *state, pic_value obj) { pic_state *pic = state->pic; codegen_context cxt; - pic_value name, args, locals, closes, body; - bool varg; + pic_value name, 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); + rest_opt = pic_list_ref(pic, obj, 2); + if (pic_sym_p(rest_opt)) { + rest = pic_sym_ptr(rest_opt); + } + args = pic_vec_ptr(pic_list_ref(pic, obj, 3)); + locals = pic_vec_ptr(pic_list_ref(pic, obj, 4)); + captures = pic_vec_ptr(pic_list_ref(pic, obj, 5)); body = pic_list_ref(pic, obj, 6); /* inner environment */ - push_codegen_context(state, &cxt, name, args, locals, varg, closes); + push_codegen_context(state, &cxt, name, rest, args, locals, captures); { /* body */ codegen(state, body); From df645b68aeab5fc4f0cc5750cae1e0a4fc88a43c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 15:59:22 +0900 Subject: [PATCH 114/125] more optimization --- extlib/benz/codegen.c | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index b928401f..8dfc8ab3 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -361,19 +361,11 @@ static void pop_scope(analyze_state *); static void analyze_state_init(analyze_state *state, pic_state *pic) { - pic_sym *sym; - khiter_t it; - int ret; - state->pic = pic; state->scope = NULL; /* push initial scope */ push_scope(state, &state->s, pic_nil_value()); - - pic_dict_for_each (sym, pic->globals, it) { - kh_put(a, &state->scope->locals, sym, &ret); - } } static void @@ -453,7 +445,7 @@ pop_scope(analyze_state *state) static bool lookup_scope(analyze_scope *scope, pic_sym *sym) { - return kh_get(a, &scope->args, sym) != kh_end(&scope->args) || kh_get(a, &scope->locals, sym) != kh_end(&scope->locals); + 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 @@ -491,7 +483,9 @@ define_var(analyze_state *state, pic_sym *sym) int ret; if (lookup_scope(scope, sym)) { - pic_warnf(pic, "redefining variable: ~s", pic_obj_value(sym)); + if (scope->depth > 0 || pic_dict_has(pic, pic->globals, sym)) { + pic_warnf(pic, "redefining variable: ~s", pic_obj_value(sym)); + } return; } From ac094a947738bfcf0a3a4ebf22795ab49e75ed9d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 16:33:31 +0900 Subject: [PATCH 115/125] cosmetic changes --- extlib/benz/codegen.c | 791 +++++++++++++++++------------------------- 1 file changed, 318 insertions(+), 473 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 8dfc8ab3..2f2f92b0 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -334,10 +334,6 @@ pic_expand(pic_state *pic, pic_value expr, struct pic_env *env) KHASH_DECLARE(a, pic_sym *, int) KHASH_DEFINE2(a, pic_sym *, int, 0, kh_ptr_hash_func, kh_ptr_hash_equal) -/** - * scope object - */ - typedef struct analyze_scope { int depth; pic_sym *rest; /* Nullable */ @@ -346,32 +342,36 @@ typedef struct analyze_scope { struct analyze_scope *up; } analyze_scope; -/** - * global analyzer state - */ +static bool analyze_args(pic_state *, pic_value, analyze_scope *); -typedef struct analyze_state { - pic_state *pic; - analyze_scope s, *scope; -} analyze_state; - -static bool push_scope(analyze_state *, analyze_scope *scope, pic_value); -static void pop_scope(analyze_state *); - -static void -analyze_state_init(analyze_state *state, pic_state *pic) +static bool +analyzer_scope_init(pic_state *pic, analyze_scope *scope, pic_value formals, analyze_scope *up) { - 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, &state->s, pic_nil_value()); + if (analyze_args(pic, formals, scope)) { + scope->up = up; + scope->depth = up ? up->depth + 1 : 0; + scope->defer = pic_nil_value(); + + return true; + } + else { + kh_destroy(a, &scope->args); + kh_destroy(a, &scope->locals); + kh_destroy(a, &scope->captures); + return false; + } } static void -analyze_state_destroy(analyze_state *state) +analyzer_scope_destroy(pic_state *pic, analyze_scope *scope) { - pop_scope(state); + kh_destroy(a, &scope->args); + kh_destroy(a, &scope->locals); + kh_destroy(a, &scope->captures); } static bool @@ -401,47 +401,6 @@ analyze_args(pic_state *pic, pic_value formals, analyze_scope *scope) return true; } -static bool -push_scope(analyze_state *state, analyze_scope *scope, pic_value formals) -{ - pic_state *pic = state->pic; - - kh_init(a, &scope->args); - kh_init(a, &scope->locals); - kh_init(a, &scope->captures); - - if (analyze_args(pic, formals, scope)) { - scope->up = state->scope; - scope->depth = scope->up ? scope->up->depth + 1 : 0; - scope->defer = pic_nil_value(); - - state->scope = scope; - - return true; - } - else { - kh_destroy(a, &scope->args); - kh_destroy(a, &scope->locals); - kh_destroy(a, &scope->captures); - return false; - } -} - -static void -pop_scope(analyze_state *state) -{ - pic_state *pic = state->pic; - analyze_scope *scope; - - scope = state->scope; - kh_destroy(a, &scope->args); - kh_destroy(a, &scope->locals); - kh_destroy(a, &scope->captures); - - scope = scope->up; - state->scope = scope; -} - static bool lookup_scope(analyze_scope *scope, pic_sym *sym) { @@ -457,15 +416,14 @@ capture_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) } 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 (depth > 0) { - capture_var(state->pic, scope, sym); + capture_var(pic, scope, sym); } return depth; } @@ -476,10 +434,8 @@ find_var(analyze_state *state, pic_sym *sym) } 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)) { @@ -492,18 +448,17 @@ define_var(analyze_state *state, pic_sym *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, pic_value, 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) { @@ -517,106 +472,77 @@ 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) { + if ((depth = find_var(pic, scope, sym)) == -1) { pic_errorf(pic, "unbound variable %s", pic_symbol_name(pic, 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 name, pic_value formal, pic_value body) { - 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_list4(pic, name, formal, body, skel), 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_for_each (defer, pic_reverse(pic, state->scope->defer), it) { + pic_for_each (defer, pic_reverse(pic, 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); - val = analyze_procedure(state, name, formal, body); + val = analyze_procedure(pic, scope, name, formal, body); /* copy */ pic_pair_ptr(dst)->car = pic_car(pic, val); pic_pair_ptr(dst)->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 name, pic_value formals, pic_value body_exprs) { - pic_state *pic = state->pic; - analyze_scope scope; + analyze_scope s, *scope = &s; pic_value rest = pic_undef_value(), body; pic_vec *args, *locals, *captures; assert(pic_sym_p(name) || pic_false_p(name)); - if (push_scope(state, &scope, formals)) { - analyze_scope *scope = state->scope; + if (analyzer_scope_init(pic, scope, formals, up)) { size_t i, j; /* analyze body */ - body = analyze(state, pic_cons(pic, pic_obj_value(pic->uBEGIN), body_exprs), true); - analyze_deferred(state); + body = analyze(pic, scope, pic_cons(pic, pic_obj_value(pic->uBEGIN), body_exprs), 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++) { @@ -641,7 +567,7 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v } } - pop_scope(state); + analyzer_scope_destroy(pic, scope); } else { pic_errorf(pic, "invalid formal syntax: ~s", formals); @@ -651,9 +577,8 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v } static pic_value -analyze_lambda(analyze_state *state, pic_value obj) +analyze_lambda(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) { @@ -663,21 +588,20 @@ analyze_lambda(analyze_state *state, pic_value obj) 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); + return analyze_defer(pic, scope, pic_false_value(), formals, body_exprs); } static pic_value -analyze_declare(analyze_state *state, pic_sym *var) +analyze_declare(pic_state *pic, analyze_scope *scope, pic_sym *var) { - define_var(state, var); + define_var(pic, scope, var); - return analyze_var(state, var); + return analyze_var(pic, scope, var); } static pic_value -analyze_define(analyze_state *state, pic_value obj) +analyze_define(pic_state *pic, analyze_scope *scope, pic_value obj) { - pic_state *pic = state->pic; pic_value var, val; pic_sym *sym; @@ -691,7 +615,7 @@ analyze_define(analyze_state *state, pic_value obj) } else { sym = pic_sym_ptr(var); } - var = analyze_declare(state, sym); + var = analyze_declare(pic, scope, 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)) @@ -701,21 +625,20 @@ analyze_define(analyze_state *state, pic_value obj) 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); + val = analyze_defer(pic, scope, 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); + 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(); @@ -730,25 +653,24 @@ analyze_if(analyze_state *state, pic_value obj, bool tailpos) } /* 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; switch (pic_length(pic, obj)) { case 1: - return analyze(state, pic_undef_value(), tailpos); + return analyze(pic, scope, pic_undef_value(), tailpos); case 2: - return analyze(state, pic_list_ref(pic, obj, 1), tailpos); + return analyze(pic, scope, 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)) { @@ -757,16 +679,15 @@ analyze_begin(analyze_state *state, pic_value obj, bool tailpos) } else { tail = false; } - seq = pic_cons(pic, analyze(state, pic_car(pic, obj), tail), seq); + seq = pic_cons(pic, analyze(pic, scope, pic_car(pic, obj), tail), seq); } return pic_reverse(pic, seq); } } 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) { @@ -780,17 +701,15 @@ analyze_set(analyze_state *state, pic_value obj) 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"); } @@ -800,24 +719,23 @@ analyze_quote(analyze_state *state, pic_value obj) #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, "+"); @@ -825,7 +743,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); @@ -834,16 +752,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); @@ -852,9 +769,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, "*"); @@ -862,7 +778,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); @@ -871,9 +787,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, "/"); @@ -885,7 +800,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); @@ -894,9 +809,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; @@ -907,32 +821,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; @@ -945,8 +857,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); } @@ -963,25 +875,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; @@ -995,22 +905,22 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos) pic_sym *sym = pic_sym_ptr(proc); if (sym == pic->uDEFINE) { - return analyze_define(state, obj); + return analyze_define(pic, scope, obj); } else if (sym == pic->uLAMBDA) { - return analyze_lambda(state, obj); + return analyze_lambda(pic, scope, obj); } else if (sym == pic->uIF) { - return analyze_if(state, obj, tailpos); + return analyze_if(pic, scope, obj, tailpos); } else if (sym == pic->uBEGIN) { - return analyze_begin(state, obj, tailpos); + return analyze_begin(pic, scope, obj, tailpos); } else if (sym == pic->uSETBANG) { - return analyze_set(state, obj); + return analyze_set(pic, scope, obj); } else if (sym == pic->uQUOTE) { - return analyze_quote(state, obj); + return analyze_quote(pic, obj); } else if (sym == pic->uCONS) { ARGC_ASSERT(2, "cons"); @@ -1037,16 +947,16 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos) return CONSTRUCT_OP1(pic->sPAIRP); } else if (sym == pic->uADD) { - return analyze_add(state, obj, tailpos); + return analyze_add(pic, scope, obj, tailpos); } else if (sym == pic->uSUB) { - return analyze_sub(state, obj); + return analyze_sub(pic, scope, obj); } else if (sym == pic->uMUL) { - return analyze_mul(state, obj, tailpos); + return analyze_mul(pic, scope, obj, tailpos); } else if (sym == pic->uDIV) { - return analyze_div(state, obj); + return analyze_div(pic, scope, obj); } else if (sym == pic->uEQ) { ARGC_ASSERT_WITH_FALLBACK(2); @@ -1073,15 +983,15 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos) return CONSTRUCT_OP1(pic->sNOT); } else if (sym == pic->uVALUES) { - return analyze_values(state, obj, tailpos); + return analyze_values(pic, scope, obj, tailpos); } else if (sym == pic->uCALL_WITH_VALUES) { - return analyze_call_with_values(state, obj, tailpos); + 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); @@ -1091,22 +1001,18 @@ 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; - analyze_state_init(&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); - analyze_state_destroy(&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 */ @@ -1128,141 +1034,14 @@ typedef struct codegen_context { struct codegen_context *up; } codegen_context; -/** - * global codegen state - */ - -typedef struct codegen_state { - pic_state *pic; - codegen_context c, *cxt; -} codegen_state; - -static void push_codegen_context(codegen_state *, codegen_context *, pic_value, pic_sym *, pic_vec *, pic_vec *, pic_vec *); -static struct pic_irep *pop_codegen_context(codegen_state *); +static void create_activation(pic_state *, codegen_context *); static void -codegen_state_init(codegen_state *state, pic_state *pic) +codegen_context_init(pic_state *pic, codegen_context *cxt, codegen_context *up, pic_value name, pic_sym *rest, pic_vec *args, pic_vec *locals, pic_vec *captures) { - pic_vec *empty = pic_make_vec(pic, 0); - - state->pic = pic; - state->cxt = NULL; - - push_codegen_context(state, &state->c, pic_false_value(), NULL, empty, empty, empty); -} - -static struct pic_irep * -codegen_state_destroy(codegen_state *state) -{ - struct pic_irep *irep; - - irep = pop_codegen_context(state); - - return irep; -} - -static void -emit_n(codegen_state *state, enum pic_opcode insn) -{ - 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->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; - 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(state, OP_LREF, (int)n); - } else { - /* otherwise, just extend the stack */ - emit_n(state, OP_PUSHUNDEF); - } - } -} - -static void -push_codegen_context(codegen_state *state, codegen_context *cxt, pic_value name, pic_sym *rest, pic_vec *args, pic_vec *locals, pic_vec *captures) -{ - pic_state *pic = state->pic; - assert(pic_sym_p(name) || pic_false_p(name)); - cxt->up = state->cxt; + cxt->up = up; cxt->name = pic_false_p(name) ? pic_intern_cstr(pic, "(anonymous lambda)") : pic_sym_ptr(name); @@ -1288,45 +1067,116 @@ push_codegen_context(codegen_state *state, codegen_context *cxt, pic_value name, 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->rest != NULL; - irep->argc = (int)state->cxt->args->len + 1; - irep->localc = (int)state->cxt->locals->len; - irep->capturec = (int)state->cxt->captures->len; - 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; - - /* destroy context */ - cxt = cxt->up; - state->cxt = cxt; + irep->name = cxt->name; + 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) { @@ -1341,9 +1191,8 @@ index_capture(codegen_state *state, pic_sym *sym, int depth) } 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; @@ -1360,10 +1209,8 @@ index_local(codegen_state *state, pic_sym *sym) } 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) { @@ -1379,18 +1226,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; @@ -1398,31 +1243,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)cxt->args->len + (int)cxt->locals->len + 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) { @@ -1431,8 +1276,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) { @@ -1440,13 +1285,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)cxt->args->len + (int)cxt->locals->len + 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; } } @@ -1458,31 +1303,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; } @@ -1492,9 +1337,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; } @@ -1504,16 +1349,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) { @@ -1522,103 +1367,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) { @@ -1626,19 +1471,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) { @@ -1646,19 +1491,18 @@ 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; - codegen_context cxt; + codegen_context c, *cxt = &c; pic_value name, rest_opt, body; pic_sym *rest = NULL; pic_vec *args, *locals, *captures; @@ -1674,24 +1518,25 @@ codegen_lambda(codegen_state *state, pic_value obj) body = pic_list_ref(pic, obj, 6); /* inner environment */ - push_codegen_context(state, &cxt, name, rest, args, locals, captures); + codegen_context_init(pic, cxt, up, name, 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; - codegen_state_init(&state, pic); + codegen_context_init(pic, cxt, NULL, pic_false_value(), NULL, empty, empty, empty); - codegen(&state, obj); + codegen(pic, cxt, obj); - return codegen_state_destroy(&state); + return codegen_context_destroy(pic, cxt); } struct pic_proc * From 8c6496ef2445d0eb2e3ae846a3e1a84d8381c1ce Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 16:44:05 +0900 Subject: [PATCH 116/125] remvoe dead code --- extlib/benz/codegen.c | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 2f2f92b0..a256b563 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -402,7 +402,7 @@ analyze_args(pic_state *pic, pic_value formals, analyze_scope *scope) } static bool -lookup_scope(analyze_scope *scope, pic_sym *sym) +search_scope(analyze_scope *scope, pic_sym *sym) { return kh_get(a, &scope->args, sym) != kh_end(&scope->args) || kh_get(a, &scope->locals, sym) != kh_end(&scope->locals) || scope->depth == 0; } @@ -421,7 +421,7 @@ find_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) int depth = 0; while (scope) { - if (lookup_scope(scope, sym)) { + if (search_scope(scope, sym)) { if (depth > 0) { capture_var(pic, scope, sym); } @@ -430,7 +430,7 @@ find_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) depth++; scope = scope->up; } - return -1; + PIC_UNREACHABLE(); } static void @@ -438,7 +438,7 @@ define_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) { int ret; - if (lookup_scope(scope, 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)); } @@ -481,9 +481,7 @@ analyze_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) { int depth; - if ((depth = find_var(pic, scope, sym)) == -1) { - pic_errorf(pic, "unbound variable %s", pic_symbol_name(pic, sym)); - } + depth = find_var(pic, scope, sym); if (depth == scope->depth) { return pic_list2(pic, pic_obj_value(pic->sGREF), pic_obj_value(sym)); From bcf53b9883fcea38f1ba19462115d5a5109b064b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 17:43:42 +0900 Subject: [PATCH 117/125] reimplement core syntaxes in scheme --- extlib/benz/boot.c | 650 ++++++++++++++++++++++++++------------------ extlib/benz/state.c | 19 +- extlib/benz/vm.c | 8 +- 3 files changed, 411 insertions(+), 266 deletions(-) diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index d24bcf40..328ca73d 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -8,25 +8,118 @@ use strict; my $src = <<'EOL'; -(define-macro call-with-current-environment - (lambda (form env) +(builtin:define-macro call-with-current-environment + (builtin:lambda (form env) (list (cadr form) env))) -(define here +(builtin:define here (call-with-current-environment - (lambda (env) + (builtin:lambda (env) env))) -(define (the var) ; synonym for #'var - (make-identifier var here)) +(builtin:define the ; synonym for #'var + (builtin:lambda (var) + (make-identifier var here))) + + +(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))) + +(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))) + +(builtin:define-macro quote + (builtin:lambda (form env) + (builtin:if (= (length form) 2) + (list the-builtin-quote (cadr form)) + (error "illegal quote form" form)))) + +(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)))) + +(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)))) + +(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)))) + +(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))))) + +(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))))) + +(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 "illegal define form" form))))) + (length form)))) + +(builtin:define-macro define-macro + (lambda (form env) + (if (= (length form) 3) + (if (variable? (cadr form)) + (cons the-builtin-define-macro (cdr form)) + (error "illegal define-macro form" form)) + (error "illegal define-macro form" form)))) -(define the-define (the 'define)) -(define the-lambda (the 'lambda)) -(define the-begin (the 'begin)) -(define the-quote (the 'quote)) -(define the-set! (the 'set!)) -(define the-if (the 'if)) -(define the-define-macro (the 'define-macro)) (define-macro syntax-error (lambda (form _) @@ -623,251 +716,294 @@ EOL #endif const char pic_boot[][80] = { -"\n(define-macro call-with-current-environment\n (lambda (form env)\n (list (cad", -"r form) env)))\n\n(define here\n (call-with-current-environment\n (lambda (env)\n ", -" env)))\n\n(define (the var) ; synonym for #'var\n (make-id", -"entifier var here))\n\n(define the-define (the 'define))\n(define the-lambda (the '", -"lambda))\n(define the-begin (the 'begin))\n(define the-quote (the 'quote))\n(define", -" the-set! (the 'set!))\n(define the-if (the 'if))\n(define the-define-macro (the '", -"define-macro))\n\n(define-macro syntax-error\n (lambda (form _)\n (apply error (", -"cdr form))))\n\n(define-macro define-auxiliary-syntax\n (lambda (form _)\n (defi", -"ne message\n (string-append\n \"invalid use of auxiliary syntax: '\" (sym", -"bol->string (cadr form)) \"'\"))\n (list\n the-define-macro\n (cadr form)\n", -" (list the-lambda '_\n (list (the 'error) message)))))\n\n(define-aux", -"iliary-syntax else)\n(define-auxiliary-syntax =>)\n(define-auxiliary-syntax unquot", -"e)\n(define-auxiliary-syntax unquote-splicing)\n(define-auxiliary-syntax syntax-un", -"quote)\n(define-auxiliary-syntax syntax-unquote-splicing)\n\n(define-macro let\n (l", -"ambda (form env)\n (if (variable? (cadr form))\n (list\n (list th", -"e-lambda '()\n (list the-define (cadr form)\n (c", -"ons the-lambda\n (cons (map car (car (cddr form)))\n ", -" (cdr (cddr form)))))\n (cons (cadr for", -"m) (map cadr (car (cddr form))))))\n (cons\n (cons\n the-la", -"mbda\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 (nu", -"ll? (cdr form))\n #t\n (if (null? (cddr form))\n (cadr for", -"m)\n (list the-if\n (cadr form)\n (con", -"s (the 'and) (cddr form))\n #f)))))\n\n(define-macro or\n (lambda ", -"(form env)\n (if (null? (cdr form))\n #f\n (let ((tmp (make-identi", -"fier '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-macr", -"o cond\n (lambda (form env)\n (let ((clauses (cdr form)))\n (if (null? cla", -"uses)\n #undefined\n (let ((clause (car clauses)))\n (", -"if (and (variable? (car clause))\n (variable=? (the 'else) (m", -"ake-identifier (car clause) env)))\n (cons the-begin (cdr clause))", -"\n (if (and (variable? (cadr clause))\n (va", -"riable=? (the '=>) (make-identifier (cadr clause) env)))\n (le", -"t ((tmp (make-identifier 'tmp here)))\n (list (the 'let) (li", -"st (list tmp (car clause)))\n (list 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 (cdr clause))\n ", -" (cons (the 'cond) (cdr clauses))))))))))\n\n(define-macro quasiquo", -"te\n (lambda (form env)\n\n (define (quasiquote? form)\n (and (pair? form)\n", -" (variable? (car form))\n (variable=? (the 'quasiquote) (make", -"-identifier (car form) env))))\n\n (define (unquote? form)\n (and (pair? fo", -"rm)\n (variable? (car form))\n (variable=? (the 'unquote) (mak", -"e-identifier (car form) env))))\n\n (define (unquote-splicing? form)\n (and", -" (pair? form)\n (pair? (car form))\n (variable? (caar form))\n ", -" (variable=? (the 'unquote-splicing) (make-identifier (caar form) env))", -"))\n\n (define (qq depth expr)\n (cond\n ;; unquote\n ((unquote? ", -"expr)\n (if (= depth 1)\n (car (cdr expr))\n (list (th", -"e 'list)\n (list (the 'quote) (the 'unquote))\n ", -"(qq (- depth 1) (car (cdr expr))))))\n ;; unquote-splicing\n ((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 'quote) (the 'unquote-splicing))\n (qq (- ", -"depth 1) (car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ", -" ;; quasiquote\n ((quasiquote? expr)\n (list (the 'list)\n ", -" (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) (car (c", -"dr expr)))))\n ;; list\n ((pair? expr)\n (list (the 'cons)\n ", -" (qq depth (car expr))\n (qq depth (cdr expr))))\n ;; v", -"ector\n ((vector? expr)\n (list (the 'list->vector) (qq depth (vector", -"->list expr))))\n ;; simple datum\n (else\n (list (the 'quote) e", -"xpr))))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n(define-macro let*\n (lam", -"bda (form env)\n (let ((bindings (car (cdr form)))\n (body (cdr (c", -"dr form))))\n (if (null? bindings)\n `(,(the 'let) () ,@body)\n ", -" `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))\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 b", -"indings)))\n (initials (map (lambda (v) `(,(the 'set!) ,@v)) bindings", -")))\n `(,(the 'let) (,@variables)\n ,@initials\n ,@body)))", -"))\n\n(define-macro let-values\n (lambda (form env)\n `(,(the 'let*-values) ,@(c", -"dr form))))\n\n(define-macro let*-values\n (lambda (form env)\n (let ((formal (c", -"ar (cdr form)))\n (body (cdr (cdr form))))\n (if (null? formal)\n ", -" `(,(the 'let) () ,@body)\n `(,(the 'call-with-values) (,the-lamb", -"da () ,@(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 ((arguments (make-identifier", -" 'arguments here)))\n `(,the-begin\n ,@(let loop ((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 () ,@body)\n (,the", -"-lambda\n ,arguments\n ,@(let loop ((formal formal) (args ar", -"guments))\n (if (pair? formal)\n `((,the-set! ,(", -"car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args)))\n ", -" (if (variable? formal)\n `((,the-set! ,fo", -"rmal ,args))\n '()))))))))))\n\n(define-macro do\n (lambda (", -"form env)\n (let ((bindings (car (cdr form)))\n (test (car (car (c", -"dr (cdr form)))))\n (cleanup (cdr (car (cdr (cdr form)))))\n (b", -"ody (cdr (cdr (cdr form)))))\n (let ((loop (make-identifier 'loop here))", -")\n `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindings)", -"\n (,the-if ,test\n (,the-begin\n ,@c", -"leanup)\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 (form env)\n (let ((te", -"st (car (cdr form)))\n (body (cdr (cdr form))))\n `(,the-if ,test\n ", -" (,the-begin ,@body)\n #undefined))))\n\n(define-macro ", -"unless\n (lambda (form env)\n (let ((test (car (cdr form)))\n (body (c", -"dr (cdr form))))\n `(,the-if ,test\n #undefined\n ", -" (,the-begin ,@body)))))\n\n(define-macro case\n (lambda (form env)\n (let ((ke", -"y (car (cdr form)))\n (clauses (cdr (cdr form))))\n (let ((the-k", -"ey (make-identifier 'key here)))\n `(,(the 'let) ((,the-key ,key))\n ", -" ,(let loop ((clauses clauses))\n (if (null? clauses)\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 (la", -"mbda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))\n ", -" ,(if (and (variable? (cadr clause))\n ", -" (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ", -" `(,(car (cdr (cdr clause))) ,the-key)\n ", -" `(,the-begin ,@(cdr clause)))\n ,(lo", -"op (cdr clauses)))))))))))\n\n(define-macro parameterize\n (lambda (form env)\n ", -"(let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(,(t", -"he 'with-parameter)\n (,(the 'lambda) ()\n ,@formal\n ,@body", -")))))\n\n(define-macro syntax-quote\n (lambda (form env)\n (let ((renames '()))\n", -" (letrec\n ((rename (lambda (var)\n (let ((x (as", -"sq var renames)))\n (if x\n (cadr ", -"x)\n (begin\n (set! renames ", -"`((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,ren", -"ames))\n (rename var))))))\n (walk (lambda (", +"\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 \"illegal define for", +"m\" form)))))\n (length form))))\n\n(builtin:define-macro define-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 \"illegal d", +"efine-macro form\" form))\n (error \"illegal define-macro form\" form))))\n\n\n(", +"define-macro syntax-error\n (lambda (form _)\n (apply error (cdr form))))\n\n(de", +"fine-macro define-auxiliary-syntax\n (lambda (form _)\n (define message\n ", +"(string-append\n \"invalid use of auxiliary syntax: '\" (symbol->string (cadr", +" form)) \"'\"))\n (list\n the-define-macro\n (cadr form)\n (list the-la", +"mbda '_\n (list (the 'error) message)))))\n\n(define-auxiliary-syntax els", +"e)\n(define-auxiliary-syntax =>)\n(define-auxiliary-syntax unquote)\n(define-auxili", +"ary-syntax unquote-splicing)\n(define-auxiliary-syntax syntax-unquote)\n(define-au", +"xiliary-syntax syntax-unquote-splicing)\n\n(define-macro let\n (lambda (form env)\n", +" (if (variable? (cadr form))\n (list\n (list the-lambda '()\n ", +" (list the-define (cadr form)\n (cons the-lambda\n ", +" (cons (map car (car (cddr form)))\n ", +" (cdr (cddr form)))))\n (cons (cadr form) (map cadr (car", +" (cddr form))))))\n (cons\n (cons\n the-lambda\n (c", +"ons (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 (l", +"ist the-if\n (cadr form)\n (cons (the 'and) (cdd", +"r form))\n #f)))))\n\n(define-macro or\n (lambda (form env)\n (i", +"f (null? (cdr form))\n #f\n (let ((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 clauses)))\n (if (and (variable", +"? (car clause))\n (variable=? (the 'else) (make-identifier (c", +"ar clause) env)))\n (cons the-begin (cdr clause))\n ", +"(if (and (variable? (cadr clause))\n (variable=? (the '=>", +") (make-identifier (cadr clause) env)))\n (let ((tmp (make-ide", +"ntifier 'tmp here)))\n (list (the 'let) (list (list tmp (car", +" clause)))\n (list 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 (cdr clause))\n (", +"cons (the 'cond) (cdr clauses))))))))))\n\n(define-macro quasiquote\n (lambda (for", +"m env)\n\n (define (quasiquote? form)\n (and (pair? form)\n (varia", +"ble? (car form))\n (variable=? (the 'quasiquote) (make-identifier (car ", +"form) env))))\n\n (define (unquote? form)\n (and (pair? form)\n (v", +"ariable? (car form))\n (variable=? (the 'unquote) (make-identifier (car", +" form) env))))\n\n (define (unquote-splicing? form)\n (and (pair? form)\n ", +" (pair? (car form))\n (variable? (caar form))\n (variab", +"le=? (the 'unquote-splicing) (make-identifier (caar form) env))))\n\n (define (", +"qq depth expr)\n (cond\n ;; unquote\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-splicing\n ((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 '", +"quote) (the 'unquote-splicing))\n (qq (- depth 1) (car (cd", +"r (car expr)))))\n (qq depth (cdr expr)))))\n ;; quasiquote", +"\n ((quasiquote? expr)\n (list (the 'list)\n (list (the '", +"quote) (the 'quasiquote))\n (qq (+ depth 1) (car (cdr expr)))))\n ", +" ;; list\n ((pair? expr)\n (list (the 'cons)\n (qq dept", +"h (car expr))\n (qq depth (cdr expr))))\n ;; vector\n ((ve", +"ctor? expr)\n (list (the 'list->vector) (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(define-macro let*\n (lambda (form env)\n ", +" (let ((bindings (car (cdr form)))\n (body (cdr (cdr form))))\n ", +" (if (null? bindings)\n `(,(the 'let) () ,@body)\n `(,(the 'let)", +" ((,(car (car bindings)) ,@(cdr (car bindings))))\n (,(the 'let*) (,@(", +"cdr bindings))\n ,@body))))))\n\n(define-macro letrec\n (lambda (form e", +"nv)\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 `(,(t", +"he 'let) (,@variables)\n ,@initials\n ,@body)))))\n\n(define-macro", +" let-values\n (lambda (form env)\n `(,(the 'let*-values) ,@(cdr form))))\n\n(def", +"ine-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-with-values) (,the-lambda () ,@(cdr (car", +" formal)))\n (,(the 'lambda) (,@(car (car formal)))\n (,(th", +"e 'let*-values) (,@(cdr formal))\n ,@body)))))))\n\n(define-macro defi", +"ne-values\n (lambda (form env)\n (let ((formal (car (cdr form)))\n (bo", +"dy (cdr (cdr form))))\n (let ((arguments (make-identifier 'arguments here)", +"))\n `(,the-begin\n ,@(let loop ((formal formal))\n (i", +"f (pair? formal)\n `((,the-define ,(car formal) #undefined) ,@(l", +"oop (cdr formal)))\n (if (variable? formal)\n ", +" `((,the-define ,formal #undefined))\n '())))\n (,(", +"the 'call-with-values) (,the-lambda () ,@body)\n (,the-lambda\n ", +" ,arguments\n ,@(let loop ((formal formal) (args arguments))\n ", +" (if (pair? formal)\n `((,the-set! ,(car formal) (,(th", +"e 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args)))\n ", +"(if (variable? formal)\n `((,the-set! ,formal ,args))\n ", +" '()))))))))))\n\n(define-macro do\n (lambda (form env)\n (le", +"t ((bindings (car (cdr form)))\n (test (car (car (cdr (cdr form)))))", +"\n (cleanup (cdr (car (cdr (cdr form)))))\n (body (cdr (cdr", +" (cdr form)))))\n (let ((loop (make-identifier '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 ,@(m", +"ap (lambda (x) (if (null? (cdr (cdr x))) (car x) (car (cdr (cdr x))))) bindings)", +"))))))))\n\n(define-macro when\n (lambda (form env)\n (let ((test (car (cdr form", +")))\n (body (cdr (cdr form))))\n `(,the-if ,test\n (,t", +"he-begin ,@body)\n #undefined))))\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 #undefined\n (,the-begin ,@b", +"ody)))))\n\n(define-macro case\n (lambda (form env)\n (let ((key (car (cdr f", +"orm)))\n (clauses (cdr (cdr form))))\n (let ((the-key (make-identifi", +"er 'key here)))\n `(,(the 'let) ((,the-key ,key))\n ,(let loop ((c", +"lauses clauses))\n (if (null? clauses)\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 clause))))\n ,", +"(if (and (variable? (cadr clause))\n (varia", +"ble=? (the '=>) (make-identifier (cadr clause) env)))\n ", +" `(,(car (cdr (cdr clause))) ,the-key)\n ", +"`(,the-begin ,@(cdr clause)))\n ,(loop (cdr clauses))", +")))))))))\n\n(define-macro parameterize\n (lambda (form env)\n (let ((formal (ca", +"r (cdr form)))\n (body (cdr (cdr form))))\n `(,(the 'with-paramete", +"r)\n (,(the 'lambda) ()\n ,@formal\n ,@body)))))\n\n(define-ma", +"cro 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-id", +"entifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))\n ", +" (rename var))))))\n (walk (lambda (f form)\n ", +" (cond\n ((variable? form)\n (f fo", +"rm))\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 ((fo", +"rm (walk rename (cadr form))))\n `(,(the 'let)\n ,(map cdr ren", +"ames)\n ,form))))))\n\n(define-macro syntax-quasiquote\n (lambda (form e", +"nv)\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-ide", +"ntifier) ',var ',env)) . ,renames))\n (rename var))))", +")))\n\n (define (syntax-quasiquote? form)\n (and (pair? form)\n ", +" (variable? (car form))\n (variable=? (the 'syntax-quasiqu", +"ote) (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 (variable? (caar form))\n (va", +"riable=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env))))\n\n ", +" (define (qq depth expr)\n (cond\n ;; syntax-unquote\n ", +" ((syntax-unquote? expr)\n (if (= depth 1)\n (car (", +"cdr expr))\n (list (the 'list)\n (list (the 'q", +"uote) (the 'syntax-unquote))\n (qq (- depth 1) (car (cdr exp", +"r))))))\n ;; syntax-unquote-splicing\n ((syntax-unquote-splici", +"ng? 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 'quote) (the 'syntax-unquote-splicing))\n ", +" (qq (- depth 1) (car (cdr (car expr)))))\n ", +" (qq depth (cdr expr)))))\n ;; syntax-quasiquote\n ((sy", +"ntax-quasiquote? expr)\n (list (the 'list)\n (list (th", +"e 'quote) (the 'quasiquote))\n (qq (+ depth 1) (car (cdr expr)))", +"))\n ;; list\n ((pair? expr)\n (list (the 'cons)\n ", +" (qq depth (car expr))\n (qq depth (cdr expr))))\n ", +" ;; vector\n ((vector? expr)\n (list (the 'list->vec", +"tor) (qq depth (vector->list expr))))\n ;; variable\n ((variab", +"le? 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 ,(map cdr renames)\n ,body)))))", +")\n\n(define (transformer f)\n (lambda (form env)\n (let ((register1 (make-regis", +"ter))\n (register2 (make-register)))\n (letrec\n ((wrap (lam", +"bda (var1)\n (let ((var2 (register1 var1)))\n ", +" (if (undefined? var2)\n (let ((var2 (make-identifier va", +"r1 env)))\n (register1 var1 var2)\n ", +" (register2 var2 var1)\n var2)\n ", +" var2))))\n (unwrap (lambda (var2)\n (let ((var", +"1 (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 `(,", -"(the 'cons) (walk f (car form)) (walk f (cdr form))))\n ((vect", -"or? 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-macro syntax-quasiquote\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 (beg", -"in\n (set! renames `((,var ,(make-identifier var env)", -" (,(the 'make-identifier) ',var ',env)) . ,renames))\n ", -" (rename var)))))))\n\n (define (syntax-quasiquote? form)\n (and (", -"pair? form)\n (variable? (car form))\n (variable=? (th", -"e 'syntax-quasiquote) (make-identifier (car form) env))))\n\n (define (synt", -"ax-unquote? form)\n (and (pair? form)\n (variable? (car for", -"m))\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 (variable? (caar form))\n ", -" (variable=? (the 'syntax-unquote-splicing) (make-identifier (caar ", -"form) env))))\n\n (define (qq depth expr)\n (cond\n ;; syn", -"tax-unquote\n ((syntax-unquote? expr)\n (if (= depth 1)\n ", -" (car (cdr expr))\n (list (the 'list)\n ", -" (list (the 'quote) (the 'syntax-unquote))\n (qq (- depth", -" 1) (car (cdr expr))))))\n ;; syntax-unquote-splicing\n ((synt", -"ax-unquote-splicing? expr)\n (if (= depth 1)\n (list (th", -"e 'append)\n (car (cdr (car expr)))\n (q", -"q depth (cdr expr)))\n (list (the 'cons)\n (li", -"st (the 'list)\n (list (the 'quote) (the 'syntax-unquo", -"te-splicing))\n (qq (- depth 1) (car (cdr (car expr)))", -"))\n (qq depth (cdr expr)))))\n ;; syntax-quasiquot", -"e\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? expr)\n (lis", -"t (the 'cons)\n (qq depth (car expr))\n (qq dept", -"h (cdr expr))))\n ;; vector\n ((vector? expr)\n (lis", -"t (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 ,(map cdr renames)\n ", -" ,body))))))\n\n(define (transformer f)\n (lambda (form env)\n (let ((regi", -"ster1 (make-register))\n (register2 (make-register)))\n (letrec\n ", -" ((wrap (lambda (var1)\n (let ((var2 (register1 var1)))\n ", -" (if (undefined? var2)\n (let ((var2 (m", -"ake-identifier var1 env)))\n (register1 var1 var2)\n ", -" (register2 var2 var1)\n var2)\n ", -" var2))))\n (unwrap (lambda (var2)\n ", -" (let ((var1 (register2 var2)))\n (if (undefined? var", -"1)\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 form))))))))\n\n(define-m", -"acro define-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", -" (body (cdr (cdr form))))\n (if (pair? formal)\n `(,(the 'def", -"ine-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body))\n `(,the-d", -"efine-macro ,formal (,(the 'transformer) (,the-begin ,@body)))))))\n\n(define-macr", -"o letrec-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", -" (body (cdr (cdr form))))\n `(let ()\n ,@(map (lambda (x)\n ", -" `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n formal)\n", -" ,@body))))\n\n(define-macro let-syntax\n (lambda (form env)\n `(,(the '", -"letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(define-macro define-li", -"brary\n (lambda (form _)\n (let ((name (cadr form))\n (body (cddr form", -")))\n (let ((old-library (current-library))\n (new-library (or (fi", -"nd-library name) (make-library name))))\n (let ((env (library-environment ", -"new-library)))\n (current-library new-library)\n (for-each (lamb", -"da (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 'else)\n ", -"(and (symbol? form)\n (memq form (features)))\n ", -" (and (pair? form)\n (case (car form)\n ", -" ((library) (find-library (cadr form)))\n ((not) (", -"not (test (cadr form))))\n ((and) (let loop ((form (cdr f", -"orm)))\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 (test (car form)) (loop (", -"cdr form))))))\n (else #f)))))))\n (let loop ((clause", -"s (cdr form)))\n (if (null? clauses)\n #undefined\n (i", -"f (test (caar clauses))\n `(,the-begin ,@(cdar clauses))\n ", -" (loop (cdr clauses))))))))\n\n(define-macro import\n (lambda (form _)\n (", -"let ((caddr\n (lambda (x) (car (cdr (cdr x)))))\n (prefix\n ", -" (lambda (prefix symbol)\n (string->symbol\n (string", -"-append\n (symbol->string prefix)\n (symbol->string sy", -"mbol))))))\n (letrec\n ((extract\n (lambda (spec)\n ", -" (case (car spec)\n ((only rename prefix except)\n ", -" (extract (cadr spec)))\n (else\n (or (find-lib", -"rary 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 (va", -"r) (assq var alist)) (cddr spec))))\n ((rename)\n (", -"let ((alist (collect (cadr spec))))\n (map (lambda (s) (or (ass", -"q (car s) (cddr spec)) s)) alist)))\n ((prefix)\n (", -"let ((alist (collect (cadr spec))))\n (map (lambda (s) (cons (p", -"refix (caddr spec) (car s)) (cdr s))) alist)))\n ((except)\n ", -" (let ((alist (collect (cadr spec))))\n (let loop ((al", -"ist alist))\n (if (null? alist)\n '()\n", -" (if (memq (caar alist) (cddr spec))\n ", -" (loop (cdr alist))\n (cons (car alist) (loo", -"p (cdr alist))))))))\n (else\n (let ((lib (or (find", -"-library spec) (error \"library not found\" spec))))\n (map (lamb", -"da (x) (cons x x)) (library-exports lib))))))))\n (letrec\n ((im", -"port\n (lambda (spec)\n (let ((lib (extract spec))\n ", -" (alist (collect spec)))\n (for-each\n ", -" (lambda (slot)\n (library-import lib (cdr slo", -"t) (car slot)))\n alist)))))\n (for-each import (cdr f", -"orm)))))))\n\n(define-macro export\n (lambda (form _)\n (letrec\n ((collec", -"t\n (lambda (spec)\n (cond\n ((symbol? spec)\n ", -" `(,spec . ,spec))\n ((and (list? spec) (= (length spec) 3) (e", -"q? (car spec) 'rename))\n `(,(list-ref spec 1) . ,(list-ref spec 2))", -")\n (else\n (error \"malformed export\")))))\n (expo", -"rt\n (lambda (spec)\n (let ((slot (collect spec)))\n ", -" (library-export (car slot) (cdr slot))))))\n (for-each export (cdr for", -"m)))))\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 els", -"e =>\n do when unless\n parameterize\n define-syntax\n s", -"yntax-quote syntax-unquote\n syntax-quasiquote syntax-unquote-splicing\n ", -" let-syntax letrec-syntax\n syntax-error)\n\n\n", +" (f form))\n ((pair? form)\n (co", +"ns (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 form))))))))\n\n(define-macro define-synta", +"x\n (lambda (form env)\n (let ((formal (car (cdr form)))\n (body (cd", +"r (cdr form))))\n (if (pair? formal)\n `(,(the 'define-syntax) ,(car", +" formal) (,the-lambda ,(cdr formal) ,@body))\n `(,the-define-macro ,form", +"al (,(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 ,@(map (lambda (x)\n `(,(th", +"e 'define-syntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))", +"))\n\n(define-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@", +"(cdr form))))\n\n\n;;; library primitives\n\n(define-macro define-library\n (lambda (", +"form _)\n (let ((name (cadr form))\n (body (cddr form)))\n (let ((", +"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 e", +"xpr 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 'else)\n (and (symbol? for", +"m)\n (memq form (features)))\n (and (pair? ", +"form)\n (case (car form)\n ((library", +") (find-library (cadr form)))\n ((not) (not (test (cadr f", +"orm))))\n ((and) (let loop ((form (cdr form)))\n ", +" (or (null? form)\n (", +"and (test (car form)) (loop (cdr form))))))\n ((or) (let ", +"loop ((form (cdr form)))\n (and (pair? form)\n ", +" (or (test (car form)) (loop (cdr form))))))\n ", +" (else #f)))))))\n (let loop ((clauses (cdr form)))\n ", +" (if (null? clauses)\n #undefined\n (if (test (caar cla", +"uses))\n `(,the-begin ,@(cdar clauses))\n (loop (cdr", +" clauses))))))))\n\n(define-macro import\n (lambda (form _)\n (let ((caddr\n ", +" (lambda (x) (car (cdr (cdr x)))))\n (prefix\n (lambda (pr", +"efix symbol)\n (string->symbol\n (string-append\n ", +" (symbol->string prefix)\n (symbol->string symbol))))))\n ", +"(letrec\n ((extract\n (lambda (spec)\n (case (car ", +"spec)\n ((only rename prefix except)\n (extract (ca", +"dr 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 ((al", +"ist (collect (cadr spec))))\n (map (lambda (var) (assq var alis", +"t)) (cddr spec))))\n ((rename)\n (let ((alist (coll", +"ect (cadr spec))))\n (map (lambda (s) (or (assq (car s) (cddr s", +"pec)) s)) alist)))\n ((prefix)\n (let ((alist (coll", +"ect (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) (e", +"rror \"library not found\" spec))))\n (map (lambda (x) (cons x x)", +") (library-exports lib))))))))\n (letrec\n ((import\n ", +" (lambda (spec)\n (let ((lib (extract spec))\n ", +" (alist (collect spec)))\n (for-each\n (l", +"ambda (slot)\n (library-import lib (cdr slot) (car slot)))\n ", +" alist)))))\n (for-each import (cdr form)))))))\n\n(defi", +"ne-macro export\n (lambda (form _)\n (letrec\n ((collect\n (lamb", +"da (spec)\n (cond\n ((symbol? spec)\n `(,spec .", +" ,spec))\n ((and (list? spec) (= (length spec) 3) (eq? (car spec) 're", +"name))\n `(,(list-ref spec 1) . ,(list-ref spec 2)))\n (e", +"lse\n (error \"malformed export\")))))\n (export\n (la", +"mbda (spec)\n (let ((slot (collect spec)))\n (library-ex", +"port (car slot) (cdr slot))))))\n (for-each export (cdr form)))))\n\n(export d", +"efine-library\n cond-expand\n import\n export)\n\n(export let le", +"t* letrec letrec*\n let-values let*-values define-values\n quasiquot", +"e unquote unquote-splicing\n and or\n cond case else =>\n do w", +"hen unless\n parameterize\n define-syntax\n syntax-quote synta", +"x-unquote\n syntax-quasiquote syntax-unquote-splicing\n let-syntax l", +"etrec-syntax\n syntax-error)\n\n\n", "", "" }; diff --git a/extlib/benz/state.c b/extlib/benz/state.c index f334a23c..70e09571 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -109,23 +109,26 @@ pic_features(pic_state *pic) #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->uDEFINE); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->uSETBANG); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->uQUOTE); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->uLAMBDA); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->uIF); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->uBEGIN); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_MACRO, pic->uDEFINE_MACRO); + 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); diff --git a/extlib/benz/vm.c b/extlib/benz/vm.c index f661f10a..13b8727c 100644 --- a/extlib/benz/vm.c +++ b/extlib/benz/vm.c @@ -1110,9 +1110,15 @@ pic_apply5(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2 } void -pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *uid) +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); From 4d18610a79cc2d50b0c9b5acdae584a23654e97a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 17:44:06 +0900 Subject: [PATCH 118/125] refine error messages --- extlib/benz/boot.c | 492 +++++++++++++++++++++--------------------- extlib/benz/codegen.c | 6 +- extlib/benz/state.c | 8 +- extlib/benz/vm.c | 2 +- 4 files changed, 257 insertions(+), 251 deletions(-) diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index 328ca73d..81e82626 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -109,7 +109,7 @@ my $src = <<'EOL'; (list the-define (car (cadr form)) (cons the-lambda (cons (cdr (cadr form)) (cddr form)))) - (error "illegal define form" form))))) + (error "define: binding to non-varaible object" form))))) (length form)))) (builtin:define-macro define-macro @@ -117,7 +117,7 @@ my $src = <<'EOL'; (if (= (length form) 3) (if (variable? (cadr form)) (cons the-builtin-define-macro (cdr form)) - (error "illegal define-macro form" form)) + (error "define-macro: binding to non-variable object" form)) (error "illegal define-macro form" form)))) @@ -760,250 +760,250 @@ const char pic_boot[][80] = { "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 \"illegal define for", -"m\" form)))))\n (length form))))\n\n(builtin:define-macro define-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 \"illegal d", -"efine-macro form\" form))\n (error \"illegal define-macro form\" form))))\n\n\n(", -"define-macro syntax-error\n (lambda (form _)\n (apply error (cdr form))))\n\n(de", -"fine-macro define-auxiliary-syntax\n (lambda (form _)\n (define message\n ", -"(string-append\n \"invalid use of auxiliary syntax: '\" (symbol->string (cadr", -" form)) \"'\"))\n (list\n the-define-macro\n (cadr form)\n (list the-la", -"mbda '_\n (list (the 'error) message)))))\n\n(define-auxiliary-syntax els", -"e)\n(define-auxiliary-syntax =>)\n(define-auxiliary-syntax unquote)\n(define-auxili", -"ary-syntax unquote-splicing)\n(define-auxiliary-syntax syntax-unquote)\n(define-au", -"xiliary-syntax syntax-unquote-splicing)\n\n(define-macro let\n (lambda (form env)\n", -" (if (variable? (cadr form))\n (list\n (list the-lambda '()\n ", -" (list the-define (cadr form)\n (cons the-lambda\n ", -" (cons (map car (car (cddr form)))\n ", -" (cdr (cddr form)))))\n (cons (cadr form) (map cadr (car", -" (cddr form))))))\n (cons\n (cons\n the-lambda\n (c", -"ons (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 (l", -"ist the-if\n (cadr form)\n (cons (the 'and) (cdd", -"r form))\n #f)))))\n\n(define-macro or\n (lambda (form env)\n (i", -"f (null? (cdr form))\n #f\n (let ((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 clauses)))\n (if (and (variable", -"? (car clause))\n (variable=? (the 'else) (make-identifier (c", -"ar clause) env)))\n (cons the-begin (cdr clause))\n ", -"(if (and (variable? (cadr clause))\n (variable=? (the '=>", -") (make-identifier (cadr clause) env)))\n (let ((tmp (make-ide", -"ntifier 'tmp here)))\n (list (the 'let) (list (list tmp (car", -" clause)))\n (list 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 (cdr clause))\n (", -"cons (the 'cond) (cdr clauses))))))))))\n\n(define-macro quasiquote\n (lambda (for", -"m env)\n\n (define (quasiquote? form)\n (and (pair? form)\n (varia", -"ble? (car form))\n (variable=? (the 'quasiquote) (make-identifier (car ", -"form) env))))\n\n (define (unquote? form)\n (and (pair? form)\n (v", -"ariable? (car form))\n (variable=? (the 'unquote) (make-identifier (car", -" form) env))))\n\n (define (unquote-splicing? form)\n (and (pair? form)\n ", -" (pair? (car form))\n (variable? (caar form))\n (variab", -"le=? (the 'unquote-splicing) (make-identifier (caar form) env))))\n\n (define (", -"qq depth expr)\n (cond\n ;; unquote\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-splicing\n ((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 '", -"quote) (the 'unquote-splicing))\n (qq (- depth 1) (car (cd", -"r (car expr)))))\n (qq depth (cdr expr)))))\n ;; quasiquote", -"\n ((quasiquote? expr)\n (list (the 'list)\n (list (the '", -"quote) (the 'quasiquote))\n (qq (+ depth 1) (car (cdr expr)))))\n ", -" ;; list\n ((pair? expr)\n (list (the 'cons)\n (qq dept", -"h (car expr))\n (qq depth (cdr expr))))\n ;; vector\n ((ve", -"ctor? expr)\n (list (the 'list->vector) (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(define-macro let*\n (lambda (form env)\n ", -" (let ((bindings (car (cdr form)))\n (body (cdr (cdr form))))\n ", -" (if (null? bindings)\n `(,(the 'let) () ,@body)\n `(,(the 'let)", -" ((,(car (car bindings)) ,@(cdr (car bindings))))\n (,(the 'let*) (,@(", -"cdr bindings))\n ,@body))))))\n\n(define-macro letrec\n (lambda (form e", -"nv)\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 `(,(t", -"he 'let) (,@variables)\n ,@initials\n ,@body)))))\n\n(define-macro", -" let-values\n (lambda (form env)\n `(,(the 'let*-values) ,@(cdr form))))\n\n(def", -"ine-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-with-values) (,the-lambda () ,@(cdr (car", -" formal)))\n (,(the 'lambda) (,@(car (car formal)))\n (,(th", -"e 'let*-values) (,@(cdr formal))\n ,@body)))))))\n\n(define-macro defi", -"ne-values\n (lambda (form env)\n (let ((formal (car (cdr form)))\n (bo", -"dy (cdr (cdr form))))\n (let ((arguments (make-identifier 'arguments here)", -"))\n `(,the-begin\n ,@(let loop ((formal formal))\n (i", -"f (pair? formal)\n `((,the-define ,(car formal) #undefined) ,@(l", -"oop (cdr formal)))\n (if (variable? formal)\n ", -" `((,the-define ,formal #undefined))\n '())))\n (,(", -"the 'call-with-values) (,the-lambda () ,@body)\n (,the-lambda\n ", -" ,arguments\n ,@(let loop ((formal formal) (args arguments))\n ", -" (if (pair? formal)\n `((,the-set! ,(car formal) (,(th", -"e 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args)))\n ", -"(if (variable? formal)\n `((,the-set! ,formal ,args))\n ", -" '()))))))))))\n\n(define-macro do\n (lambda (form env)\n (le", -"t ((bindings (car (cdr form)))\n (test (car (car (cdr (cdr form)))))", -"\n (cleanup (cdr (car (cdr (cdr form)))))\n (body (cdr (cdr", -" (cdr form)))))\n (let ((loop (make-identifier '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 ,@(m", -"ap (lambda (x) (if (null? (cdr (cdr x))) (car x) (car (cdr (cdr x))))) bindings)", -"))))))))\n\n(define-macro when\n (lambda (form env)\n (let ((test (car (cdr form", -")))\n (body (cdr (cdr form))))\n `(,the-if ,test\n (,t", -"he-begin ,@body)\n #undefined))))\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 #undefined\n (,the-begin ,@b", -"ody)))))\n\n(define-macro case\n (lambda (form env)\n (let ((key (car (cdr f", -"orm)))\n (clauses (cdr (cdr form))))\n (let ((the-key (make-identifi", -"er 'key here)))\n `(,(the 'let) ((,the-key ,key))\n ,(let loop ((c", -"lauses clauses))\n (if (null? clauses)\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 clause))))\n ,", -"(if (and (variable? (cadr clause))\n (varia", -"ble=? (the '=>) (make-identifier (cadr clause) env)))\n ", -" `(,(car (cdr (cdr clause))) ,the-key)\n ", -"`(,the-begin ,@(cdr clause)))\n ,(loop (cdr clauses))", -")))))))))\n\n(define-macro parameterize\n (lambda (form env)\n (let ((formal (ca", -"r (cdr form)))\n (body (cdr (cdr form))))\n `(,(the 'with-paramete", -"r)\n (,(the 'lambda) ()\n ,@formal\n ,@body)))))\n\n(define-ma", -"cro 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-id", -"entifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))\n ", -" (rename var))))))\n (walk (lambda (f form)\n ", -" (cond\n ((variable? form)\n (f fo", -"rm))\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 ((fo", -"rm (walk rename (cadr form))))\n `(,(the 'let)\n ,(map cdr ren", -"ames)\n ,form))))))\n\n(define-macro syntax-quasiquote\n (lambda (form e", -"nv)\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-ide", -"ntifier) ',var ',env)) . ,renames))\n (rename var))))", -")))\n\n (define (syntax-quasiquote? form)\n (and (pair? form)\n ", -" (variable? (car form))\n (variable=? (the 'syntax-quasiqu", -"ote) (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 (variable? (caar form))\n (va", -"riable=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env))))\n\n ", -" (define (qq depth expr)\n (cond\n ;; syntax-unquote\n ", -" ((syntax-unquote? expr)\n (if (= depth 1)\n (car (", -"cdr expr))\n (list (the 'list)\n (list (the 'q", -"uote) (the 'syntax-unquote))\n (qq (- depth 1) (car (cdr exp", -"r))))))\n ;; syntax-unquote-splicing\n ((syntax-unquote-splici", -"ng? 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 'quote) (the 'syntax-unquote-splicing))\n ", -" (qq (- depth 1) (car (cdr (car expr)))))\n ", -" (qq depth (cdr expr)))))\n ;; syntax-quasiquote\n ((sy", -"ntax-quasiquote? expr)\n (list (the 'list)\n (list (th", -"e 'quote) (the 'quasiquote))\n (qq (+ depth 1) (car (cdr expr)))", -"))\n ;; list\n ((pair? expr)\n (list (the 'cons)\n ", -" (qq depth (car expr))\n (qq depth (cdr expr))))\n ", -" ;; vector\n ((vector? expr)\n (list (the 'list->vec", -"tor) (qq depth (vector->list expr))))\n ;; variable\n ((variab", -"le? 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 ,(map cdr renames)\n ,body)))))", -")\n\n(define (transformer f)\n (lambda (form env)\n (let ((register1 (make-regis", -"ter))\n (register2 (make-register)))\n (letrec\n ((wrap (lam", -"bda (var1)\n (let ((var2 (register1 var1)))\n ", -" (if (undefined? var2)\n (let ((var2 (make-identifier va", -"r1 env)))\n (register1 var1 var2)\n ", -" (register2 var2 var1)\n var2)\n ", -" var2))))\n (unwrap (lambda (var2)\n (let ((var", -"1 (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 (co", -"ns (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 form))))))))\n\n(define-macro define-synta", -"x\n (lambda (form env)\n (let ((formal (car (cdr form)))\n (body (cd", -"r (cdr form))))\n (if (pair? formal)\n `(,(the 'define-syntax) ,(car", -" formal) (,the-lambda ,(cdr formal) ,@body))\n `(,the-define-macro ,form", -"al (,(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 ,@(map (lambda (x)\n `(,(th", -"e 'define-syntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))", -"))\n\n(define-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@", -"(cdr form))))\n\n\n;;; library primitives\n\n(define-macro define-library\n (lambda (", -"form _)\n (let ((name (cadr form))\n (body (cddr form)))\n (let ((", -"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 e", -"xpr 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 'else)\n (and (symbol? for", -"m)\n (memq form (features)))\n (and (pair? ", -"form)\n (case (car form)\n ((library", -") (find-library (cadr form)))\n ((not) (not (test (cadr f", -"orm))))\n ((and) (let loop ((form (cdr form)))\n ", -" (or (null? form)\n (", -"and (test (car form)) (loop (cdr form))))))\n ((or) (let ", -"loop ((form (cdr form)))\n (and (pair? form)\n ", -" (or (test (car form)) (loop (cdr form))))))\n ", -" (else #f)))))))\n (let loop ((clauses (cdr form)))\n ", -" (if (null? clauses)\n #undefined\n (if (test (caar cla", -"uses))\n `(,the-begin ,@(cdar clauses))\n (loop (cdr", -" clauses))))))))\n\n(define-macro import\n (lambda (form _)\n (let ((caddr\n ", -" (lambda (x) (car (cdr (cdr x)))))\n (prefix\n (lambda (pr", -"efix symbol)\n (string->symbol\n (string-append\n ", -" (symbol->string prefix)\n (symbol->string symbol))))))\n ", -"(letrec\n ((extract\n (lambda (spec)\n (case (car ", -"spec)\n ((only rename prefix except)\n (extract (ca", -"dr 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 ((al", -"ist (collect (cadr spec))))\n (map (lambda (var) (assq var alis", -"t)) (cddr spec))))\n ((rename)\n (let ((alist (coll", -"ect (cadr spec))))\n (map (lambda (s) (or (assq (car s) (cddr s", -"pec)) s)) alist)))\n ((prefix)\n (let ((alist (coll", -"ect (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) (e", -"rror \"library not found\" spec))))\n (map (lambda (x) (cons x x)", -") (library-exports lib))))))))\n (letrec\n ((import\n ", -" (lambda (spec)\n (let ((lib (extract spec))\n ", -" (alist (collect spec)))\n (for-each\n (l", -"ambda (slot)\n (library-import lib (cdr slot) (car slot)))\n ", -" alist)))))\n (for-each import (cdr form)))))))\n\n(defi", -"ne-macro export\n (lambda (form _)\n (letrec\n ((collect\n (lamb", -"da (spec)\n (cond\n ((symbol? spec)\n `(,spec .", -" ,spec))\n ((and (list? spec) (= (length spec) 3) (eq? (car spec) 're", -"name))\n `(,(list-ref spec 1) . ,(list-ref spec 2)))\n (e", -"lse\n (error \"malformed export\")))))\n (export\n (la", -"mbda (spec)\n (let ((slot (collect spec)))\n (library-ex", -"port (car slot) (cdr slot))))))\n (for-each export (cdr form)))))\n\n(export d", -"efine-library\n cond-expand\n import\n export)\n\n(export let le", -"t* letrec letrec*\n let-values let*-values define-values\n quasiquot", -"e unquote unquote-splicing\n and or\n cond case else =>\n do w", -"hen unless\n parameterize\n define-syntax\n syntax-quote synta", -"x-unquote\n syntax-quasiquote syntax-unquote-splicing\n let-syntax l", -"etrec-syntax\n syntax-error)\n\n\n", +"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 a256b563..7b5e82da 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -1547,7 +1547,7 @@ pic_compile(pic_state *pic, pic_value obj, struct pic_env *env) 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)); @@ -1557,7 +1557,7 @@ pic_compile(pic_state *pic, pic_value obj, struct pic_env *env) obj = pic_expand(pic, obj, env); #if DEBUG fprintf(stdout, "## expand completed\n"); - pic_debug(pic, obj); + pic_write(pic, obj); fprintf(stdout, "\n"); fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); #endif @@ -1566,7 +1566,7 @@ pic_compile(pic_state *pic, pic_value obj, struct pic_env *env) 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/state.c b/extlib/benz/state.c index 70e09571..ddbe27fa 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -156,7 +156,13 @@ pic_init_core(pic_state *pic) pic_init_attr(pic); DONE; pic_init_reg(pic); DONE; - pic_load_cstr(pic, &pic_boot[0][0]); + pic_try { + pic_load_cstr(pic, &pic_boot[0][0]); + } + pic_catch { + pic_print_backtrace(pic, xstdout); + pic_raise(pic, pic->err); + } } pic_import(pic, pic->PICRIN_BASE); diff --git a/extlib/benz/vm.c b/extlib/benz/vm.c index 13b8727c..47044312 100644 --- a/extlib/benz/vm.c +++ b/extlib/benz/vm.c @@ -633,7 +633,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; From 1bed1bd42034d0763af015e465dd50449b2d06a8 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 17:50:14 +0900 Subject: [PATCH 119/125] remove unnecessary error checks --- extlib/benz/codegen.c | 33 ++++----------------------------- 1 file changed, 4 insertions(+), 29 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 7b5e82da..a7a3cc6e 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -13,7 +13,7 @@ lookup(pic_state PIC_UNUSED(*pic), pic_value var, struct pic_env *env) { khiter_t it; - assert(pic_var_p(var)); + pic_assert_type(pic, var, var); while (env != NULL) { it = kh_get(env, &env->map, pic_ptr(var)); @@ -30,9 +30,10 @@ pic_resolve(pic_state *pic, pic_value var, struct pic_env *env) { pic_sym *uid; - assert(pic_var_p(var)); assert(env != NULL); + pic_assert_type(pic, var, var); + while ((uid = lookup(pic, var, env)) == NULL) { if (pic_sym_p(var)) { break; @@ -145,26 +146,14 @@ expand_lambda(pic_state *pic, pic_value expr, struct pic_env *env) struct pic_env *in; pic_value a, deferred; - 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 var = pic_car(pic, a); - - if (! pic_var_p(var)) { - pic_errorf(pic, "syntax error"); - } - pic_add_variable(pic, in, var); + pic_add_variable(pic, in, pic_car(pic, a)); } if (pic_var_p(a)) { pic_add_variable(pic, in, a); } - else if (! pic_nil_p(a)) { - pic_errorf(pic, "syntax error"); - } deferred = pic_list1(pic, pic_nil_value()); @@ -189,14 +178,7 @@ expand_define(pic_state *pic, pic_value expr, struct pic_env *env, pic_value def expr = pic_list3(pic, pic_obj_value(pic->uDEFINE), var, pic_cons(pic, pic_obj_value(pic->sLAMBDA), 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_var_p(var)) { - pic_errorf(pic, "binding to non-variable object"); - } if ((uid = pic_find_variable(pic, env, var)) == NULL) { uid = pic_add_variable(pic, env, var); } else { @@ -213,14 +195,7 @@ expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) pic_value var, val; pic_sym *uid; - if (pic_length(pic, expr) != 3) { - pic_errorf(pic, "syntax error"); - } - var = pic_cadr(pic, expr); - if (! pic_var_p(var)) { - pic_errorf(pic, "binding to non-variable object"); - } if ((uid = pic_find_variable(pic, env, var)) == NULL) { uid = pic_add_variable(pic, env, var); } From f98a5ab14d9e80db445a5ed65f2f7f68c958397f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 18:23:08 +0900 Subject: [PATCH 120/125] cleanup --- extlib/benz/codegen.c | 22 +--------------------- 1 file changed, 1 insertion(+), 21 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index a7a3cc6e..012eceb9 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -171,13 +171,6 @@ expand_define(pic_state *pic, pic_value expr, struct pic_env *env, pic_value def pic_sym *uid; 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->uDEFINE), var, pic_cons(pic, pic_obj_value(pic->sLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr)))); - } - var = pic_cadr(pic, expr); if ((uid = pic_find_variable(pic, env, var)) == NULL) { uid = pic_add_variable(pic, env, var); @@ -201,7 +194,6 @@ expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) } 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); } @@ -211,12 +203,6 @@ expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) return pic_undef_value(); } -static pic_value -expand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct pic_env *env) -{ - return pic_apply2(pic, mac, expr, pic_obj_value(env)); -} - static pic_value expand_node(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred) { @@ -251,7 +237,7 @@ expand_node(pic_state *pic, pic_value expr, struct pic_env *env, pic_value defer } if ((mac = find_macro(pic, functor)) != NULL) { - return expand_node(pic, expand_macro(pic, mac, expr, env), env, deferred); + return expand_node(pic, pic_apply2(pic, mac, expr, pic_obj_value(env)), env, deferred); } } return expand_list(pic, expr, env, deferred); @@ -267,12 +253,6 @@ 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; -#if DEBUG - printf("[expand] expanding... "); - pic_debug(pic, expr); - puts(""); -#endif - v = expand_node(pic, expr, env, deferred); pic_gc_arena_restore(pic, ai); From 5633bbefaeeb938bab8b0ce6b298e9665c2130ed Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 18:38:16 +0900 Subject: [PATCH 121/125] don't enclose load_cstr with try-catch --- extlib/benz/state.c | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/extlib/benz/state.c b/extlib/benz/state.c index ddbe27fa..70e09571 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -156,13 +156,7 @@ pic_init_core(pic_state *pic) pic_init_attr(pic); DONE; pic_init_reg(pic); DONE; - pic_try { - pic_load_cstr(pic, &pic_boot[0][0]); - } - pic_catch { - pic_print_backtrace(pic, xstdout); - pic_raise(pic, pic->err); - } + pic_load_cstr(pic, &pic_boot[0][0]); } pic_import(pic, pic->PICRIN_BASE); From 36c498e7d7598815234e3e19fcdd609876c4ca0b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 18:47:16 +0900 Subject: [PATCH 122/125] cleanup analyzer --- extlib/benz/codegen.c | 208 ++++++++++++++---------------------------- 1 file changed, 67 insertions(+), 141 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 012eceb9..d539281e 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -157,12 +157,12 @@ expand_lambda(pic_state *pic, pic_value expr, struct pic_env *env) deferred = pic_list1(pic, pic_nil_value()); - formal = expand_list(pic, pic_cadr(pic, expr), in, deferred); - body = expand_list(pic, pic_cddr(pic, expr), in, deferred); + 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_cons(pic, pic_obj_value(pic->uLAMBDA), pic_cons(pic, formal, body)); + return pic_list3(pic, pic_obj_value(pic->uLAMBDA), formal, body); } static pic_value @@ -297,28 +297,30 @@ typedef struct analyze_scope { struct analyze_scope *up; } analyze_scope; -static bool analyze_args(pic_state *, pic_value, analyze_scope *); - -static bool -analyzer_scope_init(pic_state *pic, analyze_scope *scope, pic_value formals, analyze_scope *up) +static void +analyzer_scope_init(pic_state *pic, analyze_scope *scope, pic_value formal, analyze_scope *up) { + int ret; + kh_init(a, &scope->args); kh_init(a, &scope->locals); kh_init(a, &scope->captures); - if (analyze_args(pic, formals, scope)) { - scope->up = up; - scope->depth = up ? up->depth + 1 : 0; - scope->defer = pic_nil_value(); - - return true; + /* 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 { - kh_destroy(a, &scope->args); - kh_destroy(a, &scope->locals); - kh_destroy(a, &scope->captures); - return false; + scope->rest = pic_sym_ptr(formal); + kh_put(a, &scope->locals, pic_sym_ptr(formal), &ret); } + + scope->up = up; + scope->depth = up ? up->depth + 1 : 0; + scope->defer = pic_nil_value(); } static void @@ -329,33 +331,6 @@ analyzer_scope_destroy(pic_state *pic, analyze_scope *scope) kh_destroy(a, &scope->captures); } -static bool -analyze_args(pic_state *pic, pic_value formals, analyze_scope *scope) -{ - pic_value v, t; - int ret; - - for (v = formals; pic_pair_p(v); v = pic_cdr(pic, v)) { - t = pic_car(pic, v); - if (! pic_sym_p(t)) { - return false; - } - kh_put(a, &scope->args, pic_sym_ptr(t), &ret); - } - if (pic_nil_p(v)) { - scope->rest = NULL; - } - else if (pic_sym_p(v)) { - scope->rest = pic_sym_ptr(v); - kh_put(a, &scope->locals, pic_sym_ptr(v), &ret); - } - else { - return false; - } - - return true; -} - static bool search_scope(analyze_scope *scope, pic_sym *sym) { @@ -482,66 +457,58 @@ analyze_deferred(pic_state *pic, analyze_scope *scope) } static pic_value -analyze_procedure(pic_state *pic, analyze_scope *up, pic_value name, pic_value formals, pic_value body_exprs) +analyze_procedure(pic_state *pic, analyze_scope *up, pic_value name, pic_value formals, pic_value body) { analyze_scope s, *scope = &s; - pic_value rest = pic_undef_value(), 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)); - if (analyzer_scope_init(pic, scope, formals, up)) { - size_t i, j; + analyzer_scope_init(pic, scope, formals, up); - /* analyze body */ - body = analyze(pic, scope, pic_cons(pic, pic_obj_value(pic->uBEGIN), body_exprs), true); - analyze_deferred(pic, scope); + /* 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)); - } - } - - 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)); - } - } - - analyzer_scope_destroy(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); } - else { - pic_errorf(pic, "invalid formal syntax: ~s", 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)); + } + } + + 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)); + } + } + + analyzer_scope_destroy(pic, scope); + return pic_list7(pic, pic_obj_value(pic->sLAMBDA), name, rest, pic_obj_value(args), pic_obj_value(locals), pic_obj_value(captures), body); } static pic_value analyze_lambda(pic_state *pic, analyze_scope *scope, pic_value obj) { - pic_value formals, body_exprs; - - if (pic_length(pic, obj) < 2) { - pic_errorf(pic, "syntax error"); - } + pic_value formals, body; formals = pic_list_ref(pic, obj, 1); - body_exprs = pic_list_tail(pic, obj, 2); + body = pic_list_ref(pic, obj, 2); - return analyze_defer(pic, scope, pic_false_value(), formals, body_exprs); + return analyze_defer(pic, scope, pic_false_value(), formals, body); } static pic_value @@ -558,31 +525,21 @@ analyze_define(pic_state *pic, analyze_scope *scope, pic_value obj) pic_value var, val; pic_sym *sym; - 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"); - } else { - sym = pic_sym_ptr(var); - } + sym = pic_sym_ptr(pic_list_ref(pic, obj, 1)); var = analyze_declare(pic, scope, 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->uLAMBDA) { - pic_value formals, body_exprs; + pic_value formals, body; + + /* restore (define (foo ...) ...) structure */ 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); + body = pic_list_ref(pic, pic_list_ref(pic, obj, 2), 2); - val = analyze_defer(pic, scope, pic_obj_value(sym), formals, body_exprs); + val = analyze_defer(pic, scope, pic_obj_value(sym), formals, body); } else { - if (pic_length(pic, obj) != 3) { - pic_errorf(pic, "syntax error"); - } val = analyze(pic, scope, pic_list_ref(pic, obj, 2), false); } @@ -594,18 +551,9 @@ analyze_if(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) { 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(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); @@ -616,26 +564,15 @@ analyze_if(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) static pic_value analyze_begin(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) { - pic_value seq; - bool tail; + pic_value beg1, beg2; - switch (pic_length(pic, obj)) { - case 1: - return analyze(pic, scope, pic_undef_value(), tailpos); - case 2: - return analyze(pic, scope, 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(pic, scope, 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 @@ -643,15 +580,7 @@ analyze_set(pic_state *pic, analyze_scope *scope, pic_value obj) { 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(pic, scope, var, false); @@ -663,9 +592,6 @@ analyze_set(pic_state *pic, analyze_scope *scope, pic_value obj) static pic_value analyze_quote(pic_state *pic, pic_value obj) { - 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)); } From ddcf96f6893fae6499962831e6fa2b4ed2f5efac Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 19:02:18 +0900 Subject: [PATCH 123/125] remove pic_proc_name (for a moment) --- contrib/10.callcc/callcc.c | 6 +-- extlib/benz/codegen.c | 71 +++++++++--------------------- extlib/benz/cont.c | 2 +- extlib/benz/debug.c | 2 +- extlib/benz/gc.c | 3 -- extlib/benz/include/picrin/error.h | 2 +- extlib/benz/include/picrin/irep.h | 1 - extlib/benz/include/picrin/proc.h | 4 +- extlib/benz/port.c | 2 +- extlib/benz/proc.c | 20 +-------- extlib/benz/reg.c | 2 +- extlib/benz/var.c | 2 +- extlib/benz/vm.c | 10 ++--- 13 files changed, 36 insertions(+), 91 deletions(-) diff --git a/contrib/10.callcc/callcc.c b/contrib/10.callcc/callcc.c index d4bed2e8..36ac9ed5 100644 --- a/contrib/10.callcc/callcc.c +++ b/contrib/10.callcc/callcc.c @@ -246,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); @@ -270,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); @@ -292,7 +292,7 @@ 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) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index d539281e..75371b81 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -379,7 +379,7 @@ define_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) } static pic_value analyze_node(pic_state *, analyze_scope *, pic_value, bool); -static pic_value analyze_procedure(pic_state *, analyze_scope *, pic_value, pic_value, pic_value); +static pic_value analyze_procedure(pic_state *, analyze_scope *, pic_value, pic_value); static pic_value analyze(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) @@ -423,14 +423,14 @@ analyze_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) } static pic_value -analyze_defer(pic_state *pic, analyze_scope *scope, pic_value name, pic_value formal, pic_value body) +analyze_defer(pic_state *pic, analyze_scope *scope, pic_value formal, pic_value body) { 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), scope->defer); + pic_push(pic, pic_list3(pic, formal, body, skel), scope->defer); return skel; } @@ -438,15 +438,14 @@ analyze_defer(pic_state *pic, analyze_scope *scope, pic_value name, pic_value fo static void analyze_deferred(pic_state *pic, analyze_scope *scope) { - pic_value defer, val, name, formal, body, dst, it; + pic_value defer, val, formal, body, dst, it; pic_for_each (defer, pic_reverse(pic, 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); + formal = pic_list_ref(pic, defer, 0); + body = pic_list_ref(pic, defer, 1); + dst = pic_list_ref(pic, defer, 2); - val = analyze_procedure(pic, scope, name, formal, body); + val = analyze_procedure(pic, scope, formal, body); /* copy */ pic_pair_ptr(dst)->car = pic_car(pic, val); @@ -457,15 +456,13 @@ analyze_deferred(pic_state *pic, analyze_scope *scope) } static pic_value -analyze_procedure(pic_state *pic, analyze_scope *up, pic_value name, pic_value formals, pic_value body) +analyze_procedure(pic_state *pic, analyze_scope *up, pic_value formals, pic_value body) { analyze_scope s, *scope = &s; pic_value rest = pic_undef_value(); pic_vec *args, *locals, *captures; size_t i, j; - assert(pic_sym_p(name) || pic_false_p(name)); - analyzer_scope_init(pic, scope, formals, up); /* analyze body */ @@ -497,7 +494,7 @@ analyze_procedure(pic_state *pic, analyze_scope *up, pic_value name, pic_value f analyzer_scope_destroy(pic, scope); - return pic_list7(pic, pic_obj_value(pic->sLAMBDA), name, rest, pic_obj_value(args), pic_obj_value(locals), pic_obj_value(captures), body); + 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 @@ -508,7 +505,7 @@ analyze_lambda(pic_state *pic, analyze_scope *scope, pic_value obj) formals = pic_list_ref(pic, obj, 1); body = pic_list_ref(pic, obj, 2); - return analyze_defer(pic, scope, pic_false_value(), formals, body); + return analyze_defer(pic, scope, formals, body); } static pic_value @@ -523,25 +520,9 @@ static pic_value analyze_define(pic_state *pic, analyze_scope *scope, pic_value obj) { pic_value var, val; - pic_sym *sym; - sym = pic_sym_ptr(pic_list_ref(pic, obj, 1)); - var = analyze_declare(pic, scope, 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->uLAMBDA) { - pic_value formals, body; - - /* restore (define (foo ...) ...) structure */ - - formals = pic_list_ref(pic, pic_list_ref(pic, obj, 2), 1); - body = pic_list_ref(pic, pic_list_ref(pic, obj, 2), 2); - - val = analyze_defer(pic, scope, pic_obj_value(sym), formals, body); - } else { - val = analyze(pic, scope, pic_list_ref(pic, obj, 2), false); - } + var = analyze_declare(pic, scope, pic_sym_ptr(pic_list_ref(pic, obj, 1))); + val = analyze(pic, scope, pic_list_ref(pic, obj, 2), false); return pic_list3(pic, pic_obj_value(pic->sSETBANG), var, val); } @@ -893,7 +874,6 @@ pic_analyze(pic_state *pic, pic_value obj) } typedef struct codegen_context { - pic_sym *name; /* rest args variable is counted as a local */ pic_sym *rest; pic_vec *args, *locals, *captures; @@ -916,14 +896,9 @@ typedef struct codegen_context { static void create_activation(pic_state *, codegen_context *); static void -codegen_context_init(pic_state *pic, codegen_context *cxt, codegen_context *up, pic_value name, pic_sym *rest, pic_vec *args, pic_vec *locals, pic_vec *captures) +codegen_context_init(pic_state *pic, codegen_context *cxt, codegen_context *up, pic_sym *rest, pic_vec *args, pic_vec *locals, pic_vec *captures) { - assert(pic_sym_p(name) || pic_false_p(name)); - cxt->up = up; - cxt->name = pic_false_p(name) - ? pic_intern_cstr(pic, "(anonymous lambda)") - : pic_sym_ptr(name); cxt->rest = rest; cxt->args = args; @@ -956,7 +931,6 @@ codegen_context_destroy(pic_state *pic, codegen_context *cxt) /* create irep */ irep = (struct pic_irep *)pic_obj_alloc(pic, sizeof(struct pic_irep), PIC_TT_IREP); - irep->name = cxt->name; irep->varg = cxt->rest != NULL; irep->argc = (int)cxt->args->len + 1; irep->localc = (int)cxt->locals->len; @@ -1382,22 +1356,21 @@ static struct pic_irep * codegen_lambda(pic_state *pic, codegen_context *up, pic_value obj) { codegen_context c, *cxt = &c; - pic_value name, rest_opt, body; + pic_value rest_opt, body; pic_sym *rest = NULL; pic_vec *args, *locals, *captures; - name = pic_list_ref(pic, obj, 1); - rest_opt = pic_list_ref(pic, obj, 2); + 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, 3)); - locals = pic_vec_ptr(pic_list_ref(pic, obj, 4)); - captures = pic_vec_ptr(pic_list_ref(pic, obj, 5)); - body = pic_list_ref(pic, obj, 6); + 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 */ - codegen_context_init(pic, cxt, up, name, rest, args, locals, captures); + codegen_context_init(pic, cxt, up, rest, args, locals, captures); { /* body */ codegen(pic, cxt, body); @@ -1411,7 +1384,7 @@ pic_codegen(pic_state *pic, pic_value obj) pic_vec *empty = pic_make_vec(pic, 0); codegen_context c, *cxt = &c; - codegen_context_init(pic, cxt, NULL, pic_false_value(), NULL, empty, empty, empty); + codegen_context_init(pic, cxt, NULL, NULL, empty, empty, empty); codegen(pic, cxt, obj); diff --git a/extlib/benz/cont.c b/extlib/benz/cont.c index 132ed018..fe9947a3 100644 --- a/extlib/benz/cont.c +++ b/extlib/benz/cont.c @@ -121,7 +121,7 @@ pic_make_cont(pic_state *pic, struct pic_cont *cont) 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); diff --git a/extlib/benz/debug.c b/extlib/benz/debug.c index 2e7097cc..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")); diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index 55e1c040..b441d786 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -366,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); } @@ -430,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]); } diff --git a/extlib/benz/include/picrin/error.h b/extlib/benz/include/picrin/error.h index 15fd57b4..b8de3442 100644 --- a/extlib/benz/include/picrin/error.h +++ b/extlib/benz/include/picrin/error.h @@ -35,7 +35,7 @@ struct pic_error *pic_make_error(pic_state *, pic_sym *, const char *, pic_list) 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)"); \ + 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); diff --git a/extlib/benz/include/picrin/irep.h b/extlib/benz/include/picrin/irep.h index daa639cc..200278ed 100644 --- a/extlib/benz/include/picrin/irep.h +++ b/extlib/benz/include/picrin/irep.h @@ -68,7 +68,6 @@ typedef struct { struct pic_irep { PIC_OBJECT_HEADER - pic_sym *name; pic_code *code; int argc, localc, capturec; bool varg; 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/port.c b/extlib/benz/port.c index 3ad3702c..bc5ab406 100644 --- a/extlib/benz/port.c +++ b/extlib/benz/port.c @@ -154,7 +154,7 @@ pic_define_standard_port(pic_state *pic, const char *name, xFILE *file, int dir) port->file = file; port->flags = dir | PIC_PORT_TEXT | PIC_PORT_OPEN; - pic_defvar(pic, name, pic_obj_value(port), pic_make_proc(pic, pic_assert_port, "pic_assert_port")); + pic_defvar(pic, name, pic_obj_value(port), pic_make_proc(pic, pic_assert_port)); } #define DEFINE_STANDARD_PORT_ACCESSOR(name, var) \ 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/reg.c b/extlib/benz/reg.c index c5268b2e..d72aceaf 100644 --- a/extlib/benz/reg.c +++ b/extlib/benz/reg.c @@ -118,7 +118,7 @@ pic_reg_make_register(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)); 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 47044312..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 */ @@ -1131,7 +1127,7 @@ 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, name); + proc = pic_make_proc(pic, func); sym = pic_intern_cstr(pic, name); @@ -1168,7 +1164,7 @@ pic_define(pic_state *pic, const char *name, pic_value val) 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, name))); + pic_define_(pic, name, pic_obj_value(pic_make_proc(pic, cfunc))); } void From 885942b541291f05b414074a1245e225b9ed40e9 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 19:10:15 +0900 Subject: [PATCH 124/125] more cleanup --- extlib/benz/codegen.c | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 75371b81..0261105d 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -508,20 +508,14 @@ analyze_lambda(pic_state *pic, analyze_scope *scope, pic_value obj) return analyze_defer(pic, scope, formals, body); } -static pic_value -analyze_declare(pic_state *pic, analyze_scope *scope, pic_sym *var) -{ - define_var(pic, scope, var); - - return analyze_var(pic, scope, var); -} - static pic_value analyze_define(pic_state *pic, analyze_scope *scope, pic_value obj) { pic_value var, val; - var = analyze_declare(pic, scope, pic_sym_ptr(pic_list_ref(pic, obj, 1))); + define_var(pic, scope, pic_sym_ptr(pic_list_ref(pic, obj, 1))); + + 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); From 3428803bdb7917c00130d3ba095d2039b709e8a6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 19:19:43 +0900 Subject: [PATCH 125/125] less consing --- extlib/benz/codegen.c | 38 +++++++++++++++----------------------- 1 file changed, 15 insertions(+), 23 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 0261105d..d9be026a 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -379,7 +379,7 @@ define_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) } static pic_value analyze_node(pic_state *, analyze_scope *, pic_value, bool); -static pic_value analyze_procedure(pic_state *, analyze_scope *, pic_value, pic_value); +static pic_value analyze_procedure(pic_state *, analyze_scope *, pic_value); static pic_value analyze(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) @@ -423,14 +423,14 @@ analyze_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) } static pic_value -analyze_defer(pic_state *pic, analyze_scope *scope, pic_value formal, pic_value body) +analyze_defer(pic_state *pic, analyze_scope *scope, pic_value form) { 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_list3(pic, formal, body, skel), scope->defer); + pic_push(pic, pic_cons(pic, skel, form), scope->defer); return skel; } @@ -438,31 +438,34 @@ analyze_defer(pic_state *pic, analyze_scope *scope, pic_value formal, pic_value static void analyze_deferred(pic_state *pic, analyze_scope *scope) { - pic_value defer, val, formal, body, dst, it; + pic_value defer, it, skel, form, val; pic_for_each (defer, pic_reverse(pic, scope->defer), it) { - formal = pic_list_ref(pic, defer, 0); - body = pic_list_ref(pic, defer, 1); - dst = pic_list_ref(pic, defer, 2); + skel = pic_car(pic, defer); + form = pic_cdr(pic, defer); - val = analyze_procedure(pic, scope, 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); } scope->defer = pic_nil_value(); } static pic_value -analyze_procedure(pic_state *pic, analyze_scope *up, pic_value formals, pic_value body) +analyze_procedure(pic_state *pic, analyze_scope *up, pic_value form) { analyze_scope s, *scope = &s; + pic_value formals, body; pic_value rest = pic_undef_value(); pic_vec *args, *locals, *captures; size_t i, j; + formals = pic_list_ref(pic, form, 1); + body = pic_list_ref(pic, form, 2); + analyzer_scope_init(pic, scope, formals, up); /* analyze body */ @@ -497,17 +500,6 @@ analyze_procedure(pic_state *pic, analyze_scope *up, pic_value formals, pic_valu 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(pic_state *pic, analyze_scope *scope, pic_value obj) -{ - pic_value formals, body; - - formals = pic_list_ref(pic, obj, 1); - body = pic_list_ref(pic, obj, 2); - - return analyze_defer(pic, scope, formals, body); -} - static pic_value analyze_define(pic_state *pic, analyze_scope *scope, pic_value obj) { @@ -762,7 +754,7 @@ analyze_node(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) return analyze_define(pic, scope, obj); } else if (sym == pic->uLAMBDA) { - return analyze_lambda(pic, scope, obj); + return analyze_defer(pic, scope, obj); } else if (sym == pic->uIF) { return analyze_if(pic, scope, obj, tailpos);