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;
}
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
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;
}
static pic_sym
static pic_value
macroexpand_symbol(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;
}
return pic_sym_value(translate(pic, sym, senv, assoc_box));
}
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);
}
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: {
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));
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
@ -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));
assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2);
m = macroexpand_symbol(pic, pic_sym(a), use_env, assoc_box);
n = macroexpand_symbol(pic, pic_sym(b), use_env, assoc_box);
m = translate(pic, pic_sym(a), use_env, assoc_box);
n = translate(pic, pic_sym(b), use_env, assoc_box);
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));
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
@ -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));
assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2);
m = macroexpand_symbol(pic, pic_sym(a), mac_env, assoc_box);
n = macroexpand_symbol(pic, pic_sym(b), mac_env, assoc_box);
m = translate(pic, pic_sym(a), mac_env, assoc_box);
n = translate(pic, pic_sym(b), mac_env, assoc_box);
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)) {
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);
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))) {
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)) {
return pic_cons(pic,