/*
 *
 * 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;
}
