Logo Search packages:      
Sourcecode: ucblogo version File versions

wrksp.c

/*
 *      wrksp.c         logo workspace management module                dvb
 *
 *    Copyright (C) 1993 by the Regents of the University of California
 *
 *      This program is free software; you can redistribute it and/or modify
 *      it under the terms of the GNU General Public License as published by
 *      the Free Software Foundation; either version 2 of the License, or
 *      (at your option) any later version.
 *  
 *      This program is distributed in the hope that it will be useful,
 *      but WITHOUT ANY WARRANTY; without even the implied warranty of
 *      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *      GNU General Public License for more details.
 *  
 *      You should have received a copy of the GNU General Public License
 *      along with this program; if not, write to the Free Software
 *      Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 *
 */

#ifdef WIN32
#include <windows.h>
#endif

#define WANT_EVAL_REGS 1
#include "logo.h"
#include "globals.h"

#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif

#ifdef ibm
#include "process.h"
#endif

#ifdef HAVE_TERMIO_H
#include <termio.h>
#else
#ifdef HAVE_SGTTY_H
#include <sgtty.h>
#endif
#endif

char *editor, *editorname, *tempdir;
int to_pending = 0;

NODE *make_procnode(NODE *lst, NODE *wrds, int min, int df, int max) {
    return(cons_list(0, lst, wrds, make_intnode((FIXNUM)min),
                 make_intnode((FIXNUM)df), make_intnode((FIXNUM)max),
                 END_OF_LIST));
}

NODE *get_bodywords(NODE *pproc, NODE *name) {
    NODE *val = bodywords__procnode(pproc);
    NODE *head = NIL, *tail = NIL;

    if (val != NIL) return(val);
    name = intern(name);
    head = cons_list(0, (is_macro(name) ? theName(Name_macro) : theName(Name_to)),
                  name, END_OF_LIST);
    tail = cdr(head);
    val = formals__procnode(pproc);
    while (val != NIL) {
      if (is_list(car(val)))
          setcdr(tail, cons(cons(make_colon(caar(val)), cdar(val)), NIL));
      else if (nodetype(car(val)) == INT)
          setcdr(tail, cons(car(val),NIL));
      else
          setcdr(tail, cons(make_colon(car(val)),NIL));
      tail = cdr(tail);
      val = cdr(val);
    }
    head = cons(head, NIL);
    tail = head;
    val = bodylist__procnode(pproc);
    while (val != NIL) {
      setcdr(tail, cons(runparse(car(val)), NIL));
      tail = cdr(tail);
      val = cdr(val);
    }
    setcdr(tail, cons(cons(theName(Name_end), NIL), NIL));
/*  setbodywords__procnode(pproc,head);    */   /* confuses copydef */
    return(head);
}

NODE *name_arg(NODE *args) {
    while (aggregate(car(args)) && NOT_THROWING)
      setcar(args, err_logo(BAD_DATA, car(args)));
    return car(args);
}

NODE *proc_name_arg(NODE *args) {
    while ((aggregate(car(args)) || numberp(car(args))) && NOT_THROWING)
      setcar(args, err_logo(BAD_DATA, car(args)));
    return car(args);
}

NODE *ltext(NODE *args) {
    NODE *name, *val = UNBOUND;

    name = proc_name_arg(args);
    if (NOT_THROWING) {
      val = procnode__caseobj(intern(name));
      if (val == UNDEFINED) {
          err_logo(DK_HOW_UNREC,name);
          return UNBOUND;
      } else if (is_prim(val)) {
          err_logo(IS_PRIM,name);
          return UNBOUND;
      } else 
          return text__procnode(val);
    }
    return UNBOUND;
}

NODE *lfulltext(NODE *args) {
    NODE *name, *val = UNBOUND;

    name = proc_name_arg(args);
    if (NOT_THROWING) {
      val = procnode__caseobj(intern(name));
      if (val == UNDEFINED) {
          err_logo(DK_HOW_UNREC,name);
          return UNBOUND;
      } else if (is_prim(val)) {
          err_logo(IS_PRIM,name);
          return UNBOUND;
      } else 
          return get_bodywords(val,name);
    }
    return UNBOUND;
}

BOOLEAN all_lists(NODE *val) {
    if (val == NIL) return TRUE;
    if (!is_list(car(val))) return FALSE;
    return all_lists(cdr(val));
}

