conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'master' into symbol-is-a-identifier

This commit is contained in:
Yuichi Nishiwaki 2016-02-06 21:21:24 +09:00
parent 5e58847721 bb5b15790d
commit bf68695707
12 changed files with 364 additions and 373 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
extlib/benz/bool.c
View File

@ -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;

206
extlib/benz/codegen.c
View File

@ -9,48 +9,6 @@
* macro expander
*/
static pic_sym *
lookup(pic_state *pic, pic_value var, struct pic_env *env)
{
khiter_t it;
pic_assert_type(pic, var, var);
while (env != NULL) {
it = kh_get(env, &env->map, pic_ptr(var));
if (it != kh_end(&env->map)) {
return kh_val(&env->map, it);
}
env = env->up;
}
return NULL;
}
pic_sym *
pic_resolve(pic_state *pic, pic_value var, struct pic_env *env)
{
pic_sym *uid;
assert(env != NULL);
pic_assert_type(pic, var, var);
while ((uid = lookup(pic, var, env)) == NULL) {
if (pic_sym_p(var)) {
break;
}
env = pic_id_ptr(var)->env;
var = pic_id_ptr(var)->var;
}
if (uid == NULL) {
while (env->up != NULL) {
env = env->up;
}
uid = pic_add_variable(pic, env, var);
}
return uid;
}
static void
define_macro(pic_state *pic, pic_sym *uid, struct pic_proc *mac)
{
@ -86,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);
@ -97,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
@ -171,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
@ -188,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
@ -230,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);
}
@ -310,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)));
}
}
@ -327,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) */
@ -336,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:
@ -548,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
@ -595,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)));
}
}
@ -612,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);
}
}
@ -652,10 +610,14 @@ typedef struct codegen_context {
pic_code *code;
size_t clen, ccapa;
/* child ireps */
struct pic_irep **irep;
union irep_node *irep;
size_t ilen, icapa;
/* constant object pool */
pic_value *pool;
int *ints;
size_t klen, kcapa;
double *nums;
size_t flen, fcapa;
struct pic_object **pool;
size_t plen, pcapa;
struct codegen_context *up;
@ -677,14 +639,22 @@ codegen_context_init(pic_state *pic, codegen_context *cxt, codegen_context *up,
cxt->clen = 0;
cxt->ccapa = PIC_ISEQ_SIZE;
cxt->irep = pic_calloc(pic, PIC_IREP_SIZE, sizeof(struct pic_irep *));
cxt->irep = pic_calloc(pic, PIC_IREP_SIZE, sizeof(union irep_node));
cxt->ilen = 0;
cxt->icapa = PIC_IREP_SIZE;
cxt->pool = pic_calloc(pic, PIC_POOL_SIZE, sizeof(pic_value));
cxt->pool = pic_calloc(pic, PIC_POOL_SIZE, sizeof(struct pic_object *));
cxt->plen = 0;
cxt->pcapa = PIC_POOL_SIZE;
cxt->ints = pic_calloc(pic, PIC_POOL_SIZE, sizeof(int));
cxt->klen = 0;
cxt->kcapa = PIC_POOL_SIZE;
cxt->nums = pic_calloc(pic, PIC_POOL_SIZE, sizeof(double));
cxt->flen = 0;
cxt->fcapa = PIC_POOL_SIZE;
create_activation(pic, cxt);
}
@ -700,11 +670,16 @@ codegen_context_destroy(pic_state *pic, codegen_context *cxt)
irep->argc = (int)cxt->args->len + 1;
irep->localc = (int)cxt->locals->len;
irep->capturec = (int)cxt->captures->len;
irep->code = pic_realloc(pic, cxt->code, sizeof(pic_code) * cxt->clen);
irep->irep = pic_realloc(pic, cxt->irep, sizeof(struct pic_irep *) * cxt->ilen);
irep->ilen = cxt->ilen;
irep->pool = pic_realloc(pic, cxt->pool, sizeof(pic_value) * cxt->plen);
irep->plen = cxt->plen;
irep->u.s.code = pic_realloc(pic, cxt->code, sizeof(pic_code) * cxt->clen);
irep->u.s.irep = pic_realloc(pic, cxt->irep, sizeof(union irep_node) * cxt->ilen);
irep->u.s.ints = pic_realloc(pic, cxt->ints, sizeof(int) * cxt->klen);
irep->u.s.nums = pic_realloc(pic, cxt->nums, sizeof(double) * cxt->flen);
irep->pool = pic_realloc(pic, cxt->pool, sizeof(struct pic_object *) * cxt->plen);
irep->ncode = cxt->clen;
irep->nirep = cxt->ilen;
irep->nints = cxt->klen;
irep->nnums = cxt->flen;
irep->npool = cxt->plen;
irep->list.next = pic->ireps.next;
irep->list.prev = &pic->ireps;
@ -723,7 +698,9 @@ codegen_context_destroy(pic_state *pic, codegen_context *cxt)
#define check_code_size(pic, cxt) check_size(pic, cxt, c, code, pic_code)
#define check_irep_size(pic, cxt) check_size(pic, cxt, i, irep, struct pic_irep *)
#define check_pool_size(pic, cxt) check_size(pic, cxt, p, pool, pic_value)
#define check_pool_size(pic, cxt) check_size(pic, cxt, p, pool, struct pic_object *)
#define check_ints_size(pic, cxt) check_size(pic, cxt, k, ints, int)
#define check_nums_size(pic, cxt) check_size(pic, cxt, f, nums, double)
#define emit_n(pic, cxt, ins) do { \
check_code_size(pic, cxt); \
@ -734,15 +711,15 @@ codegen_context_destroy(pic_state *pic, codegen_context *cxt)
#define emit_i(pic, cxt, ins, I) do { \
check_code_size(pic, cxt); \
cxt->code[cxt->clen].insn = ins; \
cxt->code[cxt->clen].u.i = I; \
cxt->code[cxt->clen].a = I; \
cxt->clen++; \
} while (0) \
#define emit_r(pic, cxt, ins, D, I) do { \
check_code_size(pic, cxt); \
cxt->code[cxt->clen].insn = ins; \
cxt->code[cxt->clen].u.r.depth = D; \
cxt->code[cxt->clen].u.r.idx = I; \
cxt->code[cxt->clen].a = D; \
cxt->code[cxt->clen].b = I; \
cxt->clen++; \
} while (0) \
@ -793,7 +770,7 @@ index_global(pic_state *pic, codegen_context *cxt, pic_sym *name)
check_pool_size(pic, cxt);
pidx = (int)cxt->plen++;
cxt->pool[pidx] = pic_obj_value(slot);
cxt->pool[pidx] = (struct pic_object *)(slot);
return pidx;
}
@ -920,7 +897,7 @@ codegen_lambda(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos
/* emit irep */
codegen_context_init(pic, inner_cxt, cxt, rest, args, locals, captures);
codegen(pic, inner_cxt, body, true);
cxt->irep[cxt->ilen] = codegen_context_destroy(pic, inner_cxt);
cxt->irep[cxt->ilen].i = codegen_context_destroy(pic, inner_cxt);
/* emit OP_LAMBDA */
emit_i(pic, cxt, OP_LAMBDA, cxt->ilen++);
@ -945,11 +922,11 @@ codegen_if(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
emit_n(pic, cxt, OP_JMP);
cxt->code[s].u.i = (int)cxt->clen - s;
cxt->code[s].a = (int)cxt->clen - s;
/* if true branch */
codegen(pic, cxt, pic_list_ref(pic, obj, 2), tailpos);
cxt->code[t].u.i = (int)cxt->clen - t;
cxt->code[t].a = (int)cxt->clen - t;
}
static void
@ -969,32 +946,43 @@ codegen_quote(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
switch (pic_type(obj)) {
case PIC_TT_UNDEF:
emit_n(pic, cxt, OP_PUSHUNDEF);
emit_ret(pic, cxt, tailpos);
break;
case PIC_TT_BOOL:
emit_n(pic, cxt, (pic_true_p(obj) ? OP_PUSHTRUE : OP_PUSHFALSE));
emit_ret(pic, cxt, tailpos);
break;
case PIC_TT_INT:
emit_i(pic, cxt, OP_PUSHINT, pic_int(obj));
emit_ret(pic, cxt, tailpos);
check_ints_size(pic, cxt);
pidx = (int)cxt->klen++;
cxt->ints[pidx] = pic_int(obj);
emit_i(pic, cxt, OP_PUSHINT, pidx);
break;
case PIC_TT_FLOAT:
check_nums_size(pic, cxt);
pidx = (int)cxt->flen++;
cxt->nums[pidx] = pic_float(obj);
emit_i(pic, cxt, OP_PUSHFLOAT, pidx);
break;
case PIC_TT_NIL:
emit_n(pic, cxt, OP_PUSHNIL);
emit_ret(pic, cxt, tailpos);
break;
case PIC_TT_EOF:
emit_n(pic, cxt, OP_PUSHEOF);
break;
case PIC_TT_CHAR:
emit_i(pic, cxt, OP_PUSHCHAR, pic_char(obj));
emit_ret(pic, cxt, tailpos);
check_ints_size(pic, cxt);
pidx = (int)cxt->klen++;
cxt->ints[pidx] = pic_char(obj);
emit_i(pic, cxt, OP_PUSHCHAR, pidx);
break;
default:
assert(pic_obj_p(obj));
check_pool_size(pic, cxt);
pidx = (int)cxt->plen++;
cxt->pool[pidx] = obj;
cxt->pool[pidx] = pic_obj_ptr(obj);
emit_i(pic, cxt, OP_PUSHCONST, pidx);
emit_ret(pic, cxt, tailpos);
break;
}
emit_ret(pic, cxt, tailpos);
}
#define VM(uid, op) \
@ -1020,22 +1008,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);
@ -1050,19 +1038,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) {

23
extlib/benz/gc.c
View File

@ -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)
@ -463,28 +465,19 @@ gc_mark_phase(pic_state *pic)
/* ireps */
for (list = pic->ireps.next; list != &pic->ireps; list = list->next) {
struct pic_irep *irep = (struct pic_irep *)list;
for (j = 0; j < irep->plen; ++j) {
gc_mark(pic, irep->pool[j]);
for (j = 0; j < irep->npool; ++j) {
gc_mark_object(pic, irep->pool[j]);
}
}
/* 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) {

15
extlib/benz/include/picrin.h
View File

@ -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;

29
extlib/benz/include/picrin/irep.h
View File

@ -11,13 +11,8 @@ extern "C" {
typedef struct {
int insn;
union {
int i;
struct {
int depth;
int idx;
} r;
} u;
int a;
int b;
} pic_code;
struct pic_list {
@ -26,20 +21,26 @@ struct pic_list {
struct pic_irep {
struct pic_list list;
int refc;
pic_code *code;
unsigned refc;
int argc, localc, capturec;
bool varg;
struct pic_irep **irep;
size_t ilen;
pic_value *pool;
size_t plen;
union {
struct {
pic_code *code;
int *ints;
double *nums;
union irep_node {
struct pic_irep *i;
} *irep;
} s;
} u;
struct pic_object **pool; /* pool of heap objects */
size_t ncode, nirep, nints, nnums, npool;
};
void pic_irep_incref(pic_state *, struct pic_irep *);
void pic_irep_decref(pic_state *, struct pic_irep *);
pic_sym *pic_resolve(pic_state *, pic_value, struct pic_env *);
pic_value pic_expand(pic_state *, pic_value, struct pic_env *);
pic_value pic_analyze(pic_state *, pic_value);
struct pic_irep *pic_codegen(pic_state *, pic_value);

