/*
 *
 * e v a l . c				-- The evaluator
 *
 * Copyright (C) 1993,1994,1995 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: 12-Jun-1995 21:41
 */

#include "stk.h"
#include "extend.h"

/*
 * Eval stack
 * 
 * The eval stack is a stack of the argumenet passed toeval. 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 all the objects which are in the C stack
 */
#define INITIAL_STACK_SIZE 	10
#define RETURN(x)		{tmp = (x); goto Out; }

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(stderr, "\nCurrent eval stack:\n__________________\n");
  for (p=stack, j=0; p && j<=depth ; p=p->previous, j++) {
    fprintf(stderr, "%3d    ", j);
    STk_print(STk_uncode(p->expr), STk_curr_eport, WRT_MODE);
    putc('\n', stderr);
    if (j == depth && p->previous) fprintf(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),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 */
}


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; 

  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: {
         /* 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);
	 
	 /* 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 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_TK
	  case tc_tkcommand:
	    	RETURN(STk_execute_Tk_lib_cmd(fct, tmp, env, 1));
#endif
	   case tc_closure:
		env = STk_extend_env(CAR(fct->storage_as.closure.code),
				     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));
#ifdef USE_TK
		Tcl_ChangeValue(PNAME(CAR(tmp)));
#endif
		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);
		switch (TYPE(fct)) {
		  case tc_closure: tmp = STk_liststar(CDR(tmp),len-1);
				   if (STk_llength(tmp) == -1)
				     Err("apply: bad parameter list", tmp);
				   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 ...
				    */
		    		   tmp = STk_liststar(CDR(tmp), len-1);
				   RETURN(Apply(fct, tmp));
		    case tc_call_cc:
		    case tc_dynwind: x=Cons(fct, STk_liststar(CDR(tmp), len-1));
				     goto Top;
		    default: 	     RETURN(Apply(fct, 
						  STk_liststar(CDR(tmp),len-1)));
		}
           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_TK
    case tc_tkcommand:
      	return STk_execute_Tk_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;
}