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

293
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,15 +1085,14 @@ 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)); check_formals (CAR (r1), MAKE_NUMBER (FUNCTION (CAR (r1)).arity), CDR (r1));
r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply
goto vm_return; goto vm_return;
} }
case TCLOSURE: else if (t == TCLOSURE)
{ {
cl = CLOSURE (CAR (r1)); cl = CLOSURE (CAR (r1));
body = CDDR (cl); body = CDDR (cl);
@ -1043,7 +1105,7 @@ eval_apply ()
call_lambda (body, p, aa, r0); call_lambda (body, p, aa, r0);
goto begin; goto begin;
} }
case TCONTINUATION: else if (t == TCONTINUATION)
{ {
x = r1; x = r1;
g_stack = CONTINUATION (CAR (r1)); g_stack = CONTINUATION (CAR (r1));
@ -1051,34 +1113,33 @@ eval_apply ()
r1 = CADR (x); r1 = CADR (x);
goto eval_apply; goto eval_apply;
} }
case TSPECIAL: else if (t == TSPECIAL)
{ {
switch (CAR (r1)) c = CAR (r1);
{ if (c == cell_vm_apply)
case cell_vm_apply:
{ {
push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return); push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return);
goto apply; goto apply;
} }
case cell_vm_eval: else if (c == cell_vm_eval)
{ {
push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return); push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return);
goto eval; goto eval;
} }
case cell_vm_begin_expand: else if (c == cell_vm_begin_expand)
{ {
push_cc (cons (CADR (r1), cell_nil), r1, CADDR (r1), cell_vm_return); push_cc (cons (CADR (r1), cell_nil), r1, CADDR (r1), cell_vm_return);
goto begin_expand; goto begin_expand;
} }
case cell_call_with_current_continuation: else if (c == cell_call_with_current_continuation)
{ {
r1 = CDR (r1); r1 = CDR (r1);
goto call_with_current_continuation; goto call_with_current_continuation;
} }
default: check_apply (cell_f, CAR (r1)); else
check_apply (cell_f, CAR (r1));
} }
} else if (t == TSYMBOL)
case TSYMBOL:
{ {
if (CAR (r1) == cell_symbol_call_with_values) if (CAR (r1) == cell_symbol_call_with_values)
{ {
@ -1090,13 +1151,10 @@ eval_apply ()
r1 = r0; r1 = r0;
goto vm_return; goto vm_return;
} }
break;
} }
case TPAIR: else if (t == TPAIR)
{ {
switch (CAAR (r1)) if (CAAR (r1) == cell_symbol_lambda)
{
case cell_symbol_lambda:
{ {
formals = CADR (CAR (r1)); formals = CADR (CAR (r1));
args = CDR (r1); args = CDR (r1);
@ -1107,8 +1165,6 @@ eval_apply ()
goto begin; goto begin;
} }
} }
}
}
push_cc (CAR (r1), r1, r0, cell_vm_apply2); push_cc (CAR (r1), r1, r0, cell_vm_apply2);
goto eval; goto eval;
apply2: apply2:
@ -1117,13 +1173,11 @@ 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))
{
case cell_symbol_pmatch_car:
{ {
push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_car); push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_car);
goto eval; goto eval;
@ -1133,7 +1187,7 @@ eval_apply ()
r1 = CAR (x); r1 = CAR (x);
goto eval_apply; goto eval_apply;
} }
case cell_symbol_pmatch_cdr: else if (c == cell_symbol_pmatch_cdr)
{ {
push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_cdr); push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_cdr);
goto eval; goto eval;
@ -1143,26 +1197,26 @@ eval_apply ()
r1 = CDR (x); r1 = CDR (x);
goto eval_apply; goto eval_apply;
} }
case cell_symbol_quote: else if (c == cell_symbol_quote)
{ {
x = r1; x = r1;
gc_pop_frame (); gc_pop_frame ();
r1 = CADR (x); r1 = CADR (x);
goto eval_apply; goto eval_apply;
} }
case cell_symbol_begin: else if (c == cell_symbol_begin)
goto begin; goto begin;
case cell_symbol_lambda: else if (c == cell_symbol_lambda)
{ {
r1 = make_closure_ (CADR (r1), CDDR (r1), r0); r1 = make_closure_ (CADR (r1), CDDR (r1), r0);
goto vm_return; goto vm_return;
} }
case cell_symbol_if: else if (c == cell_symbol_if)
{ {
r1=CDR (r1); r1=CDR (r1);
goto vm_if; goto vm_if;
} }
case cell_symbol_set_x: else if (c == cell_symbol_set_x)
{ {
push_cc (CAR (CDDR (r1)), r1, r0, cell_vm_eval_set_x); push_cc (CAR (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
goto eval; goto eval;
@ -1170,7 +1224,7 @@ eval_apply ()
r1 = set_env_x (CADR (r2), r1, r0); r1 = set_env_x (CADR (r2), r1, r0);
goto vm_return; goto vm_return;
} }
case cell_vm_macro_expand: else if (c == cell_vm_macro_expand)
{ {
push_cc (CADR (r1), r1, r0, cell_vm_eval_macro_expand_eval); push_cc (CADR (r1), r1, r0, cell_vm_eval_macro_expand_eval);
goto eval; goto eval;
@ -1180,7 +1234,7 @@ eval_apply ()
eval_macro_expand_expand: eval_macro_expand_expand:
goto vm_return; goto vm_return;
} }
default: else
{ {
if (TYPE (r1) == TPAIR if (TYPE (r1) == TPAIR
&& (CAR (r1) == cell_symbol_define && (CAR (r1) == cell_symbol_define
@ -1270,8 +1324,7 @@ eval_apply ()
goto apply; goto apply;
} }
} }
} else if (t == TSYMBOL)
case TSYMBOL:
{ {
if (r1 == cell_symbol_current_module) if (r1 == cell_symbol_current_module)
goto vm_return; goto vm_return;
@ -1283,17 +1336,15 @@ eval_apply ()
r1 = assert_defined (r1, assq_ref_env (r1, r0)); r1 = assert_defined (r1, assq_ref_env (r1, r0));
goto vm_return; goto vm_return;
} }
case TVARIABLE: else if (t == TVARIABLE)
{ {
r1 = CDR (VARIABLE (r1)); r1 = CDR (VARIABLE (r1));
goto vm_return; goto vm_return;
} }
case TBROKEN_HEART: else if (t == TBROKEN_HEART)
{
error (cell_symbol_system_error, r1); error (cell_symbol_system_error, r1);
} else
default: goto vm_return; goto vm_return;
}
macro_expand: macro_expand:
{ {