NODE *define_helper(NODE *args, BOOLEAN macro_flag) {
    /* macro_flag is -1 for anonymous function */
    NODE *name = NIL, *val = NIL, *arg = NIL;
    int minimum = 0, deflt = 0, maximum = 0, old_default = -1;
    int redef = (varTrue(Redefp));

    if (macro_flag >= 0) {
      name = proc_name_arg(args);
      if (NOT_THROWING) {
          name = intern(name);
          val = procnode__caseobj(name);
          if (!redef && is_prim(val)) {
            err_logo(IS_PRIM,name);
            return UNBOUND;
          } else if (val != UNDEFINED) {
            old_default = (is_prim(val) ? getprimdflt(val) :
                                    getint(dfltargs__procnode(val)));
          }
      }
      if (NOT_THROWING) {
          val = cadr(args);
          while ((val == NIL || !is_list(val) || !all_lists(val)) &&
                      NOT_THROWING) {
            setcar(cdr(args), err_logo(BAD_DATA, val));
            val = cadr(args);
          }
      }
    } else {      /* lambda */
      val = args;
    }
    if (NOT_THROWING) {
      args = car(val);
      if (args != NIL) {
          make_runparse(args);
          args = parsed__runparse(args);
      }
      setcar(val, args);
      while (args != NIL) {
          arg = car(args);
          if (arg != NIL && is_list(arg) && maximum != -1) {
            make_runparse(arg);
            arg = parsed__runparse(arg);
            setcar(args, arg);
            setcar(arg, intern(car(arg)));      /* fixes crash for # as arg */
            maximum++;
            if (arg == NIL || !is_word(car(arg))) {
                err_logo(BAD_DATA_UNREC, arg);
                break;
            }
            if (cdr(arg) == NIL)
                maximum = -1;
          } else if (nodetype(arg) == INT) {
            if ((unsigned)getint(arg) <= (unsigned) maximum &&
                 getint(arg) >= minimum) {
                  deflt = getint(arg);
            } else {
                err_logo(BAD_DATA_UNREC, arg);
                break;
            }
          } else if (is_word(arg) && maximum == minimum) {
            minimum++;
            maximum++;
            deflt++;
          } else {
            err_logo(BAD_DATA_UNREC, arg);
            break;
          }
          args = cdr(args);
          if (check_throwing) break;
      }
    }
    if (macro_flag < 0) {
      return make_procnode(val, NIL, minimum, deflt, maximum);
    } else if (NOT_THROWING) {
      setprocnode__caseobj(name,
                       make_procnode(val, NIL, minimum, deflt, maximum));
      if (macro_flag)
          setflag__caseobj(name, PROC_MACRO);
      else
          clearflag__caseobj(name, PROC_MACRO);
      if (deflt != old_default && old_default >= 0) {
          the_generation = cons(NIL, NIL);
      }
    }
    return(UNBOUND);
}

NODE *ldefine(NODE *args) {
    return define_helper(args, FALSE);
}

NODE *ldefmacro(NODE *args) {
    return define_helper(args, TRUE);
}

NODE *anonymous_function(NODE *text) {
    return define_helper(text, -1);
}

NODE *to_helper(NODE *args, BOOLEAN macro_flag) {
    NODE *arg = NIL, *tnode = NIL, *proc_name, *forms = NIL, *lastnode = NIL,
       *body_words, *lastnode2, *body_list;
    int minimum = 0, deflt = 0, maximum = 0, old_default = -1;

    if (ufun != NIL && loadstream == stdin) {
      err_logo(NOT_INSIDE,NIL);
      return(UNBOUND);
    }

    if (args == NIL) {
      err_logo(NOT_ENOUGH,NIL);
      return(UNBOUND);
    }

    deepend_proc_name = proc_name = car(args);
    args = cdr(args);

    if (nodetype(proc_name) != CASEOBJ)
      err_logo(BAD_DATA_UNREC, proc_name);
    else if ((procnode__caseobj(proc_name) != UNDEFINED && loadstream == stdin)
           || is_prim(procnode__caseobj(proc_name)))
      err_logo(ALREADY_DEFINED, proc_name);
    else {
      NODE *old_proc = procnode__caseobj(proc_name);
      if (old_proc != UNDEFINED) {
          old_default = (is_prim(old_proc) ? getprimdflt(old_proc) :
                                    getint(dfltargs__procnode(old_proc)));
      }
      while (args != NIL) {
          arg = car(args);
          args = cdr(args);
          if (nodetype(arg) == CONS && maximum != -1) {
            make_runparse(arg);
            arg = parsed__runparse(arg);
            maximum++;
            if (arg == NIL || !is_word(car(arg))) {
                err_logo(BAD_DATA_UNREC, arg);
                break;
            }
            if (nodetype(car(arg)) == COLON)
                setcar(arg, node__colon(car(arg)));
            if (nodetype(car(arg)) == QUOTE)
                setcar(arg, node__quote(car(arg)));
            if (cdr(arg) == NIL)
                maximum = -1;
          } else if (nodetype(arg) == INT) {
            if ((unsigned)getint(arg) <= (unsigned) maximum &&
                 getint(arg) >= minimum) {
                  deflt = getint(arg);
            } else {
                err_logo(BAD_DATA_UNREC, arg);
                break;
            }
          } else if (is_word(arg) && maximum == minimum) {
            if (nodetype(arg) == COLON)
                arg = node__colon(arg);
            if (nodetype(arg) == QUOTE)
                arg = node__quote(arg);
            minimum++;
            maximum++;
            deflt++;
          } else {
            err_logo(BAD_DATA_UNREC, arg);
            break;
          }
          tnode = cons(arg, NIL);
          if (forms == NIL) forms = tnode;
          else setcdr(lastnode, tnode);
          lastnode = tnode;
      }
    }

    if (NOT_THROWING) {
      body_words = cons(current_line, NIL);
      lastnode2 = body_words;
      body_list = cons(forms, NIL);
      lastnode = body_list;
      to_pending++;    /* for int or quit signal */
      while (NOT_THROWING && to_pending && (!feof(loadstream))) {
          tnode = cons(reader(loadstream, "> "), NIL);
          if ((feof(loadstream))) {
            tnode = cons(theName(Name_end), NIL);
          }
          setcdr(lastnode2, tnode);
          lastnode2 = tnode;
          tnode = cons(parser(car(tnode), TRUE), NIL);
          if (car(tnode) != NIL && isName(caar(tnode), Name_end))
            break;
          else if (car(tnode) != NIL) {
            setcdr(lastnode, tnode);
            lastnode = tnode;
          }
      }
      if (to_pending && NOT_THROWING) {
          setprocnode__caseobj(proc_name,
                         make_procnode(body_list, body_words, minimum,
                                     deflt, maximum));
          if (macro_flag)
            setflag__caseobj(proc_name, PROC_MACRO);
          else
            clearflag__caseobj(proc_name, PROC_MACRO);
          if (deflt != old_default && old_default >= 0) {
            the_generation = cons(NIL, NIL);
          }
          if (loadstream == stdin || varTrue(LoadNoisily)) {
            ndprintf(stdout, message_texts[LOAD_DEF], proc_name);
          }
          if (loadstream != stdin && varTrue(UnburyOnEdit)) {
            clearflag__caseobj(proc_name, PROC_BURIED);
          }
      }
      to_pending = 0;
    }
    deepend_proc_name = NIL;
    return(UNBOUND);
}

