/* Scheme implementation intended for JACAL.
   Copyright (C) 1990, 1991, 1992 Aubrey Jaffer & Hugh E. Secker-Walker.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 1, or (at your option)
any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

The author can be reached at jaffer@ai.mit.edu or
Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880
*/
#include <stdio.h>
#include "scm.h"

typedef struct {long sname;double (*dproc)();} dsubr;
#define DSUBRF(x) (((dsubr *)(x))->dproc)

#define I_VAL(x) (CDR((x)-1L))
#define EVALCELLCAR(x,env) SYMBOLP(CAR(x))?*lookupcar(x,env):ceval(CAR(x),env)
#ifdef MEMOIZE_LOCALS
#define EVALIMP(x,env) (ILOCP(x)?*ilookup((x),env):x)
#else
#define EVALIMP(x,env) x
#endif
#define EVALCAR(x,env) (NCELLP(CAR(x))?(IMP(CAR(x))?EVALIMP(CAR(x),env):\
					I_VAL(CAR(x))):EVALCELLCAR(x,env))
#define EXTEND_ENV(formals,actuals,env) cons2r(formals,actuals,env)

#ifdef MEMOIZE_LOCALS
SCM *ilookup(iloc,env)
SCM iloc,env;
{
  register int ir = IFRAME(iloc);
  register SCM er = env;
  for(;ir != 0;--ir) er = CDR(er);
  er = CAR(er);
  for(ir = IDIST(iloc);ir != 0;--ir) er = CDR(er);
  if ICDRP(iloc) return &CDR(er);
  return &CAR(CDR(er));
}
#endif
SCM *lookupcar(vloc,genv)
SCM vloc,genv;
{
  SCM env = genv;
  register SCM *al, fl, var = CAR(vloc);
#ifdef MEMOIZE_LOCALS
  register SCM iloc = ILOC00;
#endif
  for(;NIMP(env);env = CDR(env)) {
    al = &CAR(env);
    for(fl = CAR(*al);NIMP(fl);fl = CDR(fl)) {
      if NCONSP(fl)
	if (fl == var) {
#ifdef MEMOIZE_LOCALS
	  CAR(vloc) = iloc + ICDR;
#endif
	  return &CDR(*al);
	}
	else break;
      al = &CDR(*al);
      if (CAR(fl) == var) {
#ifdef MEMOIZE_LOCALS
	CAR(vloc) = iloc;
#endif
	return &CAR(*al);
      }
#ifdef MEMOIZE_LOCALS
      iloc += IDINC;
#endif
    }
#ifdef MEMOIZE_LOCALS
    iloc = (~IDSTMSK) & (iloc + IFRINC);
#endif
  }
  var = sym2vcell(var);
#ifndef RECKLESS
  if (NNULLP(env) || UNBNDP(CDR(var)))
    everr(vloc,genv,CAR(var),
	  NULLP(env)?"unbound variable: ":"damaged environment","");
#endif
  CAR(vloc) = var + 1;
  return &CDR(var);
}
SCM eval_args(l,env)
SCM l,env;
{
	SCM res = EOL,*lloc = &res;
	while NIMP(l) {
		*lloc = cons(EVALCAR(l,env),EOL);
		lloc = &CDR(*lloc);
		l = CDR(l);
	}
	return res;
}

SCM iqq(form, env, depth)
SCM form, env;
int depth;
{
  SCM tmp;
  int edepth = depth;
  if IMP(form) return form;
  if VECTORP(form) {
    long i = LENGTH(form);
    SCM *data = VELTS(form);
    tmp = EOL;
    for(;--i>=0;) tmp = cons(data[i],tmp);
    return vector(iqq(tmp,env,depth));
  }
  if NCONSP(form) return form;
  tmp = CAR(form);
  if (tmp == I_QUASIQUOTE) {
    depth++;
    goto label;
  }
  if (tmp == I_UNQUOTE) {
    --depth;
  label:
    form = CDR(form);
    ASSERT(NIMP(form) && ECONSP(form) && NULLP(CDR(form)),
	   form,ARG1,ISYMCHARS(I_QUASIQUOTE));
    if (depth == 0) return EVALCAR(form,env);
    return cons2(tmp,iqq(CAR(form),env,depth),EOL);
  }
  if (NIMP(tmp) && (CAR(tmp) == I_UQ_SPLICING)) {
    tmp = CDR(tmp);
    if (--edepth == 0)
      return append(cons2(EVALCAR(tmp,env),iqq(CDR(form),env,depth),EOL));
  }
  return cons(iqq(CAR(form),env,edepth),iqq(CDR(form),env,depth));
}

static char EXPRESSION[]="missing or extra expression";
static char TEST[]="bad test";
static char BODY[]="bad body";
static char BINDINGS[]="bad bindings";
static char VARIABLE[]="bad variable";
static char CLAUSES[]="bad or missing clauses";
static char FORMALS[]="bad formals";
#define ASRTSYNTAX(cond_,msg_) if(!(cond_))wta(xorig,(msg_),what);

