From 3a59a959609ba702b0f550b0b07365deae0719b4 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Jun 2015 02:16:38 +0900 Subject: [PATCH] [WIP] replace macro expander remove define-syntax, add define-macro instead saner display when writing identifiers --- extlib/benz/gc.c | 21 +- extlib/benz/include/picrin.h | 7 +- extlib/benz/include/picrin/macro.h | 25 ++- extlib/benz/include/picrin/value.h | 3 + extlib/benz/lib.c | 8 +- extlib/benz/macro.c | 331 +++++++++++++++++------------ extlib/benz/state.c | 11 +- extlib/benz/symbol.c | 21 +- extlib/benz/vm.c | 30 +-- extlib/benz/write.c | 3 + 10 files changed, 266 insertions(+), 194 deletions(-) diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index 1ada79bc..11ee202e 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -411,14 +411,24 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) case PIC_TT_BLOB: { break; } + case PIC_TT_ID: { + struct pic_id *id = (struct pic_id *)obj; + gc_mark(pic, id->var); + gc_mark_object(pic, (struct pic_object *)id->env); + break; + } case PIC_TT_ENV: { struct pic_env *env = (struct pic_env *)obj; + xh_entry *it; if (env->up) { gc_mark_object(pic, (struct pic_object *)env->up); } gc_mark(pic, env->defer); - gc_mark_object(pic, (struct pic_object *)env->map); + for (it = xh_begin(&env->map); it != NULL; it = xh_next(it)) { + gc_mark_object(pic, xh_key(it, struct pic_object *)); + gc_mark_object(pic, xh_val(it, struct pic_object *)); + } break; } case PIC_TT_LIB: { @@ -519,7 +529,7 @@ gc_mark_global_symbols(pic_state *pic) { M(sDEFINE); M(sLAMBDA); M(sIF); M(sBEGIN); M(sQUOTE); M(sSETBANG); M(sQUASIQUOTE); M(sUNQUOTE); M(sUNQUOTE_SPLICING); - M(sDEFINE_SYNTAX); M(sIMPORT); M(sEXPORT); + M(sDEFINE_MACRO); M(sIMPORT); M(sEXPORT); M(sDEFINE_LIBRARY); M(sCOND_EXPAND); M(sAND); M(sOR); M(sELSE); M(sLIBRARY); M(sONLY); M(sRENAME); M(sPREFIX); M(sEXCEPT); @@ -532,7 +542,7 @@ gc_mark_global_symbols(pic_state *pic) M(sGREF); M(sLREF); M(sCREF); M(sRETURN); M(uDEFINE); M(uLAMBDA); M(uIF); M(uBEGIN); M(uQUOTE); M(uSETBANG); - M(uDEFINE_SYNTAX); M(uIMPORT); M(uEXPORT); + M(uDEFINE_MACRO); M(uIMPORT); M(uEXPORT); M(uDEFINE_LIBRARY); M(uCOND_EXPAND); M(uCONS); M(uCAR); M(uCDR); M(uNILP); @@ -681,7 +691,12 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) case PIC_TT_ERROR: { break; } + case PIC_TT_ID: { + break; + } case PIC_TT_ENV: { + struct pic_env *env = (struct pic_env *)obj; + xh_destroy(&env->map); break; } case PIC_TT_LIB: { diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index f23de1b3..c6e9595d 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -98,7 +98,7 @@ typedef struct { pic_sym *sDEFINE, *sLAMBDA, *sIF, *sBEGIN, *sQUOTE, *sSETBANG; pic_sym *sQUASIQUOTE, *sUNQUOTE, *sUNQUOTE_SPLICING; - pic_sym *sDEFINE_SYNTAX, *sIMPORT, *sEXPORT; + pic_sym *sDEFINE_MACRO, *sIMPORT, *sEXPORT; pic_sym *sDEFINE_LIBRARY; pic_sym *sCOND_EXPAND, *sAND, *sOR, *sELSE, *sLIBRARY; pic_sym *sONLY, *sRENAME, *sPREFIX, *sEXCEPT; @@ -112,7 +112,7 @@ typedef struct { pic_sym *sCALL_WITH_VALUES, *sTAILCALL_WITH_VALUES; pic_sym *uDEFINE, *uLAMBDA, *uIF, *uBEGIN, *uQUOTE, *uSETBANG; - pic_sym *uDEFINE_SYNTAX, *uIMPORT, *uEXPORT; + pic_sym *uDEFINE_MACRO, *uIMPORT, *uEXPORT; pic_sym *uDEFINE_LIBRARY; pic_sym *uCOND_EXPAND; pic_sym *uCONS, *uCAR, *uCDR, *uNILP; @@ -127,6 +127,7 @@ typedef struct { pic_value features; xhash syms; /* name to symbol */ + int ucnt; struct pic_dict *globals; struct pic_dict *macros; pic_value libs; @@ -193,8 +194,6 @@ bool pic_equal_p(pic_state *, pic_value, pic_value); pic_sym *pic_intern(pic_state *, pic_str *); pic_sym *pic_intern_cstr(pic_state *, const char *); const char *pic_symbol_name(pic_state *, pic_sym *); -pic_sym *pic_gensym(pic_state *, pic_sym *); -bool pic_interned_p(pic_state *, pic_sym *); pic_value pic_read(pic_state *, struct pic_port *); pic_value pic_read_cstr(pic_state *, const char *); diff --git a/extlib/benz/include/picrin/macro.h b/extlib/benz/include/picrin/macro.h index 7d150777..28ce8208 100644 --- a/extlib/benz/include/picrin/macro.h +++ b/extlib/benz/include/picrin/macro.h @@ -9,24 +9,35 @@ extern "C" { #endif +struct pic_id { + PIC_OBJECT_HEADER + pic_value var; + struct pic_env *env; +}; + struct pic_env { PIC_OBJECT_HEADER - struct pic_dict *map; + xhash map; pic_value defer; struct pic_env *up; }; +#define pic_id_p(v) (pic_type(v) == PIC_TT_ID) +#define pic_id_ptr(v) ((struct pic_id *)pic_ptr(v)) + #define pic_env_p(v) (pic_type(v) == PIC_TT_ENV) #define pic_env_ptr(v) ((struct pic_env *)pic_ptr(v)) -bool pic_identifier_p(pic_state *pic, pic_value obj); -bool pic_identifier_eq_p(pic_state *, struct pic_env *, pic_sym *, struct pic_env *, pic_sym *); - +struct pic_id *pic_make_id(pic_state *, pic_value, struct pic_env *); struct pic_env *pic_make_env(pic_state *, struct pic_env *); -pic_sym *pic_add_rename(pic_state *, struct pic_env *, pic_sym *); -pic_sym *pic_find_rename(pic_state *, struct pic_env *, pic_sym *); -void pic_put_rename(pic_state *, struct pic_env *, pic_sym *, pic_sym *); +pic_sym *pic_uniq(pic_state *, pic_value); + +pic_sym *pic_add_variable(pic_state *, struct pic_env *, pic_value); +void pic_put_variable(pic_state *, struct pic_env *, pic_value, pic_sym *); +pic_sym *pic_find_variable(pic_state *, struct pic_env *, pic_value); + +pic_sym *pic_var_name(pic_state *, pic_value); #if defined(__cplusplus) } diff --git a/extlib/benz/include/picrin/value.h b/extlib/benz/include/picrin/value.h index d69eaf59..7868429c 100644 --- a/extlib/benz/include/picrin/value.h +++ b/extlib/benz/include/picrin/value.h @@ -157,6 +157,7 @@ enum pic_tt { PIC_TT_PROC, PIC_TT_PORT, PIC_TT_ERROR, + PIC_TT_ID, PIC_TT_CXT, PIC_TT_ENV, PIC_TT_LIB, @@ -314,6 +315,8 @@ pic_type_repr(enum pic_tt tt) return "port"; case PIC_TT_ERROR: return "error"; + case PIC_TT_ID: + return "id"; case PIC_TT_CXT: return "cxt"; case PIC_TT_PROC: diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index 985f414c..545052c7 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -110,14 +110,14 @@ import_table(pic_state *pic, pic_value spec, struct pic_dict *imports) pic_errorf(pic, "library not found: ~a", spec); } pic_dict_for_each (nick, lib->exports, iter) { - pic_sym *realname, *rename; + pic_sym *realname, *uid; realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, nick)); - if ((rename = pic_find_rename(pic, lib->env, realname)) == NULL) { + if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(realname))) == NULL) { pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname)); } - pic_dict_set(pic, imports, nick, pic_obj_value(rename)); + pic_dict_set(pic, imports, nick, pic_obj_value(uid)); } } @@ -133,7 +133,7 @@ import(pic_state *pic, pic_value spec) import_table(pic, spec, imports); pic_dict_for_each (sym, imports, it) { - pic_put_rename(pic, pic->lib->env, sym, pic_sym_ptr(pic_dict_ref(pic, imports, sym))); + pic_put_variable(pic, pic->lib->env, pic_obj_value(sym), pic_sym_ptr(pic_dict_ref(pic, imports, sym))); } } diff --git a/extlib/benz/macro.c b/extlib/benz/macro.c index 6560f06c..a4b9d98a 100644 --- a/extlib/benz/macro.c +++ b/extlib/benz/macro.c @@ -4,74 +4,155 @@ #include "picrin.h" -pic_sym * -pic_add_rename(pic_state *pic, struct pic_env *env, pic_sym *sym) +static bool +pic_var_p(pic_value obj) { - pic_sym *rename = pic_gensym(pic, sym); - - pic_put_rename(pic, env, sym, rename); - - return rename; + return pic_sym_p(obj) || pic_id_p(obj); } -void -pic_put_rename(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *rename) +struct pic_id * +pic_make_id(pic_state *pic, pic_value var, struct pic_env *env) { - pic_dict_set(pic, env->map, sym, pic_obj_value(rename)); + struct pic_id *id; + + assert(pic_var_p(var)); + + id = (struct pic_id *)pic_obj_alloc(pic, sizeof(struct pic_id), PIC_TT_ID); + id->var = var; + id->env = env; + return id; +} + +struct pic_env * +pic_make_env(pic_state *pic, struct pic_env *up) +{ + struct pic_env *env; + + env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV); + env->up = up; + env->defer = pic_nil_value(); + xh_init_ptr(&env->map, sizeof(pic_sym *)); + return env; } pic_sym * -pic_find_rename(pic_state *pic, struct pic_env *env, pic_sym *sym) +pic_var_name(pic_state PIC_UNUSED(*pic), pic_value var) { - if (! pic_dict_has(pic, env->map, sym)) { - return NULL; + assert(pic_var_p(var)); + + while (pic_id_p(var)) { + var = pic_id_ptr(var)->var; } - return pic_sym_ptr(pic_dict_ref(pic, env->map, sym)); + return pic_sym_ptr(var); } -static void -define_macro(pic_state *pic, pic_sym *rename, struct pic_proc *mac) +pic_sym * +pic_uniq(pic_state *pic, pic_value var) { - pic_dict_set(pic, pic->macros, rename, pic_obj_value(mac)); -} + pic_str *str; -static struct pic_proc * -find_macro(pic_state *pic, pic_sym *rename) -{ - if (! pic_dict_has(pic, pic->macros, rename)) { - return NULL; - } - return pic_proc_ptr(pic_dict_ref(pic, pic->macros, rename)); + assert(pic_var_p(var)); + + str = pic_format(pic, "%s.%d", pic_symbol_name(pic, pic_var_name(pic, var)), pic->ucnt++); + + return pic_intern(pic, str); } static pic_sym * -make_identifier(pic_state *pic, pic_sym *sym, struct pic_env *env) +lookup(pic_state PIC_UNUSED(*pic), pic_value var, struct pic_env *env) { - pic_sym *rename; + xh_entry *e; - while (true) { - if ((rename = pic_find_rename(pic, env, sym)) != NULL) { - return rename; + assert(pic_var_p(var)); + + while (env != NULL) { + if ((e = xh_get_ptr(&env->map, pic_ptr(var))) != NULL) { + return xh_val(e, pic_sym *); } - if (! env->up) - break; env = env->up; } - if (! pic_interned_p(pic, sym)) { - return sym; + return NULL; +} + +static pic_sym * +resolve(pic_state *pic, pic_value var, struct pic_env *env) +{ + pic_sym *uid; + + assert(pic_var_p(var)); + + while ((uid = lookup(pic, var, env)) == NULL) { + if (pic_sym_p(var)) { + return NULL; + } + env = pic_id_ptr(var)->env; + var = pic_id_ptr(var)->var; } - else { - return pic_gensym(pic, sym); + return uid; +} + +pic_sym * +pic_add_variable(pic_state *pic, struct pic_env *env, pic_value var) +{ + pic_sym *uid; + + assert(pic_var_p(var)); + + uid = pic_uniq(pic, var); + + pic_put_variable(pic, env, var, uid); + + return uid; +} + +void +pic_put_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var, pic_sym *uid) +{ + assert(pic_var_p(var)); + + xh_put_ptr(&env->map, pic_ptr(var), &uid); +} + +pic_sym * +pic_find_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var) +{ + xh_entry *e; + + assert(pic_var_p(var)); + + if ((e = xh_get_ptr(&env->map, pic_ptr(var))) == NULL) { + return NULL; } + return xh_val(e, pic_sym *); +} + +static void +define_macro(pic_state *pic, pic_sym *uid, struct pic_proc *mac) +{ + pic_dict_set(pic, pic->macros, uid, pic_obj_value(mac)); +} + +static struct pic_proc * +find_macro(pic_state *pic, pic_sym *uid) +{ + if (! pic_dict_has(pic, pic->macros, uid)) { + return NULL; + } + return pic_proc_ptr(pic_dict_ref(pic, pic->macros, uid)); } static pic_value macroexpand(pic_state *, pic_value, struct pic_env *); static pic_value macroexpand_lambda(pic_state *, pic_value, struct pic_env *); static pic_value -macroexpand_symbol(pic_state *pic, pic_sym *sym, struct pic_env *env) +macroexpand_var(pic_state *pic, pic_value var, struct pic_env *env) { - return pic_obj_value(make_identifier(pic, sym, env)); + pic_sym *uid; + + if ((uid = resolve(pic, var, env)) == NULL) { + pic_errorf(pic, "unbound variable found: ~s", var); + } + return pic_obj_value(uid); } static pic_value @@ -142,15 +223,15 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_env *env) in = pic_make_env(pic, env); for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) { - pic_value v = pic_car(pic, a); + pic_value var = pic_car(pic, a); - if (! pic_sym_p(v)) { + if (! pic_var_p(var)) { pic_errorf(pic, "syntax error"); } - pic_add_rename(pic, in, pic_sym_ptr(v)); + pic_add_variable(pic, in, var); } - if (pic_sym_p(a)) { - pic_add_rename(pic, in, pic_sym_ptr(a)); + if (pic_var_p(a)) { + pic_add_variable(pic, in, a); } else if (! pic_nil_p(a)) { pic_errorf(pic, "syntax error"); @@ -167,14 +248,14 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_env *env) static pic_value macroexpand_define(pic_state *pic, pic_value expr, struct pic_env *env) { - pic_sym *sym, *rename; + pic_sym *uid; pic_value var, val; while (pic_length(pic, expr) >= 2 && pic_pair_p(pic_cadr(pic, expr))) { var = pic_car(pic, pic_cadr(pic, expr)); val = pic_cdr(pic, pic_cadr(pic, expr)); - expr = pic_list3(pic, pic_obj_value(pic->uDEFINE), var, pic_cons(pic, pic_obj_value(pic->uLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr)))); + expr = pic_list3(pic, pic_obj_value(pic->uDEFINE), var, pic_cons(pic, pic_obj_value(pic->sLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr)))); } if (pic_length(pic, expr) != 3) { @@ -182,37 +263,35 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_env *env) } var = pic_cadr(pic, expr); - if (! pic_sym_p(var)) { - pic_errorf(pic, "binding to non-symbol object"); + if (! pic_var_p(var)) { + pic_errorf(pic, "binding to non-variable object"); } - sym = pic_sym_ptr(var); - if ((rename = pic_find_rename(pic, env, sym)) == NULL) { - rename = pic_add_rename(pic, env, sym); + if ((uid = pic_find_variable(pic, env, var)) == NULL) { + uid = pic_add_variable(pic, env, var); } val = macroexpand(pic, pic_list_ref(pic, expr, 2), env); - return pic_list3(pic, pic_obj_value(pic->uDEFINE), pic_obj_value(rename), val); + return pic_list3(pic, pic_obj_value(pic->uDEFINE), pic_obj_value(uid), val); } static pic_value -macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_env *env) +macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) { pic_value var, val; - pic_sym *sym, *rename; + pic_sym *uid; if (pic_length(pic, expr) != 3) { pic_errorf(pic, "syntax error"); } var = pic_cadr(pic, expr); - if (! pic_sym_p(var)) { - pic_errorf(pic, "binding to non-symbol object"); + if (! pic_var_p(var)) { + pic_errorf(pic, "binding to non-variable object"); } - sym = pic_sym_ptr(var); - if ((rename = pic_find_rename(pic, env, sym)) == NULL) { - rename = pic_add_rename(pic, env, sym); + if ((uid = pic_find_variable(pic, env, var)) == NULL) { + uid = pic_add_variable(pic, env, var); } else { - pic_warnf(pic, "redefining syntax variable: ~s", pic_obj_value(sym)); + pic_warnf(pic, "redefining syntax variable: ~s", var); } val = pic_cadr(pic, pic_cdr(pic, expr)); @@ -227,13 +306,7 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_env *env) pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); } - val = pic_apply1(pic, pic_proc_ptr(val), pic_obj_value(env)); - - if (! pic_proc_p(val)) { - pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); - } - - define_macro(pic, rename, pic_proc_ptr(val)); + define_macro(pic, uid, pic_proc_ptr(val)); return pic_undef_value(); } @@ -241,7 +314,7 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_env *env) static pic_value macroexpand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct pic_env *env) { - pic_value v, args; + pic_value v; #if DEBUG puts("before expand-1:"); @@ -249,10 +322,8 @@ macroexpand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct p puts(""); #endif - args = pic_list2(pic, expr, pic_obj_value(env)); - pic_try { - v = pic_apply(pic, mac, args); + v = pic_apply2(pic, mac, expr, pic_obj_value(env)); } pic_catch { pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic)); } @@ -270,40 +341,44 @@ static pic_value macroexpand_node(pic_state *pic, pic_value expr, struct pic_env *env) { switch (pic_type(expr)) { + case PIC_TT_ID: case PIC_TT_SYMBOL: { - return macroexpand_symbol(pic, pic_sym_ptr(expr), env); + return macroexpand_var(pic, expr, env); } case PIC_TT_PAIR: { - pic_value car; struct pic_proc *mac; if (! pic_list_p(expr)) { pic_errorf(pic, "cannot macroexpand improper list: ~s", expr); } - car = macroexpand(pic, pic_car(pic, expr), env); - if (pic_sym_p(car)) { - pic_sym *tag = pic_sym_ptr(car); + if (pic_var_p(pic_car(pic, expr))) { + pic_sym *functor; - if (tag == pic->uDEFINE_SYNTAX) { - return macroexpand_defsyntax(pic, expr, env); + if ((functor = resolve(pic, pic_car(pic, expr), env)) == NULL) { + goto call; } - else if (tag == pic->uLAMBDA) { + + if (functor == pic->uDEFINE_MACRO) { + return macroexpand_defmacro(pic, expr, env); + } + else if (functor == pic->uLAMBDA) { return macroexpand_defer(pic, expr, env); } - else if (tag == pic->uDEFINE) { + else if (functor == pic->uDEFINE) { return macroexpand_define(pic, expr, env); } - else if (tag == pic->uQUOTE) { + else if (functor == pic->uQUOTE) { return macroexpand_quote(pic, expr); } - if ((mac = find_macro(pic, tag)) != NULL) { + if ((mac = find_macro(pic, functor)) != NULL) { return macroexpand_node(pic, macroexpand_macro(pic, mac, expr, env), env); } } + call: - return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), env)); + return macroexpand_list(pic, expr, env); } default: return expr; @@ -362,22 +437,6 @@ pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib) return v; } -struct pic_env * -pic_make_env(pic_state *pic, struct pic_env *up) -{ - struct pic_env *env; - struct pic_dict *map; - - map = pic_make_dict(pic); - - env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV); - env->up = up; - env->defer = pic_nil_value(); - env->map = map; - - return env; -} - static pic_value defmacro_call(pic_state *pic) { @@ -398,7 +457,7 @@ pic_defmacro(pic_state *pic, pic_sym *name, pic_sym *id, pic_func_t func) trans = pic_make_proc(pic, func, pic_symbol_name(pic, name)); - pic_put_rename(pic, pic->lib->env, name, id); + pic_put_variable(pic, pic->lib->env, pic_obj_value(name), id); proc = pic_make_proc(pic, defmacro_call, "defmacro_call"); pic_attr_set(pic, pic_obj_value(proc), "@@transformer", pic_obj_value(trans)); @@ -410,30 +469,6 @@ pic_defmacro(pic_state *pic, pic_sym *name, pic_sym *id, pic_func_t func) pic_export(pic, name); } -bool -pic_identifier_p(pic_state *pic, pic_value obj) -{ - return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym_ptr(obj)); -} - -bool -pic_identifier_eq_p(pic_state *pic, struct pic_env *env1, pic_sym *sym1, struct pic_env *env2, pic_sym *sym2) -{ - pic_sym *a, *b; - - a = make_identifier(pic, sym1, env1); - if (a != make_identifier(pic, sym1, env1)) { - a = sym1; - } - - b = make_identifier(pic, sym2, env2); - if (b != make_identifier(pic, sym2, env2)) { - b = sym2; - } - - return pic_eq_p(pic_obj_value(a), pic_obj_value(b)); -} - static pic_value pic_macro_identifier_p(pic_state *pic) { @@ -441,40 +476,62 @@ pic_macro_identifier_p(pic_state *pic) pic_get_args(pic, "o", &obj); - return pic_bool_value(pic_identifier_p(pic, obj)); + return pic_bool_value(pic_id_p(obj)); } static pic_value pic_macro_make_identifier(pic_state *pic) { - pic_value obj; - pic_sym *sym; + pic_value var, env; - pic_get_args(pic, "mo", &sym, &obj); + pic_get_args(pic, "oo", &var, &env); - pic_assert_type(pic, obj, env); + pic_assert_type(pic, var, var); + pic_assert_type(pic, env, env); - return pic_obj_value(make_identifier(pic, sym, pic_env_ptr(obj))); + return pic_obj_value(pic_make_id(pic, var, pic_env_ptr(env))); } static pic_value -pic_macro_identifier_eq_p(pic_state *pic) +pic_macro_variable_p(pic_state *pic) { - pic_sym *sym1, *sym2; - pic_value env1, env2; + pic_value obj; - pic_get_args(pic, "omom", &env1, &sym1, &env2, &sym2); + pic_get_args(pic, "o", &obj); - pic_assert_type(pic, env1, env); - pic_assert_type(pic, env2, env); + return pic_bool_value(pic_var_p(obj)); +} - return pic_bool_value(pic_identifier_eq_p(pic, pic_env_ptr(env1), sym1, pic_env_ptr(env2), sym2)); +static pic_value +pic_macro_variable_eq_p(pic_state *pic) +{ + pic_value var1, var2; + pic_sym *uid1, *uid2; + + pic_get_args(pic, "oo", &var1, &var2); + + pic_assert_type(pic, var1, var); + pic_assert_type(pic, var2, var); + + if (pic_eq_p(var1, var2)) { + return pic_true_value(); + } + + uid1 = resolve(pic, var1, NULL); + uid2 = resolve(pic, var2, NULL); + + if (uid1 || uid2) { + return pic_bool_value(uid1 == uid2); + } + return pic_false_value(); } void pic_init_macro(pic_state *pic) { pic_defun(pic, "identifier?", pic_macro_identifier_p); - pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p); pic_defun(pic, "make-identifier", pic_macro_make_identifier); + + pic_defun(pic, "variable?", pic_macro_variable_p); + pic_defun(pic, "variable=?", pic_macro_variable_eq_p); } diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 85c35d5c..c7f965e0 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -109,7 +109,7 @@ pic_init_core(pic_state *pic) pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->uLAMBDA); pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->uIF); pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->uBEGIN); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->uDEFINE_SYNTAX); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_MACRO, pic->uDEFINE_MACRO); pic_init_undef(pic); DONE; pic_init_bool(pic); DONE; @@ -222,6 +222,9 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) /* symbol table */ xh_init_str(&pic->syms, sizeof(pic_sym *)); + /* unique symbol count */ + pic->ucnt = 0; + /* global variables */ pic->globals = NULL; @@ -265,7 +268,7 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) S(sQUASIQUOTE, "quasiquote"); S(sUNQUOTE, "unquote"); S(sUNQUOTE_SPLICING, "unquote-splicing"); - S(sDEFINE_SYNTAX, "define-syntax"); + S(sDEFINE_MACRO, "define-macro"); S(sIMPORT, "import"); S(sEXPORT, "export"); S(sDEFINE_LIBRARY, "define-library"); @@ -308,7 +311,7 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) pic_gc_arena_restore(pic, ai); -#define U(slot,name) pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name)) +#define U(slot,name) pic->slot = pic_uniq(pic, pic_obj_value(pic_intern_cstr(pic, name))) U(uDEFINE, "define"); U(uLAMBDA, "lambda"); @@ -316,7 +319,7 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) U(uBEGIN, "begin"); U(uSETBANG, "set!"); U(uQUOTE, "quote"); - U(uDEFINE_SYNTAX, "define-syntax"); + U(uDEFINE_MACRO, "define-macro"); U(uIMPORT, "import"); U(uEXPORT, "export"); U(uDEFINE_LIBRARY, "define-library"); diff --git a/extlib/benz/symbol.c b/extlib/benz/symbol.c index 9f716ae9..ce70edb0 100644 --- a/extlib/benz/symbol.c +++ b/extlib/benz/symbol.c @@ -4,7 +4,7 @@ #include "picrin.h" -pic_sym * +static pic_sym * pic_make_symbol(pic_state *pic, pic_str *str) { pic_sym *sym; @@ -42,25 +42,6 @@ pic_intern_cstr(pic_state *pic, const char *str) return pic_intern(pic, pic_make_str(pic, str, strlen(str))); } -pic_sym * -pic_gensym(pic_state *pic, pic_sym *base) -{ - return pic_make_symbol(pic, base->str); -} - -bool -pic_interned_p(pic_state *pic, pic_sym *sym) -{ - xh_entry *e; - - e = xh_get_str(&pic->syms, pic_str_cstr(pic, sym->str)); - if (e) { - return sym == xh_val(e, pic_sym *); - } else { - return false; - } -} - const char * pic_symbol_name(pic_state *pic, pic_sym *sym) { diff --git a/extlib/benz/vm.c b/extlib/benz/vm.c index 7a062019..c3e6de16 100644 --- a/extlib/benz/vm.c +++ b/extlib/benz/vm.c @@ -394,9 +394,9 @@ pic_get_args(pic_state *pic, const char *format, ...) } void -pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *rsym) +pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *uid) { - pic_put_rename(pic, env, sym, rsym); + pic_put_variable(pic, env, pic_obj_value(sym), uid); if (pic->lib && pic->lib->env == env) { pic_export(pic, sym); @@ -406,17 +406,17 @@ pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym, void pic_define_noexport(pic_state *pic, const char *name, pic_value val) { - pic_sym *sym, *rename; + pic_sym *sym, *uid; sym = pic_intern_cstr(pic, name); - if ((rename = pic_find_rename(pic, pic->lib->env, sym)) == NULL) { - rename = pic_add_rename(pic, pic->lib->env, sym); + if ((uid = pic_find_variable(pic, pic->lib->env, pic_obj_value(sym))) == NULL) { + uid = pic_add_variable(pic, pic->lib->env, pic_obj_value(sym)); } else { pic_warnf(pic, "redefining global"); } - pic_dict_set(pic, pic->globals, rename, val); + pic_dict_set(pic, pic->globals, uid, val); } void @@ -430,29 +430,29 @@ pic_define(pic_state *pic, const char *name, pic_value val) pic_value pic_ref(pic_state *pic, struct pic_lib *lib, const char *name) { - pic_sym *sym, *rename; + pic_sym *sym, *uid; sym = pic_intern_cstr(pic, name); - if ((rename = pic_find_rename(pic, lib->env, sym)) == NULL) { + if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(sym))) == NULL) { pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); } - return pic_dict_ref(pic, pic->globals, rename); + return pic_dict_ref(pic, pic->globals, uid); } void pic_set(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val) { - pic_sym *sym, *rename; + pic_sym *sym, *uid; sym = pic_intern_cstr(pic, name); - if ((rename = pic_find_rename(pic, lib->env, sym)) == NULL) { + if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(sym))) == NULL) { pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); } - pic_dict_set(pic, pic->globals, rename, val); + pic_dict_set(pic, pic->globals, uid, val); } pic_value @@ -477,7 +477,7 @@ pic_defun(pic_state *pic, const char *name, pic_func_t cfunc) } void -pic_defun_vm(pic_state *pic, const char *name, pic_sym *rename, pic_func_t func) +pic_defun_vm(pic_state *pic, const char *name, pic_sym *uid, pic_func_t func) { struct pic_proc *proc; pic_sym *sym; @@ -486,9 +486,9 @@ pic_defun_vm(pic_state *pic, const char *name, pic_sym *rename, pic_func_t func) sym = pic_intern_cstr(pic, name); - pic_put_rename(pic, pic->lib->env, sym, rename); + pic_put_variable(pic, pic->lib->env, pic_obj_value(sym), uid); - pic_dict_set(pic, pic->globals, rename, pic_obj_value(proc)); + pic_dict_set(pic, pic->globals, uid, pic_obj_value(proc)); pic_export(pic, sym); } diff --git a/extlib/benz/write.c b/extlib/benz/write.c index 4c9d7333..374d54e2 100644 --- a/extlib/benz/write.c +++ b/extlib/benz/write.c @@ -302,6 +302,9 @@ write_core(struct writer_control *p, pic_value obj) } xfprintf(file, ")"); break; + case PIC_TT_ID: + xfprintf(file, "#", pic_symbol_name(pic, pic_var_name(pic, obj))); + break; default: xfprintf(file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj)); break;