This is eval.c in view mode; [Download] [Up]
Changes file for /usr/local/src/kcl/./c/eval.c
Created on Wed Jun 19 11:00:15 1991
Usage \n@s[Original text\n@s|Replacement Text\n@s]
See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c
for a program to merge change files. Anything not between
"\n@s[" and "\n@s]" is a simply a comment.
This file was constructed using emacs and merge.el
Enhancements Copyright (c) W. Schelter All rights reserved.
by (Bill Schelter) wfs@carl.ma.utexas.edu
****Change:(orig (11 11 a))
@s[*/
#include "include.h"
@s|*/
#include "include.h"
#include "sfun_argd.h"
@s]
****Change:(orig (14 14 a))
@s[struct nil3 { object nil3_self[3]; } three_nils;
@s|struct nil3 { object nil3_self[3]; } three_nils;
#ifdef DEBUG_AVMA
#undef DEBUG_AVMA
unsigned long avma,bot;
#define DEBUG_AVMA unsigned long saved_avma = avma;
warn_avma()
{
print(list(2,make_simple_string("avma changed"),ihs_top_function_name()),
Vstandard_output->s.s_dbind);
}
#define CHECK_AVMA if(avma!= saved_avma) warn_avma();
#else
#define DEBUG_AVMA
#define CHECK_AVMA
#endif
@s]
****Change:(orig (23 23 a))
@s[object endp_temp;
int eval1 = 0;
@s|object endp_temp;
int eval1 = 0;
object c_apply_n();
@s]
****Change:(orig (25 26 c))
@s[object Vevalhook;
object Vapplyhook;
@s|object siSbreak_points;
object siSbreak_step;
@s]
****Change:(orig (28 28 d))
@s[static object temporary;
@s|
@s]
****Change:(orig (30 31 c))
@s[object Sapply;
object Sfuncall;
@s|#define SET_TO_APPLY(res,f,n,x) \
switch(n) {\
case 0: res=((f))(); break;\
case 1: res=((f))(x[0]); break; \
case 2: res=((f))(x[0],x[1]);break; \
case 3: res=((f))(x[0],x[1],x[2]);break; \
case 4: res=((f))(x[0],x[1],x[2],x[3]);break; \
case 5: res=((f))(x[0],x[1],x[2],x[3],x[4]);break; \
case 6: res=((f))(x[0],x[1],x[2],x[3],x[4],x[5]); break;\
case 7: res=((f))(x[0],x[1],x[2],x[3],x[4],x[5], x[6]); break;\
case 8: res=((f))(x[0],x[1],x[2],x[3],x[4],x[5], x[6],x[7]); break;\
case 9: res=((f))(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8]);break;\
case 10: res=((f))(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9]);break;\
default: res=c_apply_n(f,n,x); break;}
@s]
****Change:(orig (32 32 a))
@s[
@s|
/*
#undef SET_TO_APPLY
#define SET_TO_APPLY(res,f,n,x) res=c_apply_n(f,n,x);
*/
/* for t_sfun,t_gfun with args on vs stack */
quick_call_sfun(fun)
object fun;
{ DEBUG_AVMA
int i,n;
enum ftype restype;
object *x,res;
object temp_ar[10];
i=fun->sfn.sfn_argd;
n=SFUN_NARGS(i);
if (n != vs_top -vs_base)
{check_arg_failed(n);}
restype = SFUN_RETURN_TYPE(i);
SFUN_START_ARG_TYPES(i);
/* for moment just support object and int */
#define COERCE_ARG(a,type) (type==f_object ? a : (object)(fix(a)))
if (i==0)
x=vs_base;
else
{int j;
x=temp_ar;
for (j=0; j<n ; j++)
{enum ftype typ=SFUN_NEXT_TYPE(i);
x[j]=COERCE_ARG(vs_base[j],typ);}}
SET_TO_APPLY(res,(object (*)())fun->sfn.sfn_self,n,x);
vs_base[0]=
(restype==f_object ? res :
restype==f_fixnum ? make_fixnum((int)res)
:(object) FEerror("Bad result type"));
vs_top=vs_base+1;
CHECK_AVMA;
return;}
/* only for sfun not gfun !! Does not check number of args */
call_sfun_no_check(fun)
object fun;
{ DEBUG_AVMA
int n;
object *base=vs_base;
n=vs_top - base;
SET_TO_APPLY(base[0],(object (*)())fun->sfn.sfn_self,n,base);
vs_top=(vs_base=base)+1;
CHECK_AVMA;
return;
}
call_vfun(fun)
object fun;
{ DEBUG_AVMA
int n;
object *base=vs_base;
n=vs_top - base;
if (n < fun->vfn.vfn_minargs)
{FEtoo_few_arguments(base,vs_top); return;}
if (n > fun->vfn.vfn_maxargs)
{FEtoo_many_arguments(base,vs_top); return;}
VFUN_NARGS = n;
SET_TO_APPLY(base[0],(object (*)())fun->sfn.sfn_self,n,base);
vs_top=(vs_base=base)+1;
CHECK_AVMA;
return;
}
static object temporary;
@s]
****Change:(orig (37 37 c))
@s[ object x;
object *top, *lex;
@s| object x;
object * VOL top;
object *lex;
@s]
****Change:(orig (39 40 c))
@s[ bds_ptr old_bds_top;
bool b, c;
@s| bds_ptr old_bds_top;
VOL bool b;
bool c;
DEBUG_AVMA
TOP:
@s]
****Change:(orig (45 45 a))
@s[ case t_cfun:
MMcall(fun);
@s| case t_cfun:
MMcall(fun);
CHECK_AVMA; return;
case t_gfun:
case t_sfun:
ihs_check;ihs_push(fun);
quick_call_sfun(fun);
ihs_pop();
@s]
****Change:(orig (47 47 c))
@s[ return;
@s| return;
case t_vfun:
ihs_check;ihs_push(fun);
call_vfun(fun);
ihs_pop();
return;
@s]
****Change:(orig (54 54 c))
@s[ MMccall(fun, fun->cc.cc_turbo);
return;
@s| MMccall(fun, fun->cc.cc_turbo);
CHECK_AVMA; return;
@s]
****Change:(orig (64 64 c))
@s[ MMccall(fun, top);
return;
@s| MMccall(fun, top);
CHECK_AVMA; return;
@s]
****Change:(orig (65 65 a))
@s[ }
@s| }
case t_dclosure:
(*(fun)->dc.dc_self)(fun->dc.dc_env);
CHECK_AVMA; return;
case t_symbol:
{object x = fun->s.s_gfdef;
if (x) { fun = x; goto TOP;}
else
FEundefined_function(fun);
}
@s]
****Change:(orig (77 78 c))
@s[ ihs_check;
ihs_push(fun);
@s|
/* we may have pushed the calling form if this is called invoked from
eval. A lambda call requires vs_push's, so we can tell
if we pushed by vs_base being the same.
*/
{ VOL int not_pushed = 0;
if (vs_base != ihs_top->ihs_base){
ihs_check;
ihs_push(fun);
}
else
not_pushed = 1;
@s]
****Change:(orig (84 87 c))
@s[ if (x == Slambda_block) {
b = TRUE;
c = FALSE;
fun = fun->c.c_cdr;
@s|
/* maybe digest this lambda expression
(lambda-block-expand name ..) has already been
expanded. The value of lambda-block-expand may
be a compiled function in which case we say expand
with it)
*/
if (x == siSlambda_block_expanded) {
b = TRUE;
c = FALSE;
fun = fun->c.c_cdr;
}else if (x == Slambda_block) {
b = TRUE;
c = FALSE;
if(type_of(siSlambda_block_expanded->s.s_dbind) == t_sfun)
fun = ifuncall1(siSlambda_block_expanded->s.s_dbind,fun);
fun = fun->c.c_cdr;
@s]
****Change:(orig (151 152 c))
@s[ lex_env = lex;
ihs_pop();
}
@s| lex_env = lex;
if (not_pushed == 0) {ihs_pop();}
CHECK_AVMA;
}}
@s]
****Change:(orig (153 153 a))
@s[
@s|
@s]
****Change:(orig (156 156 c))
@s[funcall_no_event(fun)
object fun;
{
@s|funcall_no_event(fun)
object fun;
{ DEBUG_AVMA
@s]
****Change:(orig (183 185 c))
@s[ case t_cons:
funcall(fun);
break;
@s| case t_sfun:
call_sfun_no_check(fun); return;
case t_gfun:
quick_call_sfun(fun); return;
case t_vfun:
call_vfun(fun); return;
case t_dclosure:
(*(fun)->dc.dc_self)(fun->dc.dc_env);
CHECK_AVMA; return;
@s]
****Change:(orig (188 188 c))
@s[ FEinvalid_function(fun);
@s| funcall(fun);
@s]
****Change:(orig (195 195 c))
@s[object *funp;
int narg;
{
@s|object *funp;
int narg;
{ DEBUG_AVMA
@s]
****Change:(orig (227 227 c))
@s[ break;
}
case t_cons:
@s| break;
}
default:
@s]
****Change:(orig (229 229 d))
@s[ funcall(fun);
break;
@s| funcall(fun);
@s]
****Change:(orig (231 232 d))
@s[ default:
FEinvalid_function(fun);
@s|
@s]
****Change:(orig (233 233 a))
@s[ }
@s| }
CHECK_AVMA;
@s]
****Change:(orig (239 239 c))
@s[object *funp;
int narg;
{
@s|object *funp;
int narg;
{ DEBUG_AVMA
@s]
****Change:(orig (271 273 d))
@s[ case t_cons:
funcall(fun);
break;
@s|
@s]
****Change:(orig (276 276 c))
@s[ FEinvalid_function(fun);
@s| funcall(fun);
@s]
****Change:(orig (277 277 a))
@s[ }
@s| }
CHECK_AVMA;
@s]
****Change:(orig (283 283 c))
@s[object sym, *base;
int narg;
{
@s|object sym, *base;
int narg;
{ DEBUG_AVMA
@s]
****Change:(orig (315 318 d))
@s[ case t_cons:
funcall(fun);
break;
@s|
@s]
****Change:(orig (320 320 c))
@s[ FEinvalid_function(fun);
@s| funcall(fun);
@s]
****Change:(orig (321 321 a))
@s[ }
@s| }
CHECK_AVMA;
@s]
****Change:(orig (327 327 c))
@s[object sym, *base;
int narg;
{
@s|object sym, *base;
int narg;
{ DEBUG_AVMA
@s]
****Change:(orig (359 359 c))
@s[ break;
}
case t_cons:
@s| break;
}
default:
@s]
****Change:(orig (361 361 d))
@s[ funcall(fun);
break;
@s| funcall(fun);
@s]
****Change:(orig (363 364 d))
@s[ default:
FEinvalid_function(fun);
@s|
@s]
****Change:(orig (365 365 a))
@s[ }
@s| }
CHECK_AVMA;
@s]
****Change:(orig (372 372 c))
@s[object *funp;
int narg;
{
@s|object *funp;
int narg;
{ DEBUG_AVMA
@s]
****Change:(orig (405 408 d))
@s[ case t_cons:
funcall(fun);
break;
@s|
@s]
****Change:(orig (410 410 c))
@s[ FEinvalid_function(fun);
@s| funcall(fun);
@s]
****Change:(orig (412 412 a))
@s[ }
vs_top = sup;
@s| }
vs_top = sup;
CHECK_AVMA;
@s]
****Change:(orig (413 413 a))
@s[ return(vs_base[0]);
@s| return(vs_base[0]);
@s]
****Change:(orig (420 420 c))
@s[object *funp;
int narg;
{
@s|object *funp;
int narg;
{ DEBUG_AVMA
@s]
****Change:(orig (453 453 c))
@s[ break;
}
case t_cons:
@s| break;
}
default:
@s]
****Change:(orig (455 455 d))
@s[ funcall(fun);
break;
@s| funcall(fun);
@s]
****Change:(orig (457 458 d))
@s[ default:
FEinvalid_function(fun);
@s|
@s]
****Change:(orig (460 460 a))
@s[ }
vs_top = sup;
@s| }
vs_top = sup;
CHECK_AVMA;
@s]
****Change:(orig (468 468 c))
@s[object sym, *base;
int narg;
{
@s|object sym, *base;
int narg;
{ DEBUG_AVMA
@s]
****Change:(orig (501 501 c))
@s[ break;
}
case t_cons:
@s| break;
}
default:
@s]
****Change:(orig (503 503 d))
@s[ funcall(fun);
break;
@s| funcall(fun);
@s]
****Change:(orig (505 506 d))
@s[ default:
FEinvalid_function(fun);
@s|
@s]
****Change:(orig (508 508 a))
@s[ }
vs_top = sup;
@s| }
vs_top = sup;
CHECK_AVMA;
@s]
****Change:(orig (516 516 c))
@s[object sym, *base;
int narg;
{
@s|object sym, *base;
int narg;
{ DEBUG_AVMA
@s]
****Change:(orig (549 552 d))
@s[ case t_cons:
funcall(fun);
break;
@s|
@s]
****Change:(orig (554 554 c))
@s[ FEinvalid_function(fun);
@s| funcall(fun);
@s]
****Change:(orig (556 556 a))
@s[ }
vs_top = sup;
@s| }
vs_top = sup;
CHECK_AVMA;
@s]
****Change:(orig (576 577 c))
@s[super_funcall_no_event(fun)
object fun;
{
if (type_of(fun) == t_symbol) {
if (fun->s.s_sfdef != NOT_SPECIAL || fun->s.s_mflag)
@s|super_funcall_no_event(fun)
object fun;
{
#ifdef DEBUG_AVMA
funcall_no_event(fun); return;
#endif
if (type_of(fun)==t_cfun){(*fun->cf.cf_self)();return;}
if (type_of(fun)==t_sfun){call_sfun_no_check(fun); return;}
if (type_of(fun)==t_gfun)
{quick_call_sfun(fun); return;}
if (type_of(fun)==t_vfun)
{call_vfun(fun); return;}
if (type_of(fun) == t_symbol) {
if (fun->s.s_sfdef != NOT_SPECIAL || fun->s.s_mflag)
@s]
****Change:(orig (581 581 a))
@s[ fun = fun->s.s_gfdef;
@s| fun = fun->s.s_gfdef;
if (type_of(fun)==t_cfun){(*fun->cf.cf_self)();
return;}
@s]
****Change:(orig (588 588 c))
@s[eval(form)
object form;
{
@s|eval(form)
object form;
{ DEBUG_AVMA
@s]
****Change:(orig (591 591 a))
@s[ object *top;
object *base;
@s| object *top;
object *base;
object orig_form;
@s]
****Change:(orig (662 662 a))
@s[ return;
}
APPLICATION:
@s| return;
}
APPLICATION:
/* Hook for possibly stopping at forms in the break point
list. Also for stepping. We only want to check
one form each time round, so we do *breakpoints*
*/
if (siSbreak_points->s.s_dbind != Cnil)
{ if (siSbreak_step->s.s_dbind == Cnil ||
ifuncall2(siSbreak_step->s.s_dbind,form,
list(3,lex_env[0],lex_env[1],lex_env[2])) == Cnil)
{object* bpts = siSbreak_points->s.s_dbind->v.v_self;
int i = siSbreak_points->s.s_dbind->v.v_fillp;
while (--i >= 0)
{ if((*bpts)->c.c_car == form)
{ifuncall2(siSbreak_points->s.s_gfdef,form,
list(3,lex_env[0],lex_env[1],lex_env[2]));
break;}
bpts++;}
}}
@s]
****Change:(orig (668 668 c))
@s[ ihs_check;
ihs_push(fun);
@s| ihs_check;
ihs_push(form);
@s]
****Change:(orig (670 670 a))
@s[ (*fun->s.s_sfdef)(MMcdr(form));
@s| (*fun->s.s_sfdef)(MMcdr(form));
CHECK_AVMA;
@s]
****Change:(orig (699 699 a))
@s[ vs_push(form);
goto EVAL;
}
@s| vs_push(form);
goto EVAL;
}
@s]
****Change:(orig (701 701 a))
@s[EVAL_ARGS:
vs_push(x);
@s|EVAL_ARGS:
vs_push(x);
ihs_check;
ihs_push(form);
ihs_top->ihs_base = lex_env;
@s]
****Change:(orig (716 719 c))
@s[ if (type_of(x) == t_cfun) {
MMcall(x);
} else
funcall(x);
@s| ihs_top->ihs_function = x;
ihs_top->ihs_base = vs_base;
if (type_of(x) == t_cfun)
(*(x)->cf.cf_self)();
else
funcall_no_event(x);
CHECK_AVMA;
ihs_pop();
@s]
****Change:(orig (961 961 a))
@s[ funcall(fun);
frs_pop();
}
@s| funcall(fun);
frs_pop();
}
#include <varargs.h>
object
fcalln_cclosure(ap)
va_list ap;
{int i=fcall.argd;
{object *base=vs_top;
DEBUG_AVMA
vs_base=base;
switch(i){
case 10: *(base++)=va_arg(ap,object);
case 9: *(base++)=va_arg(ap,object);
case 8: *(base++)=va_arg(ap,object);
case 7: *(base++)=va_arg(ap,object);
case 6: *(base++)=va_arg(ap,object);
case 5: *(base++)=va_arg(ap,object);
case 4: *(base++)=va_arg(ap,object);
case 3: *(base++)=va_arg(ap,object);
case 2: *(base++)=va_arg(ap,object);
case 1: *(base++)=va_arg(ap,object);
case 0: break;
default:
FEerror(0,"bad args");
} vs_top=base;
base=base -i;
do{object fun=fcall.fun;
object *top, *base, l;
if (fun->cc.cc_turbo != NULL) {
(*fun->cc.cc_self)(fun->cc.cc_turbo);
break;
}
top = vs_top;
base = vs_base;
for (l = fun->cc.cc_env; !endp(l); l = l->c.c_cdr)
vs_push(l);
vs_base = vs_top;
while (base < top)
vs_push(*base++);
(*fcall.fun->cc.cc_self)(top);
break;
}while (0);
vs_top=base;
CHECK_AVMA;
return(vs_base[0]);
}}
object
fcalln_general(ap)
va_list ap;
{int i=fcall.argd;
object fun=fcall.fun;
{int n= SFUN_NARGS(i);
/* object *old_vs_base=vs_base; */
object *old_vs_top=vs_top;
object x;
enum ftype typ,restype=SFUN_RETURN_TYPE(i);
vs_top = vs_base = old_vs_top;
SFUN_START_ARG_TYPES(i);
if (i==0)
while (n-- > 0)
{ typ= SFUN_NEXT_TYPE(i);
x =
(typ==f_object ? va_arg(ap,object):
typ==f_fixnum ? make_fixnum(va_arg(ap,fixnum)):
(object) FEerror("bad type",0));
*(vs_top++) = x;}
else
{object *base=vs_top;
while (n-- > 0)
{ *(base++) = va_arg(ap,object);}
vs_top=base;}
funcall(fcall.fun);
x= vs_base[0];
vs_top=old_vs_top;
/* vs_base=old_vs_base; */
return (restype== f_object ? x :
restype== f_fixnum ? (object) (fix(x)):
(object) FEerror("bad type",0));
}}
object
fcalln_vfun(vl)
va_list vl;
{object *new,res;
DEBUG_AVMA
COERCE_VA_LIST(new,vl,fcall.argd);
res = c_apply_n(fcall.fun->vfn.vfn_self,fcall.argd,new);
CHECK_AVMA;
return res;
}
object
fcalln(va_alist)
va_dcl
{ va_list ap;
object fun=fcall.fun;
DEBUG_AVMA
va_start(ap);
if(type_of(fun)==t_cfun)
{object *base=vs_top;
int i=fcall.argd;
vs_base=base;
switch(i){
case 10: *(base++)=va_arg(ap,object);
case 9: *(base++)=va_arg(ap,object);
case 8: *(base++)=va_arg(ap,object);
case 7: *(base++)=va_arg(ap,object);
case 6: *(base++)=va_arg(ap,object);
case 5: *(base++)=va_arg(ap,object);
case 4: *(base++)=va_arg(ap,object);
case 3: *(base++)=va_arg(ap,object);
case 2: *(base++)=va_arg(ap,object);
case 1: *(base++)=va_arg(ap,object);
case 0: break;
default:
FEerror(0,"bad args");
} vs_top=base;
base=base -i;
(*fcall.fun->cf.cf_self)();
vs_top=base;
CHECK_AVMA;
return(vs_base[0]);
}
if(type_of(fun)==t_cclosure)
return(fcalln_cclosure(ap));
if(type_of(fun)==t_vfun)
return(fcalln_vfun(ap));
return(fcalln_general(ap));
va_end(ap);
}
/* call a cfun eg funcall_cfun(Lmake_hash_table,2,Ktest,Seq) */
typedef void (*funcvoid)();
object
funcall_cfun(fn,n,va_alist)
int n;
funcvoid fn;
va_dcl
{object *old_top = vs_top;
object *old_base= vs_base;
object result;
va_list ap;
DEBUG_AVMA
vs_base=vs_top;
va_start(ap);
while(n-->0) vs_push(va_arg(ap,object));
va_end(ap);
(*fn)();
if(vs_top>vs_base) result=vs_base[0];
else result=Cnil;
vs_top=old_top;
vs_base=old_base;
CHECK_AVMA;
return result;}
@s]
****Change:(orig (963 963 a))
@s[init_eval()
{
@s|init_eval()
{
@s]
****Change:(orig (983 983 a))
@s[ make_function("APPLYHOOK", Lapplyhook);
@s| make_function("APPLYHOOK", Lapplyhook);
siSlambda_block_expanded=make_si_special("LAMBDA-BLOCK-EXPANDED",Cnil);
@s]
****Change:(orig (984 984 a))
@s[ make_function("CONSTANTP", Lconstantp);
@s| make_function("CONSTANTP", Lconstantp);
siSbreak_points = make_si_special("*BREAK-POINTS*",Cnil);
siSbreak_step = make_si_special("*BREAK-STEP*",Cnil);
@s]
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.