/[gcl]/gcl/o/eval.c
ViewVC logotype

Diff of /gcl/o/eval.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.3 by camm, Fri Jul 12 22:00:49 2002 UTC revision 1.4 by camm, Sat Jul 20 07:10:55 2002 UTC
# Line 46  warn_avma() Line 46  warn_avma()
46    
47    
48    
49  object c_apply_n();  /*  object c_apply_n(long int (*fn)(), int n, object *x); */
50    
51  object sSAbreak_pointsA;  object sSAbreak_pointsA;
52  object sSAbreak_stepA;  object sSAbreak_stepA;
# Line 54  object sSAbreak_stepA; Line 54  object sSAbreak_stepA;
54    
55  #define SET_TO_APPLY(res,f,n,x) \  #define SET_TO_APPLY(res,f,n,x) \
56   switch(n) {\   switch(n) {\
57   case 0:   res=(object)((long (*)())(f))(); break;\   case 0:   res=(*f)(); break;\
58    case 1:  res=(object)((long (*)())(f))(x[0]); break; \    case 1:  res=(*f)(x[0]); break; \
59    case 2:  res=(object)((long (*)())(f))(x[0],x[1]);break; \    case 2:  res=(*f)(x[0],x[1]);break; \
60    case 3:  res=(object)((long (*)())(f))(x[0],x[1],x[2]);break; \    case 3:  res=(*f)(x[0],x[1],x[2]);break; \
61    case 4:  res=(object)((long (*)())(f))(x[0],x[1],x[2],x[3]);break; \    case 4:  res=(*f)(x[0],x[1],x[2],x[3]);break; \
62    case 5:  res=(object)((long (*)())(f))(x[0],x[1],x[2],x[3],x[4]);break; \    case 5:  res=(*f)(x[0],x[1],x[2],x[3],x[4]);break; \
63    case 6:  res=(object)((long (*)())(f))(x[0],x[1],x[2],x[3],x[4],x[5]);  break;\    case 6:  res=(*f)(x[0],x[1],x[2],x[3],x[4],x[5]);  break;\
64    case 7:  res=(object)((long (*)())(f))(x[0],x[1],x[2],x[3],x[4],x[5], x[6]); break;\    case 7:  res=(*f)(x[0],x[1],x[2],x[3],x[4],x[5], x[6]); break;\
65    case 8:  res=(object)((long (*)())(f))(x[0],x[1],x[2],x[3],x[4],x[5], x[6],x[7]); break;\    case 8:  res=(*f)(x[0],x[1],x[2],x[3],x[4],x[5], x[6],x[7]); break;\
66    case 9:  res=(object)((long (*)())(f))(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8]);break;\    case 9:  res=(*f)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8]);break;\
67    case 10: res=(object)((long (*)())(f))(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9]);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;\
68     default: res=c_apply_n(f,n,x); break;}     default: res=c_apply_n(*f,n,x); break;}
69    
70  /*  /*
71  #undef SET_TO_APPLY  #undef SET_TO_APPLY
# Line 74  object sSAbreak_stepA; Line 74  object sSAbreak_stepA;
74    
75  /* for t_sfun,t_gfun with args on vs stack */  /* for t_sfun,t_gfun with args on vs stack */
76    
77  quick_call_sfun(fun)  void
78       object fun;  quick_call_sfun(object fun)
79  { DEBUG_AVMA  { DEBUG_AVMA
80    int i,n;    int i,n;
81    enum ftype restype;    enum ftype restype;
# Line 109  quick_call_sfun(fun) Line 109  quick_call_sfun(fun)
109    return;}    return;}
110    
111  /* only for sfun not gfun !!  Does not check number of args */  /* only for sfun not gfun !!  Does not check number of args */
112  call_sfun_no_check(fun)  void
113       object fun;  call_sfun_no_check(object fun)
114  { DEBUG_AVMA  { DEBUG_AVMA
115    int n;    int n;
116    object *base=vs_base;    object *base=vs_base;
# Line 120  call_sfun_no_check(fun) Line 120  call_sfun_no_check(fun)
120    CHECK_AVMA;    CHECK_AVMA;
121    return;    return;
122  }  }
123  call_vfun(fun)  void
124       object fun;  call_vfun(object fun)
125  { DEBUG_AVMA  { DEBUG_AVMA
126    int n;    int n;
127    object *base=vs_base;    object *base=vs_base;
# Line 138  call_vfun(fun) Line 138  call_vfun(fun)
138  }  }
139    
140    
141    void
142  funcall(fun)  funcall(object fun)
 object fun;  