SCM syntax_mem(xorig,xin,what)
  SCM xorig,xin;
  char *what;
{
  SCM carx=CAR(xin);
  SCM cdrx=CDR(xin); /* locally mutable version of form */
  SCM x, proc, arg1; /* structure traversers */
  SCM vars, inits, steps;
  SCM *varloc, *initloc, *steploc;
  SCM name;
  int len;

 top:
  vars = inits = steps = EOL;
  varloc = &vars;
  initloc = &inits;
  steploc = &steps;
  x = cdrx;
  len = ilength(x);
  
  switch ISYMNUM(carx) {
  case ISYMNUM(I_BEGIN):
    ASRTSYNTAX(len>=1,BODY);
    carx = IM_BEGIN;
    goto mutate;
  case ISYMNUM(I_AND):
    ASRTSYNTAX(len>=0,TEST);
    if (len >= 1) carx = IM_AND;
    else {
      carx = IM_QUOTE;
      cdrx = cons(BOOL_T, EOL);
    }
    goto mutate;
  case ISYMNUM(I_OR):
    ASRTSYNTAX(len>=0,TEST);
    if (len >= 1) carx = IM_OR;
    else {
      carx = IM_QUOTE;
      cdrx = cons(BOOL_F, EOL);
    }
    goto mutate;
  case ISYMNUM(I_IF):
    ASRTSYNTAX(len>=2 && len<=3,EXPRESSION);
    carx = IM_IF;
    goto mutate;
  case ISYMNUM(I_CASE):
    ASRTSYNTAX(len>=2,CLAUSES);
    while(NIMP(x = CDR(x))) {
      proc = CAR(x);
      ASRTSYNTAX(ilength(proc)>=2,CLAUSES);
      ASRTSYNTAX(ilength(CAR(proc))>=0 || CAR(proc) == I_ELSE,CLAUSES);
    }
    carx = IM_CASE;
    goto mutate;
  case ISYMNUM(I_COND):
    ASRTSYNTAX(len>=1,CLAUSES);
    while(NIMP(x)) {
      arg1 = CAR(x);
      len = ilength(arg1);
      ASRTSYNTAX(len>=1,CLAUSES);
      if (CAR(arg1)==I_ELSE) 
	ASRTSYNTAX(len>=2,"bad ELSE clause");
      if (len>=2 && CAR(CDR(arg1)) == I_ARROW)
	ASRTSYNTAX(len==3&&NIMP(CAR(CDR(CDR(arg1)))),"bad recipient");
      x = CDR(x);
    }
    carx = IM_COND;
    goto mutate;
  case ISYMNUM(I_LAMBDA):
    ASRTSYNTAX(len>=2,BODY);
    proc = CAR(x);
    if NULLP(proc)
      goto memlambda;
    ASRTSYNTAX(NIMP(proc),FORMALS);
    if SYMBOLP(proc)
      goto memlambda;
    ASRTSYNTAX(CONSP(proc),FORMALS);
    while NIMP(proc) {
      if NCONSP(proc) {
	ASRTSYNTAX(SYMBOLP(proc),FORMALS);
	goto memlambda;
      }	
      ASRTSYNTAX(NIMP(CAR(proc)) && SYMBOLP(CAR(proc)),FORMALS);
      proc = CDR(proc);
    }
    ASRTSYNTAX(NULLP(proc),FORMALS);
  memlambda:
    carx = IM_LAMBDA;
    goto mutate;
  case ISYMNUM(I_QUOTE):
    ASRTSYNTAX(len==1,EXPRESSION);
    carx = IM_QUOTE;
    goto mutate;
  case ISYMNUM(I_SET):
    ASRTSYNTAX(len==2,EXPRESSION);
    ASRTSYNTAX(NIMP(CAR(x))&&SYMBOLP(CAR(x)),VARIABLE);
    carx = IM_SET;
    goto mutate;
/* the following rewrite expressions 
 * and/or the memoized forms have different syntax */
  case ISYMNUM(I_DEFINE):
    ASRTSYNTAX(len>=2,EXPRESSION);
    proc = CAR(x);
    x = CDR(x);
    while (NIMP(proc) && CONSP(proc)) {
      x = cons(syntax_mem(xorig,cons2(I_LAMBDA,CDR(proc),x),what),EOL); 
      proc = CAR(proc);
    }
    ASRTSYNTAX(NIMP(proc)&&SYMBOLP(proc),VARIABLE);
    ASRTSYNTAX(ilength(x)==1,EXPRESSION);
    carx = IM_DEFINE;
    cdrx = cons(proc,x);
    goto mutate;

/* DO gets the most radically altered syntax
 (do ((<var1> <init1> <step1>)
     (<var2> <init2>)
      ... )
    (<test> <return>)
  <body>)
 ;; becomes
 (do_mem (varn ... var2 var1)
	(<init1> <init2> ... <initn>)
	(<test> <return>)
	(<body>)
	<step1> <step2> ... <stepn>) ;; missing steps replaced by var
*/
  case ISYMNUM(I_DO):
    ASRTSYNTAX(len>=2,TEST);
    proc = CAR(x);
    ASRTSYNTAX(ilength(proc)>=0,BINDINGS);
    while NIMP(proc) {
      arg1 = CAR(proc);
      len = ilength(arg1);
      ASRTSYNTAX(len==2||len==3,BINDINGS);
      ASRTSYNTAX(NIMP(CAR(arg1)) && SYMBOLP(CAR(arg1)),VARIABLE);
      /* vars reversed here, inits and steps reversed at evaluation */
      vars = cons(CAR(arg1),vars); /* variable */

      arg1 = CDR(arg1);
      *initloc = cons(CAR(arg1),EOL); /* init */
      initloc = &CDR(*initloc);
      
      arg1 = CDR(arg1);
      *steploc = cons(IMP(arg1)?CAR(vars):CAR(arg1),EOL); /* step */
      steploc = &CDR(*steploc);
      proc = CDR(proc);
    }
    x = CDR(x);
    ASRTSYNTAX(ilength(CAR(x))>=1,TEST);
    carx = IM_DO;
    cdrx = cons2(vars, inits, cons2(CAR(x), CDR(x), steps));
    goto mutate;

  case ISYMNUM(I_LET):
    ASRTSYNTAX(len>=2,BODY);
    proc = CAR(x); 
    if (NULLP(proc) || 
	(NIMP(proc) && CONSP(proc) && 
	 NIMP(CAR(proc)) && CONSP(CAR(proc)) && NULLP(CDR(proc)))) {
      /* null or single binding, let* is faster */
      carx = I_LETSTAR;
      goto top;
    }
    ASRTSYNTAX(NIMP(proc),BINDINGS);
    if CONSP(proc) { /* plain let, proc is <bindings> */
      carx = IM_LET;
    letmemsyntax:    /* same syntax for memoized let and letrec */
      ASRTSYNTAX(ilength(proc)>=1,BINDINGS);
      do {    /* vars list reversed here, inits reversed at evaluation */
	arg1 = CAR(proc);
	ASRTSYNTAX(ilength(arg1)==2,BINDINGS);
	ASRTSYNTAX(NIMP(CAR(arg1))&&SYMBOLP(CAR(arg1)), VARIABLE);
	vars = cons(CAR(arg1),vars);
	*initloc = cons(CAR(CDR(arg1)),EOL);
	initloc = &CDR(*initloc);
      } while NIMP(proc = CDR(proc));
      cdrx = cons2(vars,inits,CDR(x));
      goto mutate;
    }
    if SYMBOLP(proc) { /* named let, build equiv letrec */
      name = proc;
      x = CDR(x);
      ASRTSYNTAX(ilength(x)>=2,BODY);
      proc = CAR(x); /* bindings list */
      ASRTSYNTAX(ilength(proc)>=0,BINDINGS);
      while NIMP(proc) {    /* vars and inits both in order */
	arg1 = CAR(proc);
	ASRTSYNTAX(ilength(arg1)==2,BINDINGS);
	ASRTSYNTAX(NIMP(CAR(arg1))&&SYMBOLP(CAR(arg1)),VARIABLE);
	*varloc = cons(CAR(arg1),EOL);
	varloc = &CDR(*varloc);
	*initloc = cons(CAR(CDR(arg1)),EOL);
	initloc = &CDR(*initloc);
	proc = CDR(proc);
      }
      carx = I_LETREC;
      cdrx = cons2(cons( /* bindings */
			   cons2(name,cons2(I_LAMBDA,vars,CDR(x)),EOL),
			   EOL),
		      cons(name,inits),EOL); /* body */
      goto top;
    }
    ASRTSYNTAX(0,BINDINGS); /* bad let */
    
  case ISYMNUM(I_LETREC):
    ASRTSYNTAX(len>=2,BODY);
    proc = CAR(x); 
    if NULLP(proc) { /* null binding, let* is faster */
      carx = I_LETSTAR;
      goto top;
    }
    carx = IM_LETREC;
    goto letmemsyntax; /* same memoized syntax */

  case ISYMNUM(I_LETSTAR):
    ASRTSYNTAX(len>=2,BODY);
    proc = CAR(x);
    ASRTSYNTAX(ilength(proc)>=0,BINDINGS);
    while NIMP(proc) { 
      arg1 = CAR(proc);
      ASRTSYNTAX(ilength(arg1)==2,BINDINGS);
      ASRTSYNTAX(NIMP(CAR(arg1))&&SYMBOLP(CAR(arg1)),VARIABLE);
      *varloc = cons2(CAR(arg1),CAR(CDR(arg1)),EOL);
      varloc = &CDR(CDR(*varloc));
      proc = CDR(proc);
    }
    carx = IM_LETSTAR;
    cdrx = cons(vars,CDR(x));
    goto mutate;
  }
 mutate:
  DEFER_INTS;
  CAR(xin) = carx;
  CDR(xin) = cdrx;
  ALLOW_INTS;
  return xin;
}

