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