add analyzer prototype
This commit is contained in:
Yuichi Nishiwaki
parent
0ceb9c9953
commit
ae933252c9
|
|
@ -72,7 +72,7 @@ typedef struct {
|
||||||
pic_sym sDEFINE_SYNTAX, sDEFINE_MACRO;
|
pic_sym sDEFINE_SYNTAX, sDEFINE_MACRO;
|
||||||
pic_sym sDEFINE_LIBRARY, sIMPORT, sEXPORT;
|
pic_sym sDEFINE_LIBRARY, sIMPORT, sEXPORT;
|
||||||
pic_sym sCONS, sCAR, sCDR, sNILP;
|
pic_sym sCONS, sCAR, sCDR, sNILP;
|
||||||
pic_sym sADD, sSUB, sMUL, sDIV;
|
pic_sym sADD, sSUB, sMUL, sDIV, sMINUS;
|
||||||
pic_sym sEQ, sLT, sLE, sGT, sGE;
|
pic_sym sEQ, sLT, sLE, sGT, sGE;
|
||||||
|
|
||||||
struct xhash *sym_tbl;
|
struct xhash *sym_tbl;
|
||||||
|
|
|
||||||
629
src/codegen.c
629
src/codegen.c
|
|
@ -37,6 +37,615 @@ new_irep(pic_state *pic)
|
||||||
return irep;
|
return irep;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
static bool
|
||||||
|
valid_formal(pic_state *pic, pic_value formal)
|
||||||
|
{
|
||||||
|
if (pic_symbol_p(formal))
|
||||||
|
return true;
|
||||||
|
|
||||||
|
while (pic_pair_p(formal)) {
|
||||||
|
if (! pic_symbol_p(pic_car(pic, formal))) {
|
||||||
|
return false;
|
||||||
|
}
|
||||||
|
formal = pic_cdr(pic, formal);
|
||||||
|
}
|
||||||
|
if (pic_nil_p(formal))
|
||||||
|
return true;
|
||||||
|
if (pic_symbol_p(formal))
|
||||||
|
return true;
|
||||||
|
|
||||||
|
return false;
|
||||||
|
}
|
||||||
|
|
||||||
|
typedef struct analyze_scope {
|
||||||
|
bool varg;
|
||||||
|
/* rest args variable is counted by localc */
|
||||||
|
size_t argc, localc;
|
||||||
|
/* local variables are 1-indexed, 0 is reserved for the callee */
|
||||||
|
struct xhash *local_tbl;
|
||||||
|
/* if local var i is captured, then dirty_flags[i] == 1 */
|
||||||
|
int *dirty_flags;
|
||||||
|
|
||||||
|
struct analyze_scope *up;
|
||||||
|
} analyze_scope;
|
||||||
|
|
||||||
|
static analyze_scope *
|
||||||
|
global_scope(pic_state *pic)
|
||||||
|
{
|
||||||
|
analyze_scope *scope;
|
||||||
|
|
||||||
|
scope = (analyze_scope *)pic_alloc(pic, sizeof(analyze_scope));
|
||||||
|
scope->up = NULL;
|
||||||
|
scope->local_tbl = pic->global_tbl;
|
||||||
|
scope->argc = -1;
|
||||||
|
scope->localc = -1;
|
||||||
|
scope->varg = false;
|
||||||
|
scope->dirty_flags = NULL;
|
||||||
|
|
||||||
|
return scope;
|
||||||
|
}
|
||||||
|
|
||||||
|
typedef struct analyze_state {
|
||||||
|
pic_state *pic;
|
||||||
|
analyze_scope *scope;
|
||||||
|
pic_sym rCONS, rCAR, rCDR, rNILP;
|
||||||
|
pic_sym rADD, rSUB, rMUL, rDIV;
|
||||||
|
pic_sym rEQ, rLT, rLE, rGT, rGE;
|
||||||
|
pic_sym sCALL, sTAILCALL;
|
||||||
|
pic_sym sGREF, sLREF, sCREF;
|
||||||
|
pic_sym sGSET, sLSET, sCSET;
|
||||||
|
} analyze_state;
|
||||||
|
|
||||||
|
#define register_symbol(pic, state, slot, name) do { \
|
||||||
|
state->slot = pic_intern_cstr(pic, name); \
|
||||||
|
} while (0)
|
||||||
|
|
||||||
|
#define register_renamed_symbol(pic, state, slot, lib, name) do { \
|
||||||
|
struct xh_entry *e; \
|
||||||
|
if (! (e = xh_get(lib->senv->tbl, name))) \
|
||||||
|
pic_error(pic, "internal error! native VM procedure not found"); \
|
||||||
|
state->slot = e->val; \
|
||||||
|
} while (0)
|
||||||
|
|
||||||
|
static analyze_state *
|
||||||
|
new_analyze_state(pic_state *pic)
|
||||||
|
{
|
||||||
|
analyze_state *state;
|
||||||
|
struct pic_lib *stdlib;
|
||||||
|
|
||||||
|
state = (analyze_state *)pic_alloc(pic, sizeof(analyze_state));
|
||||||
|
state->pic = pic;
|
||||||
|
state->scope = global_scope(pic);
|
||||||
|
|
||||||
|
stdlib = pic_find_library(pic, pic_parse(pic, "(scheme base)"));
|
||||||
|
|
||||||
|
/* native VM procedures */
|
||||||
|
register_renamed_symbol(pic, state, rCONS, stdlib, "cons");
|
||||||
|
register_renamed_symbol(pic, state, rCAR, stdlib, "car");
|
||||||
|
register_renamed_symbol(pic, state, rCDR, stdlib, "cdr");
|
||||||
|
register_renamed_symbol(pic, state, rNILP, stdlib, "null?");
|
||||||
|
register_renamed_symbol(pic, state, rADD, stdlib, "+");
|
||||||
|
register_renamed_symbol(pic, state, rSUB, stdlib, "-");
|
||||||
|
register_renamed_symbol(pic, state, rMUL, stdlib, "*");
|
||||||
|
register_renamed_symbol(pic, state, rDIV, stdlib, "/");
|
||||||
|
register_renamed_symbol(pic, state, rEQ, stdlib, "=");
|
||||||
|
register_renamed_symbol(pic, state, rLT, stdlib, "<");
|
||||||
|
register_renamed_symbol(pic, state, rLE, stdlib, "<=");
|
||||||
|
register_renamed_symbol(pic, state, rGT, stdlib, ">");
|
||||||
|
register_renamed_symbol(pic, state, rGE, stdlib, ">=");
|
||||||
|
|
||||||
|
register_symbol(pic, state, sCALL, "call");
|
||||||
|
register_symbol(pic, state, sTAILCALL, "tail-call");
|
||||||
|
register_symbol(pic, state, sGREF, "gref");
|
||||||
|
register_symbol(pic, state, sLREF, "lref");
|
||||||
|
register_symbol(pic, state, sCREF, "cref");
|
||||||
|
register_symbol(pic, state, sGREF, "gref");
|
||||||
|
register_symbol(pic, state, sLREF, "lref");
|
||||||
|
register_symbol(pic, state, sCREF, "cref");
|
||||||
|
|
||||||
|
return state;
|
||||||
|
}
|
||||||
|
|
||||||
|
static void
|
||||||
|
push_scope(analyze_state *state, pic_value args)
|
||||||
|
{
|
||||||
|
pic_state *pic = state->pic;
|
||||||
|
analyze_scope *scope;
|
||||||
|
struct xhash *x;
|
||||||
|
pic_value v;
|
||||||
|
int i, l;
|
||||||
|
|
||||||
|
scope = (analyze_scope *)pic_alloc(pic, sizeof(analyze_scope));
|
||||||
|
scope->up = state->scope;
|
||||||
|
scope->local_tbl = x = xh_new();
|
||||||
|
scope->varg = false;
|
||||||
|
|
||||||
|
i = 1; l = 0;
|
||||||
|
for (v = args; pic_pair_p(v); v = pic_cdr(pic, v)) {
|
||||||
|
pic_value sym;
|
||||||
|
|
||||||
|
sym = pic_car(pic, v);
|
||||||
|
xh_put(x, pic_symbol_name(pic, pic_sym(sym)), i++);
|
||||||
|
}
|
||||||
|
if (pic_nil_p(v)) {
|
||||||
|
/* pass */
|
||||||
|
}
|
||||||
|
else if (pic_symbol_p(v)) {
|
||||||
|
scope->varg = true;
|
||||||
|
xh_put(x, pic_symbol_name(pic, pic_sym(v)), i + l++);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
pic_error(pic, "logic flaw");
|
||||||
|
}
|
||||||
|
scope->argc = i;
|
||||||
|
scope->localc = l;
|
||||||
|
scope->dirty_flags = (int *)pic_calloc(pic, i + l, sizeof(int));
|
||||||
|
}
|
||||||
|
|
||||||
|
static void
|
||||||
|
pop_scope(analyze_state *state)
|
||||||
|
{
|
||||||
|
analyze_scope *scope;
|
||||||
|
|
||||||
|
scope = state->scope;
|
||||||
|
xh_destroy(scope->local_tbl);
|
||||||
|
pic_free(state->pic, scope->dirty_flags);
|
||||||
|
|
||||||
|
scope = scope->up;
|
||||||
|
pic_free(state->pic, state->scope);
|
||||||
|
state->scope = scope;
|
||||||
|
}
|
||||||
|
|
||||||
|
static analyze_scope *
|
||||||
|
lookup_var(analyze_state *state, const char *key, int *depth, int *idx)
|
||||||
|
{
|
||||||
|
analyze_scope *scope = state->scope;
|
||||||
|
struct xh_entry *e;
|
||||||
|
int d = 0;
|
||||||
|
|
||||||
|
enter:
|
||||||
|
|
||||||
|
e = xh_get(scope->local_tbl, key);
|
||||||
|
if (e && e->val >= 0) {
|
||||||
|
if (scope->up == NULL) { /* global */
|
||||||
|
*depth = -1;
|
||||||
|
}
|
||||||
|
else { /* non-global */
|
||||||
|
*depth = d;
|
||||||
|
}
|
||||||
|
*idx = e->val;
|
||||||
|
return scope;
|
||||||
|
}
|
||||||
|
if (scope->up) {
|
||||||
|
scope = scope->up;
|
||||||
|
++d;
|
||||||
|
goto enter;
|
||||||
|
}
|
||||||
|
return NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
static int
|
||||||
|
define_global_var(pic_state *pic, const char *name)
|
||||||
|
{
|
||||||
|
struct xh_entry *e;
|
||||||
|
|
||||||
|
if ((e = xh_get(pic->global_tbl, name))) {
|
||||||
|
pic_warn(pic, "redefining global");
|
||||||
|
return e->val;
|
||||||
|
}
|
||||||
|
e = xh_put(pic->global_tbl, name, pic->glen++);
|
||||||
|
if (pic->glen >= pic->gcapa) {
|
||||||
|
pic_error(pic, "global table overflow");
|
||||||
|
}
|
||||||
|
return e->val;
|
||||||
|
}
|
||||||
|
|
||||||
|
static int
|
||||||
|
define_local_var(pic_state *pic, const char *name, analyze_scope *scope)
|
||||||
|
{
|
||||||
|
struct xh_entry *e;
|
||||||
|
|
||||||
|
e = xh_put(scope->local_tbl, name, scope->argc + scope->localc++);
|
||||||
|
scope->dirty_flags = (int *)pic_realloc(pic, scope->dirty_flags, (scope->argc + scope->localc) * sizeof(int));
|
||||||
|
scope->dirty_flags[e->val] = 0;
|
||||||
|
return e->val;
|
||||||
|
}
|
||||||
|
|
||||||
|
static bool
|
||||||
|
is_global_scope(analyze_scope *scope)
|
||||||
|
{
|
||||||
|
return scope->up == NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
static pic_value
|
||||||
|
new_gref(analyze_state *state, int idx)
|
||||||
|
{
|
||||||
|
return pic_list(state->pic, 2, pic_symbol_value(state->sGREF), pic_int_value(idx));
|
||||||
|
}
|
||||||
|
|
||||||
|
static pic_value
|
||||||
|
new_gset(analyze_state *state, int idx, pic_value value)
|
||||||
|
{
|
||||||
|
return pic_list(state->pic, 3, pic_symbol_value(state->sGSET), pic_int_value(idx), value);
|
||||||
|
}
|
||||||
|
|
||||||
|
static pic_value
|
||||||
|
new_cref(analyze_state *state, int depth, int idx)
|
||||||
|
{
|
||||||
|
return pic_list(state->pic, 3, pic_symbol_value(state->sCREF), pic_int_value(depth), pic_int_value(idx));
|
||||||
|
}
|
||||||
|
|
||||||
|
static pic_value
|
||||||
|
new_cset(analyze_state *state, int depth, int idx, pic_value value)
|
||||||
|
{
|
||||||
|
return pic_list(state->pic, 4, pic_symbol_value(state->sCSET), pic_int_value(depth), pic_int_value(idx), value);
|
||||||
|
}
|
||||||
|
|
||||||
|
static pic_value analyze_call(analyze_state *, pic_value, bool);
|
||||||
|
static pic_value analyze_lambda(analyze_state *, pic_value);
|
||||||
|
|
||||||
|
static pic_value
|
||||||
|
analyze(analyze_state *state, pic_value obj, bool tailpos)
|
||||||
|
{
|
||||||
|
pic_state *pic = state->pic;
|
||||||
|
analyze_scope *scope = state->scope;
|
||||||
|
|
||||||
|
switch (pic_type(obj)) {
|
||||||
|
case PIC_TT_SYMBOL: {
|
||||||
|
analyze_scope *s;
|
||||||
|
int depth = -1, idx = -1;
|
||||||
|
const char *name = pic_symbol_name(pic, pic_sym(obj));
|
||||||
|
|
||||||
|
s = lookup_var(state, name, &depth, &idx);
|
||||||
|
if (! s) {
|
||||||
|
#if DEBUG
|
||||||
|
printf("%s\n", name);
|
||||||
|
#endif
|
||||||
|
pic_error(pic, "symbol: unbound variable");
|
||||||
|
}
|
||||||
|
|
||||||
|
switch (depth) {
|
||||||
|
case -1: /* global */
|
||||||
|
return new_gref(state, idx);
|
||||||
|
default: /* nonlocal */
|
||||||
|
s->dirty_flags[idx] = 1;
|
||||||
|
/* at this stage, lref and cref are not distinguished */
|
||||||
|
FALLTHROUGH;
|
||||||
|
case 0: /* local */
|
||||||
|
return new_cref(state, depth, idx);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
case PIC_TT_PAIR: {
|
||||||
|
pic_value proc;
|
||||||
|
|
||||||
|
if (! pic_list_p(pic, obj)) {
|
||||||
|
pic_error(pic, "invalid expression given");
|
||||||
|
}
|
||||||
|
|
||||||
|
proc = pic_car(pic, obj);
|
||||||
|
if (pic_symbol_p(proc)) {
|
||||||
|
pic_sym sym = pic_sym(proc);
|
||||||
|
|
||||||
|
if (sym == pic->sDEFINE) {
|
||||||
|
int idx;
|
||||||
|
pic_value var, val;
|
||||||
|
|
||||||
|
if (pic_length(pic, obj) < 2) {
|
||||||
|
pic_error(pic, "syntax error");
|
||||||
|
}
|
||||||
|
|
||||||
|
var = pic_car(pic, pic_cdr(pic, obj));
|
||||||
|
if (pic_pair_p(var)) {
|
||||||
|
val = pic_cons(pic, pic_symbol_value(pic->sLAMBDA),
|
||||||
|
pic_cons(pic, pic_cdr(pic, var),
|
||||||
|
pic_cdr(pic, pic_cdr(pic, obj))));
|
||||||
|
var = pic_car(pic, var);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
if (pic_length(pic, obj) != 3) {
|
||||||
|
pic_error(pic, "syntax error");
|
||||||
|
}
|
||||||
|
val = pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj)));
|
||||||
|
}
|
||||||
|
if (! pic_symbol_p(var)) {
|
||||||
|
pic_error(pic, "syntax error");
|
||||||
|
}
|
||||||
|
|
||||||
|
if (is_global_scope(scope)) {
|
||||||
|
idx = define_global_var(pic, pic_symbol_name(pic, pic_sym(var)));
|
||||||
|
return new_gset(state, idx, analyze(state, val, false));
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
idx = define_local_var(pic, pic_symbol_name(pic, pic_sym(var)), scope);
|
||||||
|
return new_cset(state, 0, idx, analyze(state, val, false));
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else if (sym == pic->sLAMBDA) {
|
||||||
|
return analyze_lambda(state, obj);
|
||||||
|
}
|
||||||
|
else if (sym == pic->sIF) {
|
||||||
|
pic_value if_true, if_false;
|
||||||
|
|
||||||
|
if_false = pic_none_value();
|
||||||
|
switch (pic_length(pic, obj)) {
|
||||||
|
default:
|
||||||
|
pic_error(pic, "syntax error");
|
||||||
|
break;
|
||||||
|
case 4:
|
||||||
|
if_false = pic_car(pic, pic_cdr(pic, pic_cdr(pic, pic_cdr(pic, obj))));
|
||||||
|
FALLTHROUGH;
|
||||||
|
case 3:
|
||||||
|
if_true = pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj)));
|
||||||
|
}
|
||||||
|
|
||||||
|
return pic_list(pic, 4,
|
||||||
|
pic_symbol_value(pic->sIF),
|
||||||
|
analyze(state, pic_car(pic, pic_cdr(pic, obj)), false),
|
||||||
|
analyze(state, if_true, tailpos),
|
||||||
|
analyze(state, if_false, tailpos));
|
||||||
|
}
|
||||||
|
else if (sym == pic->sBEGIN) {
|
||||||
|
pic_value seq;
|
||||||
|
bool tail;
|
||||||
|
|
||||||
|
/* TODO: unwrap if the number of objects is 1 or 0 */
|
||||||
|
seq = pic_list(pic, 1, pic_symbol_value(pic->sBEGIN));
|
||||||
|
for (obj = pic_cdr(pic, obj); ! pic_nil_p(obj); obj = pic_cdr(pic, obj)) {
|
||||||
|
if (pic_nil_p(pic_cdr(pic, obj))) {
|
||||||
|
tail = tailpos;
|
||||||
|
} else {
|
||||||
|
tail = false;
|
||||||
|
}
|
||||||
|
seq = pic_cons(pic, analyze(state, pic_car(pic, obj), tail), seq);
|
||||||
|
}
|
||||||
|
return pic_reverse(pic, seq);
|
||||||
|
}
|
||||||
|
else if (sym == pic->sSETBANG) {
|
||||||
|
analyze_scope *s;
|
||||||
|
pic_value var, val;
|
||||||
|
int depth = -1, idx = -1;
|
||||||
|
|
||||||
|
if (pic_length(pic, obj) != 3) {
|
||||||
|
pic_error(pic, "syntax error");
|
||||||
|
}
|
||||||
|
|
||||||
|
var = pic_car(pic, pic_cdr(pic, obj));
|
||||||
|
if (! pic_symbol_p(var)) {
|
||||||
|
pic_error(pic, "syntax error");
|
||||||
|
}
|
||||||
|
|
||||||
|
s = lookup_var(state, pic_symbol_name(pic, pic_sym(var)), &depth, &idx);
|
||||||
|
if (! s) {
|
||||||
|
pic_error(pic, "unbound variable");
|
||||||
|
}
|
||||||
|
|
||||||
|
val = pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj)));
|
||||||
|
|
||||||
|
switch (depth) {
|
||||||
|
case -1: /* global */
|
||||||
|
return new_gset(state, idx, val);
|
||||||
|
default: /* nonlocal */
|
||||||
|
s->dirty_flags[idx] = 1;
|
||||||
|
/* at this stage, lset and cset are not distinguished */
|
||||||
|
FALLTHROUGH;
|
||||||
|
case 0: /* local */
|
||||||
|
return new_cset(state, depth, idx, val);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else if (sym == pic->sQUOTE) {
|
||||||
|
if (pic_length(pic, obj) != 2) {
|
||||||
|
pic_error(pic, "syntax error");
|
||||||
|
}
|
||||||
|
return obj; /* TODO: quote only if necessary */
|
||||||
|
}
|
||||||
|
|
||||||
|
#define ARGC_ASSERT(n) do { \
|
||||||
|
if (pic_length(pic, obj) != (n) + 1) { \
|
||||||
|
pic_error(pic, "wrong number of arguments"); \
|
||||||
|
} \
|
||||||
|
} while (0)
|
||||||
|
|
||||||
|
#define CONSTRUCT_OP1(op) \
|
||||||
|
pic_list(pic, 2, \
|
||||||
|
pic_symbol_value(op), \
|
||||||
|
analyze(state, pic_car(pic, pic_cdr(pic, obj)), false))
|
||||||
|
|
||||||
|
#define CONSTRUCT_OP2(op) \
|
||||||
|
pic_list(pic, 3, \
|
||||||
|
pic_symbol_value(op), \
|
||||||
|
analyze(state, pic_car(pic, pic_cdr(pic, obj)), false), \
|
||||||
|
analyze(state, pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj))), false))
|
||||||
|
|
||||||
|
else if (sym == state->rCONS) {
|
||||||
|
ARGC_ASSERT(2);
|
||||||
|
return CONSTRUCT_OP2(pic->sCONS);
|
||||||
|
}
|
||||||
|
else if (sym == state->rCAR) {
|
||||||
|
ARGC_ASSERT(1);
|
||||||
|
return CONSTRUCT_OP1(pic->sCAR);
|
||||||
|
}
|
||||||
|
else if (sym == state->rCDR) {
|
||||||
|
ARGC_ASSERT(1);
|
||||||
|
return CONSTRUCT_OP1(pic->sCDR);
|
||||||
|
}
|
||||||
|
else if (sym == state->rNILP) {
|
||||||
|
ARGC_ASSERT(1);
|
||||||
|
return CONSTRUCT_OP1(pic->sNILP);
|
||||||
|
}
|
||||||
|
|
||||||
|
#define ARGC_ASSERT_GE(n) do { \
|
||||||
|
if (pic_length(pic, obj) < (n) + 1) { \
|
||||||
|
pic_error(pic, "wrong number of arguments"); \
|
||||||
|
} \
|
||||||
|
} while (0)
|
||||||
|
|
||||||
|
#define FOLD_ARGS(sym) do { \
|
||||||
|
obj = analyze(state, pic_car(pic, args), false); \
|
||||||
|
for (args = pic_cdr(pic, obj); ! pic_nil_p(args); args = pic_cdr(pic, args)) { \
|
||||||
|
obj = pic_list(pic, 3, pic_symbol_value(sym), obj, \
|
||||||
|
analyze(state, pic_car(pic, args), false)); \
|
||||||
|
} \
|
||||||
|
} while (0)
|
||||||
|
|
||||||
|
else if (sym == state->rADD) {
|
||||||
|
pic_value args;
|
||||||
|
|
||||||
|
ARGC_ASSERT_GE(0);
|
||||||
|
switch (pic_length(pic, obj)) {
|
||||||
|
case 1:
|
||||||
|
return pic_int_value(0);
|
||||||
|
case 2:
|
||||||
|
return analyze(state, pic_car(pic, pic_cdr(pic, obj)), tailpos);
|
||||||
|
default:
|
||||||
|
args = pic_cdr(pic, obj);
|
||||||
|
FOLD_ARGS(pic->sADD);
|
||||||
|
return obj;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else if (sym == state->rSUB) {
|
||||||
|
pic_value args;
|
||||||
|
|
||||||
|
ARGC_ASSERT_GE(1);
|
||||||
|
switch (pic_length(pic, obj)) {
|
||||||
|
case 2:
|
||||||
|
return pic_list(pic, 2, pic_symbol_value(pic->sMINUS),
|
||||||
|
analyze(state, pic_car(pic, pic_cdr(pic, obj)), false));
|
||||||
|
default:
|
||||||
|
args = pic_cdr(pic, obj);
|
||||||
|
FOLD_ARGS(pic->sSUB);
|
||||||
|
return obj;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else if (sym == state->rMUL) {
|
||||||
|
pic_value args;
|
||||||
|
|
||||||
|
ARGC_ASSERT_GE(0);
|
||||||
|
switch (pic_length(pic, obj)) {
|
||||||
|
case 1:
|
||||||
|
return pic_int_value(1);
|
||||||
|
case 2:
|
||||||
|
return analyze(state, pic_car(pic, pic_cdr(pic, obj)), tailpos);
|
||||||
|
default:
|
||||||
|
args = pic_cdr(pic, obj);
|
||||||
|
FOLD_ARGS(pic->sMUL);
|
||||||
|
return obj;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else if (sym == state->rDIV) {
|
||||||
|
pic_value args;
|
||||||
|
|
||||||
|
ARGC_ASSERT_GE(1);
|
||||||
|
switch (pic_length(pic, obj)) {
|
||||||
|
case 2:
|
||||||
|
args = pic_cdr(pic, obj);
|
||||||
|
obj = pic_list(pic, 3, proc, pic_float_value(1), pic_car(pic, args));
|
||||||
|
return analyze(state, obj, tailpos);
|
||||||
|
default:
|
||||||
|
args = pic_cdr(pic, obj);
|
||||||
|
FOLD_ARGS(pic->sDIV);
|
||||||
|
return obj;
|
||||||
|
}
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
else if (sym == state->rEQ) {
|
||||||
|
ARGC_ASSERT(2);
|
||||||
|
return CONSTRUCT_OP2(pic->sEQ);
|
||||||
|
}
|
||||||
|
else if (sym == state->rLT) {
|
||||||
|
ARGC_ASSERT(2);
|
||||||
|
return CONSTRUCT_OP2(pic->sLT);
|
||||||
|
}
|
||||||
|
else if (sym == state->rLE) {
|
||||||
|
ARGC_ASSERT(2);
|
||||||
|
return CONSTRUCT_OP2(pic->sLE);
|
||||||
|
}
|
||||||
|
else if (sym == state->rGT) {
|
||||||
|
ARGC_ASSERT(2);
|
||||||
|
return CONSTRUCT_OP2(pic->sGT);
|
||||||
|
}
|
||||||
|
else if (sym == state->rGE) {
|
||||||
|
ARGC_ASSERT(2);
|
||||||
|
return CONSTRUCT_OP2(pic->sGE);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
return analyze_call(state, obj, tailpos);
|
||||||
|
}
|
||||||
|
case PIC_TT_BOOL:
|
||||||
|
case PIC_TT_FLOAT:
|
||||||
|
case PIC_TT_INT:
|
||||||
|
case PIC_TT_NIL:
|
||||||
|
case PIC_TT_CHAR: {
|
||||||
|
return obj;
|
||||||
|
}
|
||||||
|
case PIC_TT_STRING:
|
||||||
|
case PIC_TT_VECTOR:
|
||||||
|
case PIC_TT_BLOB: {
|
||||||
|
return pic_list(pic, 2, pic_symbol_value(pic->sQUOTE), obj);
|
||||||
|
}
|
||||||
|
case PIC_TT_CONT:
|
||||||
|
case PIC_TT_ENV:
|
||||||
|
case PIC_TT_PROC:
|
||||||
|
case PIC_TT_UNDEF:
|
||||||
|
case PIC_TT_EOF:
|
||||||
|
case PIC_TT_PORT:
|
||||||
|
case PIC_TT_ERROR:
|
||||||
|
case PIC_TT_SENV:
|
||||||
|
case PIC_TT_SYNTAX:
|
||||||
|
case PIC_TT_SC:
|
||||||
|
case PIC_TT_LIB:
|
||||||
|
case PIC_TT_VAR:
|
||||||
|
case PIC_TT_IREP:
|
||||||
|
pic_error(pic, "invalid expression given");
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
static pic_value
|
||||||
|
analyze_call(analyze_state *state, pic_value obj, bool tailpos)
|
||||||
|
{
|
||||||
|
pic_state *pic = state->pic;
|
||||||
|
pic_value seq;
|
||||||
|
pic_sym call;
|
||||||
|
|
||||||
|
if (tailpos) {
|
||||||
|
call = state->sCALL;
|
||||||
|
} else {
|
||||||
|
call = state->sTAILCALL;
|
||||||
|
}
|
||||||
|
seq = pic_list(pic, 1, pic_symbol_value(call));
|
||||||
|
for (; ! pic_nil_p(seq); obj = pic_cdr(pic, obj)) {
|
||||||
|
seq = pic_cons(pic, analyze(state, pic_car(pic, obj), false), seq);
|
||||||
|
}
|
||||||
|
return pic_reverse(pic, seq);
|
||||||
|
}
|
||||||
|
|
||||||
|
static pic_value
|
||||||
|
analyze_lambda(analyze_state *state, pic_value obj)
|
||||||
|
{
|
||||||
|
pic_state *pic = state->pic;
|
||||||
|
pic_value args, body;
|
||||||
|
|
||||||
|
if (pic_length(pic, obj) < 2) {
|
||||||
|
pic_error(pic, "syntax error");
|
||||||
|
}
|
||||||
|
|
||||||
|
/* formal arguments */
|
||||||
|
args = pic_car(pic, pic_cdr(pic, obj));
|
||||||
|
if (! valid_formal(pic, args)) {
|
||||||
|
pic_error(pic, "syntax error");
|
||||||
|
}
|
||||||
|
|
||||||
|
/* analyze body in inner environment */
|
||||||
|
push_scope(state, args);
|
||||||
|
{
|
||||||
|
body = pic_cdr(pic, pic_cdr(pic, obj));
|
||||||
|
body = pic_cons(pic, pic_symbol_value(pic->sBEGIN), body);
|
||||||
|
body = analyze(state, body, true);
|
||||||
|
}
|
||||||
|
pop_scope(state);
|
||||||
|
|
||||||
|
return pic_list(pic, 3, pic_symbol_value(pic->sLAMBDA), args, body);
|
||||||
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* scope object
|
* scope object
|
||||||
*/
|
*/
|
||||||
|
|
@ -770,26 +1379,6 @@ codegen_call(codegen_state *state, pic_value obj, bool tailpos)
|
||||||
scope->clen++;
|
scope->clen++;
|
||||||
}
|
}
|
||||||
|
|
||||||
static bool
|
|
||||||
valid_formal(pic_state *pic, pic_value formal)
|
|
||||||
{
|
|
||||||
if (pic_symbol_p(formal))
|
|
||||||
return true;
|
|
||||||
|
|
||||||
while (pic_pair_p(formal)) {
|
|
||||||
if (! pic_symbol_p(pic_car(pic, formal))) {
|
|
||||||
return false;
|
|
||||||
}
|
|
||||||
formal = pic_cdr(pic, formal);
|
|
||||||
}
|
|
||||||
if (pic_nil_p(formal))
|
|
||||||
return true;
|
|
||||||
if (pic_symbol_p(formal))
|
|
||||||
return true;
|
|
||||||
|
|
||||||
return false;
|
|
||||||
}
|
|
||||||
|
|
||||||
static void
|
static void
|
||||||
lift_cv(pic_state *pic, struct pic_irep *irep, int d)
|
lift_cv(pic_state *pic, struct pic_irep *irep, int d)
|
||||||
{
|
{
|
||||||
|
|
|
||||||
|
|
@ -106,6 +106,7 @@ pic_open(int argc, char *argv[], char **envp)
|
||||||
register_core_symbol(pic, sSUB, "-");
|
register_core_symbol(pic, sSUB, "-");
|
||||||
register_core_symbol(pic, sMUL, "*");
|
register_core_symbol(pic, sMUL, "*");
|
||||||
register_core_symbol(pic, sDIV, "/");
|
register_core_symbol(pic, sDIV, "/");
|
||||||
|
register_core_symbol(pic, sMINUS, "minus");
|
||||||
register_core_symbol(pic, sEQ, "=");
|
register_core_symbol(pic, sEQ, "=");
|
||||||
register_core_symbol(pic, sLT, "<");
|
register_core_symbol(pic, sLT, "<");
|
||||||
register_core_symbol(pic, sLE, "<=");
|
register_core_symbol(pic, sLE, "<=");
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue