sources-request@mirror.UUCP (08/13/86)
Submitted by: seismo!utah-cs!b-davis (Brad Davis)
Mod.sources: Volume 6, Issue 108
Archive-name: xlisp1.6/Part01
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# xlfio.c
# xlftab.c
# xlglob.c
# xlinit.c
# xlio.c
# xlisp.c
# xljump.c
# xllist.c
# xlmath.c
# This archive created: Mon Jul 14 10:22:46 1986
export PATH; PATH=/bin:$PATH
if test -f 'xlfio.c'
then
echo shar: will not over-write existing file "'xlfio.c'"
else
cat << \SHAR_EOF > 'xlfio.c'
/* xlfio.c - xlisp file i/o */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
#ifdef MEGAMAX
overlay "io"
#endif
/* external variables */
extern NODE *s_stdin,*s_stdout,*true;
extern NODE ***xlstack;
extern int xlfsize;
extern char buf[];
/* external routines */
extern FILE *fopen();
/* forward declarations */
FORWARD NODE *printit();
FORWARD NODE *flatsize();
FORWARD NODE *openit();
/* xread - read an expression */
NODE *xread(args)
NODE *args;
{
NODE ***oldstk,*fptr,*eof,*rflag,*val;
/* create a new stack frame */
oldstk = xlsave(&fptr,&eof,(NODE **)NULL);
/* get file pointer and eof value */
fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
eof = (args ? xlarg(&args) : NIL);
rflag = (args ? xlarg(&args) : NIL);
xllastarg(args);
/* read an expression */
if (!xlread(fptr,&val,rflag != NIL))
val = eof;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the expression */
return (val);
}
/* xprint - built-in function 'print' */
NODE *xprint(args)
NODE *args;
{
return (printit(args,TRUE,TRUE));
}
/* xprin1 - built-in function 'prin1' */
NODE *xprin1(args)
NODE *args;
{
return (printit(args,TRUE,FALSE));
}
/* xprinc - built-in function princ */
NODE *xprinc(args)
NODE *args;
{
return (printit(args,FALSE,FALSE));
}
/* xterpri - terminate the current print line */
NODE *xterpri(args)
NODE *args;
{
NODE *fptr;
/* get file pointer */
fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
xllastarg(args);
/* terminate the print line and return nil */
xlterpri(fptr);
return (NIL);
}
/* printit - common print function */
LOCAL NODE *printit(args,pflag,tflag)
NODE *args; int pflag,tflag;
{
NODE ***oldstk,*fptr,*val;
/* create a new stack frame */
oldstk = xlsave(&fptr,&val,(NODE **)NULL);
/* get expression to print and file pointer */
val = xlarg(&args);
fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
xllastarg(args);
/* print the value */
xlprint(fptr,val,pflag);
/* terminate the print line if necessary */
if (tflag)
xlterpri(fptr);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result */
return (val);
}
/* xflatsize - compute the size of a printed representation using prin1 */
NODE *xflatsize(args)
NODE *args;
{
return (flatsize(args,TRUE));
}
/* xflatc - compute the size of a printed representation using princ */
NODE *xflatc(args)
NODE *args;
{
return (flatsize(args,FALSE));
}
/* flatsize - compute the size of a printed expression */
LOCAL NODE *flatsize(args,pflag)
NODE *args; int pflag;
{
NODE ***oldstk,*val;
/* create a new stack frame */
oldstk = xlsave(&val,(NODE **)NULL);
/* get the expression */
val = xlarg(&args);
xllastarg(args);
/* print the value to compute its size */
xlfsize = 0;
xlprint(NIL,val,pflag);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the length of the expression */
return (cvfixnum((FIXNUM)xlfsize));
}
/* xopeni - open an input file */
NODE *xopeni(args)
NODE *args;
{
return (openit(args,"r"));
}
/* xopeno - open an output file */
NODE *xopeno(args)
NODE *args;
{
return (openit(args,"w"));
}
/* openit - common file open routine */
LOCAL NODE *openit(args,mode)
NODE *args; char *mode;
{
NODE *fname,*val;
char *name;
FILE *fp;
/* get the file name */
fname = xlarg(&args);
xllastarg(args);
/* get the name string */
if (symbolp(fname))
name = getstring(getpname(fname));
else if (stringp(fname))
name = getstring(fname);
else
xlfail("bad argument type",fname);
/* try to open the file */
if ((fp = fopen(name,mode)) != NULL)
val = cvfile(fp);
else
val = NIL;
/* return the file pointer */
return (val);
}
/* xclose - close a file */
NODE *xclose(args)
NODE *args;
{
NODE *fptr;
/* get file pointer */
fptr = xlmatch(FPTR,&args);
xllastarg(args);
/* make sure the file exists */
if (getfile(fptr) == NULL)
xlfail("file not open");
/* close the file */
fclose(getfile(fptr));
setfile(fptr,NULL);
/* return nil */
return (NIL);
}
/* xrdchar - read a character from a file */
NODE *xrdchar(args)
NODE *args;
{
NODE *fptr;
int ch;
/* get file pointer */
fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
xllastarg(args);
/* get character and check for eof */
return ((ch = xlgetc(fptr)) == EOF ? NIL : cvfixnum((FIXNUM)ch));
}
/* xpkchar - peek at a character from a file */
NODE *xpkchar(args)
NODE *args;
{
NODE *flag,*fptr;
int ch;
/* peek flag and get file pointer */
flag = (args ? xlarg(&args) : NIL);
fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
xllastarg(args);
/* skip leading white space and get a character */
if (flag)
while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
xlgetc(fptr);
else
ch = xlpeek(fptr);
/* return the character */
return (ch == EOF ? NIL : cvfixnum((FIXNUM)ch));
}
/* xwrchar - write a character to a file */
NODE *xwrchar(args)
NODE *args;
{
NODE *fptr,*chr;
/* get the character and file pointer */
chr = xlmatch(INT,&args);
fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
xllastarg(args);
/* put character to the file */
xlputc(fptr,(int)getfixnum(chr));
/* return the character */
return (chr);
}
/* xreadline - read a line from a file */
NODE *xreadline(args)
NODE *args;
{
NODE ***oldstk,*fptr,*str,*newstr;
int len,blen,ch;
char *p,*sptr;
/* create a new stack frame */
oldstk = xlsave(&fptr,&str,(NODE **)NULL);
/* get file pointer */
fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
xllastarg(args);
/* get character and check for eof */
len = blen = 0; p = buf;
while ((ch = xlgetc(fptr)) != EOF && ch != '\n') {
/* check for buffer overflow */
if (blen >= STRMAX) {
newstr = newstring(len+STRMAX);
sptr = getstring(newstr); *sptr = 0;
if (str) strcat(sptr,getstring(str));
*p = 0; strcat(sptr,buf);
p = buf; blen = 0;
len += STRMAX;
str = newstr;
}
/* store the character */
*p++ = ch; blen++;
}
/* check for end of file */
if (len == 0 && p == buf && ch == EOF) {
xlstack = oldstk;
return (NIL);
}
/* append the last substring */
if (str == NIL || blen) {
newstr = newstring(len+blen);
sptr = getstring(newstr); *sptr = 0;
if (str) strcat(sptr,getstring(str));
*p = 0; strcat(sptr,buf);
str = newstr;
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the string */
return (str);
}
SHAR_EOF
fi # end of overwriting check
if test -f 'xlftab.c'
then
echo shar: will not over-write existing file "'xlftab.c'"
else
cat << \SHAR_EOF > 'xlftab.c'
/* xlftab.c - xlisp function table */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
/* external functions */
extern NODE
*xeval(),*xapply(),*xfuncall(),*xquote(),*xfunction(),*xbquote(),
*xlambda(),*xset(),*xsetq(),*xsetf(),*xdefun(),*xdefmacro(),
*xgensym(),*xmakesymbol(),*xintern(),
*xsymname(),*xsymvalue(),*xsymplist(),*xget(),*xputprop(),*xremprop(),
*xhash(),*xmkarray(),*xaref(),
*xcar(),*xcdr(),
*xcaar(),*xcadr(),*xcdar(),*xcddr(),
*xcaaar(),*xcaadr(),*xcadar(),*xcaddr(),
*xcdaar(),*xcdadr(),*xcddar(),*xcdddr(),
*xcaaaar(),*xcaaadr(),*xcaadar(),*xcaaddr(),
*xcadaar(),*xcadadr(),*xcaddar(),*xcadddr(),
*xcdaaar(),*xcdaadr(),*xcdadar(),*xcdaddr(),
*xcddaar(),*xcddadr(),*xcdddar(),*xcddddr(),
*xcons(),*xlist(),*xappend(),*xreverse(),*xlast(),*xnth(),*xnthcdr(),
*xmember(),*xassoc(),*xsubst(),*xsublis(),*xremove(),*xlength(),
*xmapc(),*xmapcar(),*xmapl(),*xmaplist(),
*xrplca(),*xrplcd(),*xnconc(),*xdelete(),
*xatom(),*xsymbolp(),*xnumberp(),*xboundp(),*xnull(),*xlistp(),*xconsp(),
*xeq(),*xeql(),*xequal(),
*xcond(),*xcase(),*xand(),*xor(),*xlet(),*xletstar(),*xif(),
*xprog(),*xprogstar(),*xprog1(),*xprog2(),*xprogn(),*xgo(),*xreturn(),
*xcatch(),*xthrow(),
*xerror(),*xcerror(),*xbreak(),*xcleanup(),*xcontinue(),*xerrset(),
*xbaktrace(),*xevalhook(),
*xdo(),*xdostar(),*xdolist(),*xdotimes(),
*xminusp(),*xzerop(),*xplusp(),*xevenp(),*xoddp(),
*xfix(),*xfloat(),
*xadd(),*xsub(),*xmul(),*xdiv(),*xrem(),*xmin(),*xmax(),*xabs(),
*xadd1(),*xsub1(),*xbitand(),*xbitior(),*xbitxor(),*xbitnot(),
*xsin(),*xcos(),*xtan(),*xexpt(),*xexp(),*xsqrt(),*xrand(),
*xlss(),*xleq(),*xequ(),*xneq(),*xgeq(),*xgtr(),
*xstrcat(),*xsubstr(),*xstring(),*xchar(),
*xread(),*xprint(),*xprin1(),*xprinc(),*xterpri(),
*xflatsize(),*xflatc(),
*xopeni(),*xopeno(),*xclose(),*xrdchar(),*xpkchar(),*xwrchar(),*xreadline(),
*xload(),*xgc(),*xexpand(),*xalloc(),*xmem(),*xtype(),*xexit();
/* the function table */
struct fdef ftab[] = {
/* evaluator functions */
{ "EVAL", SUBR, xeval },
{ "APPLY", SUBR, xapply },
{ "FUNCALL", SUBR, xfuncall },
{ "QUOTE", FSUBR, xquote },
{ "FUNCTION", FSUBR, xfunction },
{ "BACKQUOTE", FSUBR, xbquote },
{ "LAMBDA", FSUBR, xlambda },
/* symbol functions */
{ "SET", SUBR, xset },
{ "SETQ", FSUBR, xsetq },
{ "SETF", FSUBR, xsetf },
{ "DEFUN", FSUBR, xdefun },
{ "DEFMACRO", FSUBR, xdefmacro },
{ "GENSYM", SUBR, xgensym },
{ "MAKE-SYMBOL", SUBR, xmakesymbol },
{ "INTERN", SUBR, xintern },
{ "SYMBOL-NAME", SUBR, xsymname },
{ "SYMBOL-VALUE", SUBR, xsymvalue },
{ "SYMBOL-PLIST", SUBR, xsymplist },
{ "GET", SUBR, xget },
{ "PUTPROP", SUBR, xputprop },
{ "REMPROP", SUBR, xremprop },
{ "HASH", SUBR, xhash },
/* array functions */
{ "MAKE-ARRAY", SUBR, xmkarray },
{ "AREF", SUBR, xaref },
/* list functions */
{ "CAR", SUBR, xcar },
{ "CDR", SUBR, xcdr },
{ "CAAR", SUBR, xcaar },
{ "CADR", SUBR, xcadr },
{ "CDAR", SUBR, xcdar },
{ "CDDR", SUBR, xcddr },
{ "CAAAR", SUBR, xcaaar },
{ "CAADR", SUBR, xcaadr },
{ "CADAR", SUBR, xcadar },
{ "CADDR", SUBR, xcaddr },
{ "CDAAR", SUBR, xcdaar },
{ "CDADR", SUBR, xcdadr },
{ "CDDAR", SUBR, xcddar },
{ "CDDDR", SUBR, xcdddr },
{ "CAAAAR", SUBR, xcaaaar },
{ "CAAADR", SUBR, xcaaadr },
{ "CAADAR", SUBR, xcaadar },
{ "CAADDR", SUBR, xcaaddr },
{ "CADAAR", SUBR, xcadaar },
{ "CADADR", SUBR, xcadadr },
{ "CADDAR", SUBR, xcaddar },
{ "CADDDR", SUBR, xcadddr },
{ "CDAAAR", SUBR, xcdaaar },
{ "CDAADR", SUBR, xcdaadr },
{ "CDADAR", SUBR, xcdadar },
{ "CDADDR", SUBR, xcdaddr },
{ "CDDAAR", SUBR, xcddaar },
{ "CDDADR", SUBR, xcddadr },
{ "CDDDAR", SUBR, xcdddar },
{ "CDDDDR", SUBR, xcddddr },
{ "CONS", SUBR, xcons },
{ "LIST", SUBR, xlist },
{ "APPEND", SUBR, xappend },
{ "REVERSE", SUBR, xreverse },
{ "LAST", SUBR, xlast },
{ "NTH", SUBR, xnth },
{ "NTHCDR", SUBR, xnthcdr },
{ "MEMBER", SUBR, xmember },
{ "ASSOC", SUBR, xassoc },
{ "SUBST", SUBR, xsubst },
{ "SUBLIS", SUBR, xsublis },
{ "REMOVE", SUBR, xremove },
{ "LENGTH", SUBR, xlength },
{ "MAPC", SUBR, xmapc },
{ "MAPCAR", SUBR, xmapcar },
{ "MAPL", SUBR, xmapl },
{ "MAPLIST", SUBR, xmaplist },
/* destructive list functions */
{ "RPLACA", SUBR, xrplca },
{ "RPLACD", SUBR, xrplcd },
{ "NCONC", SUBR, xnconc },
{ "DELETE", SUBR, xdelete },
/* predicate functions */
{ "ATOM", SUBR, xatom },
{ "SYMBOLP", SUBR, xsymbolp },
{ "NUMBERP", SUBR, xnumberp },
{ "BOUNDP", SUBR, xboundp },
{ "NULL", SUBR, xnull },
{ "NOT", SUBR, xnull },
{ "LISTP", SUBR, xlistp },
{ "CONSP", SUBR, xconsp },
{ "MINUSP", SUBR, xminusp },
{ "ZEROP", SUBR, xzerop },
{ "PLUSP", SUBR, xplusp },
{ "EVENP", SUBR, xevenp },
{ "ODDP", SUBR, xoddp },
{ "EQ", SUBR, xeq },
{ "EQL", SUBR, xeql },
{ "EQUAL", SUBR, xequal },
/* control functions */
{ "COND", FSUBR, xcond },
{ "CASE", FSUBR, xcase },
{ "AND", FSUBR, xand },
{ "OR", FSUBR, xor },
{ "LET", FSUBR, xlet },
{ "LET*", FSUBR, xletstar },
{ "IF", FSUBR, xif },
{ "PROG", FSUBR, xprog },
{ "PROG*", FSUBR, xprogstar },
{ "PROG1", FSUBR, xprog1 },
{ "PROG2", FSUBR, xprog2 },
{ "PROGN", FSUBR, xprogn },
{ "GO", FSUBR, xgo },
{ "RETURN", SUBR, xreturn },
{ "DO", FSUBR, xdo },
{ "DO*", FSUBR, xdostar },
{ "DOLIST", FSUBR, xdolist },
{ "DOTIMES", FSUBR, xdotimes },
{ "CATCH", FSUBR, xcatch },
{ "THROW", SUBR, xthrow },
/* debugging and error handling functions */
{ "ERROR", SUBR, xerror },
{ "CERROR", SUBR, xcerror },
{ "BREAK", SUBR, xbreak },
{ "CLEAN-UP", SUBR, xcleanup },
{ "CONTINUE", SUBR, xcontinue },
{ "ERRSET", FSUBR, xerrset },
{ "BAKTRACE", SUBR, xbaktrace },
{ "EVALHOOK", SUBR, xevalhook },
/* arithmetic functions */
{ "TRUNCATE", SUBR, xfix },
{ "FLOAT", SUBR, xfloat },
{ "+", SUBR, xadd },
{ "-", SUBR, xsub },
{ "*", SUBR, xmul },
{ "/", SUBR, xdiv },
{ "1+", SUBR, xadd1 },
{ "1-", SUBR, xsub1 },
{ "REM", SUBR, xrem },
{ "MIN", SUBR, xmin },
{ "MAX", SUBR, xmax },
{ "ABS", SUBR, xabs },
{ "SIN", SUBR, xsin },
{ "COS", SUBR, xcos },
{ "TAN", SUBR, xtan },
{ "EXPT", SUBR, xexpt },
{ "EXP", SUBR, xexp },
{ "SQRT", SUBR, xsqrt },
{ "RANDOM", SUBR, xrand },
/* bitwise logical functions */
{ "BIT-AND", SUBR, xbitand },
{ "BIT-IOR", SUBR, xbitior },
{ "BIT-XOR", SUBR, xbitxor },
{ "BIT-NOT", SUBR, xbitnot },
/* numeric comparison functions */
{ "<", SUBR, xlss },
{ "<=", SUBR, xleq },
{ "=", SUBR, xequ },
{ "/=", SUBR, xneq },
{ ">=", SUBR, xgeq },
{ ">", SUBR, xgtr },
/* string functions */
{ "STRCAT", SUBR, xstrcat },
{ "SUBSTR", SUBR, xsubstr },
{ "STRING", SUBR, xstring },
{ "CHAR", SUBR, xchar },
/* I/O functions */
{ "READ", SUBR, xread },
{ "PRINT", SUBR, xprint },
{ "PRIN1", SUBR, xprin1 },
{ "PRINC", SUBR, xprinc },
{ "TERPRI", SUBR, xterpri },
{ "FLATSIZE", SUBR, xflatsize },
{ "FLATC", SUBR, xflatc },
/* file I/O functions */
{ "OPENI", SUBR, xopeni },
{ "OPENO", SUBR, xopeno },
{ "CLOSE", SUBR, xclose },
{ "READ-CHAR", SUBR, xrdchar },
{ "PEEK-CHAR", SUBR, xpkchar },
{ "WRITE-CHAR", SUBR, xwrchar },
{ "READ-LINE", SUBR, xreadline },
/* system functions */
{ "LOAD", SUBR, xload },
{ "GC", SUBR, xgc },
{ "EXPAND", SUBR, xexpand },
{ "ALLOC", SUBR, xalloc },
{ "MEM", SUBR, xmem },
{ "TYPE-OF", SUBR, xtype },
{ "EXIT", SUBR, xexit },
{ 0 }
};
SHAR_EOF
fi # end of overwriting check
if test -f 'xlglob.c'
then
echo shar: will not over-write existing file "'xlglob.c'"
else
cat << \SHAR_EOF > 'xlglob.c'
/* xlglobals - xlisp global variables */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
/* symbols */
NODE *true = NIL, *s_dot = NIL;
NODE *s_quote = NIL, *s_function = NIL;
NODE *s_bquote = NIL, *s_comma = NIL, *s_comat = NIL;
NODE *s_evalhook = NIL, *s_applyhook = NIL;
NODE *s_lambda = NIL, *s_macro = NIL;
NODE *s_stdin = NIL, *s_stdout = NIL, *s_rtable = NIL;
NODE *s_tracenable = NIL, *s_tlimit = NIL, *s_breakenable = NIL;
NODE *s_car = NIL, *s_cdr = NIL, *s_nth = NIL;
NODE *s_get = NIL, *s_svalue = NIL, *s_splist = NIL, *s_aref = NIL;
NODE *s_eql = NIL, *k_test = NIL, *k_tnot = NIL;
NODE *k_wspace = NIL, *k_const = NIL, *k_nmacro = NIL, *k_tmacro = NIL;
NODE *k_optional = NIL, *k_rest = NIL, *k_aux = NIL;
NODE *a_subr = NIL, *a_fsubr = NIL;
NODE *a_list = NIL, *a_sym = NIL, *a_int = NIL, *a_float = NIL;
NODE *a_str = NIL, *a_obj = NIL, *a_fptr = NIL, *a_vect;
NODE *obarray = NIL, *s_unbound = NIL;
/* evaluation variables */
NODE ***xlstack = NULL, ***xlstkbase = NULL, ***xlstktop = NULL;
NODE *xlenv = NIL;
/* exception handling variables */
CONTEXT *xlcontext = NULL; /* current exception handler */
NODE *xlvalue = NIL; /* exception value */
/* debugging variables */
int xldebug = 0; /* debug level */
int xltrace = -1; /* trace stack pointer */
NODE **trace_stack = NULL; /* trace stack */
int xlsample = 0; /* control character sample rate */
/* gensym variables */
char gsprefix[STRMAX+1] = { 'G',0 }; /* gensym prefix string */
int gsnumber = 1; /* gensym number */
/* i/o variables */
int prompt = TRUE; /* prompt flag */
int xlplevel = 0; /* paren nesting level */
int xlfsize = 0; /* flat size of current print call */
/* dynamic memory variables */
long total = 0L; /* total memory in use */
int anodes = 0; /* number of nodes to allocate */
int nnodes = 0; /* number of nodes allocated */
int nsegs = 0; /* number of segments allocated */
int nfree = 0; /* number of nodes free */
int gccalls = 0; /* number of gc calls */
struct segment *segs = NULL; /* list of allocated segments */
NODE *fnodes = NIL; /* list of free nodes */
/* object programming variables */
NODE *self = NIL, *class = NIL, *object = NIL;
NODE *new = NIL, *isnew = NIL, *msgcls = NIL, *msgclass = NIL;
/* general purpose string buffer */
char buf[STRMAX+1] = { 0 };
SHAR_EOF
fi # end of overwriting check
if test -f 'xlinit.c'
then
echo shar: will not over-write existing file "'xlinit.c'"
else
cat << \SHAR_EOF > 'xlinit.c'
/* xlinit.c - xlisp initialization module */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
/* external variables */
extern NODE *true,*s_dot;
extern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
extern NODE *s_lambda,*s_macro;
extern NODE *s_stdin,*s_stdout;
extern NODE *s_evalhook,*s_applyhook;
extern NODE *s_tracenable,*s_tlimit,*s_breakenable;
extern NODE *s_car,*s_cdr,*s_nth,*s_get,*s_svalue,*s_splist,*s_aref,*s_eql;
extern NODE *s_rtable,*k_wspace,*k_const,*k_nmacro,*k_tmacro;
extern NODE *k_test,*k_tnot,*k_optional,*k_rest,*k_aux;
extern NODE *a_subr,*a_fsubr;
extern NODE *a_list,*a_sym,*a_int,*a_float,*a_str,*a_obj,*a_fptr,*a_vect;
extern struct fdef ftab[];
/* xlinit - xlisp initialization routine */
xlinit()
{
struct fdef *fptr;
NODE *sym;
/* initialize xlisp (must be in this order) */
xlminit(); /* initialize xldmem.c */
xlsinit(); /* initialize xlsym.c */
xldinit(); /* initialize xldbug.c */
xloinit(); /* initialize xlobj.c */
/* enter the builtin functions */
for (fptr = ftab; fptr->f_name; fptr++)
xlsubr(fptr->f_name,fptr->f_type,fptr->f_fcn);
/* enter operating system specific functions */
osfinit();
/* enter the 't' symbol */
true = xlsenter("T");
setvalue(true,true);
/* enter some important symbols */
s_dot = xlsenter(".");
s_quote = xlsenter("QUOTE");
s_function = xlsenter("FUNCTION");
s_bquote = xlsenter("BACKQUOTE");
s_comma = xlsenter("COMMA");
s_comat = xlsenter("COMMA-AT");
s_lambda = xlsenter("LAMBDA");
s_macro = xlsenter("MACRO");
s_eql = xlsenter("EQL");
/* enter setf place specifiers */
s_car = xlsenter("CAR");
s_cdr = xlsenter("CDR");
s_nth = xlsenter("NTH");
s_get = xlsenter("GET");
s_svalue = xlsenter("SYMBOL-VALUE");
s_splist = xlsenter("SYMBOL-PLIST");
s_aref = xlsenter("AREF");
/* enter the readtable variable and keywords */
s_rtable = xlsenter("*READTABLE*");
k_wspace = xlsenter(":WHITE-SPACE");
k_const = xlsenter(":CONSTITUENT");
k_nmacro = xlsenter(":NMACRO");
k_tmacro = xlsenter(":TMACRO");
xlrinit();
/* enter parameter list keywords */
k_test = xlsenter(":TEST");
k_tnot = xlsenter(":TEST-NOT");
/* enter lambda list keywords */
k_optional = xlsenter("&OPTIONAL");
k_rest = xlsenter("&REST");
k_aux = xlsenter("&AUX");
/* enter *standard-input* and *standard-output* */
s_stdin = xlsenter("*STANDARD-INPUT*");
setvalue(s_stdin,cvfile(stdin));
s_stdout = xlsenter("*STANDARD-OUTPUT*");
setvalue(s_stdout,cvfile(stdout));
/* enter the eval and apply hook variables */
s_evalhook = xlsenter("*EVALHOOK*");
setvalue(s_evalhook,NIL);
s_applyhook = xlsenter("*APPLYHOOK*");
setvalue(s_applyhook,NIL);
/* enter the error traceback and the error break enable flags */
s_tracenable = xlsenter("*TRACENABLE*");
setvalue(s_tracenable,NIL);
s_tlimit = xlsenter("*TRACELIMIT*");
setvalue(s_tlimit,NIL);
s_breakenable = xlsenter("*BREAKENABLE*");
setvalue(s_breakenable,true);
/* enter a copyright notice into the oblist */
sym = xlsenter("**Copyright-1985-by-David-Betz**");
setvalue(sym,true);
/* enter type names */
a_subr = xlsenter(":SUBR");
a_fsubr = xlsenter(":FSUBR");
a_list = xlsenter(":CONS");
a_sym = xlsenter(":SYMBOL");
a_int = xlsenter(":FIXNUM");
a_float = xlsenter(":FLONUM");
a_str = xlsenter(":STRING");
a_obj = xlsenter(":OBJECT");
a_fptr = xlsenter(":FILE");
a_vect = xlsenter(":ARRAY");
}
SHAR_EOF
fi # end of overwriting check
if test -f 'xlio.c'
then
echo shar: will not over-write existing file "'xlio.c'"
else
cat << \SHAR_EOF > 'xlio.c'
/* xlio - xlisp i/o routines */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
#ifdef MEGAMAX
overlay "io"
#endif
/* external variables */
extern NODE ***xlstack;
extern NODE *s_stdin,*s_unbound;
extern int xlfsize;
extern int xlplevel;
extern int xldebug;
extern int prompt;
extern char buf[];
/* xlgetc - get a character from a file or stream */
int xlgetc(fptr)
NODE *fptr;
{
NODE *lptr,*cptr;
FILE *fp;
int ch;
/* check for input from nil */
if (fptr == NIL)
ch = EOF;
/* otherwise, check for input from a stream */
else if (consp(fptr)) {
if ((lptr = car(fptr)) == NIL)
ch = EOF;
else {
if (!consp(lptr) ||
(cptr = car(lptr)) == NIL || !fixp(cptr))
xlfail("bad stream");
if (rplaca(fptr,cdr(lptr)) == NIL)
rplacd(fptr,NIL);
ch = getfixnum(cptr);
}
}
/* otherwise, check for a buffered file character */
else if (ch = getsavech(fptr))
setsavech(fptr,0);
/* otherwise, get a new character */
else {
/* get the file pointer */
fp = getfile(fptr);
/* prompt if necessary */
if (prompt && fp == stdin) {
/* print the debug level */
if (xldebug)
{ sprintf(buf,"%d:",xldebug); stdputstr(buf); }
/* print the nesting level */
if (xlplevel > 0)
{ sprintf(buf,"%d",xlplevel); stdputstr(buf); }
/* print the prompt */
stdputstr("> ");
prompt = FALSE;
}
/* get the character */
if (((ch = osgetc(fp)) == '\n' || ch == EOF) && fp == stdin)
prompt = TRUE;
}
/* return the character */
return (ch);
}
/* docommand - create a nested MS-DOS shell */
#ifdef SYSTEM
docommand()
{
stdputstr("\n[ creating a nested command processor ]\n");
system("COMMAND");
stdputstr("[ returning to XLISP ]\n");
}
#endif
/* xlpeek - peek at a character from a file or stream */
int xlpeek(fptr)
NODE *fptr;
{
NODE *lptr,*cptr;
int ch;
/* check for input from nil */
if (fptr == NIL)
ch = EOF;
/* otherwise, check for input from a stream */
else if (consp(fptr)) {
if ((lptr = car(fptr)) == NIL)
ch = EOF;
else {
if (!consp(lptr) ||
(cptr = car(lptr)) == NIL || !fixp(cptr))
xlfail("bad stream");
ch = getfixnum(cptr);
}
}
/* otherwise, get the next file character and save it */
else
setsavech(fptr,ch = xlgetc(fptr));
/* return the character */
return (ch);
}
/* xlputc - put a character to a file or stream */
xlputc(fptr,ch)
NODE *fptr; int ch;
{
NODE ***oldstk,*lptr;
/* count the character */
xlfsize++;
/* check for output to nil */
if (fptr == NIL)
;
/* otherwise, check for output to a stream */
else if (consp(fptr)) {
oldstk = xlsave(&lptr,(NODE **)NULL);
lptr = consa(NIL);
rplaca(lptr,cvfixnum((FIXNUM)ch));
if (cdr(fptr))
rplacd(cdr(fptr),lptr);
else
rplaca(fptr,lptr);
rplacd(fptr,lptr);
xlstack = oldstk;
}
/* otherwise, output the character to a file */
else
osputc(ch,getfile(fptr));
}
/* xlflush - flush the input buffer */
int xlflush()
{
if (!prompt)
while (xlgetc(getvalue(s_stdin)) != '\n')
;
}
SHAR_EOF
fi # end of overwriting check
if test -f 'xlisp.c'
then
echo shar: will not over-write existing file "'xlisp.c'"
else
cat << \SHAR_EOF > 'xlisp.c'
/* xlisp - a small implementation of lisp with object-oriented programming */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
/* define the banner line string */
#define BANNER "XLISP version 1.6, Copyright (c) 1985, by David Betz"
/* external variables */
extern NODE *s_stdin,*s_stdout;
extern NODE *s_evalhook,*s_applyhook;
extern int xldebug;
extern NODE *true;
/* main - the main routine */
main(argc,argv)
int argc; char *argv[];
{
CONTEXT cntxt;
NODE *expr;
int i;
/* initialize and print the banner line */
osinit(BANNER);
/* setup initialization error handler */
xlbegin(&cntxt,CF_TOPLEVEL|CF_ERROR,(NODE *) 1);
if (setjmp(cntxt.c_jmpbuf)) {
printf("fatal initialization error\n");
osfinish();
exit(1);
}
/* initialize xlisp */
xlinit();
xlend(&cntxt);
/* reset the error handler */
xlbegin(&cntxt,CF_TOPLEVEL|CF_ERROR,true);
/* load "init.lsp" */
if (setjmp(cntxt.c_jmpbuf) == 0)
xlload("init.lsp",FALSE,FALSE);
/* load any files mentioned on the command line */
#ifndef MEGAMAX
if (setjmp(cntxt.c_jmpbuf) == 0)
for (i = 1; i < argc; i++)
if (!xlload(argv[i],TRUE,FALSE))
xlfail("can't load file");
#endif
/* create a new stack frame */
xlsave(&expr,(NODE **)NULL);
/* main command processing loop */
while (TRUE) {
/* setup the error return */
if (i = setjmp(cntxt.c_jmpbuf)) {
if (i == CF_TOPLEVEL)
stdputstr("[ back to the top level ]\n");
setvalue(s_evalhook,NIL);
setvalue(s_applyhook,NIL);
xldebug = 0;
xlflush();
}
/* read an expression */
if (!xlread(getvalue(s_stdin),&expr,FALSE))
break;
/* evaluate the expression */
expr = xleval(expr);
/* print it */
stdprint(expr);
}
xlend(&cntxt);
osfinish ();
exit (0);
}
/* stdprint - print to standard output */
stdprint(expr)
NODE *expr;
{
xlprint(getvalue(s_stdout),expr,TRUE);
xlterpri(getvalue(s_stdout));
}
/* stdputstr - print a string to standard output */
stdputstr(str)
char *str;
{
xlputstr(getvalue(s_stdout),str);
}
SHAR_EOF
fi # end of overwriting check
if test -f 'xljump.c'
then
echo shar: will not over-write existing file "'xljump.c'"
else
cat << \SHAR_EOF > 'xljump.c'
/* xljump - execution context routines */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
/* external variables */
extern CONTEXT *xlcontext;
extern NODE *xlvalue;
extern NODE ***xlstack,*xlenv;
extern int xltrace,xldebug;
/* xlbegin - beginning of an execution context */
xlbegin(cptr,flags,expr)
CONTEXT *cptr; int flags; NODE *expr;
{
cptr->c_flags = flags;
cptr->c_expr = expr;
cptr->c_xlstack = xlstack;
cptr->c_xlenv = xlenv;
cptr->c_xltrace = xltrace;
cptr->c_xlcontext = xlcontext;
xlcontext = cptr;
}
/* xlend - end of an execution context */
xlend(cptr)
CONTEXT *cptr;
{
xlcontext = cptr->c_xlcontext;
}
/* xljump - jump to a saved execution context */
xljump(cptr,type,val)
CONTEXT *cptr; int type; NODE *val;
{
/* restore the state */
xlcontext = cptr;
xlstack = xlcontext->c_xlstack;
xlenv = xlcontext->c_xlenv;
xltrace = xlcontext->c_xltrace;
xlvalue = val;
/* call the handler */
longjmp(xlcontext->c_jmpbuf,type);
}
/* xltoplevel - go back to the top level */
xltoplevel()
{
findtarget(CF_TOPLEVEL,"no top level");
}
/* xlcleanup - clean-up after an error */
xlcleanup()
{
findtarget(CF_CLEANUP,"not in a break loop");
}
/* xlcontinue - continue from an error */
xlcontinue()
{
findtarget(CF_CONTINUE,"not in a break loop");
}
/* xlgo - go to a label */
xlgo(label)
NODE *label;
{
CONTEXT *cptr;
NODE *p;
/* find a tagbody context */
for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
if (cptr->c_flags & CF_GO)
for (p = cptr->c_expr; consp(p); p = cdr(p))
if (car(p) == label)
xljump(cptr,CF_GO,p);
xlfail("no target for GO");
}
/* xlreturn - return from a block */
xlreturn(val)
NODE *val;
{
CONTEXT *cptr;
/* find a block context */
for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
if (cptr->c_flags & CF_RETURN)
xljump(cptr,CF_RETURN,val);
xlfail("no target for RETURN");
}
/* xlthrow - throw to a catch */
xlthrow(tag,val)
NODE *tag,*val;
{
CONTEXT *cptr;
/* find a catch context */
for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
if ((cptr->c_flags & CF_THROW) && cptr->c_expr == tag)
xljump(cptr,CF_THROW,val);
xlfail("no target for THROW");
}
/* xlsignal - signal an error */
xlsignal(emsg,arg)
char *emsg; NODE *arg;
{
CONTEXT *cptr;
/* find an error catcher */
for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
if (cptr->c_flags & CF_ERROR) {
if (cptr->c_expr && emsg)
xlerrprint("error",NULL,emsg,arg);
xljump(cptr,CF_ERROR,NIL);
}
xlfail("no target for error");
}
/* findtarget - find a target context frame */
LOCAL findtarget(flag,error)
int flag; char *error;
{
CONTEXT *cptr;
/* find a block context */
for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
if (cptr->c_flags & flag)
xljump(cptr,flag,NIL);
xlabort(error);
}
SHAR_EOF
fi # end of overwriting check
if test -f 'xllist.c'
then
echo shar: will not over-write existing file "'xllist.c'"
else
cat << \SHAR_EOF > 'xllist.c'
/* xllist - xlisp built-in list functions */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
#ifdef MEGAMAX
overlay "overflow"
#endif
/* external variables */
extern NODE ***xlstack;
extern NODE *s_unbound;
extern NODE *true;
/* external routines */
extern int eq(),eql(),equal();
/* forward declarations */
FORWARD NODE *cxr();
FORWARD NODE *nth(),*assoc();
FORWARD NODE *subst(),*sublis(),*map();
FORWARD NODE *cequal();
/* cxr functions */
NODE *xcar(args) NODE *args; { return (cxr(args,"a")); }
NODE *xcdr(args) NODE *args; { return (cxr(args,"d")); }
/* cxxr functions */
NODE *xcaar(args) NODE *args; { return (cxr(args,"aa")); }
NODE *xcadr(args) NODE *args; { return (cxr(args,"da")); }
NODE *xcdar(args) NODE *args; { return (cxr(args,"ad")); }
NODE *xcddr(args) NODE *args; { return (cxr(args,"dd")); }
/* cxxxr functions */
NODE *xcaaar(args) NODE *args; { return (cxr(args,"aaa")); }
NODE *xcaadr(args) NODE *args; { return (cxr(args,"daa")); }
NODE *xcadar(args) NODE *args; { return (cxr(args,"ada")); }
NODE *xcaddr(args) NODE *args; { return (cxr(args,"dda")); }
NODE *xcdaar(args) NODE *args; { return (cxr(args,"aad")); }
NODE *xcdadr(args) NODE *args; { return (cxr(args,"dad")); }
NODE *xcddar(args) NODE *args; { return (cxr(args,"add")); }
NODE *xcdddr(args) NODE *args; { return (cxr(args,"ddd")); }
/* cxxxxr functions */
NODE *xcaaaar(args) NODE *args; { return (cxr(args,"aaaa")); }
NODE *xcaaadr(args) NODE *args; { return (cxr(args,"daaa")); }
NODE *xcaadar(args) NODE *args; { return (cxr(args,"adaa")); }
NODE *xcaaddr(args) NODE *args; { return (cxr(args,"ddaa")); }
NODE *xcadaar(args) NODE *args; { return (cxr(args,"aada")); }
NODE *xcadadr(args) NODE *args; { return (cxr(args,"dada")); }
NODE *xcaddar(args) NODE *args; { return (cxr(args,"adda")); }
NODE *xcadddr(args) NODE *args; { return (cxr(args,"ddda")); }
NODE *xcdaaar(args) NODE *args; { return (cxr(args,"aaad")); }
NODE *xcdaadr(args) NODE *args; { return (cxr(args,"daad")); }
NODE *xcdadar(args) NODE *args; { return (cxr(args,"adad")); }
NODE *xcdaddr(args) NODE *args; { return (cxr(args,"ddad")); }
NODE *xcddaar(args) NODE *args; { return (cxr(args,"aadd")); }
NODE *xcddadr(args) NODE *args; { return (cxr(args,"dadd")); }
NODE *xcdddar(args) NODE *args; { return (cxr(args,"addd")); }
NODE *xcddddr(args) NODE *args; { return (cxr(args,"dddd")); }
/* cxr - common car/cdr routine */
LOCAL NODE *cxr(args,adstr)
NODE *args; char *adstr;
{
NODE *list;
/* get the list */
list = xlmatch(LIST,&args);
xllastarg(args);
/* perform the car/cdr operations */
while (*adstr && consp(list))
list = (*adstr++ == 'a' ? car(list) : cdr(list));
/* make sure the operation succeeded */
if (*adstr && list)
xlfail("bad argument");
/* return the result */
return (list);
}
/* xcons - construct a new list cell */
NODE *xcons(args)
NODE *args;
{
NODE *arg1,*arg2;
/* get the two arguments */
arg1 = xlarg(&args);
arg2 = xlarg(&args);
xllastarg(args);
/* construct a new list element */
return (cons(arg1,arg2));
}
/* xlist - built a list of the arguments */
NODE *xlist(args)
NODE *args;
{
NODE ***oldstk,*arg,*list,*val,*last;
NODE *lptr = NIL;
/* create a new stack frame */
oldstk = xlsave(&arg,&list,&val,(NODE **)NULL);
/* initialize */
arg = args;
/* evaluate and append each argument */
for (last = NIL; arg; last = lptr) {
/* evaluate the next argument */
val = xlarg(&arg);
/* append this argument to the end of the list */
lptr = consa(val);
if (last == NIL)
list = lptr;
else
rplacd(last,lptr);
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the list */
return (list);
}
/* xappend - built-in function append */
NODE *xappend(args)
NODE *args;
{
NODE ***oldstk,*arg,*list,*last,*val,*lptr;
/* create a new stack frame */
oldstk = xlsave(&arg,&list,&last,&val,(NODE **)NULL);
/* initialize */
arg = args;
/* evaluate and append each argument */
while (arg) {
/* evaluate the next argument */
list = xlmatch(LIST,&arg);
/* append each element of this list to the result list */
while (consp(list)) {
/* append this element */
lptr = consa(car(list));
if (last == NIL)
val = lptr;
else
rplacd(last,lptr);
/* save the new last element */
last = lptr;
/* move to the next element */
list = cdr(list);
}
}
/* restore previous stack frame */
xlstack = oldstk;
/* return the list */
return (val);
}
/* xreverse - built-in function reverse */
NODE *xreverse(args)
NODE *args;
{
NODE ***oldstk,*list,*val;
/* create a new stack frame */
oldstk = xlsave(&list,&val,(NODE **)NULL);
/* get the list to reverse */
list = xlmatch(LIST,&args);
xllastarg(args);
/* append each element of this list to the result list */
while (consp(list)) {
/* append this element */
val = cons(car(list),val);
/* move to the next element */
list = cdr(list);
}
/* restore previous stack frame */
xlstack = oldstk;
/* return the list */
return (val);
}
/* xlast - return the last cons of a list */
NODE *xlast(args)
NODE *args;
{
NODE *list;
/* get the list */
list = xlmatch(LIST,&args);
xllastarg(args);
/* find the last cons */
while (consp(list) && cdr(list))
list = cdr(list);
/* return the last element */
return (list);
}
/* xmember - built-in function 'member' */
NODE *xmember(args)
NODE *args;
{
NODE ***oldstk,*x,*list,*fcn,*val;
int tresult;
/* create a new stack frame */
oldstk = xlsave(&x,&list,&fcn,(NODE **)NULL);
/* get the expression to look for and the list */
x = xlarg(&args);
list = xlmatch(LIST,&args);
xltest(&fcn,&tresult,&args);
xllastarg(args);
/* look for the expression */
for (val = NIL; consp(list); list = cdr(list))
if (dotest(x,car(list),fcn) == tresult) {
val = list;
break;
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result */
return (val);
}
/* xassoc - built-in function 'assoc' */
NODE *xassoc(args)
NODE *args;
{
NODE ***oldstk,*x,*alist,*fcn,*pair,*val;
int tresult;
/* create a new stack frame */
oldstk = xlsave(&x,&alist,&fcn,(NODE **)NULL);
/* get the expression to look for and the association list */
x = xlarg(&args);
alist = xlmatch(LIST,&args);
xltest(&fcn,&tresult,&args);
xllastarg(args);
/* look for the expression */
for (val = NIL; consp(alist); alist = cdr(alist))
if ((pair = car(alist)) && consp(pair))
if (dotest(x,car(pair),fcn) == tresult) {
val = pair;
break;
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result */
return (val);
}
/* xsubst - substitute one expression for another */
NODE *xsubst(args)
NODE *args;
{
NODE ***oldstk,*to,*from,*expr,*fcn,*val;
int tresult;
/* create a new stack frame */
oldstk = xlsave(&to,&from,&expr,&fcn,(NODE **)NULL);
/* get the to value, the from value and the expression */
to = xlarg(&args);
from = xlarg(&args);
expr = xlarg(&args);
xltest(&fcn,&tresult,&args);
xllastarg(args);
/* do the substitution */
val = subst(to,from,expr,fcn,tresult);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result */
return (val);
}
/* subst - substitute one expression for another */
LOCAL NODE *subst(to,from,expr,fcn,tresult)
NODE *to,*from,*expr,*fcn; int tresult;
{
NODE ***oldstk,*carval,*cdrval,*val;
if (dotest(expr,from,fcn) == tresult)
val = to;
else if (consp(expr)) {
oldstk = xlsave(&carval,&cdrval,(NODE **)NULL);
carval = subst(to,from,car(expr),fcn,tresult);
cdrval = subst(to,from,cdr(expr),fcn,tresult);
val = cons(carval,cdrval);
xlstack = oldstk;
}
else
val = expr;
return (val);
}
/* xsublis - substitute using an association list */
NODE *xsublis(args)
NODE *args;
{
NODE ***oldstk,*alist,*expr,*fcn,*val;
int tresult;
/* create a new stack frame */
oldstk = xlsave(&alist,&expr,&fcn,(NODE **)NULL);
/* get the assocation list and the expression */
alist = xlmatch(LIST,&args);
expr = xlarg(&args);
xltest(&fcn,&tresult,&args);
xllastarg(args);
/* do the substitution */
val = sublis(alist,expr,fcn,tresult);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result */
return (val);
}
/* sublis - substitute using an association list */
LOCAL NODE *sublis(alist,expr,fcn,tresult)
NODE *alist,*expr,*fcn; int tresult;
{
NODE ***oldstk,*carval,*cdrval,*val;
if (val = assoc(expr,alist,fcn,tresult))
val = cdr(val);
else if (consp(expr)) {
oldstk = xlsave(&carval,&cdrval,(NODE **)NULL);
carval = sublis(alist,car(expr),fcn,tresult);
cdrval = sublis(alist,cdr(expr),fcn,tresult);
val = cons(carval,cdrval);
xlstack = oldstk;
}
else
val = expr;
return (val);
}
/* assoc - find a pair in an association list */
LOCAL NODE *assoc(expr,alist,fcn,tresult)
NODE *expr,*alist,*fcn; int tresult;
{
NODE *pair;
for (; consp(alist); alist = cdr(alist))
if ((pair = car(alist)) && consp(pair))
if (dotest(expr,car(pair),fcn) == tresult)
return (pair);
return (NIL);
}
/* xremove - built-in function 'remove' */
NODE *xremove(args)
NODE *args;
{
NODE ***oldstk,*x,*list,*fcn,*val,*p;
NODE *last = NIL;
int tresult;
/* create a new stack frame */
oldstk = xlsave(&x,&list,&fcn,&val,(NODE **)NULL);
/* get the expression to remove and the list */
x = xlarg(&args);
list = xlmatch(LIST,&args);
xltest(&fcn,&tresult,&args);
xllastarg(args);
/* remove matches */
while (consp(list)) {
/* check to see if this element should be deleted */
if (dotest(x,car(list),fcn) != tresult) {
p = consa(car(list));
if (val) rplacd(last,p);
else val = p;
last = p;
}
/* move to the next element */
list = cdr(list);
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the updated list */
return (val);
}
/* dotest - call a test function */
int dotest(arg1,arg2,fcn)
NODE *arg1,*arg2,*fcn;
{
NODE ***oldstk,*args,*val;
/* create a new stack frame */
oldstk = xlsave(&args,(NODE **)NULL);
/* build an argument list */
args = consa(arg1);
rplacd(args,consa(arg2));
/* apply the test function */
val = xlapply(fcn,args);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result of the test */
return (val != NIL);
}
/* xnth - return the nth element of a list */
NODE *xnth(args)
NODE *args;
{
return (nth(args,TRUE));
}
/* xnthcdr - return the nth cdr of a list */
NODE *xnthcdr(args)
NODE *args;
{
return (nth(args,FALSE));
}
/* nth - internal nth function */
LOCAL NODE *nth(args,carflag)
NODE *args; int carflag;
{
NODE *list;
int n;
/* get n and the list */
if ((n = getfixnum(xlmatch(INT,&args))) < 0)
xlfail("bad argument");
if ((list = xlmatch(LIST,&args)) == NIL)
xlfail("bad argument");
xllastarg(args);
/* find the nth element */
while (consp(list) && n--)
list = cdr(list);
/* return the list beginning at the nth element */
return (carflag && consp(list) ? car(list) : list);
}
/* xlength - return the length of a list or string */
NODE *xlength(args)
NODE *args;
{
NODE *arg;
int n;
/* get the list or string */
arg = xlarg(&args);
xllastarg(args);
/* find the length of a list */
if (listp(arg))
for (n = 0; consp(arg); n++)
arg = cdr(arg);
/* find the length of a string */
else if (stringp(arg))
n = strlen(getstring(arg));
/* find the length of a vector */
else if (vectorp(arg))
n = getsize(arg);
/* otherwise, bad argument type */
else
xlerror("bad argument type",arg);
/* return the length */
return (cvfixnum((FIXNUM)n));
}
/* xmapc - built-in function 'mapc' */
NODE *xmapc(args)
NODE *args;
{
return (map(args,TRUE,FALSE));
}
/* xmapcar - built-in function 'mapcar' */
NODE *xmapcar(args)
NODE *args;
{
return (map(args,TRUE,TRUE));
}
/* xmapl - built-in function 'mapl' */
NODE *xmapl(args)
NODE *args;
{
return (map(args,FALSE,FALSE));
}
/* xmaplist - built-in function 'maplist' */
NODE *xmaplist(args)
NODE *args;
{
return (map(args,FALSE,TRUE));
}
/* map - internal mapping function */
LOCAL NODE *map(args,carflag,valflag)
NODE *args; int carflag,valflag;
{
NODE ***oldstk,*fcn,*lists,*arglist,*val,*p,*x,*y;
NODE *last = NIL;
/* create a new stack frame */
oldstk = xlsave(&fcn,&lists,&arglist,&val,(NODE **)NULL);
/* get the function to apply and the first list */
fcn = xlarg(&args);
lists = xlmatch(LIST,&args);
/* save the first list if not saving function values */
if (!valflag)
val = lists;
/* set up the list of argument lists */
lists = consa(lists);
/* get the remaining argument lists */
while (args) {
lists = consd(lists);
rplaca(lists,xlmatch(LIST,&args));
}
/* if the function is a symbol, get its value */
if (symbolp(fcn))
fcn = xleval(fcn);
/* loop through each of the argument lists */
for (;;) {
/* build an argument list from the sublists */
arglist = NIL;
for (x = lists; x && (y = car(x)) && consp(y); x = cdr(x)) {
arglist = consd(arglist);
rplaca(arglist,carflag ? car(y) : y);
rplaca(x,cdr(y));
}
/* quit if any of the lists were empty */
if (x) break;
/* apply the function to the arguments */
if (valflag) {
p = consa(NIL);
if (val) rplacd(last,p);
else val = p;
rplaca(p,xlapply(fcn,arglist));
last = p;
}
else
xlapply(fcn,arglist);
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the last test expression value */
return (val);
}
/* xrplca - replace the car of a list node */
NODE *xrplca(args)
NODE *args;
{
NODE *list,*newcar;
/* get the list and the new car */
if ((list = xlmatch(LIST,&args)) == NIL)
xlfail("bad argument");
newcar = xlarg(&args);
xllastarg(args);
/* replace the car */
rplaca(list,newcar);
/* return the list node that was modified */
return (list);
}
/* xrplcd - replace the cdr of a list node */
NODE *xrplcd(args)
NODE *args;
{
NODE *list,*newcdr;
/* get the list and the new cdr */
if ((list = xlmatch(LIST,&args)) == NIL)
xlfail("bad argument");
newcdr = xlarg(&args);
xllastarg(args);
/* replace the cdr */
rplacd(list,newcdr);
/* return the list node that was modified */
return (list);
}
/* xnconc - destructively append lists */
NODE *xnconc(args)
NODE *args;
{
NODE *list,*val;
NODE *last = NIL;
/* concatenate each argument */
for (val = NIL; args; ) {
/* concatenate this list */
if (list = xlmatch(LIST,&args)) {
/* check for this being the first non-empty list */
if (val)
rplacd(last,list);
else
val = list;
/* find the end of the list */
while (consp(cdr(list)))
list = cdr(list);
/* save the new last element */
last = list;
}
}
/* return the list */
return (val);
}
/* xdelete - built-in function 'delete' */
NODE *xdelete(args)
NODE *args;
{
NODE ***oldstk,*x,*list,*fcn,*last,*val;
int tresult;
/* create a new stack frame */
oldstk = xlsave(&x,&list,&fcn,(NODE **)NULL);
/* get the expression to delete and the list */
x = xlarg(&args);
list = xlmatch(LIST,&args);
xltest(&fcn,&tresult,&args);
xllastarg(args);
/* delete leading matches */
while (consp(list)) {
if (dotest(x,car(list),fcn) != tresult)
break;
list = cdr(list);
}
val = last = list;
/* delete embedded matches */
if (consp(list)) {
/* skip the first non-matching element */
list = cdr(list);
/* look for embedded matches */
while (consp(list)) {
/* check to see if this element should be deleted */
if (dotest(x,car(list),fcn) == tresult)
rplacd(last,cdr(list));
else
last = list;
/* move to the next element */
list = cdr(list);
}
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the updated list */
return (val);
}
/* xatom - is this an atom? */
NODE *xatom(args)
NODE *args;
{
NODE *arg;
arg = xlarg(&args);
xllastarg(args);
return (atom(arg) ? true : NIL);
}
/* xsymbolp - is this an symbol? */
NODE *xsymbolp(args)
NODE *args;
{
NODE *arg;
arg = xlarg(&args);
xllastarg(args);
return (arg == NIL || symbolp(arg) ? true : NIL);
}
/* xnumberp - is this a number? */
NODE *xnumberp(args)
NODE *args;
{
NODE *arg;
arg = xlarg(&args);
xllastarg(args);
return (fixp(arg) || floatp(arg) ? true : NIL);
}
/* xboundp - is this a value bound to this symbol? */
NODE *xboundp(args)
NODE *args;
{
NODE *sym;
sym = xlmatch(SYM,&args);
xllastarg(args);
return (getvalue(sym) == s_unbound ? NIL : true);
}
/* xnull - is this null? */
NODE *xnull(args)
NODE *args;
{
NODE *arg;
arg = xlarg(&args);
xllastarg(args);
return (null(arg) ? true : NIL);
}
/* xlistp - is this a list? */
NODE *xlistp(args)
NODE *args;
{
NODE *arg;
arg = xlarg(&args);
xllastarg(args);
return (listp(arg) ? true : NIL);
}
/* xconsp - is this a cons? */
NODE *xconsp(args)
NODE *args;
{
NODE *arg;
arg = xlarg(&args);
xllastarg(args);
return (consp(arg) ? true : NIL);
}
/* xeq - are these equal? */
NODE *xeq(args)
NODE *args;
{
return (cequal(args,eq));
}
/* xeql - are these equal? */
NODE *xeql(args)
NODE *args;
{
return (cequal(args,eql));
}
/* xequal - are these equal? */
NODE *xequal(args)
NODE *args;
{
return (cequal(args,equal));
}
/* cequal - common eq/eql/equal function */
LOCAL NODE *cequal(args,fcn)
NODE *args; int (*fcn)();
{
NODE *arg1,*arg2;
/* get the two arguments */
arg1 = xlarg(&args);
arg2 = xlarg(&args);
xllastarg(args);
/* compare the arguments */
return ((*fcn)(arg1,arg2) ? true : NIL);
}
SHAR_EOF
fi # end of overwriting check
if test -f 'xlmath.c'
then
echo shar: will not over-write existing file "'xlmath.c'"
else
cat << \SHAR_EOF > 'xlmath.c'
/* xlmath - xlisp builtin arithmetic functions */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#ifdef MEGAMAX
#include <fmath.h>
overlay "math"
#else
#include <math.h>
#endif
/*
* Lattice's math.h include declarations for fabs, so must come before
* xlisp.h
*/
#include "xlisp.h"
/* external variables */
extern NODE *true;
/* forward declarations */
FORWARD NODE *unary();
FORWARD NODE *binary();
FORWARD NODE *predicate();
FORWARD NODE *compare();
/* xadd - builtin function for addition */
NODE *xadd(args)
NODE *args;
{
return (binary(args,'+'));
}
/* xsub - builtin function for subtraction */
NODE *xsub(args)
NODE *args;
{
return (binary(args,'-'));
}
/* xmul - builtin function for multiplication */
NODE *xmul(args)
NODE *args;
{
return (binary(args,'*'));
}
/* xdiv - builtin function for division */
NODE *xdiv(args)
NODE *args;
{
return (binary(args,'/'));
}
/* xrem - builtin function for remainder */
NODE *xrem(args)
NODE *args;
{
return (binary(args,'%'));
}
/* xmin - builtin function for minimum */
NODE *xmin(args)
NODE *args;
{
return (binary(args,'m'));
}
/* xmax - builtin function for maximum */
NODE *xmax(args)
NODE *args;
{
return (binary(args,'M'));
}
/* xexpt - built-in function 'expt' */
NODE *xexpt(args)
NODE *args;
{
return (binary(args,'E'));
}
/* xbitand - builtin function for bitwise and */
NODE *xbitand(args)
NODE *args;
{
return (binary(args,'&'));
}
/* xbitior - builtin function for bitwise inclusive or */
NODE *xbitior(args)
NODE *args;
{
return (binary(args,'|'));
}
/* xbitxor - builtin function for bitwise exclusive or */
NODE *xbitxor(args)
NODE *args;
{
return (binary(args,'^'));
}
/* binary - handle binary operations */
LOCAL NODE *binary(args,fcn)
NODE *args; int fcn;
{
FIXNUM ival,iarg;
FLONUM fval,farg;
NODE *arg;
int imode;
/* get the first argument */
arg = xlarg(&args);
/* set the type of the first argument */
if (fixp(arg)) {
ival = getfixnum(arg);
imode = TRUE;
}
else if (floatp(arg)) {
fval = getflonum(arg);
imode = FALSE;
}
else
xlerror("bad argument type",arg);
/* treat '-' with a single argument as a special case */
if (fcn == '-' && args == NIL)
if (imode)
ival = -ival;
else
fval = -fval;
/* handle each remaining argument */
while (args) {
/* get the next argument */
arg = xlarg(&args);
/* check its type */
if (fixp(arg))
if (imode) iarg = getfixnum(arg);
else farg = (FLONUM)getfixnum(arg);
else if (floatp(arg))
if (imode) { fval = (FLONUM)ival; farg = getflonum(arg); imode = FALSE; }
else farg = getflonum(arg);
else
xlerror("bad argument type",arg);
/* accumulate the result value */
if (imode)
switch (fcn) {
case '+': ival += iarg; break;
case '-': ival -= iarg; break;
case '*': ival *= iarg; break;
case '/': checkizero(iarg); ival /= iarg; break;
case '%': checkizero(iarg); ival %= iarg; break;
case 'M': if (iarg > ival) ival = iarg; break;
case 'm': if (iarg < ival) ival = iarg; break;
case '&': ival &= iarg; break;
case '|': ival |= iarg; break;
case '^': ival ^= iarg; break;
default: badiop();
}
else
switch (fcn) {
case '+': fval += farg; break;
case '-': fval -= farg; break;
case '*': fval *= farg; break;
case '/': checkfzero(farg); fval /= farg; break;
case 'M': if (farg > fval) fval = farg; break;
case 'm': if (farg < fval) fval = farg; break;
case 'E': fval = pow(fval,farg); break;
default: badfop();
}
}
/* return the result */
return (imode ? cvfixnum(ival) : cvflonum(fval));
}
/* checkizero - check for integer division by zero */
checkizero(iarg)
FIXNUM iarg;
{
if (iarg == 0)
xlfail("division by zero");
}
/* checkfzero - check for floating point division by zero */
checkfzero(farg)
FLONUM farg;
{
if (farg == 0.0)
xlfail("division by zero");
}
/* checkfneg - check for square root of a negative number */
checkfneg(farg)
FLONUM farg;
{
if (farg < 0.0)
xlfail("square root of a negative number");
}
/* xbitnot - bitwise not */
NODE *xbitnot(args)
NODE *args;
{
return (unary(args,'~'));
}
/* xabs - builtin function for absolute value */
NODE *xabs(args)
NODE *args;
{
return (unary(args,'A'));
}
/* xadd1 - builtin function for adding one */
NODE *xadd1(args)
NODE *args;
{
return (unary(args,'+'));
}
/* xsub1 - builtin function for subtracting one */
NODE *xsub1(args)
NODE *args;
{
return (unary(args,'-'));
}
/* xsin - built-in function 'sin' */
NODE *xsin(args)
NODE *args;
{
return (unary(args,'S'));
}
/* xcos - built-in function 'cos' */
NODE *xcos(args)
NODE *args;
{
return (unary(args,'C'));
}
/* xtan - built-in function 'tan' */
NODE *xtan(args)
NODE *args;
{
return (unary(args,'T'));
}
/* xexp - built-in function 'exp' */
NODE *xexp(args)
NODE *args;
{
return (unary(args,'E'));
}
/* xsqrt - built-in function 'sqrt' */
NODE *xsqrt(args)
NODE *args;
{
return (unary(args,'R'));
}
/* xfix - built-in function 'fix' */
NODE *xfix(args)
NODE *args;
{
return (unary(args,'I'));
}
/* xfloat - built-in function 'float' */
NODE *xfloat(args)
NODE *args;
{
return (unary(args,'F'));
}
/* xrand - built-in function 'random' */
NODE *xrand(args)
NODE *args;
{
return (unary(args,'R'));
}
/* unary - handle unary operations */
LOCAL NODE *unary(args,fcn)
NODE *args; int fcn;
{
FLONUM fval;
FIXNUM ival;
NODE *arg;
/* get the argument */
arg = xlarg(&args);
xllastarg(args);
/* check its type */
if (fixp(arg)) {
ival = getfixnum(arg);
switch (fcn) {
case '~': ival = ~ival; break;
case 'A': ival = abs(ival); break;
case '+': ival++; break;
case '-': ival--; break;
case 'I': break;
case 'F': return (cvflonum((FLONUM)ival));
case 'R': ival = (FIXNUM)osrand((int)ival); break;
default: badiop();
}
return (cvfixnum(ival));
}
else if (floatp(arg)) {
fval = getflonum(arg);
switch (fcn) {
case 'A': fval = fabs(fval); break;
case '+': fval += 1.0; break;
case '-': fval -= 1.0; break;
case 'S': fval = sin(fval); break;
case 'C': fval = cos(fval); break;
case 'T': fval = tan(fval); break;
case 'E': fval = exp(fval); break;
case 'R': checkfneg(fval); fval = sqrt(fval); break;
case 'I': return (cvfixnum((FIXNUM)fval));
case 'F': break;
default: badfop();
}
return (cvflonum(fval));
}
else
xlerror("bad argument type",arg);
/*NOTREACHED*/
}
/* xminusp - is this number negative? */
NODE *xminusp(args)
NODE *args;
{
return (predicate(args,'-'));
}
/* xzerop - is this number zero? */
NODE *xzerop(args)
NODE *args;
{
return (predicate(args,'Z'));
}
/* xplusp - is this number positive? */
NODE *xplusp(args)
NODE *args;
{
return (predicate(args,'+'));
}
/* xevenp - is this number even? */
NODE *xevenp(args)
NODE *args;
{
return (predicate(args,'E'));
}
/* xoddp - is this number odd? */
NODE *xoddp(args)
NODE *args;
{
return (predicate(args,'O'));
}
/* predicate - handle a predicate function */
LOCAL NODE *predicate(args,fcn)
NODE *args; int fcn;
{
FLONUM fval;
FIXNUM ival;
NODE *arg;
/* get the argument */
arg = xlarg(&args);
xllastarg(args);
/* check the argument type */
if (fixp(arg)) {
ival = getfixnum(arg);
switch (fcn) {
case '-': ival = (ival < 0); break;
case 'Z': ival = (ival == 0); break;
case '+': ival = (ival > 0); break;
case 'E': ival = ((ival & 1) == 0); break;
case 'O': ival = ((ival & 1) != 0); break;
default: badiop();
}
}
else if (floatp(arg)) {
fval = getflonum(arg);
switch (fcn) {
case '-': ival = (fval < 0); break;
case 'Z': ival = (fval == 0); break;
case '+': ival = (fval > 0); break;
default: badfop();
}
}
else
xlerror("bad argument type",arg);
/* return the result value */
return (ival ? true : NIL);
}
/* xlss - builtin function for < */
NODE *xlss(args)
NODE *args;
{
return (compare(args,'<'));
}
/* xleq - builtin function for <= */
NODE *xleq(args)
NODE *args;
{
return (compare(args,'L'));
}
/* equ - builtin function for = */
NODE *xequ(args)
NODE *args;
{
return (compare(args,'='));
}
/* xneq - builtin function for /= */
NODE *xneq(args)
NODE *args;
{
return (compare(args,'#'));
}
/* xgeq - builtin function for >= */
NODE *xgeq(args)
NODE *args;
{
return (compare(args,'G'));
}
/* xgtr - builtin function for > */
NODE *xgtr(args)
NODE *args;
{
return (compare(args,'>'));
}
/* compare - common compare function */
LOCAL NODE *compare(args,fcn)
NODE *args; int fcn;
{
NODE *arg1,*arg2;
FIXNUM icmp;
FLONUM fcmp;
int imode;
/* get the two arguments */
arg1 = xlarg(&args);
arg2 = xlarg(&args);
xllastarg(args);
/* do the compare */
if (stringp(arg1) && stringp(arg2)) {
icmp = strcmp(getstring(arg1),getstring(arg2));
imode = TRUE;
}
else if (fixp(arg1) && fixp(arg2)) {
icmp = getfixnum(arg1) - getfixnum(arg2);
imode = TRUE;
}
else if (floatp(arg1) && floatp(arg2)) {
fcmp = getflonum(arg1) - getflonum(arg2);
imode = FALSE;
}
else if (fixp(arg1) && floatp(arg2)) {
fcmp = (FLONUM)getfixnum(arg1) - getflonum(arg2);
imode = FALSE;
}
else if (floatp(arg1) && fixp(arg2)) {
fcmp = getflonum(arg1) - (FLONUM)getfixnum(arg2);
imode = FALSE;
}
else
xlfail("expecting strings, integers or floats");
/* compute result of the compare */
if (imode)
switch (fcn) {
case '<': icmp = (icmp < 0); break;
case 'L': icmp = (icmp <= 0); break;
case '=': icmp = (icmp == 0); break;
case '#': icmp = (icmp != 0); break;
case 'G': icmp = (icmp >= 0); break;
case '>': icmp = (icmp > 0); break;
}
else
switch (fcn) {
case '<': icmp = (fcmp < 0.0); break;
case 'L': icmp = (fcmp <= 0.0); break;
case '=': icmp = (fcmp == 0.0); break;
case '#': icmp = (fcmp != 0.0); break;
case 'G': icmp = (fcmp >= 0.0); break;
case '>': icmp = (fcmp > 0.0); break;
}
/* return the result */
return (icmp ? true : NIL);
}
/* badiop - bad integer operation */
LOCAL badiop()
{
xlfail("bad integer operation");
}
/* badfop - bad floating point operation */
LOCAL badfop()
{
xlfail("bad floating point operation");
}
SHAR_EOF
fi # end of overwriting check
# End of shell archive
exit 0