7
extlib/benz/include/picrin/macro.h
View File

@ -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,13 +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_variable(pic_state *, struct pic_env *, pic_value);
bool pic_var_p(pic_value);
pic_sym *pic_var_name(pic_state *, pic_value);

53
extlib/benz/include/picrin/opcode.h
View File

@ -17,7 +17,9 @@ enum pic_opcode {
OP_PUSHTRUE,
OP_PUSHFALSE,
OP_PUSHINT,
OP_PUSHFLOAT,
OP_PUSHCHAR,
OP_PUSHEOF,
OP_PUSHCONST,
OP_GREF,
OP_GSET,
@ -52,7 +54,7 @@ enum pic_opcode {
#define PIC_INIT_CODE_I(code, op, ival) do { \
code.insn = op; \
code.u.i = ival; \
code.a = ival; \
} while (0)
#if DEBUG
@ -80,52 +82,58 @@ pic_dump_code(pic_code c)
puts("OP_PUSHFALSE");
break;
case OP_PUSHINT:
printf("OP_PUSHINT\t%d\n", c.u.i);
printf("OP_PUSHINT\t%d\n", c.a);
break;
case OP_PUSHFLOAT:
printf("OP_PUSHFLAOT\t%d\n", c.a);
break;
case OP_PUSHCHAR:
printf("OP_PUSHCHAR\t%c\n", c.u.c);
printf("OP_PUSHCHAR\t%c\n", c.a);
break;
case OP_PUSHEOF:
puts("OP_PUSHEOF");
break;
case OP_PUSHCONST:
printf("OP_PUSHCONST\t%d\n", c.u.i);
printf("OP_PUSHCONST\t%d\n", c.a);
break;
case OP_GREF:
printf("OP_GREF\t%i\n", c.u.i);
printf("OP_GREF\t%i\n", c.a);
break;
case OP_GSET:
printf("OP_GSET\t%i\n", c.u.i);
printf("OP_GSET\t%i\n", c.a);
break;
case OP_LREF:
printf("OP_LREF\t%d\n", c.u.i);
printf("OP_LREF\t%d\n", c.a);
break;
case OP_LSET:
printf("OP_LSET\t%d\n", c.u.i);
printf("OP_LSET\t%d\n", c.a);
break;
case OP_CREF:
printf("OP_CREF\t%d\t%d\n", c.u.r.depth, c.u.r.idx);
printf("OP_CREF\t%d\t%d\n", c.a, c.b);
break;
case OP_CSET:
printf("OP_CSET\t%d\t%d\n", c.u.r.depth, c.u.r.idx);
printf("OP_CSET\t%d\t%d\n", c.a, c.b);
break;
case OP_JMP:
printf("OP_JMP\t%x\n", c.u.i);
printf("OP_JMP\t%x\n", c.a);
break;
case OP_JMPIF:
printf("OP_JMPIF\t%x\n", c.u.i);
printf("OP_JMPIF\t%x\n", c.a);
break;
case OP_NOT:
puts("OP_NOT");
break;
case OP_CALL:
printf("OP_CALL\t%d\n", c.u.i);
printf("OP_CALL\t%d\n", c.a);
break;
case OP_TAILCALL:
printf("OP_TAILCALL\t%d\n", c.u.i);
printf("OP_TAILCALL\t%d\n", c.a);
break;
case OP_RET:
puts("OP_RET");
break;
case OP_LAMBDA:
printf("OP_LAMBDA\t%d\n", c.u.i);
printf("OP_LAMBDA\t%d\n", c.a);
break;
case OP_CONS:
puts("OP_CONS");
@ -181,17 +189,20 @@ pic_dump_code(pic_code c)
PIC_INLINE void
pic_dump_irep(struct pic_irep *irep)
{
unsigned i;
size_t i;
printf("## irep %p\n", (void *)irep);
printf("[clen = %zd, argc = %d, localc = %d, capturec = %d]\n", irep->clen, irep->argc, irep->localc, irep->capturec);
for (i = 0; i < irep->clen; ++i) {
printf("# argc = %d\n", irep->argc);
printf("# localc = %d\n", irep->localc);
printf("# capturec = %d\n", irep->capturec);
for (i = 0; i < irep->ncode; ++i) {
printf("%02x: ", i);
pic_dump_code(irep->code[i]);
pic_dump_code(irep->u.s.code[i]);
}
for (i = 0; i < irep->ilen; ++i) {
pic_dump_irep(irep->irep[i]);
for (i = 0; i < irep->nirep; ++i) {
pic_dump_irep(irep->u.s.irep[i].i);
}
}

33
extlib/benz/lib.c
View File

@ -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;

88
extlib/benz/macro.c
View File

@ -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 *
@ -99,6 +111,46 @@ pic_find_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var
return kh_val(&env->map, it);
}
static pic_sym *
lookup(void *var, struct pic_env *env)
{
khiter_t it;
while (env != NULL) {
it = kh_get(env, &env->map, var);
if (it != kh_end(&env->map)) {
return kh_val(&env->map, it);
}
env = env->up;
}
return NULL;
}
pic_sym *
pic_resolve_variable(pic_state *pic, struct pic_env *env, pic_value var)
{
pic_sym *uid;
assert(env != NULL);
pic_assert_type(pic, var, var);
while ((uid = lookup(pic_ptr(var), env)) == NULL) {
if (pic_sym_p(var)) {
break;
}
env = pic_id_ptr(var)->env;
var = pic_id_ptr(var)->var;
}
if (uid == NULL) {
while (env->up != NULL) {
env = env->up;
}
uid = pic_add_variable(pic, env, var);
}
return uid;
}
static pic_value
pic_macro_identifier_p(pic_state *pic)
{

10
extlib/benz/proc.c
View File

@ -16,17 +16,19 @@ pic_irep_decref(pic_state *pic, struct pic_irep *irep)
size_t i;
if (--irep->refc == 0) {
pic_free(pic, irep->code);
pic_free(pic, irep->u.s.code);
pic_free(pic, irep->u.s.ints);
pic_free(pic, irep->u.s.nums);
pic_free(pic, irep->pool);
/* unchain before decref children ireps */
irep->list.prev->next = irep->list.next;
irep->list.next->prev = irep->list.prev;
for (i = 0; i < irep->ilen; ++i) {
pic_irep_decref(pic, irep->irep[i]);
for (i = 0; i < irep->nirep; ++i) {
pic_irep_decref(pic, irep->u.s.irep[i].i);
}
pic_free(pic, irep->irep);
pic_free(pic, irep->u.s.irep);
pic_free(pic, irep);
}
}

196
extlib/benz/state.c
View File

@ -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);

71
extlib/benz/vm.c
View File

@ -353,7 +353,8 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv)
#if PIC_DIRECT_THREADED_VM
static const void *oplabels[] = {
&&L_OP_NOP, &&L_OP_POP, &&L_OP_PUSHUNDEF, &&L_OP_PUSHNIL, &&L_OP_PUSHTRUE,
&&L_OP_PUSHFALSE, &&L_OP_PUSHINT, &&L_OP_PUSHCHAR, &&L_OP_PUSHCONST,
&&L_OP_PUSHFALSE, &&L_OP_PUSHINT, &&L_OP_PUSHFLOAT,
&&L_OP_PUSHCHAR, &&L_OP_PUSHEOF, &&L_OP_PUSHCONST,
&&L_OP_GREF, &&L_OP_GSET, &&L_OP_LREF, &&L_OP_LSET, &&L_OP_CREF, &&L_OP_CSET,
&&L_OP_JMP, &&L_OP_JMPIF, &&L_OP_NOT, &&L_OP_CALL, &&L_OP_TAILCALL, &&L_OP_RET,
&&L_OP_LAMBDA, &&L_OP_CONS, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_NILP,
@ -378,7 +379,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv)
/* boot! */
boot[0].insn = OP_CALL;
boot[0].u.i = argc + 1;
boot[0].a = argc + 1;
boot[1].insn = OP_STOP;
pic->ip = boot;
@ -407,23 +408,31 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv)
NEXT;
}
CASE(OP_PUSHINT) {
PUSH(pic_int_value(c.u.i));
PUSH(pic_int_value(pic->ci->irep->u.s.ints[c.a]));
NEXT;
}
CASE(OP_PUSHFLOAT) {
PUSH(pic_float_value(pic->ci->irep->u.s.nums[c.a]));
NEXT;
}
CASE(OP_PUSHCHAR) {
PUSH(pic_char_value(c.u.i));
PUSH(pic_char_value(pic->ci->irep->u.s.ints[c.a]));
NEXT;
}
CASE(OP_PUSHEOF) {
PUSH(pic_eof_object());
NEXT;
}
CASE(OP_PUSHCONST) {
PUSH(pic->ci->irep->pool[c.u.i]);
PUSH(pic_obj_value(pic->ci->irep->pool[c.a]));
NEXT;
}
CASE(OP_GREF) {
PUSH(vm_gref(pic, pic_box_ptr(pic->ci->irep->pool[c.u.i]), NULL)); /* FIXME */
PUSH(vm_gref(pic, (struct pic_box *)(pic->ci->irep->pool[c.a]), NULL)); /* FIXME */
NEXT;
}
CASE(OP_GSET) {
vm_gset(pic_box_ptr(pic->ci->irep->pool[c.u.i]), POP());
vm_gset((struct pic_box *)(pic->ci->irep->pool[c.a]), POP());
PUSH(pic_undef_value());
NEXT;
}
@ -432,12 +441,12 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv)
struct pic_irep *irep = ci->irep;
if (ci->cxt != NULL && ci->cxt->regs == ci->cxt->storage) {
if (c.u.i >= irep->argc + irep->localc) {
PUSH(ci->cxt->regs[c.u.i - (ci->regs - ci->fp)]);
if (c.a >= irep->argc + irep->localc) {
PUSH(ci->cxt->regs[c.a - (ci->regs - ci->fp)]);
NEXT;
}
}
PUSH(pic->ci->fp[c.u.i]);
PUSH(pic->ci->fp[c.a]);
NEXT;
}
CASE(OP_LSET) {
@ -445,41 +454,41 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv)
struct pic_irep *irep = ci->irep;
if (ci->cxt != NULL && ci->cxt->regs == ci->cxt->storage) {
if (c.u.i >= irep->argc + irep->localc) {
ci->cxt->regs[c.u.i - (ci->regs - ci->fp)] = POP();
if (c.a >= irep->argc + irep->localc) {
ci->cxt->regs[c.a - (ci->regs - ci->fp)] = POP();
PUSH(pic_undef_value());
NEXT;
}
}
pic->ci->fp[c.u.i] = POP();
pic->ci->fp[c.a] = POP();
PUSH(pic_undef_value());
NEXT;
}
CASE(OP_CREF) {
int depth = c.u.r.depth;
int depth = c.a;
struct pic_context *cxt;
cxt = pic->ci->up;
while (--depth) {
cxt = cxt->up;
}
PUSH(cxt->regs[c.u.r.idx]);
PUSH(cxt->regs[c.b]);
NEXT;
}
CASE(OP_CSET) {
int depth = c.u.r.depth;
int depth = c.a;
struct pic_context *cxt;
cxt = pic->ci->up;
while (--depth) {
cxt = cxt->up;
}
cxt->regs[c.u.r.idx] = POP();
cxt->regs[c.b] = POP();
PUSH(pic_undef_value());
NEXT;
}
CASE(OP_JMP) {
pic->ip += c.u.i;
pic->ip += c.a;
JUMP;
}
CASE(OP_JMPIF) {
@ -487,7 +496,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv)
v = POP();
if (! pic_false_p(v)) {
pic->ip += c.u.i;
pic->ip += c.a;
JUMP;
}
NEXT;
@ -496,13 +505,13 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv)
pic_value x, v;
pic_callinfo *ci;
if (c.u.i == -1) {
if (c.a == -1) {
pic->sp += pic->ci[1].retc - 1;
c.u.i = pic->ci[1].retc + 1;
c.a = pic->ci[1].retc + 1;
}
L_CALL:
x = pic->sp[-c.u.i];
x = pic->sp[-c.a];
if (! pic_proc_p(x)) {
pic_errorf(pic, "invalid application: ~s", x);
}
@ -515,10 +524,10 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv)
}
ci = PUSHCI();
ci->argc = c.u.i;
ci->argc = c.a;
ci->retc = 1;
ci->ip = pic->ip;
ci->fp = pic->sp - c.u.i;
ci->fp = pic->sp - c.a;
ci->irep = NULL;
ci->cxt = NULL;
if (pic_proc_func_p(proc)) {
@ -567,7 +576,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv)
ci->regc = irep->capturec;
ci->regs = ci->fp + irep->argc + irep->localc;
pic->ip = irep->code;
pic->ip = irep->u.s.code;
pic_gc_arena_restore(pic, ai);
JUMP;
}
@ -581,12 +590,12 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv)
vm_tear_off(pic->ci);
}
if (c.u.i == -1) {
if (c.a == -1) {
pic->sp += pic->ci[1].retc - 1;
c.u.i = pic->ci[1].retc + 1;
c.a = pic->ci[1].retc + 1;
}
argc = c.u.i;
argc = c.a;
argv = pic->sp - argc;
for (i = 0; i < argc; ++i) {
pic->ci->fp[i] = argv[i];
@ -629,16 +638,14 @@ pic_apply(pic_state *pic, struct pic_proc *proc, int argc, pic_value *argv)
vm_push_cxt(pic);
}
proc = pic_make_proc_irep(pic, pic->ci->irep->irep[c.u.i], pic->ci->cxt);
proc = pic_make_proc_irep(pic, pic->ci->irep->u.s.irep[c.a].i, pic->ci->cxt);
PUSH(pic_obj_value(proc));
pic_gc_arena_restore(pic, ai);
NEXT;
}
#define check_condition(name, n) do { \
if (! pic_eq_p(pic->p##name, pic->c##name->value)) \
goto L_CALL; \
if (c.u.i != n + 1) \
if (c.a != n + 1) \
goto L_CALL; \
} while (0)