home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / eval.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  25.8 KB  |  1,350 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. */
  21.  
  22. /*
  23.     eval.c
  24. */
  25.  
  26. #include "include.h"
  27. #include "sfun_argd.h"
  28.  
  29. struct nil3 { object nil3_self[3]; } three_nils;
  30.  
  31. #ifdef DEBUG_AVMA
  32. #undef DEBUG_AVMA
  33. unsigned long avma,bot;
  34. #define DEBUG_AVMA unsigned long saved_avma =  avma;
  35. warn_avma()
  36. { 
  37.   print(list(2,make_simple_string("avma changed"),ihs_top_function_name()),
  38.     Vstandard_output->s.s_dbind);
  39. }
  40. #define CHECK_AVMA if(avma!= saved_avma) warn_avma();
  41. #define DEBUGGING_AVMA  
  42. #else
  43. #define DEBUG_AVMA
  44. #define CHECK_AVMA
  45. #endif
  46.  
  47. #undef endp
  48.  
  49. #define    endp(obje)    ((enum type)((endp_temp = (obje))->d.t) == t_cons ? \
  50.              FALSE : endp_temp == Cnil ? TRUE : \
  51.              (bool)FEwrong_type_argument(Slist, endp_temp))
  52.  
  53. object endp_temp;
  54.  
  55. int eval1 = 0;
  56. object c_apply_n();
  57.  
  58. object siSbreak_points;
  59. object siSbreak_step;
  60.  
  61.  
  62. #define SET_TO_APPLY(res,f,n,x) \
  63.  switch(n) {\
  64.  case 0:   res=((f))(); break;\
  65.   case 1:  res=((f))(x[0]); break; \
  66.   case 2:  res=((f))(x[0],x[1]);break; \
  67.   case 3:  res=((f))(x[0],x[1],x[2]);break; \
  68.   case 4:  res=((f))(x[0],x[1],x[2],x[3]);break; \
  69.   case 5:  res=((f))(x[0],x[1],x[2],x[3],x[4]);break; \
  70.   case 6:  res=((f))(x[0],x[1],x[2],x[3],x[4],x[5]);  break;\
  71.   case 7:  res=((f))(x[0],x[1],x[2],x[3],x[4],x[5], x[6]); break;\
  72.   case 8:  res=((f))(x[0],x[1],x[2],x[3],x[4],x[5], x[6],x[7]); break;\
  73.   case 9:  res=((f))(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8]);break;\
  74.   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;\
  75.    default: res=c_apply_n(f,n,x); break;}
  76.  
  77. /*
  78. #undef SET_TO_APPLY
  79. #define SET_TO_APPLY(res,f,n,x)  res=c_apply_n(f,n,x);
  80. */
  81.  
  82. /* for t_sfun,t_gfun with args on vs stack */
  83.  
  84. quick_call_sfun(fun)
  85.      object fun;
  86. { DEBUG_AVMA
  87.   int i,n;
  88.   enum ftype restype;
  89.   object *x,res;
  90.   object temp_ar[10];
  91.   i=fun->sfn.sfn_argd;
  92.   n=SFUN_NARGS(i);
  93.   if (n != vs_top -vs_base)
  94.     {check_arg_failed(n);}
  95.   restype = SFUN_RETURN_TYPE(i);
  96.   SFUN_START_ARG_TYPES(i);
  97.   /* for moment just support object and int */
  98. #define COERCE_ARG(a,type)  (type==f_object ? a : (object)(fix(a)))
  99.   if (i==0)
  100.     x=vs_base;
  101.   else
  102.     {int j;
  103.      x=temp_ar;
  104.      for (j=0; j<n ; j++)
  105.        {enum ftype typ=SFUN_NEXT_TYPE(i);
  106.     x[j]=COERCE_ARG(vs_base[j],typ);}}
  107.   SET_TO_APPLY(res,(object (*)())fun->sfn.sfn_self,n,x);
  108.   vs_base[0]=
  109.     (restype==f_object ?  res :
  110.      restype==f_fixnum ? make_fixnum((int)res)
  111.      :(object) FEerror("Bad result type"));
  112.   vs_top=vs_base+1;
  113.   CHECK_AVMA;
  114.   return;}
  115.  
  116. /* only for sfun not gfun !!  Does not check number of args */
  117. call_sfun_no_check(fun)
  118.      object fun;
  119. { DEBUG_AVMA
  120.   int n;
  121.   object *base=vs_base;
  122.   n=vs_top - base;
  123.   SET_TO_APPLY(base[0],(object (*)())fun->sfn.sfn_self,n,base);
  124.   vs_top=(vs_base=base)+1;
  125.   CHECK_AVMA;
  126.   return;
  127. }
  128. call_vfun(fun)
  129.      object fun;
  130. { DEBUG_AVMA
  131.   int n;
  132.   object *base=vs_base;
  133.   n=vs_top - base;
  134.   if (n < fun->vfn.vfn_minargs)
  135.     {FEtoo_few_arguments(base,vs_top); return;}
  136.   if (n > fun->vfn.vfn_maxargs)
  137.     {FEtoo_many_arguments(base,vs_top); return;}
  138.   VFUN_NARGS = n;
  139.   SET_TO_APPLY(base[0],(object (*)())fun->sfn.sfn_self,n,base);
  140.   vs_top=(vs_base=base)+1;
  141.   CHECK_AVMA;
  142.   return;
  143. }
  144.  
  145. static object temporary;
  146.  
  147. funcall(fun)
  148. object fun;
  149. {
  150.     object x;
  151.      object * VOL top;
  152.     object *lex;
  153.     bds_ptr old_bds_top;
  154.     VOL bool b;
  155.     bool c;
  156.     DEBUG_AVMA
  157.       TOP:
  158.     if (fun == OBJNULL)
  159.         FEerror("Undefined function.", 0);
  160.     switch (type_of(fun)) {
  161.     case t_cfun:
  162.         MMcall(fun);
  163.         CHECK_AVMA; return;
  164.     case t_gfun:    
  165.     case t_sfun:
  166.         ihs_check;ihs_push(fun);
  167.         quick_call_sfun(fun);
  168.         ihs_pop();
  169.         return;
  170.         case t_vfun:
  171.         ihs_check;ihs_push(fun);
  172.         call_vfun(fun);
  173.         ihs_pop();
  174.         return;
  175.     case t_cclosure:
  176.     {
  177.         object *top, *base, l;
  178.  
  179.         if (fun->cc.cc_turbo != NULL) {
  180.             MMccall(fun, fun->cc.cc_turbo);
  181.             CHECK_AVMA; return;
  182.         }
  183.         top = vs_top;
  184.         base = vs_base;
  185.         for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
  186.             vs_push(l);
  187.         vs_base = vs_top;
  188.         while (base < top)
  189.             vs_push(*base++);
  190.         MMccall(fun, top);
  191.         CHECK_AVMA; return;
  192.     }
  193.         
  194.         case t_dclosure:
  195.         (*(fun)->dc.dc_self)(fun->dc.dc_env);
  196.         CHECK_AVMA; return;
  197.     case t_symbol:
  198.          {object x = fun->s.s_gfdef;
  199.           if (x) { fun = x; goto TOP;}
  200.           else
  201.         FEundefined_function(fun);
  202.           }
  203.  
  204.     case t_cons:
  205.         break;
  206.  
  207.     default:
  208.         FEinvalid_function(fun);
  209.     }
  210.  
  211.     /*
  212.         This part is the same as that of funcall_no_event.
  213.     */
  214.  
  215.     /* we may have pushed the calling form if this is called invoked from 
  216.        eval.   A lambda call requires vs_push's, so we can tell
  217.        if we pushed by vs_base being the same.
  218.        */
  219.       { VOL int not_pushed = 0;
  220.     if (vs_base !=     ihs_top->ihs_base){
  221.       ihs_check;
  222.       ihs_push(fun);
  223.     }
  224.     else
  225.       not_pushed = 1;
  226.  
  227.     ihs_top->ihs_base = lex_env;
  228.     x = MMcar(fun);
  229.     top = vs_top;
  230.     lex = lex_env;
  231.     old_bds_top = bds_top;
  232.  
  233.     /* maybe digest this lambda expression
  234.        (lambda-block-expand name ..) has already been
  235.        expanded.    The value of lambda-block-expand may
  236.        be a compiled function in which case we say expand
  237.        with it)
  238.      */
  239.  
  240.     if (x == siSlambda_block_expanded) {
  241.  
  242.       b = TRUE;
  243.       c = FALSE;
  244.       fun = fun->c.c_cdr;
  245.  
  246.     }else if (x == Slambda_block) {
  247.       b = TRUE;
  248.       c = FALSE;
  249.       if(type_of(siSlambda_block_expanded->s.s_dbind) == t_sfun)
  250.         fun = ifuncall1(siSlambda_block_expanded->s.s_dbind,fun);
  251.  
  252.       fun = fun->c.c_cdr;
  253.  
  254.  
  255.     
  256.     } else if (x == Slambda_closure) {
  257.         b = FALSE;
  258.         c = TRUE;
  259.         fun = fun->c.c_cdr;
  260.     } else if (x == Slambda) {
  261.         b = c = FALSE;
  262.         fun = fun->c.c_cdr;
  263.     } else if (x == Slambda_block_closure) {
  264.         b = c = TRUE;
  265.         fun = fun->c.c_cdr;
  266.     } else
  267.         b = c = TRUE;
  268.     if (c) {
  269.         vs_push(kar(fun));
  270.         fun = fun->c.c_cdr;
  271.         vs_push(kar(fun));
  272.         fun = fun->c.c_cdr;
  273.         vs_push(kar(fun));
  274.         fun = fun->c.c_cdr;
  275.     } else {
  276.         *(struct nil3 *)vs_top = three_nils;
  277.         vs_top += 3;
  278.     }
  279.     if (b) {
  280.         x = kar(fun);  /* block name */
  281.         fun = fun->c.c_cdr;
  282.     }
  283.     lex_env = top;
  284.     vs_push(fun);
  285.         lambda_bind(top);
  286.     ihs_top->ihs_base = lex_env;
  287.     if (b) {
  288.         fun = temporary = alloc_frame_id();
  289.         /*  lex_block_bind(x, temporary);  */
  290.         temporary = MMcons(temporary, Cnil);
  291.         temporary = MMcons(Sblock, temporary);
  292.         temporary = MMcons(x, temporary);
  293.         lex_env[2] = MMcons(temporary, lex_env[2]);
  294.         frs_push(FRS_CATCH, fun);
  295.         if (nlj_active) {
  296.             nlj_active = FALSE;
  297.             goto END;
  298.         }
  299.     }
  300.     x = top[3];  /* body */
  301.     if(endp(x)) {
  302.         vs_base = vs_top;
  303.         vs_push(Cnil);
  304.     } else {
  305.         top = vs_top;
  306.         for (;;) {
  307.             eval(MMcar(x));
  308.             x = MMcdr(x);
  309.             if (endp(x))
  310.                 break;
  311.             vs_top = top;
  312.         }
  313.     }
  314. END:
  315.     if (b)
  316.         frs_pop();
  317.     bds_unwind(old_bds_top);
  318.     lex_env = lex;
  319.     if (not_pushed == 0) {ihs_pop();}
  320.     CHECK_AVMA;
  321. }}
  322.  
  323.  
  324. funcall_no_event(fun)
  325. object fun;
  326. { DEBUG_AVMA
  327.     if (fun == OBJNULL)
  328.         FEerror("Undefined function.", 0);
  329.     switch (type_of(fun)) {
  330.     case t_cfun:
  331.         (*fun->cf.cf_self)();
  332.         break;
  333.  
  334.     case t_cclosure:
  335.     {
  336.         object *top, *base, l;
  337.  
  338.         if (fun->cc.cc_turbo != NULL) {
  339.             (*fun->cc.cc_self)(fun->cc.cc_turbo);
  340.             break;
  341.         }
  342.         top = vs_top;
  343.         base = vs_base;
  344.         for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
  345.             vs_push(l);
  346.         vs_base = vs_top;
  347.         while (base < top)
  348.             vs_push(*base++);
  349.         (*fun->cc.cc_self)(top);
  350.         break;
  351.     }
  352.  
  353.     case t_sfun:
  354.         call_sfun_no_check(fun); return;
  355.         case t_gfun:
  356.         quick_call_sfun(fun); return;
  357.         case t_vfun:
  358.         call_vfun(fun); return;
  359.         case t_dclosure:
  360.         (*(fun)->dc.dc_self)(fun->dc.dc_env);
  361.         CHECK_AVMA; return;
  362.  
  363.     default:
  364.         funcall(fun);
  365.         
  366.     }
  367. }
  368.  
  369. lispcall(funp, narg)
  370. object *funp;
  371. int narg;
  372. { DEBUG_AVMA
  373.     object fun = *funp;
  374.  
  375.     vs_base = funp + 1;
  376.     vs_top = vs_base + narg;
  377.  
  378.     if (fun == OBJNULL)
  379.         FEerror("Undefined function.", 0);
  380.     switch (type_of(fun)) {
  381.     case t_cfun:
  382.         MMcall(fun);
  383.         break;
  384.  
  385.     case t_cclosure:
  386.     {
  387.         object *top, *base, l;
  388.  
  389.         if (fun->cc.cc_turbo != NULL) {
  390.             MMccall(fun, fun->cc.cc_turbo);
  391.             break;
  392.         }
  393.         top = vs_top;
  394.         base = vs_base;
  395.         for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
  396.             vs_push(l);
  397.         vs_base = vs_top;
  398.         while (base < top)
  399.             vs_push(*base++);
  400.         MMccall(fun, top);
  401.         break;
  402.     }
  403.  
  404.           default:
  405.         funcall(fun);
  406.  
  407.     }
  408.   CHECK_AVMA;
  409. }
  410.  
  411. lispcall_no_event(funp, narg)
  412. object *funp;
  413. int narg;
  414. {        DEBUG_AVMA
  415.     object fun = *funp;
  416.  
  417.     vs_base = funp + 1;
  418.     vs_top = vs_base + narg;
  419.  
  420.     if (fun == OBJNULL)
  421.         FEerror("Undefined function.", 0);
  422.     switch (type_of(fun)) {
  423.     case t_cfun:
  424.         (*fun->cf.cf_self)();
  425.         break;
  426.  
  427.     case t_cclosure:
  428.     {
  429.         object *top, *base, l;
  430.  
  431.         if (fun->cc.cc_turbo != NULL) {
  432.             (*fun->cc.cc_self)(fun->cc.cc_turbo);
  433.             break;
  434.         }
  435.         top = vs_top;
  436.         base = vs_base;
  437.         for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
  438.             vs_push(l);
  439.         vs_base = vs_top;
  440.         while (base < top)
  441.             vs_push(*base++);
  442.         (*fun->cc.cc_self)(top);
  443.         break;
  444.     }
  445.  
  446.  
  447.     default:
  448.         funcall(fun);
  449.  
  450.     }
  451.      CHECK_AVMA;
  452. }
  453.  
  454. symlispcall(sym, base, narg)
  455. object sym, *base;
  456. int narg;
  457. {       DEBUG_AVMA
  458.     object fun = symbol_function(sym);
  459.  
  460.     vs_base = base;
  461.     vs_top = vs_base + narg;
  462.  
  463.     if (fun == OBJNULL)
  464.         FEerror("Undefined function.", 0);
  465.     switch (type_of(fun)) {
  466.     case t_cfun:
  467.         MMcall(fun);
  468.         break;
  469.  
  470.     case t_cclosure:
  471.     {
  472.         object *top, *base, l;
  473.  
  474.         if (fun->cc.cc_turbo != NULL) {
  475.             MMccall(fun, fun->cc.cc_turbo);
  476.             break;
  477.         }
  478.         top = vs_top;
  479.         base = vs_base;
  480.         for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
  481.             vs_push(l);
  482.         vs_base = vs_top;
  483.         while (base < top)
  484.             vs_push(*base++);
  485.         MMccall(fun, top);
  486.         break;
  487.     }
  488.  
  489.     default:
  490.         funcall(fun);
  491.     }
  492.     CHECK_AVMA;
  493. }
  494.  
  495. symlispcall_no_event(sym, base, narg)
  496. object sym, *base;
  497. int narg;
  498. {       DEBUG_AVMA
  499.     object fun = symbol_function(sym);
  500.  
  501.     vs_base = base;
  502.     vs_top = vs_base + narg;
  503.  
  504.     if (fun == OBJNULL)
  505.         FEerror("Undefined function.", 0);
  506.     switch (type_of(fun)) {
  507.     case t_cfun:
  508.         (*fun->cf.cf_self)();
  509.         break;
  510.  
  511.     case t_cclosure:
  512.     {
  513.         object *top, *base, l;
  514.  
  515.         if (fun->cc.cc_turbo != NULL) {
  516.             (*fun->cc.cc_self)(fun->cc.cc_turbo);
  517.             break;
  518.         }
  519.         top = vs_top;
  520.         base = vs_base;
  521.         for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
  522.             vs_push(l);
  523.         vs_base = vs_top;
  524.         while (base < top)
  525.             vs_push(*base++);
  526.         (*fun->cc.cc_self)(top);
  527.         break;
  528.     }
  529.  
  530.     default:
  531.         funcall(fun);
  532.  
  533.     }
  534.     CHECK_AVMA;
  535. }
  536.  
  537. object
  538. simple_lispcall(funp, narg)
  539. object *funp;
  540. int narg;
  541. {       DEBUG_AVMA
  542.     object fun = *funp;
  543.     object *sup = vs_top;
  544.  
  545.     vs_base = funp + 1;
  546.     vs_top = vs_base + narg;
  547.  
  548.     if (fun == OBJNULL)
  549.         FEerror("Undefined function.", 0);
  550.     switch (type_of(fun)) {
  551.     case t_cfun:
  552.         MMcall(fun);
  553.         break;
  554.  
  555.     case t_cclosure:
  556.     {
  557.         object *top, *base, l;
  558.  
  559.         if (fun->cc.cc_turbo != NULL) {
  560.             MMccall(fun, fun->cc.cc_turbo);
  561.             break;
  562.         }
  563.         top = vs_top;
  564.         base = vs_base;
  565.         for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
  566.             vs_push(l);
  567.         vs_base = vs_top;
  568.         while (base < top)
  569.             vs_push(*base++);
  570.         MMccall(fun, top);
  571.         break;
  572.     }
  573.  
  574.     default:
  575.         funcall(fun);
  576.     }
  577.     vs_top = sup;
  578.     CHECK_AVMA;
  579.     return(vs_base[0]);
  580.     
  581. }
  582.  
  583. object
  584. simple_lispcall_no_event(funp, narg)
  585. object *funp;
  586. int narg;
  587. {       DEBUG_AVMA 
  588.     object fun = *funp;
  589.     object *sup = vs_top;
  590.  
  591.     vs_base = funp + 1;
  592.     vs_top = vs_base + narg;
  593.  
  594.     if (fun == OBJNULL)
  595.         FEerror("Undefined function.", 0);
  596.     switch (type_of(fun)) {
  597.     case t_cfun:
  598.         (*fun->cf.cf_self)();
  599.         break;
  600.  
  601.     case t_cclosure:
  602.     {
  603.         object *top, *base, l;
  604.  
  605.         if (fun->cc.cc_turbo != NULL) {
  606.             (*fun->cc.cc_self)(fun->cc.cc_turbo);
  607.             break;
  608.         }
  609.         top = vs_top;
  610.         base = vs_base;
  611.         for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
  612.             vs_push(l);
  613.         vs_base = vs_top;
  614.         while (base < top)
  615.             vs_push(*base++);
  616.         (*fun->cc.cc_self)(top);
  617.         break;
  618.     }
  619.  
  620.     default:
  621.         funcall(fun);
  622.  
  623.     }
  624.     vs_top = sup;
  625.     CHECK_AVMA;
  626.     return(vs_base[0]);
  627. }
  628.  
  629. object
  630. simple_symlispcall(sym, base, narg)
  631. object sym, *base;
  632. int narg;
  633. {       DEBUG_AVMA
  634.     object fun = symbol_function(sym);
  635.     object *sup = vs_top;
  636.  
  637.     vs_base = base;
  638.     vs_top = vs_base + narg;
  639.  
  640.     if (fun == OBJNULL)
  641.         FEerror("Undefined function.", 0);
  642.     switch (type_of(fun)) {
  643.     case t_cfun:
  644.         MMcall(fun);
  645.         break;
  646.  
  647.     case t_cclosure:
  648.     {
  649.         object *top, *base, l;
  650.  
  651.         if (fun->cc.cc_turbo != NULL) {
  652.             MMccall(fun, fun->cc.cc_turbo);
  653.             break;
  654.         }
  655.         top = vs_top;
  656.         base = vs_base;
  657.         for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
  658.             vs_push(l);
  659.         vs_base = vs_top;
  660.         while (base < top)
  661.             vs_push(*base++);
  662.         MMccall(fun, top);
  663.         break;
  664.     }
  665.  
  666.     default:
  667.         funcall(fun);
  668.  
  669.     }
  670.     vs_top = sup;
  671.     CHECK_AVMA;
  672.     return(vs_base[0]);
  673. }
  674.  
  675. object
  676. simple_symlispcall_no_event(sym, base, narg)
  677. object sym, *base;
  678. int narg;
  679. {       DEBUG_AVMA
  680.     object fun = symbol_function(sym);
  681.     object *sup = vs_top;
  682.  
  683.     vs_base = base;
  684.     vs_top = vs_base + narg;
  685.  
  686.     if (fun == OBJNULL)
  687.         FEerror("Undefined function.", 0);
  688.     switch (type_of(fun)) {
  689.     case t_cfun:
  690.         (*fun->cf.cf_self)();
  691.         break;
  692.  
  693.     case t_cclosure:
  694.     {
  695.         object *top, *base, l;
  696.  
  697.         if (fun->cc.cc_turbo != NULL) {
  698.             (*fun->cc.cc_self)(fun->cc.cc_turbo);
  699.             break;
  700.         }
  701.         top = vs_top;
  702.         base = vs_base;
  703.         for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
  704.             vs_push(l);
  705.         vs_base = vs_top;
  706.         while (base < top)
  707.             vs_push(*base++);
  708.         (*fun->cc.cc_self)(top);
  709.         break;
  710.     }
  711.  
  712.     default:
  713.         funcall(fun);
  714.     }
  715.     vs_top = sup;
  716.     CHECK_AVMA;
  717.     return(vs_base[0]);
  718. }
  719.  
  720. super_funcall(fun)
  721. object fun;
  722. {
  723.     if (type_of(fun) == t_symbol) {
  724.         if (fun->s.s_sfdef != NOT_SPECIAL || fun->s.s_mflag)
  725.             FEinvalid_function(fun);
  726.         if (fun->s.s_gfdef == OBJNULL)
  727.             FEundefined_function(fun);
  728.         fun = fun->s.s_gfdef;
  729.     }
  730.     funcall(fun);
  731. }
  732.  
  733. super_funcall_no_event(fun)
  734. object fun;
  735. {
  736. #ifdef DEBUGGING_AVMA
  737.   funcall_no_event(fun); return;
  738. #endif 
  739.    if (type_of(fun)==t_cfun){(*fun->cf.cf_self)();return;}
  740.    if (type_of(fun)==t_sfun){call_sfun_no_check(fun); return;}
  741.    if (type_of(fun)==t_gfun)
  742.        {quick_call_sfun(fun); return;}
  743.    if (type_of(fun)==t_vfun)
  744.        {call_vfun(fun); return;}
  745.    if (type_of(fun) == t_symbol) {
  746.       if (fun->s.s_sfdef != NOT_SPECIAL || fun->s.s_mflag)
  747.             FEinvalid_function(fun);
  748.         if (fun->s.s_gfdef == OBJNULL)
  749.             FEundefined_function(fun);
  750.         fun = fun->s.s_gfdef;
  751.         if (type_of(fun)==t_cfun){(*fun->cf.cf_self)();
  752.                       return;}
  753.     }
  754.     funcall_no_event(fun);
  755. }
  756.  
  757. eval(form)
  758. object form;
  759. {       DEBUG_AVMA
  760.     object fun, x;
  761.     object *top;
  762.     object *base;
  763.     object orig_form;
  764.  
  765.     cs_check(form);
  766.  
  767. EVAL:
  768.  
  769.     vs_check;
  770.  
  771.     if (Vevalhook->s.s_dbind != Cnil && eval1 == 0)
  772.     {
  773.         bds_ptr old_bds_top = bds_top;
  774.         object hookfun = symbol_value(Vevalhook);
  775.         /*  check if Vevalhook is unbound  */
  776.  
  777.         bds_bind(Vevalhook, Cnil);
  778.         vs_base = vs_top;
  779.         vs_push(form);
  780.         vs_push(lex_env[0]);
  781.         vs_push(lex_env[1]);
  782.         vs_push(lex_env[2]);
  783.         vs_push(Cnil);
  784.         stack_cons();
  785.         stack_cons();
  786.         stack_cons();
  787.         super_funcall(hookfun);
  788.         bds_unwind(old_bds_top);
  789.         return;
  790.     } else
  791.         eval1 = 0;
  792.  
  793.     if (type_of(form) == t_cons)
  794.         goto APPLICATION;
  795.  
  796.     if (type_of(form) != t_symbol) {
  797.         vs_base = vs_top;
  798.         vs_push(form);
  799.         return;
  800.     }
  801.  
  802. SYMBOL:
  803.     switch (form->s.s_stype) {
  804.     case stp_constant:
  805.         vs_base = vs_top;
  806.         vs_push(form->s.s_dbind);
  807.         return;
  808.  
  809.     case stp_special:
  810.         if(form->s.s_dbind == OBJNULL)
  811.             FEunbound_variable(form);
  812.         vs_base = vs_top;
  813.         vs_push(form->s.s_dbind);
  814.         return;
  815.  
  816.     default:
  817.         /*  x = lex_var_sch(form);  */
  818.         for (x = lex_env[0];  type_of(x) == t_cons;  x = x->c.c_cdr)
  819.             if (x->c.c_car->c.c_car == form) {
  820.                 x = x->c.c_car->c.c_cdr;
  821.                 if (endp(x))
  822.                     break;
  823.                 vs_base = vs_top;
  824.                 vs_push(x->c.c_car);
  825.                 return;
  826.             }
  827.         if(form->s.s_dbind == OBJNULL)
  828.             FEunbound_variable(form);
  829.         vs_base = vs_top;
  830.         vs_push(form->s.s_dbind);
  831.         return;
  832.     }
  833.  
  834. APPLICATION:
  835.     /* Hook for possibly stopping at forms in the break point
  836.        list.  Also for stepping.  We only want to check
  837.        one form each time round, so we do *breakpoints*
  838.        */
  839.     if (siSbreak_points->s.s_dbind != Cnil)
  840.       { if (siSbreak_step->s.s_dbind == Cnil ||
  841.         ifuncall2(siSbreak_step->s.s_dbind,form,
  842.               list(3,lex_env[0],lex_env[1],lex_env[2])) == Cnil)
  843.           {object* bpts = siSbreak_points->s.s_dbind->v.v_self;
  844.            int i = siSbreak_points->s.s_dbind->v.v_fillp;
  845.            while (--i >= 0)
  846.          { if((*bpts)->c.c_car == form)
  847.              {ifuncall2(siSbreak_points->s.s_gfdef,form,
  848.                 list(3,lex_env[0],lex_env[1],lex_env[2]));
  849.  
  850.               break;}
  851.            bpts++;}
  852.          }}
  853.     
  854.     fun = MMcar(form);
  855.     if (type_of(fun) != t_symbol)
  856.         goto LAMBDA;
  857.     if (fun->s.s_sfdef != NOT_SPECIAL) {
  858.         ihs_check;
  859.         ihs_push(form);
  860.         ihs_top->ihs_base = lex_env;
  861.         (*fun->s.s_sfdef)(MMcdr(form));
  862.         CHECK_AVMA;
  863.         ihs_pop();
  864.         return;
  865.     }
  866.     /*  x = lex_fd_sch(fun);  */
  867.     for (x = lex_env[1];  type_of(x) == t_cons;  x = x->c.c_cdr)
  868.         if (x->c.c_car->c.c_car == fun) {
  869.             x = x->c.c_car;
  870.             if (MMcadr(x) == Smacro) {
  871.                 x = MMcaddr(x);
  872.                 goto EVAL_MACRO;
  873.             }
  874.             x = MMcaddr(x);
  875.             goto EVAL_ARGS;
  876.         }
  877.  
  878. GFDEF:
  879.     if ((x = fun->s.s_gfdef) == OBJNULL)
  880.         FEundefined_function(fun);
  881.  
  882.     if (fun->s.s_mflag) {
  883.     EVAL_MACRO:
  884.         top = vs_top;
  885.         macro_expand1(x, form);
  886.         form = vs_base[0];
  887.         vs_top = top;
  888.         vs_push(form);
  889.         goto EVAL;
  890.     }
  891.  
  892.       
  893.     
  894. EVAL_ARGS:
  895.     vs_push(x);
  896.     ihs_check;
  897.     ihs_push(form);
  898.     ihs_top->ihs_base = lex_env;
  899.     form = form->c.c_cdr;
  900.     base = vs_top;
  901.     top = vs_top;
  902.     while(!endp(form)) {
  903.         eval(MMcar(form));
  904.         top[0] = vs_base[0];
  905.         vs_top = ++top;
  906.         form = MMcdr(form);
  907.     }
  908.     vs_base = base;
  909.     if (Vapplyhook->s.s_dbind != Cnil) {
  910.         call_applyhook(fun);
  911.         return;
  912.     }
  913.     ihs_top->ihs_function = x;
  914.     ihs_top->ihs_base = vs_base;
  915.     if (type_of(x) == t_cfun) 
  916.       (*(x)->cf.cf_self)();
  917.     else
  918.       funcall_no_event(x);
  919.     CHECK_AVMA;
  920.     ihs_pop();
  921.     return;
  922.  
  923. LAMBDA:
  924.     if (type_of(fun) == t_cons && MMcar(fun) == Slambda) {
  925.         temporary = make_cons(lex_env[2], fun->c.c_cdr);
  926.         temporary = make_cons(lex_env[1], temporary);
  927.         temporary = make_cons(lex_env[0], temporary);
  928.         x = make_cons(Slambda_closure, temporary);
  929.         vs_push(x);
  930.         goto EVAL_ARGS;
  931.     }
  932.     FEinvalid_function(fun);
  933. }    
  934.  
  935. call_applyhook(fun)
  936. object fun;
  937. {
  938.     object ah;
  939.     object *v;
  940.  
  941.     ah = symbol_value(Vapplyhook);
  942.     v = vs_base + 1;
  943.     vs_push(Cnil);
  944.     while (vs_top > v)
  945.         stack_cons();
  946.     vs_push(vs_base[0]);
  947.     vs_base[0] = fun;
  948.     vs_push(lex_env[0]);
  949.     vs_push(lex_env[1]);
  950.     vs_push(lex_env[2]);
  951.     vs_push(Cnil);
  952.     stack_cons();
  953.     stack_cons();
  954.     stack_cons();
  955.     super_funcall(ah);
  956. }
  957.  
  958. Lfuncall()
  959. {
  960.     if (vs_top-vs_base < 1)
  961.         too_few_arguments();
  962.     vs_base++;
  963.     super_funcall(vs_base[-1]);
  964. }
  965.  
  966. Lapply()
  967. {
  968.     object lastarg;
  969.     if (vs_top-vs_base < 2)
  970.         too_few_arguments();
  971.     lastarg = vs_pop;
  972.     while (!endp(lastarg)) {
  973.         vs_push(MMcar(lastarg));
  974.         lastarg = MMcdr(lastarg);
  975.     }
  976.     vs_base++;
  977.     super_funcall(vs_base[-1]);
  978. }
  979.  
  980. Leval()
  981. {
  982.     object *lex = lex_env;
  983.  
  984.     check_arg(1);
  985.     lex_new();
  986.     eval(vs_base[0]);
  987.     lex_env = lex;
  988. }
  989.  
  990. Levalhook()
  991. {
  992.     object env;
  993.     bds_ptr old_bds_top = bds_top;
  994.     object *lex = lex_env;
  995.     int n = vs_top - vs_base;
  996.  
  997.     lex_env = vs_top;
  998.     if (n < 3)
  999.         too_few_arguments();
  1000.     else if (n == 3) {
  1001.         *(struct nil3 *)vs_top = three_nils;
  1002.         vs_top += 3;
  1003.     } else if (n == 4) {
  1004.         env = vs_base[3];
  1005.         vs_push(car(env));
  1006.         env = cdr(env);
  1007.         vs_push(car(env));
  1008.         env = cdr(env);
  1009.         vs_push(car(env));
  1010.     } else
  1011.         too_many_arguments();
  1012.     bds_bind(Vevalhook, vs_base[1]);
  1013.     bds_bind(Vapplyhook, vs_base[2]);
  1014.     eval1 = 1;
  1015.     eval(vs_base[0]);
  1016.     lex_env = lex;
  1017.     bds_unwind(old_bds_top);
  1018. }
  1019.  
  1020. Lapplyhook()
  1021. {
  1022.     object env;
  1023.     bds_ptr old_bds_top = bds_top;
  1024.     object *lex = lex_env;
  1025.     int n = vs_top - vs_base;
  1026.     object l, *z;
  1027.  
  1028.     lex_env = vs_top;
  1029.     if (n < 4)
  1030.         too_few_arguments();
  1031.     else if (n == 4) {
  1032.         *(struct nil3 *)vs_top = three_nils;
  1033.         vs_top += 3;
  1034.     } else if (n == 5) {
  1035.         env = vs_base[4];
  1036.         vs_push(car(env));
  1037.         env = cdr(env);
  1038.         vs_push(car(env));
  1039.         env = cdr(env);
  1040.         vs_push(car(env));
  1041.     } else
  1042.         too_many_arguments();
  1043.     bds_bind(Vevalhook, vs_base[2]);
  1044.     bds_bind(Vapplyhook, vs_base[3]);
  1045.     z = vs_top;
  1046.     for (l = vs_base[1];  !endp(l);  l = l->c.c_cdr)
  1047.         vs_push(l->c.c_car);
  1048.     l = vs_base[0];
  1049.     vs_base = z;
  1050.     super_funcall(l);
  1051.     lex_env = lex;
  1052.     bds_unwind(old_bds_top);
  1053. }
  1054.  
  1055. Lconstantp()
  1056. {
  1057.     enum type x;
  1058.     check_arg(1);
  1059.  
  1060.     x = type_of(vs_base[0]);
  1061.     if(x == t_cons)
  1062.         if(vs_base[0]->c.c_car == Squote)
  1063.             vs_base[0] = Ct;
  1064.         else    vs_base[0] = Cnil;
  1065.     else if(x == t_symbol)
  1066.         if((enum stype)vs_base[0]->s.s_stype == stp_constant)
  1067.             vs_base[0] = Ct;
  1068.         else
  1069.             vs_base[0] = Cnil;
  1070.     else
  1071.             vs_base[0] = Ct;
  1072. }
  1073.  
  1074. object
  1075. ieval(x)
  1076. object x;
  1077. {
  1078.     object *old_vs_base;
  1079.     object *old_vs_top;
  1080.  
  1081.     old_vs_base = vs_base;
  1082.     old_vs_top = vs_top;
  1083.     eval(x);
  1084.     x = vs_base[0];
  1085.     vs_base = old_vs_base;
  1086.     vs_top = old_vs_top;
  1087.     return(x);
  1088. }
  1089.  
  1090. object
  1091. ifuncall1(fun, arg1)
  1092. object fun, arg1;
  1093. {
  1094.     object *old_vs_base;
  1095.     object *old_vs_top;
  1096.     object x;
  1097.  
  1098.     old_vs_base = vs_base;
  1099.     old_vs_top = vs_top;
  1100.     vs_base = vs_top;
  1101.     vs_push(arg1);
  1102.     super_funcall(fun);
  1103.     x = vs_base[0];
  1104.     vs_top = old_vs_top;
  1105.     vs_base = old_vs_base;
  1106.     return(x);
  1107. }
  1108.  
  1109. object
  1110. ifuncall2(fun, arg1, arg2)
  1111. object fun, arg1, arg2;
  1112. {
  1113.     object *old_vs_base;
  1114.     object *old_vs_top;
  1115.     object x;
  1116.  
  1117.     old_vs_base = vs_base;
  1118.     old_vs_top = vs_top;
  1119.     vs_base = vs_top;
  1120.     vs_push(arg1);
  1121.     vs_push(arg2);
  1122.     super_funcall(fun);
  1123.     x = vs_base[0];
  1124.     vs_top = old_vs_top;
  1125.     vs_base = old_vs_base;
  1126.     return(x);
  1127. }
  1128.  
  1129. object
  1130. ifuncall3(fun, arg1, arg2, arg3)
  1131. object fun, arg1, arg2, arg3;
  1132. {
  1133.     object *old_vs_base;
  1134.     object *old_vs_top;
  1135.     object x;
  1136.  
  1137.     old_vs_base = vs_base;
  1138.     old_vs_top = vs_top;
  1139.     vs_base = vs_top;
  1140.     vs_push(arg1);
  1141.     vs_push(arg2);
  1142.     vs_push(arg3);
  1143.     super_funcall(fun);
  1144.     x = vs_base[0];
  1145.     vs_top = old_vs_top;
  1146.     vs_base = old_vs_base;
  1147.     return(x);
  1148. }
  1149.  
  1150. funcall_with_catcher(fname, fun)
  1151. object fname, fun;
  1152. {
  1153.     int n = vs_top - vs_base;
  1154.     if (n > 64) n = 64;
  1155.     frs_push(FRS_CATCH, make_cons(fname, make_fixnum(n)));
  1156.     if (nlj_active)
  1157.         nlj_active = FALSE;
  1158.     else
  1159.         funcall(fun);
  1160.     frs_pop();
  1161. }
  1162.  
  1163. #include <varargs.h>
  1164.  
  1165. object 
  1166. fcalln_cclosure(ap)
  1167. va_list ap;
  1168. {int i=fcall.argd;
  1169.  {object *base=vs_top;
  1170.   DEBUG_AVMA
  1171.     vs_base=base;
  1172.     switch(i){
  1173.     case 10: *(base++)=va_arg(ap,object);
  1174.     case 9: *(base++)=va_arg(ap,object);
  1175.     case 8: *(base++)=va_arg(ap,object);
  1176.     case 7: *(base++)=va_arg(ap,object);
  1177.     case 6: *(base++)=va_arg(ap,object);
  1178.     case 5: *(base++)=va_arg(ap,object);
  1179.     case 4: *(base++)=va_arg(ap,object);
  1180.     case 3: *(base++)=va_arg(ap,object);
  1181.     case 2: *(base++)=va_arg(ap,object);
  1182.     case 1: *(base++)=va_arg(ap,object);
  1183.     case 0: break;
  1184.     default:
  1185.       FEerror(0,"bad args");
  1186.     } vs_top=base;
  1187.       base=base -i;
  1188.       do{object fun=fcall.fun;
  1189.         object *top, *base, l;
  1190.  
  1191.         if (fun->cc.cc_turbo != NULL) {
  1192.             (*fun->cc.cc_self)(fun->cc.cc_turbo);
  1193.             break;
  1194.         }
  1195.         top = vs_top;
  1196.         base = vs_base;
  1197.         for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
  1198.             vs_push(l);
  1199.         vs_base = vs_top;
  1200.         while (base < top)
  1201.             vs_push(*base++);
  1202.         (*fcall.fun->cc.cc_self)(top);
  1203.         break;
  1204.     }while (0);
  1205.        vs_top=base;
  1206.        CHECK_AVMA;
  1207.        return(vs_base[0]);
  1208. }}
  1209.  
  1210. object 
  1211. fcalln_general(ap)
  1212. va_list ap;
  1213. {int i=fcall.argd;
  1214.  object fun=fcall.fun;
  1215.  {int n= SFUN_NARGS(i);
  1216.   /*  object *old_vs_base=vs_base; */
  1217.   object *old_vs_top=vs_top;
  1218.   object x;
  1219.   enum ftype typ,restype=SFUN_RETURN_TYPE(i);
  1220.   vs_top =  vs_base = old_vs_top;
  1221.   SFUN_START_ARG_TYPES(i);
  1222.   if (i==0)
  1223.     while (n-- > 0)
  1224.       { typ= SFUN_NEXT_TYPE(i);
  1225.     x =
  1226.       (typ==f_object ?    va_arg(ap,object):
  1227.        typ==f_fixnum ? make_fixnum(va_arg(ap,fixnum)):
  1228.        (object) FEerror("bad type",0));
  1229.     *(vs_top++) = x;}
  1230.   else
  1231.     {object *base=vs_top;
  1232.      while (n-- > 0)
  1233.        { *(base++) = va_arg(ap,object);}
  1234.      vs_top=base;}
  1235.   funcall(fcall.fun);
  1236.   x= vs_base[0];
  1237.   vs_top=old_vs_top;
  1238.   /* vs_base=old_vs_base; */
  1239.   return (restype== f_object ? x :
  1240.       restype== f_fixnum ? (object) (fix(x)):
  1241.       (object) FEerror("bad type",0));
  1242. }}
  1243. object
  1244. fcalln_vfun(vl)
  1245.   va_list vl;
  1246. {object *new,res;
  1247.  DEBUG_AVMA
  1248.  COERCE_VA_LIST(new,vl,fcall.argd);
  1249.  res = c_apply_n(fcall.fun->vfn.vfn_self,fcall.argd,new);
  1250.  CHECK_AVMA;
  1251.  return res; 
  1252. }
  1253.  
  1254. object 
  1255. fcalln(va_alist)
  1256. va_dcl
  1257. {  va_list ap;
  1258.    object fun=fcall.fun;
  1259.    DEBUG_AVMA
  1260.    va_start(ap);
  1261.    if(type_of(fun)==t_cfun)
  1262.      {object *base=vs_top;
  1263.       int i=fcall.argd;
  1264.       vs_base=base;
  1265.       switch(i){
  1266.       case 10: *(base++)=va_arg(ap,object);
  1267.       case 9: *(base++)=va_arg(ap,object);
  1268.       case 8: *(base++)=va_arg(ap,object);
  1269.       case 7: *(base++)=va_arg(ap,object);
  1270.       case 6: *(base++)=va_arg(ap,object);
  1271.       case 5: *(base++)=va_arg(ap,object);
  1272.       case 4: *(base++)=va_arg(ap,object);
  1273.       case 3: *(base++)=va_arg(ap,object);
  1274.       case 2: *(base++)=va_arg(ap,object);
  1275.       case 1: *(base++)=va_arg(ap,object);
  1276.       case 0: break;
  1277.       default:
  1278.     FEerror(0,"bad args");
  1279.       }  vs_top=base;
  1280.       base=base -i;
  1281.       (*fcall.fun->cf.cf_self)();
  1282.       vs_top=base;
  1283.       CHECK_AVMA;
  1284.       return(vs_base[0]);
  1285.     }
  1286.    if(type_of(fun)==t_cclosure)
  1287.      return(fcalln_cclosure(ap));
  1288.    if(type_of(fun)==t_vfun)
  1289.      return(fcalln_vfun(ap));
  1290.    return(fcalln_general(ap));
  1291.   va_end(ap);
  1292.  }
  1293.  
  1294. /* call a cfun eg funcall_cfun(Lmake_hash_table,2,Ktest,Seq) */
  1295. typedef void (*funcvoid)();
  1296.  
  1297. object
  1298. funcall_cfun(fn,n,va_alist)
  1299.      int n;
  1300.      funcvoid fn;
  1301.      va_dcl
  1302. {object *old_top = vs_top;
  1303.  object *old_base= vs_base;
  1304.  object result;
  1305.  va_list ap;
  1306.  DEBUG_AVMA
  1307.  vs_base=vs_top;
  1308.  va_start(ap);
  1309.  while(n-->0) vs_push(va_arg(ap,object));
  1310.  va_end(ap);
  1311.  (*fn)();
  1312.  if(vs_top>vs_base) result=vs_base[0];
  1313.  else result=Cnil;
  1314.  vs_top=old_top;
  1315.  vs_base=old_base;
  1316.  CHECK_AVMA;
  1317.  return result;}
  1318.  
  1319.  
  1320. init_eval()
  1321. {
  1322.  
  1323.         make_constant("CALL-ARGUMENTS-LIMIT", make_fixnum(64));
  1324.  
  1325.     Sapply = make_function("APPLY", Lapply);
  1326.     enter_mark_origin(&Sapply);
  1327.     Sfuncall = make_function("FUNCALL", Lfuncall);
  1328.     enter_mark_origin(&Sfuncall);
  1329.  
  1330.     Vevalhook = make_special("*EVALHOOK*", Cnil);
  1331.     Vapplyhook = make_special("*APPLYHOOK*", Cnil);
  1332.  
  1333.     temporary = Cnil;
  1334.     enter_mark_origin(&temporary);
  1335.  
  1336.     three_nils.nil3_self[0] = Cnil;
  1337.     three_nils.nil3_self[1] = Cnil;
  1338.     three_nils.nil3_self[2] = Cnil;
  1339.  
  1340.     make_function("EVAL", Leval);
  1341.     make_function("EVALHOOK", Levalhook);
  1342.     make_function("APPLYHOOK", Lapplyhook);
  1343.     siSlambda_block_expanded=make_si_special("LAMBDA-BLOCK-EXPANDED",Cnil);
  1344.     make_function("CONSTANTP", Lconstantp);
  1345.     siSbreak_points = make_si_special("*BREAK-POINTS*",Cnil);
  1346.     siSbreak_step = make_si_special("*BREAK-STEP*",Cnil);
  1347.  
  1348.     
  1349. }
  1350.