char s_apply[]="apply", s_map[]="map", s_for_each[]="for-each";
SCM eqv();
cell dummy_cell = {EOL, EOL};
SCM ceval(x,env)
SCM x,env;
{
  union {SCM *lloc; SCM arg1;} t;
  SCM proc;
 loop:
  switch TYP7(x) {
  case tcs_symbols:
    /* only happens when called at top level */
    CAR(&dummy_cell) = x; /*    CDR(&dummy_cell) = EOL; */
    x = (SCM)&dummy_cell;
    goto retval;
  case (127 & IM_AND):
    x = CDR(x);
    t.arg1 = x;
    while(NNULLP(t.arg1 = CDR(t.arg1)))
      if FALSEP(EVALCAR(x,env)) return BOOL_F;
      else x = t.arg1;
    goto carloop;
  case (127 & IM_BEGIN):
 cdrxbegin:
    x = CDR(x);
 begin:
    t.arg1 = x;
    while(NNULLP(t.arg1 = CDR(t.arg1))) {
      SIDEVAL(CAR(x),env);
      x = t.arg1;
    }
 carloop:			/* eval car of last form in list */
    if NCELLP(CAR(x)) {
      x = CAR(x);
      return IMP(x)?EVALIMP(x,env):I_VAL(x);
    }
    if SYMBOLP(CAR(x)) {
 retval:
      return *lookupcar(x,env);
    }
    x = CAR(x);
    goto loop;			/* tail recurse */

  case (127 & IM_CASE):
    x = CDR(x);
    t.arg1 = EVALCAR(x,env);
    while(NIMP(x = CDR(x))) {
      proc = CAR(x);
      if (CAR(proc) == I_ELSE) {
	x = CDR(proc);
	goto begin;
      }
      proc = CAR(proc);
      while NIMP(proc) {
	if (CAR(proc) == t.arg1
#ifdef FLOATS
	    || NFALSEP(eqv(CAR(proc),t.arg1))
#endif
	    ) {
	  x = CDR(CAR(x));
	  goto begin;
	}
	proc = CDR(proc);
      }
    }
    return UNSPECIFIED;
  case (127 & IM_COND):
    while(NIMP(x = CDR(x))) {
      proc = CAR(x);
      t.arg1 = EVALCAR(proc,env);
      if NFALSEP(t.arg1) {
	x = CDR(proc);
	if NULLP(x) return t.arg1;
	if (I_ARROW != CAR(x)) goto begin;
	proc = CDR(x);
	proc = EVALCAR(proc,env);
	ASRTGO(NIMP(proc),badfun);
	goto evap1;
      }
    }
    return UNSPECIFIED;
  case (127 & IM_DO):
    x = CDR(x);
    proc = CAR(CDR(x)); /* inits */
    t.arg1 = EOL; /* values */
    while NIMP(proc) {
      t.arg1 = cons(EVALCAR(proc,env),t.arg1);
      proc = CDR(proc);
    }
    env = EXTEND_ENV(CAR(x),t.arg1,env);    
    x = CDR(CDR(x));
    while (proc = CAR(x),FALSEP(EVALCAR(proc,env))) {
      for(proc = CAR(CDR(x));NIMP(proc);proc=CDR(proc)) { /* body */
	t.arg1 = CAR(proc);
	SIDEVAL(t.arg1,env);
      }
      for(t.arg1=EOL, proc=CDR(CDR(x)); NIMP(proc); proc=CDR(proc)) /* steps */
	  t.arg1 = cons(EVALCAR(proc,env),t.arg1);
      CDR(CAR(env)) = t.arg1;
    }
    x = CDR(proc);
    if NULLP(x) return UNSPECIFIED;
    goto begin;

  case (127 & IM_IF):
    x = CDR(x);
    if NFALSEP(EVALCAR(x,env)) x = CDR(x);
    else if IMP(x = CDR(CDR(x))) return UNSPECIFIED;
    goto carloop;
  case (127 & IM_LET):
    x = CDR(x);
    proc = CAR(CDR(x));
    t.arg1 = EOL;
    do {
      t.arg1 = cons(EVALCAR(proc,env), t.arg1);
    } while NIMP(proc = CDR(proc));
    env = EXTEND_ENV(CAR(x),t.arg1,env);
    x = CDR(x);
    goto cdrxbegin;
  case (127 & IM_LETREC):
    x = CDR(x);
    env = EXTEND_ENV(CAR(x),undefineds,env);
    x = CDR(x);
    proc = CAR(x);
    t.arg1 = EOL;
    do {
	t.arg1 = cons(EVALCAR(proc,env), t.arg1);
    } while NIMP(proc = CDR(proc));
    CDR(CAR(env)) = t.arg1;
    goto cdrxbegin;
  case (127 & IM_LETSTAR):
    x = CDR(x);
    proc = CAR(x);
    if IMP(proc) {
      env = EXTEND_ENV(EOL,EOL, env);
      goto cdrxbegin;
    }
    do {
      t.arg1 = CAR(proc);
      proc = CDR(proc);
      env = EXTEND_ENV(t.arg1, EVALCAR(proc,env), env);
    } while NIMP(proc = CDR(proc));
    goto cdrxbegin;
  case (127 & IM_OR):
    x = CDR(x);
    t.arg1 = x;
    while(NNULLP(t.arg1 = CDR(t.arg1))) {
      x = EVALCAR(x,env);
      if NFALSEP(x) return x;
      x = t.arg1;
    }
    goto carloop;
  case (127 & IM_DEFINE):
    x = CDR(x);
    proc = CAR(x);
    x = CDR(x);
    x = EVALCAR(x,env);
    if NNULLP(env) {
      env = CAR(env);
      CAR(env) = cons(proc,CAR(env));
      CDR(env) = cons(x,CDR(env));
    }
    else {
      t.arg1 = sym2vcell(proc);
#ifndef RECKLESS
      if (NIMP(CDR(t.arg1))  &&
	  ((SCM) SNAME(CDR(t.arg1)) == proc))
	warn("redefining built-in ", CHARS(proc));
#endif
      CDR(t.arg1) = x;
    }
    return UNSPECIFIED;
  case (127 & IM_LAMBDA):
    return closure(CDR(x),env);
  case (127 & IM_QUOTE):
    return CAR(CDR(x));
#ifndef PURE_FUNCTIONAL
  case (127 & IM_SET):
    x = CDR(x);
    proc = CAR(x);
    switch (7 & (int)proc) {
    case 0:
      t.lloc = lookupcar(x,env);
      break;
    case 1:
      t.lloc = &CDR(proc-1);
      break;
#ifdef MEMOIZE_LOCALS
    case 4:
      t.lloc = ilookup(proc,env);
      break;
#endif
    }
    x = CDR(x);
    *t.lloc = EVALCAR(x,env);
    return UNSPECIFIED;
#endif /* ~PURE_FUNCTIONAL */
  case (127 & MAKISYM(0)):
    proc = CAR(x);
    ASRTGO(ISYMP(proc),badfun);
    switch ISYMNUM(proc) {
	/* syntactic forms which get memoized */
    case ISYMNUM(I_BEGIN):
    case ISYMNUM(I_AND):
    case ISYMNUM(I_OR):
    case ISYMNUM(I_IF):
    case ISYMNUM(I_CASE):
    case ISYMNUM(I_COND):
    case ISYMNUM(I_DO):      
    case ISYMNUM(I_LET):
    case ISYMNUM(I_LETSTAR):      
    case ISYMNUM(I_LETREC):      
    case ISYMNUM(I_LAMBDA):      
    case ISYMNUM(I_QUOTE):
    case ISYMNUM(I_DEFINE):      
    case ISYMNUM(I_SET):      
      (void) syntax_mem(x,x,isymnames[ISYMNUM(CAR(x))]);
      goto loop;
    case ISYMNUM(I_QUASIQUOTE):
      x = CDR(x);
      ASSERT(NIMP(x) && CONSP(x) && NULLP(CDR(x)),
	     x,ARG1,ISYMCHARS(I_QUASIQUOTE));
      return iqq(CAR(x), env, 1);
    case ISYMNUM(I_DELAY):
      return makprom(closure(cons(EOL,CDR(x)),env));
#ifdef SYNTAX_EXTENSIONS	/* extension special forms go here */
    case ISYMNUM(I_DEFINEDP):
      CAR(x) = I_QUOTE;
      x = CDR(x);
      proc = CAR(x);
      CAR(x) = (ISYMP(proc) ||
		(NIMP(proc) && SYMBOLP(proc) &&
		 !UNBNDP(CDR(sym2vcell(proc)))))? BOOL_T : BOOL_F;
      return CAR(x);
#endif /* SYNTAX_EXTENSIONS */
    default:
      goto badfun;
    }
  default:
/*  badfun2: */
    proc = x;
  badfun:
    everr(x,env,proc,"Wrong type to apply: ","");
  case tc7_vector:
  case tc7_string:
  case tc7_smob:
    return x;
#ifdef MEMOIZE_LOCALS
  case (127 & ILOC00):
/*    ASRTGO(ILOCP(CAR(x)),badfun2); */
    proc = *ilookup(CAR(x),env);
    goto checkprocbreak;
#endif
  case tcs_cons_gloc:
    proc = I_VAL(CAR(x));
  checkprocbreak:
    ASRTGO(NIMP(proc),badfun);
    break;
  case tcs_cons_nimcar:
    proc = EVALCELLCAR(x,env);
    ASRTGO(NIMP(proc),badfun);
#ifndef RECKLESS
    if CLOSUREP(proc) {
      SCM varl = CAR(CODE(proc));
      t.arg1 = CDR(x);
      while NIMP(varl) {
	if NCONSP(varl)
	  goto evapply;
	if IMP(t.arg1) goto wrongnumargs;
	varl = CDR(varl);
	t.arg1 = CDR(t.arg1);
      }
      if NNULLP(t.arg1) goto wrongnumargs;
    }
#endif
  }
 evapply:
  x = CDR(x);
  if NULLP(x) switch TYP7(proc) { /* no arguments given */
  case tc7_subr_0:
    return SUBRF(proc)();
  case tc7_subr_1o:
    return SUBRF(proc) (UNDEFINED);
  case tc7_lsubr:
    return SUBRF(proc)(EOL);
  case tc7_asubr:
    return SUBRF(proc)(UNDEFINED,UNDEFINED);
  case tcs_closures:
    x = CODE(proc);
    env = EXTEND_ENV(CAR(x),EOL,ENV(proc));
    goto cdrxbegin;
  case tc7_contin:
  case tc7_subr_1:
  case tc7_subr_2:
  case tc7_subr_2x:
  case tc7_subr_2o:
  case tc7_cxr:
  case tc7_subr_3:
  case tc7_lsubr_2:
  wrongnumargs:
    everr(x,env,proc,(char *)WNA,"");
  default:
    goto badfun;
  }
  t.arg1 = EVALCAR(x,env);
  x = CDR(x);
  if NULLP(x)
evap1: switch TYP7(proc) { /* have one argument in t.arg1 */
  case tc7_subr_2o:
    return SUBRF(proc)(t.arg1,UNDEFINED);
  case tc7_subr_1:
  case tc7_subr_1o:
    return SUBRF(proc)(t.arg1);
  case tc7_cxr:
#ifdef FLOATS
    if SUBRF(proc) {
      if INUMP(t.arg1)
	return makdbl(DSUBRF(proc)((double) INUM(t.arg1)), 0.0);
      ASRTGO(NIMP(t.arg1),floerr);
      if REALP(t.arg1)
	return makdbl(DSUBRF(proc)(REALPART(t.arg1)), 0.0);
#ifdef BIGDIG
      if BIGP(t.arg1)
	return makdbl(DSUBRF(proc)(big2dbl(t.arg1)), 0.0);
#endif
    floerr:
      wta(t.arg1,(char *)ARG1,CHARS(SNAME(proc)));
    }
#endif
    proc = (SCM)SNAME(proc);
    {
      char *chrs = CHARS(proc)+LENGTH(proc)-1;
      while(*--chrs != 'c') {
	ASSERT(NIMP(t.arg1) && CONSP(t.arg1),
	       t.arg1,ARG1,CHARS(proc));
	t.arg1 = (*chrs == 'a')?CAR(t.arg1):CDR(t.arg1);
      }
      return t.arg1;
    }
  case tc7_asubr:
    return t.arg1 = SUBRF(proc)(t.arg1,UNDEFINED);
  case tc7_lsubr:
    return SUBRF(proc)(cons(t.arg1,EOL));
  case tcs_closures:
    x = CODE(proc);
    env = EXTEND_ENV(CAR(x),cons(t.arg1,EOL),ENV(proc));
    goto cdrxbegin;
  case tc7_contin:
    lthrow(proc,t.arg1);
  case tc7_subr_2x:
  case tc7_subr_2:
  case tc7_subr_0:
  case tc7_subr_3:
  case tc7_lsubr_2:
    goto wrongnumargs;
  default:
    goto badfun;
  }
  {				/* have two or more arguments */
    SCM arg2 = EVALCAR(x,env);
    x = CDR(x);
    if NULLP(x) switch TYP7(proc) { /* have two arguments */
    case tc7_subr_2:
    case tc7_subr_2o:
      return SUBRF(proc)(t.arg1,arg2);
    case tc7_subr_2x:
      return SUBRF(proc)(arg2,t.arg1);
    case tc7_lsubr:
      return SUBRF(proc)(cons2(t.arg1,arg2,EOL));
    case tc7_lsubr_2:
      return SUBRF(proc)(t.arg1, arg2, EOL);
    case tc7_asubr:
      return t.arg1 = SUBRF(proc)(t.arg1,arg2);
    case tc7_subr_0:
    case tc7_cxr:
    case tc7_subr_1o:
    case tc7_subr_1:
    case tc7_subr_3:
    case tc7_contin:
      goto wrongnumargs;
    default:
      goto badfun;
    case tcs_closures:
      env =EXTEND_ENV(CAR(CODE(proc)),cons2(t.arg1,arg2,EOL),ENV(proc));
      x = CODE(proc);
      goto cdrxbegin;
    }
    switch TYP7(proc) {		/* have 3 or more arguments */
    case tc7_subr_3:
      ASRTGO(NULLP(CDR(x)), wrongnumargs);
      return SUBRF(proc)(t.arg1,arg2,EVALCAR(x,env));
    case tc7_asubr:
      t.arg1 = SUBRF(proc)(t.arg1,arg2);
      while NIMP(x) {
	t.arg1 = SUBRF(proc)(t.arg1,EVALCAR(x,env));
	x = CDR(x);
      }
      return t.arg1;
    case tc7_lsubr_2:
      return SUBRF(proc)(t.arg1, arg2, eval_args(x,env));
    case tc7_lsubr:
      return SUBRF(proc)(cons2(t.arg1,arg2,eval_args(x,env)));
    case tcs_closures:
      env = EXTEND_ENV(CAR(CODE(proc)),
		       cons2(t.arg1,arg2,eval_args(x,env)),
		       ENV(proc));
      x = CODE(proc);
      goto cdrxbegin;
    case tc7_subr_2:
    case tc7_subr_2x:
    case tc7_subr_1o:
    case tc7_subr_2o:
    case tc7_subr_0:
    case tc7_cxr:
    case tc7_subr_1:
    case tc7_contin:
      goto wrongnumargs;
    default:
      goto badfun;
    }
  }
}

