wegrzyn@encore.UUCP (Chuck Wegrzyn) (03/13/85)
# This is a shell archive. # Remove everything above and including the cut line. # Then run the rest of the file through sh. -----cut here-----cut here-----cut here-----cut here----- #!/bin/sh # shar: Shell Archiver # Run the following text with /bin/sh to create: # fact.lsp # init.lsp # object.lsp # prolog.lsp # trace.lsp # This archive created: Wed Mar 13 08:44:34 1985 echo shar: extracting fact.lsp '(84 characters)' sed 's/^XX//' << \SHAR_EOF > fact.lsp XX(defun factorial (n) XX (cond ((= n 1) 1) XX (t (* n (factorial (- n 1)))))) SHAR_EOF if test 84 -ne "`wc -c fact.lsp`" then echo shar: error transmitting fact.lsp '(should have been 84 characters)' fi echo shar: extracting init.lsp '(1959 characters)' sed 's/^XX//' << \SHAR_EOF > init.lsp XX; get some more memory XX(expand 1) XX XX; some fake definitions for Common Lisp pseudo compatiblity XX(setq symbol-function symbol-value) XX(setq fboundp boundp) XX(setq first car) XX(setq second cadr) XX(setq rest cdr) XX XX; some more cxr functions XX(defun caddr (x) (car (cddr x))) XX(defun cadddr (x) (cadr (cddr x))) XX XX; (when test code...) - execute code when test is true XX(defmacro when (test &rest code) XX `(cond (,test ,@code))) XX XX; (unless test code...) - execute code unless test is true XX(defmacro unless (test &rest code) XX `(cond ((not ,test) ,@code))) XX XX; (makunbound sym) - make a symbol be unbound XX(defun makunbound (sym) (setq sym '*unbound*) sym) XX XX; (objectp expr) - object predicate XX(defun objectp (x) (eq (type x) 'OBJ)) XX XX; (filep expr) - file predicate XX(defun filep (x) (eq (type x) 'FPTR)) XX XX; (unintern sym) - remove a symbol from the oblist XX(defun unintern (sym) (cond ((member sym *oblist*) XX (setq *oblist* (delete sym *oblist*)) XX t) XX (t nil))) XX XX; (mapcan ...) XX(defmacro mapcan (&rest args) `(apply #'nconc (mapcar ,@args))) XX XX; (mapcon ...) XX(defmacro mapcon (&rest args) `(apply #'nconc (maplist ,@args))) XX XX; (save fun) - save a function definition to a file XX(defun save (fun) XX (let* ((fname (strcat (symbol-name fun) ".lsp")) XX (fp (openo fname))) XX (cond (fp (print (cons (if (eq (car (eval fun)) 'lambda) XX 'defun XX 'defmacro) XX (cons fun (cdr (eval fun)))) fp) XX (close fp) XX fname) XX (t nil)))) XX XX; (debug) - enable debug breaks XX(defun debug () XX (setq *breakenable* t)) XX XX; (nodebug) - disable debug breaks XX(defun nodebug () XX (setq *breakenable* nil)) XX XX; initialize to enable breaks but no trace back XX(setq *breakenable* t) XX(setq *tracenable* nil) SHAR_EOF if test 1959 -ne "`wc -c init.lsp`" then echo shar: error transmitting init.lsp '(should have been 1959 characters)' fi echo shar: extracting object.lsp '(2374 characters)' sed 's/^XX//' << \SHAR_EOF > object.lsp XX; This is an example using the object-oriented programming support in XX; XLISP. The example involves defining a class of objects representing XX; dictionaries. Each instance of this class will be a dictionary in XX; which names and values can be stored. There will also be a facility XX; for finding the values associated with names after they have been XX; stored. XX XX; Create the 'Dictionary' class. XX XX(setq Dictionary (Class 'new)) XX XX; Establish the instance variables for the new class. XX; The variable 'entries' will point to an association list representing the XX; entries in the dictionary instance. XX XX(Dictionary 'ivars '(entries)) XX XX; Setup the method for the 'isnew' initialization message. XX; This message will be send whenever a new instance of the 'Dictionary' XX; class is created. Its purpose is to allow the new instance to be XX; initialized before any other messages are sent to it. It sets the value XX; of 'entries' to nil to indicate that the dictionary is empty. XX XX(Dictionary 'answer 'isnew '() XX '((setq entries nil) XX self)) XX XX; Define the message 'add' to make a new entry in the dictionary. This XX; message takes two arguments. The argument 'name' specifies the name XX; of the new entry; the argument 'value' specifies the value to be XX; associated with that name. XX XX(Dictionary 'answer 'add '(name value) XX '((setq entries XX (cons (cons name value) entries)) XX value)) XX XX; Create an instance of the 'Dictionary' class. This instance is an empty XX; dictionary to which words may be added. XX XX(setq d (Dictionary 'new)) XX XX; Add some entries to the new dictionary. XX XX(d 'add 'mozart 'composer) XX(d 'add 'winston 'computer-scientist) XX XX; Define a message to find entries in a dictionary. This message takes XX; one argument 'name' which specifies the name of the entry for which to XX; search. It returns the value associated with the entry if one is XX; present in the dictionary. Otherwise, it returns nil. XX XX(Dictionary 'answer 'find '(name &aux entry) XX '((cond ((setq entry (assoc name entries)) XX (cdr entry)) XX (t XX nil)))) XX XX; Try to find some entries in the dictionary we created. XX XX(d 'find 'mozart) XX(d 'find 'winston) XX(d 'find 'bozo) XX XX; The names 'mozart' and 'winston' are found in the dictionary so their XX; values 'composer' and 'computer-scientist' are returned. The name 'bozo' XX; is not found so nil is returned in this case. SHAR_EOF if test 2374 -ne "`wc -c object.lsp`" then echo shar: error transmitting object.lsp '(should have been 2374 characters)' fi echo shar: extracting prolog.lsp '(4289 characters)' sed 's/^XX//' << \SHAR_EOF > prolog.lsp XX XX;; The following is a tiny Prolog interpreter in MacLisp XX;; written by Ken Kahn and modified for XLISP by David Betz. XX;; It was inspired by other tiny Lisp-based Prologs of XX;; Par Emanuelson and Martin Nilsson. XX;; There are no side-effects anywhere in the implementation. XX;; Though it is VERY slow of course. XX XX(defun prolog (database &aux goal) XX (do () ((not (progn (princ "Query?") (setq goal (read))))) XX (prove (list (rename-variables goal '(0))) XX '((bottom-of-environment)) XX database XX 1))) XX XX;; prove - proves the conjunction of the list-of-goals XX;; in the current environment XX XX(defun prove (list-of-goals environment database level) XX (cond ((null list-of-goals) ;; succeeded since there are no goals XX (print-bindings environment environment) XX (not (y-or-n-p "More?"))) XX (t (try-each database database XX (cdr list-of-goals) (car list-of-goals) XX environment level)))) XX XX(defun try-each (database-left database goals-left goal environment level XX &aux assertion new-enviroment) XX (cond ((null database-left) nil) ;; fail since nothing left in database XX (t (setq assertion XX (rename-variables (car database-left) XX (list level))) XX (setq new-environment XX (unify goal (car assertion) environment)) XX (cond ((null new-environment) ;; failed to unify XX (try-each (cdr database-left) database XX goals-left goal XX environment level)) XX ((prove (append (cdr assertion) goals-left) XX new-environment XX database XX (+ 1 level))) XX (t (try-each (cdr database-left) database XX goals-left goal XX environment level)))))) XX XX(defun unify (x y environment &aux new-environment) XX (setq x (value x environment)) XX (setq y (value y environment)) XX (cond ((variable-p x) (cons (list x y) environment)) XX ((variable-p y) (cons (list y x) environment)) XX ((or (atom x) (atom y)) XX (cond ((equal x y) environment) XX (t nil))) XX (t (setq new-environment (unify (car x) (car y) environment)) XX (cond (new-environment (unify (cdr x) (cdr y) new-environment)) XX (t nil))))) XX XX(defun value (x environment &aux binding) XX (cond ((variable-p x) XX (setq binding (assoc x environment)) XX (cond ((null binding) x) XX (t (value (cadr binding) environment)))) XX (t x))) XX XX(defun variable-p (x) XX (and x (listp x) (eq (car x) '?))) XX XX(defun rename-variables (term list-of-level) XX (cond ((variable-p term) (append term list-of-level)) XX ((atom term) term) XX (t (cons (rename-variables (car term) list-of-level) XX (rename-variables (cdr term) list-of-level))))) XX XX(defun print-bindings (environment-left environment) XX (cond ((cdr environment-left) XX (cond ((= 0 (nth 2 (caar environment-left))) XX (prin1 (cadr (caar environment-left))) XX (princ " = ") XX (print (value (caar environment-left) environment)))) XX (print-bindings (cdr environment-left) environment)))) XX XX;; a sample database: XX(setq db '(((father madelyn ernest)) XX ((mother madelyn virginia)) XX ((father david arnold)) XX ((mother david pauline)) XX ((father rachel david)) XX ((mother rachel madelyn)) XX ((grandparent (? grandparent) (? grandchild)) XX (parent (? grandparent) (? parent)) XX (parent (? parent) (? grandchild))) XX ((parent (? parent) (? child)) XX (mother (? parent) (? child))) XX ((parent (? parent) (? child)) XX (father (? parent) (? child))))) XX XX;; the following are utilities XX(defun y-or-n-p (prompt) XX (princ prompt) XX (eq (read) 'y)) XX XX;; start things going XX(prolog db) SHAR_EOF if test 4289 -ne "`wc -c prolog.lsp`" then echo shar: error transmitting prolog.lsp '(should have been 4289 characters)' fi echo shar: extracting trace.lsp '(642 characters)' sed 's/^XX//' << \SHAR_EOF > trace.lsp XX(setq *tracelist* nil) XX XX(defun evalhookfcn (expr &aux val) XX (if (and (consp expr) (member (car expr) *tracelist*)) XX (progn (princ ">>> ") (print expr) XX (setq val (evalhook expr evalhookfcn nil)) XX (princ "<<< ") (print val)) XX (evalhook expr evalhookfcn nil))) XX XX(defun trace (fun) XX (if (not (member fun *tracelist*)) XX (progn (setq *tracelist* (cons fun *tracelist*)) XX (setq *evalhook* evalhookfcn))) XX *tracelist*) XX XX(defun untrace (fun) XX (if (null (setq *tracelist* (delete fun *tracelist*))) XX (setq *evalhook* nil)) XX *tracelist*) SHAR_EOF if test 642 -ne "`wc -c trace.lsp`" then echo shar: error transmitting trace.lsp '(should have been 642 characters)' fi # End of shell archive exit 0
wegrzyn@encore.UUCP (Chuck Wegrzyn) (03/13/85)
# This is a shell archive.
# Remove everything above and including the cut line.
# Then run the rest of the file through sh.
-----cut here-----cut here-----cut here-----cut here-----
#!/bin/sh
# shar: Shell Archiver
# Run the following text with /bin/sh to create:
# xlbfun.c
# xlbind.c
# xldbug.c
# xldmem.c
# xlio.c
# xlisp.c
# xlisp.h
# xljump.c
# xlread.c
# xlsetf.c
# xlstr.c
# This archive created: Wed Mar 13 08:36:56 1985
echo shar: extracting xlbfun.c '(8689 characters)'
sed 's/^XX//' << \SHAR_EOF > xlbfun.c
XX/* xlbfun.c - xlisp basic builtin functions */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern NODE *xlstack;
XXextern NODE *s_lambda,*s_macro;
XXextern NODE *s_comma,*s_comat;
XXextern NODE *s_unbound;
XXextern char gsprefix[];
XXextern int gsnumber;
XX
XX/* forward declarations */
XXFORWARD NODE *bquote1();
XXFORWARD NODE *defun();
XXFORWARD NODE *makesymbol();
XX
XX/* xeval - the builtin function 'eval' */
XXNODE *xeval(args)
XX NODE *args;
XX{
XX NODE *oldstk,expr,*val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&expr,NULL);
XX
XX /* get the expression to evaluate */
XX expr.n_ptr = xlarg(&args);
XX xllastarg(args);
XX
XX /* evaluate the expression */
XX val = xleval(expr.n_ptr);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the expression evaluated */
XX return (val);
XX}
XX
XX/* xapply - the builtin function 'apply' */
XXNODE *xapply(args)
XX NODE *args;
XX{
XX NODE *oldstk,fun,arglist,*val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&fun,&arglist,NULL);
XX
XX /* get the function and argument list */
XX fun.n_ptr = xlarg(&args);
XX arglist.n_ptr = xlarg(&args);
XX xllastarg(args);
XX
XX /* if the function is a symbol, get its value */
XX if (symbolp(fun.n_ptr))
XX fun.n_ptr = xleval(fun.n_ptr);
XX
XX /* apply the function to the arguments */
XX val = xlapply(fun.n_ptr,arglist.n_ptr);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the expression evaluated */
XX return (val);
XX}
XX
XX/* xfuncall - the builtin function 'funcall' */
XXNODE *xfuncall(args)
XX NODE *args;
XX{
XX NODE *oldstk,fun,arglist,*val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&fun,&arglist,NULL);
XX
XX /* get the function and argument list */
XX fun.n_ptr = xlarg(&args);
XX arglist.n_ptr = args;
XX
XX /* if the function is a symbol, get its value */
XX if (symbolp(fun.n_ptr))
XX fun.n_ptr = xleval(fun.n_ptr);
XX
XX /* apply the function to the arguments */
XX val = xlapply(fun.n_ptr,arglist.n_ptr);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the expression evaluated */
XX return (val);
XX}
XX
XX/* xquote - builtin function to quote an expression */
XXNODE *xquote(args)
XX NODE *args;
XX{
XX NODE *arg;
XX
XX /* get the argument */
XX arg = xlarg(&args);
XX xllastarg(args);
XX
XX /* return the quoted expression */
XX return (arg);
XX}
XX
XX/* xbquote - back quote function */
XXNODE *xbquote(args)
XX NODE *args;
XX{
XX NODE *oldstk,expr,*val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&expr,NULL);
XX
XX /* get the expression */
XX expr.n_ptr = xlarg(&args);
XX xllastarg(args);
XX
XX /* fill in the template */
XX val = bquote1(expr.n_ptr);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the result */
XX return (val);
XX}
XX
XX/* bquote1 - back quote helper function */
XXLOCAL NODE *bquote1(expr)
XX NODE *expr;
XX{
XX NODE *oldstk,val,list,*last,*new;
XX
XX /* handle atoms */
XX if (atom(expr))
XX val.n_ptr = expr;
XX
XX /* handle (comma <expr>) */
XX else if (car(expr) == s_comma) {
XX if (atom(cdr(expr)))
XX xlfail("bad comma expression");
XX val.n_ptr = xleval(car(cdr(expr)));
XX }
XX
XX /* handle ((comma-at <expr>) ... ) */
XX else if (consp(car(expr)) && car(car(expr)) == s_comat) {
XX oldstk = xlsave(&list,&val,NULL);
XX if (atom(cdr(car(expr))))
XX xlfail("bad comma-at expression");
XX list.n_ptr = xleval(car(cdr(car(expr))));
XX for (last = NIL; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
XX new = newnode(LIST);
XX rplaca(new,car(list.n_ptr));
XX if (last)
XX rplacd(last,new);
XX else
XX val.n_ptr = new;
XX last = new;
XX }
XX if (last)
XX rplacd(last,bquote1(cdr(expr)));
XX else
XX val.n_ptr = bquote1(cdr(expr));
XX xlstack = oldstk;
XX }
XX
XX /* handle any other list */
XX else {
XX oldstk = xlsave(&val,NULL);
XX val.n_ptr = newnode(LIST);
XX rplaca(val.n_ptr,bquote1(car(expr)));
XX rplacd(val.n_ptr,bquote1(cdr(expr)));
XX xlstack = oldstk;
XX }
XX
XX /* return the result */
XX return (val.n_ptr);
XX}
XX
XX/* xset - builtin function set */
XXNODE *xset(args)
XX NODE *args;
XX{
XX NODE *sym,*val;
XX
XX /* get the symbol and new value */
XX sym = xlmatch(SYM,&args);
XX val = xlarg(&args);
XX xllastarg(args);
XX
XX /* assign the symbol the value of argument 2 and the return value */
XX assign(sym,val);
XX
XX /* return the result value */
XX return (val);
XX}
XX
XX/* xsetq - builtin function setq */
XXNODE *xsetq(args)
XX NODE *args;
XX{
XX NODE *oldstk,arg,sym,val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&arg,&sym,&val,NULL);
XX
XX /* initialize */
XX arg.n_ptr = args;
XX
XX /* handle each pair of arguments */
XX while (arg.n_ptr) {
XX sym.n_ptr = xlmatch(SYM,&arg.n_ptr);
XX val.n_ptr = xlevarg(&arg.n_ptr);
XX assign(sym.n_ptr,val.n_ptr);
XX }
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the result value */
XX return (val.n_ptr);
XX}
XX
XX/* xdefun - builtin function 'defun' */
XXNODE *xdefun(args)
XX NODE *args;
XX{
XX return (defun(args,s_lambda));
XX}
XX
XX/* xdefmacro - builtin function 'defmacro' */
XXNODE *xdefmacro(args)
XX NODE *args;
XX{
XX return (defun(args,s_macro));
XX}
XX
XX/* defun - internal function definition routine */
XXLOCAL NODE *defun(args,type)
XX NODE *args,*type;
XX{
XX NODE *oldstk,sym,fargs,fun;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&sym,&fargs,&fun,NULL);
XX
XX /* get the function symbol and formal argument list */
XX sym.n_ptr = xlmatch(SYM,&args);
XX fargs.n_ptr = xlmatch(LIST,&args);
XX
XX /* create a new function definition */
XX fun.n_ptr = newnode(LIST);
XX rplaca(fun.n_ptr,type);
XX rplacd(fun.n_ptr,newnode(LIST));
XX rplaca(cdr(fun.n_ptr),fargs.n_ptr);
XX rplacd(cdr(fun.n_ptr),args);
XX
XX /* make the symbol point to a new function definition */
XX assign(sym.n_ptr,fun.n_ptr);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the function symbol */
XX return (sym.n_ptr);
XX}
XX
XX/* xgensym - generate a symbol */
XXNODE *xgensym(args)
XX NODE *args;
XX{
XX char sym[STRMAX+1];
XX NODE *x;
XX
XX /* get the prefix or number */
XX if (args) {
XX x = xlarg(&args);
XX switch (ntype(x)) {
XX case STR:
XX strcpy(gsprefix,x->n_str);
XX break;
XX case INT:
XX gsnumber = x->n_int;
XX break;
XX default:
XX xlfail("bad argument type");
XX }
XX }
XX xllastarg(args);
XX
XX /* create the pname of the new symbol */
XX sprintf(sym,"%s%d",gsprefix,gsnumber++);
XX
XX /* make a symbol with this print name */
XX return (xlmakesym(sym,DYNAMIC));
XX}
XX
XX/* xmakesymbol - make a new uninterned symbol */
XXNODE *xmakesymbol(args)
XX NODE *args;
XX{
XX return (makesymbol(args,FALSE));
XX}
XX
XX/* xintern - make a new interned symbol */
XXNODE *xintern(args)
XX NODE *args;
XX{
XX return (makesymbol(args,TRUE));
XX}
XX
XX/* makesymbol - make a new symbol */
XXLOCAL NODE *makesymbol(args,iflag)
XX NODE *args; int iflag;
XX{
XX NODE *oldstk,pname,*val;
XX char *str;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&pname,NULL);
XX
XX /* get the print name of the symbol to intern */
XX pname.n_ptr = xlmatch(STR,&args);
XX xllastarg(args);
XX
XX /* make the symbol */
XX str = pname.n_ptr->n_str;
XX val = (iflag ? xlenter(str,DYNAMIC) : xlmakesym(str,DYNAMIC));
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the symbol */
XX return (val);
XX}
XX
XX/* xsymname - get the print name of a symbol */
XXNODE *xsymname(args)
XX NODE *args;
XX{
XX NODE *sym;
XX
XX /* get the symbol */
XX sym = xlmatch(SYM,&args);
XX xllastarg(args);
XX
XX /* return the print name */
XX return (car(sym->n_symplist));
XX}
XX
XX/* xsymvalue - get the print value of a symbol */
XXNODE *xsymvalue(args)
XX NODE *args;
XX{
XX NODE *sym;
XX
XX /* get the symbol */
XX sym = xlmatch(SYM,&args);
XX xllastarg(args);
XX
XX /* check for an unbound symbol */
XX while (sym->n_symvalue == s_unbound)
XX xlunbound(sym);
XX
XX /* return the value */
XX return (sym->n_symvalue);
XX}
XX
XX/* xsymplist - get the property list of a symbol */
XXNODE *xsymplist(args)
XX NODE *args;
XX{
XX NODE *sym;
XX
XX /* get the symbol */
XX sym = xlmatch(SYM,&args);
XX xllastarg(args);
XX
XX /* return the property list */
XX return (cdr(sym->n_symplist));
XX}
XX
XX/* xget - get the value of a property */
XXNODE *xget(args)
XX NODE *args;
XX{
XX NODE *sym,*prp;
XX
XX /* get the symbol and property */
XX sym = xlmatch(SYM,&args);
XX prp = xlmatch(SYM,&args);
XX xllastarg(args);
XX
XX /* retrieve the property value */
XX return (xlgetprop(sym,prp));
XX}
XX
XX/* xremprop - remove a property value from a property list */
XXNODE *xremprop(args)
XX NODE *args;
XX{
XX NODE *sym,*prp;
XX
XX /* get the symbol and property */
XX sym = xlmatch(SYM,&args);
XX prp = xlmatch(SYM,&args);
XX xllastarg(args);
XX
XX /* remove the property */
XX xlremprop(sym,prp);
XX
XX /* return nil */
XX return (NIL);
XX}
SHAR_EOF
if test 8689 -ne "`wc -c xlbfun.c`"
then
echo shar: error transmitting xlbfun.c '(should have been 8689 characters)'
fi
echo shar: extracting xlbind.c '(1509 characters)'
sed 's/^XX//' << \SHAR_EOF > xlbind.c
XX/* xlbind - xlisp symbol binding routines */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern NODE *xlenv,*xlnewenv;
XX
XX/* xlsbind - bind a value to a symbol sequentially */
XXxlsbind(sym,val)
XX NODE *sym,*val;
XX{
XX NODE *ptr;
XX
XX /* create a new environment list entry */
XX ptr = newnode(LIST);
XX rplacd(ptr,xlenv);
XX xlenv = ptr;
XX
XX /* create a new variable binding */
XX rplaca(ptr,newnode(LIST));
XX rplaca(car(ptr),sym);
XX rplacd(car(ptr),sym->n_symvalue);
XX sym->n_symvalue = val;
XX}
XX
XX/* xlbind - bind a value to a symbol in parallel */
XXxlbind(sym,val)
XX NODE *sym,*val;
XX{
XX NODE *ptr;
XX
XX /* create a new environment list entry */
XX ptr = newnode(LIST);
XX rplacd(ptr,xlnewenv);
XX xlnewenv = ptr;
XX
XX /* create a new variable binding */
XX rplaca(ptr,newnode(LIST));
XX rplaca(car(ptr),sym);
XX rplacd(car(ptr),val);
XX}
XX
XX/* xlfixbindings - make a new set of bindings visible */
XXxlfixbindings()
XX{
XX NODE *eptr,*bnd,*sym,*oldvalue;
XX
XX /* fix the bound value of each symbol in the environment chain */
XX for (eptr = xlnewenv; eptr != xlenv; eptr = cdr(eptr)) {
XX bnd = car(eptr);
XX sym = car(bnd);
XX oldvalue = sym->n_symvalue;
XX sym->n_symvalue = cdr(bnd);
XX rplacd(bnd,oldvalue);
XX }
XX xlenv = xlnewenv;
XX}
XX
XX/* xlunbind - unbind symbols bound in this environment */
XXxlunbind(env)
XX NODE *env;
XX{
XX NODE *bnd;
XX
XX /* unbind each symbol in the environment chain */
XX for (; xlenv != env; xlenv = cdr(xlenv))
XX if (bnd = car(xlenv))
XX car(bnd)->n_symvalue = cdr(bnd);
XX}
SHAR_EOF
if test 1509 -ne "`wc -c xlbind.c`"
then
echo shar: error transmitting xlbind.c '(should have been 1509 characters)'
fi
echo shar: extracting xldbug.c '(3924 characters)'
sed 's/^XX//' << \SHAR_EOF > xldbug.c
XX/* xldebug - xlisp debugging support */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern long total;
XXextern int xldebug;
XXextern int xltrace;
XXextern NODE *s_unbound;
XXextern NODE *s_stdin,*s_stdout;
XXextern NODE *s_tracenable,*s_tlimit,*s_breakenable;
XXextern NODE *s_continue,*s_quit;
XXextern NODE *xlstack;
XXextern NODE *true;
XXextern NODE **trace_stack;
XX
XX/* external routines */
XXextern char *malloc();
XX
XX/* forward declarations */
XXFORWARD NODE *stacktop();
XX
XX/* xlfail - xlisp error handler */
XXxlfail(emsg)
XX char *emsg;
XX{
XX xlerror(emsg,stacktop());
XX}
XX
XX/* xlabort - xlisp serious error handler */
XXxlabort(emsg)
XX char *emsg;
XX{
XX xlsignal(emsg,s_unbound);
XX}
XX
XX/* xlbreak - enter a break loop */
XXxlbreak(emsg,arg)
XX char *emsg; NODE *arg;
XX{
XX breakloop("break",NULL,emsg,arg,TRUE);
XX}
XX
XX/* xlerror - handle a fatal error */
XXxlerror(emsg,arg)
XX char *emsg; NODE *arg;
XX{
XX doerror(NULL,emsg,arg,FALSE);
XX}
XX
XX/* xlcerror - handle a recoverable error */
XXxlcerror(cmsg,emsg,arg)
XX char *cmsg,*emsg; NODE *arg;
XX{
XX doerror(cmsg,emsg,arg,TRUE);
XX}
XX
XX/* xlerrprint - print an error message */
XXxlerrprint(hdr,cmsg,emsg,arg)
XX char *hdr,*cmsg,*emsg; NODE *arg;
XX{
XX printf("%s: %s",hdr,emsg);
XX if (arg != s_unbound) { printf(" - "); stdprint(arg); }
XX else printf("\n");
XX if (cmsg) printf("if continued: %s\n",cmsg);
XX}
XX
XX/* doerror - handle xlisp errors */
XXLOCAL doerror(cmsg,emsg,arg,cflag)
XX char *cmsg,*emsg; NODE *arg; int cflag;
XX{
XX /* make sure the break loop is enabled */
XX if (s_breakenable->n_symvalue == NIL)
XX xlsignal(emsg,arg);
XX
XX /* call the debug read-eval-print loop */
XX breakloop("error",cmsg,emsg,arg,cflag);
XX}
XX
XX/* breakloop - the debug read-eval-print loop */
XXLOCAL int breakloop(hdr,cmsg,emsg,arg,cflag)
XX char *hdr,*cmsg,*emsg; NODE *arg; int cflag;
XX{
XX NODE *oldstk,expr,*val;
XX CONTEXT cntxt;
XX
XX /* increment the debug level */
XX xldebug++;
XX
XX /* flush the input buffer */
XX xlflush();
XX
XX /* print the error message */
XX xlerrprint(hdr,cmsg,emsg,arg);
XX
XX /* do the back trace */
XX if (s_tracenable->n_symvalue) {
XX val = s_tlimit->n_symvalue;
XX xlbaktrace(fixp(val) ? val->n_int : -1);
XX }
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&expr,NULL);
XX
XX /* debug command processing loop */
XX xlbegin(&cntxt,CF_ERROR,true);
XX while (TRUE) {
XX
XX /* setup the continue trap */
XX if (setjmp(cntxt.c_jmpbuf)) {
XX xlflush();
XX continue;
XX }
XX
XX /* read an expression and check for eof */
XX if (!xlread(s_stdin->n_symvalue,&expr.n_ptr)) {
XX expr.n_ptr = s_quit;
XX break;
XX }
XX
XX /* check for commands */
XX if (expr.n_ptr == s_continue) {
XX if (cflag) break;
XX else xlabort("this error can't be continued");
XX }
XX else if (expr.n_ptr == s_quit)
XX break;
XX
XX /* evaluate the expression */
XX expr.n_ptr = xleval(expr.n_ptr);
XX
XX /* print it */
XX xlprint(s_stdout->n_symvalue,expr.n_ptr,TRUE);
XX xlterpri(s_stdout->n_symvalue);
XX }
XX xlend(&cntxt);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* decrement the debug level */
XX xldebug--;
XX
XX /* continue the next higher break loop on quit */
XX if (expr.n_ptr == s_quit)
XX xlsignal("quit from break loop",s_unbound);
XX}
XX
XX/* tpush - add an entry to the trace stack */
XXxltpush(nptr)
XX NODE *nptr;
XX{
XX if (++xltrace < TDEPTH)
XX trace_stack[xltrace] = nptr;
XX}
XX
XX/* tpop - pop an entry from the trace stack */
XXxltpop()
XX{
XX xltrace--;
XX}
XX
XX/* stacktop - return the top node on the stack */
XXLOCAL NODE *stacktop()
XX{
XX return (xltrace >= 0 && xltrace < TDEPTH ? trace_stack[xltrace] : s_unbound);
XX}
XX
XX/* baktrace - do a back trace */
XXxlbaktrace(n)
XX int n;
XX{
XX int i;
XX
XX for (i = xltrace; (n < 0 || n--) && i >= 0; i--)
XX if (i < TDEPTH)
XX stdprint(trace_stack[i]);
XX}
XX
XX/* xldinit - debug initialization routine */
XXxldinit()
XX{
XX if ((trace_stack = (NODE **) malloc(TSTKSIZE)) == NULL)
XX xlabort("insufficient memory");
XX total += (long) TSTKSIZE;
XX xltrace = -1;
XX xldebug = 0;
XX}
SHAR_EOF
if test 3924 -ne "`wc -c xldbug.c`"
then
echo shar: error transmitting xldbug.c '(should have been 3924 characters)'
fi
echo shar: extracting xldmem.c '(6552 characters)'
sed 's/^XX//' << \SHAR_EOF > xldmem.c
XX/* xldmem - xlisp dynamic memory management routines */
XX
XX#include "xlisp.h"
XX
XX/* useful definitions */
XX#define ALLOCSIZE (sizeof(struct segment) + (anodes-1) * sizeof(NODE))
XX
XX/* external variables */
XXextern NODE *oblist,*keylist;
XXextern NODE *xlstack;
XXextern NODE *xlenv,*xlnewenv;
XXextern long total;
XXextern int anodes,nnodes,nsegs,nfree,gccalls;
XXextern struct segment *segs;
XXextern NODE *fnodes;
XX
XX/* external procedures */
XXextern char *malloc();
XXextern char *calloc();
XX
XX/* newnode - allocate a new node */
XXNODE *newnode(type)
XX int type;
XX{
XX NODE *nnode;
XX
XX /* get a free node */
XX if ((nnode = fnodes) == NIL) {
XX gc();
XX if ((nnode = fnodes) == NIL)
XX xlabort("insufficient node space");
XX }
XX
XX /* unlink the node from the free list */
XX fnodes = cdr(nnode);
XX nfree -= 1;
XX
XX /* initialize the new node */
XX nnode->n_type = type;
XX rplacd(nnode,NIL);
XX
XX /* return the new node */
XX return (nnode);
XX}
XX
XX/* stralloc - allocate memory for a string adding a byte for the terminator */
XXchar *stralloc(size)
XX int size;
XX{
XX char *sptr;
XX
XX /* allocate memory for the string copy */
XX if ((sptr = malloc(size+1)) == NULL) {
XX gc();
XX if ((sptr = malloc(size+1)) == NULL)
XX xlfail("insufficient string space");
XX }
XX total += (long) (size+1);
XX
XX /* return the new string memory */
XX return (sptr);
XX}
XX
XX/* strsave - generate a dynamic copy of a string */
XXchar *strsave(str)
XX char *str;
XX{
XX char *sptr;
XX
XX /* create a new string */
XX sptr = stralloc(strlen(str));
XX strcpy(sptr,str);
XX
XX /* return the new string */
XX return (sptr);
XX}
XX
XX/* strfree - free string memory */
XXstrfree(str)
XX char *str;
XX{
XX total -= (long) (strlen(str)+1);
XX free(str);
XX}
XX
XX/* gc - garbage collect */
XXgc()
XX{
XX NODE *p;
XX
XX /* mark all accessible nodes */
XX mark(oblist); mark(keylist);
XX mark(xlenv);
XX mark(xlnewenv);
XX
XX /* mark the evaluation stack */
XX for (p = xlstack; p; p = cdr(p))
XX mark(car(p));
XX
XX /* sweep memory collecting all unmarked nodes */
XX sweep();
XX
XX /* if there's still nothing available, allocate more memory */
XX if (fnodes == NIL)
XX addseg();
XX
XX /* count the gc call */
XX gccalls++;
XX}
XX
XX/* mark - mark all accessible nodes */
XXLOCAL mark(ptr)
XX NODE *ptr;
XX{
XX NODE *this,*prev,*tmp;
XX
XX /* just return on nil */
XX if (ptr == NIL)
XX return;
XX
XX /* initialize */
XX prev = NIL;
XX this = ptr;
XX
XX /* mark this list */
XX while (TRUE) {
XX
XX /* descend as far as we can */
XX while (TRUE) {
XX
XX /* check for this node being marked */
XX if (this->n_flags & MARK)
XX break;
XX
XX /* mark it and its descendants */
XX else {
XX
XX /* mark the node */
XX this->n_flags |= MARK;
XX
XX /* follow the left sublist if there is one */
XX if (livecar(this)) {
XX this->n_flags |= LEFT;
XX tmp = prev;
XX prev = this;
XX this = car(prev);
XX rplaca(prev,tmp);
XX }
XX
XX /* otherwise, follow the right sublist if there is one */
XX else if (livecdr(this)) {
XX this->n_flags &= ~LEFT;
XX tmp = prev;
XX prev = this;
XX this = cdr(prev);
XX rplacd(prev,tmp);
XX }
XX else
XX break;
XX }
XX }
XX
XX /* backup to a point where we can continue descending */
XX while (TRUE) {
XX
XX /* check for termination condition */
XX if (prev == NIL)
XX return;
XX
XX /* check for coming from the left side */
XX if (prev->n_flags & LEFT)
XX if (livecdr(prev)) {
XX prev->n_flags &= ~LEFT;
XX tmp = car(prev);
XX rplaca(prev,this);
XX this = cdr(prev);
XX rplacd(prev,tmp);
XX break;
XX }
XX else {
XX tmp = prev;
XX prev = car(tmp);
XX rplaca(tmp,this);
XX this = tmp;
XX }
XX
XX /* otherwise, came from the right side */
XX else {
XX tmp = prev;
XX prev = cdr(tmp);
XX rplacd(tmp,this);
XX this = tmp;
XX }
XX }
XX }
XX}
XX
XX/* sweep - sweep all unmarked nodes and add them to the free list */
XXLOCAL sweep()
XX{
XX struct segment *seg;
XX NODE *p;
XX int n;
XX
XX /* empty the free list */
XX fnodes = NIL;
XX nfree = 0;
XX
XX /* add all unmarked nodes */
XX for (seg = segs; seg != NULL; seg = seg->sg_next) {
XX p = &seg->sg_nodes[0];
XX for (n = seg->sg_size; n--; p++)
XX if (!(p->n_flags & MARK)) {
XX switch (ntype(p)) {
XX case STR:
XX if (p->n_strtype == DYNAMIC && p->n_str != NULL)
XX strfree(p->n_str);
XX break;
XX case FPTR:
XX if (p->n_fp)
XX fclose(p->n_fp);
XX break;
XX }
XX p->n_type = FREE;
XX p->n_flags = 0;
XX rplaca(p,NIL);
XX rplacd(p,fnodes);
XX fnodes = p;
XX nfree++;
XX }
XX else
XX p->n_flags &= ~(MARK | LEFT);
XX }
XX}
XX
XX/* addseg - add a segment to the available memory */
XXint addseg()
XX{
XX struct segment *newseg;
XX NODE *p;
XX int n;
XX
XX /* check for zero allocation */
XX if (anodes == 0)
XX return (FALSE);
XX
XX /* allocate a new segment */
XX if ((newseg = (struct segment *) calloc(1,ALLOCSIZE)) != NULL) {
XX
XX /* initialize the new segment */
XX newseg->sg_size = anodes;
XX newseg->sg_next = segs;
XX segs = newseg;
XX
XX /* add each new node to the free list */
XX p = &newseg->sg_nodes[0];
XX for (n = anodes; n--; ) {
XX rplacd(p,fnodes);
XX fnodes = p++;
XX }
XX
XX /* update the statistics */
XX total += (long) ALLOCSIZE;
XX nnodes += anodes;
XX nfree += anodes;
XX nsegs++;
XX
XX /* return successfully */
XX return (TRUE);
XX }
XX else
XX return (FALSE);
XX}
XX
XX/* livecar - do we need to follow the car? */
XXLOCAL int livecar(n)
XX NODE *n;
XX{
XX switch (ntype(n)) {
XX case SUBR:
XX case FSUBR:
XX case INT:
XX case STR:
XX case FPTR:
XX return (FALSE);
XX case SYM:
XX case LIST:
XX case OBJ:
XX return (car(n) != NIL);
XX default:
XX printf("bad node type (%d) found during left scan\n",ntype(n));
XX exit();
XX }
XX}
XX
XX/* livecdr - do we need to follow the cdr? */
XXLOCAL int livecdr(n)
XX NODE *n;
XX{
XX switch (ntype(n)) {
XX case SUBR:
XX case FSUBR:
XX case INT:
XX case STR:
XX case FPTR:
XX return (FALSE);
XX case SYM:
XX case LIST:
XX case OBJ:
XX return (cdr(n) != NIL);
XX default:
XX printf("bad node type (%d) found during right scan\n",ntype(n));
XX exit();
XX }
XX}
XX
XX/* stats - print memory statistics */
XXstats()
XX{
XX printf("Nodes: %d\n",nnodes);
XX printf("Free nodes: %d\n",nfree);
XX printf("Segments: %d\n",nsegs);
XX printf("Allocate: %d\n",anodes);
XX printf("Total: %ld\n",total);
XX printf("Collections: %d\n",gccalls);
XX}
XX
XX/* xlminit - initialize the dynamic memory module */
XXxlminit()
XX{
XX /* initialize our internal variables */
XX anodes = NNODES;
XX total = 0L;
XX nnodes = nsegs = nfree = gccalls = 0;
XX fnodes = NIL;
XX segs = NULL;
XX
XX /* initialize structures that are marked by the collector */
XX xlstack = xlenv = xlnewenv = oblist = keylist = NIL;
XX}
SHAR_EOF
if test 6552 -ne "`wc -c xldmem.c`"
then
echo shar: error transmitting xldmem.c '(should have been 6552 characters)'
fi
echo shar: extracting xlio.c '(2897 characters)'
sed 's/^XX//' << \SHAR_EOF > xlio.c
XX/* xlio - xlisp i/o routines */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern int xlplevel;
XXextern int xlfsize;
XXextern NODE *xlstack;
XXextern NODE *s_stdin;
XXextern int xldebug;
XXextern int prompt;
XX
XX/* xlgetc - get a character from a file or stream */
XXint xlgetc(fptr)
XX NODE *fptr;
XX{
XX NODE *lptr,*cptr;
XX FILE *fp;
XX int ch;
XX
XX /* check for input from nil */
XX if (fptr == NIL)
XX ch = EOF;
XX
XX /* otherwise, check for input from a stream */
XX else if (consp(fptr)) {
XX if ((lptr = car(fptr)) == NIL)
XX ch = EOF;
XX else {
XX if (!consp(lptr) ||
XX (cptr = car(lptr)) == NIL || !fixp(cptr))
XX xlfail("bad stream");
XX if (rplaca(fptr,cdr(lptr)) == NIL)
XX rplacd(fptr,NIL);
XX ch = cptr->n_int;
XX }
XX }
XX
XX /* otherwise, check for a buffered file character */
XX else if (ch = fptr->n_savech)
XX fptr->n_savech = 0;
XX
XX /* otherwise, get a new character */
XX else {
XX
XX /* get the file pointer */
XX fp = fptr->n_fp;
XX
XX /* prompt if necessary */
XX if (prompt && fp == stdin) {
XX
XX /* print the debug level */
XX if (xldebug)
XX printf("%d:",xldebug);
XX
XX /* print the nesting level */
XX if (xlplevel > 0)
XX printf("%d",xlplevel);
XX
XX /* print the prompt */
XX printf("> ");
XX prompt = FALSE;
XX }
XX
XX /* get the character */
XX if (((ch = getc(fp)) == '\n' || ch == EOF) && fp == stdin)
XX prompt = TRUE;
XX
XX /* check for input abort */
XX if (fp == stdin && ch == '\007') {
XX putchar('\n');
XX xlabort("input aborted");
XX }
XX }
XX
XX /* return the character */
XX return (ch);
XX}
XX
XX/* xlpeek - peek at a character from a file or stream */
XXint xlpeek(fptr)
XX NODE *fptr;
XX{
XX NODE *lptr,*cptr;
XX int ch;
XX
XX /* check for input from nil */
XX if (fptr == NIL)
XX ch = EOF;
XX
XX /* otherwise, check for input from a stream */
XX else if (consp(fptr)) {
XX if ((lptr = car(fptr)) == NIL)
XX ch = EOF;
XX else {
XX if (!consp(lptr) ||
XX (cptr = car(lptr)) == NIL || !fixp(cptr))
XX xlfail("bad stream");
XX ch = cptr->n_int;
XX }
XX }
XX
XX /* otherwise, get the next file character and save it */
XX else
XX ch = fptr->n_savech = xlgetc(fptr);
XX
XX /* return the character */
XX return (ch);
XX}
XX
XX/* xlputc - put a character to a file or stream */
XXxlputc(fptr,ch)
XX NODE *fptr; int ch;
XX{
XX NODE *oldstk,lptr;
XX
XX /* count the character */
XX xlfsize++;
XX
XX /* check for output to nil */
XX if (fptr == NIL)
XX ;
XX
XX /* otherwise, check for output to a stream */
XX else if (consp(fptr)) {
XX oldstk = xlsave(&lptr,NULL);
XX lptr.n_ptr = newnode(LIST);
XX rplaca(lptr.n_ptr,newnode(INT));
XX car(lptr.n_ptr)->n_int = ch;
XX if (cdr(fptr))
XX rplacd(cdr(fptr),lptr.n_ptr);
XX else
XX rplaca(fptr,lptr.n_ptr);
XX rplacd(fptr,lptr.n_ptr);
XX xlstack = oldstk;
XX }
XX
XX /* otherwise, output the character to a file */
XX else
XX putc(ch,fptr->n_fp);
XX}
XX
XX/* xlflush - flush the input buffer */
XXint xlflush()
XX{
XX if (!prompt)
XX while (xlgetc(s_stdin->n_symvalue) != '\n')
XX ;
XX}
SHAR_EOF
if test 2897 -ne "`wc -c xlio.c`"
then
echo shar: error transmitting xlio.c '(should have been 2897 characters)'
fi
echo shar: extracting xlisp.c '(1820 characters)'
sed 's/^XX//' << \SHAR_EOF > xlisp.c
XX/* xlisp - an experimental version of lisp that supports object-oriented
XX programming */
XX
XX#include "xlisp.h"
XX
XX/* define the banner line string */
XX#define BANNER "XLISP version 1.4 - 14-FEB-1985, by David Betz"
XX
XX/* external variables */
XXextern NODE *s_stdin,*s_stdout;
XXextern NODE *s_evalhook,*s_applyhook;
XXextern NODE *true;
XX
XX/* main - the main routine */
XXmain()
XX/*
XXmain(argc,argv)
XX int argc; char *argv[];
XX*/
XX{
XX NODE expr;
XX CONTEXT cntxt;
XX int i;
XX
XX /* print the banner line */
XX#ifdef MEGAMAX
XX _autowin(BANNER);
XX#else
XX printf("%s\n",BANNER);
XX#endif
XX
XX /* setup initialization error handler */
XX xlbegin(&cntxt,CF_ERROR,(NODE *) 1);
XX if (setjmp(cntxt.c_jmpbuf)) {
XX printf("fatal initialization error\n");
XX exit();
XX }
XX
XX /* initialize xlisp */
XX xlinit();
XX xlend(&cntxt);
XX
XX /* reset the error handler */
XX xlbegin(&cntxt,CF_ERROR,true);
XX
XX /* load "init.lsp" */
XX if (setjmp(cntxt.c_jmpbuf) == 0)
XX xlload("init",FALSE,FALSE);
XX
XX /* load any files mentioned on the command line */
XX/**
XX if (setjmp(cntxt.c_jmpbuf) == 0)
XX for (i = 1; i < argc; i++)
XX if (!xlload(argv[i],TRUE,FALSE)) xlfail("can't load file");
XX**/
XX
XX /* create a new stack frame */
XX xlsave(&expr,NULL);
XX
XX /* main command processing loop */
XX while (TRUE) {
XX
XX /* setup the error return */
XX if (setjmp(cntxt.c_jmpbuf)) {
XX s_evalhook->n_symvalue = NIL;
XX s_applyhook->n_symvalue = NIL;
XX xlflush();
XX }
XX
XX /* read an expression */
XX if (!xlread(s_stdin->n_symvalue,&expr.n_ptr))
XX break;
XX
XX /* evaluate the expression */
XX expr.n_ptr = xleval(expr.n_ptr);
XX
XX /* print it */
XX stdprint(expr.n_ptr);
XX }
XX xlend(&cntxt);
XX}
XX
XX/* stdprint - print to standard output */
XXstdprint(expr)
XX NODE *expr;
XX{
XX xlprint(s_stdout->n_symvalue,expr,TRUE);
XX xlterpri(s_stdout->n_symvalue);
XX}
SHAR_EOF
if test 1820 -ne "`wc -c xlisp.c`"
then
echo shar: error transmitting xlisp.c '(should have been 1820 characters)'
fi
echo shar: extracting xlisp.h '(6810 characters)'
sed 's/^XX//' << \SHAR_EOF > xlisp.h
XX/* xlisp - a small subset of lisp */
XX
XX/* system specific definitions */
XX#define UNIX
XX
XX#ifdef AZTEC
XX#include "stdio.h"
XX#include "setjmp.h"
XX#else
XX#include <stdio.h>
XX#include <setjmp.h>
XX#include <ctype.h>
XX#endif
XX
XX/* NNODES number of nodes to allocate in each request */
XX/* TDEPTH trace stack depth */
XX/* FORWARD type of a forward declaration (usually "") */
XX/* LOCAL type of a local function (usually "static") */
XX
XX/* for the Computer Innovations compiler */
XX#ifdef CI
XX#define NNODES 1000
XX#define TDEPTH 500
XX#endif
XX
XX/* for the CPM68K compiler */
XX#ifdef CPM68K
XX#define NNODES 1000
XX#define TDEPTH 500
XX#define LOCAL
XX#define AFMT "%lx"
XX#undef NULL
XX#define NULL (char *)0
XX#endif
XX
XX/* for the DeSmet compiler */
XX#ifdef DESMET
XX#define NNODES 1000
XX#define TDEPTH 500
XX#define LOCAL
XX#define getc(fp) getcx(fp)
XX#define putc(ch,fp) putcx(ch,fp)
XX#define EOF -1
XX#endif
XX
XX/* for the MegaMax compiler */
XX#ifdef MEGAMAX
XX#define NNODES 200
XX#define TDEPTH 100
XX#define LOCAL
XX#define AFMT "%lx"
XX#define TSTKSIZE (4 * TDEPTH)
XX#endif
XX
XX/* for the VAX-11 C compiler */
XX#ifdef vms
XX#define NNODES 2000
XX#define TDEPTH 1000
XX#endif
XX
XX/* for the DECUS C compiler */
XX#ifdef decus
XX#define NNODES 200
XX#define TDEPTH 100
XX#define FORWARD extern
XX#endif
XX
XX/* for unix compilers */
XX#ifdef unix
XX#define NNODES 200
XX#define TDEPTH 100
XX#endif
XX
XX/* for the AZTEC C compiler */
XX#ifdef AZTEC
XX#define NNODES 200
XX#define TDEPTH 100
XX#define getc(fp) agetc(fp)
XX#define putc(ch,fp) aputc(ch,fp)
XX#endif
XX
XX/* default important definitions */
XX#ifndef NNODES
XX#define NNODES 200
XX#endif
XX#ifndef TDEPTH
XX#define TDEPTH 100
XX#endif
XX#ifndef FORWARD
XX#define FORWARD
XX#endif
XX#ifndef LOCAL
XX#define LOCAL static
XX#endif
XX#ifndef AFMT
XX#define AFMT "%x"
XX#endif
XX#ifndef TSTKSIZE
XX#define TSTKSIZE (sizeof(NODE *) * TDEPTH)
XX#endif
XX
XX/* useful definitions */
XX#define TRUE 1
XX#define FALSE 0
XX#define NIL (NODE *)0
XX
XX/* program limits */
XX#define STRMAX 100 /* maximum length of a string constant */
XX
XX/* node types */
XX#define FREE 0
XX#define SUBR 1
XX#define FSUBR 2
XX#define LIST 3
XX#define SYM 4
XX#define INT 5
XX#define STR 6
XX#define OBJ 7
XX#define FPTR 8
XX
XX/* node flags */
XX#define MARK 1
XX#define LEFT 2
XX
XX/* string types */
XX#define DYNAMIC 0
XX#define STATIC 1
XX
XX/* new node access macros */
XX#define ntype(x) ((x)->n_type)
XX#define atom(x) ((x) == NIL || (x)->n_type != LIST)
XX#define null(x) ((x) == NIL)
XX#define listp(x) ((x) == NIL || (x)->n_type == LIST)
XX#define consp(x) ((x) && (x)->n_type == LIST)
XX#define subrp(x) ((x) && (x)->n_type == SUBR)
XX#define fsubrp(x) ((x) && (x)->n_type == FSUBR)
XX#define stringp(x) ((x) && (x)->n_type == STR)
XX#define symbolp(x) ((x) && (x)->n_type == SYM)
XX#define filep(x) ((x) && (x)->n_type == FPTR)
XX#define objectp(x) ((x) && (x)->n_type == OBJ)
XX#define fixp(x) ((x) && (x)->n_type == INT)
XX#define car(x) ((x)->n_car)
XX#define cdr(x) ((x)->n_cdr)
XX#define rplaca(x,y) ((x)->n_car = (y))
XX#define rplacd(x,y) ((x)->n_cdr = (y))
XX
XX/* symbol node */
XX#define n_symplist n_info.n_xsym.xsy_plist
XX#define n_symvalue n_info.n_xsym.xsy_value
XX
XX/* subr/fsubr node */
XX#define n_subr n_info.n_xsubr.xsu_subr
XX
XX/* list node */
XX#define n_car n_info.n_xlist.xl_car
XX#define n_cdr n_info.n_xlist.xl_cdr
XX#define n_ptr n_info.n_xlist.xl_car
XX
XX/* integer node */
XX#define n_int n_info.n_xint.xi_int
XX
XX/* string node */
XX#define n_str n_info.n_xstr.xst_str
XX#define n_strtype n_info.n_xstr.xst_type
XX
XX/* object node */
XX#define n_obclass n_info.n_xobj.xo_obclass
XX#define n_obdata n_info.n_xobj.xo_obdata
XX
XX/* file pointer node */
XX#define n_fp n_info.n_xfptr.xf_fp
XX#define n_savech n_info.n_xfptr.xf_savech
XX
XX/* node structure */
XXtypedef struct node {
XX char n_type; /* type of node */
XX char n_flags; /* flag bits */
XX union { /* value */
XX struct xsym { /* symbol node */
XX struct node *xsy_plist; /* symbol plist - (name . plist) */
XX struct node *xsy_value; /* the current value */
XX } n_xsym;
XX struct xsubr { /* subr/fsubr node */
XX struct node *(*xsu_subr)(); /* pointer to an internal routine */
XX } n_xsubr;
XX struct xlist { /* list node (cons) */
XX struct node *xl_car; /* the car pointer */
XX struct node *xl_cdr; /* the cdr pointer */
XX } n_xlist;
XX struct xint { /* integer node */
XX int xi_int; /* integer value */
XX } n_xint;
XX struct xstr { /* string node */
XX int xst_type; /* string type */
XX char *xst_str; /* string pointer */
XX } n_xstr;
XX struct xobj { /* object node */
XX struct node *xo_obclass; /* class of object */
XX struct node *xo_obdata; /* instance data */
XX } n_xobj;
XX struct xfptr { /* file pointer node */
XX FILE *xf_fp; /* the file pointer */
XX int xf_savech; /* lookahead character for input files */
XX } n_xfptr;
XX } n_info;
XX} NODE;
XX
XX/* execution context flags */
XX#define CF_GO 1
XX#define CF_RETURN 2
XX#define CF_THROW 4
XX#define CF_ERROR 8
XX
XX/* execution context */
XXtypedef struct context {
XX int c_flags; /* context type flags */
XX struct node *c_expr; /* expression (type dependant) */
XX jmp_buf c_jmpbuf; /* longjmp context */
XX struct context *c_xlcontext; /* old value of xlcontext */
XX struct node *c_xlstack; /* old value of xlstack */
XX struct node *c_xlenv,*c_xlnewenv; /* old values of xlenv and xlnewenv */
XX int c_xltrace; /* old value of xltrace */
XX} CONTEXT;
XX
XX/* function table entry structure */
XXstruct fdef {
XX char *f_name; /* function name */
XX int f_type; /* function type SUBR/FSUBR */
XX struct node *(*f_fcn)(); /* function code */
XX};
XX
XX/* memory segment structure definition */
XXstruct segment {
XX int sg_size;
XX struct segment *sg_next;
XX struct node sg_nodes[1];
XX};
XX
XX/* external procedure declarations */
XXextern struct node *xleval(); /* evaluate an expression */
XXextern struct node *xlapply(); /* apply a function to arguments */
XXextern struct node *xlevlist(); /* evaluate a list of arguments */
XXextern struct node *xlarg(); /* fetch an argument */
XXextern struct node *xlevarg(); /* fetch and evaluate an argument */
XXextern struct node *xlmatch(); /* fetch an typed argument */
XXextern struct node *xlevmatch(); /* fetch and evaluate a typed arg */
XXextern struct node *xlsend(); /* send a message to an object */
XXextern struct node *xlenter(); /* enter a symbol */
XXextern struct node *xlsenter(); /* enter a symbol with a static pname */
XXextern struct node *xlintern(); /* intern a symbol */
XXextern struct node *xlmakesym(); /* make an uninterned symbol */
XXextern struct node *xlsave(); /* generate a stack frame */
XXextern struct node *xlobsym(); /* find an object's class or instance
XX variable */
XXextern struct node *xlgetprop(); /* get the value of a property */
XXextern char *xlsymname(); /* get the print name of a symbol */
XX
XXextern struct node *newnode(); /* allocate a new node */
XXextern char *stralloc(); /* allocate string space */
XXextern char *strsave(); /* make a safe copy of a string */
SHAR_EOF
if test 6810 -ne "`wc -c xlisp.h`"
then
echo shar: error transmitting xlisp.h '(should have been 6810 characters)'
fi
echo shar: extracting xljump.c '(2300 characters)'
sed 's/^XX//' << \SHAR_EOF > xljump.c
XX/* xljump - execution context routines */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern CONTEXT *xlcontext;
XXextern NODE *xlvalue;
XXextern NODE *xlstack,*xlenv,*xlnewenv;
XXextern int xltrace,xldebug;
XX
XX/* xlbegin - beginning of an execution context */
XXxlbegin(cptr,flags,expr)
XX CONTEXT *cptr; int flags; NODE *expr;
XX{
XX cptr->c_flags = flags;
XX cptr->c_expr = expr;
XX cptr->c_xlstack = xlstack;
XX cptr->c_xlenv = xlenv;
XX cptr->c_xlnewenv = xlnewenv;
XX cptr->c_xltrace = xltrace;
XX cptr->c_xlcontext = xlcontext;
XX xlcontext = cptr;
XX}
XX
XX/* xlend - end of an execution context */
XXxlend(cptr)
XX CONTEXT *cptr;
XX{
XX xlcontext = cptr->c_xlcontext;
XX}
XX
XX/* xljump - jump to a saved execution context */
XXxljump(cptr,type,val)
XX CONTEXT *cptr; int type; NODE *val;
XX{
XX /* restore the state */
XX xlvalue = val;
XX xlstack = cptr->c_xlstack;
XX xlunbind(cptr->c_xlenv);
XX xlnewenv = cptr->c_xlnewenv;
XX xltrace = cptr->c_xltrace;
XX
XX /* call the handler */
XX longjmp(cptr->c_jmpbuf,type);
XX}
XX
XX/* xlgo - go to a label */
XXxlgo(label)
XX NODE *label;
XX{
XX CONTEXT *cptr;
XX NODE *p;
XX
XX /* find a tagbody context */
XX for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
XX if (cptr->c_flags & CF_GO)
XX for (p = cptr->c_expr; consp(p); p = cdr(p))
XX if (car(p) == label)
XX xljump(cptr,CF_GO,p);
XX xlfail("no target for go");
XX}
XX
XX/* xlreturn - return from a block */
XXxlreturn(val)
XX NODE *val;
XX{
XX CONTEXT *cptr;
XX
XX /* find a block context */
XX for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
XX if (cptr->c_flags & CF_RETURN)
XX xljump(cptr,CF_RETURN,val);
XX xlfail("no target for return");
XX}
XX
XX/* xlthrow - throw to a catch */
XXxlthrow(tag,val)
XX NODE *tag,*val;
XX{
XX CONTEXT *cptr;
XX
XX /* find a catch context */
XX for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
XX if ((cptr->c_flags & CF_THROW) && cptr->c_expr == tag)
XX xljump(cptr,CF_THROW,val);
XX xlfail("no target for throw");
XX}
XX
XX/* xlsignal - signal an error */
XXxlsignal(emsg,arg)
XX char *emsg; NODE *arg;
XX{
XX CONTEXT *cptr;
XX
XX /* find an error catcher */
XX for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
XX if (cptr->c_flags & CF_ERROR) {
XX if (cptr->c_expr)
XX xlerrprint("error",NULL,emsg,arg);
XX xljump(cptr,CF_ERROR,NIL);
XX }
XX xlfail("no target for error");
XX}
SHAR_EOF
if test 2300 -ne "`wc -c xljump.c`"
then
echo shar: error transmitting xljump.c '(should have been 2300 characters)'
fi
echo shar: extracting xlread.c '(8381 characters)'
sed 's/^XX//' << \SHAR_EOF > xlread.c
XX/* xlread - xlisp expression input routine */
XX
XX#include "xlisp.h"
XX#include "ctype.h"
XX
XX/* external variables */
XXextern NODE *s_stdout,*true;
XXextern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
XXextern NODE *xlstack;
XXextern int xlplevel;
XX
XX/* external routines */
XXextern FILE *fopen();
XX
XX/* forward declarations */
XXFORWARD NODE *plist();
XXFORWARD NODE *pstring();
XXFORWARD NODE *pquote();
XXFORWARD NODE *pname();
XX
XX/* xlload - load a file of xlisp expressions */
XXint xlload(name,vflag,pflag)
XX char *name; int vflag,pflag;
XX{
XX NODE *oldstk,fptr,expr;
XX char fname[50];
XX CONTEXT cntxt;
XX int sts;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&fptr,&expr,NULL);
XX
XX /* allocate a file node */
XX fptr.n_ptr = newnode(FPTR);
XX fptr.n_ptr->n_fp = NULL;
XX fptr.n_ptr->n_savech = 0;
XX
XX /* create the file name and print the information line */
XX strcpy(fname,name); strcat(fname,".lsp");
XX if (vflag)
XX printf("; loading \"%s\"\n",fname);
XX
XX /* open the file */
XX if ((fptr.n_ptr->n_fp = fopen(fname,"r")) == NULL) {
XX xlstack = oldstk;
XX return (FALSE);
XX }
XX
XX /* read, evaluate and possibly print each expression in the file */
XX xlbegin(&cntxt,CF_ERROR,true);
XX if (setjmp(cntxt.c_jmpbuf))
XX sts = FALSE;
XX else {
XX while (xlread(fptr.n_ptr,&expr.n_ptr)) {
XX expr.n_ptr = xleval(expr.n_ptr);
XX if (pflag)
XX stdprint(expr.n_ptr);
XX }
XX sts = TRUE;
XX }
XX xlend(&cntxt);
XX
XX /* close the file */
XX fclose(fptr.n_ptr->n_fp);
XX fptr.n_ptr->n_fp = NULL;
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return status */
XX return (sts);
XX}
XX
XX/* xlread - read an xlisp expression */
XXint xlread(fptr,pval)
XX NODE *fptr,**pval;
XX{
XX /* initialize */
XX xlplevel = 0;
XX
XX /* parse an expression */
XX return (parse(fptr,pval));
XX}
XX
XX/* parse - parse an xlisp expression */
XXLOCAL int parse(fptr,pval)
XX NODE *fptr,**pval;
XX{
XX int ch;
XX
XX /* keep looking for a node skipping comments */
XX while (TRUE)
XX
XX /* check next character for type of node */
XX switch (ch = nextch(fptr)) {
XX case EOF:
XX xlgetc(fptr);
XX return (FALSE);
XX case '\'': /* a quoted expression */
XX xlgetc(fptr);
XX *pval = pquote(fptr,s_quote);
XX return (TRUE);
XX case '#': /* a quoted function */
XX xlgetc(fptr);
XX if ((ch = xlgetc(fptr)) == '<')
XX xlfail("unreadable atom");
XX else if (ch != '\'')
XX xlfail("expected quote after #");
XX *pval = pquote(fptr,s_function);
XX return (TRUE);
XX case '`': /* a back quoted expression */
XX xlgetc(fptr);
XX *pval = pquote(fptr,s_bquote);
XX return (TRUE);
XX case ',': /* a comma or comma-at expression */
XX xlgetc(fptr);
XX if (xlpeek(fptr) == '@') {
XX xlgetc(fptr);
XX *pval = pquote(fptr,s_comat);
XX }
XX else
XX *pval = pquote(fptr,s_comma);
XX return (TRUE);
XX case '(': /* a sublist */
XX *pval = plist(fptr);
XX return (TRUE);
XX case ')': /* closing paren - shouldn't happen */
XX xlfail("extra right paren");
XX case '.': /* dot - shouldn't happen */
XX xlfail("misplaced dot");
XX case ';': /* a comment */
XX pcomment(fptr);
XX break;
XX case '"': /* a string */
XX *pval = pstring(fptr);
XX return (TRUE);
XX default:
XX if (issym(ch)) /* a name */
XX *pval = pname(fptr);
XX else
XX xlfail("invalid character");
XX return (TRUE);
XX }
XX}
XX
XX/* pcomment - parse a comment */
XXLOCAL pcomment(fptr)
XX NODE *fptr;
XX{
XX int ch;
XX
XX /* skip to end of line */
XX while ((ch = checkeof(fptr)) != EOF && ch != '\n')
XX ;
XX}
XX
XX/* plist - parse a list */
XXLOCAL NODE *plist(fptr)
XX NODE *fptr;
XX{
XX NODE *oldstk,val,*lastnptr,*nptr,*p;
XX int ch;
XX
XX /* increment the nesting level */
XX xlplevel += 1;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&val,NULL);
XX
XX /* skip the opening paren */
XX xlgetc(fptr);
XX
XX /* keep appending nodes until a closing paren is found */
XX lastnptr = NIL;
XX for (lastnptr = NIL; (ch = nextch(fptr)) != ')'; lastnptr = nptr) {
XX
XX /* check for end of file */
XX if (ch == EOF)
XX badeof(fptr);
XX
XX /* check for a dotted pair */
XX if (ch == '.') {
XX
XX /* skip the dot */
XX xlgetc(fptr);
XX
XX /* make sure there's a node */
XX if (lastnptr == NIL)
XX xlfail("invalid dotted pair");
XX
XX /* parse the expression after the dot */
XX if (!parse(fptr,&p))
XX badeof(fptr);
XX rplacd(lastnptr,p);
XX
XX /* make sure its followed by a close paren */
XX if (nextch(fptr) != ')')
XX xlfail("invalid dotted pair");
XX
XX /* done with this list */
XX break;
XX }
XX
XX /* allocate a new node and link it into the list */
XX nptr = newnode(LIST);
XX if (lastnptr == NIL)
XX val.n_ptr = nptr;
XX else
XX rplacd(lastnptr,nptr);
XX
XX /* initialize the new node */
XX if (!parse(fptr,&p))
XX badeof(fptr);
XX rplaca(nptr,p);
XX }
XX
XX /* skip the closing paren */
XX xlgetc(fptr);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* decrement the nesting level */
XX xlplevel -= 1;
XX
XX /* return successfully */
XX return (val.n_ptr);
XX}
XX
XX/* pstring - parse a string */
XXLOCAL NODE *pstring(fptr)
XX NODE *fptr;
XX{
XX NODE *oldstk,val;
XX char sbuf[STRMAX+1];
XX int ch,i,d1,d2,d3;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&val,NULL);
XX
XX /* skip the opening quote */
XX xlgetc(fptr);
XX
XX /* loop looking for a closing quote */
XX for (i = 0; i < STRMAX && (ch = checkeof(fptr)) != '"'; i++) {
XX switch (ch) {
XX case EOF:
XX badeof(fptr);
XX case '\\':
XX switch (ch = checkeof(fptr)) {
XX case 'e':
XX ch = '\033';
XX break;
XX case 'n':
XX ch = '\n';
XX break;
XX case 'r':
XX ch = '\r';
XX break;
XX case 't':
XX ch = '\t';
XX break;
XX default:
XX if (ch >= '0' && ch <= '7') {
XX d1 = ch - '0';
XX d2 = checkeof(fptr) - '0';
XX d3 = checkeof(fptr) - '0';
XX ch = (d1 << 6) + (d2 << 3) + d3;
XX }
XX break;
XX }
XX }
XX sbuf[i] = ch;
XX }
XX sbuf[i] = 0;
XX
XX /* initialize the node */
XX val.n_ptr = newnode(STR);
XX val.n_ptr->n_str = strsave(sbuf);
XX val.n_ptr->n_strtype = DYNAMIC;
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the new string */
XX return (val.n_ptr);
XX}
XX
XX/* pquote - parse a quoted expression */
XXLOCAL NODE *pquote(fptr,sym)
XX NODE *fptr,*sym;
XX{
XX NODE *oldstk,val,*p;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&val,NULL);
XX
XX /* allocate two nodes */
XX val.n_ptr = newnode(LIST);
XX rplaca(val.n_ptr,sym);
XX rplacd(val.n_ptr,newnode(LIST));
XX
XX /* initialize the second to point to the quoted expression */
XX if (!parse(fptr,&p))
XX badeof(fptr);
XX rplaca(cdr(val.n_ptr),p);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the quoted expression */
XX return (val.n_ptr);
XX}
XX
XX/* pname - parse a symbol name */
XXLOCAL NODE *pname(fptr)
XX NODE *fptr;
XX{
XX char sname[STRMAX+1];
XX NODE *val;
XX int i;
XX
XX /* get symbol name */
XX for (i = 0; i < STRMAX && issym(xlpeek(fptr)); )
XX sname[i++] = xlgetc(fptr);
XX sname[i] = 0;
XX
XX /* check for a number or enter the symbol into the oblist */
XX return (isnumber(sname,&val) ? val : xlenter(sname,DYNAMIC));
XX}
XX
XX/* nextch - look at the next non-blank character */
XXLOCAL int nextch(fptr)
XX NODE *fptr;
XX{
XX int ch;
XX
XX /* return and save the next non-blank character */
XX while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
XX xlgetc(fptr);
XX return (ch);
XX}
XX
XX/* checkeof - get a character and check for end of file */
XXLOCAL int checkeof(fptr)
XX NODE *fptr;
XX{
XX int ch;
XX
XX if ((ch = xlgetc(fptr)) == EOF)
XX badeof(fptr);
XX return (ch);
XX}
XX
XX/* badeof - unexpected eof */
XXLOCAL badeof(fptr)
XX NODE *fptr;
XX{
XX xlgetc(fptr);
XX xlfail("unexpected EOF");
XX}
XX
XX/* isnumber - check if this string is a number */
XXint isnumber(str,pval)
XX char *str; NODE **pval;
XX{
XX char *p;
XX int d;
XX
XX /* initialize */
XX p = str; d = 0;
XX
XX /* check for a sign */
XX if (*p == '+' || *p == '-')
XX p++;
XX
XX /* check for a string of digits */
XX while (isdigit(*p))
XX p++, d++;
XX
XX /* make sure there was at least one digit and this is the end */
XX if (d == 0 || *p)
XX return (FALSE);
XX
XX /* convert the string to an integer and return successfully */
XX *pval = newnode(INT);
XX (*pval)->n_int = atoi(*str == '+' ? ++str : str);
XX return (TRUE);
XX}
XX
XX/* issym - check whether a character if valid in a symbol name */
XXLOCAL int issym(ch)
XX int ch;
XX{
XX if (ch <= ' ' || ch >= 0177 ||
XX ch == '(' ||
XX ch == ')' ||
XX ch == ';' ||
XX ch == ',' ||
XX ch == '`' ||
XX ch == '"' ||
XX ch == '\'')
XX return (FALSE);
XX else
XX return (TRUE);
XX}
SHAR_EOF
if test 8381 -ne "`wc -c xlread.c`"
then
echo shar: error transmitting xlread.c '(should have been 8381 characters)'
fi
echo shar: extracting xlsetf.c '(1884 characters)'
sed 's/^XX//' << \SHAR_EOF > xlsetf.c
XX/* xlsetf - set field function */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern NODE *s_car,*s_cdr,*s_get,*s_svalue,*s_splist;
XXextern NODE *xlstack;
XX
XX/* xsetf - built-in function 'setf' */
XXNODE *xsetf(args)
XX NODE *args;
XX{
XX NODE *oldstk,arg,place,value;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&arg,&place,&value,NULL);
XX
XX /* initialize */
XX arg.n_ptr = args;
XX
XX /* handle each pair of arguments */
XX while (arg.n_ptr) {
XX
XX /* get place and value */
XX place.n_ptr = xlarg(&arg.n_ptr);
XX value.n_ptr = xlevarg(&arg.n_ptr);
XX
XX /* check the place form */
XX if (symbolp(place.n_ptr))
XX assign(place.n_ptr,value.n_ptr);
XX else if (consp(place.n_ptr))
XX placeform(place.n_ptr,value.n_ptr);
XX else
XX xlfail("bad place form");
XX }
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the value */
XX return (value.n_ptr);
XX}
XX
XX/* placeform - handle a place form other than a symbol */
XXLOCAL placeform(place,value)
XX NODE *place,*value;
XX{
XX NODE *fun,*oldstk,arg1,arg2;
XX
XX /* check the function name */
XX if ((fun = xlmatch(SYM,&place)) == s_get) {
XX oldstk = xlsave(&arg1,&arg2,NULL);
XX arg1.n_ptr = xlevmatch(SYM,&place);
XX arg2.n_ptr = xlevmatch(SYM,&place);
XX xllastarg(place);
XX xlputprop(arg1.n_ptr,value,arg2.n_ptr);
XX xlstack = oldstk;
XX }
XX else if (fun == s_svalue || fun == s_splist) {
XX oldstk = xlsave(&arg1,NULL);
XX arg1.n_ptr = xlevmatch(SYM,&place);
XX xllastarg(place);
XX if (fun == s_svalue)
XX arg1.n_ptr->n_symvalue = value;
XX else
XX rplacd(arg1.n_ptr->n_symplist,value);
XX xlstack = oldstk;
XX }
XX else if (fun == s_car || fun == s_cdr) {
XX oldstk = xlsave(&arg1,NULL);
XX arg1.n_ptr = xlevmatch(LIST,&place);
XX xllastarg(place);
XX if (consp(arg1.n_ptr))
XX if (fun == s_car)
XX rplaca(arg1.n_ptr,value);
XX else
XX rplacd(arg1.n_ptr,value);
XX xlstack = oldstk;
XX }
XX else
XX xlfail("bad place form");
XX}
SHAR_EOF
if test 1884 -ne "`wc -c xlsetf.c`"
then
echo shar: error transmitting xlsetf.c '(should have been 1884 characters)'
fi
echo shar: extracting xlstr.c '(4134 characters)'
sed 's/^XX//' << \SHAR_EOF > xlstr.c
XX/* xlstr - xlisp string builtin functions */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern NODE *xlstack;
XX
XX/* external procedures */
XXextern char *strcat();
XX
XX/* xstrlen - length of a string */
XXNODE *xstrlen(args)
XX NODE *args;
XX{
XX NODE *val;
XX int total;
XX
XX /* initialize */
XX total = 0;
XX
XX /* loop over args and total */
XX while (args)
XX total += strlen(xlmatch(STR,&args)->n_str);
XX
XX /* create the value node */
XX val = newnode(INT);
XX val->n_int = total;
XX
XX /* return the total */
XX return (val);
XX}
XX
XX/* xstrcat - concatenate a bunch of strings */
XXNODE *xstrcat(args)
XX NODE *args;
XX{
XX NODE *oldstk,val,*p;
XX char *str;
XX int len;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&val,NULL);
XX
XX /* find the length of the new string */
XX for (p = args, len = 0; p; )
XX len += strlen(xlmatch(STR,&p)->n_str);
XX
XX /* create the result string */
XX val.n_ptr = newnode(STR);
XX val.n_ptr->n_str = str = stralloc(len);
XX *str = 0;
XX
XX /* combine the strings */
XX while (args)
XX strcat(str,xlmatch(STR,&args)->n_str);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the new string */
XX return (val.n_ptr);
XX}
XX
XX/* xsubstr - return a substring */
XXNODE *xsubstr(args)
XX NODE *args;
XX{
XX NODE *oldstk,arg,src,val;
XX int start,forlen,srclen;
XX char *srcptr,*dstptr;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&arg,&src,&val,NULL);
XX
XX /* initialize */
XX arg.n_ptr = args;
XX
XX /* get string and its length */
XX src.n_ptr = xlmatch(STR,&arg.n_ptr);
XX srcptr = src.n_ptr->n_str;
XX srclen = strlen(srcptr);
XX
XX /* get starting pos -- must be present */
XX start = xlmatch(INT,&arg.n_ptr)->n_int;
XX
XX /* get length -- if not present use remainder of string */
XX forlen = (arg.n_ptr ? xlmatch(INT,&arg.n_ptr)->n_int : srclen);
XX
XX /* make sure there aren't any more arguments */
XX xllastarg(arg.n_ptr);
XX
XX /* don't take more than exists */
XX if (start + forlen > srclen)
XX forlen = srclen - start + 1;
XX
XX /* if start beyond string -- return null string */
XX if (start > srclen) {
XX start = 1;
XX forlen = 0; }
XX
XX /* create return node */
XX val.n_ptr = newnode(STR);
XX val.n_ptr->n_str = dstptr = stralloc(forlen);
XX
XX /* move string */
XX for (srcptr += start-1; forlen--; *dstptr++ = *srcptr++)
XX ;
XX *dstptr = 0;
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the substring */
XX return (val.n_ptr);
XX}
XX
XX/* xascii - return ascii value */
XXNODE *xascii(args)
XX NODE *args;
XX{
XX NODE *val;
XX
XX /* build return node */
XX val = newnode(INT);
XX val->n_int = *(xlmatch(STR,&args)->n_str);
XX
XX /* make sure there aren't any more arguments */
XX xllastarg(args);
XX
XX /* return the character */
XX return (val);
XX}
XX
XX/* xchr - convert an INT into a one character ascii string */
XXNODE *xchr(args)
XX NODE *args;
XX{
XX NODE *oldstk,val;
XX char *sptr;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&val,NULL);
XX
XX /* build return node */
XX val.n_ptr = newnode(STR);
XX val.n_ptr->n_str = sptr = stralloc(1);
XX *sptr++ = xlmatch(INT,&args)->n_int;
XX *sptr = 0;
XX
XX /* make sure there aren't any more arguments */
XX xllastarg(args);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the new string */
XX return (val.n_ptr);
XX}
XX
XX/* xatoi - convert an ascii string to an integer */
XXNODE *xatoi(args)
XX NODE *args;
XX{
XX NODE *val;
XX int n;
XX
XX /* get the string and convert it */
XX n = atoi(xlmatch(STR,&args)->n_str);
XX
XX /* make sure there aren't any more arguments */
XX xllastarg(args);
XX
XX /* create the value node */
XX val = newnode(INT);
XX val->n_int = n;
XX
XX /* return the number */
XX return (val);
XX}
XX
XX/* xitoa - convert an integer to an ascii string */
XXNODE *xitoa(args)
XX NODE *args;
XX{
XX NODE *val;
XX char buf[20];
XX int n;
XX
XX /* get the integer */
XX n = xlmatch(INT,&args)->n_int;
XX xllastarg(args);
XX
XX /* convert it to ascii */
XX sprintf(buf,"%d",n);
XX
XX /* create the value node */
XX val = newnode(STR);
XX val->n_str = strsave(buf);
XX
XX /* return the string */
XX return (val);
XX}
SHAR_EOF
if test 4134 -ne "`wc -c xlstr.c`"
then
echo shar: error transmitting xlstr.c '(should have been 4134 characters)'
fi
# End of shell archive
exit 0wegrzyn@encore.UUCP (Chuck Wegrzyn) (03/13/85)
# This is a shell archive.
# Remove everything above and including the cut line.
# Then run the rest of the file through sh.
-----cut here-----cut here-----cut here-----cut here-----
#!/bin/sh
# shar: Shell Archiver
# Run the following text with /bin/sh to create:
# xleval.c
# xlfio.c
# xlftab.c
# xlglob.c
# xlinit.c
# xlmath.c
# xlprin.c
# xlstub.c.NOTUSED
# xlsubr.c
# xlsym.c
# xlsys.c
# This archive created: Wed Mar 13 08:37:11 1985
echo shar: extracting xleval.c '(7688 characters)'
sed 's/^XX//' << \SHAR_EOF > xleval.c
XX/* xleval - xlisp evaluator */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern NODE *xlstack,*xlenv,*xlnewenv;
XXextern NODE *s_lambda,*s_macro;
XXextern NODE *k_optional,*k_rest,*k_aux;
XXextern NODE *s_evalhook,*s_applyhook;
XXextern NODE *s_unbound;
XXextern NODE *s_stdout;
XX
XX/* forward declarations */
XXFORWARD NODE *xlxeval();
XXFORWARD NODE *evalhook();
XXFORWARD NODE *evform();
XXFORWARD NODE *evsym();
XXFORWARD NODE *evfun();
XX
XX/* xleval - evaluate an xlisp expression (checking for *evalhook*) */
XXNODE *xleval(expr)
XX NODE *expr;
XX{
XX return (s_evalhook->n_symvalue ? evalhook(expr) : xlxeval(expr));
XX}
XX
XX/* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
XXNODE *xlxeval(expr)
XX NODE *expr;
XX{
XX /* evaluate nil to itself */
XX if (expr == NIL)
XX return (NIL);
XX
XX /* add trace entry */
XX xltpush(expr);
XX
XX /* check type of value */
XX if (consp(expr))
XX expr = evform(expr);
XX else if (symbolp(expr))
XX expr = evsym(expr);
XX
XX /* remove trace entry */
XX xltpop();
XX
XX /* return the value */
XX return (expr);
XX}
XX
XX/* xlapply - apply a function to a list of arguments */
XXNODE *xlapply(fun,args)
XX NODE *fun,*args;
XX{
XX NODE *val;
XX
XX /* check for a null function */
XX if (fun == NIL)
XX xlfail("bad function");
XX
XX /* evaluate the function */
XX if (subrp(fun))
XX val = (*fun->n_subr)(args);
XX else if (consp(fun)) {
XX if (car(fun) != s_lambda)
XX xlfail("bad function type");
XX val = evfun(fun,args);
XX }
XX else
XX xlfail("bad function");
XX
XX /* return the result value */
XX return (val);
XX}
XX
XX/* evform - evaluate a form */
XXLOCAL NODE *evform(expr)
XX NODE *expr;
XX{
XX NODE *oldstk,fun,args,*val,*type;
XX
XX /* create a stack frame */
XX oldstk = xlsave(&fun,&args,NULL);
XX
XX /* get the function and the argument list */
XX fun.n_ptr = car(expr);
XX args.n_ptr = cdr(expr);
XX
XX /* evaluate the first expression */
XX if ((fun.n_ptr = xleval(fun.n_ptr)) == NIL)
XX xlfail("bad function");
XX
XX /* evaluate the function */
XX if (subrp(fun.n_ptr) || fsubrp(fun.n_ptr)) {
XX if (subrp(fun.n_ptr))
XX args.n_ptr = xlevlist(args.n_ptr);
XX val = (*fun.n_ptr->n_subr)(args.n_ptr);
XX }
XX else if (consp(fun.n_ptr)) {
XX if ((type = car(fun.n_ptr)) == s_lambda) {
XX args.n_ptr = xlevlist(args.n_ptr);
XX val = evfun(fun.n_ptr,args.n_ptr);
XX }
XX else if (type == s_macro) {
XX args.n_ptr = evfun(fun.n_ptr,args.n_ptr);
XX val = xleval(args.n_ptr);
XX }
XX else
XX xlfail("bad function type");
XX }
XX else if (objectp(fun.n_ptr))
XX val = xlsend(fun.n_ptr,args.n_ptr);
XX else
XX xlfail("bad function");
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the result value */
XX return (val);
XX}
XX
XX/* evalhook - call the evalhook function */
XXLOCAL NODE *evalhook(expr)
XX NODE *expr;
XX{
XX NODE *oldstk,*oldenv,fun,args,*val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&fun,&args,NULL);
XX
XX /* get the hook function */
XX fun.n_ptr = s_evalhook->n_symvalue;
XX
XX /* make an argument list */
XX args.n_ptr = newnode(LIST);
XX rplaca(args.n_ptr,expr);
XX
XX /* rebind the hook functions to nil */
XX oldenv = xlenv;
XX xlsbind(s_evalhook,NIL);
XX xlsbind(s_applyhook,NIL);
XX
XX /* call the hook function */
XX val = xlapply(fun.n_ptr,args.n_ptr);
XX
XX /* unbind the symbols */
XX xlunbind(oldenv);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the value */
XX return (val);
XX}
XX
XX/* xlevlist - evaluate a list of arguments */
XXNODE *xlevlist(args)
XX NODE *args;
XX{
XX NODE *oldstk,src,dst,*new,*last,*val;
XX
XX /* create a stack frame */
XX oldstk = xlsave(&src,&dst,NULL);
XX
XX /* initialize */
XX src.n_ptr = args;
XX
XX /* evaluate each argument */
XX for (val = NIL; src.n_ptr; src.n_ptr = cdr(src.n_ptr)) {
XX
XX /* check this entry */
XX if (!consp(src.n_ptr))
XX xlfail("bad argument list");
XX
XX /* allocate a new list entry */
XX new = newnode(LIST);
XX if (val)
XX rplacd(last,new);
XX else
XX val = dst.n_ptr = new;
XX rplaca(new,xleval(car(src.n_ptr)));
XX last = new;
XX }
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the new list */
XX return (val);
XX}
XX
XX/* evsym - evaluate a symbol */
XXLOCAL NODE *evsym(sym)
XX NODE *sym;
XX{
XX NODE *p;
XX
XX /* check for a reference to an instance variable */
XX if ((p = xlobsym(sym)) != NIL)
XX return (car(p));
XX
XX /* get the value of the variable */
XX while ((p = sym->n_symvalue) == s_unbound)
XX xlunbound(sym);
XX
XX /* return the value */
XX return (p);
XX}
XX
XX/* xlunbound - signal an unbound variable error */
XXxlunbound(sym)
XX NODE *sym;
XX{
XX xlcerror("try evaluating symbol again","unbound variable",sym);
XX}
XX
XX/* evfun - evaluate a function */
XXLOCAL NODE *evfun(fun,args)
XX NODE *fun,*args;
XX{
XX NODE *oldstk,*oldenv,*oldnewenv,cptr,*fargs,*val;
XX
XX /* create a stack frame */
XX oldstk = xlsave(&cptr,NULL);
XX
XX /* skip the function type */
XX if ((fun = cdr(fun)) == NIL || !consp(fun))
XX xlfail("bad function definition");
XX
XX /* get the formal argument list */
XX if ((fargs = car(fun)) && !consp(fargs))
XX xlfail("bad formal argument list");
XX
XX /* bind the formal parameters */
XX oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
XX xlabind(fargs,args);
XX xlfixbindings();
XX
XX /* execute the code */
XX for (cptr.n_ptr = cdr(fun); cptr.n_ptr != NIL; )
XX val = xlevarg(&cptr.n_ptr);
XX
XX /* restore the environment */
XX xlunbind(oldenv); xlnewenv = oldnewenv;
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the result value */
XX return (val);
XX}
XX
XX/* xlabind - bind the arguments for a function */
XXxlabind(fargs,aargs)
XX NODE *fargs,*aargs;
XX{
XX NODE *arg;
XX
XX /* evaluate and bind each required argument */
XX while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
XX
XX /* bind the formal variable to the argument value */
XX xlbind(arg,car(aargs));
XX
XX /* move the argument list pointers ahead */
XX fargs = cdr(fargs);
XX aargs = cdr(aargs);
XX }
XX
XX /* check for the '&optional' keyword */
XX if (consp(fargs) && car(fargs) == k_optional) {
XX fargs = cdr(fargs);
XX
XX /* bind the arguments that were supplied */
XX while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
XX
XX /* bind the formal variable to the argument value */
XX xlbind(arg,car(aargs));
XX
XX /* move the argument list pointers ahead */
XX fargs = cdr(fargs);
XX aargs = cdr(aargs);
XX }
XX
XX /* bind the rest to nil */
XX while (consp(fargs) && !iskeyword(arg = car(fargs))) {
XX
XX /* bind the formal variable to nil */
XX xlbind(arg,NIL);
XX
XX /* move the argument list pointer ahead */
XX fargs = cdr(fargs);
XX }
XX }
XX
XX /* check for the '&rest' keyword */
XX if (consp(fargs) && car(fargs) == k_rest) {
XX fargs = cdr(fargs);
XX if (consp(fargs) && (arg = car(fargs)) && !iskeyword(arg))
XX xlbind(arg,aargs);
XX else
XX xlfail("symbol missing after &rest");
XX fargs = cdr(fargs);
XX aargs = NIL;
XX }
XX
XX /* check for the '&aux' keyword */
XX if (consp(fargs) && car(fargs) == k_aux)
XX while ((fargs = cdr(fargs)) != NIL && consp(fargs))
XX xlbind(car(fargs),NIL);
XX
XX /* make sure the correct number of arguments were supplied */
XX if (fargs != aargs)
XX xlfail(fargs ? "too few arguments" : "too many arguments");
XX}
XX
XX/* iskeyword - check to see if a symbol is a keyword */
XXLOCAL int iskeyword(sym)
XX NODE *sym;
XX{
XX return (sym == k_optional || sym == k_rest || sym == k_aux);
XX}
XX
XX/* xlsave - save nodes on the stack */
XXNODE *xlsave(n)
XX NODE *n;
XX{
XX NODE **nptr,*oldstk;
XX
XX /* save the old stack pointer */
XX oldstk = xlstack;
XX
XX /* save each node */
XX for (nptr = &n; *nptr != NULL; nptr++) {
XX rplaca(*nptr,NIL);
XX rplacd(*nptr,xlstack);
XX xlstack = *nptr;
XX }
XX
XX /* return the old stack pointer */
XX return (oldstk);
XX}
SHAR_EOF
if test 7688 -ne "`wc -c xleval.c`"
then
echo shar: error transmitting xleval.c '(should have been 7688 characters)'
fi
echo shar: extracting xlfio.c '(8960 characters)'
sed 's/^XX//' << \SHAR_EOF > xlfio.c
XX/* xlfio.c - xlisp file i/o */
XX
XX#include "xlisp.h"
XX#include "ctype.h"
XX
XX/* external variables */
XXextern NODE *s_stdin,*s_stdout;
XXextern NODE *xlstack;
XXextern int xlfsize;
XXextern char buf[];
XX
XX/* external routines */
XXextern FILE *fopen();
XX
XX/* forward declarations */
XXFORWARD NODE *printit();
XXFORWARD NODE *flatsize();
XXFORWARD NODE *explode();
XXFORWARD NODE *implode();
XXFORWARD NODE *openit();
XXFORWARD NODE *getfile();
XX
XX/* xread - read an expression */
XXNODE *xread(args)
XX NODE *args;
XX{
XX NODE *oldstk,fptr,eof,*val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&fptr,&eof,NULL);
XX
XX /* get file pointer and eof value */
XX fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
XX eof.n_ptr = (args ? xlarg(&args) : NIL);
XX xllastarg(args);
XX
XX /* read an expression */
XX if (!xlread(fptr.n_ptr,&val))
XX val = eof.n_ptr;
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the expression */
XX return (val);
XX}
XX
XX/* xprint - builtin function 'print' */
XXNODE *xprint(args)
XX NODE *args;
XX{
XX return (printit(args,TRUE,TRUE));
XX}
XX
XX/* xprin1 - builtin function 'prin1' */
XXNODE *xprin1(args)
XX NODE *args;
XX{
XX return (printit(args,TRUE,FALSE));
XX}
XX
XX/* xprinc - builtin function princ */
XXNODE *xprinc(args)
XX NODE *args;
XX{
XX return (printit(args,FALSE,FALSE));
XX}
XX
XX/* xterpri - terminate the current print line */
XXNODE *xterpri(args)
XX NODE *args;
XX{
XX NODE *fptr;
XX
XX /* get file pointer */
XX fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
XX xllastarg(args);
XX
XX /* terminate the print line and return nil */
XX xlterpri(fptr);
XX return (NIL);
XX}
XX
XX/* printit - common print function */
XXLOCAL NODE *printit(args,pflag,tflag)
XX NODE *args; int pflag,tflag;
XX{
XX NODE *oldstk,fptr,val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&fptr,&val,NULL);
XX
XX /* get expression to print and file pointer */
XX val.n_ptr = xlarg(&args);
XX fptr.n_ptr = (args ? getfile(&args) : s_stdout->n_symvalue);
XX xllastarg(args);
XX
XX /* print the value */
XX xlprint(fptr.n_ptr,val.n_ptr,pflag);
XX
XX /* terminate the print line if necessary */
XX if (tflag)
XX xlterpri(fptr.n_ptr);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the result */
XX return (val.n_ptr);
XX}
XX
XX/* xflatsize - compute the size of a printed representation using prin1 */
XXNODE *xflatsize(args)
XX NODE *args;
XX{
XX return (flatsize(args,TRUE));
XX}
XX
XX/* xflatc - compute the size of a printed representation using princ */
XXNODE *xflatc(args)
XX NODE *args;
XX{
XX return (flatsize(args,FALSE));
XX}
XX
XX/* flatsize - compute the size of a printed expression */
XXLOCAL NODE *flatsize(args,pflag)
XX NODE *args; int pflag;
XX{
XX NODE *oldstk,val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&val,NULL);
XX
XX /* get the expression */
XX val.n_ptr = xlarg(&args);
XX xllastarg(args);
XX
XX /* print the value to compute its size */
XX xlfsize = 0;
XX xlprint(NIL,val.n_ptr,pflag);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the length of the expression */
XX val.n_ptr = newnode(INT);
XX val.n_ptr->n_int = xlfsize;
XX return (val.n_ptr);
XX}
XX
XX/* xexplode - explode an expression */
XXNODE *xexplode(args)
XX NODE *args;
XX{
XX return (explode(args,TRUE));
XX}
XX
XX/* xexplc - explode an expression using princ */
XXNODE *xexplc(args)
XX NODE *args;
XX{
XX return (explode(args,FALSE));
XX}
XX
XX/* explode - internal explode routine */
XXLOCAL NODE *explode(args,pflag)
XX NODE *args; int pflag;
XX{
XX NODE *oldstk,val,strm;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&val,&strm,NULL);
XX
XX /* get the expression */
XX val.n_ptr = xlarg(&args);
XX xllastarg(args);
XX
XX /* create a stream */
XX strm.n_ptr = newnode(LIST);
XX
XX /* print the value into the stream */
XX xlprint(strm.n_ptr,val.n_ptr,pflag);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the list of characters */
XX return (car(strm.n_ptr));
XX}
XX
XX/* ximplode - implode a list of characters into a symbol */
XXNODE *ximplode(args)
XX NODE *args;
XX{
XX return (implode(args,TRUE));
XX}
XX
XX/* xmaknam - implode a list of characters into an uninterned symbol */
XXNODE *xmaknam(args)
XX NODE *args;
XX{
XX return (implode(args,FALSE));
XX}
XX
XX/* implode - internal implode routine */
XXLOCAL NODE *implode(args,intflag)
XX NODE *args; int intflag;
XX{
XX NODE *list,*val;
XX char *p;
XX
XX /* get the list */
XX list = xlarg(&args);
XX xllastarg(args);
XX
XX /* assemble the symbol's pname */
XX for (p = buf; consp(list); list = cdr(list)) {
XX if ((val = car(list)) == NIL || !fixp(val))
XX xlfail("bad character list");
XX if ((int)(p - buf) < STRMAX)
XX *p++ = val->n_int;
XX }
XX *p = 0;
XX
XX /* create a symbol */
XX val = (intflag ? xlenter(buf,DYNAMIC) : xlmakesym(buf,DYNAMIC));
XX
XX /* return the symbol */
XX return (val);
XX}
XX
XX/* xopeni - open an input file */
XXNODE *xopeni(args)
XX NODE *args;
XX{
XX return (openit(args,"r"));
XX}
XX
XX/* xopeno - open an output file */
XXNODE *xopeno(args)
XX NODE *args;
XX{
XX return (openit(args,"w"));
XX}
XX
XX/* openit - common file open routine */
XXLOCAL NODE *openit(args,mode)
XX NODE *args; char *mode;
XX{
XX NODE *fname,*val;
XX FILE *fp;
XX
XX /* get the file name */
XX fname = xlmatch(STR,&args);
XX xllastarg(args);
XX
XX /* try to open the file */
XX if ((fp = fopen(fname->n_str,mode)) != NULL) {
XX val = newnode(FPTR);
XX val->n_fp = fp;
XX val->n_savech = 0;
XX }
XX else
XX val = NIL;
XX
XX /* return the file pointer */
XX return (val);
XX}
XX
XX/* xclose - close a file */
XXNODE *xclose(args)
XX NODE *args;
XX{
XX NODE *fptr;
XX
XX /* get file pointer */
XX fptr = xlmatch(FPTR,&args);
XX xllastarg(args);
XX
XX /* make sure the file exists */
XX if (fptr->n_fp == NULL)
XX xlfail("file not open");
XX
XX /* close the file */
XX fclose(fptr->n_fp);
XX fptr->n_fp = NULL;
XX
XX /* return nil */
XX return (NIL);
XX}
XX
XX/* xrdchar - read a character from a file */
XXNODE *xrdchar(args)
XX NODE *args;
XX{
XX NODE *fptr,*val;
XX int ch;
XX
XX /* get file pointer */
XX fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
XX xllastarg(args);
XX
XX /* get character and check for eof */
XX if ((ch = xlgetc(fptr)) == EOF)
XX val = NIL;
XX else {
XX val = newnode(INT);
XX val->n_int = ch;
XX }
XX
XX /* return the character */
XX return (val);
XX}
XX
XX/* xpkchar - peek at a character from a file */
XXNODE *xpkchar(args)
XX NODE *args;
XX{
XX NODE *flag,*fptr,*val;
XX int ch;
XX
XX /* peek flag and get file pointer */
XX flag = (args ? xlarg(&args) : NIL);
XX fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
XX xllastarg(args);
XX
XX /* skip leading white space and get a character */
XX if (flag)
XX while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
XX xlgetc(fptr);
XX else
XX ch = xlpeek(fptr);
XX
XX /* check for eof */
XX if (ch == EOF)
XX val = NIL;
XX else {
XX val = newnode(INT);
XX val->n_int = ch;
XX }
XX
XX /* return the character */
XX return (val);
XX}
XX
XX/* xwrchar - write a character to a file */
XXNODE *xwrchar(args)
XX NODE *args;
XX{
XX NODE *fptr,*chr;
XX
XX /* get the character and file pointer */
XX chr = xlmatch(INT,&args);
XX fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
XX xllastarg(args);
XX
XX /* put character to the file */
XX xlputc(fptr,chr->n_int);
XX
XX /* return the character */
XX return (chr);
XX}
XX
XX/* xreadline - read a line from a file */
XXNODE *xreadline(args)
XX NODE *args;
XX{
XX NODE *oldstk,fptr,str;
XX char *p,*sptr;
XX int len,ch;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&fptr,&str,NULL);
XX
XX /* get file pointer */
XX fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
XX xllastarg(args);
XX
XX /* make a string node */
XX str.n_ptr = newnode(STR);
XX str.n_ptr->n_strtype = DYNAMIC;
XX
XX /* get character and check for eof */
XX len = 0; p = buf;
XX while ((ch = xlgetc(fptr.n_ptr)) != EOF && ch != '\n') {
XX
XX /* check for buffer overflow */
XX if ((int)(p - buf) == STRMAX) {
XX *p = 0;
XX sptr = stralloc(len + STRMAX); *sptr = 0;
XX if (len) {
XX strcpy(sptr,str.n_ptr->n_str);
XX strfree(str.n_ptr->n_str);
XX }
XX str.n_ptr->n_str = sptr;
XX strcat(sptr,buf);
XX len += STRMAX;
XX p = buf;
XX }
XX
XX /* store the character */
XX *p++ = ch;
XX }
XX
XX /* check for end of file */
XX if (len == 0 && p == buf && ch == EOF) {
XX xlstack = oldstk;
XX return (NIL);
XX }
XX
XX /* append the last substring */
XX *p = 0;
XX sptr = stralloc(len + (int)(p - buf)); *sptr = 0;
XX if (len) {
XX strcpy(sptr,str.n_ptr->n_str);
XX strfree(str.n_ptr->n_str);
XX }
XX str.n_ptr->n_str = sptr;
XX strcat(sptr,buf);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the string */
XX return (str.n_ptr);
XX}
XX
XX/* getfile - get a file or stream */
XXLOCAL NODE *getfile(pargs)
XX NODE **pargs;
XX{
XX NODE *arg;
XX
XX /* get a file or stream (cons) or nil */
XX if (arg = xlarg(pargs)) {
XX if (filep(arg)) {
XX if (arg->n_fp == NULL)
XX xlfail("file not open");
XX }
XX else if (!consp(arg))
XX xlfail("bad argument type");
XX }
XX return (arg);
XX}
SHAR_EOF
if test 8960 -ne "`wc -c xlfio.c`"
then
echo shar: error transmitting xlfio.c '(should have been 8960 characters)'
fi
echo shar: extracting xlftab.c '(5998 characters)'
sed 's/^XX//' << \SHAR_EOF > xlftab.c
XX/* xlftab.c - xlisp function table */
XX
XX#include "xlisp.h"
XX
XX/* external functions */
XXextern NODE
XX *xeval(),*xapply(),*xfuncall(),*xquote(),*xbquote(),
XX *xset(),*xsetq(),*xsetf(),*xdefun(),*xdefmacro(),
XX *xgensym(),*xmakesymbol(),*xintern(),
XX *xsymname(),*xsymvalue(),*xsymplist(),*xget(),*xremprop(),
XX *xcar(),*xcaar(),*xcadr(),*xcdr(),*xcdar(),*xcddr(),
XX *xcons(),*xlist(),*xappend(),*xreverse(),*xlast(),*xnth(),*xnthcdr(),
XX *xmember(),*xassoc(),*xsubst(),*xsublis(),*xremove(),*xlength(),
XX *xmapc(),*xmapcar(),*xmapl(),*xmaplist(),
XX *xrplca(),*xrplcd(),*xnconc(),*xdelete(),
XX *xatom(),*xsymbolp(),*xnumberp(),*xboundp(),*xnull(),*xlistp(),*xconsp(),
XX *xeq(),*xeql(),*xequal(),
XX *xcond(),*xand(),*xor(),*xlet(),*xletstar(),*xif(),
XX *xprog(),*xprogstar(),*xprog1(),*xprog2(),*xprogn(),*xgo(),*xreturn(),
XX *xcatch(),*xthrow(),
XX *xerror(),*xcerror(),*xbreak(),*xerrset(),*xbaktrace(),*xevalhook(),
XX *xdo(),*xdostar(),*xdolist(),*xdotimes(),
XX *xadd(),*xsub(),*xmul(),*xdiv(),*xrem(),*xmin(),*xmax(),*xabs(),
XX *xadd1(),*xsub1(),*xbitand(),*xbitior(),*xbitxor(),*xbitnot(),
XX *xminusp(),*xzerop(),*xplusp(),*xevenp(),*xoddp(),
XX *xlss(),*xleq(),*xequ(),*xneq(),*xgeq(),*xgtr(),
XX *xstrlen(),*xstrcat(),*xsubstr(),*xascii(),*xchr(),*xatoi(),*xitoa(),
XX *xread(),*xprint(),*xprin1(),*xprinc(),*xterpri(),
XX *xflatsize(),*xflatc(),*xexplode(),*xexplc(),*ximplode(),*xmaknam(),
XX *xopeni(),*xopeno(),*xclose(),*xrdchar(),*xpkchar(),*xwrchar(),*xreadline(),
XX *xload(),*xgc(),*xexpand(),*xalloc(),*xmem(),*xtype(),*xexit();
XX
XX/* the function table */
XXstruct fdef ftab[] = {
XX
XX /* evaluator functions */
XX{ "eval", SUBR, xeval },
XX{ "apply", SUBR, xapply },
XX{ "funcall", SUBR, xfuncall },
XX{ "quote", FSUBR, xquote },
XX{ "function", FSUBR, xquote },
XX{ "backquote", FSUBR, xbquote },
XX
XX /* symbol functions */
XX{ "set", SUBR, xset },
XX{ "setq", FSUBR, xsetq },
XX{ "setf", FSUBR, xsetf },
XX{ "defun", FSUBR, xdefun },
XX{ "defmacro", FSUBR, xdefmacro },
XX{ "gensym", SUBR, xgensym },
XX{ "make-symbol", SUBR, xmakesymbol },
XX{ "intern", SUBR, xintern },
XX{ "symbol-name", SUBR, xsymname },
XX{ "symbol-value", SUBR, xsymvalue },
XX{ "symbol-plist", SUBR, xsymplist },
XX{ "get", SUBR, xget },
XX{ "remprop", SUBR, xremprop },
XX
XX /* list functions */
XX{ "car", SUBR, xcar },
XX{ "caar", SUBR, xcaar },
XX{ "cadr", SUBR, xcadr },
XX{ "cdr", SUBR, xcdr },
XX{ "cdar", SUBR, xcdar },
XX{ "cddr", SUBR, xcddr },
XX{ "cons", SUBR, xcons },
XX{ "list", SUBR, xlist },
XX{ "append", SUBR, xappend },
XX{ "reverse", SUBR, xreverse },
XX{ "last", SUBR, xlast },
XX{ "nth", SUBR, xnth },
XX{ "nthcdr", SUBR, xnthcdr },
XX{ "member", SUBR, xmember },
XX{ "assoc", SUBR, xassoc },
XX{ "subst", SUBR, xsubst },
XX{ "sublis", SUBR, xsublis },
XX{ "remove", SUBR, xremove },
XX{ "length", SUBR, xlength },
XX{ "mapc", SUBR, xmapc },
XX{ "mapcar", SUBR, xmapcar },
XX{ "mapl", SUBR, xmapl },
XX{ "maplist", SUBR, xmaplist },
XX
XX /* destructive list functions */
XX{ "rplaca", SUBR, xrplca },
XX{ "rplacd", SUBR, xrplcd },
XX{ "nconc", SUBR, xnconc },
XX{ "delete", SUBR, xdelete },
XX
XX /* predicate functions */
XX{ "atom", SUBR, xatom },
XX{ "symbolp", SUBR, xsymbolp },
XX{ "numberp", SUBR, xnumberp },
XX{ "boundp", SUBR, xboundp },
XX{ "null", SUBR, xnull },
XX{ "not", SUBR, xnull },
XX{ "listp", SUBR, xlistp },
XX{ "consp", SUBR, xconsp },
XX{ "minusp", SUBR, xminusp },
XX{ "zerop", SUBR, xzerop },
XX{ "plusp", SUBR, xplusp },
XX{ "evenp", SUBR, xevenp },
XX{ "oddp", SUBR, xoddp },
XX{ "eq", SUBR, xeq },
XX{ "eql", SUBR, xeql },
XX{ "equal", SUBR, xequal },
XX
XX /* control functions */
XX{ "cond", FSUBR, xcond },
XX{ "and", FSUBR, xand },
XX{ "or", FSUBR, xor },
XX{ "let", FSUBR, xlet },
XX{ "let*", FSUBR, xletstar },
XX{ "if", FSUBR, xif },
XX{ "prog", FSUBR, xprog },
XX{ "prog*", FSUBR, xprogstar },
XX{ "prog1", FSUBR, xprog1 },
XX{ "prog2", FSUBR, xprog2 },
XX{ "progn", FSUBR, xprogn },
XX{ "go", FSUBR, xgo },
XX{ "return", SUBR, xreturn },
XX{ "do", FSUBR, xdo },
XX{ "do*", FSUBR, xdostar },
XX{ "dolist", FSUBR, xdolist },
XX{ "dotimes", FSUBR, xdotimes },
XX{ "catch", FSUBR, xcatch },
XX{ "throw", SUBR, xthrow },
XX
XX /* debugging and error handling functions */
XX{ "error", SUBR, xerror },
XX{ "cerror", SUBR, xcerror },
XX{ "break", SUBR, xbreak },
XX{ "errset", FSUBR, xerrset },
XX{ "baktrace", SUBR, xbaktrace },
XX{ "evalhook", SUBR, xevalhook },
XX
XX /* arithmetic functions */
XX{ "+", SUBR, xadd },
XX{ "-", SUBR, xsub },
XX{ "*", SUBR, xmul },
XX{ "/", SUBR, xdiv },
XX{ "1+", SUBR, xadd1 },
XX{ "1-", SUBR, xsub1 },
XX{ "rem", SUBR, xrem },
XX{ "min", SUBR, xmin },
XX{ "max", SUBR, xmax },
XX{ "abs", SUBR, xabs },
XX
XX /* bitwise logical functions */
XX{ "bit-and", SUBR, xbitand },
XX{ "bit-ior", SUBR, xbitior },
XX{ "bit-xor", SUBR, xbitxor },
XX{ "bit-not", SUBR, xbitnot },
XX
XX /* numeric comparison functions */
XX{ "<", SUBR, xlss },
XX{ "<=", SUBR, xleq },
XX{ "=", SUBR, xequ },
XX{ "/=", SUBR, xneq },
XX{ ">=", SUBR, xgeq },
XX{ ">", SUBR, xgtr },
XX
XX /* string functions */
XX{ "strlen", SUBR, xstrlen },
XX{ "strcat", SUBR, xstrcat },
XX{ "substr", SUBR, xsubstr },
XX{ "ascii", SUBR, xascii },
XX{ "chr", SUBR, xchr },
XX{ "atoi", SUBR, xatoi },
XX{ "itoa", SUBR, xitoa },
XX
XX /* I/O functions */
XX{ "read", SUBR, xread },
XX{ "print", SUBR, xprint },
XX{ "prin1", SUBR, xprin1 },
XX{ "princ", SUBR, xprinc },
XX{ "terpri", SUBR, xterpri },
XX{ "flatsize", SUBR, xflatsize },
XX{ "flatc", SUBR, xflatc },
XX{ "explode", SUBR, xexplode },
XX{ "explodec", SUBR, xexplc },
XX{ "implode", SUBR, ximplode },
XX{ "maknam", SUBR, xmaknam },
XX
XX /* file I/O functions */
XX{ "openi", SUBR, xopeni },
XX{ "openo", SUBR, xopeno },
XX{ "close", SUBR, xclose },
XX{ "read-char", SUBR, xrdchar },
XX{ "peek-char", SUBR, xpkchar },
XX{ "write-char", SUBR, xwrchar },
XX{ "readline", SUBR, xreadline },
XX
XX /* system functions */
XX{ "load", SUBR, xload },
XX{ "gc", SUBR, xgc },
XX{ "expand", SUBR, xexpand },
XX{ "alloc", SUBR, xalloc },
XX{ "mem", SUBR, xmem },
XX{ "type", SUBR, xtype },
XX{ "exit", SUBR, xexit },
XX
XX{ 0 }
XX};
SHAR_EOF
if test 5998 -ne "`wc -c xlftab.c`"
then
echo shar: error transmitting xlftab.c '(should have been 5998 characters)'
fi
echo shar: extracting xlglob.c '(2114 characters)'
sed 's/^XX//' << \SHAR_EOF > xlglob.c
XX/* xlglobals - xlisp global variables */
XX
XX#include "xlisp.h"
XX
XX/* symbols */
XXNODE *true = NIL;
XXNODE *s_quote = NIL, *s_function = NIL;
XXNODE *s_bquote = NIL, *s_comma = NIL, *s_comat = NIL;
XXNODE *s_evalhook = NIL, *s_applyhook = NIL;
XXNODE *s_lambda = NIL, *s_macro = NIL;
XXNODE *s_stdin = NIL, *s_stdout = NIL;
XXNODE *s_tracenable = NIL, *s_tlimit = NIL, *s_breakenable = NIL;
XXNODE *s_continue = NIL, *s_quit = NIL;
XXNODE *s_car = NIL, *s_cdr = NIL;
XXNODE *s_get = NIL, *s_svalue = NIL, *s_splist = NIL;
XXNODE *s_eql = NIL, *k_test = NIL, *k_tnot = NIL;
XXNODE *k_optional = NIL, *k_rest = NIL, *k_aux = NIL;
XXNODE *a_subr = NIL, *a_fsubr = NIL;
XXNODE *a_list = NIL, *a_sym = NIL, *a_int = NIL;
XXNODE *a_str = NIL, *a_obj = NIL, *a_fptr = NIL;
XXNODE *oblist = NIL, *keylist = NIL, *s_unbound = NIL;
XX
XX/* evaluation variables */
XXNODE *xlstack = NIL;
XXNODE *xlenv = NIL;
XXNODE *xlnewenv = NIL;
XX
XX/* exception handling variables */
XXCONTEXT *xlcontext = NULL; /* current exception handler */
XXNODE *xlvalue = NIL; /* exception value */
XX
XX/* debugging variables */
XXint xldebug = 0; /* debug level */
XXint xltrace = -1; /* trace stack pointer */
XXNODE **trace_stack = NULL; /* trace stack */
XX
XX/* gensym variables */
XXchar gsprefix[STRMAX+1] = { 'G',0 }; /* gensym prefix string */
XXint gsnumber = 1; /* gensym number */
XX
XX/* i/o variables */
XXint xlplevel = 0; /* prompt nesting level */
XXint xlfsize = 0; /* flat size of current print call */
XXint prompt = TRUE; /* input prompt flag */
XX
XX/* dynamic memory variables */
XXlong total = 0L; /* total memory in use */
XXint anodes = 0; /* number of nodes to allocate */
XXint nnodes = 0; /* number of nodes allocated */
XXint nsegs = 0; /* number of segments allocated */
XXint nfree = 0; /* number of nodes free */
XXint gccalls = 0; /* number of gc calls */
XXstruct segment *segs = NULL; /* list of allocated segments */
XXNODE *fnodes = NIL; /* list of free nodes */
XX
XX/* object programming variables */
XXNODE *self = NIL, *class = NIL, *object = NIL;
XXNODE *new = NIL, *isnew = NIL, *msgcls = NIL, *msgclass = NIL;
XXint varcnt = 0;
XX
XX/* general purpose string buffer */
XXchar buf[STRMAX+1] = { 0 };
SHAR_EOF
if test 2114 -ne "`wc -c xlglob.c`"
then
echo shar: error transmitting xlglob.c '(should have been 2114 characters)'
fi
echo shar: extracting xlinit.c '(3268 characters)'
sed 's/^XX//' << \SHAR_EOF > xlinit.c
XX/* xlinit.c - xlisp initialization module */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern NODE *true;
XXextern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
XXextern NODE *s_lambda,*s_macro;
XXextern NODE *s_stdin,*s_stdout;
XXextern NODE *s_evalhook,*s_applyhook;
XXextern NODE *s_tracenable,*s_tlimit,*s_breakenable;
XXextern NODE *s_continue,*s_quit;
XXextern NODE *s_car,*s_cdr,*s_get,*s_svalue,*s_splist,*s_eql;
XXextern NODE *k_test,*k_tnot,*k_optional,*k_rest,*k_aux;
XXextern NODE *a_subr,*a_fsubr;
XXextern NODE *a_list,*a_sym,*a_int,*a_str,*a_obj,*a_fptr;
XXextern struct fdef ftab[];
XX
XX/* xlinit - xlisp initialization routine */
XXxlinit()
XX{
XX struct fdef *fptr;
XX NODE *sym;
XX
XX /* initialize xlisp (must be in this order) */
XX xlminit(); /* initialize xldmem.c */
XX xlsinit(); /* initialize xlsym.c */
XX xldinit(); /* initialize xldbug.c */
XX xloinit(); /* initialize xlobj.c */
XX
XX /* enter the builtin functions */
XX for (fptr = ftab; fptr->f_name; fptr++)
XX xlsubr(fptr->f_name,fptr->f_type,fptr->f_fcn);
XX
XX /* enter the 't' symbol */
XX true = xlsenter("t");
XX true->n_symvalue = true;
XX
XX /* enter some important symbols */
XX s_quote = xlsenter("quote");
XX s_function = xlsenter("function");
XX s_bquote = xlsenter("backquote");
XX s_comma = xlsenter("comma");
XX s_comat = xlsenter("comma-at");
XX s_lambda = xlsenter("lambda");
XX s_macro = xlsenter("macro");
XX s_eql = xlsenter("eql");
XX s_continue = xlsenter("continue");
XX s_quit = xlsenter("quit");
XX
XX /* enter setf place specifiers */
XX s_car = xlsenter("car");
XX s_cdr = xlsenter("cdr");
XX s_get = xlsenter("get");
XX s_svalue = xlsenter("symbol-value");
XX s_splist = xlsenter("symbol-plist");
XX
XX /* enter parameter list keywords */
XX k_test = xlsenter(":test");
XX k_tnot = xlsenter(":test-not");
XX
XX /* enter lambda list keywords */
XX k_optional = xlsenter("&optional");
XX k_rest = xlsenter("&rest");
XX k_aux = xlsenter("&aux");
XX
XX /* enter *standard-input* and *standard-output* */
XX s_stdin = xlsenter("*standard-input*");
XX s_stdin->n_symvalue = newnode(FPTR);
XX s_stdin->n_symvalue->n_fp = stdin;
XX s_stdin->n_symvalue->n_savech = 0;
XX s_stdout = xlsenter("*standard-output*");
XX s_stdout->n_symvalue = newnode(FPTR);
XX s_stdout->n_symvalue->n_fp = stdout;
XX s_stdout->n_symvalue->n_savech = 0;
XX
XX /* enter the eval and apply hook variables */
XX s_evalhook = xlsenter("*evalhook*");
XX s_evalhook->n_symvalue = NIL;
XX s_applyhook = xlsenter("*applyhook*");
XX s_applyhook->n_symvalue = NIL;
XX
XX /* enter the error traceback and the error break enable flags */
XX s_tracenable = xlsenter("*tracenable*");
XX s_tracenable->n_symvalue = NIL;
XX s_tlimit = xlsenter("*tracelimit*");
XX s_tlimit->n_symvalue = NIL;
XX s_breakenable = xlsenter("*breakenable*");
XX s_breakenable->n_symvalue = true;
XX
XX /* enter a copyright notice into the oblist */
XX sym = xlsenter("**Copyright-1985-by-David-Betz**");
XX sym->n_symvalue = true;
XX
XX /* enter type names */
XX a_subr = xlsenter("SUBR");
XX a_fsubr = xlsenter("FSUBR");
XX a_list = xlsenter("LIST");
XX a_sym = xlsenter("SYM");
XX a_int = xlsenter("INT");
XX a_str = xlsenter("STR");
XX a_obj = xlsenter("OBJ");
XX a_fptr = xlsenter("FPTR");
XX}
SHAR_EOF
if test 3268 -ne "`wc -c xlinit.c`"
then
echo shar: error transmitting xlinit.c '(should have been 3268 characters)'
fi
echo shar: extracting xlmath.c '(5921 characters)'
sed 's/^XX//' << \SHAR_EOF > xlmath.c
XX/* xlmath - xlisp builtin arithmetic functions */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern NODE *xlstack;
XXextern NODE *true;
XX
XX/* forward declarations */
XXFORWARD NODE *unary();
XXFORWARD NODE *binary();
XXFORWARD NODE *predicate();
XXFORWARD NODE *compare();
XX
XX/* xadd - builtin function for addition */
XXNODE *xadd(args)
XX NODE *args;
XX{
XX return (binary(args,'+'));
XX}
XX
XX/* xsub - builtin function for subtraction */
XXNODE *xsub(args)
XX NODE *args;
XX{
XX return (binary(args,'-'));
XX}
XX
XX/* xmul - builtin function for multiplication */
XXNODE *xmul(args)
XX NODE *args;
XX{
XX return (binary(args,'*'));
XX}
XX
XX/* xdiv - builtin function for division */
XXNODE *xdiv(args)
XX NODE *args;
XX{
XX return (binary(args,'/'));
XX}
XX
XX/* xrem - builtin function for remainder */
XXNODE *xrem(args)
XX NODE *args;
XX{
XX return (binary(args,'%'));
XX}
XX
XX/* xmin - builtin function for minimum */
XXNODE *xmin(args)
XX NODE *args;
XX{
XX return (binary(args,'m'));
XX}
XX
XX/* xmax - builtin function for maximum */
XXNODE *xmax(args)
XX NODE *args;
XX{
XX return (binary(args,'M'));
XX}
XX
XX/* xbitand - builtin function for bitwise and */
XXNODE *xbitand(args)
XX NODE *args;
XX{
XX return (binary(args,'&'));
XX}
XX
XX/* xbitior - builtin function for bitwise inclusive or */
XXNODE *xbitior(args)
XX NODE *args;
XX{
XX return (binary(args,'|'));
XX}
XX
XX/* xbitxor - builtin function for bitwise exclusive or */
XXNODE *xbitxor(args)
XX NODE *args;
XX{
XX return (binary(args,'^'));
XX}
XX
XX/* binary - handle binary operations */
XXLOCAL NODE *binary(args,fcn)
XX NODE *args; int fcn;
XX{
XX int ival,iarg;
XX NODE *val;
XX
XX /* get the first argument */
XX ival = xlmatch(INT,&args)->n_int;
XX
XX /* treat '-' with a single argument as a special case */
XX if (fcn == '-' && args == NIL)
XX ival = -ival;
XX
XX /* handle each remaining argument */
XX while (args) {
XX
XX /* get the next argument */
XX iarg = xlmatch(INT,&args)->n_int;
XX
XX /* accumulate the result value */
XX switch (fcn) {
XX case '+': ival += iarg; break;
XX case '-': ival -= iarg; break;
XX case '*': ival *= iarg; break;
XX case '/': ival /= iarg; break;
XX case '%': ival %= iarg; break;
XX case 'M': if (iarg > ival) ival = iarg; break;
XX case 'm': if (iarg < ival) ival = iarg; break;
XX case '&': ival &= iarg; break;
XX case '|': ival |= iarg; break;
XX case '^': ival ^= iarg; break;
XX }
XX }
XX
XX /* initialize value */
XX val = newnode(INT);
XX val->n_int = ival;
XX
XX /* return the result value */
XX return (val);
XX}
XX
XX/* xbitnot - bitwise not */
XXNODE *xbitnot(args)
XX NODE *args;
XX{
XX return (unary(args,'~'));
XX}
XX
XX/* xabs - builtin function for absolute value */
XXNODE *xabs(args)
XX NODE *args;
XX{
XX return (unary(args,'A'));
XX}
XX
XX/* xadd1 - builtin function for adding one */
XXNODE *xadd1(args)
XX NODE *args;
XX{
XX return (unary(args,'+'));
XX}
XX
XX/* xsub1 - builtin function for subtracting one */
XXNODE *xsub1(args)
XX NODE *args;
XX{
XX return (unary(args,'-'));
XX}
XX
XX/* unary - handle unary operations */
XXLOCAL NODE *unary(args,fcn)
XX NODE *args; int fcn;
XX{
XX NODE *val;
XX int ival;
XX
XX /* get the argument */
XX ival = xlmatch(INT,&args)->n_int;
XX xllastarg(args);
XX
XX /* compute the result */
XX switch (fcn) {
XX case '~': ival = ~ival; break;
XX case 'A': if (ival < 0) ival = -ival; break;
XX case '+': ival++; break;
XX case '-': ival--; break;
XX }
XX
XX /* convert the value */
XX val = newnode(INT);
XX val->n_int = ival;
XX
XX /* return the result value */
XX return (val);
XX}
XX
XX/* xminusp - is this number negative? */
XXNODE *xminusp(args)
XX NODE *args;
XX{
XX return (predicate(args,'-'));
XX}
XX
XX/* xzerop - is this number zero? */
XXNODE *xzerop(args)
XX NODE *args;
XX{
XX return (predicate(args,'Z'));
XX}
XX
XX/* xplusp - is this number positive? */
XXNODE *xplusp(args)
XX NODE *args;
XX{
XX return (predicate(args,'+'));
XX}
XX
XX/* xevenp - is this number even? */
XXNODE *xevenp(args)
XX NODE *args;
XX{
XX return (predicate(args,'E'));
XX}
XX
XX/* xoddp - is this number odd? */
XXNODE *xoddp(args)
XX NODE *args;
XX{
XX return (predicate(args,'O'));
XX}
XX
XX/* predicate - handle a predicate function */
XXLOCAL NODE *predicate(args,fcn)
XX NODE *args; int fcn;
XX{
XX NODE *val;
XX int ival;
XX
XX /* get the argument */
XX ival = xlmatch(INT,&args)->n_int;
XX xllastarg(args);
XX
XX /* compute the result */
XX switch (fcn) {
XX case '-': ival = (ival < 0); break;
XX case 'Z': ival = (ival == 0); break;
XX case '+': ival = (ival > 0); break;
XX case 'E': ival = ((ival & 1) == 0); break;
XX case 'O': ival = ((ival & 1) != 0); break;
XX }
XX
XX /* return the result value */
XX return (ival ? true : NIL);
XX}
XX
XX/* xlss - builtin function for < */
XXNODE *xlss(args)
XX NODE *args;
XX{
XX return (compare(args,'<'));
XX}
XX
XX/* xleq - builtin function for <= */
XXNODE *xleq(args)
XX NODE *args;
XX{
XX return (compare(args,'L'));
XX}
XX
XX/* equ - builtin function for = */
XXNODE *xequ(args)
XX NODE *args;
XX{
XX return (compare(args,'='));
XX}
XX
XX/* xneq - builtin function for /= */
XXNODE *xneq(args)
XX NODE *args;
XX{
XX return (compare(args,'#'));
XX}
XX
XX/* xgeq - builtin function for >= */
XXNODE *xgeq(args)
XX NODE *args;
XX{
XX return (compare(args,'G'));
XX}
XX
XX/* xgtr - builtin function for > */
XXNODE *xgtr(args)
XX NODE *args;
XX{
XX return (compare(args,'>'));
XX}
XX
XX/* compare - common compare function */
XXLOCAL NODE *compare(args,fcn)
XX NODE *args; int fcn;
XX{
XX NODE *arg1,*arg2;
XX int cmp;
XX
XX /* get the two arguments */
XX arg1 = xlarg(&args);
XX arg2 = xlarg(&args);
XX xllastarg(args);
XX
XX /* do the compare */
XX if (stringp(arg1) && stringp(arg2))
XX cmp = strcmp(arg1->n_str,arg2->n_str);
XX else if (fixp(arg1) && fixp(arg2))
XX cmp = arg1->n_int - arg2->n_int;
XX else
XX cmp = (int)(arg1 - arg2);
XX
XX /* compute result of the compare */
XX switch (fcn) {
XX case '<': cmp = (cmp < 0); break;
XX case 'L': cmp = (cmp <= 0); break;
XX case '=': cmp = (cmp == 0); break;
XX case '#': cmp = (cmp != 0); break;
XX case 'G': cmp = (cmp >= 0); break;
XX case '>': cmp = (cmp > 0); break;
XX }
XX
XX /* return the result */
XX return (cmp ? true : NIL);
XX}
SHAR_EOF
if test 5921 -ne "`wc -c xlmath.c`"
then
echo shar: error transmitting xlmath.c '(should have been 5921 characters)'
fi
echo shar: extracting xlprin.c '(2789 characters)'
sed 's/^XX//' << \SHAR_EOF > xlprin.c
XX/* xlprint - xlisp print routine */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern NODE *xlstack;
XXextern char buf[];
XX
XX/* xlprint - print an xlisp value */
XXxlprint(fptr,vptr,flag)
XX NODE *fptr,*vptr; int flag;
XX{
XX NODE *nptr,*next;
XX
XX /* print nil */
XX if (vptr == NIL) {
XX putstr(fptr,"nil");
XX return;
XX }
XX
XX /* check value type */
XX switch (ntype(vptr)) {
XX case SUBR:
XX putatm(fptr,"Subr",vptr);
XX break;
XX case FSUBR:
XX putatm(fptr,"FSubr",vptr);
XX break;
XX case LIST:
XX xlputc(fptr,'(');
XX for (nptr = vptr; nptr != NIL; nptr = next) {
XX xlprint(fptr,car(nptr),flag);
XX if (next = cdr(nptr))
XX if (consp(next))
XX xlputc(fptr,' ');
XX else {
XX putstr(fptr," . ");
XX xlprint(fptr,next,flag);
XX break;
XX }
XX }
XX xlputc(fptr,')');
XX break;
XX case SYM:
XX putstr(fptr,xlsymname(vptr));
XX break;
XX case INT:
XX putdec(fptr,vptr->n_int);
XX break;
XX case STR:
XX if (flag)
XX putstring(fptr,vptr->n_str);
XX else
XX putstr(fptr,vptr->n_str);
XX break;
XX case FPTR:
XX putatm(fptr,"File",vptr);
XX break;
XX case OBJ:
XX putatm(fptr,"Object",vptr);
XX break;
XX case FREE:
XX putatm(fptr,"Free",vptr);
XX break;
XX default:
XX putatm(fptr,"Foo",vptr);
XX break;
XX }
XX}
XX
XX/* xlterpri - terminate the current print line */
XXxlterpri(fptr)
XX NODE *fptr;
XX{
XX xlputc(fptr,'\n');
XX}
XX
XX/* putstring - output a string */
XXLOCAL putstring(fptr,str)
XX NODE *fptr; char *str;
XX{
XX int ch;
XX
XX /* output the initial quote */
XX xlputc(fptr,'"');
XX
XX /* output each character in the string */
XX while (ch = *str++)
XX
XX /* check for a control character */
XX if (ch < 040 || ch == '\\') {
XX xlputc(fptr,'\\');
XX switch (ch) {
XX case '\033':
XX xlputc(fptr,'e');
XX break;
XX case '\n':
XX xlputc(fptr,'n');
XX break;
XX case '\r':
XX xlputc(fptr,'r');
XX break;
XX case '\t':
XX xlputc(fptr,'t');
XX break;
XX case '\\':
XX xlputc(fptr,'\\');
XX break;
XX default:
XX putoct(fptr,ch);
XX break;
XX }
XX }
XX
XX /* output a normal character */
XX else
XX xlputc(fptr,ch);
XX
XX /* output the terminating quote */
XX xlputc(fptr,'"');
XX}
XX
XX/* putatm - output an atom */
XXLOCAL putatm(fptr,tag,val)
XX NODE *fptr; char *tag; NODE *val;
XX{
XX sprintf(buf,"#<%s: #",tag); putstr(fptr,buf);
XX sprintf(buf,AFMT,val); putstr(fptr,buf);
XX xlputc(fptr,'>');
XX}
XX
XX/* putdec - output a decimal number */
XXLOCAL putdec(fptr,n)
XX NODE *fptr; int n;
XX{
XX sprintf(buf,"%d",n);
XX putstr(fptr,buf);
XX}
XX
XX/* putoct - output an octal byte value */
XXLOCAL putoct(fptr,n)
XX NODE *fptr; int n;
XX{
XX sprintf(buf,"%03o",n);
XX putstr(fptr,buf);
XX}
XX
XX/* putstr - output a string */
XXLOCAL putstr(fptr,str)
XX NODE *fptr; char *str;
XX{
XX while (*str)
XX xlputc(fptr,*str++);
XX}
SHAR_EOF
if test 2789 -ne "`wc -c xlprin.c`"
then
echo shar: error transmitting xlprin.c '(should have been 2789 characters)'
fi
echo shar: extracting xlstub.c.NOTUSED '(158 characters)'
sed 's/^XX//' << \SHAR_EOF > xlstub.c.NOTUSED
XX/* xlstub.c - stubs for replacing the 'xlobj' module */
XX
XX#include "xlisp.h"
XX
XXxloinit() {}
XXNODE *xlsend() { return (NIL); }
XXNODE *xlobsym() { return (NIL); }
XX
SHAR_EOF
if test 158 -ne "`wc -c xlstub.c.NOTUSED`"
then
echo shar: error transmitting xlstub.c.NOTUSED '(should have been 158 characters)'
fi
echo shar: extracting xlsubr.c '(4232 characters)'
sed 's/^XX//' << \SHAR_EOF > xlsubr.c
XX/* xlsubr - xlisp builtin function support routines */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern NODE *k_test,*k_tnot,*s_eql;
XXextern NODE *xlstack;
XX
XX/* xlsubr - define a builtin function */
XXxlsubr(sname,type,subr)
XX char *sname; int type; NODE *(*subr)();
XX{
XX NODE *sym;
XX
XX /* enter the symbol */
XX sym = xlsenter(sname);
XX
XX /* initialize the value */
XX sym->n_symvalue = newnode(type);
XX sym->n_symvalue->n_subr = subr;
XX}
XX
XX/* xlarg - get the next argument */
XXNODE *xlarg(pargs)
XX NODE **pargs;
XX{
XX NODE *arg;
XX
XX /* make sure the argument exists */
XX if (!consp(*pargs))
XX xlfail("too few arguments");
XX
XX /* get the argument value */
XX arg = car(*pargs);
XX
XX /* make sure its not a keyword */
XX if (symbolp(arg) && *car(arg->n_symplist)->n_str == ':')
XX xlfail("too few arguments");
XX
XX /* move the argument pointer ahead */
XX *pargs = cdr(*pargs);
XX
XX /* return the argument */
XX return (arg);
XX}
XX
XX/* xlmatch - get an argument and match its type */
XXNODE *xlmatch(type,pargs)
XX int type; NODE **pargs;
XX{
XX NODE *arg;
XX
XX /* get the argument */
XX arg = xlarg(pargs);
XX
XX /* check its type */
XX if (type == LIST) {
XX if (arg && ntype(arg) != LIST)
XX xlfail("bad argument type");
XX }
XX else {
XX if (arg == NIL || ntype(arg) != type)
XX xlfail("bad argument type");
XX }
XX
XX /* return the argument */
XX return (arg);
XX}
XX
XX/* xlevarg - get the next argument and evaluate it */
XXNODE *xlevarg(pargs)
XX NODE **pargs;
XX{
XX NODE *oldstk,val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&val,NULL);
XX
XX /* get the argument */
XX val.n_ptr = xlarg(pargs);
XX
XX /* evaluate the argument */
XX val.n_ptr = xleval(val.n_ptr);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the argument */
XX return (val.n_ptr);
XX}
XX
XX/* xlevmatch - get an evaluated argument and match its type */
XXNODE *xlevmatch(type,pargs)
XX int type; NODE **pargs;
XX{
XX NODE *arg;
XX
XX /* get the argument */
XX arg = xlevarg(pargs);
XX
XX /* check its type */
XX if (type == LIST) {
XX if (arg && ntype(arg) != LIST)
XX xlfail("bad argument type");
XX }
XX else {
XX if (arg == NIL || ntype(arg) != type)
XX xlfail("bad argument type");
XX }
XX
XX /* return the argument */
XX return (arg);
XX}
XX
XX/* xltest - get the :test or :test-not keyword argument */
XXxltest(pfcn,ptresult,pargs)
XX NODE **pfcn; int *ptresult; NODE **pargs;
XX{
XX NODE *arg;
XX
XX /* default the argument to eql */
XX if (!consp(*pargs)) {
XX *pfcn = s_eql->n_symvalue;
XX *ptresult = TRUE;
XX return;
XX }
XX
XX /* get the keyword */
XX arg = car(*pargs);
XX
XX /* check the keyword */
XX if (arg == k_test)
XX *ptresult = TRUE;
XX else if (arg == k_tnot)
XX *ptresult = FALSE;
XX else
XX xlfail("expecting :test or :test-not");
XX
XX /* move the argument pointer ahead */
XX *pargs = cdr(*pargs);
XX
XX /* make sure the argument exists */
XX if (!consp(*pargs))
XX xlfail("no value for keyword argument");
XX
XX /* get the argument value */
XX *pfcn = car(*pargs);
XX
XX /* if its a symbol, get its value */
XX if (symbolp(*pfcn))
XX *pfcn = xleval(*pfcn);
XX
XX /* move the argument pointer ahead */
XX *pargs = cdr(*pargs);
XX}
XX
XX/* xllastarg - make sure the remainder of the argument list is empty */
XXxllastarg(args)
XX NODE *args;
XX{
XX if (args)
XX xlfail("too many arguments");
XX}
XX
XX/* assign - assign a value to a symbol */
XXassign(sym,val)
XX NODE *sym,*val;
XX{
XX NODE *lptr;
XX
XX /* check for a current object */
XX if ((lptr = xlobsym(sym)) != NIL)
XX rplaca(lptr,val);
XX else
XX sym->n_symvalue = val;
XX}
XX
XX/* eq - internal eq function */
XXint eq(arg1,arg2)
XX NODE *arg1,*arg2;
XX{
XX return (arg1 == arg2);
XX}
XX
XX/* eql - internal eql function */
XXint eql(arg1,arg2)
XX NODE *arg1,*arg2;
XX{
XX if (eq(arg1,arg2))
XX return (TRUE);
XX else if (fixp(arg1) && fixp(arg2))
XX return (arg1->n_int == arg2->n_int);
XX else if (stringp(arg1) && stringp(arg2))
XX return (strcmp(arg1->n_str,arg2->n_str) == 0);
XX else
XX return (FALSE);
XX}
XX
XX/* equal - internal equal function */
XXint equal(arg1,arg2)
XX NODE *arg1,*arg2;
XX{
XX /* compare the arguments */
XX if (eql(arg1,arg2))
XX return (TRUE);
XX else if (consp(arg1) && consp(arg2))
XX return (equal(car(arg1),car(arg2)) && equal(cdr(arg1),cdr(arg2)));
XX else
XX return (FALSE);
XX}
SHAR_EOF
if test 4232 -ne "`wc -c xlsubr.c`"
then
echo shar: error transmitting xlsubr.c '(should have been 4232 characters)'
fi
echo shar: extracting xlsym.c '(3869 characters)'
sed 's/^XX//' << \SHAR_EOF > xlsym.c
XX/* xlsym - symbol handling routines */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern NODE *oblist,*keylist;
XXextern NODE *s_unbound;
XXextern NODE *xlstack;
XX
XX/* forward declarations */
XXFORWARD NODE *symenter();
XXFORWARD NODE *xlmakesym();
XXFORWARD NODE *findprop();
XX
XX/* xlenter - enter a symbol into the oblist or keylist */
XXNODE *xlenter(name,type)
XX char *name;
XX{
XX return (symenter(name,type,(*name == ':' ? keylist : oblist)));
XX}
XX
XX/* symenter - enter a symbol into a package */
XXLOCAL NODE *symenter(name,type,listsym)
XX char *name; int type; NODE *listsym;
XX{
XX NODE *oldstk,*lsym,*nsym,newsym;
XX int cmp;
XX
XX /* check for nil */
XX if (strcmp(name,"nil") == 0)
XX return (NIL);
XX
XX /* check for symbol already in table */
XX lsym = NIL;
XX nsym = listsym->n_symvalue;
XX while (nsym) {
XX if ((cmp = strcmp(name,xlsymname(car(nsym)))) <= 0)
XX break;
XX lsym = nsym;
XX nsym = cdr(nsym);
XX }
XX
XX /* check to see if we found it */
XX if (nsym && cmp == 0)
XX return (car(nsym));
XX
XX /* make a new symbol node and link it into the list */
XX oldstk = xlsave(&newsym,NULL);
XX newsym.n_ptr = newnode(LIST);
XX rplaca(newsym.n_ptr,xlmakesym(name,type));
XX rplacd(newsym.n_ptr,nsym);
XX if (lsym)
XX rplacd(lsym,newsym.n_ptr);
XX else
XX listsym->n_symvalue = newsym.n_ptr;
XX xlstack = oldstk;
XX
XX /* return the new symbol */
XX return (car(newsym.n_ptr));
XX}
XX
XX/* xlsenter - enter a symbol with a static print name */
XXNODE *xlsenter(name)
XX char *name;
XX{
XX return (xlenter(name,STATIC));
XX}
XX
XX/* xlmakesym - make a new symbol node */
XXNODE *xlmakesym(name,type)
XX char *name;
XX{
XX NODE *oldstk,sym,*str;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&sym,NULL);
XX
XX /* make a new symbol node */
XX sym.n_ptr = newnode(SYM);
XX sym.n_ptr->n_symvalue = (*name == ':' ? sym.n_ptr : s_unbound);
XX sym.n_ptr->n_symplist = newnode(LIST);
XX rplaca(sym.n_ptr->n_symplist,str = newnode(STR));
XX str->n_str = (type == DYNAMIC ? strsave(name) : name);
XX str->n_strtype = type;
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the new symbol node */
XX return (sym.n_ptr);
XX}
XX
XX/* xlsymname - return the print name of a symbol */
XXchar *xlsymname(sym)
XX NODE *sym;
XX{
XX return (car(sym->n_symplist)->n_str);
XX}
XX
XX/* xlgetprop - get the value of a property */
XXNODE *xlgetprop(sym,prp)
XX NODE *sym,*prp;
XX{
XX NODE *p;
XX
XX return ((p = findprop(sym,prp)) ? car(p) : NIL);
XX}
XX
XX/* xlputprop - put a property value onto the property list */
XXxlputprop(sym,val,prp)
XX NODE *sym,*val,*prp;
XX{
XX NODE *oldstk,p,*pair;
XX
XX if ((pair = findprop(sym,prp)) == NIL) {
XX oldstk = xlsave(&p,NULL);
XX p.n_ptr = newnode(LIST);
XX rplaca(p.n_ptr,prp);
XX rplacd(p.n_ptr,pair = newnode(LIST));
XX rplaca(pair,val);
XX rplacd(pair,cdr(sym->n_symplist));
XX rplacd(sym->n_symplist,p.n_ptr);
XX xlstack = oldstk;
XX }
XX rplaca(pair,val);
XX}
XX
XX/* xlremprop - remove a property from a property list */
XXxlremprop(sym,prp)
XX NODE *sym,*prp;
XX{
XX NODE *last,*p;
XX
XX last = NIL;
XX for (p = cdr(sym->n_symplist); consp(p) && consp(cdr(p)); p = cdr(last)) {
XX if (car(p) == prp)
XX if (last)
XX rplacd(last,cdr(cdr(p)));
XX else
XX rplacd(sym->n_symplist,cdr(cdr(p)));
XX last = cdr(p);
XX }
XX}
XX
XX/* findprop - find a property pair */
XXLOCAL NODE *findprop(sym,prp)
XX NODE *sym,*prp;
XX{
XX NODE *p;
XX
XX for (p = cdr(sym->n_symplist); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
XX if (car(p) == prp)
XX return (cdr(p));
XX return (NIL);
XX}
XX
XX/* xlsinit - symbol initialization routine */
XXxlsinit()
XX{
XX /* initialize the oblist */
XX oblist = xlmakesym("*oblist*",STATIC);
XX oblist->n_symvalue = newnode(LIST);
XX rplaca(oblist->n_symvalue,oblist);
XX
XX /* initialize the keyword list */
XX keylist = xlsenter("*keylist*");
XX
XX /* enter the unbound symbol indicator */
XX s_unbound = xlsenter("*unbound*");
XX s_unbound->n_symvalue = s_unbound;
XX}
SHAR_EOF
if test 3869 -ne "`wc -c xlsym.c`"
then
echo shar: error transmitting xlsym.c '(should have been 3869 characters)'
fi
echo shar: extracting xlsys.c '(3003 characters)'
sed 's/^XX//' << \SHAR_EOF > xlsys.c
XX/* xlsys.c - xlisp builtin system functions */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern NODE *xlstack;
XXextern int anodes;
XX
XX/* external symbols */
XXextern NODE *a_subr,*a_fsubr;
XXextern NODE *a_list,*a_sym,*a_int,*a_str,*a_obj,*a_fptr;
XXextern NODE *true;
XX
XX/* xload - direct input from a file */
XXNODE *xload(args)
XX NODE *args;
XX{
XX NODE *oldstk,fname,*val;
XX int vflag,pflag;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&fname,NULL);
XX
XX /* get the file name, verbose flag and print flag */
XX fname.n_ptr = xlmatch(STR,&args);
XX vflag = (args ? xlarg(&args) != NIL : TRUE);
XX pflag = (args ? xlarg(&args) != NIL : FALSE);
XX xllastarg(args);
XX
XX /* load the file */
XX val = (xlload(fname.n_ptr->n_str,vflag,pflag) ? true : NIL);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the status */
XX return (val);
XX}
XX
XX/* xgc - xlisp function to force garbage collection */
XXNODE *xgc(args)
XX NODE *args;
XX{
XX /* make sure there aren't any arguments */
XX xllastarg(args);
XX
XX /* garbage collect */
XX gc();
XX
XX /* return nil */
XX return (NIL);
XX}
XX
XX/* xexpand - xlisp function to force memory expansion */
XXNODE *xexpand(args)
XX NODE *args;
XX{
XX NODE *val;
XX int n,i;
XX
XX /* get the new number to allocate */
XX n = (args ? xlmatch(INT,&args)->n_int : 1);
XX xllastarg(args);
XX
XX /* allocate more segments */
XX for (i = 0; i < n; i++)
XX if (!addseg())
XX break;
XX
XX /* return the number of segments added */
XX val = newnode(INT);
XX val->n_int = i;
XX return (val);
XX}
XX
XX/* xalloc - xlisp function to set the number of nodes to allocate */
XXNODE *xalloc(args)
XX NODE *args;
XX{
XX NODE *val;
XX int n,oldn;
XX
XX /* get the new number to allocate */
XX n = xlmatch(INT,&args)->n_int;
XX
XX /* make sure there aren't any more arguments */
XX xllastarg(args);
XX
XX /* set the new number of nodes to allocate */
XX oldn = anodes;
XX anodes = n;
XX
XX /* return the old number */
XX val = newnode(INT);
XX val->n_int = oldn;
XX return (val);
XX}
XX
XX/* xmem - xlisp function to print memory statistics */
XXNODE *xmem(args)
XX NODE *args;
XX{
XX /* make sure there aren't any arguments */
XX xllastarg(args);
XX
XX /* print the statistics */
XX stats();
XX
XX /* return nil */
XX return (NIL);
XX}
XX
XX/* xtype - return type of a thing */
XXNODE *xtype(args)
XX NODE *args;
XX{
XX NODE *arg;
XX
XX if (!(arg = xlarg(&args)))
XX return (NIL);
XX
XX switch (ntype(arg)) {
XX case SUBR: return (a_subr);
XX case FSUBR: return (a_fsubr);
XX case LIST: return (a_list);
XX case SYM: return (a_sym);
XX case INT: return (a_int);
XX case STR: return (a_str);
XX case OBJ: return (a_obj);
XX case FPTR: return (a_fptr);
XX default: xlfail("bad node type");
XX }
XX}
XX
XX/* xbaktrace - print the trace back stack */
XXNODE *xbaktrace(args)
XX NODE *args;
XX{
XX int n;
XX
XX n = (args ? xlmatch(INT,&args)->n_int : -1);
XX xllastarg(args);
XX xlbaktrace(n);
XX return (NIL);
XX}
XX
XX/* xexit - get out of xlisp */
XXNODE *xexit(args)
XX NODE *args;
XX{
XX xllastarg(args);
XX exit();
XX}
SHAR_EOF
if test 3003 -ne "`wc -c xlsys.c`"
then
echo shar: error transmitting xlsys.c '(should have been 3003 characters)'
fi
# End of shell archive
exit 0wegrzyn@encore.UUCP (Chuck Wegrzyn) (03/13/85)
# This is a shell archive.
# Remove everything above and including the cut line.
# Then run the rest of the file through sh.
-----cut here-----cut here-----cut here-----cut here-----
#!/bin/sh
# shar: Shell Archiver
# Run the following text with /bin/sh to create:
# xlcont.c
# xllist.c
# xlobj.c
# This archive created: Wed Mar 13 08:37:26 1985
echo shar: extracting xlcont.c '(16880 characters)'
sed 's/^XX//' << \SHAR_EOF > xlcont.c
XX/* xlcont - xlisp control built-in functions */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern NODE *xlstack,*xlenv,*xlnewenv,*xlvalue;
XXextern NODE *s_unbound;
XXextern NODE *s_evalhook,*s_applyhook;
XXextern NODE *true;
XX
XX/* external routines */
XXextern NODE *xlxeval();
XX
XX/* forward declarations */
XXFORWARD NODE *let();
XXFORWARD NODE *prog();
XXFORWARD NODE *progx();
XXFORWARD NODE *doloop();
XX
XX/* xcond - built-in function 'cond' */
XXNODE *xcond(args)
XX NODE *args;
XX{
XX NODE *oldstk,arg,list,*val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&arg,&list,NULL);
XX
XX /* initialize */
XX arg.n_ptr = args;
XX
XX /* initialize the return value */
XX val = NIL;
XX
XX /* find a predicate that is true */
XX while (arg.n_ptr) {
XX
XX /* get the next conditional */
XX list.n_ptr = xlmatch(LIST,&arg.n_ptr);
XX
XX /* evaluate the predicate part */
XX if (xlevarg(&list.n_ptr)) {
XX
XX /* evaluate each expression */
XX while (list.n_ptr)
XX val = xlevarg(&list.n_ptr);
XX
XX /* exit the loop */
XX break;
XX }
XX }
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the value */
XX return (val);
XX}
XX
XX/* xand - built-in function 'and' */
XXNODE *xand(args)
XX NODE *args;
XX{
XX NODE *oldstk,arg,*val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&arg,NULL);
XX
XX /* initialize */
XX arg.n_ptr = args;
XX val = true;
XX
XX /* evaluate each argument */
XX while (arg.n_ptr)
XX
XX /* get the next argument */
XX if ((val = xlevarg(&arg.n_ptr)) == NIL)
XX break;
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the result value */
XX return (val);
XX}
XX
XX/* xor - built-in function 'or' */
XXNODE *xor(args)
XX NODE *args;
XX{
XX NODE *oldstk,arg,*val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&arg,NULL);
XX
XX /* initialize */
XX arg.n_ptr = args;
XX val = NIL;
XX
XX /* evaluate each argument */
XX while (arg.n_ptr)
XX if ((val = xlevarg(&arg.n_ptr)))
XX break;
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the result value */
XX return (val);
XX}
XX
XX/* xif - built-in function 'if' */
XXNODE *xif(args)
XX NODE *args;
XX{
XX NODE *oldstk,testexpr,thenexpr,elseexpr,*val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&testexpr,&thenexpr,&elseexpr,NULL);
XX
XX /* get the test expression, then clause and else clause */
XX testexpr.n_ptr = xlarg(&args);
XX thenexpr.n_ptr = xlarg(&args);
XX elseexpr.n_ptr = (args ? xlarg(&args) : NIL);
XX xllastarg(args);
XX
XX /* evaluate the appropriate clause */
XX val = xleval(xleval(testexpr.n_ptr) ? thenexpr.n_ptr : elseexpr.n_ptr);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the last value */
XX return (val);
XX}
XX
XX/* xlet - built-in function 'let' */
XXNODE *xlet(args)
XX NODE *args;
XX{
XX return (let(args,TRUE));
XX}
XX
XX/* xletstar - built-in function 'let*' */
XXNODE *xletstar(args)
XX NODE *args;
XX{
XX return (let(args,FALSE));
XX}
XX
XX/* let - common let routine */
XXLOCAL NODE *let(args,pflag)
XX NODE *args; int pflag;
XX{
XX NODE *oldstk,*oldenv,*oldnewenv,arg,*val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&arg,NULL);
XX
XX /* initialize */
XX arg.n_ptr = args;
XX
XX /* get the list of bindings and bind the symbols */
XX oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
XX dobindings(xlmatch(LIST,&arg.n_ptr),pflag);
XX
XX /* execute the code */
XX for (val = NIL; arg.n_ptr; )
XX val = xlevarg(&arg.n_ptr);
XX
XX /* unbind the arguments */
XX xlunbind(oldenv); xlnewenv = oldnewenv;
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the result */
XX return (val);
XX}
XX
XX/* xprog - built-in function 'prog' */
XXNODE *xprog(args)
XX NODE *args;
XX{
XX return (prog(args,TRUE));
XX}
XX
XX/* xprogstar - built-in function 'prog*' */
XXNODE *xprogstar(args)
XX NODE *args;
XX{
XX return (prog(args,FALSE));
XX}
XX
XX/* prog - common prog routine */
XXLOCAL NODE *prog(args,pflag)
XX NODE *args; int pflag;
XX{
XX NODE *oldstk,*oldenv,*oldnewenv,arg,*val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&arg,NULL);
XX
XX /* initialize */
XX arg.n_ptr = args;
XX
XX /* get the list of bindings and bind the symbols */
XX oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
XX dobindings(xlmatch(LIST,&arg.n_ptr),pflag);
XX
XX /* execute the code */
XX tagblock(arg.n_ptr,&val);
XX
XX /* unbind the arguments */
XX xlunbind(oldenv); xlnewenv = oldnewenv;
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the result */
XX return (val);
XX}
XX
XX/* xgo - built-in function 'go' */
XXNODE *xgo(args)
XX NODE *args;
XX{
XX NODE *label;
XX
XX /* get the target label */
XX label = xlarg(&args);
XX xllastarg(args);
XX
XX /* transfer to the label */
XX xlgo(label);
XX}
XX
XX/* xreturn - built-in function 'return' */
XXNODE *xreturn(args)
XX NODE *args;
XX{
XX NODE *val;
XX
XX /* get the return value */
XX val = (args ? xlarg(&args) : NIL);
XX xllastarg(args);
XX
XX /* return from the inner most block */
XX xlreturn(val);
XX}
XX
XX/* xprog1 - built-in function 'prog1' */
XXNODE *xprog1(args)
XX NODE *args;
XX{
XX return (progx(args,1));
XX}
XX
XX/* xprog2 - built-in function 'prog2' */
XXNODE *xprog2(args)
XX NODE *args;
XX{
XX return (progx(args,2));
XX}
XX
XX/* progx - common progx code */
XXLOCAL NODE *progx(args,n)
XX NODE *args; int n;
XX{
XX NODE *oldstk,arg,val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&arg,&val,NULL);
XX
XX /* initialize */
XX arg.n_ptr = args;
XX
XX /* evaluate the first n expressions */
XX while (n--)
XX val.n_ptr = xlevarg(&arg.n_ptr);
XX
XX /* evaluate each remaining argument */
XX while (arg.n_ptr)
XX xlevarg(&arg.n_ptr);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the last test expression value */
XX return (val.n_ptr);
XX}
XX
XX/* xprogn - built-in function 'progn' */
XXNODE *xprogn(args)
XX NODE *args;
XX{
XX NODE *oldstk,arg,*val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&arg,NULL);
XX
XX /* initialize */
XX arg.n_ptr = args;
XX
XX /* evaluate each remaining argument */
XX for (val = NIL; arg.n_ptr; )
XX val = xlevarg(&arg.n_ptr);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the last test expression value */
XX return (val);
XX}
XX
XX/* xdo - built-in function 'do' */
XXNODE *xdo(args)
XX NODE *args;
XX{
XX return (doloop(args,TRUE));
XX}
XX
XX/* xdostar - built-in function 'do*' */
XXNODE *xdostar(args)
XX NODE *args;
XX{
XX return (doloop(args,FALSE));
XX}
XX
XX/* doloop - common do routine */
XXLOCAL NODE *doloop(args,pflag)
XX NODE *args; int pflag;
XX{
XX NODE *oldstk,*oldenv,*oldnewenv,arg,blist,clist,test,*rval;
XX int rbreak;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&arg,&blist,&clist,&test,NULL);
XX
XX /* initialize */
XX arg.n_ptr = args;
XX
XX /* get the list of bindings and bind the symbols */
XX blist.n_ptr = xlmatch(LIST,&arg.n_ptr);
XX oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
XX dobindings(blist.n_ptr,pflag);
XX
XX /* get the exit test and result forms */
XX clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
XX test.n_ptr = xlarg(&clist.n_ptr);
XX
XX /* execute the loop as long as the test is false */
XX rbreak = FALSE;
XX while (xleval(test.n_ptr) == NIL) {
XX
XX /* execute the body of the loop */
XX if (tagblock(arg.n_ptr,&rval)) {
XX rbreak = TRUE;
XX break;
XX }
XX
XX /* update the looping variables */
XX doupdates(blist.n_ptr,pflag);
XX }
XX
XX /* evaluate the result expression */
XX if (!rbreak)
XX for (rval = NIL; consp(clist.n_ptr); )
XX rval = xlevarg(&clist.n_ptr);
XX
XX /* unbind the arguments */
XX xlunbind(oldenv); xlnewenv = oldnewenv;
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the result */
XX return (rval);
XX}
XX
XX/* xdolist - built-in function 'dolist' */
XXNODE *xdolist(args)
XX NODE *args;
XX{
XX NODE *oldstk,*oldenv,arg,clist,sym,list,val,*rval;
XX int rbreak;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&arg,&clist,&sym,&list,&val,NULL);
XX
XX /* initialize */
XX arg.n_ptr = args;
XX
XX /* get the control list (sym list result-expr) */
XX clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
XX sym.n_ptr = xlmatch(SYM,&clist.n_ptr);
XX list.n_ptr = xlevmatch(LIST,&clist.n_ptr);
XX val.n_ptr = (clist.n_ptr ? xlarg(&clist.n_ptr) : NIL);
XX
XX /* initialize the local environment */
XX oldenv = xlenv;
XX xlsbind(sym.n_ptr,NIL);
XX
XX /* loop through the list */
XX rbreak = FALSE;
XX for (; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
XX
XX /* bind the symbol to the next list element */
XX sym.n_ptr->n_symvalue = car(list.n_ptr);
XX
XX /* execute the loop body */
XX if (tagblock(arg.n_ptr,&rval)) {
XX rbreak = TRUE;
XX break;
XX }
XX }
XX
XX /* evaluate the result expression */
XX if (!rbreak) {
XX sym.n_ptr->n_symvalue = NIL;
XX rval = xleval(val.n_ptr);
XX }
XX
XX /* unbind the arguments */
XX xlunbind(oldenv);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the result */
XX return (rval);
XX}
XX
XX/* xdotimes - built-in function 'dotimes' */
XXNODE *xdotimes(args)
XX NODE *args;
XX{
XX NODE *oldstk,*oldenv,arg,clist,sym,val,*rval;
XX int rbreak,cnt,i;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&arg,&clist,&sym,&val,NULL);
XX
XX /* initialize */
XX arg.n_ptr = args;
XX
XX /* get the control list (sym list result-expr) */
XX clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
XX sym.n_ptr = xlmatch(SYM,&clist.n_ptr);
XX cnt = xlevmatch(INT,&clist.n_ptr)->n_int;
XX val.n_ptr = (clist.n_ptr ? xlarg(&clist.n_ptr) : NIL);
XX
XX /* initialize the local environment */
XX oldenv = xlenv;
XX xlsbind(sym.n_ptr,NIL);
XX
XX /* loop through for each value from zero to cnt-1 */
XX rbreak = FALSE;
XX for (i = 0; i < cnt; i++) {
XX
XX /* bind the symbol to the next list element */
XX sym.n_ptr->n_symvalue = newnode(INT);
XX sym.n_ptr->n_symvalue->n_int = i;
XX
XX /* execute the loop body */
XX if (tagblock(arg.n_ptr,&rval)) {
XX rbreak = TRUE;
XX break;
XX }
XX }
XX
XX /* evaluate the result expression */
XX if (!rbreak) {
XX sym.n_ptr->n_symvalue = newnode(INT);
XX sym.n_ptr->n_symvalue->n_int = cnt;
XX rval = xleval(val.n_ptr);
XX }
XX
XX /* unbind the arguments */
XX xlunbind(oldenv);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the result */
XX return (rval);
XX}
XX
XX/* xcatch - built-in function 'catch' */
XXNODE *xcatch(args)
XX NODE *args;
XX{
XX NODE *oldstk,tag,arg,*val;
XX CONTEXT cntxt;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&tag,&arg,NULL);
XX
XX /* initialize */
XX tag.n_ptr = xlevarg(&args);
XX arg.n_ptr = args;
XX val = NIL;
XX
XX /* establish an execution context */
XX xlbegin(&cntxt,CF_THROW,tag.n_ptr);
XX
XX /* check for 'throw' */
XX if (setjmp(cntxt.c_jmpbuf))
XX val = xlvalue;
XX
XX /* otherwise, evaluate the remainder of the arguments */
XX else {
XX while (arg.n_ptr)
XX val = xlevarg(&arg.n_ptr);
XX }
XX xlend(&cntxt);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the result */
XX return (val);
XX}
XX
XX/* xthrow - built-in function 'throw' */
XXNODE *xthrow(args)
XX NODE *args;
XX{
XX NODE *tag,*val;
XX
XX /* get the tag and value */
XX tag = xlarg(&args);
XX val = (args ? xlarg(&args) : NIL);
XX xllastarg(args);
XX
XX /* throw the tag */
XX xlthrow(tag,val);
XX}
XX
XX/* xerror - built-in function 'error' */
XXNODE *xerror(args)
XX NODE *args;
XX{
XX char *emsg; NODE *arg;
XX
XX /* get the error message and the argument */
XX emsg = xlmatch(STR,&args)->n_str;
XX arg = (args ? xlarg(&args) : s_unbound);
XX xllastarg(args);
XX
XX /* signal the error */
XX xlerror(emsg,arg);
XX}
XX
XX/* xcerror - built-in function 'cerror' */
XXNODE *xcerror(args)
XX NODE *args;
XX{
XX char *cmsg,*emsg; NODE *arg;
XX
XX /* get the correction message, the error message, and the argument */
XX cmsg = xlmatch(STR,&args)->n_str;
XX emsg = xlmatch(STR,&args)->n_str;
XX arg = (args ? xlarg(&args) : s_unbound);
XX xllastarg(args);
XX
XX /* signal the error */
XX xlcerror(cmsg,emsg,arg);
XX
XX /* return nil */
XX return (NIL);
XX}
XX
XX/* xbreak - built-in function 'break' */
XXNODE *xbreak(args)
XX NODE *args;
XX{
XX char *emsg; NODE *arg;
XX
XX /* get the error message */
XX emsg = (args ? xlmatch(STR,&args)->n_str : "**BREAK**");
XX arg = (args ? xlarg(&args) : s_unbound);
XX xllastarg(args);
XX
XX /* enter the break loop */
XX xlbreak(emsg,arg);
XX
XX /* return nil */
XX return (NIL);
XX}
XX
XX/* xerrset - built-in function 'errset' */
XXNODE *xerrset(args)
XX NODE *args;
XX{
XX NODE *oldstk,expr,flag,*val;
XX CONTEXT cntxt;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&expr,&flag,NULL);
XX
XX /* get the expression and the print flag */
XX expr.n_ptr = xlarg(&args);
XX flag.n_ptr = (args ? xlarg(&args) : true);
XX xllastarg(args);
XX
XX /* establish an execution context */
XX xlbegin(&cntxt,CF_ERROR,flag.n_ptr);
XX
XX /* check for error */
XX if (setjmp(cntxt.c_jmpbuf))
XX val = NIL;
XX
XX /* otherwise, evaluate the expression */
XX else {
XX expr.n_ptr = xleval(expr.n_ptr);
XX val = newnode(LIST);
XX rplaca(val,expr.n_ptr);
XX }
XX xlend(&cntxt);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the result */
XX return (val);
XX}
XX
XX/* xevalhook - eval hook function */
XXNODE *xevalhook(args)
XX NODE *args;
XX{
XX NODE *oldstk,*oldenv,expr,ehook,ahook,*val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&expr,&ehook,&ahook,NULL);
XX
XX /* get the expression and the hook functions */
XX expr.n_ptr = xlarg(&args);
XX ehook.n_ptr = xlarg(&args);
XX ahook.n_ptr = xlarg(&args);
XX xllastarg(args);
XX
XX /* bind *evalhook* and *applyhook* to the hook functions */
XX oldenv = xlenv;
XX xlsbind(s_evalhook,ehook.n_ptr);
XX xlsbind(s_applyhook,ahook.n_ptr);
XX
XX /* evaluate the expression (bypassing *evalhook*) */
XX val = xlxeval(expr.n_ptr);
XX
XX /* unbind the hook variables */
XX xlunbind(oldenv);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the result */
XX return (val);
XX}
XX
XX/* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
XXLOCAL dobindings(blist,pflag)
XX NODE *blist; int pflag;
XX{
XX NODE *oldstk,list,bnd,sym,val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&list,&bnd,&sym,&val,NULL);
XX
XX /* bind each symbol in the list of bindings */
XX for (list.n_ptr = blist; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
XX
XX /* get the next binding */
XX bnd.n_ptr = car(list.n_ptr);
XX
XX /* handle a symbol */
XX if (symbolp(bnd.n_ptr)) {
XX sym.n_ptr = bnd.n_ptr;
XX val.n_ptr = NIL;
XX }
XX
XX /* handle a list of the form (symbol expr) */
XX else if (consp(bnd.n_ptr)) {
XX sym.n_ptr = xlmatch(SYM,&bnd.n_ptr);
XX val.n_ptr = xlevarg(&bnd.n_ptr);
XX }
XX else
XX xlfail("bad binding");
XX
XX /* bind the value to the symbol */
XX if (pflag)
XX xlbind(sym.n_ptr,val.n_ptr);
XX else
XX xlsbind(sym.n_ptr,val.n_ptr);
XX }
XX
XX /* fix the bindings on a parallel let */
XX if (pflag)
XX xlfixbindings();
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX}
XX
XX/* doupdates - handle updates for do/do* */
XXdoupdates(blist,pflag)
XX NODE *blist; int pflag;
XX{
XX NODE *oldstk,*oldenv,*oldnewenv,list,bnd,sym,val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&list,&bnd,&sym,&val,NULL);
XX
XX /* initialize the local environment */
XX if (pflag) {
XX oldenv = xlenv; oldnewenv = xlnewenv;
XX }
XX
XX /* bind each symbol in the list of bindings */
XX for (list.n_ptr = blist; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
XX
XX /* get the next binding */
XX bnd.n_ptr = car(list.n_ptr);
XX
XX /* handle a list of the form (symbol expr) */
XX if (consp(bnd.n_ptr)) {
XX sym.n_ptr = xlmatch(SYM,&bnd.n_ptr);
XX bnd.n_ptr = cdr(bnd.n_ptr);
XX if (bnd.n_ptr) {
XX val.n_ptr = xlevarg(&bnd.n_ptr);
XX if (pflag)
XX xlbind(sym.n_ptr,val.n_ptr);
XX else
XX sym.n_ptr->n_symvalue = val.n_ptr;
XX }
XX }
XX }
XX
XX /* fix the bindings on a parallel let */
XX if (pflag) {
XX xlfixbindings();
XX xlenv = oldenv; xlnewenv = oldnewenv;
XX }
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX}
XX
XX/* tagblock - execute code within a block and tagbody */
XXint tagblock(code,pval)
XX NODE *code,**pval;
XX{
XX NODE *oldstk,arg;
XX CONTEXT cntxt;
XX int type,sts;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&arg,NULL);
XX
XX /* initialize */
XX arg.n_ptr = code;
XX
XX /* establish an execution context */
XX xlbegin(&cntxt,CF_GO|CF_RETURN,arg.n_ptr);
XX
XX /* check for a 'return' */
XX if ((type = setjmp(cntxt.c_jmpbuf)) == CF_RETURN) {
XX *pval = xlvalue;
XX sts = TRUE;
XX }
XX
XX /* otherwise, enter the body */
XX else {
XX
XX /* check for a 'go' */
XX if (type == CF_GO)
XX arg.n_ptr = xlvalue;
XX
XX /* evaluate each expression in the body */
XX while (consp(arg.n_ptr))
XX if (consp(car(arg.n_ptr)))
XX xlevarg(&arg.n_ptr);
XX else
XX arg.n_ptr = cdr(arg.n_ptr);
XX
XX /* indicate that we fell through the bottom of the tagbody */
XX *pval = NIL;
XX sts = FALSE;
XX }
XX xlend(&cntxt);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return status */
XX return (sts);
XX}
SHAR_EOF
if test 16880 -ne "`wc -c xlcont.c`"
then
echo shar: error transmitting xlcont.c '(should have been 16880 characters)'
fi
echo shar: extracting xllist.c '(17752 characters)'
sed 's/^XX//' << \SHAR_EOF > xllist.c
XX/* xllist - xlisp built-in list functions */
XX
XX#include "xlisp.h"
XX
XX#ifdef MEGAMAX
XXoverlay "overflow"
XX#endif
XX
XX/* external variables */
XXextern NODE *xlstack;
XXextern NODE *s_unbound;
XXextern NODE *true;
XX
XX/* external routines */
XXextern int eq(),eql(),equal();
XX
XX/* forward declarations */
XXFORWARD NODE *cxr();
XXFORWARD NODE *nth(),*assoc();
XXFORWARD NODE *subst(),*sublis(),*map();
XXFORWARD NODE *cequal();
XX
XX/* xcar - return the car of a list */
XXNODE *xcar(args)
XX NODE *args;
XX{
XX return (cxr(args,"a"));
XX}
XX
XX/* xcdr - return the cdr of a list */
XXNODE *xcdr(args)
XX NODE *args;
XX{
XX return (cxr(args,"d"));
XX}
XX
XX/* xcaar - return the caar of a list */
XXNODE *xcaar(args)
XX NODE *args;
XX{
XX return (cxr(args,"aa"));
XX}
XX
XX/* xcadr - return the cadr of a list */
XXNODE *xcadr(args)
XX NODE *args;
XX{
XX return (cxr(args,"da"));
XX}
XX
XX/* xcdar - return the cdar of a list */
XXNODE *xcdar(args)
XX NODE *args;
XX{
XX return (cxr(args,"ad"));
XX}
XX
XX/* xcddr - return the cddr of a list */
XXNODE *xcddr(args)
XX NODE *args;
XX{
XX return (cxr(args,"dd"));
XX}
XX
XX/* cxr - common car/cdr routine */
XXLOCAL NODE *cxr(args,adstr)
XX NODE *args; char *adstr;
XX{
XX NODE *list;
XX
XX /* get the list */
XX list = xlmatch(LIST,&args);
XX xllastarg(args);
XX
XX /* perform the car/cdr operations */
XX while (*adstr && consp(list))
XX list = (*adstr++ == 'a' ? car(list) : cdr(list));
XX
XX /* make sure the operation succeeded */
XX if (*adstr && list)
XX xlfail("bad argument");
XX
XX /* return the result */
XX return (list);
XX}
XX
XX/* xcons - construct a new list cell */
XXNODE *xcons(args)
XX NODE *args;
XX{
XX NODE *arg1,*arg2,*val;
XX
XX /* get the two arguments */
XX arg1 = xlarg(&args);
XX arg2 = xlarg(&args);
XX xllastarg(args);
XX
XX /* construct a new list element */
XX val = newnode(LIST);
XX rplaca(val,arg1);
XX rplacd(val,arg2);
XX
XX /* return the list */
XX return (val);
XX}
XX
XX/* xlist - built a list of the arguments */
XXNODE *xlist(args)
XX NODE *args;
XX{
XX NODE *oldstk,arg,list,val,*last,*lptr;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&arg,&list,&val,NULL);
XX
XX /* initialize */
XX arg.n_ptr = args;
XX
XX /* evaluate and append each argument */
XX for (last = NIL; arg.n_ptr != NIL; last = lptr) {
XX
XX /* evaluate the next argument */
XX val.n_ptr = xlarg(&arg.n_ptr);
XX
XX /* append this argument to the end of the list */
XX lptr = newnode(LIST);
XX if (last == NIL)
XX list.n_ptr = lptr;
XX else
XX rplacd(last,lptr);
XX rplaca(lptr,val.n_ptr);
XX }
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the list */
XX return (list.n_ptr);
XX}
XX
XX/* xappend - built-in function append */
XXNODE *xappend(args)
XX NODE *args;
XX{
XX NODE *oldstk,arg,list,last,val,*lptr;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&arg,&list,&last,&val,NULL);
XX
XX /* initialize */
XX arg.n_ptr = args;
XX
XX /* evaluate and append each argument */
XX while (arg.n_ptr) {
XX
XX /* evaluate the next argument */
XX list.n_ptr = xlmatch(LIST,&arg.n_ptr);
XX
XX /* append each element of this list to the result list */
XX while (consp(list.n_ptr)) {
XX
XX /* append this element */
XX lptr = newnode(LIST);
XX if (last.n_ptr == NIL)
XX val.n_ptr = lptr;
XX else
XX rplacd(last.n_ptr,lptr);
XX rplaca(lptr,car(list.n_ptr));
XX
XX /* save the new last element */
XX last.n_ptr = lptr;
XX
XX /* move to the next element */
XX list.n_ptr = cdr(list.n_ptr);
XX }
XX }
XX
XX /* restore previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the list */
XX return (val.n_ptr);
XX}
XX
XX/* xreverse - built-in function reverse */
XXNODE *xreverse(args)
XX NODE *args;
XX{
XX NODE *oldstk,list,val,*lptr;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&list,&val,NULL);
XX
XX /* get the list to reverse */
XX list.n_ptr = xlmatch(LIST,&args);
XX xllastarg(args);
XX
XX /* append each element of this list to the result list */
XX while (consp(list.n_ptr)) {
XX
XX /* append this element */
XX lptr = newnode(LIST);
XX rplaca(lptr,car(list.n_ptr));
XX rplacd(lptr,val.n_ptr);
XX val.n_ptr = lptr;
XX
XX /* move to the next element */
XX list.n_ptr = cdr(list.n_ptr);
XX }
XX
XX /* restore previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the list */
XX return (val.n_ptr);
XX}
XX
XX/* xlast - return the last cons of a list */
XXNODE *xlast(args)
XX NODE *args;
XX{
XX NODE *list;
XX
XX /* get the list */
XX list = xlmatch(LIST,&args);
XX xllastarg(args);
XX
XX /* find the last cons */
XX while (consp(list) && cdr(list))
XX list = cdr(list);
XX
XX /* return the last element */
XX return (list);
XX}
XX
XX/* xmember - built-in function 'member' */
XXNODE *xmember(args)
XX NODE *args;
XX{
XX NODE *oldstk,x,list,fcn,*val;
XX int tresult;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&x,&list,&fcn,NULL);
XX
XX /* get the expression to look for and the list */
XX x.n_ptr = xlarg(&args);
XX list.n_ptr = xlmatch(LIST,&args);
XX xltest(&fcn.n_ptr,&tresult,&args);
XX xllastarg(args);
XX
XX /* look for the expression */
XX for (val = NIL; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr))
XX if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) == tresult) {
XX val = list.n_ptr;
XX break;
XX }
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the result */
XX return (val);
XX}
XX
XX/* xassoc - built-in function 'assoc' */
XXNODE *xassoc(args)
XX NODE *args;
XX{
XX NODE *oldstk,x,alist,fcn,*pair,*val;
XX int tresult;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&x,&alist,&fcn,NULL);
XX
XX /* get the expression to look for and the association list */
XX x.n_ptr = xlarg(&args);
XX alist.n_ptr = xlmatch(LIST,&args);
XX xltest(&fcn.n_ptr,&tresult,&args);
XX xllastarg(args);
XX
XX /* look for the expression */
XX for (val = NIL; consp(alist.n_ptr); alist.n_ptr = cdr(alist.n_ptr))
XX if ((pair = car(alist.n_ptr)) && consp(pair))
XX if (dotest(x.n_ptr,car(pair),fcn.n_ptr) == tresult) {
XX val = pair;
XX break;
XX }
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the result */
XX return (val);
XX}
XX
XX/* xsubst - substitute one expression for another */
XXNODE *xsubst(args)
XX NODE *args;
XX{
XX NODE *oldstk,to,from,expr,fcn,*val;
XX int tresult;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&to,&from,&expr,&fcn,NULL);
XX
XX /* get the to value, the from value and the expression */
XX to.n_ptr = xlarg(&args);
XX from.n_ptr = xlarg(&args);
XX expr.n_ptr = xlarg(&args);
XX xltest(&fcn.n_ptr,&tresult,&args);
XX xllastarg(args);
XX
XX /* do the substitution */
XX val = subst(to.n_ptr,from.n_ptr,expr.n_ptr,fcn.n_ptr,tresult);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the result */
XX return (val);
XX}
XX
XX/* subst - substitute one expression for another */
XXLOCAL NODE *subst(to,from,expr,fcn,tresult)
XX NODE *to,*from,*expr,*fcn; int tresult;
XX{
XX NODE *oldstk,carval,cdrval,*val;
XX
XX if (dotest(expr,from,fcn) == tresult)
XX val = to;
XX else if (consp(expr)) {
XX oldstk = xlsave(&carval,&cdrval,NULL);
XX carval.n_ptr = subst(to,from,car(expr),fcn,tresult);
XX cdrval.n_ptr = subst(to,from,cdr(expr),fcn,tresult);
XX val = newnode(LIST);
XX rplaca(val,carval.n_ptr);
XX rplacd(val,cdrval.n_ptr);
XX xlstack = oldstk;
XX }
XX else
XX val = expr;
XX return (val);
XX}
XX
XX/* xsublis - substitute using an association list */
XXNODE *xsublis(args)
XX NODE *args;
XX{
XX NODE *oldstk,alist,expr,fcn,*val;
XX int tresult;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&alist,&expr,&fcn,NULL);
XX
XX /* get the assocation list and the expression */
XX alist.n_ptr = xlmatch(LIST,&args);
XX expr.n_ptr = xlarg(&args);
XX xltest(&fcn.n_ptr,&tresult,&args);
XX xllastarg(args);
XX
XX /* do the substitution */
XX val = sublis(alist.n_ptr,expr.n_ptr,fcn.n_ptr,tresult);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the result */
XX return (val);
XX}
XX
XX/* sublis - substitute using an association list */
XXLOCAL NODE *sublis(alist,expr,fcn,tresult)
XX NODE *alist,*expr,*fcn; int tresult;
XX{
XX NODE *oldstk,carval,cdrval,*val;
XX
XX if (val = assoc(expr,alist,fcn,tresult))
XX val = cdr(val);
XX else if (consp(expr)) {
XX oldstk = xlsave(&carval,&cdrval,NULL);
XX carval.n_ptr = sublis(alist,car(expr),fcn,tresult);
XX cdrval.n_ptr = sublis(alist,cdr(expr),fcn,tresult);
XX val = newnode(LIST);
XX rplaca(val,carval.n_ptr);
XX rplacd(val,cdrval.n_ptr);
XX xlstack = oldstk;
XX }
XX else
XX val = expr;
XX return (val);
XX}
XX
XX/* assoc - find a pair in an association list */
XXLOCAL NODE *assoc(expr,alist,fcn,tresult)
XX NODE *expr,*alist,*fcn; int tresult;
XX{
XX NODE *pair;
XX
XX for (; consp(alist); alist = cdr(alist))
XX if ((pair = car(alist)) && consp(pair))
XX if (dotest(expr,car(pair),fcn) == tresult)
XX return (pair);
XX return (NIL);
XX}
XX
XX/* xremove - built-in function 'remove' */
XXNODE *xremove(args)
XX NODE *args;
XX{
XX NODE *oldstk,x,list,fcn,val,*p,*last;
XX int tresult;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&x,&list,&fcn,&val,NULL);
XX
XX /* get the expression to remove and the list */
XX x.n_ptr = xlarg(&args);
XX list.n_ptr = xlmatch(LIST,&args);
XX xltest(&fcn.n_ptr,&tresult,&args);
XX xllastarg(args);
XX
XX /* remove matches */
XX while (consp(list.n_ptr)) {
XX
XX /* check to see if this element should be deleted */
XX if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) != tresult) {
XX p = newnode(LIST);
XX rplaca(p,car(list.n_ptr));
XX if (val.n_ptr) rplacd(last,p);
XX else val.n_ptr = p;
XX last = p;
XX }
XX
XX /* move to the next element */
XX list.n_ptr = cdr(list.n_ptr);
XX }
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the updated list */
XX return (val.n_ptr);
XX}
XX
XX/* dotest - call a test function */
XXint dotest(arg1,arg2,fcn)
XX NODE *arg1,*arg2,*fcn;
XX{
XX NODE *oldstk,args,*val;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&args,NULL);
XX
XX /* build an argument list */
XX args.n_ptr = newnode(LIST);
XX rplaca(args.n_ptr,arg1);
XX rplacd(args.n_ptr,newnode(LIST));
XX rplaca(cdr(args.n_ptr),arg2);
XX
XX /* apply the test function */
XX val = xlapply(fcn,args.n_ptr);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the result of the test */
XX return (val != NIL);
XX}
XX
XX/* xnth - return the nth element of a list */
XXNODE *xnth(args)
XX NODE *args;
XX{
XX return (nth(args,FALSE));
XX}
XX
XX/* xnthcdr - return the nth cdr of a list */
XXNODE *xnthcdr(args)
XX NODE *args;
XX{
XX return (nth(args,TRUE));
XX}
XX
XX/* nth - internal nth function */
XXLOCAL NODE *nth(args,cdrflag)
XX NODE *args; int cdrflag;
XX{
XX NODE *list;
XX int n;
XX
XX /* get n and the list */
XX if ((n = xlmatch(INT,&args)->n_int) < 0)
XX xlfail("bad argument");
XX if ((list = xlmatch(LIST,&args)) == NIL)
XX xlfail("bad argument");
XX xllastarg(args);
XX
XX /* find the nth element */
XX for (; n > 0 && consp(list); n--)
XX list = cdr(list);
XX
XX /* return the list beginning at the nth element */
XX return (cdrflag || !consp(list) ? list : car(list));
XX}
XX
XX/* xlength - return the length of a list */
XXNODE *xlength(args)
XX NODE *args;
XX{
XX NODE *list,*val;
XX int n;
XX
XX /* get the list */
XX list = xlmatch(LIST,&args);
XX xllastarg(args);
XX
XX /* find the length */
XX for (n = 0; consp(list); n++)
XX list = cdr(list);
XX
XX /* create the value node */
XX val = newnode(INT);
XX val->n_int = n;
XX
XX /* return the length */
XX return (val);
XX}
XX
XX/* xmapc - built-in function 'mapc' */
XXNODE *xmapc(args)
XX NODE *args;
XX{
XX return (map(args,TRUE,FALSE));
XX}
XX
XX/* xmapcar - built-in function 'mapcar' */
XXNODE *xmapcar(args)
XX NODE *args;
XX{
XX return (map(args,TRUE,TRUE));
XX}
XX
XX/* xmapl - built-in function 'mapl' */
XXNODE *xmapl(args)
XX NODE *args;
XX{
XX return (map(args,FALSE,FALSE));
XX}
XX
XX/* xmaplist - built-in function 'maplist' */
XXNODE *xmaplist(args)
XX NODE *args;
XX{
XX return (map(args,FALSE,TRUE));
XX}
XX
XX/* map - internal mapping function */
XXLOCAL NODE *map(args,carflag,valflag)
XX NODE *args; int carflag,valflag;
XX{
XX NODE *oldstk,fcn,lists,arglist,val,*last,*p,*x,*y;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&fcn,&lists,&arglist,&val,NULL);
XX
XX /* get the function to apply and the first list */
XX fcn.n_ptr = xlarg(&args);
XX lists.n_ptr = xlmatch(LIST,&args);
XX
XX /* save the first list if not saving function values */
XX if (!valflag)
XX val.n_ptr = lists.n_ptr;
XX
XX /* set up the list of argument lists */
XX p = newnode(LIST);
XX rplaca(p,lists.n_ptr);
XX lists.n_ptr = p;
XX
XX /* get the remaining argument lists */
XX while (args) {
XX p = newnode(LIST);
XX rplacd(p,lists.n_ptr);
XX lists.n_ptr = p;
XX rplaca(p,xlmatch(LIST,&args));
XX }
XX
XX /* if the function is a symbol, get its value */
XX if (symbolp(fcn.n_ptr))
XX fcn.n_ptr = xleval(fcn.n_ptr);
XX
XX /* loop through each of the argument lists */
XX for (;;) {
XX
XX /* build an argument list from the sublists */
XX arglist.n_ptr = NIL;
XX for (x = lists.n_ptr; x && (y = car(x)) && consp(y); x = cdr(x)) {
XX p = newnode(LIST);
XX rplacd(p,arglist.n_ptr);
XX arglist.n_ptr = p;
XX rplaca(p,carflag ? car(y) : y);
XX rplaca(x,cdr(y));
XX }
XX
XX /* quit if any of the lists were empty */
XX if (x) break;
XX
XX /* apply the function to the arguments */
XX if (valflag) {
XX p = newnode(LIST);
XX if (val.n_ptr) rplacd(last,p);
XX else val.n_ptr = p;
XX rplaca(p,xlapply(fcn.n_ptr,arglist.n_ptr));
XX last = p;
XX }
XX else
XX xlapply(fcn.n_ptr,arglist.n_ptr);
XX }
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the last test expression value */
XX return (val.n_ptr);
XX}
XX
XX/* xrplca - replace the car of a list node */
XXNODE *xrplca(args)
XX NODE *args;
XX{
XX NODE *list,*newcar;
XX
XX /* get the list and the new car */
XX if ((list = xlmatch(LIST,&args)) == NIL)
XX xlfail("bad argument");
XX newcar = xlarg(&args);
XX xllastarg(args);
XX
XX /* replace the car */
XX rplaca(list,newcar);
XX
XX /* return the list node that was modified */
XX return (list);
XX}
XX
XX/* xrplcd - replace the cdr of a list node */
XXNODE *xrplcd(args)
XX NODE *args;
XX{
XX NODE *list,*newcdr;
XX
XX /* get the list and the new cdr */
XX if ((list = xlmatch(LIST,&args)) == NIL)
XX xlfail("bad argument");
XX newcdr = xlarg(&args);
XX xllastarg(args);
XX
XX /* replace the cdr */
XX rplacd(list,newcdr);
XX
XX /* return the list node that was modified */
XX return (list);
XX}
XX
XX/* xnconc - destructively append lists */
XXNODE *xnconc(args)
XX NODE *args;
XX{
XX NODE *list,*last,*val;
XX
XX /* concatenate each argument */
XX for (val = NIL; args; ) {
XX
XX /* concatenate this list */
XX if (list = xlmatch(LIST,&args)) {
XX
XX /* check for this being the first non-empty list */
XX if (val)
XX rplacd(last,list);
XX else
XX val = list;
XX
XX /* find the end of the list */
XX while (consp(cdr(list)))
XX list = cdr(list);
XX
XX /* save the new last element */
XX last = list;
XX }
XX }
XX
XX /* return the list */
XX return (val);
XX}
XX
XX/* xdelete - built-in function 'delete' */
XXNODE *xdelete(args)
XX NODE *args;
XX{
XX NODE *oldstk,x,list,fcn,*last,*val;
XX int tresult;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&x,&list,&fcn,NULL);
XX
XX /* get the expression to delete and the list */
XX x.n_ptr = xlarg(&args);
XX list.n_ptr = xlmatch(LIST,&args);
XX xltest(&fcn.n_ptr,&tresult,&args);
XX xllastarg(args);
XX
XX /* delete leading matches */
XX while (consp(list.n_ptr)) {
XX if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) != tresult)
XX break;
XX list.n_ptr = cdr(list.n_ptr);
XX }
XX val = last = list.n_ptr;
XX
XX /* delete embedded matches */
XX if (consp(list.n_ptr)) {
XX
XX /* skip the first non-matching element */
XX list.n_ptr = cdr(list.n_ptr);
XX
XX /* look for embedded matches */
XX while (consp(list.n_ptr)) {
XX
XX /* check to see if this element should be deleted */
XX if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) == tresult)
XX rplacd(last,cdr(list.n_ptr));
XX else
XX last = list.n_ptr;
XX
XX /* move to the next element */
XX list.n_ptr = cdr(list.n_ptr);
XX }
XX }
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the updated list */
XX return (val);
XX}
XX
XX/* xatom - is this an atom? */
XXNODE *xatom(args)
XX NODE *args;
XX{
XX NODE *arg;
XX arg = xlarg(&args);
XX xllastarg(args);
XX return (atom(arg) ? true : NIL);
XX}
XX
XX/* xsymbolp - is this an symbol? */
XXNODE *xsymbolp(args)
XX NODE *args;
XX{
XX NODE *arg;
XX arg = xlarg(&args);
XX xllastarg(args);
XX return (arg == NIL || symbolp(arg) ? true : NIL);
XX}
XX
XX/* xnumberp - is this an number? */
XXNODE *xnumberp(args)
XX NODE *args;
XX{
XX NODE *arg;
XX arg = xlarg(&args);
XX xllastarg(args);
XX return (fixp(arg) ? true : NIL);
XX}
XX
XX/* xboundp - is this a value bound to this symbol? */
XXNODE *xboundp(args)
XX NODE *args;
XX{
XX NODE *sym;
XX sym = xlmatch(SYM,&args);
XX xllastarg(args);
XX return (sym->n_symvalue == s_unbound ? NIL : true);
XX}
XX
XX/* xnull - is this null? */
XXNODE *xnull(args)
XX NODE *args;
XX{
XX NODE *arg;
XX arg = xlarg(&args);
XX xllastarg(args);
XX return (null(arg) ? true : NIL);
XX}
XX
XX/* xlistp - is this a list? */
XXNODE *xlistp(args)
XX NODE *args;
XX{
XX NODE *arg;
XX arg = xlarg(&args);
XX xllastarg(args);
XX return (listp(arg) ? true : NIL);
XX}
XX
XX/* xconsp - is this a cons? */
XXNODE *xconsp(args)
XX NODE *args;
XX{
XX NODE *arg;
XX arg = xlarg(&args);
XX xllastarg(args);
XX return (consp(arg) ? true : NIL);
XX}
XX
XX/* xeq - are these equal? */
XXNODE *xeq(args)
XX NODE *args;
XX{
XX return (cequal(args,eq));
XX}
XX
XX/* xeql - are these equal? */
XXNODE *xeql(args)
XX NODE *args;
XX{
XX return (cequal(args,eql));
XX}
XX
XX/* xequal - are these equal? */
XXNODE *xequal(args)
XX NODE *args;
XX{
XX return (cequal(args,equal));
XX}
XX
XX/* cequal - common eq/eql/equal function */
XXLOCAL NODE *cequal(args,fcn)
XX NODE *args; int (*fcn)();
XX{
XX NODE *arg1,*arg2;
XX
XX /* get the two arguments */
XX arg1 = xlarg(&args);
XX arg2 = xlarg(&args);
XX xllastarg(args);
XX
XX /* compare the arguments */
XX return ((*fcn)(arg1,arg2) ? true : NIL);
XX}
SHAR_EOF
if test 17752 -ne "`wc -c xllist.c`"
then
echo shar: error transmitting xllist.c '(should have been 17752 characters)'
fi
echo shar: extracting xlobj.c '(16101 characters)'
sed 's/^XX//' << \SHAR_EOF > xlobj.c
XX/* xlobj - xlisp object functions */
XX
XX#include "xlisp.h"
XX
XX#ifdef MEGAMAX
XXoverlay "overflow"
XX#endif
XX
XX/* external variables */
XXextern NODE *xlstack;
XXextern NODE *xlenv,*xlnewenv;
XXextern NODE *s_stdout;
XXextern NODE *self;
XXextern NODE *class;
XXextern NODE *object;
XXextern NODE *new;
XXextern NODE *isnew;
XXextern NODE *msgcls;
XXextern NODE *msgclass;
XXextern int varcnt;
XX
XX/* instance variable numbers for the class 'Class' */
XX#define MESSAGES 0 /* list of messages */
XX#define IVARS 1 /* list of instance variable names */
XX#define CVARS 2 /* list of class variable names */
XX#define CVALS 3 /* list of class variable values */
XX#define SUPERCLASS 4 /* pointer to the superclass */
XX#define IVARCNT 5 /* number of class instance variables */
XX#define IVARTOTAL 6 /* total number of instance variables */
XX
XX/* number of instance variables for the class 'Class' */
XX#define CLASSSIZE 7
XX
XX/* forward declarations */
XXFORWARD NODE *xlgetivar();
XXFORWARD NODE *xlsetivar();
XXFORWARD NODE *xlivar();
XXFORWARD NODE *xlcvar();
XXFORWARD NODE *findmsg();
XXFORWARD NODE *findvar();
XXFORWARD NODE *defvars();
XXFORWARD NODE *makelist();
XX
XX/* xlclass - define a class */
XXNODE *xlclass(name,vcnt)
XX char *name; int vcnt;
XX{
XX NODE *sym,*cls;
XX
XX /* create the class */
XX sym = xlsenter(name);
XX cls = sym->n_symvalue = newnode(OBJ);
XX cls->n_obclass = class;
XX cls->n_obdata = makelist(CLASSSIZE);
XX
XX /* set the instance variable counts */
XX if (vcnt > 0) {
XX xlsetivar(cls,IVARCNT,newnode(INT))->n_int = vcnt;
XX xlsetivar(cls,IVARTOTAL,newnode(INT))->n_int = vcnt;
XX }
XX
XX /* set the superclass to 'Object' */
XX xlsetivar(cls,SUPERCLASS,object);
XX
XX /* return the new class */
XX return (cls);
XX}
XX
XX/* xlmfind - find the message binding for a message to an object */
XXNODE *xlmfind(obj,msym)
XX NODE *obj,*msym;
XX{
XX return (findmsg(obj->n_obclass,msym));
XX}
XX
XX/* xlxsend - send a message to an object */
XXNODE *xlxsend(obj,msg,args)
XX NODE *obj,*msg,*args;
XX{
XX NODE *oldstk,*oldenv,*oldnewenv,method,cptr,eargs,val,*isnewmsg;
XX
XX /* save the old environment */
XX oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&method,&cptr,&eargs,&val,NULL);
XX
XX /* get the method for this message */
XX method.n_ptr = cdr(msg);
XX
XX /* make sure its a function or a subr */
XX if (!subrp(method.n_ptr) && !consp(method.n_ptr))
XX xlfail("bad method");
XX
XX /* bind the symbols 'self' and 'msgclass' */
XX xlbind(self,obj);
XX xlbind(msgclass,msgcls);
XX
XX /* evaluate the function call */
XX eargs.n_ptr = xlevlist(args);
XX if (subrp(method.n_ptr)) {
XX xlfixbindings();
XX val.n_ptr = (*method.n_ptr->n_subr)(eargs.n_ptr);
XX }
XX else {
XX
XX /* bind the formal arguments */
XX xlabind(car(method.n_ptr),eargs.n_ptr);
XX xlfixbindings();
XX
XX /* execute the code */
XX cptr.n_ptr = cdr(method.n_ptr);
XX while (cptr.n_ptr != NIL)
XX val.n_ptr = xlevarg(&cptr.n_ptr);
XX }
XX
XX /* restore the environment */
XX xlunbind(oldenv); xlnewenv = oldnewenv;
XX
XX /* after creating an object, send it the "isnew" message */
XX if (car(msg) == new && val.n_ptr != NIL) {
XX if ((isnewmsg = xlmfind(val.n_ptr,isnew)) == NIL)
XX xlfail("no method for the isnew message");
XX val.n_ptr = xlxsend(val.n_ptr,isnewmsg,args);
XX }
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the result value */
XX return (val.n_ptr);
XX}
XX
XX/* xlsend - send a message to an object (message in arg list) */
XXNODE *xlsend(obj,args)
XX NODE *obj,*args;
XX{
XX NODE *msg;
XX
XX /* find the message binding for this message */
XX if ((msg = xlmfind(obj,xlevmatch(SYM,&args))) == NIL)
XX xlfail("no method for this message");
XX
XX /* send the message */
XX return (xlxsend(obj,msg,args));
XX}
XX
XX/* xlobsym - find a class or instance variable for the current object */
XXNODE *xlobsym(sym)
XX NODE *sym;
XX{
XX NODE *obj;
XX
XX if ((obj = self->n_symvalue) != NIL && objectp(obj))
XX return (findvar(obj,sym));
XX else
XX return (NIL);
XX}
XX
XX/* mnew - create a new object instance */
XXLOCAL NODE *mnew()
XX{
XX NODE *oldstk,obj,*cls;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&obj,NULL);
XX
XX /* get the class */
XX cls = self->n_symvalue;
XX
XX /* generate a new object */
XX obj.n_ptr = newnode(OBJ);
XX obj.n_ptr->n_obclass = cls;
XX obj.n_ptr->n_obdata = makelist(getivcnt(cls,IVARTOTAL));
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the new object */
XX return (obj.n_ptr);
XX}
XX
XX/* misnew - initialize a new class */
XXLOCAL NODE *misnew(args)
XX NODE *args;
XX{
XX NODE *oldstk,super,*obj;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&super,NULL);
XX
XX /* get the superclass if there is one */
XX if (args != NIL)
XX super.n_ptr = xlmatch(OBJ,&args);
XX else
XX super.n_ptr = object;
XX xllastarg(args);
XX
XX /* get the object */
XX obj = self->n_symvalue;
XX
XX /* store the superclass */
XX xlsetivar(obj,SUPERCLASS,super.n_ptr);
XX xlsetivar(obj,IVARTOTAL,newnode(INT))->n_int =
XX getivcnt(super.n_ptr,IVARTOTAL);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the new object */
XX return (obj);
XX}
XX
XX/* xladdivar - enter an instance variable */
XXxladdivar(cls,var)
XX NODE *cls; char *var;
XX{
XX NODE *ivar,*lptr;
XX
XX /* find the 'ivars' instance variable */
XX ivar = xlivar(cls,IVARS);
XX
XX /* add the instance variable */
XX lptr = newnode(LIST);
XX rplacd(lptr,car(ivar));
XX rplaca(ivar,lptr);
XX rplaca(lptr,xlsenter(var));
XX}
XX
XX/* entermsg - add a message to a class */
XXLOCAL NODE *entermsg(cls,msg)
XX NODE *cls,*msg;
XX{
XX NODE *ivar,*lptr,*mptr;
XX
XX /* find the 'messages' instance variable */
XX ivar = xlivar(cls,MESSAGES);
XX
XX /* lookup the message */
XX for (lptr = car(ivar); lptr != NIL; lptr = cdr(lptr))
XX if (car(mptr = car(lptr)) == msg)
XX return (mptr);
XX
XX /* allocate a new message entry if one wasn't found */
XX lptr = newnode(LIST);
XX rplacd(lptr,car(ivar));
XX rplaca(ivar,lptr);
XX rplaca(lptr,mptr = newnode(LIST));
XX rplaca(mptr,msg);
XX
XX /* return the symbol node */
XX return (mptr);
XX}
XX
XX/* answer - define a method for answering a message */
XXLOCAL NODE *answer(args)
XX NODE *args;
XX{
XX NODE *oldstk,arg,msg,fargs,code;
XX NODE *obj,*mptr,*fptr;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&arg,&msg,&fargs,&code,NULL);
XX
XX /* initialize */
XX arg.n_ptr = args;
XX
XX /* message symbol, formal argument list and code */
XX msg.n_ptr = xlmatch(SYM,&arg.n_ptr);
XX fargs.n_ptr = xlmatch(LIST,&arg.n_ptr);
XX code.n_ptr = xlmatch(LIST,&arg.n_ptr);
XX xllastarg(arg.n_ptr);
XX
XX /* get the object node */
XX obj = self->n_symvalue;
XX
XX /* make a new message list entry */
XX mptr = entermsg(obj,msg.n_ptr);
XX
XX /* setup the message node */
XX rplacd(mptr,fptr = newnode(LIST));
XX rplaca(fptr,fargs.n_ptr);
XX rplacd(fptr,code.n_ptr);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the object */
XX return (obj);
XX}
XX
XX/* mivars - define the list of instance variables */
XXLOCAL NODE *mivars(args)
XX NODE *args;
XX{
XX NODE *cls,*super;
XX int scnt;
XX
XX /* define the list of instance variables */
XX cls = defvars(args,IVARS);
XX
XX /* get the superclass instance variable count */
XX if ((super = xlgetivar(cls,SUPERCLASS)) != NIL)
XX scnt = getivcnt(super,IVARTOTAL);
XX else
XX scnt = 0;
XX
XX /* save the number of instance variables */
XX xlsetivar(cls,IVARCNT,newnode(INT))->n_int = varcnt;
XX xlsetivar(cls,IVARTOTAL,newnode(INT))->n_int = scnt+varcnt;
XX
XX /* return the class */
XX return (cls);
XX}
XX
XX/* getivcnt - get the number of instance variables for a class */
XXLOCAL int getivcnt(cls,ivar)
XX NODE *cls; int ivar;
XX{
XX NODE *cnt;
XX
XX if ((cnt = xlgetivar(cls,ivar)) != NIL)
XX if (fixp(cnt))
XX return (cnt->n_int);
XX else
XX xlfail("bad value for instance variable count");
XX else
XX return (0);
XX}
XX
XX/* mcvars - define the list of class variables */
XXLOCAL NODE *mcvars(args)
XX NODE *args;
XX{
XX NODE *cls;
XX
XX /* define the list of class variables */
XX cls = defvars(args,CVARS);
XX
XX /* make a new list of values */
XX xlsetivar(cls,CVALS,makelist(varcnt));
XX
XX /* return the class */
XX return (cls);
XX}
XX
XX/* defvars - define a class or instance variable list */
XXLOCAL NODE *defvars(args,varnum)
XX NODE *args; int varnum;
XX{
XX NODE *oldstk,vars,*vptr,*cls,*sym;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&vars,NULL);
XX
XX /* get ivar list */
XX vars.n_ptr = xlmatch(LIST,&args);
XX xllastarg(args);
XX
XX /* get the class node */
XX cls = self->n_symvalue;
XX
XX /* check each variable in the list */
XX varcnt = 0;
XX for (vptr = vars.n_ptr;
XX consp(vptr);
XX vptr = cdr(vptr)) {
XX
XX /* make sure this is a valid symbol in the list */
XX if ((sym = car(vptr)) == NIL || !symbolp(sym))
XX xlfail("bad variable list");
XX
XX /* make sure its not already defined */
XX if (checkvar(cls,sym))
XX xlfail("multiply defined variable");
XX
XX /* count the variable */
XX varcnt++;
XX }
XX
XX /* make sure the list ended properly */
XX if (vptr != NIL)
XX xlfail("bad variable list");
XX
XX /* define the new variable list */
XX xlsetivar(cls,varnum,vars.n_ptr);
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the class */
XX return (cls);
XX}
XX
XX/* xladdmsg - add a message to a class */
XXxladdmsg(cls,msg,code)
XX NODE *cls; char *msg; NODE *(*code)();
XX{
XX NODE *mptr;
XX
XX /* enter the message selector */
XX mptr = entermsg(cls,xlsenter(msg));
XX
XX /* store the method for this message */
XX rplacd(mptr,newnode(SUBR));
XX cdr(mptr)->n_subr = code;
XX}
XX
XX/* getclass - get the class of an object */
XXLOCAL NODE *getclass(args)
XX NODE *args;
XX{
XX /* make sure there aren't any arguments */
XX xllastarg(args);
XX
XX /* return the object's class */
XX return (self->n_symvalue->n_obclass);
XX}
XX
XX/* obshow - show the instance variables of an object */
XXLOCAL NODE *obshow(args)
XX NODE *args;
XX{
XX NODE *fptr;
XX
XX /* get the file pointer */
XX fptr = (args ? xlmatch(FPTR,&args) : s_stdout->n_symvalue);
XX xllastarg(args);
XX
XX /* print the object's instance variables */
XX xlprint(fptr,self->n_symvalue->n_obdata,TRUE);
XX xlterpri(fptr);
XX
XX /* return the object */
XX return (self->n_symvalue);
XX}
XX
XX/* defisnew - default 'isnew' method */
XXLOCAL NODE *defisnew(args)
XX NODE *args;
XX{
XX /* make sure there aren't any arguments */
XX xllastarg(args);
XX
XX /* return the object */
XX return (self->n_symvalue);
XX}
XX
XX/* sendsuper - send a message to an object's superclass */
XXLOCAL NODE *sendsuper(args)
XX NODE *args;
XX{
XX NODE *obj,*super,*msg;
XX
XX /* get the object */
XX obj = self->n_symvalue;
XX
XX /* get the object's superclass */
XX super = xlgetivar(obj->n_obclass,SUPERCLASS);
XX
XX /* find the message binding for this message */
XX if ((msg = findmsg(super,xlmatch(SYM,&args))) == NIL)
XX xlfail("no method for this message");
XX
XX /* send the message */
XX return (xlxsend(obj,msg,args));
XX}
XX
XX/* findmsg - find the message binding given an object and a class */
XXLOCAL NODE *findmsg(cls,sym)
XX NODE *cls,*sym;
XX{
XX NODE *lptr,*msg;
XX
XX /* start at the specified class */
XX msgcls = cls;
XX
XX /* look for the message in the class or superclasses */
XX while (msgcls != NIL) {
XX
XX /* lookup the message in this class */
XX for (lptr = xlgetivar(msgcls,MESSAGES);
XX lptr != NIL;
XX lptr = cdr(lptr))
XX if ((msg = car(lptr)) != NIL && car(msg) == sym)
XX return (msg);
XX
XX /* look in class's superclass */
XX msgcls = xlgetivar(msgcls,SUPERCLASS);
XX }
XX
XX /* message not found */
XX return (NIL);
XX}
XX
XX/* findvar - find a class or instance variable */
XXLOCAL NODE *findvar(obj,sym)
XX NODE *obj,*sym;
XX{
XX NODE *cls,*lptr;
XX int base,varnum;
XX int found;
XX
XX /* get the class of the object */
XX cls = obj->n_obclass;
XX
XX /* get the total number of instance variables */
XX base = getivcnt(cls,IVARTOTAL);
XX
XX /* find the variable */
XX found = FALSE;
XX for (; cls != NIL; cls = xlgetivar(cls,SUPERCLASS)) {
XX
XX /* get the number of instance variables for this class */
XX if ((base -= getivcnt(cls,IVARCNT)) < 0)
XX xlfail("error finding instance variable");
XX
XX /* check for finding the class of the current message */
XX if (!found && cls == msgclass->n_symvalue)
XX found = TRUE;
XX
XX /* lookup the instance variable */
XX varnum = 0;
XX for (lptr = xlgetivar(cls,IVARS);
XX lptr != NIL;
XX lptr = cdr(lptr))
XX if (found && car(lptr) == sym)
XX return (xlivar(obj,base + varnum));
XX else
XX varnum++;
XX
XX /* skip the class variables if the message class hasn't been found */
XX if (!found)
XX continue;
XX
XX /* lookup the class variable */
XX varnum = 0;
XX for (lptr = xlgetivar(cls,CVARS);
XX lptr != NIL;
XX lptr = cdr(lptr))
XX if (car(lptr) == sym)
XX return (xlcvar(cls,varnum));
XX else
XX varnum++;
XX }
XX
XX /* variable not found */
XX return (NIL);
XX}
XX
XX/* checkvar - check for an existing class or instance variable */
XXLOCAL int checkvar(cls,sym)
XX NODE *cls,*sym;
XX{
XX NODE *lptr;
XX
XX /* find the variable */
XX for (; cls != NIL; cls = xlgetivar(cls,SUPERCLASS)) {
XX
XX /* lookup the instance variable */
XX for (lptr = xlgetivar(cls,IVARS);
XX lptr != NIL;
XX lptr = cdr(lptr))
XX if (car(lptr) == sym)
XX return (TRUE);
XX
XX /* lookup the class variable */
XX for (lptr = xlgetivar(cls,CVARS);
XX lptr != NIL;
XX lptr = cdr(lptr))
XX if (car(lptr) == sym)
XX return (TRUE);
XX }
XX
XX /* variable not found */
XX return (FALSE);
XX}
XX
XX/* xlgetivar - get the value of an instance variable */
XXNODE *xlgetivar(obj,num)
XX NODE *obj; int num;
XX{
XX return (car(xlivar(obj,num)));
XX}
XX
XX/* xlsetivar - set the value of an instance variable */
XXNODE *xlsetivar(obj,num,val)
XX NODE *obj; int num; NODE *val;
XX{
XX rplaca(xlivar(obj,num),val);
XX return (val);
XX}
XX
XX/* xlivar - get an instance variable */
XXNODE *xlivar(obj,num)
XX NODE *obj; int num;
XX{
XX NODE *ivar;
XX
XX /* get the instance variable */
XX for (ivar = obj->n_obdata; num > 0; num--)
XX if (ivar != NIL)
XX ivar = cdr(ivar);
XX else
XX xlfail("bad instance variable list");
XX
XX /* return the instance variable */
XX return (ivar);
XX}
XX
XX/* xlcvar - get a class variable */
XXNODE *xlcvar(cls,num)
XX NODE *cls; int num;
XX{
XX NODE *cvar;
XX
XX /* get the class variable */
XX for (cvar = xlgetivar(cls,CVALS); num > 0; num--)
XX if (cvar != NIL)
XX cvar = cdr(cvar);
XX else
XX xlfail("bad class variable list");
XX
XX /* return the class variable */
XX return (cvar);
XX}
XX
XX/* makelist - make a list of nodes */
XXLOCAL NODE *makelist(cnt)
XX int cnt;
XX{
XX NODE *oldstk,list,*lnew;
XX
XX /* create a new stack frame */
XX oldstk = xlsave(&list,NULL);
XX
XX /* make the list */
XX for (; cnt > 0; cnt--) {
XX lnew = newnode(LIST);
XX rplacd(lnew,list.n_ptr);
XX list.n_ptr = lnew;
XX }
XX
XX /* restore the previous stack frame */
XX xlstack = oldstk;
XX
XX /* return the list */
XX return (list.n_ptr);
XX}
XX
XX/* xloinit - object function initialization routine */
XXxloinit()
XX{
XX /* don't confuse the garbage collector */
XX class = object = NIL;
XX
XX /* enter the object related symbols */
XX new = xlsenter("new");
XX isnew = xlsenter("isnew");
XX self = xlsenter("self");
XX msgclass = xlsenter("msgclass");
XX
XX /* create the 'Class' object */
XX class = xlclass("Class",CLASSSIZE);
XX class->n_obclass = class;
XX
XX /* create the 'Object' object */
XX object = xlclass("Object",0);
XX
XX /* finish initializing 'class' */
XX xlsetivar(class,SUPERCLASS,object);
XX xladdivar(class,"ivartotal"); /* ivar number 6 */
XX xladdivar(class,"ivarcnt"); /* ivar number 5 */
XX xladdivar(class,"superclass"); /* ivar number 4 */
XX xladdivar(class,"cvals"); /* ivar number 3 */
XX xladdivar(class,"cvars"); /* ivar number 2 */
XX xladdivar(class,"ivars"); /* ivar number 1 */
XX xladdivar(class,"messages"); /* ivar number 0 */
XX xladdmsg(class,"new",mnew);
XX xladdmsg(class,"answer",answer);
XX xladdmsg(class,"ivars",mivars);
XX xladdmsg(class,"cvars",mcvars);
XX xladdmsg(class,"isnew",misnew);
XX
XX /* finish initializing 'object' */
XX xladdmsg(object,"class",getclass);
XX xladdmsg(object,"show",obshow);
XX xladdmsg(object,"isnew",defisnew);
XX xladdmsg(object,"sendsuper",sendsuper);
XX}
SHAR_EOF
if test 16101 -ne "`wc -c xlobj.c`"
then
echo shar: error transmitting xlobj.c '(should have been 16101 characters)'
fi
# End of shell archive
exit 0