core: mes: Prepare for M2-Planet.
* src/mes.c (cal): Refactor to use if instead of switch. (eval_apply): Likewise.
This commit is contained in:
Jan Nieuwenhuizen
parent
1e787637d8
commit
bc094d0e1f
705
src/mes.c
705
src/mes.c
|
|
@ -56,26 +56,49 @@ SCM r3 = 0;
|
|||
SCM g_macros = 1;
|
||||
SCM g_ports = 1;
|
||||
|
||||
|
||||
#if __M2_PLANET__
|
||||
CONSTANT TCHAR 0
|
||||
CONSTANT TCLOSURE 1
|
||||
CONSTANT TCONTINUATION 2
|
||||
CONSTANT TFUNCTION 3
|
||||
CONSTANT TKEYWORD 4
|
||||
CONSTANT TMACRO 5
|
||||
CONSTANT TNUMBER 6
|
||||
CONSTANT TPAIR 7
|
||||
CONSTANT TPORT 8
|
||||
CONSTANT TREF 9
|
||||
CONSTANT TSPECIAL 10
|
||||
CONSTANT TSTRING 11
|
||||
CONSTANT TSYMBOL 12
|
||||
CONSTANT TVALUES 13
|
||||
CONSTANT TVARIABLE 14
|
||||
CONSTANT TVECTOR 15
|
||||
CONSTANT TBROKEN_HEART 16
|
||||
#else // !__M2_PLANET__
|
||||
enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TPORT, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
|
||||
#endif // !__M2_PLANET__
|
||||
|
||||
#if !_POSIX_SOURCE
|
||||
typedef SCM (*function0_t) (void);
|
||||
typedef SCM (*function1_t) (SCM);
|
||||
typedef SCM (*function2_t) (SCM, SCM);
|
||||
typedef SCM (*function3_t) (SCM, SCM, SCM);
|
||||
typedef SCM (*functionn_t) (SCM);
|
||||
#if !POSIX
|
||||
struct scm {
|
||||
enum type_t type;
|
||||
SCM car;
|
||||
SCM cdr;
|
||||
};
|
||||
struct function {
|
||||
long (*function) (void);
|
||||
#if __M2_PLANET__
|
||||
FUNCTION function;
|
||||
#else // !__M2_PLANET__
|
||||
SCM (*function) (SCM);
|
||||
#endif // !__M2_PLANET__
|
||||
long arity;
|
||||
char *name;
|
||||
};
|
||||
#else
|
||||
typedef SCM (*function0_t) (void);
|
||||
typedef SCM (*function1_t) (SCM);
|
||||
typedef SCM (*function2_t) (SCM, SCM);
|
||||
typedef SCM (*function3_t) (SCM, SCM, SCM);
|
||||
typedef SCM (*functionn_t) (SCM);
|
||||
struct function {
|
||||
union {
|
||||
function0_t function0;
|
||||
|
|
@ -688,30 +711,74 @@ pairlis (SCM x, SCM y, SCM a)
|
|||
SCM
|
||||
call (SCM fn, SCM x)
|
||||
{
|
||||
if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1)
|
||||
#if __M2_PLANET__
|
||||
struct function *f = FUNCTION (fn);
|
||||
#else
|
||||
struct function *f = &FUNCTION (fn);
|
||||
#endif
|
||||
int arity = f->arity;
|
||||
if ((arity > 0 || arity == -1)
|
||||
&& x != cell_nil && TYPE (CAR (x)) == TVALUES)
|
||||
x = cons (CADAR (x), CDR (x));
|
||||
if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
|
||||
if ((arity > 1 || arity == -1)
|
||||
&& x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES)
|
||||
x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
|
||||
switch (FUNCTION (fn).arity)
|
||||
{
|
||||
#if __MESC__ || !_POSIX_SOURCE
|
||||
case 0: return (FUNCTION (fn).function) ();
|
||||
case 1: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (CAR (x));
|
||||
case 2: return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x));
|
||||
case 3: return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x), CAR (CDDR (x)));
|
||||
case -1: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);
|
||||
default: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);
|
||||
#else
|
||||
case 0: return FUNCTION (fn).function0 ();
|
||||
case 1: return FUNCTION (fn).function1 (CAR (x));
|
||||
case 2: return FUNCTION (fn).function2 (CAR (x), CADR (x));
|
||||
case 3: return FUNCTION (fn).function3 (CAR (x), CADR (x), CAR (CDDR (x)));
|
||||
case -1: return FUNCTION (fn).functionn (x);
|
||||
#endif
|
||||
}
|
||||
|
||||
#if __M2_PLANET__
|
||||
FUNCTION fp = f->function;
|
||||
if (arity == 0)
|
||||
return fp ();
|
||||
else if (arity == 1)
|
||||
return fp (CAR (x));
|
||||
else if (arity == 2)
|
||||
return fp (CAR (x), CADR (x));
|
||||
else if (arity == 3)
|
||||
return fp (CAR (x), CADR (x), CAR (CDDR (x)));
|
||||
else if (arity == -1)
|
||||
return fp (x);
|
||||
#elif !POSIX
|
||||
if (arity == 0)
|
||||
{
|
||||
//function0_t fp = f->function;
|
||||
SCM (*fp) (void) = f->function;
|
||||
return fp ();
|
||||
}
|
||||
else if (arity == 1)
|
||||
{
|
||||
//function1_t fp = f->function;
|
||||
SCM (*fp) (SCM) = f->function;
|
||||
return fp (CAR (x));
|
||||
}
|
||||
else if (arity == 2)
|
||||
{
|
||||
//function2_t fp = f->function;
|
||||
SCM (*fp) (SCM, SCM) = f->function;
|
||||
return fp (CAR (x), CADR (x));
|
||||
}
|
||||
else if (arity == 3)
|
||||
{
|
||||
//function3_t fp = f->function;
|
||||
SCM (*fp) (SCM, SCM, SCM) = f->function;
|
||||
return fp (CAR (x), CADR (x), CAR (CDDR (x)));
|
||||
}
|
||||
else if (arity == -1)
|
||||
{
|
||||
//functionn_t fp = f->function;
|
||||
SCM (*fp) (SCM) = f->function;
|
||||
return fp (x);
|
||||
}
|
||||
#else
|
||||
if (arity == 0)
|
||||
return FUNCTION (fn).function0 ();
|
||||
else if (arity == 1)
|
||||
return FUNCTION (fn).function1 (CAR (x));
|
||||
else if (arity == 2)
|
||||
return FUNCTION (fn).function2 (CAR (x), CADR (x));
|
||||
else if (arity == 3)
|
||||
return FUNCTION (fn).function3 (CAR (x), CADR (x), CAR (CDDR (x)));
|
||||
else if (arity == -1)
|
||||
return FUNCTION (fn).functionn (x);
|
||||
#endif //! (__M2_PLANET__ || !POSIX)
|
||||
return cell_unspecified;
|
||||
}
|
||||
|
||||
|
|
@ -720,29 +787,25 @@ assq (SCM x, SCM a)
|
|||
{
|
||||
if (TYPE (a) != TPAIR)
|
||||
return cell_f;
|
||||
switch (TYPE (x))
|
||||
{
|
||||
case TCHAR:
|
||||
case TNUMBER:
|
||||
int t = TYPE (x);
|
||||
if (t == TCHAR
|
||||
|| t == TNUMBER)
|
||||
{
|
||||
SCM v = VALUE (x);
|
||||
while (a != cell_nil && v != VALUE (CAAR (a)))
|
||||
a = CDR (a);
|
||||
break;
|
||||
}
|
||||
case TKEYWORD:
|
||||
else if (t == TKEYWORD)
|
||||
{
|
||||
SCM v = STRING (x);
|
||||
while (a != cell_nil && v != STRING (CAAR (a)))
|
||||
a = CDR (a);
|
||||
break;
|
||||
}
|
||||
// case TSYMBOL:
|
||||
// case TSPECIAL:
|
||||
default:
|
||||
while (a != cell_nil && x != CAAR (a))
|
||||
a = CDR (a);
|
||||
}
|
||||
// else if (t == TSYMBOL)
|
||||
// else if (t == TSPECIAL)
|
||||
else
|
||||
while (a != cell_nil && x != CAAR (a))
|
||||
a = CDR (a);
|
||||
return a != cell_nil ? CAR (a) : cell_f;
|
||||
}
|
||||
|
||||
|
|
@ -965,47 +1028,47 @@ eval_apply ()
|
|||
SCM x;
|
||||
int global_p;
|
||||
int macro_p;
|
||||
int t;
|
||||
int c;
|
||||
|
||||
eval_apply:
|
||||
switch (r3)
|
||||
{
|
||||
case cell_vm_evlis: goto evlis;
|
||||
case cell_vm_evlis2: goto evlis2;
|
||||
case cell_vm_evlis3: goto evlis3;
|
||||
case cell_vm_apply: goto apply;
|
||||
case cell_vm_apply2: goto apply2;
|
||||
case cell_vm_eval: goto eval;
|
||||
case cell_vm_eval_pmatch_car: goto eval_pmatch_car;
|
||||
case cell_vm_eval_pmatch_cdr: goto eval_pmatch_cdr;
|
||||
case cell_vm_eval_define: goto eval_define;
|
||||
case cell_vm_eval_set_x: goto eval_set_x;
|
||||
case cell_vm_eval_macro_expand_eval: goto eval_macro_expand_eval;
|
||||
case cell_vm_eval_macro_expand_expand: goto eval_macro_expand_expand;
|
||||
case cell_vm_eval_check_func: goto eval_check_func;
|
||||
case cell_vm_eval2: goto eval2;
|
||||
case cell_vm_macro_expand: goto macro_expand;
|
||||
case cell_vm_macro_expand_define: goto macro_expand_define;
|
||||
case cell_vm_macro_expand_define_macro: goto macro_expand_define_macro;
|
||||
case cell_vm_macro_expand_lambda: goto macro_expand_lambda;
|
||||
case cell_vm_macro_expand_set_x: goto macro_expand_set_x;
|
||||
case cell_vm_macro_expand_car: goto macro_expand_car;
|
||||
case cell_vm_macro_expand_cdr: goto macro_expand_cdr;
|
||||
case cell_vm_begin: goto begin;
|
||||
case cell_vm_begin_eval: goto begin_eval;
|
||||
case cell_vm_begin_primitive_load: goto begin_primitive_load;
|
||||
case cell_vm_begin_expand: goto begin_expand;
|
||||
case cell_vm_begin_expand_eval: goto begin_expand_eval;
|
||||
case cell_vm_begin_expand_macro: goto begin_expand_macro;
|
||||
case cell_vm_begin_expand_primitive_load: goto begin_expand_primitive_load;
|
||||
case cell_vm_if: goto vm_if;
|
||||
case cell_vm_if_expr: goto if_expr;
|
||||
case cell_vm_call_with_current_continuation2: goto call_with_current_continuation2;
|
||||
case cell_vm_call_with_values2: goto call_with_values2;
|
||||
case cell_vm_return: goto vm_return;
|
||||
case cell_unspecified: return r1;
|
||||
default:
|
||||
assert (0);
|
||||
}
|
||||
if (r3 == cell_vm_evlis) goto evlis;
|
||||
else if (r3 == cell_vm_evlis2) goto evlis2;
|
||||
else if (r3 == cell_vm_evlis3) goto evlis3;
|
||||
else if (r3 == cell_vm_apply) goto apply;
|
||||
else if (r3 == cell_vm_apply2) goto apply2;
|
||||
else if (r3 == cell_vm_eval) goto eval;
|
||||
else if (r3 == cell_vm_eval_pmatch_car) goto eval_pmatch_car;
|
||||
else if (r3 == cell_vm_eval_pmatch_cdr) goto eval_pmatch_cdr;
|
||||
else if (r3 == cell_vm_eval_define) goto eval_define;
|
||||
else if (r3 == cell_vm_eval_set_x) goto eval_set_x;
|
||||
else if (r3 == cell_vm_eval_macro_expand_eval) goto eval_macro_expand_eval;
|
||||
else if (r3 == cell_vm_eval_macro_expand_expand) goto eval_macro_expand_expand;
|
||||
else if (r3 == cell_vm_eval_check_func) goto eval_check_func;
|
||||
else if (r3 == cell_vm_eval2) goto eval2;
|
||||
else if (r3 == cell_vm_macro_expand) goto macro_expand;
|
||||
else if (r3 == cell_vm_macro_expand_define) goto macro_expand_define;
|
||||
else if (r3 == cell_vm_macro_expand_define_macro) goto macro_expand_define_macro;
|
||||
else if (r3 == cell_vm_macro_expand_lambda) goto macro_expand_lambda;
|
||||
else if (r3 == cell_vm_macro_expand_set_x) goto macro_expand_set_x;
|
||||
else if (r3 == cell_vm_macro_expand_car) goto macro_expand_car;
|
||||
else if (r3 == cell_vm_macro_expand_cdr) goto macro_expand_cdr;
|
||||
else if (r3 == cell_vm_begin) goto begin;
|
||||
else if (r3 == cell_vm_begin_eval) goto begin_eval;
|
||||
else if (r3 == cell_vm_begin_primitive_load) goto begin_primitive_load;
|
||||
else if (r3 == cell_vm_begin_expand) goto begin_expand;
|
||||
else if (r3 == cell_vm_begin_expand_eval) goto begin_expand_eval;
|
||||
else if (r3 == cell_vm_begin_expand_macro) goto begin_expand_macro;
|
||||
else if (r3 == cell_vm_begin_expand_primitive_load) goto begin_expand_primitive_load;
|
||||
else if (r3 == cell_vm_if) goto vm_if;
|
||||
else if (r3 == cell_vm_if_expr) goto if_expr;
|
||||
else if (r3 == cell_vm_call_with_current_continuation2) goto call_with_current_continuation2;
|
||||
else if (r3 == cell_vm_call_with_values2) goto call_with_values2;
|
||||
else if (r3 == cell_vm_return) goto vm_return;
|
||||
else if (r3 == cell_unspecified) return r1;
|
||||
else
|
||||
error (cell_symbol_system_error,
|
||||
MAKE_STRING (cstring_to_list ("eval/apply unknown continuation")));
|
||||
|
||||
evlis:
|
||||
if (r1 == cell_nil)
|
||||
|
|
@ -1022,92 +1085,85 @@ eval_apply ()
|
|||
goto vm_return;
|
||||
|
||||
apply:
|
||||
switch (TYPE (CAR (r1)))
|
||||
t = TYPE (CAR (r1));
|
||||
if (t == TFUNCTION)
|
||||
{
|
||||
case TFUNCTION:
|
||||
{
|
||||
check_formals (CAR (r1), MAKE_NUMBER (FUNCTION (CAR (r1)).arity), CDR (r1));
|
||||
r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply
|
||||
goto vm_return;
|
||||
}
|
||||
case TCLOSURE:
|
||||
{
|
||||
cl = CLOSURE (CAR (r1));
|
||||
body = CDDR (cl);
|
||||
formals = CADR (cl);
|
||||
args = CDR (r1);
|
||||
aa = CDAR (cl);
|
||||
aa = CDR (aa);
|
||||
check_formals (CAR (r1), formals, CDR (r1));
|
||||
p = pairlis (formals, args, aa);
|
||||
call_lambda (body, p, aa, r0);
|
||||
goto begin;
|
||||
}
|
||||
case TCONTINUATION:
|
||||
{
|
||||
x = r1;
|
||||
g_stack = CONTINUATION (CAR (r1));
|
||||
gc_pop_frame ();
|
||||
r1 = CADR (x);
|
||||
goto eval_apply;
|
||||
}
|
||||
case TSPECIAL:
|
||||
{
|
||||
switch (CAR (r1))
|
||||
{
|
||||
case cell_vm_apply:
|
||||
{
|
||||
push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return);
|
||||
goto apply;
|
||||
}
|
||||
case cell_vm_eval:
|
||||
{
|
||||
push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return);
|
||||
goto eval;
|
||||
}
|
||||
case cell_vm_begin_expand:
|
||||
{
|
||||
push_cc (cons (CADR (r1), cell_nil), r1, CADDR (r1), cell_vm_return);
|
||||
goto begin_expand;
|
||||
}
|
||||
case cell_call_with_current_continuation:
|
||||
{
|
||||
r1 = CDR (r1);
|
||||
goto call_with_current_continuation;
|
||||
}
|
||||
default: check_apply (cell_f, CAR (r1));
|
||||
}
|
||||
}
|
||||
case TSYMBOL:
|
||||
{
|
||||
if (CAR (r1) == cell_symbol_call_with_values)
|
||||
{
|
||||
r1 = CDR (r1);
|
||||
goto call_with_values;
|
||||
}
|
||||
if (CAR (r1) == cell_symbol_current_module)
|
||||
{
|
||||
r1 = r0;
|
||||
goto vm_return;
|
||||
}
|
||||
break;
|
||||
}
|
||||
case TPAIR:
|
||||
{
|
||||
switch (CAAR (r1))
|
||||
{
|
||||
case cell_symbol_lambda:
|
||||
{
|
||||
formals = CADR (CAR (r1));
|
||||
args = CDR (r1);
|
||||
body = CDDR (CAR (r1));
|
||||
p = pairlis (formals, CDR (r1), r0);
|
||||
check_formals (r1, formals, args);
|
||||
call_lambda (body, p, p, r0);
|
||||
goto begin;
|
||||
}
|
||||
}
|
||||
}
|
||||
check_formals (CAR (r1), MAKE_NUMBER (FUNCTION (CAR (r1)).arity), CDR (r1));
|
||||
r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply
|
||||
goto vm_return;
|
||||
}
|
||||
else if (t == TCLOSURE)
|
||||
{
|
||||
cl = CLOSURE (CAR (r1));
|
||||
body = CDDR (cl);
|
||||
formals = CADR (cl);
|
||||
args = CDR (r1);
|
||||
aa = CDAR (cl);
|
||||
aa = CDR (aa);
|
||||
check_formals (CAR (r1), formals, CDR (r1));
|
||||
p = pairlis (formals, args, aa);
|
||||
call_lambda (body, p, aa, r0);
|
||||
goto begin;
|
||||
}
|
||||
else if (t == TCONTINUATION)
|
||||
{
|
||||
x = r1;
|
||||
g_stack = CONTINUATION (CAR (r1));
|
||||
gc_pop_frame ();
|
||||
r1 = CADR (x);
|
||||
goto eval_apply;
|
||||
}
|
||||
else if (t == TSPECIAL)
|
||||
{
|
||||
c = CAR (r1);
|
||||
if (c == cell_vm_apply)
|
||||
{
|
||||
push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return);
|
||||
goto apply;
|
||||
}
|
||||
else if (c == cell_vm_eval)
|
||||
{
|
||||
push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return);
|
||||
goto eval;
|
||||
}
|
||||
else if (c == cell_vm_begin_expand)
|
||||
{
|
||||
push_cc (cons (CADR (r1), cell_nil), r1, CADDR (r1), cell_vm_return);
|
||||
goto begin_expand;
|
||||
}
|
||||
else if (c == cell_call_with_current_continuation)
|
||||
{
|
||||
r1 = CDR (r1);
|
||||
goto call_with_current_continuation;
|
||||
}
|
||||
else
|
||||
check_apply (cell_f, CAR (r1));
|
||||
}
|
||||
else if (t == TSYMBOL)
|
||||
{
|
||||
if (CAR (r1) == cell_symbol_call_with_values)
|
||||
{
|
||||
r1 = CDR (r1);
|
||||
goto call_with_values;
|
||||
}
|
||||
if (CAR (r1) == cell_symbol_current_module)
|
||||
{
|
||||
r1 = r0;
|
||||
goto vm_return;
|
||||
}
|
||||
}
|
||||
else if (t == TPAIR)
|
||||
{
|
||||
if (CAAR (r1) == cell_symbol_lambda)
|
||||
{
|
||||
formals = CADR (CAR (r1));
|
||||
args = CDR (r1);
|
||||
body = CDDR (CAR (r1));
|
||||
p = pairlis (formals, CDR (r1), r0);
|
||||
check_formals (r1, formals, args);
|
||||
call_lambda (body, p, p, r0);
|
||||
goto begin;
|
||||
}
|
||||
}
|
||||
push_cc (CAR (r1), r1, r0, cell_vm_apply2);
|
||||
goto eval;
|
||||
|
|
@ -1117,183 +1173,178 @@ eval_apply ()
|
|||
goto apply;
|
||||
|
||||
eval:
|
||||
switch (TYPE (r1))
|
||||
t = TYPE (r1);
|
||||
if (t == TPAIR)
|
||||
{
|
||||
case TPAIR:
|
||||
{
|
||||
switch (CAR (r1))
|
||||
{
|
||||
case cell_symbol_pmatch_car:
|
||||
c = CAR (r1);
|
||||
if (c == cell_symbol_pmatch_car)
|
||||
{
|
||||
push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_car);
|
||||
goto eval;
|
||||
eval_pmatch_car:
|
||||
x = r1;
|
||||
gc_pop_frame ();
|
||||
r1 = CAR (x);
|
||||
goto eval_apply;
|
||||
}
|
||||
else if (c == cell_symbol_pmatch_cdr)
|
||||
{
|
||||
push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_cdr);
|
||||
goto eval;
|
||||
eval_pmatch_cdr:
|
||||
x = r1;
|
||||
gc_pop_frame ();
|
||||
r1 = CDR (x);
|
||||
goto eval_apply;
|
||||
}
|
||||
else if (c == cell_symbol_quote)
|
||||
{
|
||||
x = r1;
|
||||
gc_pop_frame ();
|
||||
r1 = CADR (x);
|
||||
goto eval_apply;
|
||||
}
|
||||
else if (c == cell_symbol_begin)
|
||||
goto begin;
|
||||
else if (c == cell_symbol_lambda)
|
||||
{
|
||||
r1 = make_closure_ (CADR (r1), CDDR (r1), r0);
|
||||
goto vm_return;
|
||||
}
|
||||
else if (c == cell_symbol_if)
|
||||
{
|
||||
r1=CDR (r1);
|
||||
goto vm_if;
|
||||
}
|
||||
else if (c == cell_symbol_set_x)
|
||||
{
|
||||
push_cc (CAR (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
|
||||
goto eval;
|
||||
eval_set_x:
|
||||
r1 = set_env_x (CADR (r2), r1, r0);
|
||||
goto vm_return;
|
||||
}
|
||||
else if (c == cell_vm_macro_expand)
|
||||
{
|
||||
push_cc (CADR (r1), r1, r0, cell_vm_eval_macro_expand_eval);
|
||||
goto eval;
|
||||
eval_macro_expand_eval:
|
||||
push_cc (r1, r2, r0, cell_vm_eval_macro_expand_expand);
|
||||
goto macro_expand;
|
||||
eval_macro_expand_expand:
|
||||
goto vm_return;
|
||||
}
|
||||
else
|
||||
{
|
||||
if (TYPE (r1) == TPAIR
|
||||
&& (CAR (r1) == cell_symbol_define
|
||||
|| CAR (r1) == cell_symbol_define_macro))
|
||||
{
|
||||
push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_car);
|
||||
goto eval;
|
||||
eval_pmatch_car:
|
||||
x = r1;
|
||||
gc_pop_frame ();
|
||||
r1 = CAR (x);
|
||||
goto eval_apply;
|
||||
}
|
||||
case cell_symbol_pmatch_cdr:
|
||||
{
|
||||
push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_cdr);
|
||||
goto eval;
|
||||
eval_pmatch_cdr:
|
||||
x = r1;
|
||||
gc_pop_frame ();
|
||||
r1 = CDR (x);
|
||||
goto eval_apply;
|
||||
}
|
||||
case cell_symbol_quote:
|
||||
{
|
||||
x = r1;
|
||||
gc_pop_frame ();
|
||||
r1 = CADR (x);
|
||||
goto eval_apply;
|
||||
}
|
||||
case cell_symbol_begin:
|
||||
goto begin;
|
||||
case cell_symbol_lambda:
|
||||
{
|
||||
r1 = make_closure_ (CADR (r1), CDDR (r1), r0);
|
||||
goto vm_return;
|
||||
}
|
||||
case cell_symbol_if:
|
||||
{
|
||||
r1=CDR (r1);
|
||||
goto vm_if;
|
||||
}
|
||||
case cell_symbol_set_x:
|
||||
{
|
||||
push_cc (CAR (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
|
||||
goto eval;
|
||||
eval_set_x:
|
||||
r1 = set_env_x (CADR (r2), r1, r0);
|
||||
goto vm_return;
|
||||
}
|
||||
case cell_vm_macro_expand:
|
||||
{
|
||||
push_cc (CADR (r1), r1, r0, cell_vm_eval_macro_expand_eval);
|
||||
goto eval;
|
||||
eval_macro_expand_eval:
|
||||
push_cc (r1, r2, r0, cell_vm_eval_macro_expand_expand);
|
||||
goto macro_expand;
|
||||
eval_macro_expand_expand:
|
||||
goto vm_return;
|
||||
}
|
||||
default:
|
||||
{
|
||||
if (TYPE (r1) == TPAIR
|
||||
&& (CAR (r1) == cell_symbol_define
|
||||
|| CAR (r1) == cell_symbol_define_macro))
|
||||
global_p = CAAR (r0) != cell_closure;
|
||||
macro_p = CAR (r1) == cell_symbol_define_macro;
|
||||
if (global_p)
|
||||
{
|
||||
global_p = CAAR (r0) != cell_closure;
|
||||
macro_p = CAR (r1) == cell_symbol_define_macro;
|
||||
if (global_p)
|
||||
{
|
||||
name = CADR (r1);
|
||||
if (TYPE (CADR (r1)) == TPAIR)
|
||||
name = CAR (name);
|
||||
if (macro_p)
|
||||
{
|
||||
entry = assq (name, g_macros);
|
||||
if (entry == cell_f)
|
||||
{
|
||||
entry = cons (name, cell_f);
|
||||
g_macros = cons (entry, g_macros);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
entry = assq (name, r0);
|
||||
if (entry == cell_f)
|
||||
{
|
||||
entry = cons (name, cell_f);
|
||||
aa = cons (entry, cell_nil);
|
||||
set_cdr_x (aa, cdr (r0));
|
||||
set_cdr_x (r0, aa);
|
||||
}
|
||||
}
|
||||
}
|
||||
r2 = r1;
|
||||
if (TYPE (CADR (r1)) != TPAIR)
|
||||
{
|
||||
push_cc (CAR (CDDR (r1)), r2, cons (cons (CADR (r1), CADR (r1)), r0), cell_vm_eval_define);
|
||||
goto eval;
|
||||
}
|
||||
else
|
||||
{
|
||||
p = pairlis (CADR (r1), CADR (r1), r0);
|
||||
formals = CDR (CADR (r1));
|
||||
body = CDDR (r1);
|
||||
|
||||
if (macro_p || global_p)
|
||||
expand_variable (body, formals);
|
||||
r1 = cons (cell_symbol_lambda, cons (formals, body));
|
||||
push_cc (r1, r2, p, cell_vm_eval_define);
|
||||
goto eval;
|
||||
}
|
||||
eval_define:;
|
||||
name = CADR (r2);
|
||||
if (TYPE (CADR (r2)) == TPAIR)
|
||||
name = CADR (r1);
|
||||
if (TYPE (CADR (r1)) == TPAIR)
|
||||
name = CAR (name);
|
||||
if (macro_p)
|
||||
{
|
||||
entry = assq (name, g_macros);
|
||||
r1 = MAKE_MACRO (name, r1);
|
||||
set_cdr_x (entry, r1);
|
||||
}
|
||||
else if (global_p)
|
||||
{
|
||||
entry = assq (name, r0);
|
||||
set_cdr_x (entry, r1);
|
||||
if (entry == cell_f)
|
||||
{
|
||||
entry = cons (name, cell_f);
|
||||
g_macros = cons (entry, g_macros);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
entry = cons (name, r1);
|
||||
aa = cons (entry, cell_nil);
|
||||
set_cdr_x (aa, cdr (r0));
|
||||
set_cdr_x (r0, aa);
|
||||
cl = assq (cell_closure, r0);
|
||||
set_cdr_x (cl, aa);
|
||||
entry = assq (name, r0);
|
||||
if (entry == cell_f)
|
||||
{
|
||||
entry = cons (name, cell_f);
|
||||
aa = cons (entry, cell_nil);
|
||||
set_cdr_x (aa, cdr (r0));
|
||||
set_cdr_x (r0, aa);
|
||||
}
|
||||
}
|
||||
r1 = cell_unspecified;
|
||||
goto vm_return;
|
||||
}
|
||||
push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func);
|
||||
gc_check ();
|
||||
goto eval;
|
||||
eval_check_func:
|
||||
push_cc (CDR (r2), r2, r0, cell_vm_eval2);
|
||||
goto evlis;
|
||||
eval2:
|
||||
r1 = cons (CAR (r2), r1);
|
||||
goto apply;
|
||||
r2 = r1;
|
||||
if (TYPE (CADR (r1)) != TPAIR)
|
||||
{
|
||||
push_cc (CAR (CDDR (r1)), r2, cons (cons (CADR (r1), CADR (r1)), r0), cell_vm_eval_define);
|
||||
goto eval;
|
||||
}
|
||||
else
|
||||
{
|
||||
p = pairlis (CADR (r1), CADR (r1), r0);
|
||||
formals = CDR (CADR (r1));
|
||||
body = CDDR (r1);
|
||||
|
||||
if (macro_p || global_p)
|
||||
expand_variable (body, formals);
|
||||
r1 = cons (cell_symbol_lambda, cons (formals, body));
|
||||
push_cc (r1, r2, p, cell_vm_eval_define);
|
||||
goto eval;
|
||||
}
|
||||
eval_define:;
|
||||
name = CADR (r2);
|
||||
if (TYPE (CADR (r2)) == TPAIR)
|
||||
name = CAR (name);
|
||||
if (macro_p)
|
||||
{
|
||||
entry = assq (name, g_macros);
|
||||
r1 = MAKE_MACRO (name, r1);
|
||||
set_cdr_x (entry, r1);
|
||||
}
|
||||
else if (global_p)
|
||||
{
|
||||
entry = assq (name, r0);
|
||||
set_cdr_x (entry, r1);
|
||||
}
|
||||
else
|
||||
{
|
||||
entry = cons (name, r1);
|
||||
aa = cons (entry, cell_nil);
|
||||
set_cdr_x (aa, cdr (r0));
|
||||
set_cdr_x (r0, aa);
|
||||
cl = assq (cell_closure, r0);
|
||||
set_cdr_x (cl, aa);
|
||||
}
|
||||
r1 = cell_unspecified;
|
||||
goto vm_return;
|
||||
}
|
||||
}
|
||||
}
|
||||
case TSYMBOL:
|
||||
{
|
||||
if (r1 == cell_symbol_current_module)
|
||||
goto vm_return;
|
||||
if (r1 == cell_symbol_begin) // FIXME
|
||||
{
|
||||
r1 = cell_begin;
|
||||
goto vm_return;
|
||||
}
|
||||
r1 = assert_defined (r1, assq_ref_env (r1, r0));
|
||||
goto vm_return;
|
||||
}
|
||||
case TVARIABLE:
|
||||
{
|
||||
r1 = CDR (VARIABLE (r1));
|
||||
goto vm_return;
|
||||
}
|
||||
case TBROKEN_HEART:
|
||||
{
|
||||
error (cell_symbol_system_error, r1);
|
||||
}
|
||||
default: goto vm_return;
|
||||
push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func);
|
||||
gc_check ();
|
||||
goto eval;
|
||||
eval_check_func:
|
||||
push_cc (CDR (r2), r2, r0, cell_vm_eval2);
|
||||
goto evlis;
|
||||
eval2:
|
||||
r1 = cons (CAR (r2), r1);
|
||||
goto apply;
|
||||
}
|
||||
}
|
||||
else if (t == TSYMBOL)
|
||||
{
|
||||
if (r1 == cell_symbol_current_module)
|
||||
goto vm_return;
|
||||
if (r1 == cell_symbol_begin) // FIXME
|
||||
{
|
||||
r1 = cell_begin;
|
||||
goto vm_return;
|
||||
}
|
||||
r1 = assert_defined (r1, assq_ref_env (r1, r0));
|
||||
goto vm_return;
|
||||
}
|
||||
else if (t == TVARIABLE)
|
||||
{
|
||||
r1 = CDR (VARIABLE (r1));
|
||||
goto vm_return;
|
||||
}
|
||||
else if (t == TBROKEN_HEART)
|
||||
error (cell_symbol_system_error, r1);
|
||||
else
|
||||
goto vm_return;
|
||||
|
||||
macro_expand:
|
||||
{
|
||||
|
|
|
|||
Loading…
Reference in New Issue