home *** CD-ROM | disk | FTP | other *** search
/ CICA 1995 May / cica_0595_4.zip / cica_0595_4 / UTIL / MSWSRC35 / WRKSP.CPP < prev    next >
C/C++ Source or Header  |  1993-09-19  |  24KB  |  1,026 lines
  1. /*
  2.  *      wrksp.c         logo workspace management module                dvb
  3.  *
  4.  *    Copyright (C) 1989 The Regents of the University of California
  5.  *    This Software may be copied and distributed for educational,
  6.  *    research, and not for profit purposes provided that this
  7.  *    copyright and statement are included in all such copies.
  8.  *
  9.  */
  10.  
  11. #include "logo.h"
  12. #include "globals.h"
  13. #ifdef ibm
  14. #include "process.h"
  15. #endif
  16.  
  17. char *editor, *editorname;
  18. int to_pending = 0;
  19.  
  20. NODE *make_procnode(NODE *lst, NODE *wrds, short min, short df, short max)
  21. {
  22.     return(cons_list(0, lst, wrds, make_intnode((FIXNUM)min),
  23.              make_intnode((FIXNUM)df), make_intnode((FIXNUM)max),
  24.              END_OF_LIST));
  25. }
  26.  
  27. NODE *get_bodywords(NODE *proc, NODE *name)
  28. {
  29.     NODE *val = bodywords__procnode(proc);
  30.     NODE *head = NIL, *tail = NIL;
  31.  
  32.     if (val != NIL) return(val);
  33.     name = intern(name);
  34.     head = cons_list(0, (is_macro(name) ? Macro : To), name, END_OF_LIST);
  35.     tail = cdr(head);
  36.     val = formals__procnode(proc);
  37.     while (val != NIL) {
  38.     if (is_list(car(val)))
  39.         setcdr(tail, cons(cons(make_colon(caar(val)), cdar(val)), NIL));
  40.     else if (nodetype(car(val)) == INT)
  41.         setcdr(tail, cons(car(val),NIL));
  42.     else
  43.         setcdr(tail, cons(make_colon(car(val)),NIL));
  44.     tail = cdr(tail);
  45.     val = cdr(val);
  46.     }
  47.     head = cons(head, NIL);
  48.     tail = head;
  49.     val = bodylist__procnode(proc);
  50.     while (val != NIL) {
  51.     setcdr(tail, cons(car(val), NIL));
  52.     tail = cdr(tail);
  53.     val = cdr(val);
  54.     }
  55.     setcdr(tail, cons(End, NIL));
  56.     setbodywords__procnode(proc,head);
  57.     return(head);
  58. }
  59.  
  60. NODE *name_arg(NODE *args) {
  61.     while (aggregate(car(args)) && NOT_THROWING)
  62.     setcar(args, err_logo(BAD_DATA, car(args)));
  63.     return car(args);
  64. }
  65.  
  66. NODE *ltext(NODE *args)
  67. {
  68.     NODE *name, *val = UNBOUND;
  69.  
  70.     name = name_arg(args);
  71.     if (NOT_THROWING) {
  72.     val = procnode__caseobj(intern(name));
  73.     if (val == UNDEFINED) {
  74.         err_logo(DK_HOW_UNREC,name);
  75.         return UNBOUND;
  76.     } else if (is_prim(val)) {
  77.         err_logo(IS_PRIM,name);
  78.         return UNBOUND;
  79.     } else 
  80.         return text__procnode(val);
  81.     }
  82.     return UNBOUND;
  83. }
  84.  
  85. NODE *lfulltext(NODE *args)
  86. {
  87.     NODE *name, *val = UNBOUND;
  88.  
  89.     name = name_arg(args);
  90.     if (NOT_THROWING) {
  91.     val = procnode__caseobj(intern(name));
  92.     if (val == UNDEFINED) {
  93.         err_logo(DK_HOW_UNREC,name);
  94.         return UNBOUND;
  95.     } else if (is_prim(val)) {
  96.         err_logo(IS_PRIM,name);
  97.         return UNBOUND;
  98.     } else 
  99.         return get_bodywords(val,name);
  100.     }
  101.     return UNBOUND;
  102. }
  103.  
  104. NODE *define_helper(NODE *args, BOOLEAN macro_flag)
  105. {
  106.     NODE *name, *val, *arg = NIL;
  107.     int minimum = 0, deflt = 0, maximum = 0, old_default = -1;
  108.     int redef = (compare_node(valnode__caseobj(Redefp),Truex,TRUE) == 0);
  109.  
  110.     name = name_arg(args);
  111.     if (NOT_THROWING) {
  112.     name = intern(name);
  113.     val = procnode__caseobj(name);
  114.     if (!redef && is_prim(val)) {
  115.         err_logo(IS_PRIM,name);
  116.         return UNBOUND;
  117.     } else if (val != UNDEFINED) {
  118.         old_default = getint(dfltargs__procnode(val));
  119.     }
  120.     }
  121.     if (NOT_THROWING) {
  122.     val = cadr(args);
  123.     while ((val == NIL || !is_list(val) || !is_list(car(val))) &&
  124.             NOT_THROWING) {
  125.         setcar(cdr(args), err_logo(BAD_DATA, val));
  126.         val = cadr(args);
  127.     }
  128.     }
  129.     if (NOT_THROWING) {
  130.     args = car(val);
  131.     if (args != NIL) {
  132.         make_runparse(args);
  133.         args = parsed__runparse(args);
  134.     }
  135.     setcar(val, args);
  136.     while (args != NIL) {
  137.         arg = car(args);
  138.         if (arg != NIL && is_list(arg) && maximum != -1) {
  139.         make_runparse(arg);
  140.         arg = parsed__runparse(arg);
  141.         setcar(args, arg);
  142.         maximum++;
  143.         if (cdr(arg) == NIL)
  144.             maximum = -1;
  145.         } else if (nodetype(arg) == INT &&
  146.                getint(arg) <= (unsigned) maximum &&
  147.                getint(arg) >= minimum) {
  148.         deflt = getint(arg);
  149.         } else if (maximum == minimum) {
  150.         minimum++;
  151.         maximum++;
  152.         deflt++;
  153.         } else {
  154.         err_logo(BAD_DATA_UNREC, arg);
  155.         break;
  156.         }
  157.         args = cdr(args);
  158.         if (check_throwing) break;
  159.     }
  160.     }
  161.     if (NOT_THROWING) {
  162.     setprocnode__caseobj(name,
  163.                  make_procnode(val, NIL, minimum, deflt, maximum));
  164.     if (macro_flag)
  165.         setflag__caseobj(name, PROC_MACRO);
  166.     else
  167.         clearflag__caseobj(name, PROC_MACRO);
  168.     if (deflt != old_default && old_default >= 0) {
  169.         the_generation = reref(the_generation, cons(NIL, NIL));
  170.     }
  171.     }
  172.     return(UNBOUND);
  173. }
  174.  
  175. NODE *ldefine(NODE *args)
  176. {
  177.     return define_helper(args, FALSE);
  178. }
  179.  
  180. NODE *ldefmacro(NODE *args)
  181. {
  182.     return define_helper(args, TRUE);
  183. }
  184.  
  185. NODE *to_helper(NODE *args, BOOLEAN macro_flag)
  186. {
  187.     NODE *arg = NIL, *tnode = NIL, *proc_name, *formals = NIL, *lastnode = NIL,
  188.      *body_words, *lastnode2, *body_list, *ttnode = NIL;
  189.     int minimum = 0, deflt = 0, maximum = 0, old_default = -1;
  190.     char ttemp[16];
  191.  
  192.     if (ufun != NIL && loadstream == stdin) {
  193.     err_logo(NOT_INSIDE,NIL);
  194.     return(UNBOUND);
  195.     }
  196.  
  197.     if (args == NIL) {
  198.     err_logo(NOT_ENOUGH,NIL);
  199.     return(UNBOUND);
  200.     }
  201.  
  202.     proc_name = car(args);
  203.     args = cdr(args);
  204.  
  205.     if (nodetype(proc_name) != CASEOBJ)
  206.     err_logo(BAD_DATA_UNREC, proc_name);
  207.     else if ((procnode__caseobj(proc_name) != UNDEFINED && loadstream == stdin)
  208.          || is_prim(procnode__caseobj(proc_name)))
  209.     err_logo(ALREADY_DEFINED, proc_name);
  210.     else {
  211.     NODE *old_proc = procnode__caseobj(proc_name);
  212.     if (old_proc != UNDEFINED) {
  213.         old_default = getint(dfltargs__procnode(old_proc));
  214.     }
  215.     while (args != NIL) {
  216.         arg = car(args);
  217.         args = cdr(args);
  218.         if (nodetype(arg) == CONS && maximum != -1) {
  219.         make_runparse(arg);
  220.         arg = parsed__runparse(arg);
  221.         maximum++;
  222.         if (nodetype(car(arg)) != COLON) {
  223.             err_logo(BAD_DATA_UNREC, arg);
  224.             break;
  225.         } else
  226.             setcar(arg, node__colon(car(arg)));
  227.         if (cdr(arg) == NIL)
  228.             maximum = -1;
  229.         } else if (nodetype(arg) == COLON && maximum == minimum) {
  230.         arg = node__colon(arg);
  231.         minimum++;
  232.         maximum++;
  233.         deflt++;
  234.         } else if (nodetype(arg) == INT && 
  235.                getint(arg) <= (unsigned) maximum &&
  236.                getint(arg) >= minimum) {
  237.         deflt = getint(arg);
  238.         } else {
  239.         err_logo(BAD_DATA_UNREC, arg);
  240.         break;
  241.         }
  242.         tnode = cons(arg, NIL);
  243.         if (formals == NIL) formals = tnode;
  244.         else setcdr(lastnode, tnode);
  245.         lastnode = tnode;
  246.     }
  247.     }
  248.  
  249.     if (NOT_THROWING) {
  250.     body_words = cons(current_line, NIL);
  251.     lastnode2 = body_words;
  252.     body_list = cons(formals, NIL);
  253.     lastnode = body_list;
  254.     to_pending++;    /* for int or quit signal */
  255.     while (NOT_THROWING && to_pending && (!feof(loadstream))) {
  256.             strcpy(ttemp,"> ");
  257.             ttnode = reader(loadstream, ttemp);
  258.         tnode = cons(ttnode, NIL);
  259.         setcdr(lastnode2, tnode);
  260.         lastnode2 = tnode;
  261.         tnode = cons(parser(car(tnode), TRUE), NIL);
  262.         if (car(tnode) != NIL && compare_node(caar(tnode), End, TRUE) == 0)
  263.         break;
  264.         else if (car(tnode) != NIL) {
  265.         setcdr(lastnode, tnode);
  266.         lastnode = tnode;
  267.         }
  268.     }
  269.     if (to_pending && NOT_THROWING) {
  270.         setprocnode__caseobj(proc_name,
  271.                  make_procnode(body_list, body_words, minimum,
  272.                            deflt, maximum));
  273.         if (macro_flag)
  274.         setflag__caseobj(proc_name, PROC_MACRO);
  275.         else
  276.         clearflag__caseobj(proc_name, PROC_MACRO);
  277.         if (deflt != old_default && old_default >= 0) {
  278.         the_generation = reref(the_generation,
  279.                cons(NIL, NIL));
  280.         }
  281.         if (loadstream == stdin) {
  282.         ndprintf(stdout, "%s defined\n", proc_name);
  283.         }
  284.     }
  285.     to_pending = 0;
  286.     }
  287.     return(UNBOUND);
  288. }
  289.  
  290. NODE *lto(NODE *args)
  291. {
  292.     NODE *temp_node;
  293.  
  294.     IsDirty = 1;
  295.     input_mode = TO_MODE;
  296.     temp_node = to_helper(args, FALSE);
  297.     input_mode = NO_MODE;
  298.     return (temp_node);
  299. }
  300.  
  301. NODE *lmacro(NODE *args)
  302. {
  303.     return to_helper(args, TRUE);
  304. }
  305.  
  306. NODE *lmake(NODE *args)
  307. {
  308.     NODE *what;
  309.  
  310.     what = name_arg(args);
  311.     if (NOT_THROWING) {
  312.     what = intern(what);
  313.     setvalnode__caseobj(what, cadr(args));
  314.     if (flag__caseobj(what, VAL_TRACED)) {
  315.         NODE *tvar = maybe_quote(cadr(args));
  316.         ndprintf(writestream, "Make %s %s", make_quote(what), tvar);
  317.         if (ufun != NIL) {
  318.         ndprintf(writestream, " in %s\n%s", ufun, this_line);
  319.         }
  320.         new_line(writestream);
  321.     }
  322.     }
  323.     return(UNBOUND);
  324. }
  325.  
  326. NODE *llocal(NODE *args)
  327. {
  328.     NODE *arg = NIL;
  329.     NODE *vsp = var_stack;
  330.  
  331.     if (tailcall == 1) return UNBOUND;
  332.     while (is_list(car(args)) && cdr(args) != NIL && NOT_THROWING)
  333.     setcar(args, err_logo(BAD_DATA, car(args)));
  334.     if (is_list(car(args)))
  335.     args = car(args);
  336.     while (args != NIL && NOT_THROWING) {
  337.     arg = car(args);
  338.     while (!is_word(arg) && NOT_THROWING) {
  339.         arg = err_logo(BAD_DATA, arg);
  340.         setcar(args, arg); /* prevent crash in lapply */
  341.     }
  342.     if (NOT_THROWING) {
  343.         arg = intern(arg);
  344.         setcar(args, arg); /* local [a b] faster next time */
  345.         if (not_local(arg,vsp)) {
  346.         push(arg, var_stack);
  347.         setobject(var_stack, valnode__caseobj(arg));
  348.         }
  349.         setvalnode__caseobj(arg, UNBOUND);
  350.         tell_shadow(arg);
  351.         args = cdr(args);
  352.     }
  353.     if (check_throwing) break;
  354.     }
  355.     var = reref(var, var_stack);    /* so eval won't undo our work */
  356.     return(UNBOUND);
  357. }
  358.  
  359. NODE *cnt_list = NIL;
  360. NODE *cnt_last = NIL;
  361. int want_buried = 0;
  362.  
  363. typedef enum {c_PROCS, c_VARS, c_PLISTS} CNTLSTTYP;
  364. CNTLSTTYP contents_list_type;
  365.  
  366. int bck(int flag)
  367. {
  368.     return (want_buried ? !flag : flag);
  369. }
  370.  
  371. void contents_map(NODE *sym)
  372. {
  373.     switch(contents_list_type) {
  374.     case c_PROCS:
  375.         if (procnode__object(sym) == UNDEFINED ||
  376.             is_prim(procnode__object(sym)))
  377.         return;
  378.         if (bck(flag__object(sym,PROC_BURIED))) return;
  379.         break;
  380.     case c_VARS:
  381.         if (valnode__object(sym) == UNBOUND) return;
  382.         if (bck(flag__object(sym,VAL_BURIED))) return;
  383.         break;
  384.     case c_PLISTS:
  385.         if (plist__object(sym) == NIL) return;
  386.         if (bck(flag__object(sym,PLIST_BURIED))) return;
  387.         break;
  388.     }
  389.     if (cnt_list == NIL) {
  390.     cnt_list = cons(canonical__object(sym), NIL);
  391.     cnt_last = vref(cnt_list);
  392.     } else {
  393.     setcdr(cnt_last, cons(canonical__object(sym), NIL));
  394.     cnt_last = cdr(cnt_last);
  395.     }
  396. }
  397.  
  398. void ms_listlist(NODE *nd)
  399. {
  400.     NODE *temp;
  401.  
  402.     while (nd != NIL) {
  403.     temp = newnode(CONS);
  404.     car(temp) = car(nd);
  405.     car(nd) = temp;
  406.     increfcnt(temp);
  407.     nd = cdr(nd);
  408.     }
  409. }
  410.  
  411. NODE *merge(NODE *a, NODE *b)
  412. {
  413.     NODE *ret, *tail;
  414.  
  415.     if (a == NIL) return(b);
  416.     if (b == NIL) return(a);
  417.     if (compare_node(car(a),car(b),FALSE) < 0) {
  418.     ret = a;
  419.     tail = a;
  420.     a = cdr(a);
  421.     } else {
  422.     ret = b;
  423.     tail = b;
  424.     b = cdr(b);
  425.     }
  426.  
  427.     while (a != NIL && b != NIL) {
  428.     if (compare_node(car(a),car(b),FALSE) < 0) {
  429.         cdr(tail) = a;
  430.         a = cdr(a);
  431.     } else {
  432.         cdr(tail) = b;
  433.         b = cdr(b);
  434.     }
  435.     tail = cdr(tail);
  436.     }
  437.  
  438.     if (b == NIL) cdr(tail) = a;
  439.     else cdr(tail) = b;
  440.  
  441.     return ret;
  442. }
  443.  
  444. void mergepairs(NODE *nd) {
  445.     NODE *temp;
  446.  
  447.     while (nd != NIL && cdr(nd) != NIL) {
  448.     car(nd) = merge(car(nd), cadr(nd));
  449.     temp = cdr(nd);
  450.     cdr(nd) = cddr(nd);
  451.     car(temp) = cdr(temp) = NIL;
  452.     gc(temp);
  453.     nd = cdr(nd);
  454.     }
  455. }
  456.  
  457. NODE *mergesort(NODE *nd)
  458. {
  459.     NODE *ret;
  460.  
  461.     if (nd == NIL) return(NIL);
  462.     if (cdr(nd) == NIL) return(nd);
  463.     ms_listlist(nd);
  464.     while (cdr(nd) != NIL)
  465.     mergepairs(nd);
  466.     ret = car(nd);
  467.     car(nd) = NIL;
  468.     gc(nd);
  469.     return(ret);
  470. }
  471.  
  472. NODE *get_contents()
  473. {
  474.     deref(cnt_list);
  475.     cnt_list = NIL;
  476.     cnt_last = NIL;
  477.     map_oblist(contents_map);
  478.     cnt_list = mergesort(cnt_list);
  479.     return(cnt_list);
  480. }
  481.  
  482. NODE *lcontents()
  483. {
  484.     NODE *ret;
  485.  
  486.     want_buried = 0;
  487.  
  488.     contents_list_type = c_PLISTS;
  489.     ret = cons(get_contents(), NIL);
  490.     ref(ret);
  491.  
  492.     contents_list_type = c_VARS;
  493.     push(get_contents(), ret);
  494.  
  495.     contents_list_type = c_PROCS;
  496.     push(get_contents(), ret);
  497.  
  498.     deref(cnt_list);
  499.     cnt_list = NIL;
  500.     return(unref(ret));
  501. }
  502.  
  503. NODE *lburied()
  504. {
  505.     NODE *ret;
  506.  
  507.     want_buried = 1;
  508.  
  509.     contents_list_type = c_PLISTS;
  510.     ret = cons(get_contents(), NIL);
  511.     ref(ret);
  512.  
  513.     contents_list_type = c_VARS;
  514.     push(get_contents(), ret);
  515.  
  516.     contents_list_type = c_PROCS;
  517.     push(get_contents(), ret);
  518.  
  519.     deref(cnt_list);
  520.     cnt_list = NIL;
  521.     return(unref(ret));
  522. }
  523.  
  524. NODE *lprocedures()
  525. {
  526.     NODE *ret;
  527.  
  528.     want_buried = 0;
  529.  
  530.     contents_list_type = c_PROCS;
  531.     ret = get_contents();
  532.     ref(ret);
  533.     deref(cnt_list);
  534.     cnt_list = NIL;
  535.     return(unref(ret));
  536. }
  537.  
  538. NODE *lnames()
  539. {
  540.     NODE *ret;
  541.  
  542.     want_buried = 0;
  543.  
  544.     contents_list_type = c_VARS;
  545.     ret = cons(NIL, cons(get_contents(), NIL));
  546.     ref(ret);
  547.     deref(cnt_list);
  548.     cnt_list = NIL;
  549.     return(unref(ret));
  550. }
  551.  
  552. NODE *lplists()
  553. {
  554.     NODE *ret;
  555.  
  556.     want_buried = 0;
  557.  
  558.     contents_list_type = c_PLISTS;
  559.     ret = cons(NIL, cons(NIL, cons(get_contents(), NIL)));
  560.     ref(ret);
  561.     deref(cnt_list);
  562.     cnt_list = NIL;
  563.     return(unref(ret));
  564. }
  565.  
  566. NODE *one_list(NODE *nd)
  567. {
  568.     if (!is_list(nd))
  569.     return(cons(nd,NIL));
  570.     return nd;
  571. }
  572.  
  573. void three_lists(NODE *arg, NODE **proclst, NODE **varlst, NODE **plistlst)
  574. {
  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. NODE *po_helper(NODE *arg, int just_titles)    /* >0 for POT, <0 for EDIT */
  596. {
  597.     NODE *proclst = NIL, *varlst = NIL, *plistlst = NIL, *tvar = NIL;
  598.     NODE *plist;
  599.  
  600.     print_backslashes = TRUE;
  601.  
  602.     three_lists(arg, &proclst, &varlst, &plistlst);
  603.  
  604.     while (proclst != NIL) {
  605.     if (aggregate(car(proclst))) {
  606.         err_logo(BAD_DATA_UNREC, car(proclst));
  607.         break;
  608.     } else
  609.         tvar = procnode__caseobj(intern(car(proclst)));
  610.  
  611.     if (tvar == UNDEFINED) {
  612.         if (just_titles < 0) {
  613.         ndprintf(writestream,"to %p\nend\n\n", car(proclst));
  614.         } else {
  615.         err_logo(DK_HOW_UNREC, car(proclst));
  616.         break;
  617.         }
  618.     } else if (nodetype(tvar) == PRIM) {
  619.         err_logo(IS_PRIM, car(proclst));
  620.         break;
  621.     } else {
  622.         tvar = get_bodywords(tvar,car(proclst));
  623.         if (just_titles > 0)
  624.         print_nobrak(writestream, car(tvar));
  625.         else while (tvar != NIL) {
  626.         print_nobrak(writestream, car(tvar));
  627.         new_line(writestream);
  628.         tvar = cdr(tvar);
  629.         }
  630.         new_line(writestream);
  631.     }
  632.     proclst = cdr(proclst);
  633.     if (check_throwing) break;
  634.     }
  635.  
  636.     while (varlst != NIL && NOT_THROWING) {
  637.     if (aggregate(car(varlst))) {
  638.         err_logo(BAD_DATA_UNREC, car(varlst));
  639.         break;
  640.     } else
  641.         tvar = maybe_quote(valnode__caseobj(intern(car(varlst))));
  642.  
  643.     if (tvar == UNBOUND) {
  644.         if (just_titles >= 0) {
  645.         err_logo(NO_VALUE, car(varlst));
  646.         break;
  647.         }
  648.     } else {
  649.         ndprintf(writestream, "Make %s %s\n",
  650.              make_quote(car(varlst)), tvar);
  651.     }
  652.     varlst = cdr(varlst);
  653.     if (check_throwing) break;
  654.     }
  655.  
  656.     while (plistlst != NIL && NOT_THROWING) {
  657.     if (aggregate(car(plistlst))) {
  658.         err_logo(BAD_DATA_UNREC, car(plistlst));
  659.         break;
  660.     } else {
  661.         plist = plist__caseobj(intern(car(plistlst)));
  662.         if (plist != NIL && just_titles > 0) {
  663.         ndprintf(writestream, "Plist %s = %s\n",
  664.              maybe_quote(car(plistlst)), plist);
  665.         } else while (plist != NIL) {
  666.         ndprintf(writestream, "Pprop %s %s %s\n",
  667.              maybe_quote(car(plistlst)),
  668.              maybe_quote(car(plist)),
  669.              maybe_quote(cadr(plist)));
  670.         plist = cddr(plist);
  671.         }
  672.     }
  673.     plistlst = cdr(plistlst);
  674.     if (check_throwing) break;
  675.     }
  676.  
  677.     print_backslashes = FALSE;
  678.     return(UNBOUND);
  679. }
  680.  
  681. NODE *lpo(NODE *arg)
  682. {
  683.     return(po_helper(arg,0));
  684. }
  685.  
  686. NODE *lpot(NODE *arg)
  687. {
  688.     return(po_helper(arg,1));
  689. }
  690.  
  691. NODE *lerase(NODE *arg)
  692. {
  693.     NODE *proclst = NIL, *varlst = NIL, *plistlst = NIL;
  694.     NODE *nd;
  695.     int redef = (compare_node(valnode__caseobj(Redefp),Truex,TRUE) == 0);
  696.  
  697.     three_lists(arg, &proclst, &varlst, &plistlst);
  698.  
  699.     if (proclst != NIL)
  700.     the_generation = reref(the_generation, cons(NIL, NIL));
  701.  
  702.     while (proclst != NIL) {
  703.     if (aggregate(car(proclst))) {
  704.         err_logo(BAD_DATA_UNREC, car(proclst));
  705.         break;
  706.     }
  707.     nd = intern(car(proclst));
  708.     if (!redef && is_prim(procnode__caseobj(nd))) {
  709.         err_logo(IS_PRIM, nd);
  710.         break;
  711.     }
  712.     setprocnode__caseobj(nd, UNDEFINED);
  713.     proclst = cdr(proclst);
  714.     }
  715.  
  716.     while (varlst != NIL && NOT_THROWING) {
  717.     if (aggregate(car(varlst))) {
  718.         err_logo(BAD_DATA_UNREC, car(varlst));
  719.         break;
  720.     }
  721.     setvalnode__caseobj(intern(car(varlst)), UNBOUND);
  722.     varlst = cdr(varlst);
  723.     }
  724.  
  725.     while (plistlst != NIL && NOT_THROWING) {
  726.     if (aggregate(car(plistlst))) {
  727.         err_logo(BAD_DATA_UNREC, car(plistlst));
  728.         break;
  729.     }
  730.     setplist__caseobj(intern(car(plistlst)), NIL);
  731.     plistlst = cdr(plistlst);
  732.     }
  733.     return(UNBOUND);
  734. }
  735.  
  736. NODE *bury_helper(NODE *arg, int flag)
  737. {
  738.     NODE *proclst = NIL, *varlst = NIL, *plistlst = NIL;
  739.  
  740.     three_lists(arg, &proclst, &varlst, &plistlst);
  741.  
  742.     while (proclst != NIL) {
  743.     if (aggregate(car(proclst))) {
  744.         err_logo(BAD_DATA_UNREC, car(proclst));
  745.         break;
  746.     }
  747.     setflag__caseobj(intern(car(proclst)), flag);
  748.     proclst = cdr(proclst);
  749.     if (check_throwing) break;
  750.     }
  751.  
  752.     flag <<= 1;
  753.     while (varlst != NIL && NOT_THROWING) {
  754.     if (aggregate(car(varlst))) {
  755.         err_logo(BAD_DATA_UNREC, car(varlst));
  756.         break;
  757.     }
  758.     setflag__caseobj(intern(car(varlst)), flag);
  759.     varlst = cdr(varlst);
  760.     if (check_throwing) break;
  761.     }
  762.  
  763.     flag <<= 1;
  764.     while (plistlst != NIL && NOT_THROWING) {
  765.     if (aggregate(car(plistlst))) {
  766.         err_logo(BAD_DATA_UNREC, car(plistlst));
  767.         break;
  768.     }
  769.     setflag__caseobj(intern(car(plistlst)), flag);
  770.     plistlst = cdr(plistlst);
  771.     if (check_throwing) break;
  772.     }
  773.     return(UNBOUND);
  774. }
  775.  
  776. NODE *lbury(NODE *arg)
  777. {
  778.     return bury_helper(arg,PROC_BURIED);
  779. }
  780.  
  781. NODE *ltrace(NODE *arg)
  782. {
  783.     return bury_helper(arg,PROC_TRACED);
  784. }
  785.  
  786. NODE *lstep(NODE *arg)
  787. {
  788.     return bury_helper(arg,PROC_STEPPED);
  789. }
  790.  
  791. NODE *unbury_helper(NODE *arg, int flag)
  792. {
  793.     NODE *proclst = NIL, *varlst = NIL, *plistlst = NIL;
  794.  
  795.     three_lists(arg, &proclst, &varlst, &plistlst);
  796.  
  797.     while (proclst != NIL) {
  798.     if (aggregate(car(proclst))) {
  799.         err_logo(BAD_DATA_UNREC, car(proclst));
  800.         break;
  801.     }
  802.     clearflag__caseobj(intern(car(proclst)), flag);
  803.     proclst = cdr(proclst);
  804.     if (check_throwing) break;
  805.     }
  806.  
  807.     flag <<= 1;
  808.     while (varlst != NIL && NOT_THROWING) {
  809.     if (aggregate(car(varlst))) {
  810.         err_logo(BAD_DATA_UNREC, car(varlst));
  811.         break;
  812.     }
  813.     clearflag__caseobj(intern(car(varlst)), flag);
  814.     varlst = cdr(varlst);
  815.     if (check_throwing) break;
  816.     }
  817.  
  818.     flag <<= 1;
  819.     while (plistlst != NIL && NOT_THROWING) {
  820.     if (aggregate(car(plistlst))) {
  821.         err_logo(BAD_DATA_UNREC, car(plistlst));
  822.         break;
  823.     }
  824.     clearflag__caseobj(intern(car(plistlst)), flag);
  825.     plistlst = cdr(plistlst);
  826.     if (check_throwing) break;
  827.     }
  828.     return(UNBOUND);
  829. }
  830.  
  831. NODE *lunbury(NODE *arg)
  832. {
  833.     return unbury_helper(arg,PROC_BURIED);
  834. }
  835.  
  836. NODE *luntrace(NODE *arg)
  837. {
  838.     return unbury_helper(arg,PROC_TRACED);
  839. }
  840.  
  841. NODE *lunstep(NODE *arg)
  842. {
  843.     return unbury_helper(arg,PROC_STEPPED);
  844. }
  845.  
  846. NODE *ledit(NODE *args)
  847. {
  848.     FILE *holdstrm;
  849.     NODE *args_list = NIL;
  850.     int save_yield_flag;
  851.  
  852.     save_yield_flag = yield_flag;
  853.     yield_flag = 0;
  854.     lsetcursorwait();
  855.  
  856.     if (args != NIL) {
  857.     holdstrm = writestream;
  858.     writestream = fopen(TempPathName, "w");
  859.     if (writestream != NULL) {
  860.         po_helper(args,-1);
  861.         fclose(writestream);
  862.         writestream = holdstrm;
  863.     } else {
  864.         err_logo(FILE_ERROR,
  865.           make_static_strnode("Could not create editor file"));
  866.         writestream = holdstrm;
  867.         return(UNBOUND);
  868.     }
  869.     }
  870.  
  871.     if (in_graphics_mode) text_screen;
  872.     args_list = reref(args_list, args);
  873.     if (TMyWindow_MyPopupEdit(TempPathName,args_list))
  874.       {
  875.       err_logo(FILE_ERROR, make_static_strnode("Could not launch the editor"));
  876.       }
  877.     else
  878.       {
  879.       unlink(TempPathName);
  880.       IsDirty = 1;
  881.       }
  882.  
  883.     lsetcursorarrow();
  884.     yield_flag = save_yield_flag;
  885.  
  886.     return(UNBOUND);
  887. }
  888.  
  889. int lendedit(void)
  890. {
  891.     FILE *holdstrm;
  892.  
  893.     NODE *tmp_line = NIL;
  894.     NODE *exec_list = NIL;
  895.  
  896.     int sv_val_status = val_status;
  897.     int realsave = 0;
  898.     int save_yield_flag;
  899.  
  900.     holdstrm = loadstream;
  901.     tmp_line = reref(tmp_line, current_line);
  902.     save_yield_flag = yield_flag;
  903.     yield_flag = 0;
  904.     lsetcursorwait();
  905.  
  906.     loadstream = fopen(TempPathName, "r");
  907.     if (loadstream != NULL) {
  908.         realsave = 1;
  909.     while (!feof(loadstream) && NOT_THROWING) {
  910.         current_line = reref(current_line, reader(loadstream, ""));
  911.         exec_list = parser(current_line, TRUE);
  912.         val_status = 0;
  913.         if (exec_list != NIL) eval_driver(exec_list);
  914.     }
  915.     fclose(loadstream);
  916.     val_status = sv_val_status;
  917.     }
  918.     else
  919.     {
  920. //    err_logo(FILE_ERROR,
  921. //          make_static_strnode("Could not read editor file"));
  922.     }
  923.  
  924.     lsetcursorarrow();
  925.     yield_flag = save_yield_flag;
  926.     loadstream = holdstrm;
  927.     current_line = reref(current_line, tmp_line);
  928.  
  929.     return(realsave);
  930. }
  931.  
  932. NODE *lthing(NODE *args)
  933. {
  934.     NODE *val = UNBOUND, *arg;
  935.  
  936.     arg = name_arg(args);
  937.     if (NOT_THROWING) val = valnode__caseobj(intern(arg));
  938.     while (val == UNBOUND && NOT_THROWING)
  939.     val = err_logo(NO_VALUE, car(args));
  940.     return(val);
  941. }
  942.  
  943. NODE *lnamep(NODE *args)
  944. {
  945.     NODE *arg;
  946.  
  947.     arg = name_arg(args);
  948.     if (NOT_THROWING) 
  949.     return torf(valnode__caseobj(intern(arg)) != UNBOUND);
  950.     return UNBOUND;
  951. }
  952.  
  953. NODE *lprocedurep(NODE *args)
  954. {
  955.     NODE *arg;
  956.  
  957.     arg = name_arg(args);
  958.     if (NOT_THROWING) 
  959.     return torf(procnode__caseobj(intern(arg)) != UNDEFINED);
  960.     return UNBOUND;
  961. }
  962.  
  963. NODE *check_proctype(NODE *args, int wanted)
  964. {
  965.     NODE *arg,*cell;
  966.     int isprim;
  967.  
  968.     arg = name_arg(args);
  969.     if (NOT_THROWING && (cell = procnode__caseobj(intern(arg))) == UNDEFINED) {
  970.     return(Falsex);
  971.     }
  972.     if (wanted == 2) return torf(is_macro(intern(arg)));
  973.     isprim = is_prim(cell);
  974.     if (NOT_THROWING) return torf((isprim != 0) == wanted);
  975.     return(UNBOUND);
  976. }
  977.  
  978. NODE *lprimitivep(NODE *args)
  979. {
  980.     return(check_proctype(args,1));
  981. }
  982.  
  983. NODE *ldefinedp(NODE *args)
  984. {
  985.     return(check_proctype(args,0));
  986. }
  987.  
  988. NODE *lmacrop(NODE *args)
  989. {
  990.     return(check_proctype(args,2));
  991. }
  992.  
  993. NODE *lcopydef(NODE *args)
  994. {
  995.     NODE *arg1, *arg2;
  996.     int redef = (compare_node(valnode__caseobj(Redefp),Truex,TRUE) == 0);
  997.  
  998.     arg1 = name_arg(args);
  999.     arg2 = name_arg(cdr(args));
  1000.     if (numberp(arg2)) err_logo(BAD_DATA_UNREC, arg2);
  1001.     if (numberp(arg1)) err_logo(BAD_DATA_UNREC, arg1);
  1002.     if (NOT_THROWING) {
  1003.     arg1 = intern(arg1);
  1004.     arg2 = intern(arg2);
  1005.     }
  1006.     if (NOT_THROWING && procnode__caseobj(arg2) == UNDEFINED)
  1007.     err_logo(DK_HOW, arg2);
  1008.     if (NOT_THROWING && !redef && is_prim(procnode__caseobj(arg1)))
  1009.     err_logo(IS_PRIM, arg1);
  1010.     if (NOT_THROWING) {
  1011.     NODE *old_proc = procnode__caseobj(arg1);
  1012.     NODE *new_proc = procnode__caseobj(arg2);
  1013.     if (old_proc != UNDEFINED) {
  1014.         if (getint(dfltargs__procnode(old_proc)) !=
  1015.             getint(dfltargs__procnode(new_proc))) {
  1016.         the_generation = reref(the_generation, cons(NIL, NIL));
  1017.         }
  1018.     }
  1019.     setprocnode__caseobj(arg1, new_proc);
  1020.     setflag__caseobj(arg1, PROC_BURIED);
  1021.     if (is_macro(arg2)) setflag__caseobj(arg1, PROC_MACRO);
  1022.     else clearflag__caseobj(arg1, PROC_MACRO);
  1023.     }
  1024.     return(UNBOUND);
  1025. }
  1026.