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

refactor macro use expander

This commit is contained in:
Yuichi Nishiwaki 2014-04-03 22:16:09 +09:00
parent 113ae32e47
commit 030c7f9034
1 changed files with 58 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

150
src/macro.c
View File

@ -131,7 +131,7 @@ pic_core_syntactic_env(pic_state *pic)
return senv; return senv;
} }
struct pic_macro * static struct pic_macro *
macro_new(pic_state *pic, struct pic_proc *proc, struct pic_senv *mac_env) macro_new(pic_state *pic, struct pic_proc *proc, struct pic_senv *mac_env)
{ {
struct pic_macro *mac; struct pic_macro *mac;
@ -142,6 +142,24 @@ macro_new(pic_state *pic, struct pic_proc *proc, struct pic_senv *mac_env)
return mac; 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 * static struct pic_sc *
sc_new(pic_state *pic, pic_value expr, struct pic_senv *senv) 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 */ /* symbol registration */
sym = pic_intern_cstr(pic, name); sym = pic_intern_cstr(pic, name);
rename = pic_add_rename(pic, pic->lib->senv, sym); rename = pic_add_rename(pic, pic->lib->senv, sym);
xh_put(&pic->macros, rename, &mac); add_macro(pic, rename, mac);
/* auto export! */ /* auto export! */
pic_export(pic, sym); 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_value var, val;
pic_sym sym, rename; pic_sym sym, rename;
struct pic_macro *mac;
if (pic_length(pic, expr) != 3) { if (pic_length(pic, expr) != 3) {
pic_error(pic, "syntax error"); 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); pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
} }
mac = macro_new(pic, pic_proc_ptr(val), senv); add_macro(pic, rename, macro_new(pic, pic_proc_ptr(val), senv));
xh_put(&pic->macros, rename, &mac);
return pic_none_value(); 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_value var, val;
pic_sym sym, rename; pic_sym sym, rename;
struct pic_macro *mac;
if (pic_length(pic, expr) < 2) { if (pic_length(pic, expr) < 2) {
pic_error(pic, "syntax error"); 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); pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
} }
mac = macro_new(pic, pic_proc_ptr(val), NULL); add_macro(pic, rename, macro_new(pic, pic_proc_ptr(val), NULL));
xh_put(&pic->macros, rename, &mac);
return pic_none_value(); return pic_none_value();
} }
@ -492,69 +506,9 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_va
} }
static pic_value static pic_value
macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, pic_value assoc_box)
{ {
#if DEBUG
printf("[macroexpand] expanding... ");
pic_debug(pic, expr);
puts("");
#endif
switch (pic_type(expr)) {
case PIC_TT_SC: {
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;
xh_entry *e;
if (! pic_list_p(expr)) {
pic_errorf(pic, "cannot macroexpand improper list: ~s", expr);
}
car = macroexpand(pic, pic_car(pic, expr), senv, assoc_box);
if (pic_sym_p(car)) {
pic_sym tag = pic_sym(car);
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; pic_value v, args;
struct pic_macro *mac;
#if DEBUG #if DEBUG
puts("before expand-1:"); puts("before expand-1:");
@ -562,7 +516,6 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu
puts(""); puts("");
#endif #endif
mac = xh_val(e, struct pic_macro *);
if (mac->senv == NULL) { /* legacy macro */ if (mac->senv == NULL) { /* legacy macro */
args = pic_cdr(pic, expr); args = pic_cdr(pic, expr);
} }
@ -584,6 +537,63 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu
return macroexpand(pic, v, senv, assoc_box); 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)
{
#if DEBUG
printf("[macroexpand] expanding... ");
pic_debug(pic, expr);
puts("");
#endif
switch (pic_type(expr)) {
case PIC_TT_SC: {
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;
struct pic_macro *mac;
if (! pic_list_p(expr)) {
pic_errorf(pic, "cannot macroexpand improper list: ~s", expr);
}
car = macroexpand(pic, pic_car(pic, expr), senv, assoc_box);
if (pic_sym_p(car)) {
pic_sym tag = pic_sym(car);
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));
}
if ((mac = find_macro(pic, tag)) != NULL) {
return macroexpand_macro(pic, mac, expr, senv, assoc_box);
}
} }
return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv, assoc_box)); return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv, assoc_box));