change mangling rule for global variables
This commit is contained in:
parent
1fbc38fe55
commit
0fd529c968
|
@ -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;
|
||||
|
|
|
@ -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) {
|
||||
|
|
|
@ -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) {
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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;
|
||||
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in New Issue