replace old macroexpand facility with new renamer implementation
This commit is contained in:
parent
1f3f7c99a2
commit
be311cb96f
|
@ -55,8 +55,6 @@ typedef struct {
|
|||
struct xhash *global_tbl;
|
||||
pic_value *globals;
|
||||
size_t glen, gcapa;
|
||||
struct pic_proc **macros;
|
||||
size_t mlen, mcapa;
|
||||
|
||||
/* positive for variables, negative for macros (bitwise-not) */
|
||||
struct xhash *var_tbl;
|
||||
|
|
2
src/gc.c
2
src/gc.c
|
@ -360,8 +360,6 @@ gc_mark_phase(pic_state *pic)
|
|||
}
|
||||
|
||||
/* macros */
|
||||
for (i = 0; i < pic->mlen; ++i) {
|
||||
gc_mark_object(pic, (struct pic_object *)pic->macros[i]);
|
||||
for (i = 0; i < pic->xlen; ++i) {
|
||||
gc_mark_object(pic, (struct pic_object *)pic->stx[i]);
|
||||
}
|
||||
|
|
242
src/macro.c
242
src/macro.c
|
@ -11,199 +11,19 @@
|
|||
|
||||
#define FALLTHROUGH ((void)0)
|
||||
|
||||
struct syntactic_env {
|
||||
struct syntactic_env *up;
|
||||
|
||||
struct xhash *tbl;
|
||||
};
|
||||
|
||||
static void
|
||||
define_macro(pic_state *pic, const char *name, struct pic_proc *macro)
|
||||
{
|
||||
int idx;
|
||||
|
||||
idx = pic->mlen++;
|
||||
if (idx >= pic->mcapa) {
|
||||
idx = pic->xlen++;
|
||||
if (idx >= pic->xcapa) {
|
||||
pic_abort(pic, "macro table overflow");
|
||||
}
|
||||
pic->macros[idx] = macro;
|
||||
pic->stx[idx] = pic_syntax_new_macro(pic, pic_intern_cstr(pic, name), macro);
|
||||
xh_put(pic->global_tbl, name, ~idx);
|
||||
}
|
||||
|
||||
static struct pic_proc *
|
||||
lookup_macro(pic_state *pic, struct syntactic_env *env, const char *name)
|
||||
{
|
||||
struct xh_entry *e;
|
||||
|
||||
e = xh_get(env->tbl, name);
|
||||
if (! e)
|
||||
return NULL;
|
||||
|
||||
if (e->val >= 0)
|
||||
return NULL;
|
||||
|
||||
return pic->macros[~e->val];
|
||||
}
|
||||
|
||||
pic_value
|
||||
expand(pic_state *pic, pic_value obj, struct syntactic_env *env)
|
||||
{
|
||||
int ai = pic_gc_arena_preserve(pic);
|
||||
|
||||
#if DEBUG
|
||||
printf("current ai = %d\n", ai);
|
||||
|
||||
printf("expanding...");
|
||||
pic_debug(pic, obj);
|
||||
puts("");
|
||||
#endif
|
||||
|
||||
switch (pic_type(obj)) {
|
||||
case PIC_TT_SYMBOL: {
|
||||
return obj;
|
||||
}
|
||||
case PIC_TT_PAIR: {
|
||||
pic_value v;
|
||||
|
||||
if (! pic_list_p(pic, obj))
|
||||
return obj;
|
||||
|
||||
if (pic_symbol_p(pic_car(pic, obj))) {
|
||||
struct pic_proc *macro;
|
||||
pic_sym sym;
|
||||
|
||||
sym = pic_sym(pic_car(pic, obj));
|
||||
if (sym == pic->sDEFINE_MACRO) {
|
||||
pic_value var, val;
|
||||
struct pic_proc *proc;
|
||||
|
||||
if (pic_length(pic, obj) < 2) {
|
||||
pic_error(pic, "syntax error");
|
||||
}
|
||||
|
||||
var = pic_car(pic, pic_cdr(pic, obj));
|
||||
if (pic_pair_p(var)) {
|
||||
val = pic_cons(pic, pic_symbol_value(pic->sLAMBDA),
|
||||
pic_cons(pic, pic_cdr(pic, var),
|
||||
pic_cdr(pic, pic_cdr(pic, obj))));
|
||||
var = pic_car(pic, var);
|
||||
}
|
||||
else {
|
||||
if (pic_length(pic, obj) != 3) {
|
||||
pic_error(pic, "syntax_error");
|
||||
}
|
||||
val = pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj)));
|
||||
}
|
||||
if (! pic_symbol_p(var)) {
|
||||
pic_error(pic, "syntax error");
|
||||
}
|
||||
|
||||
proc = pic_codegen(pic, val);
|
||||
if (pic->errmsg) {
|
||||
printf("macroexpand error: %s\n", pic->errmsg);
|
||||
abort();
|
||||
}
|
||||
v = pic_apply(pic, proc, pic_nil_value());
|
||||
if (pic->errmsg) {
|
||||
printf("macroexpand error: %s\n", pic->errmsg);
|
||||
abort();
|
||||
}
|
||||
assert(pic_proc_p(v));
|
||||
define_macro(pic, pic_symbol_name(pic, pic_sym(var)), pic_proc_ptr(v));
|
||||
|
||||
pic_gc_arena_restore(pic, ai);
|
||||
return pic_false_value();
|
||||
}
|
||||
macro = lookup_macro(pic, env, pic_symbol_name(pic, sym));
|
||||
if (macro) {
|
||||
v = pic_apply(pic, macro, pic_cdr(pic, obj));
|
||||
if (pic->errmsg) {
|
||||
printf("macroexpand error: %s\n", pic->errmsg);
|
||||
abort();
|
||||
}
|
||||
pic_gc_arena_restore(pic, ai);
|
||||
pic_gc_protect(pic, v);
|
||||
|
||||
v = expand(pic, v, env);
|
||||
pic_gc_arena_restore(pic, ai);
|
||||
pic_gc_protect(pic, v);
|
||||
return v;
|
||||
}
|
||||
}
|
||||
|
||||
v = pic_nil_value();
|
||||
while (! pic_nil_p(obj)) {
|
||||
v = pic_cons(pic, expand(pic, pic_car(pic, obj), env), v);
|
||||
obj = pic_cdr(pic, obj);
|
||||
|
||||
pic_gc_arena_restore(pic, ai);
|
||||
pic_gc_protect(pic, v);
|
||||
}
|
||||
v = pic_reverse(pic, v);
|
||||
|
||||
pic_gc_arena_restore(pic, ai);
|
||||
pic_gc_protect(pic, v);
|
||||
return v;
|
||||
}
|
||||
case PIC_TT_NIL:
|
||||
case PIC_TT_BOOL:
|
||||
case PIC_TT_FLOAT:
|
||||
case PIC_TT_INT:
|
||||
case PIC_TT_CHAR:
|
||||
case PIC_TT_EOF:
|
||||
case PIC_TT_STRING:
|
||||
case PIC_TT_VECTOR:
|
||||
case PIC_TT_BLOB: {
|
||||
return obj;
|
||||
}
|
||||
case PIC_TT_PROC:
|
||||
case PIC_TT_PORT:
|
||||
case PIC_TT_ERROR:
|
||||
case PIC_TT_ENV:
|
||||
case PIC_TT_CONT:
|
||||
case PIC_TT_UNDEF:
|
||||
case PIC_TT_SENV:
|
||||
case PIC_TT_SYNTAX:
|
||||
pic_error(pic, "unexpected value type");
|
||||
return pic_undef_value(); /* unreachable */
|
||||
}
|
||||
/* logic flaw (suppress warnings gcc will emit) */
|
||||
abort();
|
||||
}
|
||||
|
||||
pic_value pic_macroexpand_2(pic_state *, pic_value);
|
||||
|
||||
pic_value
|
||||
pic_macroexpand(pic_state *pic, pic_value obj)
|
||||
{
|
||||
struct syntactic_env env;
|
||||
pic_value v;
|
||||
|
||||
env.tbl = pic->global_tbl;
|
||||
|
||||
#if DEBUG
|
||||
puts("before expand:");
|
||||
pic_debug(pic, obj);
|
||||
puts("");
|
||||
#endif
|
||||
|
||||
v = expand(pic, obj, &env);
|
||||
|
||||
#if DEBUG
|
||||
puts("after expand:");
|
||||
pic_debug(pic, v);
|
||||
puts("");
|
||||
#endif
|
||||
|
||||
v = pic_macroexpand_2(pic, v);
|
||||
#if DEBUG
|
||||
puts("after expand:");
|
||||
pic_debug(pic, v);
|
||||
puts("");
|
||||
#endif
|
||||
return v;
|
||||
}
|
||||
|
||||
static pic_sym
|
||||
new_uniq_sym(pic_state *pic, pic_sym base)
|
||||
{
|
||||
|
@ -249,6 +69,58 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
|||
car = macroexpand(pic, pic_car(pic, expr), senv);
|
||||
if (pic_syntax_p(car)) {
|
||||
switch (pic_syntax(car)->kind) {
|
||||
case PIC_STX_DEFMACRO: {
|
||||
pic_value var, val;
|
||||
struct pic_proc *proc;
|
||||
|
||||
if (pic_length(pic, expr) < 2) {
|
||||
pic_error(pic, "syntax error");
|
||||
}
|
||||
|
||||
var = pic_car(pic, pic_cdr(pic, expr));
|
||||
if (pic_pair_p(var)) {
|
||||
val = pic_cons(pic, pic_symbol_value(pic->sLAMBDA),
|
||||
pic_cons(pic, pic_cdr(pic, var),
|
||||
pic_cdr(pic, pic_cdr(pic, expr))));
|
||||
var = pic_car(pic, var);
|
||||
}
|
||||
else {
|
||||
if (pic_length(pic, expr) != 3) {
|
||||
pic_error(pic, "syntax_error");
|
||||
}
|
||||
val = pic_car(pic, pic_cdr(pic, pic_cdr(pic, expr)));
|
||||
}
|
||||
if (! pic_symbol_p(var)) {
|
||||
pic_error(pic, "syntax error");
|
||||
}
|
||||
|
||||
proc = pic_codegen(pic, val);
|
||||
if (pic->errmsg) {
|
||||
printf("macroexpand error: %s\n", pic->errmsg);
|
||||
abort();
|
||||
}
|
||||
v = pic_apply(pic, proc, pic_nil_value());
|
||||
if (pic->errmsg) {
|
||||
printf("macroexpand error: %s\n", pic->errmsg);
|
||||
abort();
|
||||
}
|
||||
assert(pic_proc_p(v));
|
||||
define_macro(pic, pic_symbol_name(pic, pic_sym(var)), pic_proc_ptr(v));
|
||||
|
||||
pic_gc_arena_restore(pic, ai);
|
||||
return pic_false_value();
|
||||
}
|
||||
case PIC_STX_MACRO: {
|
||||
v = pic_apply(pic, pic_syntax(car)->macro, pic_cdr(pic, expr));
|
||||
if (pic->errmsg) {
|
||||
printf("macroexpand error: %s\n", pic->errmsg);
|
||||
abort();
|
||||
}
|
||||
pic_gc_arena_restore(pic, ai);
|
||||
pic_gc_protect(pic, v);
|
||||
|
||||
return macroexpand(pic, v, senv);
|
||||
}
|
||||
case PIC_STX_LAMBDA: {
|
||||
struct pic_senv *in;
|
||||
pic_value a;
|
||||
|
@ -284,7 +156,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
|||
pic_error(pic, "syntax error");
|
||||
}
|
||||
|
||||
var = pic_car(pic, pic_cdr(pic, expr));
|
||||
var = pic_cadr(pic, expr);
|
||||
if (pic_pair_p(var)) {
|
||||
pic_value a;
|
||||
|
||||
|
@ -402,7 +274,7 @@ pic_syntax_new_macro(pic_state *pic, pic_sym sym, struct pic_proc *macro)
|
|||
}
|
||||
|
||||
pic_value
|
||||
pic_macroexpand_2(pic_state *pic, pic_value expr)
|
||||
pic_macroexpand(pic_state *pic, pic_value expr)
|
||||
{
|
||||
struct pic_senv *senv;
|
||||
pic_value v;
|
||||
|
|
|
@ -64,9 +64,6 @@ pic_open(int argc, char *argv[], char **envp)
|
|||
pic->globals = (pic_value *)calloc(PIC_GLOBALS_SIZE, sizeof(pic_value));
|
||||
pic->glen = 0;
|
||||
pic->gcapa = PIC_GLOBALS_SIZE;
|
||||
pic->macros = (struct pic_proc **)calloc(PIC_MACROS_SIZE, sizeof(struct pic_proc *));
|
||||
pic->mlen = 0;
|
||||
pic->mcapa = PIC_MACROS_SIZE;
|
||||
|
||||
/* identifier table */
|
||||
pic->var_tbl = xh_new();
|
||||
|
|
Loading…
Reference in New Issue