NODE *lto(NODE *args) {
    return to_helper(args, FALSE);
}

NODE *lmacro(NODE *args) {
    return to_helper(args, TRUE);
}

NODE *lmake(NODE *args) {
    NODE *what;

    what = name_arg(args);
    if (NOT_THROWING) {
      what = intern(what);
      setvalnode__caseobj(what, cadr(args));
      if (!flag__caseobj(what, IS_LOCAL_VALUE))
          setflag__caseobj(what, HAS_GLOBAL_VALUE);
      if (flag__caseobj(what, VAL_TRACED)) {
          NODE *tvar = maybe_quote(cadr(args));
          ndprintf(writestream, message_texts[TRACE_MAKE],
                          make_quote(what), tvar);
          if (ufun != NIL) {
            ndprintf(writestream,message_texts[ERROR_IN],ufun,this_line);
          }
          new_line(writestream);
      }
    }
    return(UNBOUND);
}

NODE *llocal(NODE *args) {
    NODE *arg = NIL;

    if (tailcall != 0) return UNBOUND;
    if (args==NIL) return UNBOUND;
    while (is_list(car(args)) && cdr(args) != NIL && NOT_THROWING)
      setcar(args, err_logo(BAD_DATA, car(args)));
    if (is_list(car(args)))
      args = car(args);
    while (args != NIL && NOT_THROWING) {
      arg = car(args);
      while (!is_word(arg) && NOT_THROWING) {
          arg = err_logo(BAD_DATA, arg);
          setcar(args, arg); /* prevent crash in lapply */
      }
      if (NOT_THROWING) {
          arg = intern(arg);
          setcar(args, arg); /* local [a b] faster next time */
          if (not_local(arg,var_stack)) {
            push(arg, var_stack);
            if (flag__caseobj(arg, IS_LOCAL_VALUE))
                settype(var_stack, LOCALSAVE);
            setobject(var_stack, valnode__caseobj(arg));
            setflag__caseobj(arg, IS_LOCAL_VALUE);
          }
          setvalnode__caseobj(arg, UNBOUND);
          tell_shadow(arg);
          args = cdr(args);
      }
      if (check_throwing) break;
    }
    return(UNBOUND);
}

NODE *lglobal(NODE *args) {
    NODE *arg = NIL;

    if (args==NIL) return UNBOUND;
    while (is_list(car(args)) && cdr(args) != NIL && NOT_THROWING)
      setcar(args, err_logo(BAD_DATA, car(args)));
    if (is_list(car(args)))
      args = car(args);
    while (args != NIL && NOT_THROWING) {
      arg = car(args);
      while (!is_word(arg) && NOT_THROWING) {
          arg = err_logo(BAD_DATA, arg);
          setcar(args, arg); /* prevent crash in lapply */
      }
      if (NOT_THROWING) {
          arg = intern(arg);
          setcar(args, arg); /* local [a b] faster next time */
          setflag__caseobj(arg, HAS_GLOBAL_VALUE);
          args = cdr(args);
      }
      if (check_throwing) break;
    }
    return(UNBOUND);
}

NODE *cnt_list = NIL;
NODE *cnt_last = NIL;
int want_buried = 0;

typedef enum {c_PROCS, c_VARS, c_PLISTS} CNTLSTTYP;
CNTLSTTYP contents_list_type;

int bck(int flag) {
    return (want_buried ? !flag : flag);
}

void contents_map(NODE *sym) {
    int flag_check = PROC_BURIED;

    if (want_buried) flag_check = want_buried;
    switch(contents_list_type) {
      case c_PROCS:
          if (procnode__object(sym) == UNDEFINED ||
                  is_prim(procnode__object(sym)))
            return;
          if (bck(flag__object(sym,flag_check))) return;
          break;
      case c_VARS:
          flag_check <<= 1;
          if (valnode__object(sym) == UNBOUND) return;
          if (bck(flag__object(sym,flag_check))) return;
          break;
      case c_PLISTS:
          flag_check <<= 2;
          if (plist__object(sym) == NIL) return;
          if (bck(flag__object(sym,flag_check))) return;
          break;
    }
    if (cnt_list == NIL) {
      cnt_list = cons(canonical__object(sym), NIL);
      cnt_last = cnt_list;
    } else {
      setcdr(cnt_last, cons(canonical__object(sym), NIL));
      cnt_last = cdr(cnt_last);
    }
}