SCM procedurep(obj)
SCM obj;
{
	if NIMP(obj) switch TYP7(obj) {
	case tcs_closures:
	case tc7_contin:
	case tcs_subrs:
	  return BOOL_T;
	}
	return BOOL_F;
}

SCM apply(proc,arg1,args)
SCM proc,arg1,args;
{
  ASRTGO(NIMP(proc),badproc);
  /* This code is for lsubr apply. it is destructive on multiple args.
     this will only screw you if you do (apply apply '( ... )) */
  if NULLP(args)
    if NULLP(arg1) arg1 = UNDEFINED;
    else {
      args = CDR(arg1);
      arg1 = CAR(arg1);
    }
  else {
    /*		ASRTGO(NIMP(args) && CONSP(args),wrongnumargs); */
    SCM *lloc = &args;
    while NNULLP(CDR(*lloc)) lloc = &CDR(*lloc);
    *lloc = CAR(*lloc);
  }
  switch TYP7(proc) {
  case tc7_subr_2o:
    args = NULLP(args)?UNDEFINED:CAR(args);
    return SUBRF(proc)(arg1,args);
  case tc7_subr_2x:
    ASRTGO(NULLP(CDR(args)),wrongnumargs);
    args = CAR(args);
    return SUBRF(proc)(args,arg1);
  case tc7_subr_2:
    ASRTGO(NULLP(CDR(args)),wrongnumargs);
    args = CAR(args);
    return SUBRF(proc)(arg1,args);
  case tc7_subr_0:
    ASRTGO(UNBNDP(arg1),wrongnumargs);
    return SUBRF(proc)();
  case tc7_subr_1:
  case tc7_subr_1o:
    ASRTGO(NULLP(args),wrongnumargs);
    return SUBRF(proc)(arg1);
  case tc7_cxr:
    ASRTGO(NULLP(args),wrongnumargs);
#ifdef FLOATS
    if SUBRF(proc) {
      if INUMP(arg1)
	return makdbl(DSUBRF(proc)((double) INUM(arg1)), 0.0);
      ASRTGO(NIMP(arg1),floerr);
      if REALP(arg1)
	return makdbl(DSUBRF(proc)(REALPART(arg1)), 0.0);
#ifdef BIGDIG
      if BIGP(arg1)
	return makdbl(DSUBRF(proc)(big2dbl(arg1)), 0.0);
#endif
    floerr:
      wta(arg1,(char *)ARG1,CHARS(SNAME(proc)));
    }
#endif
    proc = (SCM)SNAME(proc);
    {
      char *chrs = CHARS(proc)+LENGTH(proc)-1;
      while(*--chrs != 'c') {
	ASSERT(NIMP(arg1) && CONSP(arg1),
	       arg1,ARG1,CHARS(proc));
	arg1 = (*chrs == 'a')?CAR(arg1):CDR(arg1);
      }
      return arg1;
    }
  case tc7_subr_3:
    return SUBRF(proc)(arg1,CAR(args),CAR(CDR(args)));
  case tc7_lsubr:
    return SUBRF(proc)(UNBNDP(arg1) ? EOL : cons(arg1,args));
  case tc7_lsubr_2:
    ASRTGO(NIMP(args) && CONSP(args),wrongnumargs);
    return SUBRF(proc)(arg1,CAR(args),CDR(args));
  case tc7_asubr:
    if NULLP(args) return SUBRF(proc)(arg1,UNDEFINED);
    while NIMP(args) {
      ASSERT(CONSP(args),args,ARG2,s_apply);
      arg1 = SUBRF(proc)(arg1,CAR(args));
      args = CDR(args);
    }
    return arg1;
  case tcs_closures:
#ifndef RECKLESS
    {
      SCM formals = CAR(CODE(proc));
      arg1 = (UNBNDP(arg1) ? EOL : cons(arg1,args));
      args = EXTEND_ENV(formals,arg1,ENV(proc));
      while (1) {
	if IMP(arg1)
	  if (IMP(formals) || SYMBOLP(formals)) break;
	  else goto wrongnumargs;
	else if IMP(formals) goto wrongnumargs;
	else if SYMBOLP(formals) break;
	arg1 = CDR(arg1);
	formals = CDR(formals);
      }
    }
#else
    args = EXTEND_ENV(CAR(CODE(proc)),
		      (UNBNDP(arg1) ? EOL : cons(arg1,args)),
		      ENV(proc));
#endif
    proc = CODE(proc);
    while NNULLP(proc = CDR(proc)) arg1 = EVALCAR(proc,args);
    return arg1;
  case tc7_contin:
    ASRTGO(NULLP(args),wrongnumargs);
    lthrow(proc,arg1);
  wrongnumargs:
    wta(proc,(char *)WNA,s_apply);
  default:
  badproc:
    wta(proc,(char *)ARG1,s_apply);
    return arg1;
  }
}

