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 (4 of 5)
Message-ID: <189@encore.UUCP>
Date: 13 Mar 85 13:55:15 GMT
Organization: Encore Computer Corp., Wellesley Hills, MA
Lines: 2268

#	This is a shell archive.
#	Remove everything above and including the cut line.
#	Then run the rest of the file through sh.
-----cut here-----cut here-----cut here-----cut here-----
#!/bin/sh
# shar:	Shell Archiver
#	Run the following text with /bin/sh to create:
#	xleval.c
#	xlfio.c
#	xlftab.c
#	xlglob.c
#	xlinit.c
#	xlmath.c
#	xlprin.c
#	xlstub.c.NOTUSED
#	xlsubr.c
#	xlsym.c
#	xlsys.c
# This archive created: Wed Mar 13 08:37:11 1985
echo shar: extracting xleval.c '(7688 characters)'
sed 's/^XX//' << \SHAR_EOF > xleval.c
XX/* xleval - xlisp evaluator */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern NODE *xlstack,*xlenv,*xlnewenv;
XXextern NODE *s_lambda,*s_macro;
XXextern NODE *k_optional,*k_rest,*k_aux;
XXextern NODE *s_evalhook,*s_applyhook;
XXextern NODE *s_unbound;
XXextern NODE *s_stdout;
XX
XX/* forward declarations */
XXFORWARD NODE *xlxeval();
XXFORWARD NODE *evalhook();
XXFORWARD NODE *evform();
XXFORWARD NODE *evsym();
XXFORWARD NODE *evfun();
XX
XX/* xleval - evaluate an xlisp expression (checking for *evalhook*) */
XXNODE *xleval(expr)
XX  NODE *expr;
XX{
XX    return (s_evalhook->n_symvalue ? evalhook(expr) : xlxeval(expr));
XX}
XX
XX/* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
XXNODE *xlxeval(expr)
XX  NODE *expr;
XX{
XX    /* evaluate nil to itself */
XX    if (expr == NIL)
XX	return (NIL);
XX
XX    /* add trace entry */
XX    xltpush(expr);
XX
XX    /* check type of value */
XX    if (consp(expr))
XX	expr = evform(expr);
XX    else if (symbolp(expr))
XX	expr = evsym(expr);
XX
XX    /* remove trace entry */
XX    xltpop();
XX
XX    /* return the value */
XX    return (expr);
XX}
XX
XX/* xlapply - apply a function to a list of arguments */
XXNODE *xlapply(fun,args)
XX  NODE *fun,*args;
XX{
XX    NODE *val;
XX
XX    /* check for a null function */
XX    if (fun == NIL)
XX	xlfail("bad function");
XX
XX    /* evaluate the function */
XX    if (subrp(fun))
XX	val = (*fun->n_subr)(args);
XX    else if (consp(fun)) {
XX	if (car(fun) != s_lambda)
XX	    xlfail("bad function type");
XX	val = evfun(fun,args);
XX    }
XX    else
XX	xlfail("bad function");
XX
XX    /* return the result value */
XX    return (val);
XX}
XX
XX/* evform - evaluate a form */
XXLOCAL NODE *evform(expr)
XX  NODE *expr;
XX{
XX    NODE *oldstk,fun,args,*val,*type;
XX
XX    /* create a stack frame */
XX    oldstk = xlsave(&fun,&args,NULL);
XX
XX    /* get the function and the argument list */
XX    fun.n_ptr = car(expr);
XX    args.n_ptr = cdr(expr);
XX
XX    /* evaluate the first expression */
XX    if ((fun.n_ptr = xleval(fun.n_ptr)) == NIL)
XX	xlfail("bad function");
XX
XX    /* evaluate the function */
XX    if (subrp(fun.n_ptr) || fsubrp(fun.n_ptr)) {
XX	if (subrp(fun.n_ptr))
XX	    args.n_ptr = xlevlist(args.n_ptr);
XX	val = (*fun.n_ptr->n_subr)(args.n_ptr);
XX    }
XX    else if (consp(fun.n_ptr)) {
XX	if ((type = car(fun.n_ptr)) == s_lambda) {
XX	    args.n_ptr = xlevlist(args.n_ptr);
XX	    val = evfun(fun.n_ptr,args.n_ptr);
XX	}
XX	else if (type == s_macro) {
XX	    args.n_ptr = evfun(fun.n_ptr,args.n_ptr);
XX	    val = xleval(args.n_ptr);
XX	}
XX	else
XX	    xlfail("bad function type");
XX    }
XX    else if (objectp(fun.n_ptr))
XX	val = xlsend(fun.n_ptr,args.n_ptr);
XX    else
XX	xlfail("bad function");
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the result value */
XX    return (val);
XX}
XX
XX/* evalhook - call the evalhook function */
XXLOCAL NODE *evalhook(expr)
XX  NODE *expr;
XX{
XX    NODE *oldstk,*oldenv,fun,args,*val;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&fun,&args,NULL);
XX
XX    /* get the hook function */
XX    fun.n_ptr = s_evalhook->n_symvalue;
XX
XX    /* make an argument list */
XX    args.n_ptr = newnode(LIST);
XX    rplaca(args.n_ptr,expr);
XX
XX    /* rebind the hook functions to nil */
XX    oldenv = xlenv;
XX    xlsbind(s_evalhook,NIL);
XX    xlsbind(s_applyhook,NIL);
XX
XX    /* call the hook function */
XX    val = xlapply(fun.n_ptr,args.n_ptr);
XX
XX    /* unbind the symbols */
XX    xlunbind(oldenv);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the value */
XX    return (val);
XX}
XX
XX/* xlevlist - evaluate a list of arguments */
XXNODE *xlevlist(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,src,dst,*new,*last,*val;
XX
XX    /* create a stack frame */
XX    oldstk = xlsave(&src,&dst,NULL);
XX
XX    /* initialize */
XX    src.n_ptr = args;
XX
XX    /* evaluate each argument */
XX    for (val = NIL; src.n_ptr; src.n_ptr = cdr(src.n_ptr)) {
XX
XX	/* check this entry */
XX	if (!consp(src.n_ptr))
XX	    xlfail("bad argument list");
XX
XX	/* allocate a new list entry */
XX	new = newnode(LIST);
XX	if (val)
XX	    rplacd(last,new);
XX	else
XX	    val = dst.n_ptr = new;
XX	rplaca(new,xleval(car(src.n_ptr)));
XX	last = new;
XX    }
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the new list */
XX    return (val);
XX}
XX
XX/* evsym - evaluate a symbol */
XXLOCAL NODE *evsym(sym)
XX  NODE *sym;
XX{
XX    NODE *p;
XX
XX    /* check for a reference to an instance variable */
XX    if ((p = xlobsym(sym)) != NIL)
XX	return (car(p));
XX
XX    /* get the value of the variable */
XX    while ((p = sym->n_symvalue) == s_unbound)
XX	xlunbound(sym);
XX
XX    /* return the value */
XX    return (p);
XX}
XX
XX/* xlunbound - signal an unbound variable error */
XXxlunbound(sym)
XX  NODE *sym;
XX{
XX    xlcerror("try evaluating symbol again","unbound variable",sym);
XX}
XX
XX/* evfun - evaluate a function */
XXLOCAL NODE *evfun(fun,args)
XX  NODE *fun,*args;
XX{
XX    NODE *oldstk,*oldenv,*oldnewenv,cptr,*fargs,*val;
XX
XX    /* create a stack frame */
XX    oldstk = xlsave(&cptr,NULL);
XX
XX    /* skip the function type */
XX    if ((fun = cdr(fun)) == NIL || !consp(fun))
XX	xlfail("bad function definition");
XX
XX    /* get the formal argument list */
XX    if ((fargs = car(fun)) && !consp(fargs))
XX	xlfail("bad formal argument list");
XX
XX    /* bind the formal parameters */
XX    oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
XX    xlabind(fargs,args);
XX    xlfixbindings();
XX
XX    /* execute the code */
XX    for (cptr.n_ptr = cdr(fun); cptr.n_ptr != NIL; )
XX	val = xlevarg(&cptr.n_ptr);
XX
XX    /* restore the environment */
XX    xlunbind(oldenv); xlnewenv = oldnewenv;
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the result value */
XX    return (val);
XX}
XX
XX/* xlabind - bind the arguments for a function */
XXxlabind(fargs,aargs)
XX  NODE *fargs,*aargs;
XX{
XX    NODE *arg;
XX
XX    /* evaluate and bind each required argument */
XX    while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
XX
XX	/* bind the formal variable to the argument value */
XX	xlbind(arg,car(aargs));
XX
XX	/* move the argument list pointers ahead */
XX	fargs = cdr(fargs);
XX	aargs = cdr(aargs);
XX    }
XX
XX    /* check for the '&optional' keyword */
XX    if (consp(fargs) && car(fargs) == k_optional) {
XX	fargs = cdr(fargs);
XX
XX	/* bind the arguments that were supplied */
XX	while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
XX
XX	    /* bind the formal variable to the argument value */
XX	    xlbind(arg,car(aargs));
XX
XX	    /* move the argument list pointers ahead */
XX	    fargs = cdr(fargs);
XX	    aargs = cdr(aargs);
XX	}
XX
XX	/* bind the rest to nil */
XX	while (consp(fargs) && !iskeyword(arg = car(fargs))) {
XX
XX	    /* bind the formal variable to nil */
XX	    xlbind(arg,NIL);
XX
XX	    /* move the argument list pointer ahead */
XX	    fargs = cdr(fargs);
XX	}
XX    }
XX
XX    /* check for the '&rest' keyword */
XX    if (consp(fargs) && car(fargs) == k_rest) {
XX	fargs = cdr(fargs);
XX	if (consp(fargs) && (arg = car(fargs)) && !iskeyword(arg))
XX	    xlbind(arg,aargs);
XX	else
XX	    xlfail("symbol missing after &rest");
XX	fargs = cdr(fargs);
XX	aargs = NIL;
XX    }
XX
XX    /* check for the '&aux' keyword */
XX    if (consp(fargs) && car(fargs) == k_aux)
XX	while ((fargs = cdr(fargs)) != NIL && consp(fargs))
XX	    xlbind(car(fargs),NIL);
XX
XX    /* make sure the correct number of arguments were supplied */
XX    if (fargs != aargs)
XX	xlfail(fargs ? "too few arguments" : "too many arguments");
XX}
XX
XX/* iskeyword - check to see if a symbol is a keyword */
XXLOCAL int iskeyword(sym)
XX  NODE *sym;
XX{
XX    return (sym == k_optional || sym == k_rest || sym == k_aux);
XX}
XX
XX/* xlsave - save nodes on the stack */
XXNODE *xlsave(n)
XX  NODE *n;
XX{
XX    NODE **nptr,*oldstk;
XX
XX    /* save the old stack pointer */
XX    oldstk = xlstack;
XX
XX    /* save each node */
XX    for (nptr = &n; *nptr != NULL; nptr++) {
XX	rplaca(*nptr,NIL);
XX	rplacd(*nptr,xlstack);
XX	xlstack = *nptr;
XX    }
XX
XX    /* return the old stack pointer */
XX    return (oldstk);
XX}
SHAR_EOF
if test 7688 -ne "`wc -c xleval.c`"
then
echo shar: error transmitting xleval.c '(should have been 7688 characters)'
fi
echo shar: extracting xlfio.c '(8960 characters)'
sed 's/^XX//' << \SHAR_EOF > xlfio.c
XX/* xlfio.c - xlisp file i/o */
XX
XX#include "xlisp.h"
XX#include "ctype.h"
XX
XX/* external variables */
XXextern NODE *s_stdin,*s_stdout;
XXextern NODE *xlstack;
XXextern int xlfsize;
XXextern char buf[];
XX
XX/* external routines */
XXextern FILE *fopen();
XX
XX/* forward declarations */
XXFORWARD NODE *printit();
XXFORWARD NODE *flatsize();
XXFORWARD NODE *explode();
XXFORWARD NODE *implode();
XXFORWARD NODE *openit();
XXFORWARD NODE *getfile();
XX
XX/* xread - read an expression */
XXNODE *xread(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,fptr,eof,*val;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&fptr,&eof,NULL);
XX
XX    /* get file pointer and eof value */
XX    fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
XX    eof.n_ptr = (args ? xlarg(&args) : NIL);
XX    xllastarg(args);
XX
XX    /* read an expression */
XX    if (!xlread(fptr.n_ptr,&val))
XX	val = eof.n_ptr;
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the expression */
XX    return (val);
XX}
XX
XX/* xprint - builtin function 'print' */
XXNODE *xprint(args)
XX  NODE *args;
XX{
XX    return (printit(args,TRUE,TRUE));
XX}
XX
XX/* xprin1 - builtin function 'prin1' */
XXNODE *xprin1(args)
XX  NODE *args;
XX{
XX    return (printit(args,TRUE,FALSE));
XX}
XX
XX/* xprinc - builtin function princ */
XXNODE *xprinc(args)
XX  NODE *args;
XX{
XX    return (printit(args,FALSE,FALSE));
XX}
XX
XX/* xterpri - terminate the current print line */
XXNODE *xterpri(args)
XX  NODE *args;
XX{
XX    NODE *fptr;
XX
XX    /* get file pointer */
XX    fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
XX    xllastarg(args);
XX
XX    /* terminate the print line and return nil */
XX    xlterpri(fptr);
XX    return (NIL);
XX}
XX
XX/* printit - common print function */
XXLOCAL NODE *printit(args,pflag,tflag)
XX  NODE *args; int pflag,tflag;
XX{
XX    NODE *oldstk,fptr,val;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&fptr,&val,NULL);
XX
XX    /* get expression to print and file pointer */
XX    val.n_ptr = xlarg(&args);
XX    fptr.n_ptr = (args ? getfile(&args) : s_stdout->n_symvalue);
XX    xllastarg(args);
XX
XX    /* print the value */
XX    xlprint(fptr.n_ptr,val.n_ptr,pflag);
XX
XX    /* terminate the print line if necessary */
XX    if (tflag)
XX	xlterpri(fptr.n_ptr);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the result */
XX    return (val.n_ptr);
XX}
XX
XX/* xflatsize - compute the size of a printed representation using prin1 */
XXNODE *xflatsize(args)
XX  NODE *args;
XX{
XX    return (flatsize(args,TRUE));
XX}
XX
XX/* xflatc - compute the size of a printed representation using princ */
XXNODE *xflatc(args)
XX  NODE *args;
XX{
XX    return (flatsize(args,FALSE));
XX}
XX
XX/* flatsize - compute the size of a printed expression */
XXLOCAL NODE *flatsize(args,pflag)
XX  NODE *args; int pflag;
XX{
XX    NODE *oldstk,val;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&val,NULL);
XX
XX    /* get the expression */
XX    val.n_ptr = xlarg(&args);
XX    xllastarg(args);
XX
XX    /* print the value to compute its size */
XX    xlfsize = 0;
XX    xlprint(NIL,val.n_ptr,pflag);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the length of the expression */
XX    val.n_ptr = newnode(INT);
XX    val.n_ptr->n_int = xlfsize;
XX    return (val.n_ptr);
XX}
XX
XX/* xexplode - explode an expression */
XXNODE *xexplode(args)
XX  NODE *args;
XX{
XX    return (explode(args,TRUE));
XX}
XX
XX/* xexplc - explode an expression using princ */
XXNODE *xexplc(args)
XX  NODE *args;
XX{
XX    return (explode(args,FALSE));
XX}
XX
XX/* explode - internal explode routine */
XXLOCAL NODE *explode(args,pflag)
XX  NODE *args; int pflag;
XX{
XX    NODE *oldstk,val,strm;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&val,&strm,NULL);
XX
XX    /* get the expression */
XX    val.n_ptr = xlarg(&args);
XX    xllastarg(args);
XX
XX    /* create a stream */
XX    strm.n_ptr = newnode(LIST);
XX
XX    /* print the value into the stream */
XX    xlprint(strm.n_ptr,val.n_ptr,pflag);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the list of characters */
XX    return (car(strm.n_ptr));
XX}
XX
XX/* ximplode - implode a list of characters into a symbol */
XXNODE *ximplode(args)
XX  NODE *args;
XX{
XX    return (implode(args,TRUE));
XX}
XX
XX/* xmaknam - implode a list of characters into an uninterned symbol */
XXNODE *xmaknam(args)
XX  NODE *args;
XX{
XX    return (implode(args,FALSE));
XX}
XX
XX/* implode - internal implode routine */
XXLOCAL NODE *implode(args,intflag)
XX  NODE *args; int intflag;
XX{
XX    NODE *list,*val;
XX    char *p;
XX
XX    /* get the list */
XX    list = xlarg(&args);
XX    xllastarg(args);
XX
XX    /* assemble the symbol's pname */
XX    for (p = buf; consp(list); list = cdr(list)) {
XX	if ((val = car(list)) == NIL || !fixp(val))
XX	    xlfail("bad character list");
XX	if ((int)(p - buf) < STRMAX)
XX	    *p++ = val->n_int;
XX    }
XX    *p = 0;
XX
XX    /* create a symbol */
XX    val = (intflag ? xlenter(buf,DYNAMIC) : xlmakesym(buf,DYNAMIC));
XX
XX    /* return the symbol */
XX    return (val);
XX}
XX
XX/* xopeni - open an input file */
XXNODE *xopeni(args)
XX  NODE *args;
XX{
XX    return (openit(args,"r"));
XX}
XX
XX/* xopeno - open an output file */
XXNODE *xopeno(args)
XX  NODE *args;
XX{
XX    return (openit(args,"w"));
XX}
XX
XX/* openit - common file open routine */
XXLOCAL NODE *openit(args,mode)
XX  NODE *args; char *mode;
XX{
XX    NODE *fname,*val;
XX    FILE *fp;
XX
XX    /* get the file name */
XX    fname = xlmatch(STR,&args);
XX    xllastarg(args);
XX
XX    /* try to open the file */
XX    if ((fp = fopen(fname->n_str,mode)) != NULL) {
XX	val = newnode(FPTR);
XX	val->n_fp = fp;
XX	val->n_savech = 0;
XX    }
XX    else
XX	val = NIL;
XX
XX    /* return the file pointer */
XX    return (val);
XX}
XX
XX/* xclose - close a file */
XXNODE *xclose(args)
XX  NODE *args;
XX{
XX    NODE *fptr;
XX
XX    /* get file pointer */
XX    fptr = xlmatch(FPTR,&args);
XX    xllastarg(args);
XX
XX    /* make sure the file exists */
XX    if (fptr->n_fp == NULL)
XX	xlfail("file not open");
XX
XX    /* close the file */
XX    fclose(fptr->n_fp);
XX    fptr->n_fp = NULL;
XX
XX    /* return nil */
XX    return (NIL);
XX}
XX
XX/* xrdchar - read a character from a file */
XXNODE *xrdchar(args)
XX  NODE *args;
XX{
XX    NODE *fptr,*val;
XX    int ch;
XX
XX    /* get file pointer */
XX    fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
XX    xllastarg(args);
XX
XX    /* get character and check for eof */
XX    if ((ch = xlgetc(fptr)) == EOF)
XX	val = NIL;
XX    else {
XX	val = newnode(INT);
XX	val->n_int = ch;
XX    }
XX
XX    /* return the character */
XX    return (val);
XX}
XX
XX/* xpkchar - peek at a character from a file */
XXNODE *xpkchar(args)
XX  NODE *args;
XX{
XX    NODE *flag,*fptr,*val;
XX    int ch;
XX
XX    /* peek flag and get file pointer */
XX    flag = (args ? xlarg(&args) : NIL);
XX    fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
XX    xllastarg(args);
XX
XX    /* skip leading white space and get a character */
XX    if (flag)
XX	while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
XX	    xlgetc(fptr);
XX    else
XX	ch = xlpeek(fptr);
XX
XX    /* check for eof */
XX    if (ch == EOF)
XX	val = NIL;
XX    else {
XX	val = newnode(INT);
XX	val->n_int = ch;
XX    }
XX
XX    /* return the character */
XX    return (val);
XX}
XX
XX/* xwrchar - write a character to a file */
XXNODE *xwrchar(args)
XX  NODE *args;
XX{
XX    NODE *fptr,*chr;
XX
XX    /* get the character and file pointer */
XX    chr = xlmatch(INT,&args);
XX    fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
XX    xllastarg(args);
XX
XX    /* put character to the file */
XX    xlputc(fptr,chr->n_int);
XX
XX    /* return the character */
XX    return (chr);
XX}
XX
XX/* xreadline - read a line from a file */
XXNODE *xreadline(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,fptr,str;
XX    char *p,*sptr;
XX    int len,ch;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&fptr,&str,NULL);
XX
XX    /* get file pointer */
XX    fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
XX    xllastarg(args);
XX
XX    /* make a string node */
XX    str.n_ptr = newnode(STR);
XX    str.n_ptr->n_strtype = DYNAMIC;
XX
XX    /* get character and check for eof */
XX    len = 0; p = buf;
XX    while ((ch = xlgetc(fptr.n_ptr)) != EOF && ch != '\n') {
XX
XX	/* check for buffer overflow */
XX	if ((int)(p - buf) == STRMAX) {
XX	    *p = 0;
XX 	    sptr = stralloc(len + STRMAX); *sptr = 0;
XX	    if (len) {
XX		strcpy(sptr,str.n_ptr->n_str);
XX		strfree(str.n_ptr->n_str);
XX	    }
XX	    str.n_ptr->n_str = sptr;
XX	    strcat(sptr,buf);
XX	    len += STRMAX;
XX	    p = buf;
XX	}
XX
XX	/* store the character */
XX	*p++ = ch;
XX    }
XX
XX    /* check for end of file */
XX    if (len == 0 && p == buf && ch == EOF) {
XX	xlstack = oldstk;
XX	return (NIL);
XX    }
XX
XX    /* append the last substring */
XX    *p = 0;
XX    sptr = stralloc(len + (int)(p - buf)); *sptr = 0;
XX    if (len) {
XX	strcpy(sptr,str.n_ptr->n_str);
XX	strfree(str.n_ptr->n_str);
XX    }
XX    str.n_ptr->n_str = sptr;
XX    strcat(sptr,buf);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the string */
XX    return (str.n_ptr);
XX}
XX
XX/* getfile - get a file or stream */
XXLOCAL NODE *getfile(pargs)
XX  NODE **pargs;
XX{
XX    NODE *arg;
XX
XX    /* get a file or stream (cons) or nil */
XX    if (arg = xlarg(pargs)) {
XX	if (filep(arg)) {
XX	    if (arg->n_fp == NULL)
XX		xlfail("file not open");
XX	}
XX	else if (!consp(arg))
XX	    xlfail("bad argument type");
XX    }
XX    return (arg);
XX}
SHAR_EOF
if test 8960 -ne "`wc -c xlfio.c`"
then
echo shar: error transmitting xlfio.c '(should have been 8960 characters)'
fi
echo shar: extracting xlftab.c '(5998 characters)'
sed 's/^XX//' << \SHAR_EOF > xlftab.c
XX/* xlftab.c - xlisp function table */
XX
XX#include "xlisp.h"
XX
XX/* external functions */
XXextern NODE
XX    *xeval(),*xapply(),*xfuncall(),*xquote(),*xbquote(),
XX    *xset(),*xsetq(),*xsetf(),*xdefun(),*xdefmacro(),
XX    *xgensym(),*xmakesymbol(),*xintern(),
XX    *xsymname(),*xsymvalue(),*xsymplist(),*xget(),*xremprop(),
XX    *xcar(),*xcaar(),*xcadr(),*xcdr(),*xcdar(),*xcddr(),
XX    *xcons(),*xlist(),*xappend(),*xreverse(),*xlast(),*xnth(),*xnthcdr(),
XX    *xmember(),*xassoc(),*xsubst(),*xsublis(),*xremove(),*xlength(),
XX    *xmapc(),*xmapcar(),*xmapl(),*xmaplist(),
XX    *xrplca(),*xrplcd(),*xnconc(),*xdelete(),
XX    *xatom(),*xsymbolp(),*xnumberp(),*xboundp(),*xnull(),*xlistp(),*xconsp(),
XX    *xeq(),*xeql(),*xequal(),
XX    *xcond(),*xand(),*xor(),*xlet(),*xletstar(),*xif(),
XX    *xprog(),*xprogstar(),*xprog1(),*xprog2(),*xprogn(),*xgo(),*xreturn(),
XX    *xcatch(),*xthrow(),
XX    *xerror(),*xcerror(),*xbreak(),*xerrset(),*xbaktrace(),*xevalhook(),
XX    *xdo(),*xdostar(),*xdolist(),*xdotimes(),
XX    *xadd(),*xsub(),*xmul(),*xdiv(),*xrem(),*xmin(),*xmax(),*xabs(),
XX    *xadd1(),*xsub1(),*xbitand(),*xbitior(),*xbitxor(),*xbitnot(),
XX    *xminusp(),*xzerop(),*xplusp(),*xevenp(),*xoddp(),
XX    *xlss(),*xleq(),*xequ(),*xneq(),*xgeq(),*xgtr(),
XX    *xstrlen(),*xstrcat(),*xsubstr(),*xascii(),*xchr(),*xatoi(),*xitoa(),
XX    *xread(),*xprint(),*xprin1(),*xprinc(),*xterpri(),
XX    *xflatsize(),*xflatc(),*xexplode(),*xexplc(),*ximplode(),*xmaknam(),
XX    *xopeni(),*xopeno(),*xclose(),*xrdchar(),*xpkchar(),*xwrchar(),*xreadline(),
XX    *xload(),*xgc(),*xexpand(),*xalloc(),*xmem(),*xtype(),*xexit();
XX
XX/* the function table */
XXstruct fdef ftab[] = {
XX
XX	/* evaluator functions */
XX{	"eval",		SUBR,	xeval		},
XX{	"apply",	SUBR,	xapply		},
XX{	"funcall",	SUBR,	xfuncall	},
XX{	"quote",	FSUBR,	xquote		},
XX{	"function",	FSUBR,	xquote		},
XX{	"backquote",	FSUBR,	xbquote		},
XX
XX	/* symbol functions */
XX{	"set",		SUBR,	xset		},
XX{	"setq",		FSUBR,	xsetq		},
XX{	"setf",		FSUBR,	xsetf		},
XX{	"defun",	FSUBR,	xdefun		},
XX{	"defmacro",	FSUBR,	xdefmacro	},
XX{	"gensym",	SUBR,	xgensym		},
XX{	"make-symbol",	SUBR,	xmakesymbol	},
XX{	"intern",	SUBR,	xintern		},
XX{	"symbol-name",	SUBR,	xsymname	},
XX{	"symbol-value",	SUBR,	xsymvalue	},
XX{	"symbol-plist",	SUBR,	xsymplist	},
XX{	"get",		SUBR,	xget		},
XX{	"remprop",	SUBR,	xremprop	},
XX
XX	/* list functions */
XX{	"car",		SUBR,	xcar		},
XX{	"caar",		SUBR,	xcaar		},
XX{	"cadr",		SUBR,	xcadr		},
XX{	"cdr",		SUBR,	xcdr		},
XX{	"cdar",		SUBR,	xcdar		},
XX{	"cddr",		SUBR,	xcddr		},
XX{	"cons",		SUBR,	xcons		},
XX{	"list",		SUBR,	xlist		},
XX{	"append",	SUBR,	xappend		},
XX{	"reverse",	SUBR,	xreverse	},
XX{	"last",		SUBR,	xlast		},
XX{	"nth",		SUBR,	xnth		},
XX{	"nthcdr",	SUBR,	xnthcdr		},
XX{	"member",	SUBR,	xmember		},
XX{	"assoc",	SUBR,	xassoc		},
XX{	"subst",	SUBR,	xsubst		},
XX{	"sublis",	SUBR,	xsublis		},
XX{	"remove",	SUBR,	xremove		},
XX{	"length",	SUBR,	xlength		},
XX{	"mapc",		SUBR,	xmapc		},
XX{	"mapcar",	SUBR,	xmapcar		},
XX{	"mapl",		SUBR,	xmapl		},
XX{	"maplist",	SUBR,	xmaplist	},
XX
XX	/* destructive list functions */
XX{	"rplaca",	SUBR,	xrplca		},
XX{	"rplacd",	SUBR,	xrplcd		},
XX{	"nconc",	SUBR,	xnconc		},
XX{	"delete",	SUBR,	xdelete		},
XX
XX	/* predicate functions */
XX{	"atom",		SUBR,	xatom		},
XX{	"symbolp",	SUBR,	xsymbolp	},
XX{	"numberp",	SUBR,	xnumberp	},
XX{	"boundp",	SUBR,	xboundp		},
XX{	"null",		SUBR,	xnull		},
XX{	"not",		SUBR,	xnull		},
XX{	"listp",	SUBR,	xlistp		},
XX{	"consp",	SUBR,	xconsp		},
XX{	"minusp",	SUBR,	xminusp		},
XX{	"zerop",	SUBR,	xzerop		},
XX{	"plusp",	SUBR,	xplusp		},
XX{	"evenp",	SUBR,	xevenp		},
XX{	"oddp",		SUBR,	xoddp		},
XX{	"eq",		SUBR,	xeq		},
XX{	"eql",		SUBR,	xeql		},
XX{	"equal",	SUBR,	xequal		},
XX
XX	/* control functions */
XX{	"cond",		FSUBR,	xcond		},
XX{	"and",		FSUBR,	xand		},
XX{	"or",		FSUBR,	xor		},
XX{	"let",		FSUBR,	xlet		},
XX{	"let*",		FSUBR,	xletstar	},
XX{	"if",		FSUBR,	xif		},
XX{	"prog",		FSUBR,	xprog		},
XX{	"prog*",	FSUBR,	xprogstar	},
XX{	"prog1",	FSUBR,	xprog1		},
XX{	"prog2",	FSUBR,	xprog2		},
XX{	"progn",	FSUBR,	xprogn		},
XX{	"go",		FSUBR,	xgo		},
XX{	"return",	SUBR,	xreturn		},
XX{	"do",		FSUBR,	xdo		},
XX{	"do*",		FSUBR,	xdostar		},
XX{	"dolist",	FSUBR,	xdolist		},
XX{	"dotimes",	FSUBR,	xdotimes	},
XX{	"catch",	FSUBR,	xcatch		},
XX{	"throw",	SUBR,	xthrow		},
XX
XX	/* debugging and error handling functions */
XX{	"error",	SUBR,	xerror		},
XX{	"cerror",	SUBR,	xcerror		},
XX{	"break",	SUBR,	xbreak		},
XX{	"errset",	FSUBR,	xerrset		},
XX{	"baktrace",	SUBR,	xbaktrace	},
XX{	"evalhook",	SUBR,	xevalhook	},
XX
XX	/* arithmetic functions */
XX{	"+",		SUBR,	xadd		},
XX{	"-",		SUBR,	xsub		},
XX{	"*",		SUBR,	xmul		},
XX{	"/",		SUBR,	xdiv		},
XX{	"1+",		SUBR,	xadd1		},
XX{	"1-",		SUBR,	xsub1		},
XX{	"rem",		SUBR,	xrem		},
XX{	"min",		SUBR,	xmin		},
XX{	"max",		SUBR,	xmax		},
XX{	"abs",		SUBR,	xabs		},
XX
XX	/* bitwise logical functions */
XX{	"bit-and",	SUBR,	xbitand		},
XX{	"bit-ior",	SUBR,	xbitior		},
XX{	"bit-xor",	SUBR,	xbitxor		},
XX{	"bit-not",	SUBR,	xbitnot		},
XX
XX	/* numeric comparison functions */
XX{	"<",		SUBR,	xlss		},
XX{	"<=",		SUBR,	xleq		},
XX{	"=",		SUBR,	xequ		},
XX{	"/=",		SUBR,	xneq		},
XX{	">=",		SUBR,	xgeq		},
XX{	">",		SUBR,	xgtr		},
XX
XX	/* string functions */
XX{	"strlen",	SUBR,	xstrlen		},
XX{	"strcat",	SUBR,	xstrcat		},
XX{	"substr",	SUBR,	xsubstr		},
XX{	"ascii",	SUBR,	xascii		},
XX{	"chr",		SUBR,	xchr		},
XX{	"atoi",		SUBR,	xatoi		},
XX{	"itoa",		SUBR,	xitoa		},
XX
XX	/* I/O functions */
XX{	"read",		SUBR,	xread		},
XX{	"print",	SUBR,	xprint		},
XX{	"prin1",	SUBR,	xprin1		},
XX{	"princ",	SUBR,	xprinc		},
XX{	"terpri",	SUBR,	xterpri		},
XX{	"flatsize",	SUBR,	xflatsize	},
XX{	"flatc",	SUBR,	xflatc		},
XX{	"explode",	SUBR,	xexplode	},
XX{	"explodec",	SUBR,	xexplc		},
XX{	"implode",	SUBR,	ximplode	},
XX{	"maknam",	SUBR,	xmaknam		},
XX
XX	/* file I/O functions */
XX{	"openi",	SUBR,	xopeni		},
XX{	"openo",	SUBR,	xopeno		},
XX{	"close",	SUBR,	xclose		},
XX{	"read-char",	SUBR,	xrdchar		},
XX{	"peek-char",	SUBR,	xpkchar		},
XX{	"write-char",	SUBR,	xwrchar		},
XX{	"readline",	SUBR,	xreadline	},
XX
XX	/* system functions */
XX{	"load",		SUBR,	xload		},
XX{	"gc",		SUBR,	xgc		},
XX{	"expand",	SUBR,	xexpand		},
XX{	"alloc",	SUBR,	xalloc		},
XX{	"mem",		SUBR,	xmem		},
XX{	"type",		SUBR,	xtype		},
XX{	"exit",		SUBR,	xexit		},
XX
XX{	0					}
XX};
SHAR_EOF
if test 5998 -ne "`wc -c xlftab.c`"
then
echo shar: error transmitting xlftab.c '(should have been 5998 characters)'
fi
echo shar: extracting xlglob.c '(2114 characters)'
sed 's/^XX//' << \SHAR_EOF > xlglob.c
XX/* xlglobals - xlisp global variables */
XX
XX#include "xlisp.h"
XX
XX/* symbols */
XXNODE *true = NIL;
XXNODE *s_quote = NIL, *s_function = NIL;
XXNODE *s_bquote = NIL, *s_comma = NIL, *s_comat = NIL;
XXNODE *s_evalhook = NIL, *s_applyhook = NIL;
XXNODE *s_lambda = NIL, *s_macro = NIL;
XXNODE *s_stdin = NIL, *s_stdout = NIL;
XXNODE *s_tracenable = NIL, *s_tlimit = NIL, *s_breakenable = NIL;
XXNODE *s_continue = NIL, *s_quit = NIL;
XXNODE *s_car = NIL, *s_cdr = NIL;
XXNODE *s_get = NIL, *s_svalue = NIL, *s_splist = NIL;
XXNODE *s_eql = NIL, *k_test = NIL, *k_tnot = NIL;
XXNODE *k_optional = NIL, *k_rest = NIL, *k_aux = NIL;
XXNODE *a_subr = NIL, *a_fsubr = NIL;
XXNODE *a_list = NIL, *a_sym = NIL, *a_int = NIL;
XXNODE *a_str = NIL, *a_obj = NIL, *a_fptr = NIL;
XXNODE *oblist = NIL, *keylist = NIL, *s_unbound = NIL;
XX
XX/* evaluation variables */
XXNODE *xlstack = NIL;
XXNODE *xlenv = NIL;
XXNODE *xlnewenv = NIL;
XX
XX/* exception handling variables */
XXCONTEXT *xlcontext = NULL;	/* current exception handler */
XXNODE *xlvalue = NIL;		/* exception value */
XX
XX/* debugging variables */
XXint xldebug = 0;		/* debug level */
XXint xltrace = -1;		/* trace stack pointer */
XXNODE **trace_stack = NULL;	/* trace stack */
XX
XX/* gensym variables */
XXchar gsprefix[STRMAX+1] = { 'G',0 };	/* gensym prefix string */
XXint gsnumber = 1;		/* gensym number */
XX
XX/* i/o variables */
XXint xlplevel = 0;		/* prompt nesting level */
XXint xlfsize = 0;		/* flat size of current print call */
XXint prompt = TRUE;		/* input prompt flag */
XX
XX/* dynamic memory variables */
XXlong total = 0L;		/* total memory in use */
XXint anodes = 0;			/* number of nodes to allocate */
XXint nnodes = 0;			/* number of nodes allocated */
XXint nsegs = 0;			/* number of segments allocated */
XXint nfree = 0;			/* number of nodes free */
XXint gccalls = 0;		/* number of gc calls */
XXstruct segment *segs = NULL;	/* list of allocated segments */
XXNODE *fnodes = NIL;		/* list of free nodes */
XX
XX/* object programming variables */
XXNODE *self = NIL, *class = NIL, *object = NIL;
XXNODE *new = NIL, *isnew = NIL, *msgcls = NIL, *msgclass = NIL;
XXint varcnt = 0;
XX
XX/* general purpose string buffer */
XXchar buf[STRMAX+1] = { 0 };
SHAR_EOF
if test 2114 -ne "`wc -c xlglob.c`"
then
echo shar: error transmitting xlglob.c '(should have been 2114 characters)'
fi
echo shar: extracting xlinit.c '(3268 characters)'
sed 's/^XX//' << \SHAR_EOF > xlinit.c
XX/* xlinit.c - xlisp initialization module */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern NODE *true;
XXextern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
XXextern NODE *s_lambda,*s_macro;
XXextern NODE *s_stdin,*s_stdout;
XXextern NODE *s_evalhook,*s_applyhook;
XXextern NODE *s_tracenable,*s_tlimit,*s_breakenable;
XXextern NODE *s_continue,*s_quit;
XXextern NODE *s_car,*s_cdr,*s_get,*s_svalue,*s_splist,*s_eql;
XXextern NODE *k_test,*k_tnot,*k_optional,*k_rest,*k_aux;
XXextern NODE *a_subr,*a_fsubr;
XXextern NODE *a_list,*a_sym,*a_int,*a_str,*a_obj,*a_fptr;
XXextern struct fdef ftab[];
XX
XX/* xlinit - xlisp initialization routine */
XXxlinit()
XX{
XX    struct fdef *fptr;
XX    NODE *sym;
XX
XX    /* initialize xlisp (must be in this order) */
XX    xlminit();	/* initialize xldmem.c */
XX    xlsinit();	/* initialize xlsym.c */
XX    xldinit();	/* initialize xldbug.c */
XX    xloinit();	/* initialize xlobj.c */
XX
XX    /* enter the builtin functions */
XX    for (fptr = ftab; fptr->f_name; fptr++)
XX	xlsubr(fptr->f_name,fptr->f_type,fptr->f_fcn);
XX
XX    /* enter the 't' symbol */
XX    true = xlsenter("t");
XX    true->n_symvalue = true;
XX
XX    /* enter some important symbols */
XX    s_quote	= xlsenter("quote");
XX    s_function	= xlsenter("function");
XX    s_bquote	= xlsenter("backquote");
XX    s_comma	= xlsenter("comma");
XX    s_comat	= xlsenter("comma-at");
XX    s_lambda	= xlsenter("lambda");
XX    s_macro	= xlsenter("macro");
XX    s_eql	= xlsenter("eql");
XX    s_continue	= xlsenter("continue");
XX    s_quit	= xlsenter("quit");
XX
XX    /* enter setf place specifiers */
XX    s_car	= xlsenter("car");
XX    s_cdr	= xlsenter("cdr");
XX    s_get	= xlsenter("get");
XX    s_svalue	= xlsenter("symbol-value");
XX    s_splist	= xlsenter("symbol-plist");
XX
XX    /* enter parameter list keywords */
XX    k_test	= xlsenter(":test");
XX    k_tnot	= xlsenter(":test-not");
XX
XX    /* enter lambda list keywords */
XX    k_optional	= xlsenter("&optional");
XX    k_rest	= xlsenter("&rest");
XX    k_aux	= xlsenter("&aux");
XX
XX    /* enter *standard-input* and *standard-output* */
XX    s_stdin = xlsenter("*standard-input*");
XX    s_stdin->n_symvalue = newnode(FPTR);
XX    s_stdin->n_symvalue->n_fp = stdin;
XX    s_stdin->n_symvalue->n_savech = 0;
XX    s_stdout = xlsenter("*standard-output*");
XX    s_stdout->n_symvalue = newnode(FPTR);
XX    s_stdout->n_symvalue->n_fp = stdout;
XX    s_stdout->n_symvalue->n_savech = 0;
XX
XX    /* enter the eval and apply hook variables */
XX    s_evalhook = xlsenter("*evalhook*");
XX    s_evalhook->n_symvalue = NIL;
XX    s_applyhook = xlsenter("*applyhook*");
XX    s_applyhook->n_symvalue = NIL;
XX
XX    /* enter the error traceback and the error break enable flags */
XX    s_tracenable = xlsenter("*tracenable*");
XX    s_tracenable->n_symvalue = NIL;
XX    s_tlimit = xlsenter("*tracelimit*");
XX    s_tlimit->n_symvalue = NIL;
XX    s_breakenable = xlsenter("*breakenable*");
XX    s_breakenable->n_symvalue = true;
XX
XX    /* enter a copyright notice into the oblist */
XX    sym = xlsenter("**Copyright-1985-by-David-Betz**");
XX    sym->n_symvalue = true;
XX
XX    /* enter type names */
XX    a_subr	= xlsenter("SUBR");
XX    a_fsubr	= xlsenter("FSUBR");
XX    a_list	= xlsenter("LIST");
XX    a_sym	= xlsenter("SYM");
XX    a_int	= xlsenter("INT");
XX    a_str	= xlsenter("STR");
XX    a_obj	= xlsenter("OBJ");
XX    a_fptr	= xlsenter("FPTR");
XX}
SHAR_EOF
if test 3268 -ne "`wc -c xlinit.c`"
then
echo shar: error transmitting xlinit.c '(should have been 3268 characters)'
fi
echo shar: extracting xlmath.c '(5921 characters)'
sed 's/^XX//' << \SHAR_EOF > xlmath.c
XX/* xlmath - xlisp builtin arithmetic functions */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern NODE *xlstack;
XXextern NODE *true;
XX
XX/* forward declarations */
XXFORWARD NODE *unary();
XXFORWARD NODE *binary();
XXFORWARD NODE *predicate();
XXFORWARD NODE *compare();
XX
XX/* xadd - builtin function for addition */
XXNODE *xadd(args)
XX  NODE *args;
XX{
XX    return (binary(args,'+'));
XX}
XX
XX/* xsub - builtin function for subtraction */
XXNODE *xsub(args)
XX  NODE *args;
XX{
XX    return (binary(args,'-'));
XX}
XX
XX/* xmul - builtin function for multiplication */
XXNODE *xmul(args)
XX  NODE *args;
XX{
XX    return (binary(args,'*'));
XX}
XX
XX/* xdiv - builtin function for division */
XXNODE *xdiv(args)
XX  NODE *args;
XX{
XX    return (binary(args,'/'));
XX}
XX
XX/* xrem - builtin function for remainder */
XXNODE *xrem(args)
XX  NODE *args;
XX{
XX    return (binary(args,'%'));
XX}
XX
XX/* xmin - builtin function for minimum */
XXNODE *xmin(args)
XX  NODE *args;
XX{
XX    return (binary(args,'m'));
XX}
XX
XX/* xmax - builtin function for maximum */
XXNODE *xmax(args)
XX  NODE *args;
XX{
XX    return (binary(args,'M'));
XX}
XX
XX/* xbitand - builtin function for bitwise and */
XXNODE *xbitand(args)
XX  NODE *args;
XX{
XX    return (binary(args,'&'));
XX}
XX
XX/* xbitior - builtin function for bitwise inclusive or */
XXNODE *xbitior(args)
XX  NODE *args;
XX{
XX    return (binary(args,'|'));
XX}
XX
XX/* xbitxor - builtin function for bitwise exclusive or */
XXNODE *xbitxor(args)
XX  NODE *args;
XX{
XX    return (binary(args,'^'));
XX}
XX
XX/* binary - handle binary operations */
XXLOCAL NODE *binary(args,fcn)
XX  NODE *args; int fcn;
XX{
XX    int ival,iarg;
XX    NODE *val;
XX
XX    /* get the first argument */
XX    ival = xlmatch(INT,&args)->n_int;
XX
XX    /* treat '-' with a single argument as a special case */
XX    if (fcn == '-' && args == NIL)
XX	ival = -ival;
XX
XX    /* handle each remaining argument */
XX    while (args) {
XX
XX	/* get the next argument */
XX	iarg = xlmatch(INT,&args)->n_int;
XX
XX	/* accumulate the result value */
XX	switch (fcn) {
XX	case '+':	ival += iarg; break;
XX	case '-':	ival -= iarg; break;
XX	case '*':	ival *= iarg; break;
XX	case '/':	ival /= iarg; break;
XX	case '%':	ival %= iarg; break;
XX	case 'M':	if (iarg > ival) ival = iarg; break;
XX	case 'm':	if (iarg < ival) ival = iarg; break;
XX	case '&':	ival &= iarg; break;
XX	case '|':	ival |= iarg; break;
XX	case '^':	ival ^= iarg; break;
XX	}
XX    }
XX
XX    /* initialize value */
XX    val = newnode(INT);
XX    val->n_int = ival;
XX
XX    /* return the result value */
XX    return (val);
XX}
XX
XX/* xbitnot - bitwise not */
XXNODE *xbitnot(args)
XX  NODE *args;
XX{
XX    return (unary(args,'~'));
XX}
XX
XX/* xabs - builtin function for absolute value */
XXNODE *xabs(args)
XX  NODE *args;
XX{
XX    return (unary(args,'A'));
XX}
XX
XX/* xadd1 - builtin function for adding one */
XXNODE *xadd1(args)
XX  NODE *args;
XX{
XX    return (unary(args,'+'));
XX}
XX
XX/* xsub1 - builtin function for subtracting one */
XXNODE *xsub1(args)
XX  NODE *args;
XX{
XX    return (unary(args,'-'));
XX}
XX
XX/* unary - handle unary operations */
XXLOCAL NODE *unary(args,fcn)
XX  NODE *args; int fcn;
XX{
XX    NODE *val;
XX    int ival;
XX
XX    /* get the argument */
XX    ival = xlmatch(INT,&args)->n_int;
XX    xllastarg(args);
XX
XX    /* compute the result */
XX    switch (fcn) {
XX    case '~':	ival = ~ival; break;
XX    case 'A':	if (ival < 0) ival = -ival; break;
XX    case '+':	ival++; break;
XX    case '-':	ival--; break;
XX    }
XX
XX    /* convert the value  */
XX    val = newnode(INT);
XX    val->n_int = ival;
XX
XX    /* return the result value */
XX    return (val);
XX}
XX
XX/* xminusp - is this number negative? */
XXNODE *xminusp(args)
XX  NODE *args;
XX{
XX    return (predicate(args,'-'));
XX}
XX
XX/* xzerop - is this number zero? */
XXNODE *xzerop(args)
XX  NODE *args;
XX{
XX    return (predicate(args,'Z'));
XX}
XX
XX/* xplusp - is this number positive? */
XXNODE *xplusp(args)
XX  NODE *args;
XX{
XX    return (predicate(args,'+'));
XX}
XX
XX/* xevenp - is this number even? */
XXNODE *xevenp(args)
XX  NODE *args;
XX{
XX    return (predicate(args,'E'));
XX}
XX
XX/* xoddp - is this number odd? */
XXNODE *xoddp(args)
XX  NODE *args;
XX{
XX    return (predicate(args,'O'));
XX}
XX
XX/* predicate - handle a predicate function */
XXLOCAL NODE *predicate(args,fcn)
XX  NODE *args; int fcn;
XX{
XX    NODE *val;
XX    int ival;
XX
XX    /* get the argument */
XX    ival = xlmatch(INT,&args)->n_int;
XX    xllastarg(args);
XX
XX    /* compute the result */
XX    switch (fcn) {
XX    case '-':	ival = (ival < 0); break;
XX    case 'Z':	ival = (ival == 0); break;
XX    case '+':	ival = (ival > 0); break;
XX    case 'E':	ival = ((ival & 1) == 0); break;
XX    case 'O':	ival = ((ival & 1) != 0); break;
XX    }
XX
XX    /* return the result value */
XX    return (ival ? true : NIL);
XX}
XX
XX/* xlss - builtin function for < */
XXNODE *xlss(args)
XX  NODE *args;
XX{
XX    return (compare(args,'<'));
XX}
XX
XX/* xleq - builtin function for <= */
XXNODE *xleq(args)
XX  NODE *args;
XX{
XX    return (compare(args,'L'));
XX}
XX
XX/* equ - builtin function for = */
XXNODE *xequ(args)
XX  NODE *args;
XX{
XX    return (compare(args,'='));
XX}
XX
XX/* xneq - builtin function for /= */
XXNODE *xneq(args)
XX  NODE *args;
XX{
XX    return (compare(args,'#'));
XX}
XX
XX/* xgeq - builtin function for >= */
XXNODE *xgeq(args)
XX  NODE *args;
XX{
XX    return (compare(args,'G'));
XX}
XX
XX/* xgtr - builtin function for > */
XXNODE *xgtr(args)
XX  NODE *args;
XX{
XX    return (compare(args,'>'));
XX}
XX
XX/* compare - common compare function */
XXLOCAL NODE *compare(args,fcn)
XX  NODE *args; int fcn;
XX{
XX    NODE *arg1,*arg2;
XX    int cmp;
XX
XX    /* get the two arguments */
XX    arg1 = xlarg(&args);
XX    arg2 = xlarg(&args);
XX    xllastarg(args);
XX
XX    /* do the compare */
XX    if (stringp(arg1) && stringp(arg2))
XX	cmp = strcmp(arg1->n_str,arg2->n_str);
XX    else if (fixp(arg1) && fixp(arg2))
XX	cmp = arg1->n_int - arg2->n_int;
XX    else
XX	cmp = (int)(arg1 - arg2);
XX
XX    /* compute result of the compare */
XX    switch (fcn) {
XX    case '<':	cmp = (cmp < 0); break;
XX    case 'L':	cmp = (cmp <= 0); break;
XX    case '=':	cmp = (cmp == 0); break;
XX    case '#':	cmp = (cmp != 0); break;
XX    case 'G':	cmp = (cmp >= 0); break;
XX    case '>':	cmp = (cmp > 0); break;
XX    }
XX
XX    /* return the result */
XX    return (cmp ? true : NIL);
XX}
SHAR_EOF
if test 5921 -ne "`wc -c xlmath.c`"
then
echo shar: error transmitting xlmath.c '(should have been 5921 characters)'
fi
echo shar: extracting xlprin.c '(2789 characters)'
sed 's/^XX//' << \SHAR_EOF > xlprin.c
XX/* xlprint - xlisp print routine */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern NODE *xlstack;
XXextern char buf[];
XX
XX/* xlprint - print an xlisp value */
XXxlprint(fptr,vptr,flag)
XX  NODE *fptr,*vptr; int flag;
XX{
XX    NODE *nptr,*next;
XX
XX    /* print nil */
XX    if (vptr == NIL) {
XX	putstr(fptr,"nil");
XX	return;
XX    }
XX
XX    /* check value type */
XX    switch (ntype(vptr)) {
XX    case SUBR:
XX	    putatm(fptr,"Subr",vptr);
XX	    break;
XX    case FSUBR:
XX	    putatm(fptr,"FSubr",vptr);
XX	    break;
XX    case LIST:
XX	    xlputc(fptr,'(');
XX	    for (nptr = vptr; nptr != NIL; nptr = next) {
XX	        xlprint(fptr,car(nptr),flag);
XX		if (next = cdr(nptr))
XX		    if (consp(next))
XX			xlputc(fptr,' ');
XX		    else {
XX			putstr(fptr," . ");
XX			xlprint(fptr,next,flag);
XX			break;
XX		    }
XX	    }
XX	    xlputc(fptr,')');
XX	    break;
XX    case SYM:
XX	    putstr(fptr,xlsymname(vptr));
XX	    break;
XX    case INT:
XX	    putdec(fptr,vptr->n_int);
XX	    break;
XX    case STR:
XX	    if (flag)
XX		putstring(fptr,vptr->n_str);
XX	    else
XX		putstr(fptr,vptr->n_str);
XX	    break;
XX    case FPTR:
XX	    putatm(fptr,"File",vptr);
XX	    break;
XX    case OBJ:
XX	    putatm(fptr,"Object",vptr);
XX	    break;
XX    case FREE:
XX	    putatm(fptr,"Free",vptr);
XX	    break;
XX    default:
XX	    putatm(fptr,"Foo",vptr);
XX	    break;
XX    }
XX}
XX
XX/* xlterpri - terminate the current print line */
XXxlterpri(fptr)
XX  NODE *fptr;
XX{
XX    xlputc(fptr,'\n');
XX}
XX
XX/* putstring - output a string */
XXLOCAL putstring(fptr,str)
XX  NODE *fptr; char *str;
XX{
XX    int ch;
XX
XX    /* output the initial quote */
XX    xlputc(fptr,'"');
XX
XX    /* output each character in the string */
XX    while (ch = *str++)
XX
XX	/* check for a control character */
XX	if (ch < 040 || ch == '\\') {
XX	    xlputc(fptr,'\\');
XX	    switch (ch) {
XX	    case '\033':
XX		    xlputc(fptr,'e');
XX		    break;
XX	    case '\n':
XX		    xlputc(fptr,'n');
XX		    break;
XX	    case '\r':
XX		    xlputc(fptr,'r');
XX		    break;
XX	    case '\t':
XX		    xlputc(fptr,'t');
XX		    break;
XX	    case '\\':
XX		    xlputc(fptr,'\\');
XX		    break;
XX	    default:
XX		    putoct(fptr,ch);
XX		    break;
XX	    }
XX	}
XX
XX	/* output a normal character */
XX	else
XX	    xlputc(fptr,ch);
XX
XX    /* output the terminating quote */
XX    xlputc(fptr,'"');
XX}
XX
XX/* putatm - output an atom */
XXLOCAL putatm(fptr,tag,val)
XX  NODE *fptr; char *tag; NODE *val;
XX{
XX    sprintf(buf,"#<%s: #",tag); putstr(fptr,buf);
XX    sprintf(buf,AFMT,val); putstr(fptr,buf);
XX    xlputc(fptr,'>');
XX}
XX
XX/* putdec - output a decimal number */
XXLOCAL putdec(fptr,n)
XX  NODE *fptr; int n;
XX{
XX    sprintf(buf,"%d",n);
XX    putstr(fptr,buf);
XX}
XX
XX/* putoct - output an octal byte value */
XXLOCAL putoct(fptr,n)
XX  NODE *fptr; int n;
XX{
XX    sprintf(buf,"%03o",n);
XX    putstr(fptr,buf);
XX}
XX
XX/* putstr - output a string */
XXLOCAL putstr(fptr,str)
XX  NODE *fptr; char *str;
XX{
XX    while (*str)
XX	xlputc(fptr,*str++);
XX}
SHAR_EOF
if test 2789 -ne "`wc -c xlprin.c`"
then
echo shar: error transmitting xlprin.c '(should have been 2789 characters)'
fi
echo shar: extracting xlstub.c.NOTUSED '(158 characters)'
sed 's/^XX//' << \SHAR_EOF > xlstub.c.NOTUSED
XX/* xlstub.c - stubs for replacing the 'xlobj' module */
XX
XX#include "xlisp.h"
XX
XXxloinit() {}
XXNODE *xlsend() { return (NIL); }
XXNODE *xlobsym() { return (NIL); }
XX
SHAR_EOF
if test 158 -ne "`wc -c xlstub.c.NOTUSED`"
then
echo shar: error transmitting xlstub.c.NOTUSED '(should have been 158 characters)'
fi
echo shar: extracting xlsubr.c '(4232 characters)'
sed 's/^XX//' << \SHAR_EOF > xlsubr.c
XX/* xlsubr - xlisp builtin function support routines */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern NODE *k_test,*k_tnot,*s_eql;
XXextern NODE *xlstack;
XX
XX/* xlsubr - define a builtin function */
XXxlsubr(sname,type,subr)
XX  char *sname; int type; NODE *(*subr)();
XX{
XX    NODE *sym;
XX
XX    /* enter the symbol */
XX    sym = xlsenter(sname);
XX
XX    /* initialize the value */
XX    sym->n_symvalue = newnode(type);
XX    sym->n_symvalue->n_subr = subr;
XX}
XX
XX/* xlarg - get the next argument */
XXNODE *xlarg(pargs)
XX  NODE **pargs;
XX{
XX    NODE *arg;
XX
XX    /* make sure the argument exists */
XX    if (!consp(*pargs))
XX	xlfail("too few arguments");
XX
XX    /* get the argument value */
XX    arg = car(*pargs);
XX
XX    /* make sure its not a keyword */
XX    if (symbolp(arg) && *car(arg->n_symplist)->n_str == ':')
XX	xlfail("too few arguments");
XX
XX    /* move the argument pointer ahead */
XX    *pargs = cdr(*pargs);
XX
XX    /* return the argument */
XX    return (arg);
XX}
XX
XX/* xlmatch - get an argument and match its type */
XXNODE *xlmatch(type,pargs)
XX  int type; NODE **pargs;
XX{
XX    NODE *arg;
XX
XX    /* get the argument */
XX    arg = xlarg(pargs);
XX
XX    /* check its type */
XX    if (type == LIST) {
XX	if (arg && ntype(arg) != LIST)
XX	    xlfail("bad argument type");
XX    }
XX    else {
XX	if (arg == NIL || ntype(arg) != type)
XX	    xlfail("bad argument type");
XX    }
XX
XX    /* return the argument */
XX    return (arg);
XX}
XX
XX/* xlevarg - get the next argument and evaluate it */
XXNODE *xlevarg(pargs)
XX  NODE **pargs;
XX{
XX    NODE *oldstk,val;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&val,NULL);
XX
XX    /* get the argument */
XX    val.n_ptr = xlarg(pargs);
XX
XX    /* evaluate the argument */
XX    val.n_ptr = xleval(val.n_ptr);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the argument */
XX    return (val.n_ptr);
XX}
XX
XX/* xlevmatch - get an evaluated argument and match its type */
XXNODE *xlevmatch(type,pargs)
XX  int type; NODE **pargs;
XX{
XX    NODE *arg;
XX
XX    /* get the argument */
XX    arg = xlevarg(pargs);
XX
XX    /* check its type */
XX    if (type == LIST) {
XX	if (arg && ntype(arg) != LIST)
XX	    xlfail("bad argument type");
XX    }
XX    else {
XX	if (arg == NIL || ntype(arg) != type)
XX	    xlfail("bad argument type");
XX    }
XX
XX    /* return the argument */
XX    return (arg);
XX}
XX
XX/* xltest - get the :test or :test-not keyword argument */
XXxltest(pfcn,ptresult,pargs)
XX  NODE **pfcn; int *ptresult; NODE **pargs;
XX{
XX    NODE *arg;
XX
XX    /* default the argument to eql */
XX    if (!consp(*pargs)) {
XX	*pfcn = s_eql->n_symvalue;
XX	*ptresult = TRUE;
XX	return;
XX    }
XX
XX    /* get the keyword */
XX    arg = car(*pargs);
XX
XX    /* check the keyword */
XX    if (arg == k_test)
XX	*ptresult = TRUE;
XX    else if (arg == k_tnot)
XX	*ptresult = FALSE;
XX    else
XX	xlfail("expecting :test or :test-not");
XX
XX    /* move the argument pointer ahead */
XX    *pargs = cdr(*pargs);
XX
XX    /* make sure the argument exists */
XX    if (!consp(*pargs))
XX	xlfail("no value for keyword argument");
XX
XX    /* get the argument value */
XX    *pfcn = car(*pargs);
XX
XX    /* if its a symbol, get its value */
XX    if (symbolp(*pfcn))
XX	*pfcn = xleval(*pfcn);
XX
XX    /* move the argument pointer ahead */
XX    *pargs = cdr(*pargs);
XX}
XX
XX/* xllastarg - make sure the remainder of the argument list is empty */
XXxllastarg(args)
XX  NODE *args;
XX{
XX    if (args)
XX	xlfail("too many arguments");
XX}
XX
XX/* assign - assign a value to a symbol */
XXassign(sym,val)
XX  NODE *sym,*val;
XX{
XX    NODE *lptr;
XX
XX    /* check for a current object */
XX    if ((lptr = xlobsym(sym)) != NIL)
XX	rplaca(lptr,val);
XX    else
XX	sym->n_symvalue = val;
XX}
XX
XX/* eq - internal eq function */
XXint eq(arg1,arg2)
XX  NODE *arg1,*arg2;
XX{
XX    return (arg1 == arg2);
XX}
XX
XX/* eql - internal eql function */
XXint eql(arg1,arg2)
XX  NODE *arg1,*arg2;
XX{
XX    if (eq(arg1,arg2))
XX	return (TRUE);
XX    else if (fixp(arg1) && fixp(arg2))
XX	return (arg1->n_int == arg2->n_int);
XX    else if (stringp(arg1) && stringp(arg2))
XX	return (strcmp(arg1->n_str,arg2->n_str) == 0);
XX    else
XX	return (FALSE);
XX}
XX
XX/* equal - internal equal function */
XXint equal(arg1,arg2)
XX  NODE *arg1,*arg2;
XX{
XX    /* compare the arguments */
XX    if (eql(arg1,arg2))
XX	return (TRUE);
XX    else if (consp(arg1) && consp(arg2))
XX	return (equal(car(arg1),car(arg2)) && equal(cdr(arg1),cdr(arg2)));
XX    else
XX	return (FALSE);
XX}
SHAR_EOF
if test 4232 -ne "`wc -c xlsubr.c`"
then
echo shar: error transmitting xlsubr.c '(should have been 4232 characters)'
fi
echo shar: extracting xlsym.c '(3869 characters)'
sed 's/^XX//' << \SHAR_EOF > xlsym.c
XX/* xlsym - symbol handling routines */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern NODE *oblist,*keylist;
XXextern NODE *s_unbound;
XXextern NODE *xlstack;
XX
XX/* forward declarations */
XXFORWARD NODE *symenter();
XXFORWARD NODE *xlmakesym();
XXFORWARD NODE *findprop();
XX
XX/* xlenter - enter a symbol into the oblist or keylist */
XXNODE *xlenter(name,type)
XX  char *name;
XX{
XX    return (symenter(name,type,(*name == ':' ? keylist : oblist)));
XX}
XX
XX/* symenter - enter a symbol into a package */
XXLOCAL NODE *symenter(name,type,listsym)
XX  char *name; int type; NODE *listsym;
XX{
XX    NODE *oldstk,*lsym,*nsym,newsym;
XX    int cmp;
XX
XX    /* check for nil */
XX    if (strcmp(name,"nil") == 0)
XX	return (NIL);
XX
XX    /* check for symbol already in table */
XX    lsym = NIL;
XX    nsym = listsym->n_symvalue;
XX    while (nsym) {
XX	if ((cmp = strcmp(name,xlsymname(car(nsym)))) <= 0)
XX	    break;
XX	lsym = nsym;
XX	nsym = cdr(nsym);
XX    }
XX
XX    /* check to see if we found it */
XX    if (nsym && cmp == 0)
XX	return (car(nsym));
XX
XX    /* make a new symbol node and link it into the list */
XX    oldstk = xlsave(&newsym,NULL);
XX    newsym.n_ptr = newnode(LIST);
XX    rplaca(newsym.n_ptr,xlmakesym(name,type));
XX    rplacd(newsym.n_ptr,nsym);
XX    if (lsym)
XX	rplacd(lsym,newsym.n_ptr);
XX    else
XX	listsym->n_symvalue = newsym.n_ptr;
XX    xlstack = oldstk;
XX
XX    /* return the new symbol */
XX    return (car(newsym.n_ptr));
XX}
XX
XX/* xlsenter - enter a symbol with a static print name */
XXNODE *xlsenter(name)
XX  char *name;
XX{
XX    return (xlenter(name,STATIC));
XX}
XX
XX/* xlmakesym - make a new symbol node */
XXNODE *xlmakesym(name,type)
XX  char *name;
XX{
XX    NODE *oldstk,sym,*str;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&sym,NULL);
XX
XX    /* make a new symbol node */
XX    sym.n_ptr = newnode(SYM);
XX    sym.n_ptr->n_symvalue = (*name == ':' ? sym.n_ptr : s_unbound);
XX    sym.n_ptr->n_symplist = newnode(LIST);
XX    rplaca(sym.n_ptr->n_symplist,str = newnode(STR));
XX    str->n_str = (type == DYNAMIC ? strsave(name) : name);
XX    str->n_strtype = type;
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the new symbol node */
XX    return (sym.n_ptr);
XX}
XX
XX/* xlsymname - return the print name of a symbol */
XXchar *xlsymname(sym)
XX  NODE *sym;
XX{
XX    return (car(sym->n_symplist)->n_str);
XX}
XX
XX/* xlgetprop - get the value of a property */
XXNODE *xlgetprop(sym,prp)
XX  NODE *sym,*prp;
XX{
XX    NODE *p;
XX
XX    return ((p = findprop(sym,prp)) ? car(p) : NIL);
XX}
XX
XX/* xlputprop - put a property value onto the property list */
XXxlputprop(sym,val,prp)
XX  NODE *sym,*val,*prp;
XX{
XX    NODE *oldstk,p,*pair;
XX
XX    if ((pair = findprop(sym,prp)) == NIL) {
XX	oldstk = xlsave(&p,NULL);
XX	p.n_ptr = newnode(LIST);
XX	rplaca(p.n_ptr,prp);
XX	rplacd(p.n_ptr,pair = newnode(LIST));
XX	rplaca(pair,val);
XX	rplacd(pair,cdr(sym->n_symplist));
XX	rplacd(sym->n_symplist,p.n_ptr);
XX	xlstack = oldstk;
XX    }
XX    rplaca(pair,val);
XX}
XX
XX/* xlremprop - remove a property from a property list */
XXxlremprop(sym,prp)
XX  NODE *sym,*prp;
XX{
XX    NODE *last,*p;
XX
XX    last = NIL;
XX    for (p = cdr(sym->n_symplist); consp(p) && consp(cdr(p)); p = cdr(last)) {
XX	if (car(p) == prp)
XX	    if (last)
XX		rplacd(last,cdr(cdr(p)));
XX	    else
XX		rplacd(sym->n_symplist,cdr(cdr(p)));
XX	last = cdr(p);
XX    }
XX}
XX
XX/* findprop - find a property pair */
XXLOCAL NODE *findprop(sym,prp)
XX  NODE *sym,*prp;
XX{
XX    NODE *p;
XX
XX    for (p = cdr(sym->n_symplist); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
XX	if (car(p) == prp)
XX	    return (cdr(p));
XX    return (NIL);
XX}
XX
XX/* xlsinit - symbol initialization routine */
XXxlsinit()
XX{
XX    /* initialize the oblist */
XX    oblist = xlmakesym("*oblist*",STATIC);
XX    oblist->n_symvalue = newnode(LIST);
XX    rplaca(oblist->n_symvalue,oblist);
XX
XX    /* initialize the keyword list */
XX    keylist = xlsenter("*keylist*");
XX
XX    /* enter the unbound symbol indicator */
XX    s_unbound = xlsenter("*unbound*");
XX    s_unbound->n_symvalue = s_unbound;
XX}
SHAR_EOF
if test 3869 -ne "`wc -c xlsym.c`"
then
echo shar: error transmitting xlsym.c '(should have been 3869 characters)'
fi
echo shar: extracting xlsys.c '(3003 characters)'
sed 's/^XX//' << \SHAR_EOF > xlsys.c
XX/* xlsys.c - xlisp builtin system functions */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern NODE *xlstack;
XXextern int anodes;
XX
XX/* external symbols */
XXextern NODE *a_subr,*a_fsubr;
XXextern NODE *a_list,*a_sym,*a_int,*a_str,*a_obj,*a_fptr;
XXextern NODE *true;
XX
XX/* xload - direct input from a file */
XXNODE *xload(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,fname,*val;
XX    int vflag,pflag;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&fname,NULL);
XX
XX    /* get the file name, verbose flag and print flag */
XX    fname.n_ptr = xlmatch(STR,&args);
XX    vflag = (args ? xlarg(&args) != NIL : TRUE);
XX    pflag = (args ? xlarg(&args) != NIL : FALSE);
XX    xllastarg(args);
XX
XX    /* load the file */
XX    val = (xlload(fname.n_ptr->n_str,vflag,pflag) ? true : NIL);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the status */
XX    return (val);
XX}
XX
XX/* xgc - xlisp function to force garbage collection */
XXNODE *xgc(args)
XX  NODE *args;
XX{
XX    /* make sure there aren't any arguments */
XX    xllastarg(args);
XX
XX    /* garbage collect */
XX    gc();
XX
XX    /* return nil */
XX    return (NIL);
XX}
XX
XX/* xexpand - xlisp function to force memory expansion */
XXNODE *xexpand(args)
XX  NODE *args;
XX{
XX    NODE *val;
XX    int n,i;
XX
XX    /* get the new number to allocate */
XX    n = (args ? xlmatch(INT,&args)->n_int : 1);
XX    xllastarg(args);
XX
XX    /* allocate more segments */
XX    for (i = 0; i < n; i++)
XX	if (!addseg())
XX	    break;
XX
XX    /* return the number of segments added */
XX    val = newnode(INT);
XX    val->n_int = i;
XX    return (val);
XX}
XX
XX/* xalloc - xlisp function to set the number of nodes to allocate */
XXNODE *xalloc(args)
XX  NODE *args;
XX{
XX    NODE *val;
XX    int n,oldn;
XX
XX    /* get the new number to allocate */
XX    n = xlmatch(INT,&args)->n_int;
XX
XX    /* make sure there aren't any more arguments */
XX    xllastarg(args);
XX
XX    /* set the new number of nodes to allocate */
XX    oldn = anodes;
XX    anodes = n;
XX
XX    /* return the old number */
XX    val = newnode(INT);
XX    val->n_int = oldn;
XX    return (val);
XX}
XX
XX/* xmem - xlisp function to print memory statistics */
XXNODE *xmem(args)
XX  NODE *args;
XX{
XX    /* make sure there aren't any arguments */
XX    xllastarg(args);
XX
XX    /* print the statistics */
XX    stats();
XX
XX    /* return nil */
XX    return (NIL);
XX}
XX
XX/* xtype - return type of a thing */
XXNODE *xtype(args)
XX    NODE *args;
XX{
XX    NODE *arg;
XX
XX    if (!(arg = xlarg(&args)))
XX	return (NIL);
XX
XX    switch (ntype(arg)) {
XX	case SUBR:	return (a_subr);
XX	case FSUBR:	return (a_fsubr);
XX	case LIST:	return (a_list);
XX	case SYM:	return (a_sym);
XX	case INT:	return (a_int);
XX	case STR:	return (a_str);
XX	case OBJ:	return (a_obj);
XX	case FPTR:	return (a_fptr);
XX	default:	xlfail("bad node type");
XX    }
XX}
XX
XX/* xbaktrace - print the trace back stack */
XXNODE *xbaktrace(args)
XX  NODE *args;
XX{
XX    int n;
XX
XX    n = (args ? xlmatch(INT,&args)->n_int : -1);
XX    xllastarg(args);
XX    xlbaktrace(n);
XX    return (NIL);
XX}
XX
XX/* xexit - get out of xlisp */
XXNODE *xexit(args)
XX  NODE *args;
XX{
XX    xllastarg(args);
XX    exit();
XX}
SHAR_EOF
if test 3003 -ne "`wc -c xlsys.c`"
then
echo shar: error transmitting xlsys.c '(should have been 3003 characters)'
fi
#	End of shell archive
exit 0