void ms_listlist(NODE *nd) {
    while (nd != NIL) {
      setcar(nd, cons(car(nd), NIL));
      nd = cdr(nd);
    }
}

NODE *merge(NODE *a, NODE *b) {
    NODE *ret, *tail;

    if (a == NIL) return(b);
    if (b == NIL) return(a);
    if (compare_node(car(a),car(b),FALSE) < 0) {
      ret = a;
      tail = a;
      a = cdr(a);
    } else {
      ret = b;
      tail = b;
      b = cdr(b);
    }

    while (a != NIL && b != NIL) {
      if (compare_node(car(a),car(b),FALSE) < 0) {
          setcdr(tail, a);
          a = cdr(a);
      } else {
          setcdr(tail, b);
          b = cdr(b);
      }
      tail = cdr(tail);
    }

    if (b == NIL) setcdr(tail, a);
    else setcdr(tail, b);

    return ret;
}

void mergepairs(NODE *nd) {
    while (nd != NIL && cdr(nd) != NIL) {
      setcar(nd, merge(car(nd), cadr(nd)));
      setcdr(nd, cddr(nd));
      nd = cdr(nd);
    }
}

NODE *mergesrt(NODE *nd) {    /* spelled funny to avoid library conflict */
    if (nd == NIL) return(NIL);
    if (cdr(nd) == NIL) return(nd);
    ms_listlist(nd);
    while (cdr(nd) != NIL)
      mergepairs(nd);
    return car(nd);
}

NODE *get_contents() {
    cnt_list = NIL;
    cnt_last = NIL;
    map_oblist(contents_map);
    cnt_list = mergesrt(cnt_list);
    return(cnt_list);
}

NODE *lcontents(NODE *args) {
    NODE *ret;

    want_buried = 0;

    contents_list_type = c_PLISTS;
    ret = cons(get_contents(), NIL);

    contents_list_type = c_VARS;
    push(get_contents(), ret);

    contents_list_type = c_PROCS;
    push(get_contents(), ret);

    cnt_list = NIL;
    return(ret);
}

NODE *lburied(NODE *args) {
    NODE *ret;

    want_buried = PROC_BURIED;

    contents_list_type = c_PLISTS;
    ret = cons(get_contents(), NIL);

    contents_list_type = c_VARS;
    push(get_contents(), ret);

    contents_list_type = c_PROCS;
    push(get_contents(), ret);

    cnt_list = NIL;
    return(ret);
}

NODE *ltraced(NODE *args) {
    NODE *ret;

    want_buried = PROC_TRACED;

    contents_list_type = c_PLISTS;
    ret = cons(get_contents(), NIL);

    contents_list_type = c_VARS;
    push(get_contents(), ret);

    contents_list_type = c_PROCS;
    push(get_contents(), ret);

    cnt_list = NIL;
    return(ret);
}

NODE *lstepped(NODE *args) {
    NODE *ret;

    want_buried = PROC_STEPPED;

    contents_list_type = c_PLISTS;
    ret = cons(get_contents(), NIL);

    contents_list_type = c_VARS;
    push(get_contents(), ret);

    contents_list_type = c_PROCS;
    push(get_contents(), ret);

    cnt_list = NIL;
    return(ret);
}

NODE *lprocedures(NODE *args) {
    NODE *ret;

    want_buried = 0;

    contents_list_type = c_PROCS;
    ret = get_contents();
    cnt_list = NIL;
    return(ret);
}

NODE *lnames(NODE *args) {
    NODE *ret;

    want_buried = 0;

    contents_list_type = c_VARS;
    ret = cons(NIL, cons(get_contents(), NIL));
    cnt_list = NIL;
    return(ret);
}

NODE *lplists(NODE *args) {
    NODE *ret;

    want_buried = 0;

    contents_list_type = c_PLISTS;
    ret = cons(NIL, cons(NIL, cons(get_contents(), NIL)));
    cnt_list = NIL;
    return(ret);
}

NODE *one_list(NODE *nd) {
    if (!is_list(nd))
      return(cons(nd,NIL));
    return nd;
}

void three_lists(NODE *arg, NODE **proclst, NODE **varlst, NODE **plistlst) {
    if (nodetype(car(arg)) == CONS)
      arg = car(arg);

    if (!is_list(car(arg)))
      *proclst = arg;
    else {
      *proclst = car(arg);
      if (cdr(arg) != NIL) {
          *varlst = one_list(cadr(arg));
          if (cddr(arg) != NIL) {
            *plistlst = one_list(car(cddr(arg)));
          }
      }
    }
    if (!is_list(*proclst) || !is_list(*varlst) || !is_list(*plistlst)) {
      err_logo(BAD_DATA_UNREC,arg);
      *plistlst = *varlst = *proclst = NIL;
    }
}