SCM map(proc,arg1,args)
SCM proc,arg1,args;
{
	long i;
	SCM res = EOL,*pres = &res,*ve;
	if NULLP(arg1) return res;
	ASSERT(NIMP(arg1),arg1,ARG1,s_map);
	if NULLP(args) {
		while NIMP(arg1) {
			ASSERT(CONSP(arg1),arg1,ARG2,s_map);
			*pres = cons(apply(proc,CAR(arg1),listofnull),EOL);
			pres = &CDR(*pres);
			arg1 = CDR(arg1);
		}
		return res;
	}
	args = vector(cons(arg1,args));
	ve = VELTS(args);
	while (1) {
		arg1 = EOL;
		for (i = LENGTH(args)-1;i >= 0;i--) {
			if IMP(ve[i]) return res;
			arg1 = cons(CAR(ve[i]),arg1);
			ve[i] = CDR(ve[i]);
		}
		*pres = cons(apply(proc,arg1,EOL),EOL);
		pres = &CDR(*pres);
	}
}
SCM for_each(proc,arg1,args)
SCM proc,arg1,args;
{
	SCM *ve;
	long i;
	if NULLP(arg1) return UNSPECIFIED;
	ASSERT(NIMP(arg1),arg1,ARG1,s_for_each);
	if NULLP(args) {
		while NIMP(arg1) {
			ASSERT(CONSP(arg1),arg1,ARG2,s_for_each);
			apply(proc,CAR(arg1),listofnull);
			arg1 = CDR(arg1);
		}
		return UNSPECIFIED;
	}
	args = vector(cons(arg1,args));
	ve = VELTS(args);
	while (1) {
		arg1 = EOL;
		for (i = LENGTH(args)-1;i >= 0;i--) {
			if IMP(ve[i]) return UNSPECIFIED;
			arg1 = cons(CAR(ve[i]),arg1);
			ve[i] = CDR(ve[i]);
		}
		apply(proc,arg1,EOL);
	}
}