143  {  {
144          object temporary;          object temporary;
145          object endp_temp;          object endp_temp;
# Line 326  END: Line 325  END:
325          CHECK_AVMA;          CHECK_AVMA;
326  }}  }}
327    
328    void
329  funcall_no_event(fun)  funcall_no_event(object fun)
 object fun;  
330  {  {
331          object endp_temp;          object endp_temp;
332   DEBUG_AVMA   DEBUG_AVMA
# Line 371  object fun; Line 369  object fun;
369          }          }
370  }  }
371    
372  lispcall(funp, narg)  void
373  object *funp;  lispcall(object *funp, int narg)
 int narg;  
374  {  {
375          object endp_temp; DEBUG_AVMA          object endp_temp; DEBUG_AVMA
376          object fun = *funp;          object fun = *funp;
# Line 414  int narg; Line 411  int narg;
411    CHECK_AVMA;    CHECK_AVMA;
412  }  }
413    
414  lispcall_no_event(funp, narg)  void
415  object *funp;  lispcall_no_event(object *funp, int narg)
 int narg;  
416  {       object endp_temp;        DEBUG_AVMA  {       object endp_temp;        DEBUG_AVMA
417          object fun = *funp;          object fun = *funp;
418    
# Line 457  int narg; Line 453  int narg;
453           CHECK_AVMA;           CHECK_AVMA;
454  }  }
455    
456  symlispcall(sym, base, narg)  void
457  object sym, *base;  symlispcall(object sym, object *base, int narg)
 int narg;  
458  {  {
459          object endp_temp;          object endp_temp;
460         DEBUG_AVMA         DEBUG_AVMA
# Line 500  int narg; Line 495  int narg;
495          CHECK_AVMA;          CHECK_AVMA;
496  }  }
497    
498  symlispcall_no_event(sym, base, narg)  void
499  object sym, *base;  symlispcall_no_event(object sym, object *base, int narg)
 int narg;  
500  {  {
501          object endp_temp;          object endp_temp;
502         DEBUG_AVMA         DEBUG_AVMA
# Line 545  int narg; Line 539  int narg;
539  }  }
540    
541  object  object
542  simple_lispcall(funp, narg)  simple_lispcall(object *funp, int narg)
 object *funp;  
 int narg;  
543  {  {
544          object endp_temp;          object endp_temp;
545         DEBUG_AVMA         DEBUG_AVMA
# Line 593  int narg; Line 585  int narg;
585  }  }
586    
587  object  object
588  simple_lispcall_no_event(funp, narg)  simple_lispcall_no_event(object *funp, int narg)
 object *funp;  
 int narg;  
589  {  {
590          object endp_temp;          object endp_temp;
591         DEBUG_AVMA         DEBUG_AVMA
# Line 641  int narg; Line 631  int narg;
631  }  }
632    
633  object  object
634  simple_symlispcall(sym, base, narg)  simple_symlispcall(object sym, object *base, int narg)
 object sym, *base;  
 int narg;  
635  {  {
636          object endp_temp;          object endp_temp;
637         DEBUG_AVMA         DEBUG_AVMA
# Line 689  int narg; Line 677  int narg;
677  }  }
678    
679  object  object
680  simple_symlispcall_no_event(sym, base, narg)  simple_symlispcall_no_event(object sym, object *base, int narg)
 object sym, *base;  
 int narg;  
