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