Relay-Version: version B 2.10.2 2/19/85; site seismo.UUCP
Posting-Version: version B 2.10 beta 3/9/83; site encore.UUCP
Path: seismo!harvard!talcott!encore!wegrzyn
From: wegrzyn@encore.UUCP (Chuck Wegrzyn)
Newsgroups: net.sources
Subject: xlisp v1.4 (3 of 5)
Message-ID: <188@encore.UUCP>
Date: 13 Mar 85 13:52:22 GMT
Organization: Encore Computer Corp., Wellesley Hills, MA
Lines: 2405

#	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