681  {  {
682          object endp_temp;          object endp_temp;
683         DEBUG_AVMA         DEBUG_AVMA
# Line 735  int narg; Line 721  int narg;
721          return(vs_base[0]);          return(vs_base[0]);
722  }  }
723    
724  super_funcall(fun)  void
725  object fun;  super_funcall(object fun)
726  {  {
727          if (type_of(fun) == t_symbol) {          if (type_of(fun) == t_symbol) {
728                  if (fun->s.s_sfdef != NOT_SPECIAL || fun->s.s_mflag)                  if (fun->s.s_sfdef != NOT_SPECIAL || fun->s.s_mflag)
# Line 748  object fun; Line 734  object fun;
734          funcall(fun);          funcall(fun);
735  }  }
736    
737  super_funcall_no_event(fun)  void
738  object fun;  super_funcall_no_event(object fun)
739  {  {
740  #ifdef DEBUGGING_AVMA  #ifdef DEBUGGING_AVMA
741    funcall_no_event(fun); return;    funcall_no_event(fun); return;
# Line 808  EVAL: Line 794  EVAL:
794    
795          if (type_of(form) != t_symbol)  RETURN1(form);          if (type_of(form) != t_symbol)  RETURN1(form);
796    
 SYMBOL:  
797          switch (form->s.s_stype) {          switch (form->s.s_stype) {
798          case stp_constant:          case stp_constant:
799            RETURN1((form->s.s_dbind));            RETURN1((form->s.s_dbind));
# Line 876  APPLICATION: Line 861  APPLICATION:
861                          goto EVAL_ARGS;                          goto EVAL_ARGS;
862                  }                  }
863    
 GFDEF:  
864          if ((x = fun->s.s_gfdef) == OBJNULL)          if ((x = fun->s.s_gfdef) == OBJNULL)
865                  FEundefined_function(fun);                  FEundefined_function(fun);
866    
# Line 932  LAMBDA: Line 916  LAMBDA:
916  #else    #else  
917    
918  object  object
919  Ieval(form)  Ieval(object form)
      object form;  
920  { eval(form);  { eval(form);
921    return Ivs_values();    return Ivs_values();
922  }  }
923  #endif  #endif
924        
925    void
926  eval(form)  eval(object form)
 object form;  
927  {  {
928          object temporary;          object temporary;
929          object endp_temp;          object endp_temp;
# Line 949  object form; Line 931  object form;
931          object fun, x;          object fun, x;
932          object *top;          object *top;
933          object *base;          object *base;
         object orig_form;  
934    
935          cs_check(form);          cs_check(form);
936    
# Line 988  EVAL: Line 969  EVAL:
969                  return;                  return;
970          }          }
971    
 SYMBOL:  
972          switch (form->s.s_stype) {          switch (form->s.s_stype) {
973          case stp_constant:          case stp_constant:
974                  vs_base = vs_top;                  vs_base = vs_top;
# Line 1064  APPLICATION: Line 1044  APPLICATION:
1044                          goto EVAL_ARGS;                          goto EVAL_ARGS;
1045                  }                  }
1046    
 GFDEF:  
1047          if ((x = fun->s.s_gfdef) == OBJNULL)          if ((x = fun->s.s_gfdef) == OBJNULL)
1048                  FEundefined_function(fun);                  FEundefined_function(fun);
1049    
# Line 1120  LAMBDA: Line 1099  LAMBDA:
1099          FEinvalid_function(fun);          FEinvalid_function(fun);
1100  }        }      
1101    
1102  call_applyhook(fun)  void
1103  object fun;  call_applyhook(object fun)
1104  {  {
1105          object ah;          object ah;
1106          object *v;          object *v;
# Line 1164  DEFUNO("APPLY",object,fLapply,LISP Line 1143  DEFUNO("APPLY",object,fLapply,LISP
1143       object fun;       object fun;
1144  va_dcl  va_dcl
1145  {       int m,n=VFUN_NARGS;  {       int m,n=VFUN_NARGS;
         object *new;  
1146          object list;          object list;
1147          object buf[MAX_ARGS];          object buf[MAX_ARGS];
1148          object *base=buf;          object *base=buf;
# Line 1199  object x0; Line 1177  object x0;
1177          return Ivs_values();          return Ivs_values();
1178  }  }
1179    
1180  Levalhook()  void
1181    Levalhook(void)
1182  {  {
1183          object env;          object env;
1184          bds_ptr old_bds_top = bds_top;          bds_ptr old_bds_top = bds_top;
# Line 1229  Levalhook() Line 1208  Levalhook()
1208          bds_unwind(old_bds_top);          bds_unwind(old_bds_top);
1209  }  }
1210    
1211  Lapplyhook()  void
1212    Lapplyhook(void)
1213  {  {
1214          object endp_temp;          object endp_temp;
1215    
# Line 1289  object x0; Line 1269  object x0;
1269  }  }
1270    
1271  object  object
1272  ieval(x)  ieval(object x)
 object x;  
1273  {  {
1274          object *old_vs_base;          object *old_vs_base;
1275          object *old_vs_top;          object *old_vs_top;
# Line 1305  object x; Line 1284  object x;
1284  }  }
1285    
1286  object  object
1287  ifuncall1(fun, arg1)  ifuncall1(object fun, object arg1)
 object fun, arg1;  
1288  {  {
1289          object *old_vs_base;          object *old_vs_base;
1290          object *old_vs_top;          object *old_vs_top;
# Line 1324  object fun, arg1; Line 1302  object fun, arg1;
1302  }  }
1303    
1304  object  object
1305  ifuncall2(fun, arg1, arg2)  ifuncall2(object fun, object arg1, object arg2)
 object fun, arg1, arg2;  
1306  {  {
1307          object *old_vs_base;          object *old_vs_base;
1308          object *old_vs_top;          object *old_vs_top;
# Line 1344  object fun, arg1, arg2; Line 1321  object fun, arg1, arg2;
1321  }  }
1322    
1323  object  object
1324  ifuncall3(fun, arg1, arg2, arg3)  ifuncall3(object fun, object arg1, object arg2, object arg3)
 object fun, arg1, arg2, arg3;  
1325  {  {
1326          object *old_vs_base;          object *old_vs_base;
1327          object *old_vs_top;          object *old_vs_top;
# Line 1364  object fun, arg1, arg2, arg3; Line 1340  object fun, arg1, arg2, arg3;
1340          return(x);          return(x);
1341  }  }
1342    
1343  funcall_with_catcher(fname, fun)  void
1344  object fname, fun;  funcall_with_catcher(object fname, object fun)
1345  {  {
1346          int n = vs_top - vs_base;          int n = vs_top - vs_base;
1347          if (n > 64) n = 64;          if (n > 64) n = 64;
# Line 1380  object fname, fun; Line 1356  object fname, fun;
1356  #include <varargs.h>  #include <varargs.h>
1357    
1358  object  object
1359  fcalln_cclosure(ap)  fcalln_cclosure(va_list ap)
 va_list ap;  
1360  {  {
1361  object endp_temp;  object endp_temp;
1362  int i=fcall.argd;  int i=fcall.argd;
# Line 1427  int i=fcall.argd; Line 1402  int i=fcall.argd;
1402  }}  }}
1403    
1404  object  object
1405  fcalln_general(ap)  fcalln_general(va_list ap) {
1406  va_list ap;    int i=fcall.argd;
1407  {int i=fcall.argd;  
1408   object fun=fcall.fun;    {
1409   {int n= SFUN_NARGS(i);      int n= SFUN_NARGS(i);
1410    /*  object *old_vs_base=vs_base; */      /*  object *old_vs_base=vs_base; */
1411    object *old_vs_top=vs_top;      object *old_vs_top=vs_top;
1412    object x;      object x;
1413    enum ftype typ,restype=SFUN_RETURN_TYPE(i);      enum ftype typ,restype=SFUN_RETURN_TYPE(i);
1414    vs_top =  vs_base = old_vs_top;      vs_top =  vs_base = old_vs_top;
1415    SFUN_START_ARG_TYPES(i);      SFUN_START_ARG_TYPES(i);
1416    if (i==0)      if (i==0)
1417      while (n-- > 0)        while (n-- > 0) {
1418        { typ= SFUN_NEXT_TYPE(i);          typ= SFUN_NEXT_TYPE(i);
1419          x =          x =
1420            (typ==f_object ?      va_arg(ap,object):            (typ==f_object ?      va_arg(ap,object):
1421             typ==f_fixnum ? make_fixnum(va_arg(ap,fixnum)):             typ==f_fixnum ? make_fixnum(va_arg(ap,fixnum)):
1422             (object) (FEerror("bad type",0),Cnil));             (object) (FEerror("bad type",0),Cnil));
1423          *(vs_top++) = x;}          *(vs_top++) = x;
1424    else        }
1425      {object *base=vs_top;      else {
1426       while (n-- > 0)        object *base=vs_top;
1427         { *(base++) = va_arg(ap,object);}        while (n-- > 0)
1428       vs_top=base;}          *(base++) = va_arg(ap,object);
1429    funcall(fcall.fun);       vs_top=base;
1430    x= vs_base[0];      }
1431    vs_top=old_vs_top;      funcall(fcall.fun);
1432    /* vs_base=old_vs_base; */      x= vs_base[0];
1433    return (restype== f_object ? x :      vs_top=old_vs_top;
1434            restype== f_fixnum ? (object) (fix(x)):      /* vs_base=old_vs_base; */
1435            (object) (FEerror("bad type",0),Cnil));      return (restype== f_object ? x :
1436  }}              restype== f_fixnum ? (object) (fix(x)):
1437                (object) (FEerror("bad type",0),Cnil));
1438      }
1439    }
1440    
1441  object  object
1442  fcalln_vfun(vl)  fcalln_vfun(va_list vl)
   va_list vl;  
1443  {object *new,res;  {object *new,res;
1444   DEBUG_AVMA   DEBUG_AVMA
1445   {COERCE_VA_LIST(new,vl,fcall.argd);   {COERCE_VA_LIST(new,vl,fcall.argd);
# Line 1472  fcalln_vfun(vl) Line 1450  fcalln_vfun(vl)
1450  }  }
1451    
1452  object  object
1453  fcalln(va_alist)  fcalln(__builtin_va_alist_t __builtin_va_alist)
 va_dcl  
1454  {  va_list ap;  {  va_list ap;
1455     object fun=fcall.fun;     object fun=fcall.fun;
1456     DEBUG_AVMA     DEBUG_AVMA
# Line 1512  va_dcl Line 1489  va_dcl
1489   }   }
1490    
1491  /* call a cfun eg funcall_cfun(Lmake_hash_table,2,sKtest,sLeq) */  /* call a cfun eg funcall_cfun(Lmake_hash_table,2,sKtest,sLeq) */
1492  typedef void (*funcvoid)();  /*  typedef void (*funcvoid)(); */
1493    
1494  object  object
1495  funcall_cfun(fn,n,va_alist)  funcall_cfun(funcvoid fn, int n, __builtin_va_alist_t __builtin_va_alist)
      int n;  
      funcvoid fn;  
      va_dcl  
1496  {object *old_top = vs_top;  {object *old_top = vs_top;
1497   object *old_base= vs_base;   object *old_base= vs_base;
1498   object result;   object result;
# Line 1540  DEF_ORDINARY("LAMBDA-BLOCK-EXPANDED",sSl Line 1514  DEF_ORDINARY("LAMBDA-BLOCK-EXPANDED",sSl
1514  DEFVAR("*BREAK-POINTS*",sSAbreak_pointsA,SI,Cnil,"");  DEFVAR("*BREAK-POINTS*",sSAbreak_pointsA,SI,Cnil,"");
1515  DEFVAR("*BREAK-STEP*",sSAbreak_stepA,SI,Cnil,"");  DEFVAR("*BREAK-STEP*",sSAbreak_stepA,SI,Cnil,"");
1516    
1517    void
1518  init_eval()  init_eval(void)
1519  {  {
1520    
1521    

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26