SCM closure(code,env)
SCM code,env;
{
	register SCM z;
	NEWCELL(z);
	SETCODE(z,code);
	ENV(z) = env;
	return z;
}

long tc16_promise;
SCM makprom(code)
SCM code;
{
	register SCM z;
	NEWCELL(z);
	CDR(z) = code;
	CAR(z) = tc16_promise;
	return z;
}
int prinprom(exp,f,writing)
     SCM exp;
     FILE * f;
     int writing;
{
  lputs("#<promise ",f);
  iprin1(CDR(exp),f,writing);
  lputc('>',f);
  return !0;
}
char s_force[]="force";
SCM force(x)
     SCM x;
{
  ASSERT((TYP16(x)==tc16_promise),x,ARG1,s_force);
  if (!((1L<<16) & CAR(x))) {
    CDR(x) = apply(CDR(x),EOL,EOL);
    CAR(x) |= (1L<<16);
  }
  return CDR(x);
}

static iproc lsubr2s[]={
	{s_apply,apply},
	{s_map,map},
	{s_for_each,for_each},
	{0,0}};

static smobfuns promsmob = {markcdr,free0,prinprom};

void init_eval()
{
  init_iprocs(lsubr2s, tc7_lsubr_2);
  tc16_promise = newsmob(&promsmob);
  make_subr(s_force,tc7_subr_1,force);
}