char *expand_slash(NODE *wd) {
      char *result, *cp, *cp2;
      int i, len = getstrlen(wd), j;

      for (cp = getstrptr(wd), i=0, j = len; --j >= 0; )
            if (getparity(*cp++)) i++;
      result = malloc(len+i+1);
      if (result == NULL) {
          err_logo(OUT_OF_MEM, NIL);
          return 0;
      }
      for (cp = getstrptr(wd), cp2 = result, j = len; --j >= 0; ) {
            if (getparity(*cp)) *cp2++ = '\\';
            *cp2++ = clearparity(*cp++);
      }
      *cp2 = '\0';
      return result;
}

NODE *po_helper(NODE *arg, int just_titles) {
    /* just_titles is -1 for EDIT, 0 for PO, 1 for HELP, 3 for POT */
    NODE *proclst = NIL, *varlst = NIL, *plistlst = NIL, *tvar = NIL;
    NODE *plist, *oldfullp;

      oldfullp = valnode__caseobj(Fullprintp);
    setvalnode__caseobj(Fullprintp, theName(Name_true));

    three_lists(arg, &proclst, &varlst, &plistlst);

    while (proclst != NIL) {
      if (aggregate(car(proclst))) {
          err_logo(BAD_DATA_UNREC, car(proclst));
          break;
      } else
          tvar = procnode__caseobj(intern(car(proclst)));

      if (tvar == UNDEFINED) {
          if (just_titles < 0) {
            ndprintf(writestream,message_texts[EMPTY_PROC],car(proclst));
          } else {
            err_logo(DK_HOW_UNREC, car(proclst));
            break;
          }
      } else if (nodetype(tvar) & NT_PRIM) {
          err_logo(IS_PRIM, car(proclst));
          break;
      } else {
          tvar = get_bodywords(tvar,car(proclst));
          if (just_titles > 2) {
            if (is_list(car(tvar)))
                  print_nobrak(writestream, car(tvar));
            else {
                  char *str = expand_slash(car(tvar));
                  ndprintf(writestream, "%t", str);
                  free(str);
            }
          } else while (tvar != NIL) {
                  if (is_list(car(tvar))) {
                        if (just_titles == 2) break;
                        print_nobrak(writestream, car(tvar));
                  } else {
                        char *str = expand_slash(car(tvar));
                        if (just_titles == 2 && *str != ';') break;
                        ndprintf(writestream, "%t", str);
                        free(str);
                  }
                  new_line(writestream);
                  tvar = cdr(tvar);
                  if (just_titles == 1) just_titles++;
          }
          new_line(writestream);
      }
      proclst = cdr(proclst);
      if (check_throwing) break;
    }

    while (varlst != NIL && NOT_THROWING) {
      if (aggregate(car(varlst))) {
          err_logo(BAD_DATA_UNREC, car(varlst));
          break;
      } else
          tvar = maybe_quote(valnode__caseobj(intern(car(varlst))));

      if (tvar == UNBOUND) {
          if (just_titles >= 0) {
            err_logo(NO_VALUE, car(varlst));
            break;
          }
      } else {
          ndprintf(writestream, message_texts[TRACE_MAKE],
                 make_quote(car(varlst)), tvar);
          new_line(writestream);
      }
      varlst = cdr(varlst);
      if (check_throwing) break;
    }

    while (plistlst != NIL && NOT_THROWING) {
      if (aggregate(car(plistlst))) {
          err_logo(BAD_DATA_UNREC, car(plistlst));
          break;
      } else {
          plist = plist__caseobj(intern(car(plistlst)));
          if (plist != NIL && just_titles > 0) {
            ndprintf(writestream, message_texts[POT_PLIST],
                   maybe_quote(car(plistlst)), plist);
          } else while (plist != NIL) {
            ndprintf(writestream, "%t %s %s %s\n",
                   message_texts[TRACE_PPROP],
                   maybe_quote(car(plistlst)),
                   maybe_quote(car(plist)),
                   maybe_quote(cadr(plist)));
            plist = cddr(plist);
          }
      }
      plistlst = cdr(plistlst);
      if (check_throwing) break;
    }

    setvalnode__caseobj(Fullprintp, oldfullp);
    return(UNBOUND);
}

NODE *lpo(NODE *arg) {
    return(po_helper(arg,0));
}

NODE *lpot(NODE *arg) {
    return(po_helper(arg,3));
}

NODE *lerase(NODE *arg) {
    NODE *proclst = NIL, *varlst = NIL, *plistlst = NIL;
    NODE *nd, *what;
    int redef = (varTrue(Redefp));

    three_lists(arg, &proclst, &varlst, &plistlst);

    if (proclst != NIL)
      the_generation = cons(NIL, NIL);

    while (proclst != NIL) {
      if (aggregate(car(proclst))) {
          err_logo(BAD_DATA_UNREC, car(proclst));
          break;
      }
      nd = intern(car(proclst));
      if (!redef && is_prim(procnode__caseobj(nd))) {
          err_logo(IS_PRIM, nd);
          break;
      }
      setprocnode__caseobj(nd, UNDEFINED);
      proclst = cdr(proclst);
    }

    while (varlst != NIL && NOT_THROWING) {
      if (aggregate(car(varlst))) {
          err_logo(BAD_DATA_UNREC, car(varlst));
          break;
      }
      what = intern(car(varlst));
      setvalnode__caseobj(what, UNBOUND);
      if (!flag__caseobj(what, IS_LOCAL_VALUE))
          clearflag__caseobj(what, HAS_GLOBAL_VALUE);
      varlst = cdr(varlst);
    }

    while (plistlst != NIL && NOT_THROWING) {
      if (aggregate(car(plistlst))) {
          err_logo(BAD_DATA_UNREC, car(plistlst));
          break;
      }
      setplist__caseobj(intern(car(plistlst)), NIL);
      plistlst = cdr(plistlst);
    }
    return(UNBOUND);
}

