From c0378cb9ae21fb98ff84e6542482aed38e39b6b3 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 3 Apr 2014 00:55:34 +0900 Subject: [PATCH 01/18] [refactor] use senv_add_core to register core syntaxes --- src/macro.c | 81 +++++++++++++++++++++++++++-------------------------- 1 file changed, 41 insertions(+), 40 deletions(-) diff --git a/src/macro.c b/src/macro.c index dd92fba9..197a658a 100644 --- a/src/macro.c +++ b/src/macro.c @@ -91,6 +91,46 @@ senv_new_local(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value return senv; } +static void +senv_add_core(pic_state *pic, struct pic_senv *senv, pic_sym sym) +{ + pic_put_rename(pic, senv, sym, sym); +} + +struct pic_senv * +pic_null_syntactic_env(pic_state *pic) +{ + return senv_new(pic, NULL); +} + +struct pic_senv * +pic_minimal_syntactic_env(pic_state *pic) +{ + struct pic_senv *senv = pic_null_syntactic_env(pic); + + senv_add_core(pic, senv, pic->sDEFINE_LIBRARY); + senv_add_core(pic, senv, pic->sIMPORT); + senv_add_core(pic, senv, pic->sEXPORT); + + return senv; +} + +struct pic_senv * +pic_core_syntactic_env(pic_state *pic) +{ + struct pic_senv *senv = pic_minimal_syntactic_env(pic); + + senv_add_core(pic, senv, pic->sDEFINE); + senv_add_core(pic, senv, pic->sSETBANG); + senv_add_core(pic, senv, pic->sQUOTE); + senv_add_core(pic, senv, pic->sLAMBDA); + senv_add_core(pic, senv, pic->sIF); + senv_add_core(pic, senv, pic->sBEGIN); + senv_add_core(pic, senv, pic->sDEFINE_SYNTAX); + + return senv; +} + struct pic_macro * macro_new(pic_state *pic, struct pic_proc *proc, struct pic_senv *mac_env) { @@ -591,45 +631,6 @@ pic_macroexpand(pic_state *pic, pic_value expr) return v; } -struct pic_senv * -pic_null_syntactic_env(pic_state *pic) -{ - return senv_new(pic, NULL); -} - -#define register_core_syntax(pic,senv,id) do { \ - pic_sym sym = pic_intern_cstr(pic, id); \ - pic_put_rename(pic, senv, sym, sym); \ - } while (0) - -struct pic_senv * -pic_minimal_syntactic_env(pic_state *pic) -{ - struct pic_senv *senv = pic_null_syntactic_env(pic); - - register_core_syntax(pic, senv, "define-library"); - register_core_syntax(pic, senv, "import"); - register_core_syntax(pic, senv, "export"); - - return senv; -} - -struct pic_senv * -pic_core_syntactic_env(pic_state *pic) -{ - struct pic_senv *senv = pic_minimal_syntactic_env(pic); - - register_core_syntax(pic, senv, "define"); - register_core_syntax(pic, senv, "set!"); - register_core_syntax(pic, senv, "quote"); - register_core_syntax(pic, senv, "lambda"); - register_core_syntax(pic, senv, "if"); - register_core_syntax(pic, senv, "begin"); - register_core_syntax(pic, senv, "define-syntax"); - - return senv; -} - /* once read.c is implemented move there */ static pic_value pic_macro_include(pic_state *pic) @@ -954,7 +955,7 @@ pic_init_macro(pic_state *pic) pic_deflibrary ("(picrin macro)") { /* export define-macro syntax */ - pic_put_rename(pic, pic->lib->senv, pic->sDEFINE_MACRO, pic->sDEFINE_MACRO); + senv_add_core(pic, pic->lib->senv, pic->sDEFINE_MACRO); pic_export(pic, pic->sDEFINE_MACRO); pic_defun(pic, "gensym", pic_macro_gensym); From ffd962290f2486bd9be02b64287496a61f8a8c1d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 3 Apr 2014 01:15:39 +0900 Subject: [PATCH 02/18] s/symbol_rename/macroexpand_symbol/g --- src/macro.c | 50 +++++++++++++++++++++++++------------------------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/src/macro.c b/src/macro.c index 197a658a..bc13a54b 100644 --- a/src/macro.c +++ b/src/macro.c @@ -237,8 +237,23 @@ pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro) pic_export(pic, sym); } +static pic_value macroexpand_node(pic_state *, pic_value, struct pic_senv *, pic_value); + +static pic_value +macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) +{ + int ai = pic_gc_arena_preserve(pic); + pic_value v; + + v = macroexpand_node(pic, expr, senv, assoc_box); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, v); + return v; +} + static pic_sym -symbol_rename(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value assoc_box) +macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value assoc_box) { pic_sym rename; pic_value x; @@ -264,21 +279,6 @@ symbol_rename(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value asso } } -static pic_value macroexpand_node(pic_state *, pic_value, struct pic_senv *, pic_value); - -static pic_value -macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) -{ - int ai = pic_gc_arena_preserve(pic); - pic_value v; - - v = macroexpand_node(pic, expr, senv, assoc_box); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, v); - return v; -} - static pic_value macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) { @@ -296,7 +296,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu return macroexpand(pic, sc->expr, sc->senv, assoc_box); } case PIC_TT_SYMBOL: { - return pic_symbol_value(symbol_rename(pic, pic_sym(expr), senv, assoc_box)); + return pic_symbol_value(macroexpand_symbol(pic, pic_sym(expr), senv, assoc_box)); } case PIC_TT_PAIR: { pic_value car, v; @@ -745,7 +745,7 @@ er_macro_rename(pic_state *pic) mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1)); assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2); - return pic_symbol_value(symbol_rename(pic, sym, mac_env, assoc_box)); + return pic_symbol_value(macroexpand_symbol(pic, sym, mac_env, assoc_box)); } static pic_value @@ -764,8 +764,8 @@ er_macro_compare(pic_state *pic) use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0)); assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2); - m = symbol_rename(pic, pic_sym(a), use_env, assoc_box); - n = symbol_rename(pic, pic_sym(b), use_env, assoc_box); + m = macroexpand_symbol(pic, pic_sym(a), use_env, assoc_box); + n = macroexpand_symbol(pic, pic_sym(b), use_env, assoc_box); return pic_bool_value(m == n); } @@ -830,7 +830,7 @@ ir_macro_inject(pic_state *pic) use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0)); assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2); - return pic_symbol_value(symbol_rename(pic, sym, use_env, assoc_box)); + return pic_symbol_value(macroexpand_symbol(pic, sym, use_env, assoc_box)); } static pic_value @@ -849,8 +849,8 @@ ir_macro_compare(pic_state *pic) mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1)); assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2); - m = symbol_rename(pic, pic_sym(a), mac_env, assoc_box); - n = symbol_rename(pic, pic_sym(b), mac_env, assoc_box); + m = macroexpand_symbol(pic, pic_sym(a), mac_env, assoc_box); + n = macroexpand_symbol(pic, pic_sym(b), mac_env, assoc_box); return pic_bool_value(m == n); } @@ -860,7 +860,7 @@ ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, pic_valu { if (pic_sym_p(expr)) { pic_value r; - r = pic_sym_value(symbol_rename(pic, pic_sym(expr), use_env, assoc_box)); + r = pic_sym_value(macroexpand_symbol(pic, pic_sym(expr), use_env, assoc_box)); *ir = pic_acons(pic, r, expr, *ir); return r; } @@ -882,7 +882,7 @@ ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, pic_va if (pic_test(r = pic_assq(pic, expr, *ir))) { return pic_cdr(pic, r); } - return pic_sym_value(symbol_rename(pic, pic_sym(expr), mac_env, assoc_box)); + return pic_sym_value(macroexpand_symbol(pic, pic_sym(expr), mac_env, assoc_box)); } else if (pic_pair_p(expr)) { return pic_cons(pic, From 113ae32e4787c5dc70f328407311b88b4c3743b6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 3 Apr 2014 22:01:25 +0900 Subject: [PATCH 03/18] separate macroexpand processing into functions --- src/macro.c | 397 +++++++++++++++++++++++++++++----------------------- 1 file changed, 221 insertions(+), 176 deletions(-) diff --git a/src/macro.c b/src/macro.c index bc13a54b..5f91dae9 100644 --- a/src/macro.c +++ b/src/macro.c @@ -279,6 +279,218 @@ macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value } } +static pic_value +macroexpand_deflibrary(pic_state *pic, pic_value expr) +{ + struct pic_lib *prev = pic->lib; + pic_value v; + + if (pic_length(pic, expr) < 2) { + pic_error(pic, "syntax error"); + } + + pic_make_library(pic, pic_cadr(pic, expr)); + + pic_try { + pic_in_library(pic, pic_cadr(pic, expr)); + + pic_for_each (v, pic_cddr(pic, expr)) { + int ai = pic_gc_arena_preserve(pic); + + pic_eval(pic, v); + + pic_gc_arena_restore(pic, ai); + } + + pic_in_library(pic, prev->name); + } + pic_catch { + /* restores pic->lib even if an error occurs */ + pic_in_library(pic, prev->name); + pic_throw(pic, pic->err); + } + + return pic_none_value(); +} + +static pic_value +macroexpand_import(pic_state *pic, pic_value expr) +{ + pic_value spec; + + pic_for_each (spec, pic_cdr(pic, expr)) { + pic_import(pic, spec); + } + + return pic_none_value(); +} + +static pic_value +macroexpand_export(pic_state *pic, pic_value expr) +{ + pic_value spec; + + pic_for_each (spec, pic_cdr(pic, expr)) { + if (! pic_sym_p(spec)) { + pic_error(pic, "syntax error"); + } + /* TODO: warn if symbol is shadowed by local variable */ + pic_export(pic, pic_sym(spec)); + } + + return pic_none_value(); +} + +static pic_value +macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) +{ + pic_value var, val; + pic_sym sym, rename; + struct pic_macro *mac; + + if (pic_length(pic, expr) != 3) { + pic_error(pic, "syntax error"); + } + + var = pic_cadr(pic, expr); + if (! pic_sym_p(var)) { + var = macroexpand(pic, var, senv, assoc_box); + } + if (! pic_sym_p(var)) { + pic_error(pic, "binding to non-symbol object"); + } + sym = pic_sym(var); + if (! pic_find_rename(pic, senv, sym, &rename)) { + rename = pic_add_rename(pic, senv, sym); + } + + val = pic_cadr(pic, pic_cdr(pic, expr)); + + pic_try { + val = pic_eval(pic, val); + } pic_catch { + pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic)); + } + + if (! pic_proc_p(val)) { + pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); + } + + mac = macro_new(pic, pic_proc_ptr(val), senv); + xh_put(&pic->macros, rename, &mac); + + return pic_none_value(); +} + +static pic_value +macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv) +{ + pic_value var, val; + pic_sym sym, rename; + struct pic_macro *mac; + + if (pic_length(pic, expr) < 2) { + pic_error(pic, "syntax error"); + } + + var = pic_car(pic, pic_cdr(pic, expr)); + if (pic_pair_p(var)) { + /* FIXME: unhygienic */ + val = pic_cons(pic, pic_symbol_value(pic->sLAMBDA), + pic_cons(pic, pic_cdr(pic, var), + pic_cdr(pic, pic_cdr(pic, expr)))); + var = pic_car(pic, var); + } + else { + if (pic_length(pic, expr) != 3) { + pic_error(pic, "syntax_error"); + } + val = pic_car(pic, pic_cdr(pic, pic_cdr(pic, expr))); + } + if (! pic_sym_p(var)) { + pic_error(pic, "syntax error"); + } + sym = pic_sym(var); + if (! pic_find_rename(pic, senv, sym, &rename)) { + rename = pic_add_rename(pic, senv, sym); + } + + pic_try { + val = pic_eval(pic, val); + } pic_catch { + pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic)); + } + + if (! pic_proc_p(val)) { + pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); + } + + mac = macro_new(pic, pic_proc_ptr(val), NULL); + xh_put(&pic->macros, rename, &mac); + + return pic_none_value(); +} + +static pic_value +macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) +{ + pic_sym sym; + pic_value formals; + + if (pic_length(pic, expr) < 2) { + pic_error(pic, "syntax error"); + } + + formals = pic_cadr(pic, expr); + if (pic_pair_p(formals)) { + struct pic_senv *in = senv_new_local(pic, pic_cdr(pic, formals), senv, assoc_box); + pic_value a; + + /* defined symbol */ + a = pic_car(pic, formals); + if (! pic_sym_p(a)) { + a = macroexpand(pic, a, senv, assoc_box); + } + if (! pic_sym_p(a)) { + pic_error(pic, "binding to non-symbol object"); + } + sym = pic_sym(a); + if (! pic_find_rename(pic, senv, sym, NULL)) { + pic_add_rename(pic, senv, sym); + } + + /* binding value */ + return pic_cons(pic, pic_sym_value(pic->sDEFINE), + pic_cons(pic, + macroexpand_list(pic, pic_cadr(pic, expr), in, assoc_box), + macroexpand_list(pic, pic_cddr(pic, expr), in, assoc_box))); + } + + if (! pic_sym_p(formals)) { + formals = macroexpand(pic, formals, senv, assoc_box); + } + if (! pic_sym_p(formals)) { + pic_error(pic, "binding to non-symbol object"); + } + sym = pic_sym(formals); + if (! pic_find_rename(pic, senv, sym, NULL)) { + pic_add_rename(pic, senv, sym); + } + + return pic_cons(pic, pic_symbol_value(pic->sDEFINE), macroexpand_list(pic, pic_cdr(pic, expr), senv, assoc_box)); +} + +static pic_value +macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) +{ + struct pic_senv *in = senv_new_local(pic, pic_cadr(pic, expr), senv, assoc_box); + + return pic_cons(pic, pic_sym_value(pic->sLAMBDA), + pic_cons(pic, + macroexpand_list(pic, pic_cadr(pic, expr), in, assoc_box), + macroexpand_list(pic, pic_cddr(pic, expr), in, assoc_box))); +} + static pic_value macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) { @@ -290,16 +502,13 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu switch (pic_type(expr)) { case PIC_TT_SC: { - struct pic_sc *sc; - - sc = pic_sc(expr); - return macroexpand(pic, sc->expr, sc->senv, assoc_box); + return macroexpand(pic, pic_sc(expr)->expr, pic_sc(expr)->senv, assoc_box); } case PIC_TT_SYMBOL: { return pic_symbol_value(macroexpand_symbol(pic, pic_sym(expr), senv, assoc_box)); } case PIC_TT_PAIR: { - pic_value car, v; + pic_value car; xh_entry *e; if (! pic_list_p(expr)) { @@ -311,195 +520,31 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu pic_sym tag = pic_sym(car); if (tag == pic->sDEFINE_LIBRARY) { - struct pic_lib *prev = pic->lib; - - if (pic_length(pic, expr) < 2) { - pic_error(pic, "syntax error"); - } - pic_make_library(pic, pic_cadr(pic, expr)); - - pic_try { - pic_in_library(pic, pic_cadr(pic, expr)); - - pic_for_each (v, pic_cddr(pic, expr)) { - int ai = pic_gc_arena_preserve(pic); - - pic_eval(pic, v); - - pic_gc_arena_restore(pic, ai); - } - - pic_in_library(pic, prev->name); - } - pic_catch { - /* restores pic->lib even if an error occurs */ - pic_in_library(pic, prev->name); - pic_throw(pic, pic->err); - } - - return pic_none_value(); + return macroexpand_deflibrary(pic, expr); } else if (tag == pic->sIMPORT) { - pic_value spec; - pic_for_each (spec, pic_cdr(pic, expr)) { - pic_import(pic, spec); - } - return pic_none_value(); + return macroexpand_import(pic, expr); } else if (tag == pic->sEXPORT) { - pic_value spec; - pic_for_each (spec, pic_cdr(pic, expr)) { - if (! pic_sym_p(spec)) { - pic_error(pic, "syntax error"); - } - /* TODO: warn if symbol is shadowed by local variable */ - pic_export(pic, pic_sym(spec)); - } - return pic_none_value(); + return macroexpand_export(pic, expr); } else if (tag == pic->sDEFINE_SYNTAX) { - pic_value var, val; - pic_sym sym, rename; - struct pic_macro *mac; - - if (pic_length(pic, expr) != 3) { - pic_error(pic, "syntax error"); - } - - var = pic_cadr(pic, expr); - if (! pic_sym_p(var)) { - var = macroexpand(pic, var, senv, assoc_box); - } - if (! pic_sym_p(var)) { - pic_error(pic, "binding to non-symbol object"); - } - sym = pic_sym(var); - if (! pic_find_rename(pic, senv, sym, &rename)) { - rename = pic_add_rename(pic, senv, sym); - } - - val = pic_cadr(pic, pic_cdr(pic, expr)); - - pic_try { - v = pic_eval(pic, val); - } pic_catch { - pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic)); - } - - if (! pic_proc_p(v)) { - pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); - } - - mac = macro_new(pic, pic_proc_ptr(v), senv); - xh_put(&pic->macros, rename, &mac); - - return pic_none_value(); + return macroexpand_defsyntax(pic, expr, senv, assoc_box); } else if (tag == pic->sDEFINE_MACRO) { - pic_value var, val; - pic_sym sym, rename; - struct pic_macro *mac; - - if (pic_length(pic, expr) < 2) { - pic_error(pic, "syntax error"); - } - - var = pic_car(pic, pic_cdr(pic, expr)); - if (pic_pair_p(var)) { - /* FIXME: unhygienic */ - val = pic_cons(pic, pic_symbol_value(pic->sLAMBDA), - pic_cons(pic, pic_cdr(pic, var), - pic_cdr(pic, pic_cdr(pic, expr)))); - var = pic_car(pic, var); - } - else { - if (pic_length(pic, expr) != 3) { - pic_error(pic, "syntax_error"); - } - val = pic_car(pic, pic_cdr(pic, pic_cdr(pic, expr))); - } - if (! pic_sym_p(var)) { - pic_error(pic, "syntax error"); - } - sym = pic_sym(var); - if (! pic_find_rename(pic, senv, sym, &rename)) { - rename = pic_add_rename(pic, senv, sym); - } - - pic_try { - v = pic_eval(pic, val); - } pic_catch { - pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic)); - } - - if (! pic_proc_p(v)) { - pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); - } - - mac = macro_new(pic, pic_proc_ptr(v), NULL); - xh_put(&pic->macros, rename, &mac); - - return pic_none_value(); + return macroexpand_defmacro(pic, expr, senv); } else if (tag == pic->sLAMBDA) { - struct pic_senv *in = senv_new_local(pic, pic_cadr(pic, expr), senv, assoc_box); - - return pic_cons(pic, car, - pic_cons(pic, - macroexpand_list(pic, pic_cadr(pic, expr), in, assoc_box), - macroexpand_list(pic, pic_cddr(pic, expr), in, assoc_box))); + return macroexpand_lambda(pic, expr, senv, assoc_box); } else if (tag == pic->sDEFINE) { - pic_sym sym; - pic_value formals; - - if (pic_length(pic, expr) < 2) { - pic_error(pic, "syntax error"); - } - - formals = pic_cadr(pic, expr); - if (pic_pair_p(formals)) { - struct pic_senv *in = senv_new_local(pic, pic_cdr(pic, formals), senv, assoc_box); - pic_value a; - - /* defined symbol */ - a = pic_car(pic, formals); - if (! pic_sym_p(a)) { - a = macroexpand(pic, a, senv, assoc_box); - } - if (! pic_sym_p(a)) { - pic_error(pic, "binding to non-symbol object"); - } - sym = pic_sym(a); - if (! pic_find_rename(pic, senv, sym, NULL)) { - pic_add_rename(pic, senv, sym); - } - - /* binding value */ - return pic_cons(pic, car, - pic_cons(pic, - macroexpand_list(pic, pic_cadr(pic, expr), in, assoc_box), - macroexpand_list(pic, pic_cddr(pic, expr), in, assoc_box))); - } - - if (! pic_sym_p(formals)) { - formals = macroexpand(pic, formals, senv, assoc_box); - } - if (! pic_sym_p(formals)) { - pic_error(pic, "binding to non-symbol object"); - } - sym = pic_sym(formals); - if (! pic_find_rename(pic, senv, sym, NULL)) { - pic_add_rename(pic, senv, sym); - } - - return pic_cons(pic, pic_symbol_value(tag), macroexpand_list(pic, pic_cdr(pic, expr), senv, assoc_box)); + return macroexpand_define(pic, expr, senv, assoc_box); } else if (tag == pic->sQUOTE) { From 030c7f9034786bc552b43c2d50a2387e7fb7f3ec Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 3 Apr 2014 22:16:09 +0900 Subject: [PATCH 04/18] refactor macro use expander --- src/macro.c | 106 ++++++++++++++++++++++++++++------------------------ 1 file changed, 58 insertions(+), 48 deletions(-) diff --git a/src/macro.c b/src/macro.c index 5f91dae9..b4a10152 100644 --- a/src/macro.c +++ b/src/macro.c @@ -131,7 +131,7 @@ pic_core_syntactic_env(pic_state *pic) return senv; } -struct pic_macro * +static struct pic_macro * macro_new(pic_state *pic, struct pic_proc *proc, struct pic_senv *mac_env) { struct pic_macro *mac; @@ -142,6 +142,24 @@ macro_new(pic_state *pic, struct pic_proc *proc, struct pic_senv *mac_env) return mac; } +static void +add_macro(pic_state *pic, pic_sym rename, struct pic_macro *mac) +{ + xh_put(&pic->macros, rename, &mac); +} + +static struct pic_macro * +find_macro(pic_state *pic, pic_sym rename) +{ + xh_entry *e; + + if ((e = xh_get(&pic->macros, rename)) == NULL) { + return NULL; + } + return xh_val(e, struct pic_macro *); +} + + static struct pic_sc * sc_new(pic_state *pic, pic_value expr, struct pic_senv *senv) { @@ -231,7 +249,7 @@ pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro) /* symbol registration */ sym = pic_intern_cstr(pic, name); rename = pic_add_rename(pic, pic->lib->senv, sym); - xh_put(&pic->macros, rename, &mac); + add_macro(pic, rename, mac); /* auto export! */ pic_export(pic, sym); @@ -346,7 +364,6 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, pic { pic_value var, val; pic_sym sym, rename; - struct pic_macro *mac; if (pic_length(pic, expr) != 3) { pic_error(pic, "syntax error"); @@ -376,8 +393,7 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, pic pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); } - mac = macro_new(pic, pic_proc_ptr(val), senv); - xh_put(&pic->macros, rename, &mac); + add_macro(pic, rename, macro_new(pic, pic_proc_ptr(val), senv)); return pic_none_value(); } @@ -387,7 +403,6 @@ macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv) { pic_value var, val; pic_sym sym, rename; - struct pic_macro *mac; if (pic_length(pic, expr) < 2) { pic_error(pic, "syntax error"); @@ -425,8 +440,7 @@ macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv) pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); } - mac = macro_new(pic, pic_proc_ptr(val), NULL); - xh_put(&pic->macros, rename, &mac); + add_macro(pic, rename, macro_new(pic, pic_proc_ptr(val), NULL)); return pic_none_value(); } @@ -491,6 +505,39 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_va macroexpand_list(pic, pic_cddr(pic, expr), in, assoc_box))); } +static pic_value +macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, pic_value assoc_box) +{ + pic_value v, args; + +#if DEBUG + puts("before expand-1:"); + pic_debug(pic, expr); + puts(""); +#endif + + if (mac->senv == NULL) { /* legacy macro */ + args = pic_cdr(pic, expr); + } + else { + args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv)); + } + + pic_try { + v = pic_apply(pic, mac->proc, args); + } pic_catch { + pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic)); + } + +#if DEBUG + puts("after expand-1:"); + pic_debug(pic, v); + puts(""); +#endif + + return macroexpand(pic, v, senv, assoc_box); +} + static pic_value macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) { @@ -509,7 +556,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu } case PIC_TT_PAIR: { pic_value car; - xh_entry *e; + struct pic_macro *mac; if (! pic_list_p(expr)) { pic_errorf(pic, "cannot macroexpand improper list: ~s", expr); @@ -522,67 +569,30 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu if (tag == pic->sDEFINE_LIBRARY) { return macroexpand_deflibrary(pic, expr); } - else if (tag == pic->sIMPORT) { return macroexpand_import(pic, expr); } - else if (tag == pic->sEXPORT) { return macroexpand_export(pic, expr); } - else if (tag == pic->sDEFINE_SYNTAX) { return macroexpand_defsyntax(pic, expr, senv, assoc_box); } - else if (tag == pic->sDEFINE_MACRO) { return macroexpand_defmacro(pic, expr, senv); } - else if (tag == pic->sLAMBDA) { return macroexpand_lambda(pic, expr, senv, assoc_box); } - else if (tag == pic->sDEFINE) { return macroexpand_define(pic, expr, senv, assoc_box); } - else if (tag == pic->sQUOTE) { return pic_cons(pic, car, pic_cdr(pic, expr)); } - /* macro */ - if ((e = xh_get(&pic->macros, tag)) != NULL) { - pic_value v, args; - struct pic_macro *mac; - -#if DEBUG - puts("before expand-1:"); - pic_debug(pic, expr); - puts(""); -#endif - - mac = xh_val(e, struct pic_macro *); - if (mac->senv == NULL) { /* legacy macro */ - args = pic_cdr(pic, expr); - } - else { - args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv)); - } - - pic_try { - v = pic_apply(pic, mac->proc, args); - } pic_catch { - pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic)); - } - -#if DEBUG - puts("after expand-1:"); - pic_debug(pic, v); - puts(""); -#endif - - return macroexpand(pic, v, senv, assoc_box); + if ((mac = find_macro(pic, tag)) != NULL) { + return macroexpand_macro(pic, mac, expr, senv, assoc_box); } } From aba1f5139b95a18766c288daec5926fe174f2cce Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 3 Apr 2014 22:26:30 +0900 Subject: [PATCH 05/18] remove senv_add_core --- src/macro.c | 28 +++++++++++----------------- 1 file changed, 11 insertions(+), 17 deletions(-) diff --git a/src/macro.c b/src/macro.c index b4a10152..e8cfa91b 100644 --- a/src/macro.c +++ b/src/macro.c @@ -91,12 +91,6 @@ senv_new_local(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value return senv; } -static void -senv_add_core(pic_state *pic, struct pic_senv *senv, pic_sym sym) -{ - pic_put_rename(pic, senv, sym, sym); -} - struct pic_senv * pic_null_syntactic_env(pic_state *pic) { @@ -108,9 +102,9 @@ pic_minimal_syntactic_env(pic_state *pic) { struct pic_senv *senv = pic_null_syntactic_env(pic); - senv_add_core(pic, senv, pic->sDEFINE_LIBRARY); - senv_add_core(pic, senv, pic->sIMPORT); - senv_add_core(pic, senv, pic->sEXPORT); + pic_put_rename(pic, senv, pic->sDEFINE_LIBRARY, pic->sDEFINE_LIBRARY); + pic_put_rename(pic, senv, pic->sIMPORT, pic->sIMPORT); + pic_put_rename(pic, senv, pic->sEXPORT, pic->sEXPORT); return senv; } @@ -120,13 +114,13 @@ pic_core_syntactic_env(pic_state *pic) { struct pic_senv *senv = pic_minimal_syntactic_env(pic); - senv_add_core(pic, senv, pic->sDEFINE); - senv_add_core(pic, senv, pic->sSETBANG); - senv_add_core(pic, senv, pic->sQUOTE); - senv_add_core(pic, senv, pic->sLAMBDA); - senv_add_core(pic, senv, pic->sIF); - senv_add_core(pic, senv, pic->sBEGIN); - senv_add_core(pic, senv, pic->sDEFINE_SYNTAX); + pic_put_rename(pic, senv, pic->sDEFINE, pic->sDEFINE); + pic_put_rename(pic, senv, pic->sSETBANG, pic->sSETBANG); + pic_put_rename(pic, senv, pic->sQUOTE, pic->sQUOTE); + pic_put_rename(pic, senv, pic->sLAMBDA, pic->sLAMBDA); + pic_put_rename(pic, senv, pic->sIF, pic->sIF); + pic_put_rename(pic, senv, pic->sBEGIN, pic->sBEGIN); + pic_put_rename(pic, senv, pic->sDEFINE_SYNTAX, pic->sDEFINE_SYNTAX); return senv; } @@ -1010,7 +1004,7 @@ pic_init_macro(pic_state *pic) pic_deflibrary ("(picrin macro)") { /* export define-macro syntax */ - senv_add_core(pic, pic->lib->senv, pic->sDEFINE_MACRO); + pic_put_rename(pic, pic->lib->senv, pic->sDEFINE_MACRO, pic->sDEFINE_MACRO); pic_export(pic, pic->sDEFINE_MACRO); pic_defun(pic, "gensym", pic_macro_gensym); From 880c8c2b03dc24e24fbf482413e871d982f48ca2 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 3 Apr 2014 22:27:36 +0900 Subject: [PATCH 06/18] add macroexpand_quote --- src/macro.c | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/macro.c b/src/macro.c index e8cfa91b..fd13cd9b 100644 --- a/src/macro.c +++ b/src/macro.c @@ -499,6 +499,12 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_va macroexpand_list(pic, pic_cddr(pic, expr), in, assoc_box))); } +static pic_value +macroexpand_quote(pic_state *pic, pic_value expr) +{ + return pic_cons(pic, pic_sym_value(pic->sQUOTE), pic_cdr(pic, expr)); +} + static pic_value macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, pic_value assoc_box) { @@ -582,7 +588,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu return macroexpand_define(pic, expr, senv, assoc_box); } else if (tag == pic->sQUOTE) { - return pic_cons(pic, car, pic_cdr(pic, expr)); + return macroexpand_quote(pic, expr); } if ((mac = find_macro(pic, tag)) != NULL) { From 0823149e4f348da228234cc2e1781c7f84b9451d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 4 Apr 2014 12:48:26 +0900 Subject: [PATCH 07/18] cleanup --- src/macro.c | 1 - 1 file changed, 1 deletion(-) diff --git a/src/macro.c b/src/macro.c index fd13cd9b..09acc9c3 100644 --- a/src/macro.c +++ b/src/macro.c @@ -153,7 +153,6 @@ find_macro(pic_state *pic, pic_sym rename) return xh_val(e, struct pic_macro *); } - static struct pic_sc * sc_new(pic_state *pic, pic_value expr, struct pic_senv *senv) { From 845778eefbef33d687bef435a801305bfb66b6b2 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 4 Apr 2014 12:55:51 +0900 Subject: [PATCH 08/18] add define_macro --- src/macro.c | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/src/macro.c b/src/macro.c index 09acc9c3..04f2d4e8 100644 --- a/src/macro.c +++ b/src/macro.c @@ -142,6 +142,12 @@ add_macro(pic_state *pic, pic_sym rename, struct pic_macro *mac) xh_put(&pic->macros, rename, &mac); } +static void +define_macro(pic_state *pic, pic_sym rename, struct pic_proc *proc, struct pic_senv *senv) +{ + add_macro(pic, rename, macro_new(pic, proc, senv)); +} + static struct pic_macro * find_macro(pic_state *pic, pic_sym rename) { @@ -233,16 +239,12 @@ pic_export(pic_state *pic, pic_sym sym) void pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro) { - struct pic_macro *mac; pic_sym sym, rename; - /* new macro */ - mac = macro_new(pic, macro, NULL); - /* symbol registration */ sym = pic_intern_cstr(pic, name); rename = pic_add_rename(pic, pic->lib->senv, sym); - add_macro(pic, rename, mac); + define_macro(pic, rename, macro, NULL); /* auto export! */ pic_export(pic, sym); @@ -386,7 +388,7 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, pic pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); } - add_macro(pic, rename, macro_new(pic, pic_proc_ptr(val), senv)); + define_macro(pic, rename, pic_proc_ptr(val), senv); return pic_none_value(); } @@ -433,7 +435,7 @@ macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv) pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); } - add_macro(pic, rename, macro_new(pic, pic_proc_ptr(val), NULL)); + define_macro(pic, rename, pic_proc_ptr(val), NULL); return pic_none_value(); } From 4ec8398118fb402f98188a2b601b2bf1744e53c0 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 4 Apr 2014 12:58:28 +0900 Subject: [PATCH 09/18] inline macro_new and add_macro --- src/macro.c | 17 +++-------------- 1 file changed, 3 insertions(+), 14 deletions(-) diff --git a/src/macro.c b/src/macro.c index 04f2d4e8..21a638df 100644 --- a/src/macro.c +++ b/src/macro.c @@ -125,29 +125,18 @@ pic_core_syntactic_env(pic_state *pic) return senv; } -static struct pic_macro * -macro_new(pic_state *pic, struct pic_proc *proc, struct pic_senv *mac_env) +static void +define_macro(pic_state *pic, pic_sym rename, struct pic_proc *proc, struct pic_senv *senv) { struct pic_macro *mac; mac = (struct pic_macro *)pic_obj_alloc(pic, sizeof(struct pic_macro), PIC_TT_MACRO); - mac->senv = mac_env; + mac->senv = senv; mac->proc = proc; - return mac; -} -static void -add_macro(pic_state *pic, pic_sym rename, struct pic_macro *mac) -{ xh_put(&pic->macros, rename, &mac); } -static void -define_macro(pic_state *pic, pic_sym rename, struct pic_proc *proc, struct pic_senv *senv) -{ - add_macro(pic, rename, macro_new(pic, proc, senv)); -} - static struct pic_macro * find_macro(pic_state *pic, pic_sym rename) { From 1e5c6d899e42886025639d96296185e052f173ed Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 4 Apr 2014 13:07:16 +0900 Subject: [PATCH 10/18] s/pic_sc/pic_sc_ptr/g. s/pic_senv/pic_senv_ptr/g. --- include/picrin/macro.h | 5 ++--- src/macro.c | 10 +++++----- 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/include/picrin/macro.h b/include/picrin/macro.h index 14097046..b22de253 100644 --- a/include/picrin/macro.h +++ b/include/picrin/macro.h @@ -27,13 +27,12 @@ struct pic_sc { struct pic_senv *senv; }; -#define pic_sc(v) ((struct pic_sc *)pic_ptr(v)) #define pic_sc_p(v) (pic_type(v) == PIC_TT_SC) +#define pic_sc_ptr(v) ((struct pic_sc *)pic_ptr(v)) -#define pic_macro(v) ((struct pic_macro *)pic_ptr(v)) #define pic_macro_p(v) (pic_type(v) == PIC_TT_MACRO) +#define pic_macro_ptr(v) ((struct pic_macro *)pic_ptr(v)) -#define pic_senv(v) ((struct pic_senv *)pic_ptr(v)) #define pic_senv_p(v) (pic_type(v) == PIC_TT_SENV) #define pic_senv_ptr(v) ((struct pic_senv *)pic_ptr(v)) diff --git a/src/macro.c b/src/macro.c index 21a638df..4cabe215 100644 --- a/src/macro.c +++ b/src/macro.c @@ -166,7 +166,7 @@ identifier_p(pic_value obj) return true; } if (pic_sc_p(obj)) { - return identifier_p(pic_sc(obj)->expr); + return identifier_p(pic_sc_ptr(obj)->expr); } return false; } @@ -539,7 +539,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu switch (pic_type(expr)) { case PIC_TT_SC: { - return macroexpand(pic, pic_sc(expr)->expr, pic_sc(expr)->senv, assoc_box); + return macroexpand(pic, pic_sc_ptr(expr)->expr, pic_sc_ptr(expr)->senv, assoc_box); } case PIC_TT_SYMBOL: { return pic_symbol_value(macroexpand_symbol(pic, pic_sym(expr), senv, assoc_box)); @@ -743,7 +743,7 @@ pic_macro_make_sc(pic_state *pic) pic_error(pic, "make-syntactic-closure: senv required"); /* just ignore free_vars for now */ - sc = sc_new(pic, expr, pic_senv(senv)); + sc = sc_new(pic, expr, pic_senv_ptr(senv)); return pic_obj_value(sc); } @@ -769,11 +769,11 @@ pic_macro_identifier_eq_p(pic_state *pic) if (! pic_senv_p(e)) { pic_error(pic, "unexpected type of argument 1"); } - e1 = pic_senv(e); + e1 = pic_senv_ptr(e); if (! pic_senv_p(f)) { pic_error(pic, "unexpected type of argument 3"); } - e2 = pic_senv(f); + e2 = pic_senv_ptr(f); return pic_bool_value(identifier_eq_p(pic, e1, x, e2, y)); } From a94938c2f843fffee3be8d7f3785e7d3f354a349 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 4 Apr 2014 16:34:06 +0900 Subject: [PATCH 11/18] cleanup --- include/picrin/proc.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/include/picrin/proc.h b/include/picrin/proc.h index 86e11121..d96fb6c3 100644 --- a/include/picrin/proc.h +++ b/include/picrin/proc.h @@ -40,9 +40,9 @@ struct pic_proc { #define pic_proc_irep_p(proc) ((proc)->kind == PIC_PROC_KIND_IREP) #define pic_proc_p(o) (pic_type(o) == PIC_TT_PROC) -#define pic_env_p(o) (pic_type(o) == PIC_TT_ENV) - #define pic_proc_ptr(o) ((struct pic_proc *)pic_ptr(o)) + +#define pic_env_p(o) (pic_type(o) == PIC_TT_ENV) #define pic_env_ptr(o) ((struct pic_env *)pic_ptr(o)) struct pic_proc *pic_proc_new(pic_state *, pic_func_t, const char *); From 0d0d4e6482ac4fdba9ba725be372a9ddd8acac38 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 5 Apr 2014 01:20:19 +0900 Subject: [PATCH 12/18] s/senv_new_local/push_scope/g --- src/macro.c | 66 ++++++++++++++++++++++++++--------------------------- 1 file changed, 33 insertions(+), 33 deletions(-) diff --git a/src/macro.c b/src/macro.c index 4cabe215..f554d014 100644 --- a/src/macro.c +++ b/src/macro.c @@ -60,37 +60,6 @@ senv_new(pic_state *pic, struct pic_senv *up) return senv; } -static struct pic_senv * -senv_new_local(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value assoc_box) -{ - struct pic_senv *senv; - pic_value a; - - senv = senv_new(pic, up); - - for (a = formals; pic_pair_p(a); a = pic_cdr(pic, a)) { - pic_value v = pic_car(pic, a); - - if (! pic_sym_p(v)) { - v = macroexpand(pic, v, up, assoc_box); - } - if (! pic_sym_p(v)) { - pic_error(pic, "syntax error"); - } - pic_add_rename(pic, senv, pic_sym(v)); - } - if (! pic_sym_p(a)) { - a = macroexpand(pic, a, up, assoc_box); - } - if (pic_sym_p(a)) { - pic_add_rename(pic, senv, pic_sym(a)); - } - else if (! pic_nil_p(a)) { - pic_error(pic, "syntax error"); - } - return senv; -} - struct pic_senv * pic_null_syntactic_env(pic_state *pic) { @@ -125,6 +94,37 @@ pic_core_syntactic_env(pic_state *pic) return senv; } +static struct pic_senv * +push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value assoc_box) +{ + struct pic_senv *senv; + pic_value a; + + senv = senv_new(pic, up); + + for (a = formals; pic_pair_p(a); a = pic_cdr(pic, a)) { + pic_value v = pic_car(pic, a); + + if (! pic_sym_p(v)) { + v = macroexpand(pic, v, up, assoc_box); + } + if (! pic_sym_p(v)) { + pic_error(pic, "syntax error"); + } + pic_add_rename(pic, senv, pic_sym(v)); + } + if (! pic_sym_p(a)) { + a = macroexpand(pic, a, up, assoc_box); + } + if (pic_sym_p(a)) { + pic_add_rename(pic, senv, pic_sym(a)); + } + else if (! pic_nil_p(a)) { + pic_error(pic, "syntax error"); + } + return senv; +} + static void define_macro(pic_state *pic, pic_sym rename, struct pic_proc *proc, struct pic_senv *senv) { @@ -441,7 +441,7 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_va formals = pic_cadr(pic, expr); if (pic_pair_p(formals)) { - struct pic_senv *in = senv_new_local(pic, pic_cdr(pic, formals), senv, assoc_box); + struct pic_senv *in = push_scope(pic, pic_cdr(pic, formals), senv, assoc_box); pic_value a; /* defined symbol */ @@ -481,7 +481,7 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_va static pic_value macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) { - struct pic_senv *in = senv_new_local(pic, pic_cadr(pic, expr), senv, assoc_box); + struct pic_senv *in = push_scope(pic, pic_cadr(pic, expr), senv, assoc_box); return pic_cons(pic, pic_sym_value(pic->sLAMBDA), pic_cons(pic, From 9d2ac6b994291a50398a4e70da91f3d9a6abb484 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 5 Apr 2014 01:21:16 +0900 Subject: [PATCH 13/18] inline senv_new --- src/macro.c | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/src/macro.c b/src/macro.c index f554d014..b2a5275c 100644 --- a/src/macro.c +++ b/src/macro.c @@ -48,24 +48,18 @@ pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *ren static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *, pic_value); static pic_value macroexpand_list(pic_state *, pic_value, struct pic_senv *, pic_value); -static struct pic_senv * -senv_new(pic_state *pic, struct pic_senv *up) +struct pic_senv * +pic_null_syntactic_env(pic_state *pic) { struct pic_senv *senv; senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); - senv->up = up; + senv->up = NULL; xh_init_int(&senv->renames, sizeof(pic_sym)); return senv; } -struct pic_senv * -pic_null_syntactic_env(pic_state *pic) -{ - return senv_new(pic, NULL); -} - struct pic_senv * pic_minimal_syntactic_env(pic_state *pic) { @@ -100,7 +94,9 @@ push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value ass struct pic_senv *senv; pic_value a; - senv = senv_new(pic, up); + senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); + senv->up = up; + xh_init_int(&senv->renames, sizeof(pic_sym)); for (a = formals; pic_pair_p(a); a = pic_cdr(pic, a)) { pic_value v = pic_car(pic, a); From 1215202f669cbcc80da8244c5faf86463f1c176d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 5 Apr 2014 01:23:20 +0900 Subject: [PATCH 14/18] cleanup --- src/macro.c | 75 ++++++++++++++++++++++++++--------------------------- 1 file changed, 37 insertions(+), 38 deletions(-) diff --git a/src/macro.c b/src/macro.c index b2a5275c..2ef59598 100644 --- a/src/macro.c +++ b/src/macro.c @@ -45,9 +45,6 @@ pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *ren return true; } -static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *, pic_value); -static pic_value macroexpand_list(pic_state *, pic_value, struct pic_senv *, pic_value); - struct pic_senv * pic_null_syntactic_env(pic_state *pic) { @@ -88,6 +85,8 @@ pic_core_syntactic_env(pic_state *pic) return senv; } +static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *, pic_value); + static struct pic_senv * push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value assoc_box) { @@ -250,6 +249,41 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value ass return v; } +static pic_value +macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, pic_value assoc_box) +{ + int ai = pic_gc_arena_preserve(pic); + pic_value v, vs; + + /* macroexpand in order */ + vs = pic_nil_value(); + while (pic_pair_p(list)) { + v = pic_car(pic, list); + + vs = pic_cons(pic, macroexpand(pic, v, senv, assoc_box), vs); + list = pic_cdr(pic, list); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, vs); + pic_gc_protect(pic, list); + } + + list = macroexpand(pic, list, senv, assoc_box); + + /* reverse the result */ + pic_for_each (v, vs) { + list = pic_cons(pic, v, list); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, vs); + pic_gc_protect(pic, list); + } + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, list); + return list; +} + static pic_sym macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value assoc_box) { @@ -613,41 +647,6 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu UNREACHABLE(); } -static pic_value -macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, pic_value assoc_box) -{ - int ai = pic_gc_arena_preserve(pic); - pic_value v, vs; - - /* macroexpand in order */ - vs = pic_nil_value(); - while (pic_pair_p(list)) { - v = pic_car(pic, list); - - vs = pic_cons(pic, macroexpand(pic, v, senv, assoc_box), vs); - list = pic_cdr(pic, list); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, vs); - pic_gc_protect(pic, list); - } - - list = macroexpand(pic, list, senv, assoc_box); - - /* reverse the result */ - pic_for_each (v, vs) { - list = pic_cons(pic, v, list); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, vs); - pic_gc_protect(pic, list); - } - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, list); - return list; -} - pic_value pic_macroexpand(pic_state *pic, pic_value expr) { From 16ad48aade2071f7744c3f004bae8ba0aeb9b1e6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 5 Apr 2014 01:28:57 +0900 Subject: [PATCH 15/18] =?UTF-8?q?add=20sc=5F=20prefix=20to=20identifer=3F?= =?UTF-8?q?=20and=20identifier=3D=3F=20functions?= --- src/macro.c | 84 ++++++++++++++++++++++++++--------------------------- 1 file changed, 42 insertions(+), 42 deletions(-) diff --git a/src/macro.c b/src/macro.c index 2ef59598..f8c7b66a 100644 --- a/src/macro.c +++ b/src/macro.c @@ -143,46 +143,6 @@ find_macro(pic_state *pic, pic_sym rename) return xh_val(e, struct pic_macro *); } -static struct pic_sc * -sc_new(pic_state *pic, pic_value expr, struct pic_senv *senv) -{ - struct pic_sc *sc; - - sc = (struct pic_sc *)pic_obj_alloc(pic, sizeof(struct pic_sc), PIC_TT_SC); - sc->expr = expr; - sc->senv = senv; - return sc; -} - -static bool -identifier_p(pic_value obj) -{ - if (pic_sym_p(obj)) { - return true; - } - if (pic_sc_p(obj)) { - return identifier_p(pic_sc_ptr(obj)->expr); - } - return false; -} - -static bool -identifier_eq_p(pic_state *pic, struct pic_senv *e1, pic_value x, struct pic_senv *e2, pic_value y) -{ - pic_value box; - - if (! (identifier_p(x) && identifier_p(y))) { - return false; - } - - box = pic_box(pic, pic_nil_value()); - - x = macroexpand(pic, x, e1, box); - y = macroexpand(pic, y, e2, box); - - return pic_eq_p(x, y); -} - void pic_import(pic_state *pic, pic_value spec) { @@ -726,6 +686,46 @@ pic_macro_macroexpand(pic_state *pic) return pic_macroexpand(pic, expr); } +static struct pic_sc * +sc_new(pic_state *pic, pic_value expr, struct pic_senv *senv) +{ + struct pic_sc *sc; + + sc = (struct pic_sc *)pic_obj_alloc(pic, sizeof(struct pic_sc), PIC_TT_SC); + sc->expr = expr; + sc->senv = senv; + return sc; +} + +static bool +sc_identifier_p(pic_value obj) +{ + if (pic_sym_p(obj)) { + return true; + } + if (pic_sc_p(obj)) { + return sc_identifier_p(pic_sc_ptr(obj)->expr); + } + return false; +} + +static bool +sc_identifier_eq_p(pic_state *pic, struct pic_senv *e1, pic_value x, struct pic_senv *e2, pic_value y) +{ + pic_value box; + + if (! (sc_identifier_p(x) && sc_identifier_p(y))) { + return false; + } + + box = pic_box(pic, pic_nil_value()); + + x = macroexpand(pic, x, e1, box); + y = macroexpand(pic, y, e2, box); + + return pic_eq_p(x, y); +} + static pic_value pic_macro_make_sc(pic_state *pic) { @@ -750,7 +750,7 @@ pic_macro_identifier_p(pic_state *pic) pic_get_args(pic, "o", &obj); - return pic_bool_value(identifier_p(obj)); + return pic_bool_value(sc_identifier_p(obj)); } static pic_value @@ -770,7 +770,7 @@ pic_macro_identifier_eq_p(pic_state *pic) } e2 = pic_senv_ptr(f); - return pic_bool_value(identifier_eq_p(pic, e1, x, e2, y)); + return pic_bool_value(sc_identifier_eq_p(pic, e1, x, e2, y)); } static pic_value From eb990b4399009b4e8b97c1af59070cc3e618df93 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 5 Apr 2014 01:30:51 +0900 Subject: [PATCH 16/18] cleanup --- src/macro.c | 94 ++++++++++++++++++++++++++--------------------------- 1 file changed, 47 insertions(+), 47 deletions(-) diff --git a/src/macro.c b/src/macro.c index f8c7b66a..45fb1ffa 100644 --- a/src/macro.c +++ b/src/macro.c @@ -11,40 +11,6 @@ #include "picrin/error.h" #include "picrin/box.h" -pic_sym -pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym) -{ - pic_sym rename; - - rename = pic_gensym(pic, sym); - pic_put_rename(pic, senv, sym, rename); - return rename; -} - -void -pic_put_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rename) -{ - UNUSED(pic); - - xh_put(&senv->renames, sym, &rename); -} - -bool -pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *rename) -{ - xh_entry *e; - - UNUSED(pic); - - if ((e = xh_get(&senv->renames, sym)) == NULL) { - return false; - } - if (rename != NULL) { - *rename = xh_val(e, pic_sym); - } - return true; -} - struct pic_senv * pic_null_syntactic_env(pic_state *pic) { @@ -120,27 +86,38 @@ push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value ass return senv; } -static void -define_macro(pic_state *pic, pic_sym rename, struct pic_proc *proc, struct pic_senv *senv) +pic_sym +pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym) { - struct pic_macro *mac; + pic_sym rename; - mac = (struct pic_macro *)pic_obj_alloc(pic, sizeof(struct pic_macro), PIC_TT_MACRO); - mac->senv = senv; - mac->proc = proc; - - xh_put(&pic->macros, rename, &mac); + rename = pic_gensym(pic, sym); + pic_put_rename(pic, senv, sym, rename); + return rename; } -static struct pic_macro * -find_macro(pic_state *pic, pic_sym rename) +void +pic_put_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rename) +{ + UNUSED(pic); + + xh_put(&senv->renames, sym, &rename); +} + +bool +pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *rename) { xh_entry *e; - if ((e = xh_get(&pic->macros, rename)) == NULL) { - return NULL; + UNUSED(pic); + + if ((e = xh_get(&senv->renames, sym)) == NULL) { + return false; } - return xh_val(e, struct pic_macro *); + if (rename != NULL) { + *rename = xh_val(e, pic_sym); + } + return true; } void @@ -180,6 +157,29 @@ pic_export(pic_state *pic, pic_sym sym) xh_put(&pic->lib->exports, sym, &rename); } +static void +define_macro(pic_state *pic, pic_sym rename, struct pic_proc *proc, struct pic_senv *senv) +{ + struct pic_macro *mac; + + mac = (struct pic_macro *)pic_obj_alloc(pic, sizeof(struct pic_macro), PIC_TT_MACRO); + mac->senv = senv; + mac->proc = proc; + + xh_put(&pic->macros, rename, &mac); +} + +static struct pic_macro * +find_macro(pic_state *pic, pic_sym rename) +{ + xh_entry *e; + + if ((e = xh_get(&pic->macros, rename)) == NULL) { + return NULL; + } + return xh_val(e, struct pic_macro *); +} + void pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro) { From 7386460253233c832088a375caa60db72c2f769e Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 5 Apr 2014 02:21:07 +0900 Subject: [PATCH 17/18] s/pic_symbol_value/pic_sym_value/g --- src/macro.c | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/macro.c b/src/macro.c index 45fb1ffa..508c2904 100644 --- a/src/macro.c +++ b/src/macro.c @@ -385,7 +385,7 @@ macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv) var = pic_car(pic, pic_cdr(pic, expr)); if (pic_pair_p(var)) { /* FIXME: unhygienic */ - val = pic_cons(pic, pic_symbol_value(pic->sLAMBDA), + val = pic_cons(pic, pic_sym_value(pic->sLAMBDA), pic_cons(pic, pic_cdr(pic, var), pic_cdr(pic, pic_cdr(pic, expr)))); var = pic_car(pic, var); @@ -465,7 +465,7 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_va pic_add_rename(pic, senv, sym); } - return pic_cons(pic, pic_symbol_value(pic->sDEFINE), macroexpand_list(pic, pic_cdr(pic, expr), senv, assoc_box)); + return pic_cons(pic, pic_sym_value(pic->sDEFINE), macroexpand_list(pic, pic_cdr(pic, expr), senv, assoc_box)); } static pic_value @@ -532,7 +532,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu return macroexpand(pic, pic_sc_ptr(expr)->expr, pic_sc_ptr(expr)->senv, assoc_box); } case PIC_TT_SYMBOL: { - return pic_symbol_value(macroexpand_symbol(pic, pic_sym(expr), senv, assoc_box)); + return pic_sym_value(macroexpand_symbol(pic, pic_sym(expr), senv, assoc_box)); } case PIC_TT_PAIR: { pic_value car; @@ -642,7 +642,7 @@ pic_macro_include(pic_state *pic) pic_get_args(pic, "*", &argc, &argv); /* FIXME unhygienic */ - body = pic_list1(pic, pic_symbol_value(pic->sBEGIN)); + body = pic_list1(pic, pic_sym_value(pic->sBEGIN)); for (i = 0; i < argc; ++i) { const char *filename; @@ -673,7 +673,7 @@ pic_macro_gensym(pic_state *pic) pic_get_args(pic, ""); uniq = pic_gensym(pic, pic_intern_cstr(pic, skel)); - return pic_symbol_value(uniq); + return pic_sym_value(uniq); } static pic_value @@ -785,7 +785,7 @@ er_macro_rename(pic_state *pic) mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1)); assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2); - return pic_symbol_value(macroexpand_symbol(pic, sym, mac_env, assoc_box)); + return pic_sym_value(macroexpand_symbol(pic, sym, mac_env, assoc_box)); } static pic_value @@ -870,7 +870,7 @@ ir_macro_inject(pic_state *pic) use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0)); assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2); - return pic_symbol_value(macroexpand_symbol(pic, sym, use_env, assoc_box)); + return pic_sym_value(macroexpand_symbol(pic, sym, use_env, assoc_box)); } static pic_value From b64b2c3074c3ce4f81a695016f9af71e735b1988 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 5 Apr 2014 02:44:30 +0900 Subject: [PATCH 18/18] bugfix --- src/write.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/write.c b/src/write.c index 4c59d8ed..2eb3575e 100644 --- a/src/write.c +++ b/src/write.c @@ -320,7 +320,7 @@ write_core(struct writer_control *p, pic_value obj) break; case PIC_TT_SC: xfprintf(file, "#expr); + write_core(p, pic_sc_ptr(obj)->expr); xfprintf(file, ">"); break; case PIC_TT_LIB: