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

Merge branch 'refactor-analyzer4'

This commit is contained in:
Yuichi Nishiwaki 2015-07-02 05:55:03 +09:00
parent bda9a2f231 f9df81f046
commit 98005c4832
7 changed files with 307 additions and 669 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

722
extlib/benz/codegen.c
View File

@ -121,7 +121,7 @@ expand_list(pic_state *pic, pic_value obj, struct pic_env *env, pic_value deferr
static pic_value
expand_defer(pic_state *pic, pic_value expr, pic_value deferred)
{
pic_value skel = pic_list1(pic, pic_invalid_value()); /* (#<invalid>) */
pic_value skel = pic_cons(pic, pic_invalid_value(), pic_invalid_value());
pic_set_car(pic, deferred, pic_acons(pic, expr, skel, pic_car(pic, deferred)));
@ -328,7 +328,7 @@ analyzer_scope_init(pic_state *pic, analyze_scope *scope, pic_value formal, anal
scope->up = up;
scope->depth = up ? up->depth + 1 : 0;
scope->defer = pic_nil_value();
scope->defer = pic_list1(pic, pic_nil_value());
}
static void
@ -378,7 +378,7 @@ define_var(pic_state *pic, analyze_scope *scope, pic_sym *sym)
kh_put(a, &scope->locals, sym, &ret);
}
static pic_value analyze(pic_state *, analyze_scope *, pic_value, bool);
static pic_value analyze(pic_state *, analyze_scope *, pic_value);
static pic_value analyze_lambda(pic_state *, analyze_scope *, pic_value);
static pic_value
@ -400,12 +400,9 @@ analyze_var(pic_state *pic, analyze_scope *scope, pic_sym *sym)
static pic_value
analyze_defer(pic_state *pic, analyze_scope *scope, pic_value form)
{
pic_sym *sNOWHERE = pic_intern_cstr(pic, "<<nowhere>>");
pic_value skel;
pic_value skel = pic_cons(pic, pic_invalid_value(), pic_invalid_value());
skel = pic_list2(pic, pic_obj_value(pic->sGREF), pic_obj_value(sNOWHERE));
pic_push(pic, pic_cons(pic, skel, form), scope->defer);
pic_set_car(pic, scope->defer, pic_acons(pic, form, skel, pic_car(pic, scope->defer)));
return skel;
}
@ -413,20 +410,20 @@ analyze_defer(pic_state *pic, analyze_scope *scope, pic_value form)
static void
analyze_deferred(pic_state *pic, analyze_scope *scope)
{
pic_value defer, it, skel, form, val;
pic_value defer, val, src, dst, it;
scope->defer = pic_car(pic, scope->defer);
pic_for_each (defer, pic_reverse(pic, scope->defer), it) {
skel = pic_car(pic, defer);
form = pic_cdr(pic, defer);
src = pic_car(pic, defer);
dst = pic_cdr(pic, defer);
val = analyze_lambda(pic, scope, form);
val = analyze_lambda(pic, scope, src);
/* copy */
pic_pair_ptr(skel)->car = pic_car(pic, val);
pic_pair_ptr(skel)->cdr = pic_cdr(pic, val);
pic_set_car(pic, dst, pic_car(pic, val));
pic_set_cdr(pic, dst, pic_cdr(pic, val));
}
scope->defer = pic_nil_value();
}
static pic_value
@ -444,7 +441,7 @@ analyze_lambda(pic_state *pic, analyze_scope *up, pic_value form)
analyzer_scope_init(pic, scope, formals, up);
/* analyze body */
body = analyze(pic, scope, body, true);
body = analyze(pic, scope, body);
analyze_deferred(pic, scope);
args = pic_make_vec(pic, kh_size(&scope->args));
@ -472,243 +469,37 @@ analyze_lambda(pic_state *pic, analyze_scope *up, pic_value form)
analyzer_scope_destroy(pic, scope);
return pic_list6(pic, pic_obj_value(pic->sLAMBDA), rest, pic_obj_value(args), pic_obj_value(locals), pic_obj_value(captures), body);
return pic_list6(pic, pic_obj_value(pic->uLAMBDA), rest, pic_obj_value(args), pic_obj_value(locals), pic_obj_value(captures), body);
}
static pic_value
analyze_list(pic_state *pic, analyze_scope *scope, pic_value obj)
{
pic_value seq = pic_nil_value(), val, it;
pic_for_each (val, obj, it) {
pic_push(pic, analyze(pic, scope, val), seq);
}
return pic_reverse(pic, seq);
}
static pic_value
analyze_define(pic_state *pic, analyze_scope *scope, pic_value obj)
{
pic_value var, val;
define_var(pic, scope, pic_sym_ptr(pic_list_ref(pic, obj, 1)));
var = analyze(pic, scope, pic_list_ref(pic, obj, 1), false);
val = analyze(pic, scope, pic_list_ref(pic, obj, 2), false);
return pic_list3(pic, pic_obj_value(pic->sSETBANG), var, val);
return pic_cons(pic, pic_car(pic, obj), analyze_list(pic, scope, pic_cdr(pic, obj)));
}
static pic_value
analyze_if(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos)
analyze_call(pic_state *pic, analyze_scope *scope, pic_value obj)
{
pic_value cond, if_true, if_false;
if_true = pic_list_ref(pic, obj, 2);
if_false = pic_list_ref(pic, obj, 3);
cond = analyze(pic, scope, pic_list_ref(pic, obj, 1), false);
if_true = analyze(pic, scope, if_true, tailpos);
if_false = analyze(pic, scope, if_false, tailpos);
return pic_list4(pic, pic_obj_value(pic->sIF), cond, if_true, if_false);
return pic_cons(pic, pic_obj_value(pic->sCALL), analyze_list(pic, scope, obj));
}
static pic_value
analyze_begin(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos)
{
pic_value beg1, beg2;
beg1 = pic_list_ref(pic, obj, 1);
beg2 = pic_list_ref(pic, obj, 2);
beg1 = analyze(pic, scope, beg1, false);
beg2 = analyze(pic, scope, beg2, tailpos);
return pic_list3(pic, pic_obj_value(pic->sBEGIN), beg1, beg2);
}
static pic_value
analyze_set(pic_state *pic, analyze_scope *scope, pic_value obj)
{
pic_value var, val;
var = pic_list_ref(pic, obj, 1);
val = pic_list_ref(pic, obj, 2);
var = analyze(pic, scope, var, false);
val = analyze(pic, scope, val, false);
return pic_list3(pic, pic_obj_value(pic->sSETBANG), var, val);
}
static pic_value
analyze_quote(pic_state *pic, pic_value obj)
{
return pic_list2(pic, pic_obj_value(pic->sQUOTE), pic_list_ref(pic, obj, 1));
}
#define ARGC_ASSERT_GE(n, name) do { \
if (pic_length(pic, obj) < (n) + 1) { \
pic_errorf(pic, \
#name ": wrong number of arguments (%d for at least %d)", \
pic_length(pic, obj) - 1, \
n); \
} \
} while (0)
#define FOLD_ARGS(sym) do { \
obj = analyze(pic, scope, pic_car(pic, args), false); \
pic_for_each (arg, pic_cdr(pic, args), it) { \
obj = pic_list3(pic, pic_obj_value(sym), obj, \
analyze(pic, scope, arg, false)); \
} \
} while (0)
static pic_value
analyze_add(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos)
{
pic_value args, arg, it;
ARGC_ASSERT_GE(0, "+");
switch (pic_length(pic, obj)) {
case 1:
return pic_list2(pic, pic_obj_value(pic->sQUOTE), pic_int_value(0));
case 2:
return analyze(pic, scope, pic_car(pic, pic_cdr(pic, obj)), tailpos);
default:
args = pic_cdr(pic, obj);
FOLD_ARGS(pic->sADD);
return obj;
}
}
static pic_value
analyze_sub(pic_state *pic, analyze_scope *scope, pic_value obj)
{
pic_value args, arg, it;
ARGC_ASSERT_GE(1, "-");
switch (pic_length(pic, obj)) {
case 2:
return pic_list2(pic, pic_obj_value(pic->sMINUS),
analyze(pic, scope, pic_car(pic, pic_cdr(pic, obj)), false));
default:
args = pic_cdr(pic, obj);
FOLD_ARGS(pic->sSUB);
return obj;
}
}
static pic_value
analyze_mul(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos)
{
pic_value args, arg, it;
ARGC_ASSERT_GE(0, "*");
switch (pic_length(pic, obj)) {
case 1:
return pic_list2(pic, pic_obj_value(pic->sQUOTE), pic_int_value(1));
case 2:
return analyze(pic, scope, pic_car(pic, pic_cdr(pic, obj)), tailpos);
default:
args = pic_cdr(pic, obj);
FOLD_ARGS(pic->sMUL);
return obj;
}
}
static pic_value
analyze_div(pic_state *pic, analyze_scope *scope, pic_value obj)
{
pic_value args, arg, it;
ARGC_ASSERT_GE(1, "/");
switch (pic_length(pic, obj)) {
case 2:
args = pic_cdr(pic, obj);
#if PIC_ENABLE_FLOAT
obj = pic_list3(pic, pic_car(pic, obj), pic_float_value(1), pic_car(pic, args));
#else
obj = pic_list3(pic, pic_car(pic, obj), pic_int_value(1), pic_car(pic, args));
#endif
return analyze(pic, scope, obj, false);
default:
args = pic_cdr(pic, obj);
FOLD_ARGS(pic->sDIV);
return obj;
}
}
static pic_value
analyze_call(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos)
{
pic_value seq, elt, it;
pic_sym *call;
if (! tailpos) {
call = pic->sCALL;
} else {
call = pic->sTAILCALL;
}
seq = pic_list1(pic, pic_obj_value(call));
pic_for_each (elt, obj, it) {
seq = pic_cons(pic, analyze(pic, scope, elt, false), seq);
}
return pic_reverse(pic, seq);
}
static pic_value
analyze_values(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos)
{
pic_value v, seq, it;
if (! tailpos) {
return analyze_call(pic, scope, obj, false);
}
seq = pic_list1(pic, pic_obj_value(pic->sRETURN));
pic_for_each (v, pic_cdr(pic, obj), it) {
seq = pic_cons(pic, analyze(pic, scope, v, false), seq);
}
return pic_reverse(pic, seq);
}
static pic_value
analyze_call_with_values(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos)
{
pic_value prod, cnsm;
pic_sym *call;
if (pic_length(pic, obj) != 3) {
pic_errorf(pic, "call-with-values: wrong number of arguments (%d for 2)", pic_length(pic, obj) - 1);
}
if (! tailpos) {
call = pic->sCALL_WITH_VALUES;
} else {
call = pic->sTAILCALL_WITH_VALUES;
}
prod = analyze(pic, scope, pic_list_ref(pic, obj, 1), false);
cnsm = analyze(pic, scope, pic_list_ref(pic, obj, 2), false);
return pic_list3(pic, pic_obj_value(call), prod, cnsm);
}
#define ARGC_ASSERT(n, name) do { \
if (pic_length(pic, obj) != (n) + 1) { \
pic_errorf(pic, #name ": wrong number of arguments (%d for %d)", \
pic_length(pic, obj) - 1, n); \
} \
} while (0)
#define ARGC_ASSERT_WITH_FALLBACK(n) do { \
if (pic_length(pic, obj) != (n) + 1) { \
goto fallback; \
} \
} while (0)
#define CONSTRUCT_OP1(op) \
pic_list2(pic, \
pic_obj_value(op), \
analyze(pic, scope, pic_list_ref(pic, obj, 1), false))
#define CONSTRUCT_OP2(op) \
pic_list3(pic, \
pic_obj_value(op), \
analyze(pic, scope, pic_list_ref(pic, obj, 1), false), \
analyze(pic, scope, pic_list_ref(pic, obj, 2), false))
static pic_value
analyze_node(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos)
analyze_node(pic_state *pic, analyze_scope *scope, pic_value obj)
{
switch (pic_type(obj)) {
case PIC_TT_SYMBOL: {
@ -731,116 +522,31 @@ analyze_node(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos)
else if (sym == pic->uLAMBDA) {
return analyze_defer(pic, scope, obj);
}
else if (sym == pic->uIF) {
return analyze_if(pic, scope, obj, tailpos);
}
else if (sym == pic->uBEGIN) {
return analyze_begin(pic, scope, obj, tailpos);
}
else if (sym == pic->uSETBANG) {
return analyze_set(pic, scope, obj);
}
else if (sym == pic->uQUOTE) {
return analyze_quote(pic, obj);
return obj;
}
else if (sym == pic->uCONS) {
ARGC_ASSERT(2, "cons");
return CONSTRUCT_OP2(pic->sCONS);
}
else if (sym == pic->uCAR) {
ARGC_ASSERT(1, "car");
return CONSTRUCT_OP1(pic->sCAR);
}
else if (sym == pic->uCDR) {
ARGC_ASSERT(1, "cdr");
return CONSTRUCT_OP1(pic->sCDR);
}
else if (sym == pic->uNILP) {
ARGC_ASSERT(1, "nil?");
return CONSTRUCT_OP1(pic->sNILP);
}
else if (sym == pic->uSYMBOLP) {
ARGC_ASSERT(1, "symbol?");
return CONSTRUCT_OP1(pic->sSYMBOLP);
}
else if (sym == pic->uPAIRP) {
ARGC_ASSERT(1, "pair?");
return CONSTRUCT_OP1(pic->sPAIRP);
}
else if (sym == pic->uADD) {
return analyze_add(pic, scope, obj, tailpos);
}
else if (sym == pic->uSUB) {
return analyze_sub(pic, scope, obj);
}
else if (sym == pic->uMUL) {
return analyze_mul(pic, scope, obj, tailpos);
}
else if (sym == pic->uDIV) {
return analyze_div(pic, scope, obj);
}
else if (sym == pic->uEQ) {
ARGC_ASSERT_WITH_FALLBACK(2);
return CONSTRUCT_OP2(pic->sEQ);
}
else if (sym == pic->uLT) {
ARGC_ASSERT_WITH_FALLBACK(2);
return CONSTRUCT_OP2(pic->sLT);
}
else if (sym == pic->uLE) {
ARGC_ASSERT_WITH_FALLBACK(2);
return CONSTRUCT_OP2(pic->sLE);
}
else if (sym == pic->uGT) {
ARGC_ASSERT_WITH_FALLBACK(2);
return CONSTRUCT_OP2(pic->sGT);
}
else if (sym == pic->uGE) {
ARGC_ASSERT_WITH_FALLBACK(2);
return CONSTRUCT_OP2(pic->sGE);
}
else if (sym == pic->uNOT) {
ARGC_ASSERT(1, "not");
return CONSTRUCT_OP1(pic->sNOT);
}
else if (sym == pic->uVALUES) {
return analyze_values(pic, scope, obj, tailpos);
}
else if (sym == pic->uCALL_WITH_VALUES) {
return analyze_call_with_values(pic, scope, obj, tailpos);
else if (sym == pic->uBEGIN || sym == pic->uSETBANG || sym == pic->uIF) {
return pic_cons(pic, pic_car(pic, obj), analyze_list(pic, scope, pic_cdr(pic, obj)));
}
}
fallback:
return analyze_call(pic, scope, obj, tailpos);
return analyze_call(pic, scope, obj);
}
default:
return pic_list2(pic, pic_obj_value(pic->sQUOTE), obj);
return pic_list2(pic, pic_obj_value(pic->uQUOTE), obj);
}
}
static pic_value
analyze(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos)
analyze(pic_state *pic, analyze_scope *scope, pic_value obj)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value res;
pic_sym *tag;
res = analyze_node(pic, scope, obj, tailpos);
tag = pic_sym_ptr(pic_car(pic, res));
if (tailpos) {
if (tag == pic->sIF || tag == pic->sBEGIN || tag == pic->sTAILCALL || tag == pic->sTAILCALL_WITH_VALUES || tag == pic->sRETURN) {
/* pass through */
}
else {
res = pic_list2(pic, pic_obj_value(pic->sRETURN), res);
}
}
res = analyze_node(pic, scope, obj);
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, res);
pic_gc_protect(pic, scope->defer);
return res;
}
@ -851,7 +557,7 @@ pic_analyze(pic_state *pic, pic_value obj)
analyzer_scope_init(pic, scope, pic_nil_value(), NULL);
obj = analyze(pic, scope, obj, true);
obj = analyze(pic, scope, obj);
analyze_deferred(pic, scope);
@ -973,6 +679,8 @@ codegen_context_destroy(pic_state *pic, codegen_context *cxt)
cxt->clen++; \
} while (0) \
#define emit_ret(pic, cxt, tailpos) if (tailpos) emit_i(pic, cxt, OP_RET, 1)
static void
create_activation(pic_state *pic, codegen_context *cxt)
{
@ -1054,75 +762,57 @@ index_symbol(pic_state *pic, codegen_context *cxt, pic_sym *sym)
return i;
}
static void codegen(pic_state *, codegen_context *, pic_value);
static struct pic_irep *
codegen_lambda(pic_state *pic, codegen_context *up, pic_value obj)
{
codegen_context c, *cxt = &c;
pic_value rest_opt, body;
pic_sym *rest = NULL;
pic_vec *args, *locals, *captures;
rest_opt = pic_list_ref(pic, obj, 1);
if (pic_sym_p(rest_opt)) {
rest = pic_sym_ptr(rest_opt);
}
args = pic_vec_ptr(pic_list_ref(pic, obj, 2));
locals = pic_vec_ptr(pic_list_ref(pic, obj, 3));
captures = pic_vec_ptr(pic_list_ref(pic, obj, 4));
body = pic_list_ref(pic, obj, 5);
/* inner environment */
codegen_context_init(pic, cxt, up, rest, args, locals, captures);
{
/* body */
codegen(pic, cxt, body);
}
return codegen_context_destroy(pic, cxt);
}
static void codegen(pic_state *, codegen_context *, pic_value, bool);
static void
codegen(pic_state *pic, codegen_context *cxt, pic_value obj)
codegen_ref(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
{
pic_sym *sym;
sym = pic_sym_ptr(pic_car(pic, obj));
if (sym == pic->sGREF) {
emit_i(pic, cxt, OP_GREF, index_symbol(pic, cxt, pic_sym_ptr(pic_list_ref(pic, obj, 1))));
return;
} else if (sym == pic->sCREF) {
emit_ret(pic, cxt, tailpos);
}
else if (sym == pic->sCREF) {
pic_sym *name;
int depth;
depth = pic_int(pic_list_ref(pic, obj, 1));
name = pic_sym_ptr(pic_list_ref(pic, obj, 2));
emit_r(pic, cxt, OP_CREF, depth, index_capture(cxt, name, depth));
return;
} else if (sym == pic->sLREF) {
emit_ret(pic, cxt, tailpos);
}
else if (sym == pic->sLREF) {
pic_sym *name;
int i;
name = pic_sym_ptr(pic_list_ref(pic, obj, 1));
if ((i = index_capture(cxt, name, 0)) != -1) {
emit_i(pic, cxt, OP_LREF, i + (int)cxt->args->len + (int)cxt->locals->len + 1);
return;
}
emit_ret(pic, cxt, tailpos);
} else {
emit_i(pic, cxt, OP_LREF, index_local(cxt, name));
return;
} else if (sym == pic->sSETBANG) {
emit_ret(pic, cxt, tailpos);
}
}
}
static void
codegen_set(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
{
pic_value var, val;
pic_sym *type;
val = pic_list_ref(pic, obj, 2);
codegen(pic, cxt, val);
codegen(pic, cxt, val, false);
var = pic_list_ref(pic, obj, 1);
type = pic_sym_ptr(pic_list_ref(pic, var, 0));
if (type == pic->sGREF) {
emit_i(pic, cxt, OP_GSET, index_symbol(pic, cxt, pic_sym_ptr(pic_list_ref(pic, var, 1))));
emit_n(pic, cxt, OP_PUSHUNDEF);
return;
emit_ret(pic, cxt, tailpos);
}
else if (type == pic->sCREF) {
pic_sym *name;
@ -1132,7 +822,7 @@ codegen(pic_state *pic, codegen_context *cxt, pic_value obj)
name = pic_sym_ptr(pic_list_ref(pic, var, 2));
emit_r(pic, cxt, OP_CSET, depth, index_capture(cxt, name, depth));
emit_n(pic, cxt, OP_PUSHUNDEF);
return;
emit_ret(pic, cxt, tailpos);
}
else if (type == pic->sLREF) {
pic_sym *name;
@ -1142,34 +832,58 @@ codegen(pic_state *pic, codegen_context *cxt, pic_value obj)
if ((i = index_capture(cxt, name, 0)) != -1) {
emit_i(pic, cxt, OP_LSET, i + (int)cxt->args->len + (int)cxt->locals->len + 1);
emit_n(pic, cxt, OP_PUSHUNDEF);
return;
}
emit_ret(pic, cxt, tailpos);
} else {
emit_i(pic, cxt, OP_LSET, index_local(cxt, name));
emit_n(pic, cxt, OP_PUSHUNDEF);
return;
emit_ret(pic, cxt, tailpos);
}
}
else if (sym == pic->sLAMBDA) {
int k;
}
static void
codegen_lambda(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
{
codegen_context c, *inner_cxt = &c;
pic_value rest_opt, body;
pic_sym *rest = NULL;
pic_vec *args, *locals, *captures;
check_irep_size(pic, cxt);
k = (int)cxt->ilen++;
emit_i(pic, cxt, OP_LAMBDA, k);
cxt->irep[k] = codegen_lambda(pic, cxt, obj);
return;
/* extract arguments */
rest_opt = pic_list_ref(pic, obj, 1);
if (pic_sym_p(rest_opt)) {
rest = pic_sym_ptr(rest_opt);
}
else if (sym == pic->sIF) {
args = pic_vec_ptr(pic_list_ref(pic, obj, 2));
locals = pic_vec_ptr(pic_list_ref(pic, obj, 3));
captures = pic_vec_ptr(pic_list_ref(pic, obj, 4));
body = pic_list_ref(pic, obj, 5);
/* 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);
/* emit OP_LAMBDA */
emit_i(pic, cxt, OP_LAMBDA, cxt->ilen++);
emit_ret(pic, cxt, tailpos);
}
static void
codegen_if(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
{
int s, t;
codegen(pic, cxt, pic_list_ref(pic, obj, 1));
codegen(pic, cxt, pic_list_ref(pic, obj, 1), false);
s = (int)cxt->clen;
emit_n(pic, cxt, OP_JMPIF);
/* if false branch */
codegen(pic, cxt, pic_list_ref(pic, obj, 3));
codegen(pic, cxt, pic_list_ref(pic, obj, 3), tailpos);
t = (int)cxt->clen;
@ -1178,167 +892,143 @@ codegen(pic_state *pic, codegen_context *cxt, pic_value obj)
cxt->code[s].u.i = (int)cxt->clen - s;
/* if true branch */
codegen(pic, cxt, pic_list_ref(pic, obj, 2));
codegen(pic, cxt, pic_list_ref(pic, obj, 2), tailpos);
cxt->code[t].u.i = (int)cxt->clen - t;
return;
}
else if (sym == pic->sBEGIN) {
codegen(pic, cxt, pic_list_ref(pic, obj, 1));
}
static void
codegen_begin(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
{
codegen(pic, cxt, pic_list_ref(pic, obj, 1), false);
emit_n(pic, cxt, OP_POP);
codegen(pic, cxt, pic_list_ref(pic, obj, 2));
return;
}
else if (sym == pic->sQUOTE) {
codegen(pic, cxt, pic_list_ref(pic, obj, 2), tailpos);
}
static void
codegen_quote(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
{
int pidx;
obj = pic_list_ref(pic, obj, 1);
switch (pic_type(obj)) {
case PIC_TT_BOOL:
emit_n(pic, cxt, (pic_true_p(obj) ? OP_PUSHTRUE : OP_PUSHFALSE));
return;
emit_ret(pic, cxt, tailpos);
break;
case PIC_TT_INT:
emit_i(pic, cxt, OP_PUSHINT, pic_int(obj));
return;
emit_ret(pic, cxt, tailpos);
break;
case PIC_TT_NIL:
emit_n(pic, cxt, OP_PUSHNIL);
return;
emit_ret(pic, cxt, tailpos);
break;
case PIC_TT_CHAR:
emit_c(pic, cxt, OP_PUSHCHAR, pic_char(obj));
return;
emit_ret(pic, cxt, tailpos);
break;
default:
check_pool_size(pic, cxt);
pidx = (int)cxt->plen++;
cxt->pool[pidx] = obj;
emit_i(pic, cxt, OP_PUSHCONST, pidx);
return;
emit_ret(pic, cxt, tailpos);
break;
}
}
static bool
codegen_call_vm(pic_state *pic, codegen_context *cxt, pic_value proc, size_t len, bool tailpos)
{
pic_sym *sym;
if (pic_sym_ptr(pic_list_ref(pic, proc, 0)) == pic->sGREF) {
#define VM(uid, op) \
if (sym == uid) { \
emit_n(pic, cxt, op); \
emit_ret(pic, cxt, tailpos); \
return true; \
}
/*
TODO:
- call-with-values, values, >, >=
- more than 2 arguments for add, sub, mul, ...
*/
sym = pic_sym_ptr(pic_list_ref(pic, proc, 1));
if (len == 3) { /* binary operator */
VM(pic->uCONS, OP_CONS)
VM(pic->uADD, OP_ADD)
VM(pic->uSUB, OP_SUB)
VM(pic->uMUL, OP_MUL)
VM(pic->uDIV, OP_DIV)
VM(pic->uEQ, OP_EQ)
VM(pic->uLT, OP_LT)
VM(pic->uLE, OP_LE)
}
if (len == 2) { /* unary operator */
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->uSUB, OP_MINUS)
VM(pic->uNOT, OP_NOT)
}
}
else if (sym == pic->sCONS) {
codegen(pic, cxt, pic_list_ref(pic, obj, 1));
codegen(pic, cxt, pic_list_ref(pic, obj, 2));
emit_n(pic, cxt, OP_CONS);
return;
}
else if (sym == pic->sCAR) {
codegen(pic, cxt, pic_list_ref(pic, obj, 1));
emit_n(pic, cxt, OP_CAR);
return;
}
else if (sym == pic->sCDR) {
codegen(pic, cxt, pic_list_ref(pic, obj, 1));
emit_n(pic, cxt, OP_CDR);
return;
}
else if (sym == pic->sNILP) {
codegen(pic, cxt, pic_list_ref(pic, obj, 1));
emit_n(pic, cxt, OP_NILP);
return;
}
else if (sym == pic->sSYMBOLP) {
codegen(pic, cxt, pic_list_ref(pic, obj, 1));
emit_n(pic, cxt, OP_SYMBOLP);
return;
}
else if (sym == pic->sPAIRP) {
codegen(pic, cxt, pic_list_ref(pic, obj, 1));
emit_n(pic, cxt, OP_PAIRP);
return;
}
else if (sym == pic->sADD) {
codegen(pic, cxt, pic_list_ref(pic, obj, 1));
codegen(pic, cxt, pic_list_ref(pic, obj, 2));
emit_n(pic, cxt, OP_ADD);
return;
}
else if (sym == pic->sSUB) {
codegen(pic, cxt, pic_list_ref(pic, obj, 1));
codegen(pic, cxt, pic_list_ref(pic, obj, 2));
emit_n(pic, cxt, OP_SUB);
return;
}
else if (sym == pic->sMUL) {
codegen(pic, cxt, pic_list_ref(pic, obj, 1));
codegen(pic, cxt, pic_list_ref(pic, obj, 2));
emit_n(pic, cxt, OP_MUL);
return;
}
else if (sym == pic->sDIV) {
codegen(pic, cxt, pic_list_ref(pic, obj, 1));
codegen(pic, cxt, pic_list_ref(pic, obj, 2));
emit_n(pic, cxt, OP_DIV);
return;
}
else if (sym == pic->sMINUS) {
codegen(pic, cxt, pic_list_ref(pic, obj, 1));
emit_n(pic, cxt, OP_MINUS);
return;
}
else if (sym == pic->sEQ) {
codegen(pic, cxt, pic_list_ref(pic, obj, 1));
codegen(pic, cxt, pic_list_ref(pic, obj, 2));
emit_n(pic, cxt, OP_EQ);
return;
}
else if (sym == pic->sLT) {
codegen(pic, cxt, pic_list_ref(pic, obj, 1));
codegen(pic, cxt, pic_list_ref(pic, obj, 2));
emit_n(pic, cxt, OP_LT);
return;
}
else if (sym == pic->sLE) {
codegen(pic, cxt, pic_list_ref(pic, obj, 1));
codegen(pic, cxt, pic_list_ref(pic, obj, 2));
emit_n(pic, cxt, OP_LE);
return;
}
else if (sym == pic->sGT) {
codegen(pic, cxt, pic_list_ref(pic, obj, 2));
codegen(pic, cxt, pic_list_ref(pic, obj, 1));
emit_n(pic, cxt, OP_LT);
return;
}
else if (sym == pic->sGE) {
codegen(pic, cxt, pic_list_ref(pic, obj, 2));
codegen(pic, cxt, pic_list_ref(pic, obj, 1));
emit_n(pic, cxt, OP_LE);
return;
}
else if (sym == pic->sNOT) {
codegen(pic, cxt, pic_list_ref(pic, obj, 1));
emit_n(pic, cxt, OP_NOT);
return;
}
else if (sym == pic->sCALL || sym == pic->sTAILCALL) {
return false;
}
static void
codegen_call(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
{
int len = (int)pic_length(pic, obj);
pic_value elt, it;
pic_for_each (elt, pic_cdr(pic, obj), it) {
codegen(pic, cxt, elt);
codegen(pic, cxt, elt, false);
}
emit_i(pic, cxt, (sym == pic->sCALL ? OP_CALL : OP_TAILCALL), len - 1);
return;
}
else if (sym == pic->sCALL_WITH_VALUES || sym == pic->sTAILCALL_WITH_VALUES) {
/* stack consumer at first */
codegen(pic, cxt, pic_list_ref(pic, obj, 2));
codegen(pic, cxt, pic_list_ref(pic, obj, 1));
/* call producer */
emit_i(pic, cxt, OP_CALL, 1);
/* call consumer */
emit_i(pic, cxt, (sym == pic->sCALL_WITH_VALUES ? OP_CALL : OP_TAILCALL), -1);
return;
}
else if (sym == pic->sRETURN) {
int len = (int)pic_length(pic, obj);
pic_value elt, it;
pic_for_each (elt, pic_cdr(pic, obj), it) {
codegen(pic, cxt, elt);
}
emit_i(pic, cxt, OP_RET, len - 1);
if (codegen_call_vm(pic, cxt, pic_list_ref(pic, obj, 1), len - 1, tailpos)) {
return;
}
emit_i(pic, cxt, (tailpos ? OP_TAILCALL : OP_CALL), len - 1);
}
static void
codegen(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
{
pic_sym *sym;
sym = pic_sym_ptr(pic_car(pic, obj));
if (sym == pic->sGREF || sym == pic->sCREF || sym == pic->sLREF) {
codegen_ref(pic, cxt, obj, tailpos);
}
else if (sym == pic->uSETBANG || sym == pic->uDEFINE) {
codegen_set(pic, cxt, obj, tailpos);
}
else if (sym == pic->uLAMBDA) {
codegen_lambda(pic, cxt, obj, tailpos);
}
else if (sym == pic->uIF) {
codegen_if(pic, cxt, obj, tailpos);
}
else if (sym == pic->uBEGIN) {
codegen_begin(pic, cxt, obj, tailpos);
}
else if (sym == pic->uQUOTE) {
codegen_quote(pic, cxt, obj, tailpos);
}
else if (sym == pic->sCALL) {
codegen_call(pic, cxt, obj, tailpos);
}
else {
pic_errorf(pic, "codegen: unknown AST type ~s", obj);
}
}
struct pic_irep *
@ -1349,7 +1039,7 @@ pic_codegen(pic_state *pic, pic_value obj)
codegen_context_init(pic, cxt, NULL, NULL, empty, empty, empty);
codegen(pic, cxt, obj);
codegen(pic, cxt, obj, true);
return codegen_context_destroy(pic, cxt);
}

24
extlib/benz/gc.c
View File

@ -521,26 +521,14 @@ gc_mark(pic_state *pic, pic_value v)
static void
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(sSYNTAX_QUOTE); M(sSYNTAX_QUASIQUOTE); M(sSYNTAX_UNQUOTE);
M(sSYNTAX_UNQUOTE_SPLICING);
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);
M(sCONS); M(sCAR); M(sCDR); M(sNILP);
M(sSYMBOLP); M(sPAIRP);
M(sADD); M(sSUB); M(sMUL); M(sDIV); M(sMINUS);
M(sEQ); M(sLT); M(sLE); M(sGT); M(sGE); M(sNOT);
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(sREAD); M(sFILE);
M(sCALL); M(sTAILCALL); M(sCALL_WITH_VALUES); M(sTAILCALL_WITH_VALUES);
M(sGREF); M(sLREF); M(sCREF); M(sRETURN);
M(sCALL); M(sGREF); M(sLREF); M(sCREF);
M(uDEFINE); M(uLAMBDA); M(uIF); M(uBEGIN); M(uQUOTE); M(uSETBANG);
M(uDEFINE_MACRO); M(uIMPORT); M(uEXPORT);
M(uDEFINE_LIBRARY);
M(uCOND_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);

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

@ -95,31 +95,16 @@ struct pic_state {
struct pic_lib *lib, *prev_lib;
pic_sym *sDEFINE, *sLAMBDA, *sIF, *sBEGIN, *sQUOTE, *sSETBANG;
pic_sym *sQUASIQUOTE, *sUNQUOTE, *sUNQUOTE_SPLICING;
pic_sym *sSYNTAX_QUOTE, *sSYNTAX_QUASIQUOTE, *sSYNTAX_UNQUOTE;
pic_sym *sSYNTAX_UNQUOTE_SPLICING;
pic_sym *sDEFINE_MACRO, *sIMPORT, *sEXPORT;
pic_sym *sDEFINE_LIBRARY;
pic_sym *sCOND_EXPAND, *sAND, *sOR, *sELSE, *sLIBRARY;
pic_sym *sONLY, *sRENAME, *sPREFIX, *sEXCEPT;
pic_sym *sCONS, *sCAR, *sCDR, *sNILP;
pic_sym *sSYMBOLP, *sPAIRP;
pic_sym *sADD, *sSUB, *sMUL, *sDIV, *sMINUS;
pic_sym *sEQ, *sLT, *sLE, *sGT, *sGE, *sNOT;
pic_sym *sQUOTE, *sQUASIQUOTE, *sUNQUOTE, *sUNQUOTE_SPLICING;
pic_sym *sSYNTAX_QUOTE, *sSYNTAX_QUASIQUOTE, *sSYNTAX_UNQUOTE, *sSYNTAX_UNQUOTE_SPLICING;
pic_sym *sDEFINE_LIBRARY, *sIMPORT, *sEXPORT, *sCOND_EXPAND;
pic_sym *sGREF, *sCREF, *sLREF, *sCALL;
pic_sym *sREAD, *sFILE;
pic_sym *sGREF, *sCREF, *sLREF;
pic_sym *sCALL, *sTAILCALL, *sRETURN;
pic_sym *sCALL_WITH_VALUES, *sTAILCALL_WITH_VALUES;
pic_sym *uDEFINE, *uLAMBDA, *uIF, *uBEGIN, *uQUOTE, *uSETBANG;
pic_sym *uDEFINE_MACRO, *uIMPORT, *uEXPORT;
pic_sym *uDEFINE_LIBRARY;
pic_sym *uCOND_EXPAND;
pic_sym *uCONS, *uCAR, *uCDR, *uNILP;
pic_sym *uSYMBOLP, *uPAIRP;
pic_sym *uADD, *uSUB, *uMUL, *uDIV;
pic_sym *uEQ, *uLT, *uLE, *uGT, *uGE, *uNOT;
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_sym *uVALUES, *uCALL_WITH_VALUES;
struct pic_lib *PICRIN_BASE;

2
extlib/benz/include/picrin/config.h
View File

@ -128,7 +128,7 @@
#endif
#ifndef PIC_STACK_SIZE
# define PIC_STACK_SIZE 1024
# define PIC_STACK_SIZE 2048
#endif
#ifndef PIC_RESCUE_SIZE

35
extlib/benz/state.c
View File

@ -284,11 +284,6 @@ pic_open(pic_allocf allocf, void *userdata)
#define S(slot,name) pic->slot = pic_intern_cstr(pic, name)
S(sDEFINE, "define");
S(sLAMBDA, "lambda");
S(sIF, "if");
S(sBEGIN, "begin");
S(sSETBANG, "set!");
S(sQUOTE, "quote");
S(sQUASIQUOTE, "quasiquote");
S(sUNQUOTE, "unquote");
@ -297,46 +292,16 @@ pic_open(pic_allocf allocf, void *userdata)
S(sSYNTAX_QUASIQUOTE, "syntax-quasiquote");
S(sSYNTAX_UNQUOTE, "syntax-unquote");
S(sSYNTAX_UNQUOTE_SPLICING, "syntax-unquote-splicing");
S(sDEFINE_MACRO, "define-macro");
S(sIMPORT, "import");
S(sEXPORT, "export");
S(sDEFINE_LIBRARY, "define-library");
S(sCOND_EXPAND, "cond-expand");
S(sAND, "and");
S(sOR, "or");
S(sELSE, "else");
S(sLIBRARY, "library");
S(sONLY, "only");
S(sRENAME, "rename");
S(sPREFIX, "prefix");
S(sEXCEPT, "except");
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(sMINUS, "minus");
S(sEQ, "=");
S(sLT, "<");
S(sLE, "<=");
S(sGT, ">");
S(sGE, ">=");
S(sNOT, "not");
S(sREAD, "read");
S(sFILE, "file");
S(sCALL, "call");
S(sTAILCALL, "tail-call");
S(sGREF, "gref");
S(sLREF, "lref");
S(sCREF, "cref");
S(sRETURN, "return");
S(sCALL_WITH_VALUES, "call-with-values");
S(sTAILCALL_WITH_VALUES, "tailcall-with-values");
pic_gc_arena_restore(pic, ai);

2
extlib/benz/symbol.c
View File

@ -32,7 +32,7 @@ pic_intern_cstr(pic_state *pic, const char *cstr)
strcpy(copy, cstr);
kh_key(h, it) = copy;
kh_val(h, it) = pic->sDEFINE; /* insert dummy */
kh_val(h, it) = pic->sQUOTE; /* insert dummy */
sym = (pic_sym *)pic_obj_alloc(pic, sizeof(pic_sym), PIC_TT_SYMBOL);
sym->cstr = copy;

14
extlib/benz/vm.c
View File

@ -713,6 +713,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
pic_value v;
v = pic_false_p(POP()) ? pic_true_value() : pic_false_value();
(void)POP();
PUSH(v);
NEXT;
}
@ -876,6 +877,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
pic_value a, b;
pic_gc_protect(pic, b = POP());
pic_gc_protect(pic, a = POP());
(void)POP();
PUSH(pic_cons(pic, a, b));
pic_gc_arena_restore(pic, ai);
NEXT;
@ -883,32 +885,35 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
CASE(OP_CAR) {
pic_value p;
p = POP();
(void)POP();
PUSH(pic_car(pic, p));
NEXT;
}
CASE(OP_CDR) {
pic_value p;
p = POP();
(void)POP();
PUSH(pic_cdr(pic, p));
NEXT;
}
CASE(OP_NILP) {
pic_value p;
p = POP();
(void)POP();
PUSH(pic_bool_value(pic_nil_p(p)));
NEXT;
}
CASE(OP_SYMBOLP) {
pic_value p;
p = POP();
(void)POP();
PUSH(pic_bool_value(pic_sym_p(p)));
NEXT;
}
CASE(OP_PAIRP) {
pic_value p;
p = POP();
(void)POP();
PUSH(pic_bool_value(pic_pair_p(p)));
NEXT;
}
@ -918,6 +923,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
pic_value a, b; \
b = POP(); \
a = POP(); \
(void)POP(); \
if (pic_int_p(a) && pic_int_p(b)) { \
double f = (double)pic_int(a) op (double)pic_int(b); \
if (INT_MIN <= f && f <= INT_MAX && (guard)) { \
@ -947,6 +953,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
pic_value a, b; \
b = POP(); \
a = POP(); \
(void)POP(); \
if (pic_int_p(a) && pic_int_p(b)) { \
PUSH(pic_int_value(pic_int(a) op pic_int(b))); \
} \
@ -971,6 +978,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
CASE(OP_MINUS) {
pic_value n;
n = POP();
(void)POP();
if (pic_int_p(n)) {
PUSH(pic_int_value(-pic_int(n)));
}
@ -990,6 +998,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
pic_value a, b; \
b = POP(); \
a = POP(); \
(void)POP(); \
if (pic_int_p(a) && pic_int_p(b)) { \
PUSH(pic_bool_value(pic_int(a) op pic_int(b))); \
} \
@ -1013,6 +1022,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
pic_value a, b; \
b = POP(); \
a = POP(); \
(void)POP(); \
if (pic_int_p(a) && pic_int_p(b)) { \
PUSH(pic_bool_value(pic_int(a) op pic_int(b))); \
} \