987 lines
26 KiB
C
987 lines
26 KiB
C
/* -*-comment-start: "//";comment-end:""-*-
|
|
* GNU Mes --- Maxwell Equations of Software
|
|
* Copyright © 2016,2017,2018,2019,2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
|
*
|
|
* This file is part of GNU Mes.
|
|
*
|
|
* GNU Mes is free software; you can redistribute it and/or modify it
|
|
* under the terms of the GNU General Public License as published by
|
|
* the Free Software Foundation; either version 3 of the License, or (at
|
|
* your option) any later version.
|
|
*
|
|
* GNU Mes is distributed in the hope that it will be useful, but
|
|
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
* GNU General Public License for more details.
|
|
*
|
|
* You should have received a copy of the GNU General Public License
|
|
* along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
*/
|
|
|
|
#include "mes/lib.h"
|
|
#include "mes/mes.h"
|
|
|
|
#include <string.h>
|
|
|
|
struct scm *
|
|
assert_defined (struct scm *x, struct scm *e) /*:((internal)) */
|
|
{
|
|
if (e == cell_undefined)
|
|
return error (cell_symbol_unbound_variable, x);
|
|
return e;
|
|
}
|
|
|
|
struct scm *
|
|
check_formals (struct scm *f, struct scm *formals, struct scm *args) /*:((internal)) */
|
|
{
|
|
long flen;
|
|
if (formals->type == TNUMBER)
|
|
flen = formals->value;
|
|
else
|
|
flen = length__ (formals);
|
|
long alen = length__ (args);
|
|
if (alen != flen && alen != -1 && flen != -1)
|
|
{
|
|
char *s = "apply: wrong number of arguments; expected: ";
|
|
eputs (s);
|
|
eputs (itoa (flen));
|
|
eputs (", got: ");
|
|
eputs (itoa (alen));
|
|
eputs ("\n");
|
|
write_error_ (f);
|
|
struct scm *e = make_string0 (s);
|
|
return error (cell_symbol_wrong_number_of_args, cons (e, f));
|
|
}
|
|
return cell_unspecified;
|
|
}
|
|
|
|
struct scm *
|
|
check_apply (struct scm *f, struct scm *e) /*:((internal)) */
|
|
{
|
|
char *type = 0;
|
|
if (f == cell_f || f == cell_t)
|
|
type = "bool";
|
|
if (f == cell_nil)
|
|
type = "nil";
|
|
if (f == cell_unspecified)
|
|
type = "*unspecified*";
|
|
if (f == cell_undefined)
|
|
type = "*undefined*";
|
|
if (f->type == TCHAR)
|
|
type = "char";
|
|
if (f->type == TNUMBER)
|
|
type = "number";
|
|
if (f->type == TSTRING)
|
|
type = "string";
|
|
if (f->type == TSTRUCT && builtin_p (f) == cell_f)
|
|
type = "#<...>";
|
|
if (f->type == TBROKEN_HEART)
|
|
type = "<3";
|
|
|
|
if (type != 0)
|
|
{
|
|
char *s = "cannot apply: ";
|
|
eputs (s);
|
|
eputs (type);
|
|
eputs ("[");
|
|
write_error_ (e);
|
|
eputs ("]\n");
|
|
struct scm *e = make_string0 (s);
|
|
return error (cell_symbol_wrong_type_arg, cons (e, f));
|
|
}
|
|
return cell_unspecified;
|
|
}
|
|
|
|
struct scm *
|
|
pairlis (struct scm *x, struct scm *y, struct scm *a)
|
|
{
|
|
if (x == cell_nil)
|
|
return a;
|
|
if (x->type != TPAIR)
|
|
return cons (cons (x, y), a);
|
|
return cons (cons (car (x), car (y)), pairlis (cdr (x), cdr (y), a));
|
|
}
|
|
|
|
struct scm *
|
|
set_car_x (struct scm *x, struct scm *e)
|
|
{
|
|
if (x->type != TPAIR)
|
|
error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("set-car!")));
|
|
x->car = e;
|
|
return cell_unspecified;
|
|
}
|
|
|
|
struct scm *
|
|
set_cdr_x (struct scm *x, struct scm *e)
|
|
{
|
|
if (x->type != TPAIR)
|
|
error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("set-cdr!")));
|
|
x->cdr = e;
|
|
return cell_unspecified;
|
|
}
|
|
|
|
struct scm *
|
|
set_env_x (struct scm *x, struct scm *e, struct scm *a)
|
|
{
|
|
struct scm *p;
|
|
if (x->type == TVARIABLE)
|
|
p = x->variable;
|
|
else
|
|
p = assert_defined (x, module_variable (a, x));
|
|
if (p->type != TPAIR)
|
|
error (cell_symbol_not_a_pair, cons (p, x));
|
|
return set_cdr_x (p, e);
|
|
}
|
|
|
|
struct scm *
|
|
call_lambda (struct scm *e, struct scm *x, struct scm *aa, struct scm *a) /*:((internal)) */
|
|
{
|
|
struct scm *cl = cons (cons (cell_closure, x), x);
|
|
R1 = e;
|
|
R0 = cl;
|
|
return cell_unspecified;
|
|
}
|
|
|
|
struct scm *
|
|
make_closure_ (struct scm *args, struct scm *body, struct scm *a) /*:((internal)) */
|
|
{
|
|
return make_cell (TCLOSURE, cell_f, cons (cons (cell_circular, a), cons (args, body)));
|
|
}
|
|
|
|
struct scm *
|
|
make_variable_ (struct scm *var) /*:((internal)) */
|
|
{
|
|
return make_cell (TVARIABLE, var, 0);
|
|
}
|
|
|
|
struct scm *
|
|
macro_get_handle (struct scm *name) /*:((internal)) */
|
|
{
|
|
if (name->type == TSYMBOL)
|
|
return hashq_get_handle (g_macros, name, cell_nil);
|
|
return cell_f;
|
|
}
|
|
|
|
struct scm *
|
|
get_macro (struct scm *name) /*:((internal)) */
|
|
{
|
|
struct scm *m = macro_get_handle (name);
|
|
if (m != cell_f)
|
|
{
|
|
struct scm *d = m->cdr;
|
|
return d->macro;
|
|
}
|
|
return cell_f;
|
|
}
|
|
|
|
struct scm *
|
|
macro_set_x (struct scm *name, struct scm *value) /*:((internal)) */
|
|
{
|
|
return hashq_set_x (g_macros, name, value);
|
|
}
|
|
|
|
struct scm *
|
|
push_cc (struct scm *p1, struct scm *p2, struct scm *a, struct scm *c) /*:((internal)) */
|
|
{
|
|
struct scm *x = R3;
|
|
R3 = c;
|
|
R2 = p2;
|
|
gc_push_frame ();
|
|
R1 = p1;
|
|
R0 = a;
|
|
R3 = x;
|
|
return cell_unspecified;
|
|
}
|
|
|
|
struct scm *
|
|
add_formals (struct scm *formals, struct scm *x)
|
|
{
|
|
while (x->type == TPAIR)
|
|
{
|
|
formals = cons (x->car, formals);
|
|
x = x->cdr;
|
|
}
|
|
if (x->type == TSYMBOL)
|
|
formals = cons (x, formals);
|
|
return formals;
|
|
}
|
|
|
|
int
|
|
formal_p (struct scm *x, struct scm *formals) /*:((internal)) */
|
|
{
|
|
if (formals->type == TSYMBOL)
|
|
{
|
|
if (x == formals)
|
|
return 1;
|
|
else
|
|
return 0;
|
|
}
|
|
while (formals->type == TPAIR)
|
|
{
|
|
if (formals->car == x)
|
|
break;
|
|
formals = formals->cdr;
|
|
}
|
|
if (formals->type == TSYMBOL)
|
|
return formals == x;
|
|
return formals->type == TPAIR;
|
|
}
|
|
|
|
struct scm *
|
|
expand_variable_ (struct scm *x, struct scm *formals, int top_p) /*:((internal)) */
|
|
{
|
|
struct scm *a;
|
|
struct scm *f;
|
|
struct scm *v;
|
|
while (x->type == TPAIR)
|
|
{
|
|
a = x->car;
|
|
if (a->type == TPAIR)
|
|
{
|
|
if (a->car == cell_symbol_lambda)
|
|
{
|
|
f = a->cdr->car;
|
|
formals = add_formals (formals, f);
|
|
}
|
|
else if (a->car == cell_symbol_define || a->car == cell_symbol_define_macro)
|
|
{
|
|
f = a->cdr->car;
|
|
formals = add_formals (formals, f);
|
|
}
|
|
if (a->car != cell_symbol_quote)
|
|
expand_variable_ (a, formals, 0);
|
|
}
|
|
else
|
|
{
|
|
if (a == cell_symbol_lambda)
|
|
{
|
|
f = x->cdr->car;
|
|
formals = add_formals (formals, f);
|
|
x = x->cdr;
|
|
}
|
|
else if (a == cell_symbol_define || a == cell_symbol_define_macro)
|
|
{
|
|
f = x->cdr->car;
|
|
if (top_p != 0 && f->type == TPAIR)
|
|
f = f->cdr;
|
|
formals = add_formals (formals, f);
|
|
x = x->cdr;
|
|
}
|
|
else if (a == cell_symbol_quote)
|
|
return cell_unspecified;
|
|
else if (a->type == TSYMBOL
|
|
&& a != cell_symbol_boot_module
|
|
&& a != cell_symbol_current_module
|
|
&& a != cell_symbol_primitive_load
|
|
&& formal_p (x->car, formals) == 0)
|
|
{
|
|
v = module_variable (R0, a);
|
|
if (v != cell_f)
|
|
x->car = make_variable_ (v);
|
|
}
|
|
}
|
|
x = x->cdr;
|
|
top_p = 0;
|
|
}
|
|
return cell_unspecified;
|
|
}
|
|
|
|
struct scm *
|
|
expand_variable (struct scm *x, struct scm *formals) /*:((internal)) */
|
|
{
|
|
return expand_variable_ (x, formals, 1);
|
|
}
|
|
|
|
struct scm *
|
|
apply_builtin (struct scm *fn, struct scm *x) /*:((internal)) */
|
|
{
|
|
struct scm *a = builtin_arity (fn);
|
|
struct scm *d;
|
|
int arity = a->value;
|
|
if ((arity > 0 || arity == -1) && x != cell_nil)
|
|
{
|
|
a = x->car;
|
|
if (a->type == TVALUES)
|
|
x = cons (a->cdr->car, x->cdr);
|
|
}
|
|
if ((arity > 1 || arity == -1) && x != cell_nil)
|
|
{
|
|
a = x->car;
|
|
d = x->cdr;
|
|
if (d->type == TPAIR)
|
|
if (d->car->type == TVALUES)
|
|
x = cons (a, cons (d->car->cdr->car, d));
|
|
}
|
|
|
|
if (arity == 0)
|
|
return apply_builtin0 (fn);
|
|
if (arity == 1)
|
|
return apply_builtin1 (fn, x->car);
|
|
else if (arity == 2)
|
|
return apply_builtin2 (fn, x->car, x->cdr->car);
|
|
else if (arity == 3)
|
|
return apply_builtin3 (fn, x->car, x->cdr->car, x->cdr->cdr->car);
|
|
else if (arity == -1)
|
|
return apply_builtin1 (fn, x);
|
|
|
|
return cell_unspecified;
|
|
}
|
|
|
|
struct scm *
|
|
eval_apply ()
|
|
{
|
|
struct scm *aa;
|
|
struct scm *args;
|
|
struct scm *body;
|
|
struct scm *cl;
|
|
struct scm *entry;
|
|
struct scm *expanders;
|
|
struct scm *formals;
|
|
struct scm *input;
|
|
struct scm *name;
|
|
struct scm *macro;
|
|
struct scm *p;
|
|
struct scm *program;
|
|
struct scm *sc_expand;
|
|
struct scm *v;
|
|
struct scm *x;
|
|
int global_p;
|
|
int macro_p;
|
|
struct scm *a;
|
|
struct scm *c;
|
|
struct scm *d;
|
|
int t;
|
|
long i;
|
|
|
|
eval_apply:
|
|
if (R3 == cell_vm_evlis2)
|
|
goto evlis2;
|
|
else if (R3 == cell_vm_evlis3)
|
|
goto evlis3;
|
|
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_apply2)
|
|
goto apply2;
|
|
else if (R3 == cell_vm_if_expr)
|
|
goto if_expr;
|
|
else if (R3 == cell_vm_begin_eval)
|
|
goto begin_eval;
|
|
else if (R3 == cell_vm_eval_set_x)
|
|
goto eval_set_x;
|
|
else if (R3 == cell_vm_macro_expand_car)
|
|
goto macro_expand_car;
|
|
else if (R3 == cell_vm_return)
|
|
goto vm_return;
|
|
else if (R3 == cell_vm_macro_expand_cdr)
|
|
goto macro_expand_cdr;
|
|
else if (R3 == cell_vm_eval_define)
|
|
goto eval_define;
|
|
else if (R3 == cell_vm_macro_expand)
|
|
goto macro_expand;
|
|
else if (R3 == cell_vm_macro_expand_lambda)
|
|
goto macro_expand_lambda;
|
|
else if (R3 == cell_vm_eval_pmatch_car)
|
|
goto eval_pmatch_car;
|
|
else if (R3 == cell_vm_begin_expand_macro)
|
|
goto begin_expand_macro;
|
|
else if (R3 == cell_vm_macro_expand_define)
|
|
goto macro_expand_define;
|
|
else if (R3 == cell_vm_begin_expand_eval)
|
|
goto begin_expand_eval;
|
|
else if (R3 == cell_vm_call_with_current_continuation2)
|
|
goto call_with_current_continuation2;
|
|
else if (R3 == cell_vm_macro_expand_set_x)
|
|
goto macro_expand_set_x;
|
|
else if (R3 == cell_vm_eval_pmatch_cdr)
|
|
goto eval_pmatch_cdr;
|
|
else if (R3 == cell_vm_macro_expand_define_macro)
|
|
goto macro_expand_define_macro;
|
|
else if (R3 == cell_vm_begin_primitive_load)
|
|
goto begin_primitive_load;
|
|
|
|
else if (R3 == cell_vm_evlis)
|
|
goto evlis;
|
|
else if (R3 == cell_vm_apply)
|
|
goto apply;
|
|
else if (R3 == cell_vm_eval)
|
|
goto eval;
|
|
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_begin)
|
|
goto begin;
|
|
else if (R3 == cell_vm_begin_expand)
|
|
goto begin_expand;
|
|
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_call_with_values2)
|
|
goto call_with_values2;
|
|
else if (R3 == cell_unspecified)
|
|
return R1;
|
|
else
|
|
assert_msg (0, "eval/apply unknown continuation");
|
|
|
|
evlis:
|
|
if (R1 == cell_nil)
|
|
goto vm_return;
|
|
if (R1->type != TPAIR)
|
|
goto eval;
|
|
push_cc (R1->car, R1, R0, cell_vm_evlis2);
|
|
goto eval;
|
|
evlis2:
|
|
push_cc (R2->cdr, R1, R0, cell_vm_evlis3);
|
|
goto evlis;
|
|
evlis3:
|
|
R1 = cons (R2, R1);
|
|
goto vm_return;
|
|
|
|
apply:
|
|
g_stack_array[g_stack + GC_FRAME_PROCEDURE] = R1->car;
|
|
a = R1->car;
|
|
t = a->type;
|
|
if (t == TSTRUCT && builtin_p (R1->car) == cell_t)
|
|
{
|
|
check_formals (R1->car, builtin_arity (R1->car), R1->cdr);
|
|
R1 = apply_builtin (R1->car, R1->cdr);
|
|
goto vm_return;
|
|
}
|
|
else if (t == TCLOSURE)
|
|
{
|
|
cl = R1->car->closure;
|
|
body = cl->cdr->cdr;
|
|
formals = cl->cdr->car;
|
|
args = R1->cdr;
|
|
aa = cl->car->cdr;
|
|
aa = aa->cdr;
|
|
check_formals (R1->car, formals, R1->cdr);
|
|
p = pairlis (formals, args, aa);
|
|
call_lambda (body, p, aa, R0);
|
|
goto begin;
|
|
}
|
|
else if (t == TCONTINUATION)
|
|
{
|
|
a = R1->car;
|
|
v = a->continuation;
|
|
if (v->length != 0)
|
|
{
|
|
for (i = 0; i < v->length; i = i + 1)
|
|
g_stack_array[STACK_SIZE - v->length + i] = vector_ref_ (v, i);
|
|
g_stack = STACK_SIZE - v->length;
|
|
}
|
|
x = R1;
|
|
gc_pop_frame ();
|
|
R1 = x->cdr->car;
|
|
goto eval_apply;
|
|
}
|
|
else if (t == TSPECIAL)
|
|
{
|
|
c = R1->car;
|
|
if (c == cell_vm_apply)
|
|
{
|
|
push_cc (cons (R1->cdr->car, R1->cdr->cdr->car), R1, R0, cell_vm_return);
|
|
goto apply;
|
|
}
|
|
else if (c == cell_vm_eval)
|
|
{
|
|
push_cc (R1->cdr->car, R1, R1->cdr->cdr->car, cell_vm_return);
|
|
goto eval;
|
|
}
|
|
else if (c == cell_vm_begin_expand)
|
|
{
|
|
push_cc (cons (R1->cdr->car, cell_nil), R1, R1->cdr->cdr->car, cell_vm_return);
|
|
goto begin_expand;
|
|
}
|
|
else
|
|
check_apply (cell_f, R1->car);
|
|
}
|
|
else if (t == TSYMBOL)
|
|
{
|
|
c = R1->car;
|
|
if (c == cell_symbol_call_with_current_continuation)
|
|
{
|
|
R1 = R1->cdr;
|
|
goto call_with_current_continuation;
|
|
}
|
|
if (c == cell_symbol_call_with_values)
|
|
{
|
|
R1 = R1->cdr;
|
|
goto call_with_values;
|
|
}
|
|
if (c == cell_symbol_current_module)
|
|
{
|
|
R1 = R0;
|
|
goto vm_return;
|
|
}
|
|
if (c == cell_symbol_boot_module)
|
|
{
|
|
R1 = M0;
|
|
goto vm_return;
|
|
}
|
|
}
|
|
else if (t == TPAIR)
|
|
{
|
|
if (R1->car->car == cell_symbol_lambda)
|
|
{
|
|
formals = R1->car->cdr->car;
|
|
args = R1->cdr;
|
|
body = R1->car->cdr->cdr;
|
|
p = pairlis (formals, R1->cdr, R0);
|
|
check_formals (R1, formals, args);
|
|
call_lambda (body, p, p, R0);
|
|
goto begin;
|
|
}
|
|
}
|
|
push_cc (R1->car, R1, R0, cell_vm_apply2);
|
|
goto eval;
|
|
apply2:
|
|
check_apply (R1, R2->car);
|
|
R1 = cons (R1, R2->cdr);
|
|
goto apply;
|
|
|
|
eval:
|
|
t = R1->type;
|
|
if (t == TPAIR)
|
|
{
|
|
c = R1->car;
|
|
if (c == cell_symbol_pmatch_car)
|
|
{
|
|
push_cc (R1->cdr->car, R1, R0, cell_vm_eval_pmatch_car);
|
|
goto eval;
|
|
eval_pmatch_car:
|
|
x = R1;
|
|
gc_pop_frame ();
|
|
R1 = x->car;
|
|
goto eval_apply;
|
|
}
|
|
else if (c == cell_symbol_pmatch_cdr)
|
|
{
|
|
push_cc (R1->cdr->car, R1, R0, cell_vm_eval_pmatch_cdr);
|
|
goto eval;
|
|
eval_pmatch_cdr:
|
|
x = R1;
|
|
gc_pop_frame ();
|
|
R1 = x->cdr;
|
|
goto eval_apply;
|
|
}
|
|
else if (c == cell_symbol_quote)
|
|
{
|
|
x = R1;
|
|
gc_pop_frame ();
|
|
R1 = x->cdr->car;
|
|
goto eval_apply;
|
|
}
|
|
else if (c == cell_symbol_begin)
|
|
goto begin;
|
|
else if (c == cell_symbol_lambda)
|
|
{
|
|
R1 = make_closure_ (R1->cdr->car, R1->cdr->cdr, R0);
|
|
goto vm_return;
|
|
}
|
|
else if (c == cell_symbol_if)
|
|
{
|
|
R1 = R1->cdr;
|
|
goto vm_if;
|
|
}
|
|
else if (c == cell_symbol_set_x)
|
|
{
|
|
push_cc (R1->cdr->cdr->car, R1, R0, cell_vm_eval_set_x);
|
|
goto eval;
|
|
eval_set_x:
|
|
R1 = set_env_x (R2->cdr->car, R1, R0);
|
|
goto vm_return;
|
|
}
|
|
else if (c == cell_vm_macro_expand)
|
|
{
|
|
push_cc (R1->cdr->car, 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 (R1->type == TPAIR)
|
|
if (R1->car == cell_symbol_define || R1->car == cell_symbol_define_macro)
|
|
{
|
|
global_p = 0;
|
|
if (R0->car->car != cell_closure)
|
|
global_p = 1;
|
|
macro_p = 0;
|
|
if (R1->car == cell_symbol_define_macro)
|
|
macro_p = 1;
|
|
if (global_p != 0)
|
|
{
|
|
name = R1->cdr->car;
|
|
aa = R1->cdr->car;
|
|
if (aa->type == TPAIR)
|
|
name = name->car;
|
|
if (macro_p != 0)
|
|
{
|
|
entry = assq (name, g_macros);
|
|
if (entry == cell_f)
|
|
macro_set_x (name, cell_f);
|
|
}
|
|
else
|
|
{
|
|
entry = module_variable (R0, name);
|
|
if (entry == cell_f)
|
|
module_define_x (M0, name, cell_f);
|
|
}
|
|
}
|
|
R2 = R1;
|
|
aa = R1->cdr->car;
|
|
if (aa->type != TPAIR)
|
|
{
|
|
push_cc (R1->cdr->cdr->car, R2, cons (cons (R1->cdr->car, R1->cdr->car), R0), cell_vm_eval_define);
|
|
goto eval;
|
|
}
|
|
else
|
|
{
|
|
p = pairlis (R1->cdr->car, R1->cdr->car, R0);
|
|
formals = R1->cdr->car->cdr;
|
|
body = R1->cdr->cdr;
|
|
|
|
if (macro_p != 0 || global_p != 0)
|
|
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 = R2->cdr->car;
|
|
aa = R2->cdr->car;
|
|
if (aa->type == TPAIR)
|
|
name = name->car;
|
|
if (macro_p != 0)
|
|
{
|
|
entry = macro_get_handle (name);
|
|
R1 = make_macro (name, R1);
|
|
set_cdr_x (entry, R1);
|
|
}
|
|
else if (global_p != 0)
|
|
{
|
|
entry = module_variable (R0, name);
|
|
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 = module_variable (R0, cell_closure);
|
|
set_cdr_x (cl, aa);
|
|
}
|
|
R1 = cell_unspecified;
|
|
goto vm_return;
|
|
}
|
|
push_cc (R1->car, R1, R0, cell_vm_eval_check_func);
|
|
gc_check ();
|
|
goto eval;
|
|
eval_check_func:
|
|
push_cc (R2->cdr, R2, R0, cell_vm_eval2);
|
|
goto evlis;
|
|
eval2:
|
|
R1 = cons (R2->car, R1);
|
|
goto apply;
|
|
}
|
|
}
|
|
else if (t == TSYMBOL)
|
|
{
|
|
if (R1 == cell_symbol_boot_module)
|
|
goto vm_return;
|
|
if (R1 == cell_symbol_current_module)
|
|
goto vm_return;
|
|
if (R1 == cell_symbol_begin)
|
|
goto vm_return;
|
|
if (R1 == cell_symbol_call_with_current_continuation)
|
|
goto vm_return;
|
|
R1 = assert_defined (R1, module_ref (R0, R1));
|
|
goto vm_return;
|
|
}
|
|
else if (t == TVARIABLE)
|
|
{
|
|
x = R1->variable;
|
|
R1 = x->cdr;
|
|
goto vm_return;
|
|
}
|
|
else if (t == TBROKEN_HEART)
|
|
error (cell_symbol_system_error, R1);
|
|
else
|
|
goto vm_return;
|
|
|
|
macro_expand:
|
|
if (R1->type != TPAIR || R1->car == cell_symbol_quote)
|
|
goto vm_return;
|
|
|
|
if (R1->car == cell_symbol_lambda)
|
|
{
|
|
push_cc (R1->cdr->cdr, R1, R0, cell_vm_macro_expand_lambda);
|
|
goto macro_expand;
|
|
macro_expand_lambda:
|
|
R2->cdr->cdr = R1;
|
|
R1 = R2;
|
|
goto vm_return;
|
|
}
|
|
|
|
if (R1->type == TPAIR)
|
|
{
|
|
macro = get_macro (R1->car);
|
|
if (macro != cell_f)
|
|
{
|
|
R1 = cons (macro, R1->cdr);
|
|
push_cc (R1, cell_nil, R0, cell_vm_macro_expand);
|
|
goto apply;
|
|
}
|
|
}
|
|
|
|
if (R1->car == cell_symbol_define || R1->car == cell_symbol_define_macro)
|
|
{
|
|
push_cc (R1->cdr->cdr, R1, R0, cell_vm_macro_expand_define);
|
|
goto macro_expand;
|
|
macro_expand_define:
|
|
R2->cdr->cdr = R1;
|
|
R1 = R2;
|
|
if (R1->car == cell_symbol_define_macro)
|
|
{
|
|
push_cc (R1, R1, R0, cell_vm_macro_expand_define_macro);
|
|
goto eval;
|
|
macro_expand_define_macro:
|
|
R1 = R2;
|
|
}
|
|
goto vm_return;
|
|
}
|
|
|
|
if (R1->car == cell_symbol_set_x)
|
|
{
|
|
push_cc (R1->cdr->cdr, R1, R0, cell_vm_macro_expand_set_x);
|
|
goto macro_expand;
|
|
macro_expand_set_x:
|
|
R2->cdr->cdr = R1;
|
|
R1 = R2;
|
|
goto vm_return;
|
|
}
|
|
|
|
if (R1->type == TPAIR)
|
|
{
|
|
a = R1->car;
|
|
if (a->type == TSYMBOL && a != cell_symbol_begin)
|
|
{
|
|
macro = macro_get_handle (cell_symbol_portable_macro_expand);
|
|
if (macro != cell_f)
|
|
{
|
|
expanders = module_ref (R0, cell_symbol_sc_expander_alist);
|
|
if (expanders != cell_undefined)
|
|
{
|
|
macro = assq (R1->car, expanders);
|
|
if (macro != cell_f)
|
|
{
|
|
sc_expand = module_ref (R0, cell_symbol_macro_expand);
|
|
R2 = R1;
|
|
if (sc_expand != cell_undefined && sc_expand != cell_f)
|
|
{
|
|
R1 = cons (sc_expand, cons (R1, cell_nil));
|
|
goto apply;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
push_cc (R1->car, R1, R0, cell_vm_macro_expand_car);
|
|
goto macro_expand;
|
|
|
|
macro_expand_car:
|
|
R2->car = R1;
|
|
R1 = R2;
|
|
if (R1->cdr == cell_nil)
|
|
goto vm_return;
|
|
|
|
push_cc (R1->cdr, R1, R0, cell_vm_macro_expand_cdr);
|
|
goto macro_expand;
|
|
|
|
macro_expand_cdr:
|
|
R2->cdr = R1;
|
|
R1 = R2;
|
|
|
|
goto vm_return;
|
|
|
|
begin:
|
|
x = cell_unspecified;
|
|
while (R1 != cell_nil)
|
|
{
|
|
gc_check ();
|
|
if (R1->type == TPAIR)
|
|
{
|
|
if (R1->car->car == cell_symbol_primitive_load)
|
|
{
|
|
program = cons (R1->car, cell_nil);
|
|
push_cc (program, R1, R0, cell_vm_begin_primitive_load);
|
|
goto begin_expand;
|
|
begin_primitive_load:
|
|
R2->car = R1;
|
|
R1 = R2;
|
|
}
|
|
}
|
|
|
|
if (R1->type == TPAIR)
|
|
{
|
|
a = R1->car;
|
|
if (a->type == TPAIR)
|
|
{
|
|
if (a->car == cell_symbol_begin)
|
|
R1 = append2 (a->cdr, R1->cdr);
|
|
}
|
|
}
|
|
if (R1->cdr == cell_nil)
|
|
{
|
|
R1 = R1->car;
|
|
goto eval;
|
|
}
|
|
push_cc (R1->car, R1, R0, cell_vm_begin_eval);
|
|
goto eval;
|
|
begin_eval:
|
|
x = R1;
|
|
R1 = R2->cdr;
|
|
}
|
|
R1 = x;
|
|
goto vm_return;
|
|
|
|
|
|
begin_expand:
|
|
x = cell_unspecified;
|
|
while (R1 != cell_nil)
|
|
{
|
|
begin_expand_while:
|
|
gc_check ();
|
|
|
|
if (R1->type == TPAIR)
|
|
{
|
|
a = R1->car;
|
|
if (a->type == TPAIR)
|
|
if (R1->car->car == cell_symbol_begin)
|
|
R1 = append2 (R1->car->cdr, R1->cdr);
|
|
if (R1->car->car == cell_symbol_primitive_load)
|
|
{
|
|
push_cc (R1->car->cdr->car, R1, R0, cell_vm_begin_expand_primitive_load);
|
|
goto eval;
|
|
begin_expand_primitive_load:
|
|
if ((R1->type == TNUMBER) && R1->value == 0)
|
|
0;
|
|
else if (R1->type == TSTRING)
|
|
input = set_current_input_port (open_input_file (R1));
|
|
else if (R1->type == TPORT)
|
|
input = set_current_input_port (R1);
|
|
else
|
|
{
|
|
eputs ("begin_expand failed, R1=");
|
|
display_error_ (R1);
|
|
assert_msg (0, "begin-expand-boom 0");
|
|
}
|
|
|
|
push_cc (input, R2, R0, cell_vm_return);
|
|
x = read_input_file_env (R0);
|
|
if (g_debug > 5)
|
|
module_printer (M0);
|
|
gc_pop_frame ();
|
|
input = R1;
|
|
R1 = x;
|
|
set_current_input_port (input);
|
|
R1 = cons (cell_symbol_begin, R1);
|
|
R2->car = R1;
|
|
R1 = R2;
|
|
goto begin_expand_while;
|
|
continue; /* FIXME: M2-PLanet */
|
|
}
|
|
}
|
|
|
|
push_cc (R1->car, R1, R0, cell_vm_begin_expand_macro);
|
|
goto macro_expand;
|
|
begin_expand_macro:
|
|
if (R1 != R2->car)
|
|
{
|
|
R2->car = R1;
|
|
R1 = R2;
|
|
goto begin_expand_while;
|
|
continue; /* FIXME: M2-PLanet */
|
|
}
|
|
R1 = R2;
|
|
expand_variable (R1->car, cell_nil);
|
|
push_cc (R1->car, R1, R0, cell_vm_begin_expand_eval);
|
|
goto eval;
|
|
begin_expand_eval:
|
|
x = R1;
|
|
R1 = R2->cdr;
|
|
}
|
|
R1 = x;
|
|
goto vm_return;
|
|
|
|
vm_if:
|
|
push_cc (R1->car, R1, R0, cell_vm_if_expr);
|
|
goto eval;
|
|
if_expr:
|
|
x = R1;
|
|
R1 = R2;
|
|
if (x != cell_f)
|
|
{
|
|
R1 = R1->cdr->car;
|
|
goto eval;
|
|
}
|
|
if (R1->cdr->cdr != cell_nil)
|
|
{
|
|
R1 = R1->cdr->cdr->car;
|
|
goto eval;
|
|
}
|
|
R1 = cell_unspecified;
|
|
goto vm_return;
|
|
|
|
call_with_current_continuation:
|
|
gc_push_frame ();
|
|
x = make_continuation (g_continuations);
|
|
g_continuations = g_continuations + 1;
|
|
v = make_vector_ (STACK_SIZE - g_stack, cell_unspecified);
|
|
for (i = g_stack; i < STACK_SIZE; i = i + 1)
|
|
vector_set_x_ (v, i - g_stack, g_stack_array[i]);
|
|
x->continuation = v;
|
|
gc_pop_frame ();
|
|
push_cc (cons (R1->car, cons (x, cell_nil)), x, R0, cell_vm_call_with_current_continuation2);
|
|
goto apply;
|
|
call_with_current_continuation2:
|
|
v = make_vector_ (STACK_SIZE - g_stack, cell_unspecified);
|
|
for (i = g_stack; i < STACK_SIZE; i = i + 1)
|
|
vector_set_x_ (v, i - g_stack, g_stack_array[i]);
|
|
R2->continuation = v;
|
|
goto vm_return;
|
|
|
|
call_with_values:
|
|
push_cc (cons (R1->car, cell_nil), R1, R0, cell_vm_call_with_values2);
|
|
goto apply;
|
|
call_with_values2:
|
|
if (R1->type == TVALUES)
|
|
R1 = R1->cdr;
|
|
R1 = cons (R2->cdr->car, R1);
|
|
goto apply;
|
|
|
|
vm_return:
|
|
x = R1;
|
|
gc_pop_frame ();
|
|
R1 = x;
|
|
goto eval_apply;
|
|
}
|
|
|
|
struct scm *
|
|
apply (struct scm *f, struct scm *x, struct scm *a) /*:((internal)) */
|
|
{
|
|
push_cc (cons (f, x), cell_unspecified, R0, cell_unspecified);
|
|
R3 = cell_vm_apply;
|
|
return eval_apply ();
|
|
}
|