separate macroexpand processing into functions

This commit is contained in:
Yuichi Nishiwaki 2014-04-03 22:01:25 +09:00
parent ffd962290f
commit 113ae32e47
1 changed files with 221 additions and 176 deletions

View File

@ -280,42 +280,15 @@ macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value
}
static pic_value
macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box)
macroexpand_deflibrary(pic_state *pic, pic_value expr)
{
#if DEBUG
printf("[macroexpand] expanding... ");
pic_debug(pic, expr);
puts("");
#endif
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);
}
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;
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) {
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 {
@ -338,18 +311,25 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu
}
return pic_none_value();
}
}
else if (tag == pic->sIMPORT) {
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();
}
else if (tag == pic->sEXPORT) {
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");
@ -357,10 +337,13 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu
/* TODO: warn if symbol is shadowed by local variable */
pic_export(pic, pic_sym(spec));
}
return pic_none_value();
}
else if (tag == pic->sDEFINE_SYNTAX) {
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;
@ -384,22 +367,24 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu
val = pic_cadr(pic, pic_cdr(pic, expr));
pic_try {
v = pic_eval(pic, val);
val = pic_eval(pic, val);
} pic_catch {
pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
}
if (! pic_proc_p(v)) {
if (! pic_proc_p(val)) {
pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
}
mac = macro_new(pic, pic_proc_ptr(v), senv);
mac = macro_new(pic, pic_proc_ptr(val), senv);
xh_put(&pic->macros, rename, &mac);
return pic_none_value();
}
}
else if (tag == pic->sDEFINE_MACRO) {
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;
@ -431,31 +416,24 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu
}
pic_try {
v = pic_eval(pic, val);
val = pic_eval(pic, val);
} pic_catch {
pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
}
if (! pic_proc_p(v)) {
if (! pic_proc_p(val)) {
pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
}
mac = macro_new(pic, pic_proc_ptr(v), NULL);
mac = macro_new(pic, pic_proc_ptr(val), NULL);
xh_put(&pic->macros, rename, &mac);
return pic_none_value();
}
}
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)));
}
else if (tag == pic->sDEFINE) {
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;
@ -482,7 +460,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu
}
/* binding value */
return pic_cons(pic, car,
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)));
@ -499,7 +477,74 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu
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 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)
{
#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) {