709 lines
19 KiB
C
709 lines
19 KiB
C
/*
|
|
*
|
|
* e v a l . c -- The evaluator
|
|
*
|
|
* Copyright © 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
*
|
|
*
|
|
* Permission to use, copy, and/or distribute this software and its
|
|
* documentation for any purpose and without fee is hereby granted, provided
|
|
* that both the above copyright notice and this permission notice appear in
|
|
* all copies and derived works. Fees for distribution or use of this
|
|
* software or derived works may only be charged with express written
|
|
* permission of the copyright holder.
|
|
* This software is provided ``as is'' without express or implied warranty.
|
|
*
|
|
* This software is a derivative work of other copyrighted softwares; the
|
|
* copyright notices of these softwares are placed in the file COPYRIGHTS
|
|
*
|
|
* $Id: eval.c 1.16 Sat, 26 Dec 1998 21:46:25 +0100 eg $
|
|
*
|
|
* Author: Erick Gallesio [eg@kaolin.unice.fr]
|
|
* Creation date: 23-Oct-1993 21:37
|
|
* Last file update: 26-Dec-1998 21:43
|
|
*/
|
|
|
|
#include "stk.h"
|
|
#include "extend.h"
|
|
#ifdef USE_STKLOS
|
|
# include "stklos.h"
|
|
#endif
|
|
|
|
#define RETURN(x) {tmp = (x); goto Out; }
|
|
|
|
/*
|
|
* STk_eval_flag indicates if eval has something to test (a ^C has
|
|
* occured, a eval-hook to apply, ...). Using this flag allow to
|
|
* minimize the number of tests done in eval the eval function (which
|
|
* must be as fast as possible since we spent most of our time in it).
|
|
* When this flag is up, the set of possible "diverting" things are
|
|
* tested.
|
|
* This flag could also probably used for implementing a thread mechanism.
|
|
*
|
|
*/
|
|
|
|
int STk_eval_flag = 0;
|
|
|
|
|
|
/*
|
|
*
|
|
* Utilities
|
|
*
|
|
*/
|
|
|
|
static SCM extend_env(SCM proc, SCM actuals, SCM call, int len)
|
|
{
|
|
register int arity = CLOSARITY(proc);
|
|
|
|
/* Code is weird, but we do only 2 tests for corrects call */
|
|
if (arity >= 0) {
|
|
if (arity == len) return add_frame(CLOSPARAMS(proc), actuals, CLOSENV(proc));
|
|
if (len < arity) goto TooFew;
|
|
goto TooMuch;
|
|
}
|
|
/* arity is < 0 <=> proc has an &rest argument */
|
|
if (len >= (-arity)-1)
|
|
/* When the procedure has a &rest parameter, we add a new environment
|
|
* in front of the extended environment. This environment is only useful
|
|
* for procedures which have internal defines (which will be placed in
|
|
* this empty environment). This empty environment is not created for
|
|
* non &rest procedure since it costs (and there is perhaps no define
|
|
* in the proc!).
|
|
*/
|
|
return add_frame(NIL, NIL, add_frame(CLOSPARAMS(proc), actuals, CLOSENV(proc)));
|
|
TooFew:
|
|
Err("too few arguments to", call);
|
|
TooMuch:
|
|
Err("too many arguments to", call);
|
|
return UNDEFINED; /* never reached */
|
|
}
|
|
|
|
static SCM eval_args(SCM l, SCM env)
|
|
{
|
|
SCM result,v1,v2;
|
|
|
|
if (NULLP(l)) return NIL;
|
|
|
|
v1 = result = Cons(EVALCAR(l), NIL);
|
|
|
|
for(v2=CDR(l); CONSP(v2); v2=CDR(v2)) {
|
|
v1 = CDR(v1) = Cons(EVALCAR(v2),NIL);
|
|
}
|
|
return result;
|
|
}
|
|
|
|
static SCM eval_cond(SCM *pform, SCM env)
|
|
{
|
|
SCM l, clause, tmp, res = Truth;
|
|
|
|
for (l=*pform; NNULLP(l); l = CDR(l)) {
|
|
clause = CAR(l);
|
|
/* We are sure that clause is a cons here (see syntax_cond) */
|
|
if (EQ(CAR(clause), Sym_else) || (res=EVALCAR(clause)) != Ntruth) {
|
|
tmp = CDR(clause);
|
|
if (NULLP(tmp)) SYNTAX_RETURN(res, Ntruth);
|
|
if (NCONSP(tmp)) goto Error;
|
|
|
|
if (EQ(CAR(tmp), Sym_imply)) {
|
|
/* Clause is ((condition) => function) */
|
|
if (STk_llength(tmp) != 2) Err("cond: malformed `=>'", tmp);
|
|
SYNTAX_RETURN(Apply(EVALCAR(CDR(tmp)), LIST1(res)), Ntruth);
|
|
}
|
|
else {
|
|
for( ; NNULLP(CDR(tmp)); tmp=CDR(tmp))
|
|
EVALCAR(tmp);
|
|
SYNTAX_RETURN(CAR(tmp), Truth);
|
|
}
|
|
}
|
|
}
|
|
SYNTAX_RETURN(UNDEFINED, Ntruth);
|
|
Error:
|
|
Err("cond: bad clause body", clause);
|
|
return UNDEFINED; /* never reached */
|
|
}
|
|
|
|
|
|
/*
|
|
* Eval stack
|
|
*
|
|
* The eval stack is a stack of the arguments passed to eval. This stack permits
|
|
* to facilitate debugging of Scheme programs. Its contents is displayed
|
|
* when an error occurs.
|
|
* Note that "STk_eval_stack" does'nt need to be protected since it contains
|
|
* pointers which are themselves copies of the eval C routine. Eval parameters
|
|
* will be marked as are all the objects which are in the C stack
|
|
* */
|
|
|
|
static struct Stack_info {
|
|
SCM expr, env;
|
|
struct Stack_info *previous;
|
|
} *stack = NULL;
|
|
|
|
void STk_show_eval_stack(int depth, int uncode)
|
|
{
|
|
int j;
|
|
struct Stack_info *p;
|
|
|
|
Fprintf(STk_curr_eport, "\nCurrent eval stack:\n__________________\n");
|
|
for (p=stack, j=0; p && j<=depth ; p=p->previous, j++) {
|
|
Fprintf(STk_curr_eport, "%3d ", j);
|
|
/* if !uncode we are in panic mode (i.e. don't allocate during printing) */
|
|
if (uncode)
|
|
STk_print(STk_uncode(p->expr), STk_curr_eport, WRT_MODE);
|
|
else
|
|
STk_print(p->expr, STk_curr_eport, PANIC_MODE);
|
|
Putc('\n', STk_curr_eport);
|
|
if (j == depth && p->previous) Puts("...\n", STk_curr_eport);
|
|
}
|
|
}
|
|
|
|
|
|
void STk_reset_eval_stack(void)
|
|
{
|
|
stack = NULL;
|
|
}
|
|
|
|
|
|
PRIMITIVE STk_user_get_eval_stack(void)
|
|
{
|
|
struct Stack_info *p;
|
|
SCM z;
|
|
|
|
if (stack) {
|
|
z = NIL;
|
|
for (p = stack; p ; p = p->previous)
|
|
z = Cons(p->expr, z);
|
|
return STk_reverse(z);
|
|
}
|
|
return NIL;
|
|
}
|
|
|
|
PRIMITIVE STk_get_env_stack(void)
|
|
{
|
|
struct Stack_info *p;
|
|
SCM z;
|
|
|
|
if (stack) {
|
|
z = NIL;
|
|
for (p = stack; p ; p = p->previous) {
|
|
/* Avoid to create an environment for each item */
|
|
SCM tmp = (z!=NIL && STk_equal(CAR(z)->storage_as.env.data,p->env)==Truth) ?
|
|
CAR(z):
|
|
STk_makeenv(p->env, 0);
|
|
z = Cons(tmp, z);
|
|
}
|
|
return STk_reverse(z);
|
|
}
|
|
return NIL;
|
|
}
|
|
|
|
|
|
/*
|
|
* *eval-hook* management.
|
|
*
|
|
* STk eval-hook mechanism is similar to the CL one. The *eval-hook*
|
|
* Scheme variable is managed as a C-variable which has a getter and a
|
|
* setter function associated to it. The functions below allow to
|
|
* manage a stack of hooks in the C stack. Each hook info is stored in
|
|
* a Eval_hook_info structure
|
|
*
|
|
*/
|
|
|
|
struct Eval_hook_info {
|
|
SCM hook;
|
|
int bypass_check;
|
|
struct Eval_hook_info *previous;
|
|
};
|
|
|
|
static struct Eval_hook_info eval_hook_bottom;
|
|
static struct Eval_hook_info *eval_hook_stack = &eval_hook_bottom;
|
|
|
|
|
|
static SCM get_eval_hook(char *s)
|
|
{
|
|
return eval_hook_stack->hook;
|
|
}
|
|
|
|
static void set_eval_hook(char *unused, SCM value)
|
|
{
|
|
if (value == Ntruth) {
|
|
eval_hook_stack = &eval_hook_bottom;
|
|
eval_hook_stack->hook = Ntruth;
|
|
}
|
|
else {
|
|
if (STk_procedurep(value) == Ntruth)
|
|
STk_err("Hook value must be #f or a procedure. It is", value);
|
|
|
|
eval_hook_stack->hook = value;
|
|
eval_hook_stack->bypass_check = FALSE;
|
|
STk_eval_flag = TRUE;
|
|
}
|
|
}
|
|
|
|
static SCM handle_eval_hook(SCM x, SCM env)
|
|
{
|
|
struct Eval_hook_info info;
|
|
SCM res;
|
|
|
|
/* Reset eval-hook to avoid recursive application */
|
|
info.previous = eval_hook_stack;
|
|
info.hook = Ntruth;
|
|
info.bypass_check = FALSE;
|
|
eval_hook_stack = &info;
|
|
|
|
/* Call user code */
|
|
res = STk_apply(info.previous->hook, LIST2(x, STk_makeenv(env, 0)));
|
|
|
|
/* If we are here, everything was correct */
|
|
eval_hook_stack = info.previous;
|
|
STk_eval_flag = 1;
|
|
return res;
|
|
}
|
|
|
|
|
|
void STk_reset_eval_hook(void)
|
|
{
|
|
eval_hook_stack = &eval_hook_bottom;
|
|
eval_hook_stack->hook = Ntruth;
|
|
eval_hook_stack->bypass_check = FALSE;
|
|
eval_hook_stack->previous = &eval_hook_bottom; /* itself */
|
|
}
|
|
|
|
|
|
void STk_init_eval_hook(void)
|
|
{
|
|
STk_define_C_variable(EVAL_HOOK, get_eval_hook, set_eval_hook);
|
|
STk_gc_protect(&eval_hook_bottom.hook);
|
|
STk_reset_eval_hook();
|
|
}
|
|
|
|
|
|
PRIMITIVE STk_eval_hook(SCM x, SCM env, SCM hook)
|
|
{
|
|
SCM res;
|
|
struct Eval_hook_info info;
|
|
|
|
info.hook = hook;
|
|
info.bypass_check = TRUE;
|
|
info.previous = eval_hook_stack;
|
|
eval_hook_stack = &info;
|
|
STk_eval_flag = 1;
|
|
|
|
res = STk_eval(x, env->storage_as.env.data);
|
|
eval_hook_stack = info.previous;
|
|
STk_eval_flag = 1;
|
|
|
|
return res;
|
|
}
|
|
|
|
/*
|
|
*
|
|
* E V A L
|
|
*
|
|
*/
|
|
|
|
SCM STk_eval(SCM x, SCM env)
|
|
{
|
|
register SCM tmp, fct;
|
|
register int len;
|
|
struct Stack_info infos;
|
|
|
|
infos.previous = stack; stack = &infos;
|
|
Top:
|
|
infos.expr = x; infos.env = env;
|
|
if (STk_eval_flag) {
|
|
/* We have something to test before evaluating the form:
|
|
* - a ^C ?
|
|
* - *eval-hook*?
|
|
*/
|
|
if (STk_control_C) {
|
|
STk_handle_sigint_signal();
|
|
}
|
|
if (eval_hook_stack->hook != Ntruth) {
|
|
if (eval_hook_stack->bypass_check) {
|
|
eval_hook_stack->bypass_check = FALSE;
|
|
if (CONSP(x)) {
|
|
fct = EVAL(CAR(x)); /* Don't use EVALCAR here of course */
|
|
goto Apply_args;
|
|
}
|
|
}
|
|
else
|
|
RETURN(handle_eval_hook(x, env));
|
|
}
|
|
STk_eval_flag = STk_control_C || (eval_hook_stack->hook != Ntruth);
|
|
}
|
|
|
|
switch TYPE(x) {
|
|
case tc_symbol:
|
|
RETURN(*STk_varlookup(x, env, 1));
|
|
case tc_globalvar:
|
|
RETURN(VCELL(VCELL(x)));
|
|
case tc_localvar:
|
|
RETURN(STk_localvalue(x, env));
|
|
case tc_modulevar:
|
|
RETURN(STk_modulevalue(x));
|
|
case tc_cons: {
|
|
/* Evaluate the first argument of this list (without calling eval) */
|
|
tmp = CAR(x);
|
|
switch TYPE(tmp) {
|
|
case tc_symbol:
|
|
fct=*STk_varlookup(x, env, 1);
|
|
break;
|
|
case tc_cons:
|
|
fct = EVAL(tmp); break;
|
|
case tc_globalvar:
|
|
fct = VCELL(VCELL(tmp)); break;
|
|
case tc_localvar:
|
|
fct = STk_localvalue(tmp, env); break;
|
|
case tc_modulevar:
|
|
fct = STk_modulevalue(tmp); break;
|
|
default:
|
|
fct = tmp;
|
|
}
|
|
|
|
Apply_args:
|
|
/* Find length of the parameter list */
|
|
for (len=0, tmp=CDR(x); NNULLP(tmp); len++, tmp=CDR(tmp))
|
|
if (NCONSP(tmp)) Err("eval: malformed list", x);
|
|
|
|
/* apply parameters to fct */
|
|
tmp = CDR(x);
|
|
switch (TYPE(fct)) {
|
|
case tc_subr_0:
|
|
if (len == 0) RETURN(SUBR0(fct)());
|
|
goto Error;
|
|
case tc_subr_1:
|
|
if (len == 1) RETURN(SUBRF(fct)(EVALCAR(tmp)));
|
|
goto Error;
|
|
case tc_subr_2:
|
|
if (len == 2) RETURN(SUBRF(fct)(EVALCAR(tmp),
|
|
EVALCAR(CDR(tmp))));
|
|
goto Error;
|
|
case tc_subr_3:
|
|
if (len == 3) RETURN(SUBRF(fct)(EVALCAR(tmp),
|
|
EVALCAR(CDR(tmp)),
|
|
EVALCAR(CDR(CDR(tmp)))));
|
|
goto Error;
|
|
case tc_subr_0_or_1:
|
|
switch (len) {
|
|
case 0: RETURN(SUBRF(fct)(UNBOUND));
|
|
case 1: RETURN(SUBRF(fct)(EVALCAR(tmp)));
|
|
default: goto Error;
|
|
}
|
|
case tc_subr_1_or_2:
|
|
switch (len) {
|
|
case 1: RETURN(SUBRF(fct)(EVALCAR(tmp), UNBOUND));
|
|
case 2: RETURN(SUBRF(fct)(EVALCAR(tmp),
|
|
EVALCAR(CDR(tmp))));
|
|
default: goto Error;
|
|
}
|
|
case tc_subr_2_or_3:
|
|
switch (len) {
|
|
case 2: RETURN(SUBRF(fct)(EVALCAR(tmp),
|
|
EVALCAR(CDR(tmp)),
|
|
UNBOUND));
|
|
case 3: RETURN(SUBRF(fct)(EVALCAR(tmp),
|
|
EVALCAR(CDR(tmp)),
|
|
EVALCAR(CDR(CDR(tmp)))));
|
|
default: goto Error;
|
|
}
|
|
case tc_ssubr:
|
|
RETURN(SUBRF(fct)(tmp, env, TRUE));
|
|
case tc_fsubr:
|
|
RETURN(SUBRF(fct)(tmp, env, len));
|
|
case tc_syntax:
|
|
if (SUBRF(fct)(&x, env, len) == Truth) goto Top;
|
|
RETURN(x);
|
|
case tc_lsubr:
|
|
RETURN(SUBRF(fct)(eval_args(tmp, env), len));
|
|
#ifdef USE_STKLOS
|
|
case tc_instance:
|
|
tmp = eval_args(tmp, env);
|
|
if (PUREGENERICP(fct)) {
|
|
/* Do it in C */
|
|
SCM methods;
|
|
|
|
if (NULLP(THE_SLOT_OF(fct, S_methods)))
|
|
Apply(STk_STklos_value(Intern("no-method")), LIST2(fct, tmp));
|
|
|
|
methods = STk_compute_applicable_methods(fct, tmp, len, FALSE);
|
|
/* methods is the list of applicable methods. Apply the
|
|
* first one with the tail of the list as first
|
|
* parameter (next-method). If fct is NIL, that's because
|
|
* the no-applicable-method triggered didn't call error.
|
|
*/
|
|
if (NULLP(methods)) RETURN(UNDEFINED);
|
|
tmp = Cons(FASTMETHODP(CAR(methods))?
|
|
UNBOUND:
|
|
STk_make_next_method(CDR(methods),tmp,fct),
|
|
tmp);
|
|
fct = THE_SLOT_OF(CAR(methods), S_procedure);
|
|
env = extend_env(fct, tmp, x, len+1);
|
|
tmp = CLOSBODY(fct);
|
|
goto Begin;
|
|
}
|
|
else
|
|
/* Do it in Scheme */
|
|
RETURN(STk_apply_user_generic(fct, tmp));
|
|
|
|
case tc_next_method:
|
|
/* By nature, next methods cannot be recursive; so, we can
|
|
* call the apply-next-method function */
|
|
RETURN(STk_apply_next_method(fct, eval_args(tmp, env)));
|
|
#endif
|
|
#ifdef USE_TK
|
|
case tc_tkcommand:
|
|
RETURN(STk_execute_Tcl_lib_cmd(fct, tmp, env, 1));
|
|
#endif
|
|
case tc_closure:
|
|
env = extend_env(fct, eval_args(tmp, env), x, len);
|
|
tmp = CLOSBODY(fct);
|
|
/* NOBREAK */
|
|
Begin: case tc_begin:
|
|
for( ; NNULLP(CDR(tmp)); tmp=CDR(tmp))
|
|
EVALCAR(tmp);
|
|
x = CAR(tmp);
|
|
goto Top;
|
|
case tc_cont:
|
|
STk_throw(fct, eval_args(tmp, env));
|
|
case tc_let:
|
|
env = add_frame(CAR(tmp), eval_args(CAR(CDR(tmp)),env), env);
|
|
tmp = CDR(CDR(tmp));
|
|
goto Begin;
|
|
case tc_letstar:
|
|
{
|
|
SCM l1=CAR(tmp), l2=CAR(CDR(tmp));
|
|
/* Create a rib to avoid that internal def be seen as global */
|
|
env = add_frame(NIL, NIL, env);
|
|
for ( ; NNULLP(l1); l1=CDR(l1), l2=CDR(l2))
|
|
env = add_frame(LIST1(CAR(l1)), LIST1(EVALCAR(l2)), env);
|
|
tmp = CDR(CDR(tmp));
|
|
goto Begin;
|
|
}
|
|
case tc_letrec:
|
|
{
|
|
SCM bindings = NIL, l1=CAR(tmp), l2=CAR(CDR(tmp));
|
|
|
|
/* Make a binding list an extend current with it */
|
|
for (len=STk_llength(l1); len; len--)
|
|
bindings=Cons(UNBOUND,bindings);
|
|
env = add_frame(l1, bindings, env);
|
|
|
|
/* Eval init forms in the new environment */
|
|
for (l1 = CAR(tmp); NNULLP(l1); l1=CDR(l1), l2=CDR(l2))
|
|
*(STk_varlookup(CAR(l1), env, 0)) = EVALCAR(l2);
|
|
|
|
/* Evaluate body */
|
|
tmp = CDR(CDR(tmp));
|
|
goto Begin;
|
|
}
|
|
case tc_macro:
|
|
x = Apply(fct->storage_as.macro.code, x);
|
|
/*FIXME: x = Apply(fct->storage_as.macro.code, Cons(fct, tmp)); */
|
|
/* if (fct->storage_as.macro.env != Ntruth) {
|
|
printf("FIXME: ==========>R5 macro\n");
|
|
env = fct->storage_as.macro.env;
|
|
}
|
|
*/
|
|
goto Top;
|
|
case tc_quote:
|
|
RETURN(CAR(tmp));
|
|
case tc_lambda:
|
|
RETURN(STk_makeclosure(tmp, env));
|
|
case tc_if:
|
|
x = NEQ(EVALCAR(tmp), Ntruth) ? CAR(CDR(tmp))
|
|
: CAR(CDR(CDR(tmp)));
|
|
goto Top;
|
|
case tc_setq:
|
|
*(STk_varlookup(CAR(tmp), env, 0)) = EVALCAR(CDR(tmp));
|
|
if (TRACED_VARP(CAR(tmp))) STk_change_value(CAR(tmp), env);
|
|
RETURN(UNDEFINED);
|
|
case tc_cond:
|
|
/* Don't use tmp because
|
|
* 1) it's in a register
|
|
* 2) we can arrive from tc_syntax
|
|
*/
|
|
x = CDR(x); /* x is a "normal" var */
|
|
if (eval_cond(&x, env) == Truth) goto Top;
|
|
RETURN(x);
|
|
case tc_and:
|
|
if (!len) RETURN(Truth);
|
|
for (--len ; len; len--, tmp=CDR(tmp))
|
|
if (EVALCAR(tmp) == Ntruth) RETURN(Ntruth);
|
|
x=CAR(tmp);
|
|
goto Top;
|
|
case tc_or:
|
|
if (!len) RETURN(Ntruth);
|
|
for (--len; len; len--, tmp=CDR(tmp))
|
|
if ((fct=EVALCAR(tmp)) != Ntruth) RETURN(fct);
|
|
x=CAR(tmp);
|
|
goto Top;
|
|
case tc_call_cc:
|
|
if (len != 1) goto Error;
|
|
x = EVALCAR(tmp);
|
|
if (STk_do_call_cc(&x) == Truth) goto Top;
|
|
RETURN(x);
|
|
case tc_extend_env:
|
|
fct = EVALCAR(tmp);
|
|
if (NENVP(fct)) Err("extend-environment: bad environment", fct);
|
|
tmp = CDR(tmp);
|
|
env = STk_append2(fct->storage_as.env.data, env);
|
|
goto Begin;
|
|
case tc_apply:
|
|
if (!len) goto Error_Apply;
|
|
tmp = eval_args(tmp, env);
|
|
fct = CAR(tmp);
|
|
tmp = STk_liststar(CDR(tmp),len-1);
|
|
len = STk_llength(tmp);
|
|
if (len == -1) goto Error_Apply;
|
|
|
|
switch (TYPE(fct)) {
|
|
case tc_closure: env = extend_env(fct, tmp, x, len);
|
|
tmp = CLOSBODY(fct);
|
|
goto Begin;
|
|
case tc_apply: /* Here we are not tail recursive. (i.e. when
|
|
* we have something like (apply apply f ...)
|
|
* We cannot use a goto, since we should go again
|
|
* in tc_apply which will re-evaluates its
|
|
* parameters. However, this kind of call
|
|
* should be rare ...
|
|
*/
|
|
RETURN(Apply(fct, tmp));
|
|
case tc_call_cc:
|
|
case tc_dynwind: x=Cons(fct, tmp);
|
|
goto Top;
|
|
#ifdef USE_STKLOS
|
|
case tc_instance:
|
|
RETURN(STk_apply_generic(fct, tmp));
|
|
case tc_next_method:
|
|
RETURN(STk_apply_next_method(fct,tmp));
|
|
#endif
|
|
default: RETURN(Apply(fct, tmp));
|
|
}
|
|
Error_Apply:
|
|
Err("apply: bad parameter list", tmp);
|
|
default:
|
|
if (EXTENDEDP(fct)) {
|
|
if (STk_extended_eval_parameters(fct))
|
|
tmp = eval_args(tmp, env);
|
|
RETURN(STk_extended_apply(fct, tmp, env));
|
|
}
|
|
Err("eval: bad function in ", x);
|
|
}
|
|
}
|
|
default:
|
|
RETURN(x);
|
|
}
|
|
Out:
|
|
stack = infos.previous;
|
|
return tmp;
|
|
|
|
Error:
|
|
Err("eval: Bad number of parameters", x);
|
|
return UNDEFINED; /* never reached */
|
|
}
|
|
|
|
|
|
SCM STk_apply(SCM fct, SCM param)
|
|
{
|
|
Top:
|
|
switch TYPE(fct) {
|
|
case tc_subr_0:
|
|
if (NULLP(param)) return SUBR0(fct)();
|
|
break;
|
|
case tc_subr_1:
|
|
if (STk_llength(param) == 1)return SUBRF(fct)(CAR(param));
|
|
break;
|
|
case tc_subr_2:
|
|
if (STk_llength(param) == 2)
|
|
return SUBRF(fct)(CAR(param), CAR(CDR(param)));
|
|
break;
|
|
case tc_subr_3:
|
|
if (STk_llength(param) == 3)
|
|
return SUBRF(fct)(CAR(param), CAR(CDR(param)), CAR(CDR(CDR(param))));
|
|
break;
|
|
case tc_subr_0_or_1:
|
|
switch (STk_llength(param)) {
|
|
case 0: return SUBRF(fct)(UNBOUND);
|
|
case 1: return SUBRF(fct)(CAR(param));
|
|
}
|
|
case tc_subr_1_or_2:
|
|
switch (STk_llength(param)) {
|
|
case 1: return SUBRF(fct)(CAR(param), UNBOUND);
|
|
case 2: return SUBRF(fct)(CAR(param), CAR(CDR(param)));
|
|
}
|
|
|
|
case tc_subr_2_or_3:
|
|
switch (STk_llength(param)) {
|
|
case 2: return SUBRF(fct)(CAR(param), CAR(CDR(param)));
|
|
case 3: return SUBRF(fct)(CAR(param), CAR(CDR(param)),
|
|
CAR(CDR(CDR(param))));
|
|
}
|
|
case tc_ssubr:
|
|
return SUBRF(fct)(param, NIL, STk_llength(param));
|
|
case tc_lsubr:
|
|
return SUBRF(fct)(param, STk_llength(param));
|
|
case tc_cont:
|
|
STk_throw(fct, param);
|
|
case tc_closure: {
|
|
register SCM code;
|
|
register SCM env = extend_env(fct, param, fct, STk_llength(param));
|
|
|
|
for(code=CLOSBODY(fct); NNULLP(code); code=CDR(code))
|
|
param = EVALCAR(code);
|
|
return param;
|
|
}
|
|
#ifdef USE_STKLOS
|
|
case tc_instance:
|
|
return STk_apply_generic(fct, param);
|
|
case tc_next_method:
|
|
return STk_apply_next_method(fct, param);
|
|
#endif
|
|
#ifdef USE_TK
|
|
case tc_tkcommand:
|
|
return STk_execute_Tcl_lib_cmd(fct, param, NIL, 0);
|
|
#endif
|
|
case tc_apply:
|
|
fct = CAR(param);
|
|
param = STk_liststar(CDR(param), STk_llength(CDR(param)));
|
|
goto Top;
|
|
default:
|
|
if (EXTENDEDP(fct))
|
|
if (STk_extended_procedurep(fct))
|
|
return STk_extended_apply(fct, param, UNBOUND);
|
|
Err("apply: bad procedure", fct);
|
|
}
|
|
|
|
Err("apply: bad number of arguments to apply", Cons(fct,param));
|
|
return UNDEFINED; /* never reached */
|
|
}
|
|
|
|
PRIMITIVE STk_user_eval(SCM expr, SCM env)
|
|
{
|
|
if (env == UNBOUND) env = STk_globenv;
|
|
else
|
|
if (NENVP(env)) Err("eval: bad environment", env);
|
|
|
|
/* If expr is a list, make a copy of it to avoid the user to see it modified
|
|
* (i.e. "recoded") when eval returns
|
|
*/
|
|
if (CONSP(expr)) expr = STk_copy_tree(expr);
|
|
return STk_eval(expr, env->storage_as.env.data);
|
|
}
|
|
|
|
|
|
PRIMITIVE STk_eval_string(SCM str, SCM env)
|
|
{
|
|
SCM result;
|
|
|
|
if (env == UNBOUND) env = STk_globenv;
|
|
else
|
|
if (NENVP(env)) Err("eval-string: bad environment", env);
|
|
|
|
if (NSTRINGP(str)) Err("eval-string: Bad string", str);
|
|
result = STk_internal_eval_string(CHARS(str),
|
|
ERR_READ_FROM_STRING,
|
|
env->storage_as.env.data);
|
|
return result == EVAL_ERROR? UNDEFINED: result;
|
|
}
|