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

initial explicit renaming macro prototype

This commit is contained in:
Yuichi Nishiwaki 2014-01-09 16:34:22 +09:00
parent 8e4e226bd3
commit 9b02247082
2 changed files with 76 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
include/picrin/macro.h
View File

@ -45,6 +45,7 @@ struct pic_sc {
#define pic_senv(v) ((struct pic_senv *)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_p(v) (pic_type(v) == PIC_TT_SENV)
#define pic_senv_ptr(v) ((struct pic_senv *)pic_ptr(v))
struct pic_senv *pic_null_syntactic_env(pic_state *pic); struct pic_senv *pic_null_syntactic_env(pic_state *pic);
struct pic_senv *pic_minimal_syntactic_env(pic_state *pic); struct pic_senv *pic_minimal_syntactic_env(pic_state *pic);

75
src/macro.c
View File

@ -659,6 +659,80 @@ pic_macro_identifier_eq_p(pic_state *pic)
return pic_bool_value(pic_eq_p(x, y)); return pic_bool_value(pic_eq_p(x, y));
} }
static pic_value
er_macro_rename(pic_state *pic)
{
pic_sym sym;
struct pic_senv *mac_env;
pic_get_args(pic, "m", &sym);
mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1));
return macroexpand(pic, pic_symbol_value(sym), mac_env);
}
static pic_value
er_macro_compare(pic_state *pic)
{
pic_sym x, y;
struct pic_senv *use_env;
pic_value a, b;
pic_get_args(pic, "mm", &x, &y);
use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
a = macroexpand(pic, pic_symbol_value(x), use_env);
b = macroexpand(pic, pic_symbol_value(y), use_env);
return pic_bool_value(pic_eq_p(a, b));
}
static pic_value
er_macro_call(pic_state *pic)
{
pic_value expr, use_env, mac_env;
struct pic_proc *rename, *compare, *cb;
pic_get_args(pic, "ooo", &expr, &use_env, &mac_env);
if (! pic_senv_p(use_env)) {
pic_error(pic, "unexpected type of argument 1");
}
if (! pic_senv_p(mac_env)) {
pic_error(pic, "unexpected type of argument 3");
}
rename = pic_proc_new(pic, er_macro_rename);
pic_proc_cv_reserve(pic, rename, 2);
pic_proc_cv_set(pic, rename, 0, use_env);
pic_proc_cv_set(pic, rename, 1, mac_env);
compare = pic_proc_new(pic, er_macro_compare);
pic_proc_cv_reserve(pic, compare, 2);
pic_proc_cv_set(pic, compare, 0, use_env);
pic_proc_cv_set(pic, compare, 1, mac_env);
cb = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
return pic_apply_argv(pic, cb, 3, expr, pic_obj_value(rename), pic_obj_value(compare));
}
static pic_value
pic_macro_er_macro_transformer(pic_state *pic)
{
struct pic_proc *cb, *proc;
pic_get_args(pic, "l", &cb);
proc = pic_proc_new(pic, er_macro_call);
pic_proc_cv_reserve(pic, proc, 1);
pic_proc_cv_set(pic, proc, 0, pic_obj_value(cb));
return pic_obj_value(proc);
}
void void
pic_init_macro(pic_state *pic) pic_init_macro(pic_state *pic)
{ {
@ -667,6 +741,7 @@ pic_init_macro(pic_state *pic)
pic_defun(pic, "make-syntactic-closure", pic_macro_make_sc); pic_defun(pic, "make-syntactic-closure", pic_macro_make_sc);
pic_defun(pic, "identifier?", pic_macro_identifier_p); pic_defun(pic, "identifier?", pic_macro_identifier_p);
pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p); pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p);
pic_defun(pic, "er-macro-transformer", pic_macro_er_macro_transformer);
} }
ENDLIBRARY(pic); ENDLIBRARY(pic);
} }