From 0fd529c968a77d641d6e4d29ee7509d797ebfefb Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 6 Feb 2016 04:07:37 +0900 Subject: [PATCH] change mangling rule for global variables --- extlib/benz/bool.c | 6 +- extlib/benz/codegen.c | 82 ++++++------ extlib/benz/gc.c | 19 +-- extlib/benz/include/picrin.h | 15 +-- extlib/benz/include/picrin/macro.h | 8 +- extlib/benz/lib.c | 33 +++-- extlib/benz/macro.c | 50 +++++--- extlib/benz/state.c | 196 +++++++++-------------------- extlib/benz/vm.c | 2 - 9 files changed, 175 insertions(+), 236 deletions(-) diff --git a/extlib/benz/bool.c b/extlib/benz/bool.c index ad9dbcbe..c6188388 100644 --- a/extlib/benz/bool.c +++ b/extlib/benz/bool.c @@ -40,11 +40,15 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, int depth, khash_t(m) switch (pic_type(x)) { case PIC_TT_ID: { struct pic_id *id1, *id2; + pic_sym *s1, *s2; id1 = pic_id_ptr(x); id2 = pic_id_ptr(y); - return pic_resolve(pic, id1->var, id1->env) == pic_resolve(pic, id2->var, id2->env); + s1 = pic_resolve_variable(pic, id1->env, id1->var); + s2 = pic_resolve_variable(pic, id2->env, id2->var); + + return s1 == s2; } case PIC_TT_STRING: { return pic_str_cmp(pic, pic_str_ptr(x), pic_str_ptr(y)) == 0; diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index ba459909..427066e5 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -44,7 +44,7 @@ expand_var(pic_state *pic, pic_value var, struct pic_env *env, pic_value deferre struct pic_proc *mac; pic_sym *functor; - functor = pic_resolve(pic, var, env); + functor = pic_resolve_variable(pic, env, var); if ((mac = find_macro(pic, functor)) != NULL) { return expand(pic, pic_apply2(pic, mac, var, pic_obj_value(env)), env, deferred); @@ -55,7 +55,7 @@ expand_var(pic_state *pic, pic_value var, struct pic_env *env, pic_value deferre static pic_value expand_quote(pic_state *pic, pic_value expr) { - return pic_cons(pic, pic_obj_value(pic->uQUOTE), pic_cdr(pic, expr)); + return pic_cons(pic, pic_obj_value(pic->sQUOTE), pic_cdr(pic, expr)); } static pic_value @@ -129,7 +129,7 @@ expand_lambda(pic_state *pic, pic_value expr, struct pic_env *env) expand_deferred(pic, deferred, in); - return pic_list3(pic, pic_obj_value(pic->uLAMBDA), formal, body); + return pic_list3(pic, pic_obj_value(pic->sLAMBDA), formal, body); } static pic_value @@ -146,7 +146,7 @@ expand_define(pic_state *pic, pic_value expr, struct pic_env *env, pic_value def } val = expand(pic, pic_list_ref(pic, expr, 2), env, deferred); - return pic_list3(pic, pic_obj_value(pic->uDEFINE), pic_obj_value(uid), val); + return pic_list3(pic, pic_obj_value(pic->sDEFINE), pic_obj_value(uid), val); } static pic_value @@ -188,18 +188,18 @@ expand_node(pic_state *pic, pic_value expr, struct pic_env *env, pic_value defer if (pic_var_p(pic_car(pic, expr))) { pic_sym *functor; - functor = pic_resolve(pic, pic_car(pic, expr), env); + functor = pic_resolve_variable(pic, env, pic_car(pic, expr)); - if (functor == pic->uDEFINE_MACRO) { + if (functor == pic->sDEFINE_MACRO) { return expand_defmacro(pic, expr, env); } - else if (functor == pic->uLAMBDA) { + else if (functor == pic->sLAMBDA) { return expand_defer(pic, expr, deferred); } - else if (functor == pic->uDEFINE) { + else if (functor == pic->sDEFINE) { return expand_define(pic, expr, env, deferred); } - else if (functor == pic->uQUOTE) { + else if (functor == pic->sQUOTE) { return expand_quote(pic, expr); } @@ -268,9 +268,9 @@ optimize_beta(pic_state *pic, pic_value expr) if (pic_sym_p(pic_list_ref(pic, expr, 0))) { pic_sym *sym = pic_sym_ptr(pic_list_ref(pic, expr, 0)); - if (sym == pic->uQUOTE) { + if (sym == pic->sQUOTE) { return expr; - } else if (sym == pic->uLAMBDA) { + } else if (sym == pic->sLAMBDA) { return pic_list3(pic, pic_list_ref(pic, expr, 0), pic_list_ref(pic, expr, 1), optimize_beta(pic, pic_list_ref(pic, expr, 2))); } } @@ -285,7 +285,7 @@ optimize_beta(pic_state *pic, pic_value expr) pic_gc_protect(pic, expr); functor = pic_list_ref(pic, expr, 0); - if (pic_pair_p(functor) && pic_eq_p(pic_car(pic, functor), pic_obj_value(pic->uLAMBDA))) { + if (pic_pair_p(functor) && pic_eq_p(pic_car(pic, functor), pic_obj_value(pic->sLAMBDA))) { formals = pic_list_ref(pic, functor, 1); if (! pic_list_p(formals)) goto exit; /* TODO: support ((lambda args x) 1 2) */ @@ -294,12 +294,12 @@ optimize_beta(pic_state *pic, pic_value expr) goto exit; defs = pic_nil_value(); pic_for_each (val, args, it) { - pic_push(pic, pic_list3(pic, pic_obj_value(pic->uDEFINE), pic_car(pic, formals), val), defs); + pic_push(pic, pic_list3(pic, pic_obj_value(pic->sDEFINE), pic_car(pic, formals), val), defs); formals = pic_cdr(pic, formals); } expr = pic_list_ref(pic, functor, 2); pic_for_each (val, defs, it) { - expr = pic_list3(pic, pic_obj_value(pic->uBEGIN), val, expr); + expr = pic_list3(pic, pic_obj_value(pic->sBEGIN), val, expr); } } exit: @@ -506,7 +506,7 @@ analyze_lambda(pic_state *pic, analyze_scope *up, pic_value form) analyzer_scope_destroy(pic, scope); - return pic_list6(pic, pic_obj_value(pic->uLAMBDA), rest, pic_obj_value(args), pic_obj_value(locals), pic_obj_value(captures), body); + return pic_list6(pic, pic_obj_value(pic->sLAMBDA), rest, pic_obj_value(args), pic_obj_value(locals), pic_obj_value(captures), body); } static pic_value @@ -553,16 +553,16 @@ analyze_node(pic_state *pic, analyze_scope *scope, pic_value obj) if (pic_sym_p(proc)) { pic_sym *sym = pic_sym_ptr(proc); - if (sym == pic->uDEFINE) { + if (sym == pic->sDEFINE) { return analyze_define(pic, scope, obj); } - else if (sym == pic->uLAMBDA) { + else if (sym == pic->sLAMBDA) { return analyze_defer(pic, scope, obj); } - else if (sym == pic->uQUOTE) { + else if (sym == pic->sQUOTE) { return obj; } - else if (sym == pic->uBEGIN || sym == pic->uSETBANG || sym == pic->uIF) { + else if (sym == pic->sBEGIN || sym == pic->sSETBANG || sym == pic->sIF) { return pic_cons(pic, pic_car(pic, obj), analyze_list(pic, scope, pic_cdr(pic, obj))); } } @@ -570,7 +570,7 @@ analyze_node(pic_state *pic, analyze_scope *scope, pic_value obj) return analyze_call(pic, scope, obj); } default: - return pic_list2(pic, pic_obj_value(pic->uQUOTE), obj); + return pic_list2(pic, pic_obj_value(pic->sQUOTE), obj); } } @@ -988,22 +988,22 @@ codegen_call(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos) sym = pic_sym_ptr(pic_list_ref(pic, functor, 1)); - VM(pic->uCONS, OP_CONS) - VM(pic->uCAR, OP_CAR) - VM(pic->uCDR, OP_CDR) - VM(pic->uNILP, OP_NILP) - VM(pic->uSYMBOLP, OP_SYMBOLP) - VM(pic->uPAIRP, OP_PAIRP) - VM(pic->uNOT, OP_NOT) - VM(pic->uEQ, OP_EQ) - VM(pic->uLT, OP_LT) - VM(pic->uLE, OP_LE) - VM(pic->uGT, OP_GT) - VM(pic->uGE, OP_GE) - VM(pic->uADD, OP_ADD) - VM(pic->uSUB, OP_SUB) - VM(pic->uMUL, OP_MUL) - VM(pic->uDIV, OP_DIV) + VM(pic->sCONS, OP_CONS) + VM(pic->sCAR, OP_CAR) + VM(pic->sCDR, OP_CDR) + VM(pic->sNILP, OP_NILP) + VM(pic->sSYMBOLP, OP_SYMBOLP) + VM(pic->sPAIRP, OP_PAIRP) + VM(pic->sNOT, OP_NOT) + VM(pic->sEQ, OP_EQ) + VM(pic->sLT, OP_LT) + VM(pic->sLE, OP_LE) + VM(pic->sGT, OP_GT) + VM(pic->sGE, OP_GE) + VM(pic->sADD, OP_ADD) + VM(pic->sSUB, OP_SUB) + VM(pic->sMUL, OP_MUL) + VM(pic->sDIV, OP_DIV) } emit_i(pic, cxt, (tailpos ? OP_TAILCALL : OP_CALL), len - 1); @@ -1018,19 +1018,19 @@ codegen(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos) if (sym == GREF || sym == CREF || sym == LREF) { codegen_ref(pic, cxt, obj, tailpos); } - else if (sym == pic->uSETBANG || sym == pic->uDEFINE) { + else if (sym == pic->sSETBANG || sym == pic->sDEFINE) { codegen_set(pic, cxt, obj, tailpos); } - else if (sym == pic->uLAMBDA) { + else if (sym == pic->sLAMBDA) { codegen_lambda(pic, cxt, obj, tailpos); } - else if (sym == pic->uIF) { + else if (sym == pic->sIF) { codegen_if(pic, cxt, obj, tailpos); } - else if (sym == pic->uBEGIN) { + else if (sym == pic->sBEGIN) { codegen_begin(pic, cxt, obj, tailpos); } - else if (sym == pic->uQUOTE) { + else if (sym == pic->sQUOTE) { codegen_quote(pic, cxt, obj, tailpos); } else if (sym == CALL) { diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index 7215cb4b..c7c32319 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -347,6 +347,9 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) gc_mark_object(pic, (struct pic_object *)kh_val(h, it)); } } + if (obj->u.env.prefix) { + gc_mark_object(pic, (struct pic_object *)obj->u.env.prefix); + } if (obj->u.env.up) { LOOP(obj->u.env.up); } @@ -420,7 +423,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) } #define M(x) gc_mark_object(pic, (struct pic_object *)pic->x) -#define P(x) gc_mark(pic, pic->x) static void gc_mark_phase(pic_state *pic) @@ -469,22 +471,13 @@ gc_mark_phase(pic_state *pic) } /* mark reserved symbols */ + M(sDEFINE); M(sDEFINE_MACRO); M(sLAMBDA); M(sIF); M(sBEGIN); M(sSETBANG); M(sQUOTE); M(sQUASIQUOTE); M(sUNQUOTE); M(sUNQUOTE_SPLICING); M(sSYNTAX_QUOTE); M(sSYNTAX_QUASIQUOTE); M(sSYNTAX_UNQUOTE); M(sSYNTAX_UNQUOTE_SPLICING); M(sDEFINE_LIBRARY); M(sIMPORT); M(sEXPORT); M(sCOND_EXPAND); - M(uDEFINE); M(uLAMBDA); M(uIF); M(uBEGIN); M(uQUOTE); M(uSETBANG); M(uDEFINE_MACRO); - M(uDEFINE_LIBRARY); M(uIMPORT); M(uEXPORT); M(uCOND_EXPAND); - - M(uCONS); M(uCAR); M(uCDR); M(uNILP); M(uSYMBOLP); M(uPAIRP); - M(uADD); M(uSUB); M(uMUL); M(uDIV); M(uEQ); M(uLT); M(uLE); M(uGT); M(uGE); M(uNOT); - - /* mark system procedures */ - P(pCONS); P(pCAR); P(pCDR); P(pNILP); P(pSYMBOLP); P(pPAIRP); P(pNOT); - P(pADD); P(pSUB); P(pMUL); P(pDIV); P(pEQ); P(pLT); P(pLE); P(pGT); P(pGE); - - M(cCONS); M(cCAR); M(cCDR); M(cNILP); M(cSYMBOLP); M(cPAIRP); M(cNOT); - M(cADD); M(cSUB); M(cMUL); M(cDIV); M(cEQ); M(cLT); M(cLE); M(cGT); M(cGE); + M(sCONS); M(sCAR); M(sCDR); M(sNILP); M(sSYMBOLP); M(sPAIRP); + M(sADD); M(sSUB); M(sMUL); M(sDIV); M(sEQ); M(sLT); M(sLE); M(sGT); M(sGE); M(sNOT); /* global variables */ if (pic->globals) { diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index 8ee7db53..bf015a8b 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -94,22 +94,13 @@ struct pic_state { struct pic_lib *lib, *prev_lib; + pic_sym *sDEFINE, *sDEFINE_MACRO, *sLAMBDA, *sIF, *sBEGIN, *sSETBANG; pic_sym *sQUOTE, *sQUASIQUOTE, *sUNQUOTE, *sUNQUOTE_SPLICING; pic_sym *sSYNTAX_QUOTE, *sSYNTAX_QUASIQUOTE; pic_sym *sSYNTAX_UNQUOTE, *sSYNTAX_UNQUOTE_SPLICING; pic_sym *sDEFINE_LIBRARY, *sIMPORT, *sEXPORT, *sCOND_EXPAND; - - pic_sym *uDEFINE, *uLAMBDA, *uIF, *uBEGIN, *uQUOTE, *uSETBANG, *uDEFINE_MACRO; - pic_sym *uDEFINE_LIBRARY, *uIMPORT, *uEXPORT, *uCOND_EXPAND; - - pic_sym *uCONS, *uCAR, *uCDR, *uNILP, *uSYMBOLP, *uPAIRP; - pic_sym *uADD, *uSUB, *uMUL, *uDIV, *uEQ, *uLT, *uLE, *uGT, *uGE, *uNOT; - - pic_value pCONS, pCAR, pCDR, pNILP, pPAIRP, pSYMBOLP, pNOT; - pic_value pADD, pSUB, pMUL, pDIV, pEQ, pLT, pLE, pGT, pGE; - - struct pic_box *cCONS, *cCAR, *cCDR, *cNILP, *cPAIRP, *cSYMBOLP, *cNOT; - struct pic_box *cADD, *cSUB, *cMUL, *cDIV, *cEQ, *cLT, *cLE, *cGT, *cGE; + pic_sym *sCONS, *sCAR, *sCDR, *sNILP, *sSYMBOLP, *sPAIRP; + pic_sym *sADD, *sSUB, *sMUL, *sDIV, *sEQ, *sLT, *sLE, *sGT, *sGE, *sNOT; struct pic_lib *PICRIN_BASE; struct pic_lib *PICRIN_USER; diff --git a/extlib/benz/include/picrin/macro.h b/extlib/benz/include/picrin/macro.h index 80906ccb..db01279f 100644 --- a/extlib/benz/include/picrin/macro.h +++ b/extlib/benz/include/picrin/macro.h @@ -21,6 +21,7 @@ struct pic_env { PIC_OBJECT_HEADER khash_t(env) map; struct pic_env *up; + pic_str *prefix; }; #define pic_id_p(v) (pic_type(v) == PIC_TT_ID) @@ -30,14 +31,13 @@ struct pic_env { #define pic_env_ptr(v) ((struct pic_env *)pic_ptr(v)) struct pic_id *pic_make_id(pic_state *, pic_value, struct pic_env *); +struct pic_env *pic_make_topenv(pic_state *, pic_str *); struct pic_env *pic_make_env(pic_state *, struct pic_env *); -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_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_resolve(pic_state *, pic_value, struct pic_env *); +pic_sym *pic_resolve_variable(pic_state *, struct pic_env *, pic_value); bool pic_var_p(pic_value); pic_sym *pic_var_name(pic_state *, pic_value); diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index 76e2d70b..71a18f6a 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -4,13 +4,30 @@ #include "picrin.h" -static void -setup_default_env(pic_state *pic, struct pic_env *env) +static struct pic_env * +make_library_env(pic_state *pic, pic_value name) { - pic_put_variable(pic, env, pic_obj_value(pic->sDEFINE_LIBRARY), pic->uDEFINE_LIBRARY); - pic_put_variable(pic, env, pic_obj_value(pic->sIMPORT), pic->uIMPORT); - pic_put_variable(pic, env, pic_obj_value(pic->sEXPORT), pic->uEXPORT); - pic_put_variable(pic, env, pic_obj_value(pic->sCOND_EXPAND), pic->uCOND_EXPAND); + struct pic_env *env; + pic_value dir, it; + pic_str *prefix = NULL; + + pic_for_each (dir, name, it) { + if (prefix == NULL) { + prefix = pic_format(pic, "~a", dir); + } else { + prefix = pic_format(pic, "~a.~a", pic_obj_value(prefix), dir); + } + } + + env = pic_make_topenv(pic, prefix); + + /* set up default environment */ + pic_put_variable(pic, env, pic_obj_value(pic->sDEFINE_LIBRARY), pic->sDEFINE_LIBRARY); + pic_put_variable(pic, env, pic_obj_value(pic->sIMPORT), pic->sIMPORT); + pic_put_variable(pic, env, pic_obj_value(pic->sEXPORT), pic->sEXPORT); + pic_put_variable(pic, env, pic_obj_value(pic->sCOND_EXPAND), pic->sCOND_EXPAND); + + return env; } struct pic_lib * @@ -24,11 +41,9 @@ pic_make_library(pic_state *pic, pic_value name) pic_errorf(pic, "library name already in use: ~s", name); } - env = pic_make_env(pic, NULL); + env = make_library_env(pic, name); exports = pic_make_dict(pic); - setup_default_env(pic, env); - lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB); lib->name = name; lib->env = env; diff --git a/extlib/benz/macro.c b/extlib/benz/macro.c index 78641c44..3b052d46 100644 --- a/extlib/benz/macro.c +++ b/extlib/benz/macro.c @@ -30,8 +30,23 @@ pic_make_env(pic_state *pic, struct pic_env *up) { struct pic_env *env; + assert(up != NULL); + env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV); env->up = up; + env->prefix = NULL; + kh_init(env, &env->map); + return env; +} + +struct pic_env * +pic_make_topenv(pic_state *pic, pic_str *prefix) +{ + struct pic_env *env; + + env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV); + env->up = NULL; + env->prefix = prefix; kh_init(env, &env->map); return env; } @@ -48,33 +63,28 @@ pic_var_name(pic_state PIC_UNUSED(*pic), pic_value var) } pic_sym * -pic_uniq(pic_state *pic, pic_value var) +pic_add_variable(pic_state *pic, struct pic_env *env, pic_value var) { + const char *name; + pic_sym *uid; pic_str *str; assert(pic_var_p(var)); - str = pic_format(pic, "%s.%d", pic_symbol_name(pic, pic_var_name(pic, var)), pic->ucnt++); + name = pic_symbol_name(pic, pic_var_name(pic, var)); - return pic_intern_str(pic, str); + if (env->up == NULL && pic_sym_p(var)) { /* toplevel & public */ + str = pic_format(pic, "%s/%s", pic_str_cstr(pic, env->prefix), name); + } else { + str = pic_format(pic, ".%s.%d", name, pic->ucnt++); + } + uid = pic_intern_str(pic, str); + + return pic_put_variable(pic, env, var, 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) +pic_put_variable(pic_state *pic, struct pic_env *env, pic_value var, pic_sym *uid) { khiter_t it; int ret; @@ -83,6 +93,8 @@ pic_put_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var, it = kh_put(env, &env->map, pic_ptr(var), &ret); kh_val(&env->map, it) = uid; + + return uid; } pic_sym * @@ -115,7 +127,7 @@ lookup(void *var, struct pic_env *env) } pic_sym * -pic_resolve(pic_state *pic, pic_value var, struct pic_env *env) +pic_resolve_variable(pic_state *pic, struct pic_env *env, pic_value var) { pic_sym *uid; diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 2459db5a..ba398418 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -108,19 +108,18 @@ pic_features(pic_state *pic) return pic->features; } -#define DONE pic_gc_arena_restore(pic, ai); +#define import_builtin_syntax(name) do { \ + pic_sym *nick, *real; \ + nick = pic_intern(pic, "builtin:" name); \ + real = pic_intern(pic, name); \ + pic_put_variable(pic, pic->lib->env, pic_obj_value(nick), real); \ + } while (0) -#define define_builtin_syntax(uid, name) \ - pic_put_variable(pic, pic->lib->env, pic_obj_value(pic_intern(pic, name)), uid) - -#define VM(uid, name) \ - pic_put_variable(pic, pic->lib->env, pic_obj_value(pic_intern(pic, name)), uid) - -#define VM3(name) \ - pic->c##name = pic_vm_gref_slot(pic, pic->u##name); - -#define VM2(proc, name) \ - proc = pic_ref(pic, pic->lib, name) +#define declare_vm_procedure(name) do { \ + pic_sym *id; \ + id = pic_intern(pic, name); \ + pic_put_variable(pic, pic->lib->env, pic_obj_value(id), id); \ + } while (0) static void pic_init_core(pic_state *pic) @@ -132,32 +131,34 @@ pic_init_core(pic_state *pic) pic_deflibrary (pic, "(picrin base)") { size_t ai = pic_gc_arena_preserve(pic); - define_builtin_syntax(pic->uDEFINE, "builtin:define"); - define_builtin_syntax(pic->uSETBANG, "builtin:set!"); - define_builtin_syntax(pic->uQUOTE, "builtin:quote"); - define_builtin_syntax(pic->uLAMBDA, "builtin:lambda"); - define_builtin_syntax(pic->uIF, "builtin:if"); - define_builtin_syntax(pic->uBEGIN, "builtin:begin"); - define_builtin_syntax(pic->uDEFINE_MACRO, "builtin:define-macro"); +#define DONE pic_gc_arena_restore(pic, ai); - pic_defun(pic, "features", pic_features); + import_builtin_syntax("define"); + import_builtin_syntax("set!"); + import_builtin_syntax("quote"); + import_builtin_syntax("lambda"); + import_builtin_syntax("if"); + import_builtin_syntax("begin"); + import_builtin_syntax("define-macro"); - VM(pic->uCONS, "cons"); - VM(pic->uCAR, "car"); - VM(pic->uCDR, "cdr"); - VM(pic->uNILP, "null?"); - VM(pic->uSYMBOLP, "symbol?"); - VM(pic->uPAIRP, "pair?"); - VM(pic->uNOT, "not"); - VM(pic->uADD, "+"); - VM(pic->uSUB, "-"); - VM(pic->uMUL, "*"); - VM(pic->uDIV, "/"); - VM(pic->uEQ, "="); - VM(pic->uLT, "<"); - VM(pic->uLE, "<="); - VM(pic->uGT, ">"); - VM(pic->uGE, ">="); + declare_vm_procedure("cons"); + declare_vm_procedure("car"); + declare_vm_procedure("cdr"); + declare_vm_procedure("null?"); + declare_vm_procedure("symbol?"); + declare_vm_procedure("pair?"); + declare_vm_procedure("+"); + declare_vm_procedure("-"); + declare_vm_procedure("*"); + declare_vm_procedure("/"); + declare_vm_procedure("="); + declare_vm_procedure("<"); + declare_vm_procedure(">"); + declare_vm_procedure("<="); + declare_vm_procedure(">="); + declare_vm_procedure("not"); + + DONE; pic_init_bool(pic); DONE; pic_init_pair(pic); DONE; @@ -181,39 +182,7 @@ pic_init_core(pic_state *pic) pic_init_lib(pic); DONE; pic_init_reg(pic); DONE; - VM3(CONS); - VM3(CAR); - VM3(CDR); - VM3(NILP); - VM3(SYMBOLP); - VM3(PAIRP); - VM3(NOT); - VM3(ADD); - VM3(SUB); - VM3(MUL); - VM3(DIV); - VM3(EQ); - VM3(LT); - VM3(LE); - VM3(GT); - VM3(GE); - - VM2(pic->pCONS, "cons"); - VM2(pic->pCAR, "car"); - VM2(pic->pCDR, "cdr"); - VM2(pic->pNILP, "null?"); - VM2(pic->pSYMBOLP, "symbol?"); - VM2(pic->pPAIRP, "pair?"); - VM2(pic->pNOT, "not"); - VM2(pic->pADD, "+"); - VM2(pic->pSUB, "-"); - VM2(pic->pMUL, "*"); - VM2(pic->pDIV, "/"); - VM2(pic->pEQ, "="); - VM2(pic->pLT, "<"); - VM2(pic->pLE, "<="); - VM2(pic->pGT, ">"); - VM2(pic->pGE, ">="); + pic_defun(pic, "features", pic_features); pic_try { pic_load_cstr(pic, &pic_boot[0][0]); @@ -336,6 +305,12 @@ pic_open(pic_allocf allocf, void *userdata) #define S(slot,name) pic->slot = pic_intern(pic, name) + S(sDEFINE, "define"); + S(sDEFINE_MACRO, "define-macro"); + S(sLAMBDA, "lambda"); + S(sIF, "if"); + S(sBEGIN, "begin"); + S(sSETBANG, "set!"); S(sQUOTE, "quote"); S(sQUASIQUOTE, "quasiquote"); S(sUNQUOTE, "unquote"); @@ -349,57 +324,25 @@ pic_open(pic_allocf allocf, void *userdata) S(sDEFINE_LIBRARY, "define-library"); S(sCOND_EXPAND, "cond-expand"); + S(sCONS, "cons"); + S(sCAR, "car"); + S(sCDR, "cdr"); + S(sNILP, "null?"); + S(sSYMBOLP, "symbol?"); + S(sPAIRP, "pair?"); + S(sADD, "+"); + S(sSUB, "-"); + S(sMUL, "*"); + S(sDIV, "/"); + S(sEQ, "="); + S(sLT, "<"); + S(sLE, "<="); + S(sGT, ">"); + S(sGE, ">="); + S(sNOT, "not"); + pic_gc_arena_restore(pic, ai); -#define U(slot,name) pic->slot = pic_uniq(pic, pic_obj_value(pic_intern(pic, name))) - - U(uDEFINE, "define"); - U(uLAMBDA, "lambda"); - U(uIF, "if"); - U(uBEGIN, "begin"); - U(uSETBANG, "set!"); - U(uQUOTE, "quote"); - U(uDEFINE_MACRO, "define-macro"); - U(uIMPORT, "import"); - U(uEXPORT, "export"); - U(uDEFINE_LIBRARY, "define-library"); - U(uCOND_EXPAND, "cond-expand"); - U(uCONS, "cons"); - U(uCAR, "car"); - U(uCDR, "cdr"); - U(uNILP, "null?"); - U(uSYMBOLP, "symbol?"); - U(uPAIRP, "pair?"); - U(uADD, "+"); - U(uSUB, "-"); - U(uMUL, "*"); - U(uDIV, "/"); - U(uEQ, "="); - U(uLT, "<"); - U(uLE, "<="); - U(uGT, ">"); - U(uGE, ">="); - U(uNOT, "not"); - pic_gc_arena_restore(pic, ai); - - /* system procedures */ - pic->pCONS = pic_invalid_value(); - pic->pCAR = pic_invalid_value(); - pic->pCDR = pic_invalid_value(); - pic->pNILP = pic_invalid_value(); - pic->pSYMBOLP = pic_invalid_value(); - pic->pPAIRP = pic_invalid_value(); - pic->pNOT = pic_invalid_value(); - pic->pADD = pic_invalid_value(); - pic->pSUB = pic_invalid_value(); - pic->pMUL = pic_invalid_value(); - pic->pDIV = pic_invalid_value(); - pic->pEQ = pic_invalid_value(); - pic->pLT = pic_invalid_value(); - pic->pLE = pic_invalid_value(); - pic->pGT = pic_invalid_value(); - pic->pGE = pic_invalid_value(); - /* root tables */ pic->globals = pic_make_reg(pic); pic->macros = pic_make_reg(pic); @@ -427,23 +370,6 @@ pic_open(pic_allocf allocf, void *userdata) /* turn on GC */ pic->gc_enable = true; - pic->cCONS = pic_box(pic, pic_invalid_value()); - pic->cCAR = pic_box(pic, pic_invalid_value()); - pic->cCDR = pic_box(pic, pic_invalid_value()); - pic->cNILP = pic_box(pic, pic_invalid_value()); - pic->cSYMBOLP = pic_box(pic, pic_invalid_value()); - pic->cPAIRP = pic_box(pic, pic_invalid_value()); - pic->cNOT = pic_box(pic, pic_invalid_value()); - pic->cADD = pic_box(pic, pic_invalid_value()); - pic->cSUB = pic_box(pic, pic_invalid_value()); - pic->cMUL = pic_box(pic, pic_invalid_value()); - pic->cDIV = pic_box(pic, pic_invalid_value()); - pic->cEQ = pic_box(pic, pic_invalid_value()); - pic->cLT = pic_box(pic, pic_invalid_value()); - pic->cLE = pic_box(pic, pic_invalid_value()); - pic->cGT = pic_box(pic, pic_invalid_value()); - pic->cGE = pic_box(pic, pic_invalid_value()); - pic_init_core(pic); pic_gc_arena_restore(pic, ai); diff --git a/extlib/benz/vm.c b/extlib/benz/vm.c index 3b52b079..dc6f5130 100644 --- a/extlib/benz/vm.c +++ b/extlib/benz/vm.c @@ -636,8 +636,6 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv) } #define check_condition(name, n) do { \ - if (! pic_eq_p(pic->p##name, pic->c##name->value)) \ - goto L_CALL; \ if (c.a != n + 1) \ goto L_CALL; \ } while (0)