NODE *erall_helper(BOOLEAN procs, BOOLEAN vals, BOOLEAN plists) {
    NODE *nd, *obj;
    int loop;
    int redef = (varTrue(Redefp));

    for (loop = 0; loop < HASH_LEN ; loop++) {
      for (nd = hash_table[loop]; nd != NIL; nd = cdr(nd)) {
          obj = car(nd);
          if (procs && !flag__object(obj, PROC_BURIED) &&
                  (procnode__object(obj) != UNDEFINED) &&
                  (redef || !is_prim(procnode__object(obj))))
            setprocnode__object(obj, UNDEFINED);
          if (vals && !flag__object(obj, VAL_BURIED))
            setvalnode__object(obj, UNBOUND);
          if (plists && !flag__object(obj, PLIST_BURIED))
            setplist__object(obj, NIL);
      }
    }
    return UNBOUND;
}

NODE *lerall(NODE *args) {
    return erall_helper(TRUE, TRUE, TRUE);
}

NODE *lerps(NODE *args) {
    return erall_helper(TRUE, FALSE, FALSE);
}

NODE *lerns(NODE *args) {
    return erall_helper(FALSE, TRUE, FALSE);
}

NODE *lerpls(NODE *args) {
    return erall_helper(FALSE, FALSE, TRUE);
}

NODE *bury_helper(NODE *arg, BOOLEAN flag, BOOLEAN setp) {
    NODE *proclst = NIL, *varlst = NIL, *plistlst = NIL;

    three_lists(arg, &proclst, &varlst, &plistlst);

    while (proclst != NIL) {
      if (aggregate(car(proclst))) {
          err_logo(BAD_DATA_UNREC, car(proclst));
          break;
      }
      if (setp)
          setflag__caseobj(intern(car(proclst)), flag);
      else
          return torf(flag__caseobj(intern(car(proclst)), flag));
      proclst = cdr(proclst);
      if (check_throwing) break;
    }

    flag <<= 1;
    while (varlst != NIL && NOT_THROWING) {
      if (aggregate(car(varlst))) {
          err_logo(BAD_DATA_UNREC, car(varlst));
          break;
      }
      if (setp)
          setflag__caseobj(intern(car(varlst)), flag);
      else
          return torf(flag__caseobj(intern(car(varlst)), flag));
      varlst = cdr(varlst);
      if (check_throwing) break;
    }

    flag <<= 1;
    while (plistlst != NIL && NOT_THROWING) {
      if (aggregate(car(plistlst))) {
          err_logo(BAD_DATA_UNREC, car(plistlst));
          break;
      }
      if (setp)
          setflag__caseobj(intern(car(plistlst)), flag);
      else
          return torf(flag__caseobj(intern(car(plistlst)), flag));
      plistlst = cdr(plistlst);
      if (check_throwing) break;
    }
    if (!setp) err_logo(BAD_DATA_UNREC, NIL);
    return(UNBOUND);
}

NODE *lbury(NODE *arg) {
    return bury_helper(arg,PROC_BURIED,TRUE);
}

NODE *ltrace(NODE *arg) {
    return bury_helper(arg,PROC_TRACED,TRUE);
}

NODE *lstep(NODE *arg) {
    return bury_helper(arg,PROC_STEPPED,TRUE);
}

NODE *lburiedp(NODE *arg) {
    return bury_helper(arg,PROC_BURIED,FALSE);
}

NODE *ltracedp(NODE *arg) {
    return bury_helper(arg,PROC_TRACED,FALSE);
}

NODE *lsteppedp(NODE *arg) {
    return bury_helper(arg,PROC_STEPPED,FALSE);
}

NODE *unbury_helper(NODE *arg, int flag) {
    NODE *proclst = NIL, *varlst = NIL, *plistlst = NIL;

    three_lists(arg, &proclst, &varlst, &plistlst);

    while (proclst != NIL) {
      if (aggregate(car(proclst))) {
          err_logo(BAD_DATA_UNREC, car(proclst));
          break;
      }
      clearflag__caseobj(intern(car(proclst)), flag);
      proclst = cdr(proclst);
      if (check_throwing) break;
    }

    flag <<= 1;
    while (varlst != NIL && NOT_THROWING) {
      if (aggregate(car(varlst))) {
          err_logo(BAD_DATA_UNREC, car(varlst));
          break;
      }
      clearflag__caseobj(intern(car(varlst)), flag);
      varlst = cdr(varlst);
      if (check_throwing) break;
    }

    flag <<= 1;
    while (plistlst != NIL && NOT_THROWING) {
      if (aggregate(car(plistlst))) {
          err_logo(BAD_DATA_UNREC, car(plistlst));
          break;
      }
      clearflag__caseobj(intern(car(plistlst)), flag);
      plistlst = cdr(plistlst);
      if (check_throwing) break;
    }
    return(UNBOUND);
}

NODE *lunbury(NODE *arg) {
    return unbury_helper(arg,PROC_BURIED);
}

