xlisp v1.4 (3 of 5)
Chuck Wegrzyn
wegrzyn at encore.UUCP
Wed Mar 13 23:52:22 AEST 1985
# 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 0
More information about the Comp.sources.unix
mailing list