home *** CD-ROM | disk | FTP | other *** search
/ CICA 1995 May / cica_0595_4.zip / cica_0595_4 / UTIL / MSWSRC35 / EVAL.CPP < prev    next >
C/C++ Source or Header  |  1993-08-19  |  27KB  |  928 lines
  1. /*
  2.  *      eval.c          logo eval/apply module                  dko
  3.  *
  4.  *    Copyright (C) 1992 The Regents of the University of California
  5.  *    This Software may be copied and distributed for educational,
  6.  *    research, and not for profit purposes provided that this
  7.  *    copyright and statement are included in all such copies.
  8.  *
  9.  */
  10.  
  11. #include "logo.h"
  12. #include "globals.h"
  13. #ifdef unix
  14. #include <sgtty.h>
  15. #endif
  16.  
  17. #ifndef TIOCSTI
  18. #include <setjmp.h>
  19. extern jmp_buf iblk_buf;
  20. #endif
  21.  
  22. #define assign(to, from)    (to = reref(to, from))
  23. #define init(to, from)        (to = valref(from))
  24.  
  25. #define save(register)        push(register, stack)
  26. #define restore(register)   (assign(register, car(stack)), pop(stack))
  27.  
  28. #define save2(reg1,reg2)    (push(reg1,stack),setobject(stack,reg2))
  29. #define restore2(reg1,reg2) (assign(reg2,getobject(stack)), \
  30.                  assign(reg1,car(stack)), pop(stack))
  31.  
  32. /* saving and restoring FIXNUMs rather than NODEs */
  33.  
  34. #define numsave(register)   numpush(register, &stack)
  35. #define numrestore(register) (register=(FIXNUM)car(stack), numpop(&stack))
  36.  
  37. #define num2save(reg1,reg2) (numpush(reg1,&stack),stack->n_obj=(NODE *)reg2)
  38. #define num2restore(reg1,reg2) (reg2=(FIXNUM)getobject(stack), \
  39.                 reg1=(FIXNUM)car(stack), numpop(&stack))
  40.  
  41. /* save and restore a FIXNUM (reg1) and a NODE (reg2) */
  42.  
  43. #define mixsave(reg1,reg2)  (numpush(reg1,&stack),setobject(stack,reg2))
  44. #define mixrestore(reg1,reg2) deref(reg2); reg2=getobject(stack); \
  45.                    reg1=(FIXNUM)car(stack); numpop(&stack)
  46.  
  47. #define newcont(tag)        (numsave(cont), cont = (FIXNUM)tag)
  48.  
  49. #define nameis(x,y)        ((object__caseobj(x)) == (object__caseobj(y)))
  50.  
  51. typedef NODE *(*nodeinout)(NODE *arg);
  52.  
  53. /* These variables are all externed in globals.h */
  54.  
  55. NODE
  56. *fun        = NIL,  /* current function name */
  57. *ufun        = NIL,    /* current user-defined function name */
  58. *last_ufun    = NIL,    /* the function that called this one */
  59. *this_line    = NIL,    /* the current instruction line */
  60. *last_line    = NIL,    /* the line that called this one */
  61. *var_stack    = NIL,    /* the stack of variables and their bindings */
  62. *var        = NIL,    /* frame pointer into var_stack */
  63. *last_call    = NIL,    /* the last proc called */
  64. *didnt_output_name = NIL,   /* the name of the proc that didn't OP */
  65. *didnt_get_output  = NIL,   /* the name of the proc that wanted the OP */
  66. *output_node    = NIL;    /* the output of the current function */
  67.  
  68.  
  69. FIXNUM global_repcount[128];        /* count for repeat */
  70. FIXNUM global_repcount_index = 0;        /* count for repeat */
  71. CTRLTYPE    stopping_flag = RUN;
  72. char        *logolib;
  73. FIXNUM        tailcall; /* 0 in sequence, 1 for tail, -1 for arg */
  74. FIXNUM        val_status;        /* 0 means no value allowed (body of cmd),
  75.                    1 means value required (arg),
  76.                    2 means OUTPUT ok (body of oper),
  77.                    3 means val or no val ok (fn inside catch),
  78.                    4 means no value in macro (repeat),
  79.                    5 means value maybe ok in macro (catch)
  80.                  */
  81.  
  82. FIXNUM      dont_fix_ift = 0;
  83.  
  84. /* These variables are local to this file. */
  85. static NODE *qm_list = NIL;    /* question mark list */
  86. static int trace_level = 0;    /* indentation level when tracing */
  87.  
  88. /* These first few functions are externed in globals.h */
  89.  
  90. void spop(NODE **stack) {
  91.     NODE *temp = (*stack)->n_cdr;
  92.  
  93.     if (decrefcnt(*stack) == 0) {
  94.     (*stack)->n_cdr = NIL;
  95.     gc(*stack);
  96.     } else {
  97.     if (temp != NIL) increfcnt(temp);
  98.     }
  99.     *stack = temp;
  100. }
  101.  
  102. void spush(NODE *obj, NODE **stack) {
  103.     NODE *temp = newnode(CONS);
  104.  
  105.     setcar(temp, obj);
  106.     temp->n_cdr = *stack;
  107.     ref(temp);
  108.     *stack = temp;
  109. }
  110.  
  111. void numpop(NODE **stack) {
  112.     NODE *temp = (*stack)->n_cdr;
  113.  
  114.     (*stack)->n_car = NIL;
  115.     (*stack)->n_cdr = NIL;
  116.     (*stack)->n_obj = NIL;
  117.     deref(*stack);
  118.     *stack = temp;
  119. }
  120.  
  121. void numpush(FIXNUM obj, NODE **stack) {
  122.     NODE *temp = newnode(CONS);
  123.  
  124.     temp->n_car = (NODE *)obj;
  125.     temp->n_cdr = *stack;
  126.     ref(temp);
  127.     *stack = temp;
  128. }
  129.  
  130. /* forward declaration */
  131. NODE *evaluator(NODE *list, enum labels where);
  132.  
  133. /* Evaluate a line of input. */
  134. void eval_driver(NODE *line) {
  135.     evaluator(line, begin_line);
  136. }
  137.  
  138. /* Evaluate a sequence of expressions until we get a value to return.
  139.  * (Called from erract.)
  140.  */ 
  141. NODE *err_eval_driver(NODE *seq) {
  142.     val_status = 5;
  143.     return evaluator(seq, begin_seq);
  144. }
  145.  
  146. /* The logo word APPLY. */
  147. NODE *lapply(NODE *args) {
  148.     return make_cont(begin_apply, args);
  149. }
  150.  
  151. /* The logo word ? <question-mark>. */
  152. NODE *lqm(NODE *args) {
  153.     FIXNUM argnum = 1, i;
  154.     NODE *np = qm_list;
  155.  
  156.     if (args != NIL) argnum = getint(pos_int_arg(args));
  157.     if (stopping_flag == THROWING) return(UNBOUND);
  158.     i = argnum;
  159.     while (--i > 0 && np != NIL) np = cdr(np);
  160.     if (np == NIL)
  161.     return(err_logo(BAD_DATA_UNREC,make_intnode(argnum)));
  162.     return(car(np));
  163. }
  164.  
  165. /* The rest of the functions are local to this file. */
  166.  
  167. /* Warn the user if a local variable shadows a global one. */
  168. void tell_shadow(NODE *arg) {
  169.     if (flag__caseobj(arg, VAL_STEPPED))
  170.     err_logo(SHADOW_WARN, arg);
  171. }
  172.  
  173. /* Check if a local variable is already in this frame */
  174. int not_local(NODE *name, NODE *sp) {
  175.     for ( ; sp != var; sp = cdr(sp)) {
  176.     if (compare_node(car(sp),name,TRUE) == 0) {
  177.         return FALSE;
  178.     }
  179.     }
  180.     return TRUE;
  181. }
  182.  
  183. /* reverse a list destructively */
  184. NODE *reverse(NODE *list) {
  185.     NODE *ret = NIL, *temp;
  186.  
  187.     ref(list);
  188.     while (list != NIL) {
  189.     temp = list;
  190.     list = cdr(list);
  191.     temp->n_cdr = ret;
  192.     ret = temp;
  193.     }
  194.     return unref(ret);
  195. }
  196.  
  197. /* nondestructive append */
  198. NODE *append(NODE *a, NODE *b) {
  199. //    NODE *result;
  200.  
  201.     if (a == NIL) return b;
  202.     return cons(car(a), append(cdr(a), b));
  203. }
  204.  
  205. /* Reset the var stack to the previous place holder.
  206.  */
  207. void reset_args(NODE *old_stack) {
  208.     for (; var_stack != old_stack; pop(var_stack))
  209.     setvalnode__caseobj(car(var_stack), getobject(var_stack));
  210. }
  211.  
  212. /* An explicit control evaluator, taken almost directly from SICP, section
  213.  * 5.2.  list is a flat list of expressions to evaluate.  where is a label to
  214.  * begin at.  Return value depends on where.
  215.  */ 
  216. NODE *evaluator(NODE *list, enum labels where) {
  217.  
  218.     /* registers */
  219.     NODE    *exp    = NIL,  /* the current expression */
  220.         *val    = NIL,  /* the value of the last expression */
  221.         *proc   = NIL,  /* the procedure definition */
  222.         *argl   = NIL,  /* evaluated argument list */
  223.         *unev   = NIL,  /* list of unevaluated expressions */
  224.         *stack  = NIL,  /* register stack */
  225.         *parm   = NIL,  /* the current formal */
  226.         *catch_tag = NIL,
  227.         *arg    = NIL;  /* the current actual */
  228.  
  229. //    NODE    *tmpval = NIL;  /* */
  230.  
  231. /* registers that don't get reference counted, so we pretend they're ints */
  232. FIXNUM        vsp    = 0,        /* temp ptr into var_stack */
  233.         cont   = 0,        /* where to go next */
  234.         formals = (FIXNUM)NIL; /* list of formal parameters */
  235.  
  236.     int i;
  237. //    int nargs;
  238.     BOOLEAN tracing;        /* are we tracing the current procedure? */
  239.     FIXNUM oldtailcall;        /* in case of reentrant use of evaluator */
  240.     FIXNUM repcount;        /* count for repeat */
  241.     FIXNUM old_ift_iff;
  242.     
  243.     oldtailcall = tailcall;
  244.     old_ift_iff = ift_iff_flag;
  245.     save2(var,this_line);
  246.     assign(var, var_stack);
  247.     save2(fun,ufun);
  248.     cont = (FIXNUM)all_done;
  249.     numsave((FIXNUM)cont);
  250.     newcont(where);
  251.     goto fetch_cont;
  252.     
  253. begin_line:
  254.     ref(list);
  255.     assign(this_line, list);
  256.     newcont(end_line);
  257. begin_seq:
  258.     make_tree(list);
  259.     if (!is_tree(list)) {
  260.     assign(val, UNBOUND);
  261.     goto fetch_cont;
  262.     }
  263.     assign(unev, tree__tree(list));
  264.     assign(val, UNBOUND);
  265.     goto eval_sequence;
  266.  
  267. end_line:
  268.     if (val != UNBOUND) {
  269.     if (NOT_THROWING) err_logo(DK_WHAT, val);
  270.     deref(val);
  271.     }
  272.     val = NIL;
  273.     deref(list);
  274.     goto fetch_cont;
  275.  
  276.  
  277. /* ----------------- EVAL ---------------------------------- */
  278.  
  279. tail_eval_dispatch:
  280.     tailcall = 1;
  281. eval_dispatch:
  282.     switch (nodetype(exp)) {
  283.     case QUOTE:            /* quoted literal */
  284.         assign(val, node__quote(exp));
  285.         goto fetch_cont;
  286.     case COLON:            /* variable */
  287.         assign(val, valnode__colon(exp));
  288.         while (val == UNBOUND && NOT_THROWING)
  289.         assign(val, err_logo(NO_VALUE, node__colon(exp)));
  290.         goto fetch_cont;
  291.     case CONS:            /* procedure application */
  292.         if (tailcall == 1 && is_macro(car(exp)) &&
  293.                  is_list(procnode__caseobj(car(exp)))) {
  294.         /* tail call to user-defined macro must be treated as non-tail
  295.          * because the expression returned by the macro
  296.          * remains to be evaluated in the caller's context */
  297.         assign(unev, NIL);
  298.         goto non_tail_eval;
  299.         }
  300.         assign(fun, car(exp));
  301.         if (cdr(exp) != NIL)
  302.         goto ev_application;
  303.         else
  304.         goto ev_no_args;
  305.     default:
  306.         assign(val, exp);        /* self-evaluating */
  307.         goto fetch_cont;
  308.     }
  309.  
  310. ev_no_args:
  311.     /* Evaluate an application of a procedure with no arguments. */
  312.     assign(argl, NIL);
  313.     goto apply_dispatch;    /* apply the procedure */
  314.  
  315. ev_application:
  316.     /* Evaluate an application of a procedure with arguments. */
  317.     assign(unev, cdr(exp));
  318.     assign(argl, NIL);
  319.     mixsave(tailcall,var);
  320.     num2save(val_status,ift_iff_flag);
  321.     save2(didnt_get_output,didnt_output_name);
  322. eval_arg_loop:
  323.     if (unev == NIL) goto eval_args_done;
  324.     assign(exp, car(unev));
  325.     if (exp == Not_Enough_Node) {
  326.     if (NOT_THROWING)
  327.         err_logo(NOT_ENOUGH, NIL);
  328.     goto eval_args_done;
  329.     }
  330.     save(argl);
  331.     save2(unev,fun);
  332.     save2(ufun,last_ufun);
  333.     save2(this_line,last_line);
  334.     assign(var, var_stack);
  335.     tailcall = -1;
  336.     val_status = 1;
  337.     assign(didnt_get_output,
  338.        cons_list(0,fun,ufun,this_line,END_OF_LIST));
  339.     assign(didnt_output_name, NIL);
  340.     newcont(accumulate_arg);
  341.     goto eval_dispatch;        /* evaluate the current argument */
  342.  
  343. accumulate_arg:
  344.     /* Put the evaluated argument into the argl list. */
  345.     reset_args(var);
  346.     restore2(this_line,last_line);
  347.     restore2(ufun,last_ufun);
  348.     assign(last_call, fun);
  349.     restore2(unev,fun);
  350.     restore(argl);
  351.     while (NOT_THROWING && val == UNBOUND) {
  352.     assign(val, err_logo(DIDNT_OUTPUT, NIL));
  353.     }
  354.     push(val, argl);
  355.     pop(unev);
  356.     goto eval_arg_loop;
  357.  
  358. eval_args_done:
  359.     restore2(didnt_get_output,didnt_output_name);
  360.  
  361.     num2restore(val_status,ift_iff_flag);
  362.     mixrestore(tailcall,var);
  363.     if (stopping_flag == THROWING) {
  364.     assign(val, UNBOUND);
  365.     goto fetch_cont;
  366.     }
  367.     assign(argl, reverse(argl));
  368. /* --------------------- APPLY ---------------------------- */
  369. apply_dispatch:
  370.     eval_count++;
  371.     if (status_flag) update_status_evals();
  372.  
  373.     /* Load in the procedure's definition and decide whether it's a compound
  374.      * procedure or a primitive procedure.
  375.      */
  376.     proc = procnode__caseobj(fun);
  377.     if (is_macro(fun)) {
  378.     num2save(val_status,tailcall);
  379.     val_status = 1;
  380.     newcont(macro_return);
  381.     }
  382.     if (proc == UNDEFINED) {
  383.     if (ufun != NIL) {
  384.         untreeify_proc(ufun);
  385.     }
  386.     if (NOT_THROWING)
  387.         assign(val, err_logo(DK_HOW, fun));
  388.     else
  389.         assign(val, UNBOUND);
  390.     goto fetch_cont;
  391.     }
  392.     if (is_list(proc)) goto compound_apply;
  393.     /* primitive_apply */
  394.     if (NOT_THROWING)
  395.         assign(val, ((nodeinout)*getprimfun(proc))(argl));
  396.     else
  397.     assign(val, UNBOUND);
  398. #define do_case(x) case x: goto x;
  399. fetch_cont:
  400.     {
  401.     enum labels x = (enum labels)cont;
  402.     cont = (FIXNUM)car(stack);
  403.     numpop(&stack);
  404.     switch (x) {
  405.         do_list(do_case)
  406.         default: abort();
  407.     }
  408.     }
  409.  
  410. compound_apply:
  411. #ifdef mac
  412.     check_mac_stop();
  413. #endif
  414. #ifdef ibm
  415.     check_ibm_stop();
  416. #endif
  417.     if (tracing = flag__caseobj(fun, PROC_TRACED) || traceflag) {
  418.     for (i = 0; i < trace_level; i++) print_space(writestream);
  419.     trace_level++;
  420.     ndprintf(writestream, "( %s ", fun);
  421.     }
  422. /* Bind the actuals to the formals */
  423.     vsp = (FIXNUM)var_stack;    /* remember where we came in */
  424.     for (formals = (FIXNUM)formals__procnode(proc);
  425.          formals != (FIXNUM)NIL;
  426.      formals = (FIXNUM)cdr((NODE *)formals)) {
  427.         parm = car((NODE *)formals);
  428.         if (nodetype(parm) == INT) break;    /* default # args */
  429.         if (argl != NIL) {
  430.         arg = car(argl);
  431.         if (tracing || traceflag) {
  432.             print_node(writestream, maybe_quote(arg));
  433.             print_space(writestream);
  434.         }
  435.         } else
  436.         arg = UNBOUND;
  437.         if (nodetype(parm) == CASEOBJ) {
  438.         if (not_local(parm,(NODE *)vsp)) {
  439.             push(parm, var_stack);
  440.             setobject(var_stack, valnode__caseobj(parm));
  441.         }
  442.         tell_shadow(parm);
  443.         setvalnode__caseobj(parm, arg);
  444.         } else if (nodetype(parm) == CONS) {
  445.         /* parm is optional or rest */
  446.         if (not_local(car(parm),(NODE *)vsp)) {
  447.             push(car(parm), var_stack);
  448.             setobject(var_stack, valnode__caseobj(car(parm)));
  449.         }
  450.         tell_shadow(car(parm));
  451.         if (cdr(parm) == NIL) {            /* parm is rest */
  452.             setvalnode__caseobj(car(parm), argl);
  453.             break;
  454.         }
  455.         if (arg == UNBOUND) {            /* use default */
  456.             save2(fun,var);
  457.             save2(ufun,last_ufun);
  458.             save2(this_line,last_line);
  459.             save2(didnt_output_name,didnt_get_output);
  460.           
  461.             num2save(ift_iff_flag,val_status);
  462.             assign(var, var_stack);
  463.             tailcall = -1;
  464.             val_status = 1;
  465.             mixsave(formals,argl);
  466.             numsave(vsp);
  467.  
  468.                     assign(list, cdr(parm));
  469.                     if (NOT_THROWING)
  470.                         make_tree(list);
  471.                     else
  472.                         assign(list, NIL);
  473.                     if (!is_tree(list)) {
  474.             assign(val, UNBOUND);
  475.             goto set_args_continue;
  476.             }
  477.             assign(unev, tree__tree(list));
  478.             assign(val, UNBOUND);
  479.             newcont(set_args_continue);
  480.             goto eval_sequence;
  481.  
  482. set_args_continue:
  483.             numrestore(vsp);
  484.             mixrestore(formals,argl);
  485.             parm = car((NODE *)formals);
  486.             reset_args(var);
  487.             num2restore(ift_iff_flag,val_status);
  488.             restore2(didnt_output_name,didnt_get_output);
  489.             restore2(this_line,last_line);
  490.             restore2(ufun,last_ufun);
  491.             restore2(fun,var);
  492.             arg = val;
  493.         }
  494.         setvalnode__caseobj(car(parm), arg);
  495.         }
  496.         if (argl != NIL) pop(argl);
  497.     }
  498.     if (check_throwing) {
  499.         assign(val, UNBOUND);
  500.         goto fetch_cont;
  501.     }
  502.     vsp = 0;
  503.     if (tracing = flag__caseobj(fun, PROC_TRACED) || traceflag) {
  504.     if (NOT_THROWING) print_char(writestream, ')');
  505.     new_line(writestream);
  506.         save(fun);
  507.         newcont(compound_apply_continue);
  508.     }
  509.     assign(val, UNBOUND);
  510.     assign(last_ufun, ufun);
  511.     assign(ufun, fun);
  512.     assign(last_line, this_line);
  513.     assign(this_line, NIL);
  514.     proc = procnode__caseobj(fun);
  515.     assign(list, bodylist__procnode(proc));    /* get the body ... */
  516.     make_tree_from_body(list);
  517.     if (!is_tree(list)) {
  518.     goto fetch_cont;
  519.     }
  520.     assign(unev, tree__tree(list));
  521.     if (NOT_THROWING) stopping_flag = RUN;
  522.     assign(output_node, UNBOUND);
  523.     if (val_status == 1) val_status = 2;
  524.     else if (val_status == 5) val_status = 3;
  525.     else val_status = 0;
  526. eval_sequence:
  527.     /* Evaluate each expression in the sequence.  Stop as soon as
  528.      * val != UNBOUND.
  529.      */
  530.     if (!RUNNING || val != UNBOUND) {
  531.     goto fetch_cont;
  532.     }
  533.     if (nodetype(unev) == LINE) {
  534.     assign(this_line, unparsed__line(unev));
  535.     if (flag__caseobj(ufun, PROC_STEPPED)) {
  536. //        char junk[20];
  537.  
  538.         if (tracing || traceflag) {
  539.         int i = 1;
  540.         while (i++ < trace_level) print_space(stdout);
  541.         }
  542. //        print_node(stdout, this_line);
  543. //        ndprintf(stdout, " >>> ");
  544.         input_blocking++;
  545. #ifndef TIOCSTI
  546.         if (!setjmp(iblk_buf))
  547. #endif
  548. #ifdef __ZTC__
  549.         ztc_getcr();
  550. #else
  551. //        fgets(junk, 19, stdin);
  552.                 single_step_box(this_line);
  553. #endif
  554.         input_blocking = 0;
  555. //        update_coords('\n');
  556.     }
  557.     }
  558.     assign(exp, car(unev));
  559.     pop(unev);
  560.     if (is_list(exp) && (is_tailform(procnode__caseobj(car(exp))))) {
  561.       if (nameis(car(exp),Output) || nameis(car(exp),Op)) {
  562.     assign(didnt_get_output,
  563.            cons_list(0,car(exp),ufun,this_line,END_OF_LIST));
  564.     assign(didnt_output_name, NIL);
  565.     if (val_status == 2 || val_status == 3) {
  566.         val_status = 1;
  567.             assign(exp, cadr(exp));
  568.         goto tail_eval_dispatch;
  569.     } else if (ufun == NIL) {
  570.         err_logo(AT_TOPLEVEL,car(exp));
  571.         assign(val, UNBOUND);
  572.         goto fetch_cont;
  573.     } else if (val_status < 4) {
  574.         val_status = 1;
  575.             assign(exp, cadr(exp));
  576.         assign(unev, NIL);
  577.         goto non_tail_eval;        /* compute value then give error */
  578.     }
  579.       } else if (nameis(car(exp),Stop)) {
  580.     if (ufun == NIL) {
  581.         err_logo(AT_TOPLEVEL,car(exp));
  582.         assign(val, UNBOUND);
  583.         goto fetch_cont;
  584.     } else if (val_status == 0 || val_status == 3) {
  585.         assign(val, UNBOUND);
  586.         goto fetch_cont;
  587.     } else if (val_status < 4) {
  588.         assign(didnt_output_name, fun);
  589.         assign(val, UNBOUND);
  590.         goto fetch_cont;
  591.     }
  592.       } else { /* maybeoutput */
  593.         assign(exp, cadr(exp));
  594.     val_status = 5;
  595.     goto tail_eval_dispatch;
  596.       }
  597.     }
  598.     if (unev == NIL) {
  599. //    if (val_status == 2) {
  600.     if (val_status == 2 || val_status == 4) { // this fixes 
  601.                                                   // to line :n
  602.                                                   // if :n > 0
  603.                                                   // repeat 2 [line :n-1]
  604.                                                   // end
  605.         assign(didnt_output_name, fun);
  606.         assign(unev, UNBOUND);
  607.         goto non_tail_eval;
  608.     } else {
  609.         goto tail_eval_dispatch;
  610.     }
  611.     }
  612.     if (is_list(car(unev))) {
  613.         if (car(car(unev)) != NIL) { /* check valid ptr before using it */
  614.         if (nameis(car(car(unev)),Stop)) {
  615.             if ((val_status == 0 || val_status == 3) && ufun != NIL) {
  616.                 goto tail_eval_dispatch;
  617.             } else if (val_status < 4) {
  618.                 assign(didnt_output_name, fun);
  619.                 goto tail_eval_dispatch;
  620.             }
  621.             }
  622.         }
  623.     }
  624. non_tail_eval:
  625.     save2(unev,fun);
  626.     num2save(ift_iff_flag,val_status);
  627.     save2(ufun,last_ufun);
  628.     save2(this_line,last_line);
  629.     save(var);
  630.     assign(var, var_stack);
  631.     tailcall = 0;
  632.     newcont(eval_sequence_continue);
  633.     goto eval_dispatch;
  634.  
  635. eval_sequence_continue:
  636.     reset_args(var);
  637.     restore(var);
  638.     restore2(this_line,last_line);
  639.     restore2(ufun,last_ufun);
  640.     if (dont_fix_ift) {
  641.         num2restore(dont_fix_ift,val_status);
  642.         dont_fix_ift = 0;
  643.     } else
  644.         num2restore(ift_iff_flag,val_status);
  645.     restore2(unev,fun);
  646.     if (stopping_flag == MACRO_RETURN) {
  647.     if (unev == UNBOUND) assign(unev, NIL);
  648.     assign(unev, append(val, unev));
  649.     assign(val, UNBOUND);
  650.     stopping_flag = RUN;
  651.     if (unev == NIL) goto fetch_cont;
  652.     } else if (val_status < 4) {
  653.     if (STOPPING || RUNNING) assign(output_node, UNBOUND);
  654.     if (stopping_flag == OUTPUT || STOPPING) {
  655.         stopping_flag = RUN;
  656.         assign(val, output_node);
  657.         if (val != UNBOUND && val_status < 2 && NOT_THROWING) {
  658.         assign(didnt_output_name,Output);
  659.         err_logo(DIDNT_OUTPUT,Output);
  660.         }
  661.         if (val == UNBOUND && val_status == 1 && NOT_THROWING) {
  662.         assign(didnt_output_name,Stop);
  663.         err_logo(DIDNT_OUTPUT,Output);
  664.         }
  665.         goto fetch_cont;
  666.     }
  667.     }
  668.     if (val != UNBOUND) {
  669.     err_logo((unev == NIL ? DK_WHAT_UP : DK_WHAT), val);
  670.     assign(val, UNBOUND);
  671.     }
  672.     if (NOT_THROWING && (unev == NIL || unev == UNBOUND)) {
  673. //    err_logo(DIDNT_OUTPUT,NIL);
  674.     if (val_status != 4) err_logo(DIDNT_OUTPUT,NIL);
  675.     goto fetch_cont;
  676.     }
  677.     goto eval_sequence;
  678.  
  679. compound_apply_continue:
  680.     /* Only get here if tracing */
  681.     restore(fun);
  682.     --trace_level;
  683.     if (NOT_THROWING) {
  684.     for (i = 0; i < trace_level; i++) print_space(writestream);
  685.     print_node(writestream, fun);
  686.     if (val == UNBOUND)
  687.         ndprintf(writestream, " stops\n");
  688.     else {
  689.         ref(val);
  690.         ndprintf(writestream, " outputs %s\n", maybe_quote(val));
  691.         deref(val);
  692.     }
  693.     }
  694.     goto fetch_cont;
  695.  
  696. /* --------------------- MACROS ---------------------------- */
  697.  
  698. macro_return:
  699.     num2restore(val_status,tailcall);
  700.     while (!is_list(val) && NOT_THROWING) {
  701.     assign(val,err_logo(ERR_MACRO,val));
  702.     }
  703.     if (NOT_THROWING) {
  704.     if (is_cont(val)) {
  705.         newcont(cont__cont(val));
  706.         val->n_car = NIL;
  707.         assign(val, val__cont(val));
  708.         goto fetch_cont;
  709.     }
  710. macro_reval:
  711.     if (tailcall == 0) {
  712.         make_tree(val);
  713.         stopping_flag = MACRO_RETURN;
  714.           if (!is_tree(val)) assign(val, NIL);
  715.             else assign(val, tree__tree(val));
  716.             goto fetch_cont;
  717.     }
  718.     assign(list,val);
  719.     goto begin_seq;
  720.     }
  721.     assign(val, UNBOUND);
  722.     goto fetch_cont;
  723.  
  724. runresult_continuation:
  725.     assign(list, val);
  726.     newcont(runresult_followup);
  727.     val_status = 5;
  728.     goto begin_seq;
  729.  
  730. runresult_followup:
  731.     if (val == UNBOUND) {
  732.     assign(val, NIL);
  733.     } else {
  734.     assign(val, cons(val, NIL));
  735.     }
  736.     goto fetch_cont;
  737.  
  738. repeat_continuation:
  739.     assign(list, cdr(val));
  740.     repcount = getint(car(val));
  741. repeat_again:
  742.     assign(val, UNBOUND);
  743.     if (repcount == 0) goto fetch_cont;
  744.     mixsave(repcount,list);
  745.     num2save(val_status,tailcall);
  746.     val_status = 4;
  747.     newcont(repeat_followup);
  748.     goto begin_seq;
  749.  
  750. repeat_followup:
  751.     if (val != UNBOUND && NOT_THROWING) {
  752.     ref(val);
  753.     err_logo(DK_WHAT, val);
  754.     unref(val);
  755.     }
  756.     num2restore(val_status,tailcall);
  757.     mixrestore(repcount,list);
  758.     if (val_status < 4 && tailcall != 0) {
  759.     if (STOPPING || RUNNING) assign(output_node, UNBOUND);
  760.     if (stopping_flag == OUTPUT || STOPPING) {
  761.         stopping_flag = RUN;
  762.         assign(val, output_node);
  763.         if (val != UNBOUND && val_status < 2) {
  764.         err_logo(DK_WHAT_UP,val);
  765.         }
  766.         goto fetch_cont;
  767.     }
  768.     }
  769.     if (repcount > 0)    /* negative means forever */
  770.         {
  771.     --repcount;
  772.         global_repcount[global_repcount_index]++;
  773.         if (repcount==0) global_repcount_index--;
  774.         }
  775. #ifdef mac
  776.     check_mac_stop();
  777. #endif
  778. #ifdef ibm
  779.     check_ibm_stop();
  780. #endif
  781.     if (RUNNING) goto repeat_again;
  782.     assign(val, UNBOUND);
  783.     goto fetch_cont;
  784.  
  785. catch_continuation:
  786.     assign(list, cdr(val));
  787.     assign(catch_tag, car(val));
  788.     if (compare_node(catch_tag,Error,TRUE) == 0) {
  789.     push(Erract, var_stack);
  790.     setobject(var_stack, valnode__caseobj(Erract));
  791.     setvalnode__caseobj(Erract, UNBOUND);
  792.     }
  793.     save(catch_tag);
  794.     save2(didnt_output_name,didnt_get_output);
  795.     num2save(val_status,tailcall);
  796.     newcont(catch_followup);
  797.     val_status = 5;
  798.     goto begin_seq;
  799.  
  800. catch_followup:
  801.     num2restore(val_status,tailcall);
  802.     restore2(didnt_output_name,didnt_get_output);
  803.     restore(catch_tag);
  804.     if (val_status < 4 && tailcall != 0) {
  805.     if (STOPPING || RUNNING) assign(output_node, UNBOUND);
  806.     if (stopping_flag == OUTPUT || STOPPING) {
  807.         stopping_flag = RUN;
  808.         assign(val, output_node);
  809.         if (val != UNBOUND && val_status < 2) {
  810.         err_logo(DK_WHAT_UP,val);
  811.         }
  812.     }
  813.     }
  814.     if (stopping_flag == THROWING &&
  815.     compare_node(throw_node, catch_tag, TRUE) == 0) {
  816.         throw_node = reref(throw_node, UNBOUND);
  817.         stopping_flag = RUN;
  818.         assign(val, output_node);
  819.     }
  820.     goto fetch_cont;
  821.  
  822. begin_apply:
  823.     /* This is for lapply. */
  824.     assign(fun, car(val));
  825.     while (nodetype(fun) == ARRAY && NOT_THROWING)
  826.     assign(fun, err_logo(APPLY_BAD_DATA, fun));
  827.     assign(argl, cadr(val));
  828.     assign(val, UNBOUND);
  829.     while (!is_list(argl) && NOT_THROWING)
  830.     assign(argl, err_logo(APPLY_BAD_DATA, argl));
  831.     if (NOT_THROWING && fun != NIL) {
  832.     if (is_list(fun)) {            /* template */
  833.         if (is_list(car(fun)) && cdr(fun) != NIL) {
  834.         /* lambda form */
  835.         formals = (FIXNUM)car(fun);
  836.         numsave(tailcall);
  837.         tailcall = 0;
  838.         llocal((NODE *)formals);    /* bind the formals locally */
  839.         numrestore(tailcall);
  840.         for ( ;
  841.              formals && argl && NOT_THROWING;
  842.              formals = (FIXNUM)cdr((NODE *)formals),
  843.              assign(argl, cdr(argl)))
  844.             setvalnode__caseobj(car((NODE *)formals), car(argl));
  845.         assign(val, cdr(fun));
  846.         goto macro_reval;
  847.         } else {        /* question-mark form */
  848.         save(qm_list);
  849.         assign(qm_list, argl);
  850.         assign(list, fun);
  851.         make_tree(list);
  852.         if (list == NIL || !is_tree(list)) {
  853.             goto qm_failed;
  854.         }
  855.         assign(unev, tree__tree(list));
  856.         save2(didnt_output_name,didnt_get_output);
  857.         num2save(val_status,tailcall);
  858.         newcont(qm_continue);
  859.         val_status = 5;
  860.         goto eval_sequence;
  861.  
  862. qm_continue:
  863.         num2restore(val_status,tailcall);
  864.         restore2(didnt_output_name,didnt_get_output);
  865.         if (val_status < 4 && tailcall != 0) {
  866.             if (STOPPING || RUNNING) assign(output_node, UNBOUND);
  867.             if (stopping_flag == OUTPUT || STOPPING) {
  868.             stopping_flag = RUN;
  869.             assign(val, output_node);
  870.             if (val != UNBOUND && val_status < 2) {
  871.                 err_logo(DK_WHAT_UP,val);
  872.             }
  873.             }
  874.         }
  875. qm_failed:
  876.         restore(qm_list);
  877.         goto fetch_cont;
  878.         }
  879.     } else {    /* name of procedure to apply */
  880.         int min, max, n;
  881.         NODE *arg;
  882.         assign(fun, intern(fun));
  883.         if (procnode__caseobj(fun) == UNDEFINED && NOT_THROWING &&
  884.         fun != Null_Word)
  885.             silent_load(fun, NULL);    /* try ./<fun>.lg */
  886.         if (procnode__caseobj(fun) == UNDEFINED && NOT_THROWING &&
  887.         fun != Null_Word)
  888.             silent_load(fun, logolib); /* try <logolib>/<fun> */
  889.         proc = procnode__caseobj(fun);
  890.         while (proc == UNDEFINED && NOT_THROWING) {
  891.         assign(val, err_logo(DK_HOW_UNREC, fun));
  892.         }
  893.         if (NOT_THROWING) {
  894.         if (nodetype(proc) == CONS) {
  895.             min = getint(minargs__procnode(proc));
  896.             max = getint(maxargs__procnode(proc));
  897.         } else {
  898.             if (getprimdflt(proc) < 0) {        /* special form */
  899.             err_logo(DK_HOW_UNREC, fun);    /* can't apply */
  900.             goto fetch_cont;
  901.             } else {
  902.             min = getprimmin(proc);
  903.             max = getprimmax(proc);
  904.             }
  905.         }
  906.         for (n = 0, arg = argl; arg != NIL; n++, arg = cdr(arg));
  907.         if (n < min) {
  908.             err_logo(NOT_ENOUGH, NIL);
  909.         } else if (n > max && max >= 0) {
  910.             err_logo(TOO_MUCH, NIL);
  911.         } else {
  912.             goto apply_dispatch;
  913.         }
  914.         }
  915.     }
  916.     }
  917.     goto fetch_cont;
  918.  
  919. all_done:
  920.     tailcall = oldtailcall;
  921.     ift_iff_flag = old_ift_iff;
  922.     restore2(fun,ufun);
  923.     reset_args(var);
  924.     restore2(var,this_line);
  925.     deref(argl);deref(unev);deref(stack);deref(catch_tag);deref(exp);
  926.     return(val);
  927. }
  928.