NODE *luntrace(NODE *arg) {
    return unbury_helper(arg,PROC_TRACED);
}

NODE *lunstep(NODE *arg) {
    return unbury_helper(arg,PROC_STEPPED);
}

char *addsep(char *path) {
    static char result[70];

    strcpy(result, path);
    if (result[0]) strcat(result, separator);
    return result;
}

char tmp_filename[500] = "";

NODE *leditfile(NODE *args) {
    NODE *arg = cnv_node_to_strnode(car(args));

    if (NOT_THROWING) {
      noparity_strnzcpy(tmp_filename, getstrptr(arg), getstrlen(arg));
      return ledit(NIL);
    } else
      return UNBOUND;
}

NODE *ledit(NODE *args) {
    FILE *holdstrm;
#ifdef unix
#ifndef HAVE_UNISTD_H
    extern int getpid();
#endif
#endif
#ifdef __RZTC__
    BOOLEAN was_graphics;
#endif
    NODE *tmp_line = NIL, *exec_list = NIL;

    if (tmp_filename[0] == '\0' || args != NIL) {
#ifndef unix
      sprintf(tmp_filename, "%stemp.txt", addsep(tempdir));
#else
      sprintf(tmp_filename, "%s/logo%d", tempdir, (int)getpid());
#endif
    }
    if (args != NIL) {
      holdstrm = writestream;
      writestream = fopen(tmp_filename, "w");
      if (writestream != NULL) {
          po_helper(args,-1);
          fclose(writestream);
          writestream = holdstrm;
      } else {
          err_logo(FILE_ERROR,
            make_static_strnode("Could not create editor file"));
          writestream = holdstrm;
          return(UNBOUND);
      }
    }
    if (stopping_flag == THROWING) return(UNBOUND);
#ifdef mac
    if (!mac_edit()) return(UNBOUND);
#else     /* !mac */
#ifdef ibm
#ifdef __RZTC__
    was_graphics = in_graphics_mode;
    if (in_graphics_mode) t_screen();
    zflush();
#endif      /* ztc */
    if (spawnlp(P_WAIT, editor, editorname, tmp_filename, NULL)) {
      err_logo(FILE_ERROR, make_static_strnode
             ("Could not launch the editor"));
      return(UNBOUND);
    }
#ifdef __RZTC__
    if (was_graphics) s_screen();
    else lcleartext(NIL);
#endif      /* ztc */
#ifdef WIN32
    win32_repaint_screen();
#endif
#else /* !ibm (so unix) */
    if (fork() == 0) {
      execlp(editor, editorname, tmp_filename, 0);
      exit(1);
    }
    wait(0);
#endif      /* ibm */
#endif      /* mac */
    holdstrm = loadstream;
    tmp_line = current_line;
    loadstream = fopen(tmp_filename, "r");
    if (loadstream != NULL) {
      while (!feof(loadstream) && NOT_THROWING) {
          current_line = reader(loadstream, "");
          exec_list = parser(current_line, TRUE);
          if (exec_list != NIL) eval_driver(exec_list);
      }
      fclose(loadstream);
    } else
      err_logo(FILE_ERROR,
            make_static_strnode("Could not read editor file"));
    loadstream = holdstrm;
    current_line = tmp_line;
    return(UNBOUND);
}

NODE *lthing(NODE *args) {
    NODE *val = UNBOUND, *arg;

    arg = name_arg(args);
    if (NOT_THROWING) val = valnode__caseobj(intern(arg));
    while (val == UNBOUND && NOT_THROWING)
      val = err_logo(NO_VALUE, car(args));
    return(val);
}

NODE *lnamep(NODE *args) {
    NODE *arg;

    arg = name_arg(args);
    if (NOT_THROWING) 
      return torf(valnode__caseobj(intern(arg)) != UNBOUND);
    return UNBOUND;
}

NODE *lprocedurep(NODE *args) {
    NODE *arg;

    arg = name_arg(args);
    if (NOT_THROWING) 
      return torf(procnode__caseobj(intern(arg)) != UNDEFINED);
    return UNBOUND;
}

NODE *lplistp(NODE *args) {
    NODE *arg;

    arg = name_arg(args);
    if (NOT_THROWING) 
      return torf(plist__caseobj(intern(arg)) != NIL);
    return UNBOUND;
}

NODE *check_proctype(NODE *args, int wanted) {
    NODE *arg, *cell = NIL;
    int isprim;

    arg = proc_name_arg(args);
    if (NOT_THROWING &&
          (cell = procnode__caseobj(intern(arg))) == UNDEFINED) {
      return(FalseName());
    }
    if (wanted == 2) return torf(is_macro(intern(arg)));
    isprim = is_prim(cell);
    if (NOT_THROWING) return torf((isprim != 0) == wanted);
    return(UNBOUND);
}

NODE *lprimitivep(NODE *args) {
    return(check_proctype(args,1));
}

NODE *ldefinedp(NODE *args) {
    return(check_proctype(args,0));
}

NODE *lmacrop(NODE *args) {
    return(check_proctype(args,2));
}

