xlisp v1.4 (4 of 5)
Chuck Wegrzyn
wegrzyn at encore.UUCP
Wed Mar 13 23:55:15 AEST 1985
# This is a shell archive.
# Remove everything above and including the cut line.
# Then run the rest of the file through sh.
-----cut here-----cut here-----cut here-----cut here-----
#!/bin/sh
# shar: Shell Archiver
# Run the following text with /bin/sh to create:
# 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
More information about the Comp.sources.unix
mailing list