conservatory
/
stk
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
stk/Src/eval.c

847 lines
23 KiB
C
Raw Permalink Blame History

/*
*
* e v a l . c -- The evaluator
*
* Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* Permission to use, copy, modify, distribute,and license this
* software and its documentation for any purpose is hereby granted,
* provided that existing copyright notices are retained in all
* copies and that this notice is included verbatim in any
* distributions. No written agreement, license, or royalty fee is
* required for any of the authorized uses.
* This software is provided ``AS IS'' without express or implied
* warranty.
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 23-Oct-1993 21:37
* Last file update: 3-Sep-1999 20:19 (eg)
*/
#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(Apply1(EVALCAR(CDR(tmp)), 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 = Apply2(info.previous->hook, 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)))
Apply2(STk_STklos_value(Intern("no-method")), 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 */
}
/*
* same as STk_apply, except that there is no parameter
* than a list
*/
SCM STk_apply0(SCM fct)
{
switch TYPE(fct) {
case tc_subr_0: return SUBRF(fct)(UNBOUND);
case tc_subr_1: break;
case tc_subr_2: break;
case tc_subr_3: break;
case tc_subr_0_or_1: return SUBRF(fct)(UNBOUND);
case tc_subr_1_or_2: break;
case tc_subr_2_or_3: break;
case tc_ssubr: return SUBRF(fct)(NIL, NIL, 0);
case tc_lsubr: return SUBRF(fct)(NIL, 0);
case tc_cont: STk_throw(fct, NIL);
case tc_closure: {
register SCM code;
register SCM env = extend_env(fct, NIL, fct, 0);
SCM tmp = NIL;
for(code=CLOSBODY(fct); NNULLP(code); code=CDR(code))
tmp = EVALCAR(code);
return tmp;
}
#ifdef USE_STKLOS
case tc_instance: return STk_apply_generic(fct, NIL);
case tc_next_method: return STk_apply_next_method(fct, NIL);
#endif
#ifdef USE_TK
case tc_tkcommand: return STk_execute_Tcl_lib_cmd(fct, NIL, NIL,0);
#endif
case tc_apply: return STk_apply(fct, NIL);
default: if (EXTENDEDP(fct))
if (STk_extended_procedurep(fct))
return STk_extended_apply(fct, NIL, UNBOUND);
Err("apply: bad procedure", fct);
}
Err("apply: bad number of arguments to apply", LIST1(fct));
return UNDEFINED; /* never reached */
}
/*
* same as STk_apply, except that param is a single SCM value rather
* than a list
*/
SCM STk_apply1(SCM fct, SCM param)
{
switch TYPE(fct) {
case tc_subr_0: break;
case tc_subr_1: return SUBRF(fct)(param);
case tc_subr_2: break;
case tc_subr_3: break;
case tc_subr_0_or_1: return SUBRF(fct)(param);
case tc_subr_1_or_2: return SUBRF(fct)(param, UNBOUND);
case tc_subr_2_or_3: break;
case tc_ssubr: return SUBRF(fct)(LIST1(param), NIL, 1);
case tc_lsubr: return SUBRF(fct)(LIST1(param), 1);
case tc_cont: STk_throw(fct, LIST1(param));
case tc_closure: {
register SCM code;
register SCM env = extend_env(fct, LIST1(param),
fct, 1);
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, LIST1(param));
case tc_next_method: return STk_apply_next_method(fct, LIST1(param));
#endif
#ifdef USE_TK
case tc_tkcommand: return STk_execute_Tcl_lib_cmd(fct, LIST1(param),NIL,0);
#endif
case tc_apply: return STk_apply(fct, LIST1(param));
default: if (EXTENDEDP(fct))
if (STk_extended_procedurep(fct))
return STk_extended_apply(fct, LIST1(param),
UNBOUND);
Err("apply: bad procedure", fct);
}
Err("apply: bad number of arguments to apply", LIST2(fct, param));
return UNDEFINED; /* never reached */
}
/*
* same as STk_apply, except that there are two arguments given explictly,
* rather than a list
*/
SCM STk_apply2(SCM fct, SCM param1, SCM param2)
{
switch TYPE(fct) {
case tc_subr_0:
case tc_subr_1: break;
case tc_subr_2: return SUBRF(fct)(param1, param2);
case tc_subr_3:
case tc_subr_0_or_1: break;
case tc_subr_1_or_2: return SUBRF(fct)(param1, param2);
case tc_subr_2_or_3: return SUBRF(fct)(param1, param2, UNBOUND);
case tc_ssubr: return SUBRF(fct)(LIST2(param1, param2), NIL, 2);
case tc_lsubr: return SUBRF(fct)(LIST2(param1, param2), 2);
case tc_cont: STk_throw(fct, LIST2(param1, param2));
case tc_closure: {
register SCM code;
register SCM env = extend_env(fct,
LIST2(param1, param2),
fct, 2);
for(code=CLOSBODY(fct); NNULLP(code); code=CDR(code))
param1 = EVALCAR(code);
return param1;
}
#ifdef USE_STKLOS
case tc_instance: return STk_apply_generic(fct, LIST2(param1, param2));
case tc_next_method: return STk_apply_next_method(fct, LIST2(param1, param2));
#endif
#ifdef USE_TK
case tc_tkcommand: return STk_execute_Tcl_lib_cmd(fct,
LIST2(param1, param2),
NIL, 0);
#endif
case tc_apply: return STk_apply(fct, LIST2(param1, param2));
default: if (EXTENDEDP(fct))
if (STk_extended_procedurep(fct))
return STk_extended_apply(fct,
LIST2(param1, param2),
UNBOUND);
Err("apply: bad procedure", fct);
}
Err("apply: bad number of arguments to apply", LIST3(fct, param1, param2));
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;
}
Reference in New Issue View Git Blame Copy Permalink