NODE *larity(NODE *args) {
    NODE *arg = proc_name_arg(args);
    FIXNUM min;

    if (NOT_THROWING) {
      arg = procnode__caseobj(intern(arg));
      if is_prim(arg) {
          min = getprimmin(arg);
          if (min == OK_NO_ARG) min = 0;
          return cons_list(0, make_intnode(min),
                       make_intnode(getprimdflt(arg)),
                       make_intnode(getprimmax(arg)), END_OF_LIST);
      } else if (arg == UNDEFINED) {
          err_logo(DK_HOW_UNREC, car(args));
          return UNBOUND;
      } else {
          return cons_list(0, minargs__procnode(arg),
                       dfltargs__procnode(arg),
                       maxargs__procnode(arg), END_OF_LIST);
      }
    }
    return UNBOUND;
}

NODE *lcopydef(NODE *args) {
    NODE *arg1, *arg2;
    int redef = (varTrue(Redefp));
    int old_default = -1, new_default;

    arg1 = proc_name_arg(args);
    arg2 = proc_name_arg(cdr(args));
    if (NOT_THROWING) {
      arg1 = intern(arg1);
      arg2 = intern(arg2);
    }
    if (NOT_THROWING && procnode__caseobj(arg2) == UNDEFINED)
      err_logo(DK_HOW, arg2);
    if (NOT_THROWING && !redef && is_prim(procnode__caseobj(arg1)))
      err_logo(IS_PRIM, arg1);
    if (NOT_THROWING) {
      NODE *old_proc = procnode__caseobj(arg1);
      NODE *new_proc = procnode__caseobj(arg2);
      if (old_proc != UNDEFINED) {
          old_default = (is_prim(old_proc) ? getprimdflt(old_proc) :
                                  getint(dfltargs__procnode(old_proc)));
          }
      new_default = (is_prim(new_proc) ? getprimdflt(new_proc) :
                                 getint(dfltargs__procnode(new_proc)));
      if (old_default != new_default && old_default >= 0) {
          the_generation = cons(NIL, NIL);
      }
      setprocnode__caseobj(arg1, new_proc);
      setflag__caseobj(arg1, PROC_BURIED);
      if (is_macro(arg2)) setflag__caseobj(arg1, PROC_MACRO);
      else clearflag__caseobj(arg1, PROC_MACRO);
    }
    return(UNBOUND);
}
  
char *fixhelp(char *ptr, int len) {
    static char result[32];
    char *p, c;
    for (p = result; --len >= 0; *p++ = c) {
        c = *ptr++;
        if (c == '?')
            c = 'p';
        else if (c == '.')
            c = 'd';
    }
    *p = 0;
    return result;
}

char inops[] = "+-*/=<>";

NODE *lhelp(NODE *args) {
    NODE *arg = NIL, *pproc;
    char buffer[200];
#ifndef WIN32
    char junk[20];
#endif
    FILE *fp;
    int lines;
#ifdef __RZTC__
    size_t len;
#endif

    if (args == NIL) {
/*
 #ifdef WIN32
      sprintf(buffer, "%sHELPCONT", addsep(helpfiles));
 #else
 */
      sprintf(buffer, "%sHELPCONTENTS", addsep(helpfiles));
/* #endif */
    } else if (is_word(car(args)) && car(args) != Null_Word) {
        arg = llowercase(args);
    /*      setcar(args, arg);  */
      if (getstrlen(arg) == 1) {
          char *cp = strchr(inops,*(getstrptr(arg)));
          if (cp != NULL) {
            arg=cnv_node_to_strnode(theName(Name_sum+(cp-inops)));
          }
      }
      sprintf(buffer, "%s%s", addsep(helpfiles),
            fixhelp(getstrptr(arg), getstrlen(arg)));
#ifdef __RZTC__    /* defined(ibm) || defined(WIN32) */
      if (strlen(buffer) > (len = strlen(addsep(helpfiles))+8)) {
          buffer[len+5] = '\0';
          buffer[len+4] = buffer[len+3];
          buffer[len+3] = buffer[len+2];
          buffer[len+2] = buffer[len+1];
          buffer[len+1] = buffer[len];
          buffer[len] = '.';
      }
#endif
    } else {
        err_logo(BAD_DATA_UNREC, car(args));
      return UNBOUND;
    }
    fp = fopen(buffer, "r");
    if (fp == NULL) {
      if (args == NIL)
          ndprintf(writestream, message_texts[NO_HELP]);
      else {
          pproc = procnode__caseobj(intern(car(args)));
          if (is_list(pproc)) {
            po_helper(args, 1);
          }
          else
            ndprintf(writestream, message_texts[NO_HELPON], arg);
      }
    } else {
      (void)ltextscreen(NIL);
      lines = 0;
      fgets(buffer, 200, fp);
      while (NOT_THROWING && !feof(fp)) {
          if (interactive && writestream==stdout && ++lines >= y_max) {
            ndprintf(writestream, message_texts[MORE_HELP]);
            input_blocking++;
#ifndef TIOCSTI
            if (!setjmp(iblk_buf))
#endif
#ifdef __RZTC__
                ztc_getcr();
                print_char(stdout, '\n');
#else
#ifdef WIN32
                (void)reader(stdin, "");
#else
                fgets(junk, 19, stdin);
#endif
#endif
            input_blocking = 0;
            update_coords('\n');
            lines = 1;
          }
          ndprintf(writestream, "%t", buffer);
          fgets(buffer, 200, fp);
      }
      fclose(fp);
    }
    return UNBOUND;
}

Generated by  Doxygen 1.6.0   Back to index