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

670 lines
18 KiB
C
Raw Blame History

/*
*
* e v a l . c -- The evaluator
*
* Copyright © 1993-1996 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
*
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 23-Oct-1993 21:37
* Last file update: 2-Sep-1996 19:18
*/
#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;
/*
* 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 j;
struct Stack_info *p;
fprintf(STk_stderr, "\nCurrent eval stack:\n__________________\n");
for (p=stack, j=0; p && j<=depth ; p=p->previous, j++) {
fprintf(STk_stderr, "%3d ", j);
STk_print(STk_uncode(p->expr), STk_curr_eport, WRT_MODE);
Putc('\n', STk_stderr);
if (j == depth && p->previous) fprintf(STk_stderr, "...\n");
}
}
void STk_reset_eval_stack(void)
{
stack = NULL;
}
PRIMITIVE STk_get_eval_stack(void)
{
struct Stack_info *p;
SCM z = NIL;
for (p = stack; p ; p = p->previous) z = Cons(p->expr, z);
return STk_reverse(z);
}
PRIMITIVE STk_get_env_stack(void)
{
struct Stack_info *p;
SCM 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);
}
SCM STk_top_env_stack(void)
{
return stack ? STk_makeenv(stack->env, 0): STk_globenv;
}
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-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;
SET_EVAL_FLAG(1);
}
}
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;
SET_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;
SET_EVAL_FLAG(1);
res = STk_eval(x, env->storage_as.env.data);
eval_hook_stack = info.previous;
SET_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_sigint_counter) STk_handle_signal(SIGINT);
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));
}
SET_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_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;
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 */
if (NULLP(THE_SLOT_OF(fct, S_methods)))
Apply(VCELL(Intern("no-method")), LIST2(fct, tmp));
fct = STk_compute_applicable_methods(fct, tmp, len, FALSE);
/* fct 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(fct)) RETURN(UNDEFINED);
tmp = Cons(STk_make_next_method(CDR(fct), tmp), tmp);
fct = THE_SLOT_OF(CAR(fct), S_procedure);
env = STk_extend_env(CLOSURE_PARAMETERS(fct),
tmp,
fct->storage_as.closure.env,
x);
tmp = CDR(fct->storage_as.closure.code);
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 = STk_extend_env(CLOSURE_PARAMETERS(fct),
eval_args(tmp, env),
fct->storage_as.closure.env,
x);
tmp = CDR(fct->storage_as.closure.code);
/* NOBREAK */
Begin: case tc_begin:
for( ; NNULLP(CDR(tmp)); tmp=CDR(tmp))
EVALCAR(tmp);
x = CAR(tmp);
goto Top;
case tc_cont:
if (len == 1) STk_throw(fct, EVALCAR(tmp));
goto Error;
case tc_let:
env = STk_fast_extend_env(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 = STk_fast_extend_env(NIL, NIL, env);
for ( ; NNULLP(l1); l1=CDR(l1), l2=CDR(l2))
env = STk_fast_extend_env(Cons(CAR(l1), NIL),
Cons(EVALCAR(l2), NIL), 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 = STk_fast_extend_env(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);
goto Top;
case tc_quote:
RETURN(CAR(tmp));
case tc_lambda:
NEWCELL(x, tc_closure);
x->storage_as.closure.env = env;
x->storage_as.closure.code = tmp;
RETURN(x);
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-env: bad environment", fct);
tmp = CDR(tmp);
env = STk_append(LIST2(fct->storage_as.env.data, env), 2);
goto Begin;
case tc_apply:
tmp = eval_args(tmp, env);
fct = CAR(tmp);
tmp = STk_liststar(CDR(tmp),len-1);
if (STk_llength(tmp) == -1) Err("apply: bad parameter list", tmp);
switch (TYPE(fct)) {
case tc_closure: env=STk_extend_env(
CAR(fct->storage_as.closure.code),
tmp,
fct->storage_as.closure.env,
x);
tmp = CDR(fct->storage_as.closure.code);
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));
}
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:
if (STk_llength(param) == 1)
STk_throw(fct, CAR(param));
case tc_closure: {
register SCM env = STk_extend_env(CAR(fct->storage_as.closure.code),
param,
fct->storage_as.closure.env,
fct);
register SCM code;
for(code=CDR(fct->storage_as.closure.code); 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;
}
Reference in New Issue View Git Blame Copy Permalink