home *** CD-ROM | disk | FTP | other *** search
/ Amiga ACS 1998 #4 / amigaacscoverdisc1998-041998.iso / utilities / shareware / dev / ucb_logoppc / source / wrksp.c < prev    next >
Encoding:
C/C++ Source or Header  |  1998-02-20  |  29.3 KB  |  1,196 lines
  1. /*
  2.  *      wrksp.c         logo workspace management module                dvb
  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. #ifdef WIN32
  23. #include <windows.h>
  24. #endif
  25.  
  26. #include "logo.h"
  27. #include "globals.h"
  28.  
  29. #ifdef HAVE_UNISTD_H
  30. #include <unistd.h>
  31. #endif
  32.  
  33. #ifdef ibm
  34. #include "process.h"
  35. #endif
  36.  
  37. #ifdef HAVE_TERMIO_H
  38. #include <termio.h>
  39. #else
  40. #ifdef HAVE_SGTTY_H
  41. #include <sgtty.h>
  42. #endif
  43. #endif
  44.  
  45. #if defined(__PPC__) && defined(AMIGA)
  46.  
  47. #define __USE_SYSBASE
  48. #include <proto/exec.h>
  49. #include <proto/dos.h>
  50. #include <powerup/ppclib/interface.h>
  51. #include <powerup/gcclib/powerup_protos.h>
  52.  
  53. #define AllocVec(n, f) PPCAllocVec(n, f)
  54. #define FreeVec(b)     PPCFreeVec(b)
  55.  
  56. #endif
  57.  
  58. char *editor, *editorname, *tempdir;
  59. int to_pending = 0;
  60.  
  61. NODE *make_procnode(NODE *lst, NODE *wrds, int min, int df, int max) {
  62.     return(cons_list(0, lst, wrds, make_intnode((FIXNUM)min),
  63.            make_intnode((FIXNUM)df), make_intnode((FIXNUM)max),
  64.            END_OF_LIST));
  65. }
  66.  
  67. NODE *get_bodywords(NODE *proc, NODE *name) {
  68.     NODE *val = bodywords__procnode(proc);
  69.     NODE *head = NIL, *tail = NIL;
  70.  
  71.     if (val != NIL) return(val);
  72.     name = intern(name);
  73.     head = cons_list(0, (is_macro(name) ? Macro : To), name, END_OF_LIST);
  74.     tail = cdr(head);
  75.     val = formals__procnode(proc);
  76.     while (val != NIL) {
  77.    if (is_list(car(val)))
  78.        setcdr(tail, cons(cons(make_colon(caar(val)), cdar(val)), NIL));
  79.    else if (nodetype(car(val)) == INT)
  80.        setcdr(tail, cons(car(val),NIL));
  81.    else
  82.        setcdr(tail, cons(make_colon(car(val)),NIL));
  83.    tail = cdr(tail);
  84.    val = cdr(val);
  85.     }
  86.     head = cons(head, NIL);
  87.     tail = head;
  88.     val = bodylist__procnode(proc);
  89.     while (val != NIL) {
  90.    setcdr(tail, cons(runparse(car(val)), NIL));
  91.    tail = cdr(tail);
  92.    val = cdr(val);
  93.     }
  94.     setcdr(tail, cons(cons(End, NIL), NIL));
  95.     setbodywords__procnode(proc,head);
  96.     return(head);
  97. }
  98.  
  99. NODE *name_arg(NODE *args) {
  100.     while (aggregate(car(args)) && NOT_THROWING)
  101.    setcar(args, err_logo(BAD_DATA, car(args)));
  102.     return car(args);
  103. }
  104.  
  105. NODE *ltext(NODE *args) {
  106.     NODE *name, *val = UNBOUND;
  107.  
  108.     name = name_arg(args);
  109.     if (NOT_THROWING) {
  110.    val = procnode__caseobj(intern(name));
  111.    if (val == UNDEFINED) {
  112.        err_logo(DK_HOW_UNREC,name);
  113.        return UNBOUND;
  114.    } else if (is_prim(val)) {
  115.        err_logo(IS_PRIM,name);
  116.        return UNBOUND;
  117.    } else
  118.        return text__procnode(val);
  119.     }
  120.     return UNBOUND;
  121. }
  122.  
  123. NODE *lfulltext(NODE *args) {
  124.     NODE *name, *val = UNBOUND;
  125.  
  126.     name = name_arg(args);
  127.     if (NOT_THROWING) {
  128.    val = procnode__caseobj(intern(name));
  129.    if (val == UNDEFINED) {
  130.        err_logo(DK_HOW_UNREC,name);
  131.        return UNBOUND;
  132.    } else if (is_prim(val)) {
  133.        err_logo(IS_PRIM,name);
  134.        return UNBOUND;
  135.    } else
  136.        return get_bodywords(val,name);
  137.     }
  138.     return UNBOUND;
  139. }
  140.  
  141. BOOLEAN all_lists(NODE *val) {
  142.     if (val == NIL) return TRUE;
  143.     if (!is_list(car(val))) return FALSE;
  144.     return all_lists(cdr(val));
  145. }
  146.  
  147. NODE *define_helper(NODE *args, BOOLEAN macro_flag) {
  148.     NODE *name = NIL, *val = NIL, *arg = NIL;
  149.     int minimum = 0, deflt = 0, maximum = 0, old_default = -1;
  150.     int redef = (compare_node(valnode__caseobj(Redefp),True,TRUE) == 0);
  151.  
  152.     if (macro_flag >= 0) {
  153.    name = name_arg(args);
  154.    if (NOT_THROWING) {
  155.        name = intern(name);
  156.        val = procnode__caseobj(name);
  157.        if (!redef && is_prim(val)) {
  158.       err_logo(IS_PRIM,name);
  159.       return UNBOUND;
  160.        } else if (val != UNDEFINED) {
  161.       old_default = (is_prim(val) ? getprimdflt(val) :
  162.                      getint(dfltargs__procnode(val)));
  163.        }
  164.    }
  165.    if (NOT_THROWING) {
  166.        val = cadr(args);
  167.        while ((val == NIL || !is_list(val) || !all_lists(val)) &&
  168.              NOT_THROWING) {
  169.       setcar(cdr(args), err_logo(BAD_DATA, val));
  170.       val = cadr(args);
  171.        }
  172.    }
  173.     } else {   /* lambda */
  174.    val = args;
  175.     }
  176.     if (NOT_THROWING) {
  177.    args = car(val);
  178.    if (args != NIL) {
  179.        make_runparse(args);
  180.        args = parsed__runparse(args);
  181.    }
  182.    setcar(val, args);
  183.    while (args != NIL) {
  184.        arg = car(args);
  185.        if (arg != NIL && is_list(arg) && maximum != -1) {
  186.       make_runparse(arg);
  187.       arg = parsed__runparse(arg);
  188.       setcar(args, arg);
  189.       maximum++;
  190.       if (cdr(arg) == NIL)
  191.           maximum = -1;
  192.        } else if (nodetype(arg) == INT &&
  193.              getint(arg) <= (unsigned) maximum &&
  194.              getint(arg) >= minimum) {
  195.       deflt = getint(arg);
  196.        } else if (maximum == minimum) {
  197.       minimum++;
  198.       maximum++;
  199.       deflt++;
  200.        } else {
  201.       err_logo(BAD_DATA_UNREC, arg);
  202.       break;
  203.        }
  204.        args = cdr(args);
  205.        if (check_throwing) break;
  206.    }
  207.     }
  208.     if (macro_flag < 0) {
  209.    return make_procnode(val, NIL, minimum, deflt, maximum);
  210.     } else if (NOT_THROWING) {
  211.    setprocnode__caseobj(name,
  212.               make_procnode(val, NIL, minimum, deflt, maximum));
  213.    if (macro_flag)
  214.        setflag__caseobj(name, PROC_MACRO);
  215.    else
  216.        clearflag__caseobj(name, PROC_MACRO);
  217.    if (deflt != old_default && old_default >= 0) {
  218.        the_generation = cons(NIL, NIL);
  219.    }
  220.     }
  221.     return(UNBOUND);
  222. }
  223.  
  224. NODE *ldefine(NODE *args) {
  225.     return define_helper(args, FALSE);
  226. }
  227.  
  228. NODE *ldefmacro(NODE *args) {
  229.     return define_helper(args, TRUE);
  230. }
  231.  
  232. NODE *anonymous_function(NODE *text) {
  233.     return define_helper(text, -1);
  234. }
  235.  
  236. NODE *to_helper(NODE *args, BOOLEAN macro_flag) {
  237.     NODE *arg = NIL, *tnode = NIL, *proc_name, *formals = NIL, *lastnode = NIL,
  238.     *body_words, *lastnode2, *body_list;
  239.     int minimum = 0, deflt = 0, maximum = 0, old_default = -1;
  240.  
  241.     if (ufun != NIL && loadstream == stdin) {
  242.    err_logo(NOT_INSIDE,NIL);
  243.    return(UNBOUND);
  244.     }
  245.  
  246.     if (args == NIL) {
  247.    err_logo(NOT_ENOUGH,NIL);
  248.    return(UNBOUND);
  249.     }
  250.  
  251.     deepend_proc_name = proc_name = car(args);
  252.     args = cdr(args);
  253.  
  254.     if (nodetype(proc_name) != CASEOBJ)
  255.    err_logo(BAD_DATA_UNREC, proc_name);
  256.     else if ((procnode__caseobj(proc_name) != UNDEFINED && loadstream == stdin)
  257.         || is_prim(procnode__caseobj(proc_name)))
  258.    err_logo(ALREADY_DEFINED, proc_name);
  259.     else {
  260.    NODE *old_proc = procnode__caseobj(proc_name);
  261.    if (old_proc != UNDEFINED) {
  262.        old_default = (is_prim(old_proc) ? getprimdflt(old_proc) :
  263.                      getint(dfltargs__procnode(old_proc)));
  264.    }
  265.    while (args != NIL) {
  266.        arg = car(args);
  267.        args = cdr(args);
  268.        if (nodetype(arg) == CONS && maximum != -1) {
  269.       make_runparse(arg);
  270.       arg = parsed__runparse(arg);
  271.       maximum++;
  272.       if (nodetype(car(arg)) != COLON) {
  273.           err_logo(BAD_DATA_UNREC, arg);
  274.           break;
  275.       } else
  276.           setcar(arg, node__colon(car(arg)));
  277.       if (cdr(arg) == NIL)
  278.           maximum = -1;
  279.        } else if (nodetype(arg) == COLON && maximum == minimum) {
  280.       arg = node__colon(arg);
  281.       minimum++;
  282.       maximum++;
  283.       deflt++;
  284.        } else if (nodetype(arg) == INT &&
  285.              getint(arg) <= (unsigned) maximum &&
  286.              getint(arg) >= minimum) {
  287.       deflt = getint(arg);
  288.        } else {
  289.       err_logo(BAD_DATA_UNREC, arg);
  290.       break;
  291.        }
  292.        tnode = cons(arg, NIL);
  293.        if (formals == NIL) formals = tnode;
  294.        else setcdr(lastnode, tnode);
  295.        lastnode = tnode;
  296.    }
  297.     }
  298.  
  299.     if (NOT_THROWING) {
  300.    body_words = cons(current_line, NIL);
  301.    lastnode2 = body_words;
  302.    body_list = cons(formals, NIL);
  303.    lastnode = body_list;
  304.    to_pending++;    /* for int or quit signal */
  305.    while (NOT_THROWING && to_pending && (!feof(loadstream))) {
  306.        tnode = cons(reader(loadstream, "> "), NIL);
  307.        setcdr(lastnode2, tnode);
  308.        lastnode2 = tnode;
  309.        tnode = cons(parser(car(tnode), TRUE), NIL);
  310.        if (car(tnode) != NIL && compare_node(caar(tnode), End, TRUE) == 0)
  311.       break;
  312.        else if (car(tnode) != NIL) {
  313.       setcdr(lastnode, tnode);
  314.       lastnode = tnode;
  315.        }
  316.    }
  317.    if (to_pending && NOT_THROWING) {
  318.        setprocnode__caseobj(proc_name,
  319.              make_procnode(body_list, body_words, minimum,
  320.                       deflt, maximum));
  321.        if (macro_flag)
  322.       setflag__caseobj(proc_name, PROC_MACRO);
  323.        else
  324.       clearflag__caseobj(proc_name, PROC_MACRO);
  325.        if (deflt != old_default && old_default >= 0) {
  326.       the_generation = cons(NIL, NIL);
  327.        }
  328.        if (loadstream == stdin ||
  329.         compare_node(valnode__caseobj(LoadNoisily),True,TRUE) == 0) {
  330.       ndprintf(stdout, "%s defined\n", proc_name);
  331.        }
  332.    }
  333.    to_pending = 0;
  334.     }
  335.     deepend_proc_name = NIL;
  336.     return(UNBOUND);
  337. }
  338.  
  339. NODE *lto(NODE *args) {
  340.     return to_helper(args, FALSE);
  341. }
  342.  
  343. NODE *lmacro(NODE *args) {
  344.     return to_helper(args, TRUE);
  345. }
  346.  
  347. NODE *lmake(NODE *args) {
  348.     NODE *what;
  349.  
  350.     what = name_arg(args);
  351.     if (NOT_THROWING) {
  352.    what = intern(what);
  353.    setvalnode__caseobj(what, cadr(args));
  354.    if (flag__caseobj(what, VAL_TRACED)) {
  355.        NODE *tvar = maybe_quote(cadr(args));
  356.        ndprintf(writestream, "Make %s %s", make_quote(what), tvar);
  357.        if (ufun != NIL) {
  358.       ndprintf(writestream, " in %s\n%s", ufun, this_line);
  359.        }
  360.        new_line(writestream);
  361.    }
  362.     }
  363.     return(UNBOUND);
  364. }
  365.  
  366. NODE *llocal(NODE *args) {
  367.     NODE *arg = NIL;
  368.     NODE *vsp = var_stack;
  369.  
  370.     if (tailcall == 1) return UNBOUND;
  371.     while (is_list(car(args)) && cdr(args) != NIL && NOT_THROWING)
  372.    setcar(args, err_logo(BAD_DATA, car(args)));
  373.     if (is_list(car(args)))
  374.    args = car(args);
  375.     while (args != NIL && NOT_THROWING) {
  376.    arg = car(args);
  377.    while (!is_word(arg) && NOT_THROWING) {
  378.        arg = err_logo(BAD_DATA, arg);
  379.        setcar(args, arg); /* prevent crash in lapply */
  380.    }
  381.    if (NOT_THROWING) {
  382.        arg = intern(arg);
  383.        setcar(args, arg); /* local [a b] faster next time */
  384.        if (not_local(arg,vsp)) {
  385.       push(arg, var_stack);
  386.       setobject(var_stack, valnode__caseobj(arg));
  387.        }
  388.        setvalnode__caseobj(arg, UNBOUND);
  389.        tell_shadow(arg);
  390.        args = cdr(args);
  391.    }
  392.    if (check_throwing) break;
  393.     }
  394.     var = var_stack;    /* so eval won't undo our work */
  395.     return(UNBOUND);
  396. }
  397.  
  398. NODE *cnt_list = NIL;
  399. NODE *cnt_last = NIL;
  400. int want_buried = 0;
  401.  
  402. typedef enum {c_PROCS, c_VARS, c_PLISTS} CNTLSTTYP;
  403. CNTLSTTYP contents_list_type;
  404.  
  405. int bck(int flag) {
  406.     return (want_buried ? !flag : flag);
  407. }
  408.  
  409. void contents_map(NODE *sym) {
  410.     switch(contents_list_type) {
  411.    case c_PROCS:
  412.        if (procnode__object(sym) == UNDEFINED ||
  413.          is_prim(procnode__object(sym)))
  414.       return;
  415.        if (bck(flag__object(sym,PROC_BURIED))) return;
  416.        break;
  417.    case c_VARS:
  418.        if (valnode__object(sym) == UNBOUND) return;
  419.        if (bck(flag__object(sym,VAL_BURIED))) return;
  420.        break;
  421.    case c_PLISTS:
  422.        if (plist__object(sym) == NIL) return;
  423.        if (bck(flag__object(sym,PLIST_BURIED))) return;
  424.        break;
  425.     }
  426.     if (cnt_list == NIL) {
  427.    cnt_list = cons(canonical__object(sym), NIL);
  428.    cnt_last = cnt_list;
  429.     } else {
  430.    setcdr(cnt_last, cons(canonical__object(sym), NIL));
  431.    cnt_last = cdr(cnt_last);
  432.     }
  433. }
  434.  
  435. void ms_listlist(NODE *nd) {
  436.     while (nd != NIL) {
  437.    setcar(nd, cons(car(nd), NIL));
  438.    nd = cdr(nd);
  439.     }
  440. }
  441.  
  442. NODE *merge(NODE *a, NODE *b) {
  443.     NODE *ret, *tail;
  444.  
  445.     if (a == NIL) return(b);
  446.     if (b == NIL) return(a);
  447.     if (compare_node(car(a),car(b),FALSE) < 0) {
  448.    ret = a;
  449.    tail = a;
  450.    a = cdr(a);
  451.     } else {
  452.    ret = b;
  453.    tail = b;
  454.    b = cdr(b);
  455.     }
  456.  
  457.     while (a != NIL && b != NIL) {
  458.    if (compare_node(car(a),car(b),FALSE) < 0) {
  459.        setcdr(tail, a);
  460.        a = cdr(a);
  461.    } else {
  462.        setcdr(tail, b);
  463.        b = cdr(b);
  464.    }
  465.    tail = cdr(tail);
  466.     }
  467.  
  468.     if (b == NIL) setcdr(tail, a);
  469.     else setcdr(tail, b);
  470.  
  471.     return ret;
  472. }
  473.  
  474. void mergepairs(NODE *nd) {
  475.     while (nd != NIL && cdr(nd) != NIL) {
  476.    setcar(nd, merge(car(nd), cadr(nd)));
  477.    setcdr(nd, cddr(nd));
  478.    nd = cdr(nd);
  479.     }
  480. }
  481.  
  482. NODE *mergesrt(NODE *nd) {    /* spelled funny to avoid library conflict */
  483.     if (nd == NIL) return(NIL);
  484.     if (cdr(nd) == NIL) return(nd);
  485.     ms_listlist(nd);
  486.     while (cdr(nd) != NIL)
  487.    mergepairs(nd);
  488.     return car(nd);
  489. }
  490.  
  491. NODE *get_contents() {
  492.     cnt_list = NIL;
  493.     cnt_last = NIL;
  494.     map_oblist(contents_map);
  495.     cnt_list = mergesrt(cnt_list);
  496.     return(cnt_list);
  497. }
  498.  
  499. NODE *lcontents(NODE *args) {
  500.     NODE *ret;
  501.  
  502.     want_buried = 0;
  503.  
  504.     contents_list_type = c_PLISTS;
  505.     ret = cons(get_contents(), NIL);
  506.  
  507.     contents_list_type = c_VARS;
  508.     push(get_contents(), ret);
  509.  
  510.     contents_list_type = c_PROCS;
  511.     push(get_contents(), ret);
  512.  
  513.     cnt_list = NIL;
  514.     return(ret);
  515. }
  516.  
  517. NODE *lburied(NODE *args) {
  518.     NODE *ret;
  519.  
  520.     want_buried = 1;
  521.  
  522.     contents_list_type = c_PLISTS;
  523.     ret = cons(get_contents(), NIL);
  524.  
  525.     contents_list_type = c_VARS;
  526.     push(get_contents(), ret);
  527.  
  528.     contents_list_type = c_PROCS;
  529.     push(get_contents(), ret);
  530.  
  531.     cnt_list = NIL;
  532.     return(ret);
  533. }
  534.  
  535. NODE *lprocedures(NODE *args) {
  536.     NODE *ret;
  537.  
  538.     want_buried = 0;
  539.  
  540.     contents_list_type = c_PROCS;
  541.     ret = get_contents();
  542.     cnt_list = NIL;
  543.     return(ret);
  544. }
  545.  
  546. NODE *lnames(NODE *args) {
  547.     NODE *ret;
  548.  
  549.     want_buried = 0;
  550.  
  551.     contents_list_type = c_VARS;
  552.     ret = cons(NIL, cons(get_contents(), NIL));
  553.     cnt_list = NIL;
  554.     return(ret);
  555. }
  556.  
  557. NODE *lplists(NODE *args) {
  558.     NODE *ret;
  559.  
  560.     want_buried = 0;
  561.  
  562.     contents_list_type = c_PLISTS;
  563.     ret = cons(NIL, cons(NIL, cons(get_contents(), NIL)));
  564.     cnt_list = NIL;
  565.     return(ret);
  566. }
  567.  
  568. NODE *one_list(NODE *nd) {
  569.     if (!is_list(nd))
  570.    return(cons(nd,NIL));
  571.     return nd;
  572. }
  573.  
  574. void three_lists(NODE *arg, NODE **proclst, NODE **varlst, NODE **plistlst) {
  575.     if (nodetype(car(arg)) == CONS)
  576.    arg = car(arg);
  577.  
  578.     if (!is_list(car(arg)))
  579.    *proclst = arg;
  580.     else {
  581.    *proclst = car(arg);
  582.    if (cdr(arg) != NIL) {
  583.        *varlst = one_list(cadr(arg));
  584.        if (cddr(arg) != NIL) {
  585.       *plistlst = one_list(car(cddr(arg)));
  586.        }
  587.    }
  588.     }
  589.     if (!is_list(*proclst) || !is_list(*varlst) || !is_list(*plistlst)) {
  590.    err_logo(BAD_DATA_UNREC,arg);
  591.    *plistlst = *varlst = *proclst = NIL;
  592.     }
  593. }
  594.  
  595. char *expand_slash(NODE *wd) {
  596.    char *result, *cp, *cp2;
  597.    int i, len = getstrlen(wd), j;
  598.  
  599.    for (cp = getstrptr(wd), i=0, j = len; --j >= 0; )
  600.       if (getparity(*cp++)) i++;
  601.    result = malloc(len+i+1);
  602.    if (result == NULL) {
  603.        err_logo(OUT_OF_MEM, NIL);
  604.        return 0;
  605.    }
  606.    for (cp = getstrptr(wd), cp2 = result, j = len; --j >= 0; ) {
  607.       if (getparity(*cp)) *cp2++ = '\\';
  608.       *cp2++ = clearparity(*cp++);
  609.    }
  610.    *cp2 = '\0';
  611.    return result;
  612. }
  613.  
  614. NODE *po_helper(NODE *arg, int just_titles) {   /* >0 for POT, <0 for EDIT */
  615.     NODE *proclst = NIL, *varlst = NIL, *plistlst = NIL, *tvar = NIL;
  616.     NODE *plist;
  617.  
  618.     print_backslashes = TRUE;
  619.  
  620.     three_lists(arg, &proclst, &varlst, &plistlst);
  621.  
  622.     while (proclst != NIL) {
  623.    if (aggregate(car(proclst))) {
  624.        err_logo(BAD_DATA_UNREC, car(proclst));
  625.        break;
  626.    } else
  627.        tvar = procnode__caseobj(intern(car(proclst)));
  628.  
  629.    if (tvar == UNDEFINED) {
  630.        if (just_titles < 0) {
  631.       ndprintf(writestream,"to %p\nend\n\n", car(proclst));
  632.        } else {
  633.       err_logo(DK_HOW_UNREC, car(proclst));
  634.       break;
  635.        }
  636.    } else if (nodetype(tvar) & NT_PRIM) {
  637.        err_logo(IS_PRIM, car(proclst));
  638.        break;
  639.    } else {
  640.        tvar = get_bodywords(tvar,car(proclst));
  641.        if (just_titles > 0) {
  642.       if (is_list(car(tvar)))
  643.          print_nobrak(writestream, car(tvar));
  644.       else {
  645.          char *str = expand_slash(car(tvar));
  646.          ndprintf(writestream, "%t", str);
  647.          free(str);
  648.       }
  649.        } else while (tvar != NIL) {
  650.          if (is_list(car(tvar)))
  651.             print_nobrak(writestream, car(tvar));
  652.          else {
  653.             char *str = expand_slash(car(tvar));
  654.             ndprintf(writestream, "%t", str);
  655.             free(str);
  656.          }
  657.          new_line(writestream);
  658.          tvar = cdr(tvar);
  659.        }
  660.        new_line(writestream);
  661.    }
  662.    proclst = cdr(proclst);
  663.    if (check_throwing) break;
  664.     }
  665.  
  666.     while (varlst != NIL && NOT_THROWING) {
  667.    if (aggregate(car(varlst))) {
  668.        err_logo(BAD_DATA_UNREC, car(varlst));
  669.        break;
  670.    } else
  671.        tvar = maybe_quote(valnode__caseobj(intern(car(varlst))));
  672.  
  673.    if (tvar == UNBOUND) {
  674.        if (just_titles >= 0) {
  675.       err_logo(NO_VALUE, car(varlst));
  676.       break;
  677.        }
  678.    } else {
  679.        ndprintf(writestream, "Make %s %s\n",
  680.            make_quote(car(varlst)), tvar);
  681.    }
  682.    varlst = cdr(varlst);
  683.    if (check_throwing) break;
  684.     }
  685.  
  686.     while (plistlst != NIL && NOT_THROWING) {
  687.    if (aggregate(car(plistlst))) {
  688.        err_logo(BAD_DATA_UNREC, car(plistlst));
  689.        break;
  690.    } else {
  691.        plist = plist__caseobj(intern(car(plistlst)));
  692.        if (plist != NIL && just_titles > 0) {
  693.       ndprintf(writestream, "Plist %s = %s\n",
  694.           maybe_quote(car(plistlst)), plist);
  695.        } else while (plist != NIL) {
  696.       ndprintf(writestream, "Pprop %s %s %s\n",
  697.           maybe_quote(car(plistlst)),
  698.           maybe_quote(car(plist)),
  699.           maybe_quote(cadr(plist)));
  700.       plist = cddr(plist);
  701.        }
  702.    }
  703.    plistlst = cdr(plistlst);
  704.    if (check_throwing) break;
  705.     }
  706.  
  707.     print_backslashes = FALSE;
  708.     return(UNBOUND);
  709. }
  710.  
  711. NODE *lpo(NODE *arg) {
  712.     return(po_helper(arg,0));
  713. }
  714.  
  715. NODE *lpot(NODE *arg) {
  716.     return(po_helper(arg,1));
  717. }
  718.  
  719. NODE *lerase(NODE *arg) {
  720.     NODE *proclst = NIL, *varlst = NIL, *plistlst = NIL;
  721.     NODE *nd;
  722.     int redef = (compare_node(valnode__caseobj(Redefp),True,TRUE) == 0);
  723.  
  724.     three_lists(arg, &proclst, &varlst, &plistlst);
  725.  
  726.     if (proclst != NIL)
  727.    the_generation = cons(NIL, NIL);
  728.  
  729.     while (proclst != NIL) {
  730.    if (aggregate(car(proclst))) {
  731.        err_logo(BAD_DATA_UNREC, car(proclst));
  732.        break;
  733.    }
  734.    nd = intern(car(proclst));
  735.    if (!redef && is_prim(procnode__caseobj(nd))) {
  736.        err_logo(IS_PRIM, nd);
  737.        break;
  738.    }
  739.    setprocnode__caseobj(nd, UNDEFINED);
  740.    proclst = cdr(proclst);
  741.     }
  742.  
  743.     while (varlst != NIL && NOT_THROWING) {
  744.    if (aggregate(car(varlst))) {
  745.        err_logo(BAD_DATA_UNREC, car(varlst));
  746.        break;
  747.    }
  748.    setvalnode__caseobj(intern(car(varlst)), UNBOUND);
  749.    varlst = cdr(varlst);
  750.     }
  751.  
  752.     while (plistlst != NIL && NOT_THROWING) {
  753.    if (aggregate(car(plistlst))) {
  754.        err_logo(BAD_DATA_UNREC, car(plistlst));
  755.        break;
  756.    }
  757.    setplist__caseobj(intern(car(plistlst)), NIL);
  758.    plistlst = cdr(plistlst);
  759.     }
  760.     return(UNBOUND);
  761. }
  762.  
  763. NODE *erall_helper(BOOLEAN procs, BOOLEAN vals, BOOLEAN plists) {
  764.     NODE *nd, *obj;
  765.     int loop;
  766.     int redef = (compare_node(valnode__caseobj(Redefp),True,TRUE) == 0);
  767.  
  768.     for (loop = 0; loop < HASH_LEN ; loop++) {
  769.    for (nd = hash_table[loop]; nd != NIL; nd = cdr(nd)) {
  770.        obj = car(nd);
  771.        if (procs && !flag__object(obj, PROC_BURIED) &&
  772.          (procnode__object(obj) != UNDEFINED) &&
  773.          (redef || !is_prim(procnode__object(obj))))
  774.       setprocnode__object(obj, UNDEFINED);
  775.        if (vals && !flag__object(obj, VAL_BURIED))
  776.       setvalnode__object(obj, UNBOUND);
  777.        if (plists && !flag__object(obj, PLIST_BURIED))
  778.       setplist__object(obj, NIL);
  779.    }
  780.     }
  781.     return UNBOUND;
  782. }
  783.  
  784. NODE *lerall(NODE *args) {
  785.     return erall_helper(TRUE, TRUE, TRUE);
  786. }
  787.  
  788. NODE *lerps(NODE *args) {
  789.     return erall_helper(TRUE, FALSE, FALSE);
  790. }
  791.  
  792. NODE *lerns(NODE *args) {
  793.     return erall_helper(FALSE, TRUE, FALSE);
  794. }
  795.  
  796. NODE *lerpls(NODE *args) {
  797.     return erall_helper(FALSE, FALSE, TRUE);
  798. }
  799.  
  800. NODE *bury_helper(NODE *arg, int flag) {
  801.     NODE *proclst = NIL, *varlst = NIL, *plistlst = NIL;
  802.  
  803.     three_lists(arg, &proclst, &varlst, &plistlst);
  804.  
  805.     while (proclst != NIL) {
  806.    if (aggregate(car(proclst))) {
  807.        err_logo(BAD_DATA_UNREC, car(proclst));
  808.        break;
  809.    }
  810.    setflag__caseobj(intern(car(proclst)), flag);
  811.    proclst = cdr(proclst);
  812.    if (check_throwing) break;
  813.     }
  814.  
  815.     flag <<= 1;
  816.     while (varlst != NIL && NOT_THROWING) {
  817.    if (aggregate(car(varlst))) {
  818.        err_logo(BAD_DATA_UNREC, car(varlst));
  819.        break;
  820.    }
  821.    setflag__caseobj(intern(car(varlst)), flag);
  822.    varlst = cdr(varlst);
  823.    if (check_throwing) break;
  824.     }
  825.  
  826.     flag <<= 1;
  827.     while (plistlst != NIL && NOT_THROWING) {
  828.    if (aggregate(car(plistlst))) {
  829.        err_logo(BAD_DATA_UNREC, car(plistlst));
  830.        break;
  831.    }
  832.    setflag__caseobj(intern(car(plistlst)), flag);
  833.    plistlst = cdr(plistlst);
  834.    if (check_throwing) break;
  835.     }
  836.     return(UNBOUND);
  837. }
  838.  
  839. NODE *lbury(NODE *arg) {
  840.     return bury_helper(arg,PROC_BURIED);
  841. }
  842.  
  843. NODE *ltrace(NODE *arg) {
  844.     return bury_helper(arg,PROC_TRACED);
  845. }
  846.  
  847. NODE *lstep(NODE *arg) {
  848.     return bury_helper(arg,PROC_STEPPED);
  849. }
  850.  
  851. NODE *unbury_helper(NODE *arg, int flag) {
  852.     NODE *proclst = NIL, *varlst = NIL, *plistlst = NIL;
  853.  
  854.     three_lists(arg, &proclst, &varlst, &plistlst);
  855.  
  856.     while (proclst != NIL) {
  857.    if (aggregate(car(proclst))) {
  858.        err_logo(BAD_DATA_UNREC, car(proclst));
  859.        break;
  860.    }
  861.    clearflag__caseobj(intern(car(proclst)), flag);
  862.    proclst = cdr(proclst);
  863.    if (check_throwing) break;
  864.     }
  865.  
  866.     flag <<= 1;
  867.     while (varlst != NIL && NOT_THROWING) {
  868.    if (aggregate(car(varlst))) {
  869.        err_logo(BAD_DATA_UNREC, car(varlst));
  870.        break;
  871.    }
  872.    clearflag__caseobj(intern(car(varlst)), flag);
  873.    varlst = cdr(varlst);
  874.    if (check_throwing) break;
  875.     }
  876.  
  877.     flag <<= 1;
  878.     while (plistlst != NIL && NOT_THROWING) {
  879.    if (aggregate(car(plistlst))) {
  880.        err_logo(BAD_DATA_UNREC, car(plistlst));
  881.        break;
  882.    }
  883.    clearflag__caseobj(intern(car(plistlst)), flag);
  884.    plistlst = cdr(plistlst);
  885.    if (check_throwing) break;
  886.     }
  887.     return(UNBOUND);
  888. }
  889.  
  890. NODE *lunbury(NODE *arg) {
  891.     return unbury_helper(arg,PROC_BURIED);
  892. }
  893.  
  894. NODE *luntrace(NODE *arg) {
  895.     return unbury_helper(arg,PROC_TRACED);
  896. }
  897.  
  898. NODE *lunstep(NODE *arg) {
  899.     return unbury_helper(arg,PROC_STEPPED);
  900. }
  901.  
  902. char *addsep(char *path) {
  903.     static char result[70];
  904.  
  905.     strcpy(result, path);
  906.     if (result[0]) strcat(result, separator);
  907.     return result;
  908. }
  909.  
  910. NODE *ledit(NODE *args) {
  911.     char tmp_filename[50];
  912.     FILE *holdstrm;
  913. #ifdef unix
  914. #ifndef HAVE_UNISTD_H
  915.     extern int getpid();
  916. #endif
  917. #endif
  918. #ifdef __ZTC__
  919.     BOOLEAN was_graphics;
  920. #endif
  921.     NODE *tmp_line = NIL, *exec_list = NIL;
  922.     int sv_val_status = val_status;
  923.  
  924. #ifdef AMIGA
  925.    sprintf(tmp_filename, "T:temp%ld.txt",FindTask(NULL));
  926. #else
  927. #ifndef unix
  928.     sprintf(tmp_filename, "%stemp.txt", addsep(tempdir));
  929. #else
  930.     sprintf(tmp_filename, "%s/logo%d", tempdir, (int)getpid());
  931. #endif
  932. #endif
  933.     if (args != NIL) {
  934.    holdstrm = writestream;
  935.    writestream = fopen(tmp_filename, "w");
  936.    if (writestream != NULL) {
  937.        po_helper(args,-1);
  938.        fclose(writestream);
  939.        writestream = holdstrm;
  940.    } else {
  941.        err_logo(FILE_ERROR,
  942.          make_static_strnode("Could not create editor file"));
  943.        writestream = holdstrm;
  944.        return(UNBOUND);
  945.    }
  946.     }
  947.     if (stopping_flag == THROWING) return(UNBOUND);
  948. #ifdef AMIGA
  949.    {
  950.       char dos_command[150];
  951.       sprintf(dos_command,
  952. //         "ed %s window \"CON:20/20/600/200/Logo Editor/CLOSE/SCREEN %s\"",
  953.          prefs.editor,
  954.          tmp_filename,screenname);
  955.       Execute(dos_command,NULL,console);
  956.    }
  957. #else    /* not AMIGA */
  958. #ifdef mac
  959.     if (!mac_edit()) return(UNBOUND);
  960. #else  /* not mac */
  961. #ifdef ibm
  962. #ifdef __ZTC__
  963.     was_graphics = in_graphics_mode;
  964.     if (in_graphics_mode) t_screen();
  965.     zflush();
  966. #endif   /* __ZTC__ */
  967.     if (spawnlp(P_WAIT, editor, editorname, tmp_filename, NULL)) {
  968.    err_logo(FILE_ERROR, make_static_strnode
  969.        ("Could not launch the editor"));
  970.    return(UNBOUND);
  971.     }
  972. #ifdef __ZTC__
  973.     if (was_graphics) s_screen();
  974.     else lcleartext(NIL);
  975. #endif   /* __ZTC__ */
  976. #ifdef WIN32
  977.     win32_repaint_screen();
  978. #endif  /* WIN32 */
  979. #else    /* not ibm */
  980.     if (fork() == 0) {
  981.    execlp(editor, editorname, tmp_filename, 0);
  982.    exit(1);
  983.     }
  984.     wait(0);
  985. #ifdef WIN32
  986.     win32_repaint_screen();
  987. #endif /* WIN32 */
  988. #endif /* ibm */
  989. #endif /* AMIGA */
  990. #endif
  991.     holdstrm = loadstream;
  992.     tmp_line = current_line;
  993.     loadstream = fopen(tmp_filename, "r");
  994.     if (loadstream != NULL) {
  995.    while (!feof(loadstream) && NOT_THROWING) {
  996.        current_line = reader(loadstream, "");
  997.        exec_list = parser(current_line, TRUE);
  998.        val_status = 0;
  999.        if (exec_list != NIL) eval_driver(exec_list);
  1000.    }
  1001.    fclose(loadstream);
  1002. #ifdef AMIGA
  1003.    {
  1004.       char dos_command[150];
  1005.       sprintf(dos_command,"delete >nil: %s",tmp_filename);
  1006.       Execute(dos_command,NULL,console);
  1007.    }
  1008. #endif
  1009.    val_status = sv_val_status;
  1010.     } else
  1011.    err_logo(FILE_ERROR,
  1012.          make_static_strnode("Could not read editor file"));
  1013.     loadstream = holdstrm;
  1014.     current_line = tmp_line;
  1015.     return(UNBOUND);
  1016. }
  1017.  
  1018. NODE *lthing(NODE *args) {
  1019.     NODE *val = UNBOUND, *arg;
  1020.  
  1021.     arg = name_arg(args);
  1022.     if (NOT_THROWING) val = valnode__caseobj(intern(arg));
  1023.     while (val == UNBOUND && NOT_THROWING)
  1024.    val = err_logo(NO_VALUE, car(args));
  1025.     return(val);
  1026. }
  1027.  
  1028. NODE *lnamep(NODE *args) {
  1029.     NODE *arg;
  1030.  
  1031.     arg = name_arg(args);
  1032.     if (NOT_THROWING)
  1033.    return torf(valnode__caseobj(intern(arg)) != UNBOUND);
  1034.     return UNBOUND;
  1035. }
  1036.  
  1037. NODE *lprocedurep(NODE *args) {
  1038.     NODE *arg;
  1039.  
  1040.     arg = name_arg(args);
  1041.     if (NOT_THROWING)
  1042.    return torf(procnode__caseobj(intern(arg)) != UNDEFINED);
  1043.     return UNBOUND;
  1044. }
  1045.  
  1046. NODE *check_proctype(NODE *args, int wanted) {
  1047.     NODE *arg, *cell = NIL;
  1048.     int isprim;
  1049.  
  1050.     arg = name_arg(args);
  1051.     if (NOT_THROWING && (cell = procnode__caseobj(intern(arg))) == UNDEFINED) {
  1052.    return(False);
  1053.     }
  1054.     if (wanted == 2) return torf(is_macro(intern(arg)));
  1055.     isprim = is_prim(cell);
  1056.     if (NOT_THROWING) return torf((isprim != 0) == wanted);
  1057.     return(UNBOUND);
  1058. }
  1059.  
  1060. NODE *lprimitivep(NODE *args) {
  1061.     return(check_proctype(args,1));
  1062. }
  1063.  
  1064. NODE *ldefinedp(NODE *args) {
  1065.     return(check_proctype(args,0));
  1066. }
  1067.  
  1068. NODE *lmacrop(NODE *args) {
  1069.     return(check_proctype(args,2));
  1070. }
  1071.  
  1072. NODE *lcopydef(NODE *args) {
  1073.     NODE *arg1, *arg2;
  1074.     int redef = (compare_node(valnode__caseobj(Redefp),True,TRUE) == 0);
  1075.     int old_default, new_default;
  1076.  
  1077.     arg1 = name_arg(args);
  1078.     arg2 = name_arg(cdr(args));
  1079.     if (numberp(arg2)) err_logo(BAD_DATA_UNREC, arg2);
  1080.     if (numberp(arg1)) err_logo(BAD_DATA_UNREC, arg1);
  1081.     if (NOT_THROWING) {
  1082.    arg1 = intern(arg1);
  1083.    arg2 = intern(arg2);
  1084.     }
  1085.     if (NOT_THROWING && procnode__caseobj(arg2) == UNDEFINED)
  1086.    err_logo(DK_HOW, arg2);
  1087.     if (NOT_THROWING && !redef && is_prim(procnode__caseobj(arg1)))
  1088.    err_logo(IS_PRIM, arg1);
  1089.     if (NOT_THROWING) {
  1090.    NODE *old_proc = procnode__caseobj(arg1);
  1091.    NODE *new_proc = procnode__caseobj(arg2);
  1092.    if (old_proc != UNDEFINED) {
  1093.        old_default = (is_prim(old_proc) ? getprimdflt(old_proc) :
  1094.                       getint(dfltargs__procnode(old_proc)));
  1095.        new_default = (is_prim(new_proc) ? getprimdflt(new_proc) :
  1096.                       getint(dfltargs__procnode(new_proc)));
  1097.        if (old_default != new_default) {
  1098.       the_generation = cons(NIL, NIL);
  1099.        }
  1100.    }
  1101.    setprocnode__caseobj(arg1, new_proc);
  1102.    setflag__caseobj(arg1, PROC_BURIED);
  1103.    if (is_macro(arg2)) setflag__caseobj(arg1, PROC_MACRO);
  1104.    else clearflag__caseobj(arg1, PROC_MACRO);
  1105.     }
  1106.     return(UNBOUND);
  1107. }
  1108.  
  1109. char *fixhelp(char *ptr, int len) {
  1110.     static char result[32];
  1111.     char *p, c;
  1112.     for (p = result; --len >= 0; *p++ = c) {
  1113.         c = *ptr++;
  1114.         if (c == '?')
  1115.             c = 'p';
  1116.         else if (c == '.')
  1117.             c = 'd';
  1118.     }
  1119.     *p = 0;
  1120.     return result;
  1121. }
  1122.  
  1123. NODE *lhelp(NODE *args) {
  1124.     NODE *arg = NIL;
  1125.     char buffer[200];
  1126.     char junk[20];
  1127.     FILE *fp;
  1128.     int lines;
  1129. #if defined(ibm) || defined(WIN32)
  1130.     int len;
  1131. #endif
  1132.  
  1133.     if (args == NIL) {
  1134. #ifdef WIN32
  1135.    sprintf(buffer, "%sHELPCONT", addsep(helpfiles));
  1136. #else
  1137.    sprintf(buffer, "%sHELPCONTENTS", addsep(helpfiles));
  1138. #endif
  1139.     } else if (is_word(car(args))) {
  1140.         arg = llowercase(args);
  1141.    setcar(args, arg);
  1142.    sprintf(buffer, "%s%s", addsep(helpfiles),
  1143.       fixhelp(getstrptr(arg), getstrlen(arg)));
  1144. #if defined(ibm) || defined(WIN32)
  1145.    if (strlen(buffer) > (len = strlen(addsep(helpfiles))+8)) {
  1146.        buffer[len+5] = '\0';
  1147.        buffer[len+4] = buffer[len+3];
  1148.        buffer[len+3] = buffer[len+2];
  1149.        buffer[len+2] = buffer[len+1];
  1150.        buffer[len+1] = buffer[len];
  1151.        buffer[len] = '.';
  1152.    }
  1153. #endif
  1154.     } else {
  1155.         err_logo(BAD_DATA_UNREC, car(args));
  1156.    return UNBOUND;
  1157.     }
  1158.     fp = fopen(buffer, "r");
  1159.     if (fp == NULL) {
  1160.    if (args == NIL)
  1161.        ndprintf(writestream, "No help available.\n");
  1162.    else
  1163.        ndprintf(writestream, "No help available on %p.\n", arg);
  1164.     } else {
  1165.    (void)ltextscreen(NIL);
  1166.    lines = 0;
  1167.    fgets(buffer, 200, fp);
  1168.    while (NOT_THROWING && !feof(fp)) {
  1169.        if (interactive && writestream==stdout && ++lines >= y_max) {
  1170.       ndprintf(writestream,"--more--");
  1171.       input_blocking++;
  1172. #ifndef TIOCSTI
  1173.       if (!setjmp(iblk_buf))
  1174. #endif
  1175. #ifdef __ZTC__
  1176.           ztc_getcr();
  1177.           print_char(stdout, '\n');
  1178. #else
  1179. #ifdef WIN32
  1180.           (void)reader(stdin, "");
  1181. #else
  1182.           fgets(junk, 19, stdin);
  1183. #endif
  1184. #endif
  1185.       input_blocking = 0;
  1186.       update_coords('\n');
  1187.       lines = 1;
  1188.        }
  1189.        ndprintf(writestream, "%t", buffer);
  1190.        fgets(buffer, 200, fp);
  1191.    }
  1192.    fclose(fp);
  1193.     }
  1194.     return UNBOUND;
  1195. }
  1196.