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

add translate function

This commit is contained in:
Yuichi Nishiwaki 2014-07-13 16:56:39 +09:00
parent d4f64815b4
commit 73c406ed42
1 changed files with 38 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
src/macro.c
View File

@ -156,6 +156,33 @@ push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value ass
return senv; return senv;
} }
static pic_sym
translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value assoc_box)
{
pic_sym rename;
pic_value x;
if (! pic_interned_p(pic, sym)) {
return sym;
}
while (true) {
if (pic_find_rename(pic, senv, sym, &rename)) {
return rename;
}
if (! senv->up)
break;
senv = senv->up;
}
x = pic_assq(pic, pic_sym_value(sym), pic_unbox(pic, assoc_box));
if (pic_test(x)) {
return pic_sym(pic_cdr(pic, x));
} else {
rename = pic_gensym(pic, sym);
pic_set_box(pic, assoc_box, pic_acons(pic, pic_sym_value(sym), pic_sym_value(rename), pic_unbox(pic, assoc_box)));
return rename;
}
}
static pic_value static pic_value
macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, pic_value assoc_box) macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, pic_value assoc_box)
{ {
@ -191,31 +218,10 @@ macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, pic_valu
return list; return list;
} }
static pic_sym static pic_value
macroexpand_symbol(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; return pic_sym_value(translate(pic, sym, senv, assoc_box));
pic_value x;
if (! pic_interned_p(pic, sym)) {
return sym;
}
while (true) {
if (pic_find_rename(pic, senv, sym, &rename)) {
return rename;
}
if (! senv->up)
break;
senv = senv->up;
}
x = pic_assq(pic, pic_sym_value(sym), pic_unbox(pic, assoc_box));
if (pic_test(x)) {
return pic_sym(pic_cdr(pic, x));
} else {
rename = pic_gensym(pic, sym);
pic_set_box(pic, assoc_box, pic_acons(pic, pic_sym_value(sym), pic_sym_value(rename), pic_unbox(pic, assoc_box)));
return rename;
}
} }
static pic_value static pic_value
@ -499,7 +505,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); return macroexpand(pic, pic_sc_ptr(expr)->expr, pic_sc_ptr(expr)->senv, assoc_box);
} }
case PIC_TT_SYMBOL: { case PIC_TT_SYMBOL: {
return pic_sym_value(macroexpand_symbol(pic, pic_sym(expr), senv, assoc_box)); return macroexpand_symbol(pic, pic_sym(expr), senv, assoc_box);
} }
case PIC_TT_PAIR: { case PIC_TT_PAIR: {
pic_value car; pic_value car;
@ -720,7 +726,7 @@ er_macro_rename(pic_state *pic)
mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1)); 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); assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2);
return pic_sym_value(macroexpand_symbol(pic, sym, mac_env, assoc_box)); return pic_sym_value(translate(pic, sym, mac_env, assoc_box));
} }
static pic_value static pic_value
@ -739,8 +745,8 @@ er_macro_compare(pic_state *pic)
use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0)); 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); assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2);
m = macroexpand_symbol(pic, pic_sym(a), use_env, assoc_box); m = translate(pic, pic_sym(a), use_env, assoc_box);
n = macroexpand_symbol(pic, pic_sym(b), use_env, assoc_box); n = translate(pic, pic_sym(b), use_env, assoc_box);
return pic_bool_value(m == n); return pic_bool_value(m == n);
} }
@ -805,7 +811,7 @@ ir_macro_inject(pic_state *pic)
use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0)); 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); assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2);
return pic_sym_value(macroexpand_symbol(pic, sym, use_env, assoc_box)); return pic_sym_value(translate(pic, sym, use_env, assoc_box));
} }
static pic_value static pic_value
@ -824,8 +830,8 @@ ir_macro_compare(pic_state *pic)
mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1)); 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); assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2);
m = macroexpand_symbol(pic, pic_sym(a), mac_env, assoc_box); m = translate(pic, pic_sym(a), mac_env, assoc_box);
n = macroexpand_symbol(pic, pic_sym(b), mac_env, assoc_box); n = translate(pic, pic_sym(b), mac_env, assoc_box);
return pic_bool_value(m == n); return pic_bool_value(m == n);
} }
@ -835,7 +841,7 @@ ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, pic_valu
{ {
if (pic_sym_p(expr)) { if (pic_sym_p(expr)) {
pic_value r; pic_value r;
r = pic_sym_value(macroexpand_symbol(pic, pic_sym(expr), use_env, assoc_box)); r = pic_sym_value(translate(pic, pic_sym(expr), use_env, assoc_box));
*ir = pic_acons(pic, r, expr, *ir); *ir = pic_acons(pic, r, expr, *ir);
return r; return r;
} }
@ -857,7 +863,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))) { if (pic_test(r = pic_assq(pic, expr, *ir))) {
return pic_cdr(pic, r); return pic_cdr(pic, r);
} }
return pic_sym_value(macroexpand_symbol(pic, pic_sym(expr), mac_env, assoc_box)); return pic_sym_value(translate(pic, pic_sym(expr), mac_env, assoc_box));
} }
else if (pic_pair_p(expr)) { else if (pic_pair_p(expr)) {
return pic_cons(pic, return pic_cons(pic,