From 454146ab5225a7bda229b3835f3e0be39c6f1797 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Jun 2015 01:06:56 +0900 Subject: [PATCH 01/25] 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 02/25] [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 03/25] 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 04/25] 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 05/25] 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 06/25] 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 07/25] 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 08/25] 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 09/25] [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 10/25] 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 11/25] 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 12/25] 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 13/25] 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 14/25] 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 15/25] [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 16/25] 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 17/25] =?UTF-8?q?[bugfix]=20syntax-rules:=20don't=20compar?= =?UTF-8?q?e=20with=20variable=3D=3F=20a=20value=20of=20other=20type=20tha?= =?UTF-8?q?n=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 18/25] 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 19/25] 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 20/25] 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 21/25] 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 22/25] 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 23/25] 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 24/25] 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 25/25] 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