artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

core: mes: Prepare for M2-Planet.

Browse source 
* src/mes.c (cal): Refactor to use if instead of switch.
(eval_apply): Likewise.
This commit is contained in:
Jan Nieuwenhuizen 2018-08-12 16:53:21 +02:00
parent 1e787637d8
commit bc094d0e1f
No known key found for this signature in database
GPG key ID: F3C1A0D9C1D65273
1 changed files with 378 additions and 327 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

705
src/mes.c
View file

@ -56,26 +56,49 @@ SCM r3 = 0;
SCM g_macros = 1; SCM g_macros = 1;
SCM g_ports = 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}; 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 { struct scm {
enum type_t type; enum type_t type;
SCM car; SCM car;
SCM cdr; SCM cdr;
}; };
struct function { struct function {
long (*function) (void); #if __M2_PLANET__
FUNCTION function;
#else // !__M2_PLANET__
SCM (*function) (SCM);
#endif // !__M2_PLANET__
long arity; long arity;
char *name; char *name;
}; };
#else #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 { struct function {
union { union {
function0_t function0; function0_t function0;
@ -688,30 +711,74 @@ pairlis (SCM x, SCM y, SCM a)
SCM SCM
call (SCM fn, SCM x) 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 != cell_nil && TYPE (CAR (x)) == TVALUES)
x = cons (CADAR (x), CDR (x)); 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 != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES)
x = cons (CAR (x), cons (CDADAR (x), CDR (x))); 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; return cell_unspecified;
} }
@ -720,29 +787,25 @@ assq (SCM x, SCM a)
{ {
if (TYPE (a) != TPAIR) if (TYPE (a) != TPAIR)
return cell_f; return cell_f;
switch (TYPE (x)) int t = TYPE (x);
{ if (t == TCHAR
case TCHAR: || t == TNUMBER)
case TNUMBER:
{ {
SCM v = VALUE (x); SCM v = VALUE (x);
while (a != cell_nil && v != VALUE (CAAR (a))) while (a != cell_nil && v != VALUE (CAAR (a)))
a = CDR (a); a = CDR (a);
break;
} }
case TKEYWORD: else if (t == TKEYWORD)
{ {
SCM v = STRING (x); SCM v = STRING (x);
while (a != cell_nil && v != STRING (CAAR (a))) while (a != cell_nil && v != STRING (CAAR (a)))
a = CDR (a); a = CDR (a);
break;
} }
// case TSYMBOL: // else if (t == TSYMBOL)
// case TSPECIAL: // else if (t == TSPECIAL)
default: else
while (a != cell_nil && x != CAAR (a)) while (a != cell_nil && x != CAAR (a))
a = CDR (a); a = CDR (a);
}
return a != cell_nil ? CAR (a) : cell_f; return a != cell_nil ? CAR (a) : cell_f;
} }
@ -965,47 +1028,47 @@ eval_apply ()
SCM x; SCM x;
int global_p; int global_p;
int macro_p; int macro_p;
int t;
int c;
eval_apply: eval_apply:
switch (r3) if (r3 == cell_vm_evlis) goto evlis;
{ else if (r3 == cell_vm_evlis2) goto evlis2;
case cell_vm_evlis: goto evlis; else if (r3 == cell_vm_evlis3) goto evlis3;
case cell_vm_evlis2: goto evlis2; else if (r3 == cell_vm_apply) goto apply;
case cell_vm_evlis3: goto evlis3; else if (r3 == cell_vm_apply2) goto apply2;
case cell_vm_apply: goto apply; else if (r3 == cell_vm_eval) goto eval;
case cell_vm_apply2: goto apply2; else if (r3 == cell_vm_eval_pmatch_car) goto eval_pmatch_car;
case cell_vm_eval: goto eval; else if (r3 == cell_vm_eval_pmatch_cdr) goto eval_pmatch_cdr;
case cell_vm_eval_pmatch_car: goto eval_pmatch_car; else if (r3 == cell_vm_eval_define) goto eval_define;
case cell_vm_eval_pmatch_cdr: goto eval_pmatch_cdr; else if (r3 == cell_vm_eval_set_x) goto eval_set_x;
case cell_vm_eval_define: goto eval_define; else if (r3 == cell_vm_eval_macro_expand_eval) goto eval_macro_expand_eval;
case cell_vm_eval_set_x: goto eval_set_x; else if (r3 == cell_vm_eval_macro_expand_expand) goto eval_macro_expand_expand;
case cell_vm_eval_macro_expand_eval: goto eval_macro_expand_eval; else if (r3 == cell_vm_eval_check_func) goto eval_check_func;
case cell_vm_eval_macro_expand_expand: goto eval_macro_expand_expand; else if (r3 == cell_vm_eval2) goto eval2;
case cell_vm_eval_check_func: goto eval_check_func; else if (r3 == cell_vm_macro_expand) goto macro_expand;
case cell_vm_eval2: goto eval2; else if (r3 == cell_vm_macro_expand_define) goto macro_expand_define;
case cell_vm_macro_expand: goto macro_expand; else if (r3 == cell_vm_macro_expand_define_macro) goto macro_expand_define_macro;
case cell_vm_macro_expand_define: goto macro_expand_define; else if (r3 == cell_vm_macro_expand_lambda) goto macro_expand_lambda;
case cell_vm_macro_expand_define_macro: goto macro_expand_define_macro; else if (r3 == cell_vm_macro_expand_set_x) goto macro_expand_set_x;
case cell_vm_macro_expand_lambda: goto macro_expand_lambda; else if (r3 == cell_vm_macro_expand_car) goto macro_expand_car;
case cell_vm_macro_expand_set_x: goto macro_expand_set_x; else if (r3 == cell_vm_macro_expand_cdr) goto macro_expand_cdr;
case cell_vm_macro_expand_car: goto macro_expand_car; else if (r3 == cell_vm_begin) goto begin;
case cell_vm_macro_expand_cdr: goto macro_expand_cdr; else if (r3 == cell_vm_begin_eval) goto begin_eval;
case cell_vm_begin: goto begin; else if (r3 == cell_vm_begin_primitive_load) goto begin_primitive_load;
case cell_vm_begin_eval: goto begin_eval; else if (r3 == cell_vm_begin_expand) goto begin_expand;
case cell_vm_begin_primitive_load: goto begin_primitive_load; else if (r3 == cell_vm_begin_expand_eval) goto begin_expand_eval;
case cell_vm_begin_expand: goto begin_expand; else if (r3 == cell_vm_begin_expand_macro) goto begin_expand_macro;
case cell_vm_begin_expand_eval: goto begin_expand_eval; else if (r3 == cell_vm_begin_expand_primitive_load) goto begin_expand_primitive_load;
case cell_vm_begin_expand_macro: goto begin_expand_macro; else if (r3 == cell_vm_if) goto vm_if;
case cell_vm_begin_expand_primitive_load: goto begin_expand_primitive_load; else if (r3 == cell_vm_if_expr) goto if_expr;
case cell_vm_if: goto vm_if; else if (r3 == cell_vm_call_with_current_continuation2) goto call_with_current_continuation2;
case cell_vm_if_expr: goto if_expr; else if (r3 == cell_vm_call_with_values2) goto call_with_values2;
case cell_vm_call_with_current_continuation2: goto call_with_current_continuation2; else if (r3 == cell_vm_return) goto vm_return;
case cell_vm_call_with_values2: goto call_with_values2; else if (r3 == cell_unspecified) return r1;
case cell_vm_return: goto vm_return; else
case cell_unspecified: return r1; error (cell_symbol_system_error,
default: MAKE_STRING (cstring_to_list ("eval/apply unknown continuation")));
assert (0);
}
evlis: evlis:
if (r1 == cell_nil) if (r1 == cell_nil)
@ -1022,92 +1085,85 @@ eval_apply ()
goto vm_return; goto vm_return;
apply: 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
check_formals (CAR (r1), MAKE_NUMBER (FUNCTION (CAR (r1)).arity), CDR (r1)); goto vm_return;
r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply }
goto vm_return; else if (t == TCLOSURE)
} {
case TCLOSURE: cl = CLOSURE (CAR (r1));
{ body = CDDR (cl);
cl = CLOSURE (CAR (r1)); formals = CADR (cl);
body = CDDR (cl); args = CDR (r1);
formals = CADR (cl); aa = CDAR (cl);
args = CDR (r1); aa = CDR (aa);
aa = CDAR (cl); check_formals (CAR (r1), formals, CDR (r1));
aa = CDR (aa); p = pairlis (formals, args, aa);
check_formals (CAR (r1), formals, CDR (r1)); call_lambda (body, p, aa, r0);
p = pairlis (formals, args, aa); goto begin;
call_lambda (body, p, aa, r0); }
goto begin; else if (t == TCONTINUATION)
} {
case TCONTINUATION: x = r1;
{ g_stack = CONTINUATION (CAR (r1));
x = r1; gc_pop_frame ();
g_stack = CONTINUATION (CAR (r1)); r1 = CADR (x);
gc_pop_frame (); goto eval_apply;
r1 = CADR (x); }
goto eval_apply; else if (t == TSPECIAL)
} {
case TSPECIAL: c = CAR (r1);
{ if (c == cell_vm_apply)
switch (CAR (r1)) {
{ push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return);
case cell_vm_apply: goto apply;
{ }
push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return); else if (c == cell_vm_eval)
goto apply; {
} push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return);
case cell_vm_eval: goto eval;
{ }
push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return); else if (c == cell_vm_begin_expand)
goto eval; {
} push_cc (cons (CADR (r1), cell_nil), r1, CADDR (r1), cell_vm_return);
case cell_vm_begin_expand: goto begin_expand;
{ }
push_cc (cons (CADR (r1), cell_nil), r1, CADDR (r1), cell_vm_return); else if (c == cell_call_with_current_continuation)
goto begin_expand; {
} r1 = CDR (r1);
case cell_call_with_current_continuation: goto call_with_current_continuation;
{ }
r1 = CDR (r1); else
goto call_with_current_continuation; check_apply (cell_f, CAR (r1));
} }
default: check_apply (cell_f, CAR (r1)); else if (t == TSYMBOL)
} {
} if (CAR (r1) == cell_symbol_call_with_values)
case TSYMBOL: {
{ r1 = CDR (r1);
if (CAR (r1) == cell_symbol_call_with_values) goto call_with_values;
{ }
r1 = CDR (r1); if (CAR (r1) == cell_symbol_current_module)
goto call_with_values; {
} r1 = r0;
if (CAR (r1) == cell_symbol_current_module) goto vm_return;
{ }
r1 = r0; }
goto vm_return; else if (t == TPAIR)
} {
break; if (CAAR (r1) == cell_symbol_lambda)
} {
case TPAIR: formals = CADR (CAR (r1));
{ args = CDR (r1);
switch (CAAR (r1)) body = CDDR (CAR (r1));
{ p = pairlis (formals, CDR (r1), r0);
case cell_symbol_lambda: check_formals (r1, formals, args);
{ call_lambda (body, p, p, r0);
formals = CADR (CAR (r1)); goto begin;
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); push_cc (CAR (r1), r1, r0, cell_vm_apply2);
goto eval; goto eval;
@ -1117,183 +1173,178 @@ eval_apply ()
goto apply; goto apply;
eval: eval:
switch (TYPE (r1)) t = TYPE (r1);
if (t == TPAIR)
{ {
case TPAIR: c = CAR (r1);
{ if (c == cell_symbol_pmatch_car)
switch (CAR (r1)) {
{ push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_car);
case cell_symbol_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); global_p = CAAR (r0) != cell_closure;
goto eval; macro_p = CAR (r1) == cell_symbol_define_macro;
eval_pmatch_car: if (global_p)
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; name = CADR (r1);
macro_p = CAR (r1) == cell_symbol_define_macro; if (TYPE (CADR (r1)) == TPAIR)
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 = CAR (name); name = CAR (name);
if (macro_p) if (macro_p)
{ {
entry = assq (name, g_macros); entry = assq (name, g_macros);
r1 = MAKE_MACRO (name, r1); if (entry == cell_f)
set_cdr_x (entry, r1); {
} entry = cons (name, cell_f);
else if (global_p) g_macros = cons (entry, g_macros);
{ }
entry = assq (name, r0);
set_cdr_x (entry, r1);
} }
else else
{ {
entry = cons (name, r1); entry = assq (name, r0);
aa = cons (entry, cell_nil); if (entry == cell_f)
set_cdr_x (aa, cdr (r0)); {
set_cdr_x (r0, aa); entry = cons (name, cell_f);
cl = assq (cell_closure, r0); aa = cons (entry, cell_nil);
set_cdr_x (cl, aa); 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); r2 = r1;
gc_check (); if (TYPE (CADR (r1)) != TPAIR)
goto eval; {
eval_check_func: push_cc (CAR (CDDR (r1)), r2, cons (cons (CADR (r1), CADR (r1)), r0), cell_vm_eval_define);
push_cc (CDR (r2), r2, r0, cell_vm_eval2); goto eval;
goto evlis; }
eval2: else
r1 = cons (CAR (r2), r1); {
goto apply; 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;
} }
} push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func);
} gc_check ();
case TSYMBOL: goto eval;
{ eval_check_func:
if (r1 == cell_symbol_current_module) push_cc (CDR (r2), r2, r0, cell_vm_eval2);
goto vm_return; goto evlis;
if (r1 == cell_symbol_begin) // FIXME eval2:
{ r1 = cons (CAR (r2), r1);
r1 = cell_begin; goto apply;
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;
} }
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: macro_expand:
{ {