Article-I.D.: cwruecmp.1383
Posted: Sat Jan 18 15:03:26 1986
Date-Received: Mon, 20-Jan-86 05:23:26 EST
Organization: CWRU Dept. Computer Eng., Cleveland, OH
Lines: 2150
#!/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:
# xlftab2.c
# xlglob.c
# xlinit.c
# xlio.c
# xlisp.c
# xljump.c
# xllist.c
# xlmath.c
# This archive created: Sat Jan 18 14:32:27 1986
# By: Jwahar R. Bammi ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'xlftab2.c'" '(2614 characters)'
if test -f 'xlftab2.c'
then
echo shar: over-writing existing file "'xlftab2.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlftab2.c'
X/* xlftab2.c - xlisp function table - part 2 */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external functions */
Xextern NODE
X *xfix(),*xfloat(),
X *xadd(),*xsub(),*xmul(),*xdiv(),*xrem(),*xmin(),*xmax(),*xabs(),
X *xadd1(),*xsub1(),*xbitand(),*xbitior(),*xbitxor(),*xbitnot(),
X *xsin(),*xcos(),*xtan(),*xexpt(),*xexp(),*xsqrt(),
X *xlss(),*xleq(),*xequ(),*xneq(),*xgeq(),*xgtr(),
X *xstrcat(),*xsubstr(),*xstring(),*xchar(),
X *xread(),*xprint(),*xprin1(),*xprinc(),*xterpri(),
X *xflatsize(),*xflatc(),
X *xopeni(),*xopeno(),*xclose(),*xrdchar(),*xpkchar(),*xwrchar(),*xreadline(),
X *xload(),*xgc(),*xexpand(),*xalloc(),*xmem(),*xtype(),*xexit(),
X *xpeek(),*xpoke(),*xaddressof();
X
X/* the function table */
Xstruct fdef ftab2[] = {
X
X /* arithmetic functions */
X{ "TRUNCATE", SUBR, xfix },
X{ "FLOAT", SUBR, xfloat },
X{ "+", SUBR, xadd },
X{ "-", SUBR, xsub },
X{ "*", SUBR, xmul },
X{ "/", SUBR, xdiv },
X{ "1+", SUBR, xadd1 },
X{ "1-", SUBR, xsub1 },
X{ "REM", SUBR, xrem },
X{ "MIN", SUBR, xmin },
X{ "MAX", SUBR, xmax },
X{ "ABS", SUBR, xabs },
X{ "SIN", SUBR, xsin },
X{ "COS", SUBR, xcos },
X{ "TAN", SUBR, xtan },
X{ "EXPT", SUBR, xexpt },
X{ "EXP", SUBR, xexp },
X{ "SQRT", SUBR, xsqrt },
X
X /* bitwise logical functions */
X{ "BIT-AND", SUBR, xbitand },
X{ "BIT-IOR", SUBR, xbitior },
X{ "BIT-XOR", SUBR, xbitxor },
X{ "BIT-NOT", SUBR, xbitnot },
X
X /* numeric comparison functions */
X{ "<", SUBR, xlss },
X{ "<=", SUBR, xleq },
X{ "=", SUBR, xequ },
X{ "/=", SUBR, xneq },
X{ ">=", SUBR, xgeq },
X{ ">", SUBR, xgtr },
X
X /* string functions */
X{ "STRCAT", SUBR, xstrcat },
X{ "SUBSTR", SUBR, xsubstr },
X{ "STRING", SUBR, xstring },
X{ "CHAR", SUBR, xchar },
X
X /* I/O functions */
X{ "READ", SUBR, xread },
X{ "PRINT", SUBR, xprint },
X{ "PRIN1", SUBR, xprin1 },
X{ "PRINC", SUBR, xprinc },
X{ "TERPRI", SUBR, xterpri },
X{ "FLATSIZE", SUBR, xflatsize },
X{ "FLATC", SUBR, xflatc },
X
X /* file I/O functions */
X{ "OPENI", SUBR, xopeni },
X{ "OPENO", SUBR, xopeno },
X{ "CLOSE", SUBR, xclose },
X{ "READ-CHAR", SUBR, xrdchar },
X{ "PEEK-CHAR", SUBR, xpkchar },
X{ "WRITE-CHAR", SUBR, xwrchar },
X{ "READ-LINE", SUBR, xreadline },
X
X /* system functions */
X{ "LOAD", SUBR, xload },
X{ "GC", SUBR, xgc },
X{ "EXPAND", SUBR, xexpand },
X{ "ALLOC", SUBR, xalloc },
X{ "MEM", SUBR, xmem },
X{ "TYPE-OF", SUBR, xtype },
X{ "EXIT", SUBR, xexit },
X{ "PEEK", SUBR, xpeek },
X{ "POKE", SUBR, xpoke },
X{ "ADDRESS-OF", SUBR, xaddressof },
X
X{ 0 }
X};
SHAR_EOF
if test 2614 -ne "`wc -c 'xlftab2.c'`"
then
echo shar: error transmitting "'xlftab2.c'" '(should have been 2614 characters)'
fi
echo shar: extracting "'xlglob.c'" '(2197 characters)'
if test -f 'xlglob.c'
then
echo shar: over-writing existing file "'xlglob.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlglob.c'
X/* xlglobals - xlisp global variables */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* symbols */
XNODE *true = NIL;
XNODE *s_quote = NIL, *s_function = NIL;
XNODE *s_bquote = NIL, *s_comma = NIL, *s_comat = NIL;
XNODE *s_evalhook = NIL, *s_applyhook = NIL;
XNODE *s_lambda = NIL, *s_macro = NIL;
XNODE *s_stdin = NIL, *s_stdout = NIL;
XNODE *s_tracenable = NIL, *s_tlimit = NIL, *s_breakenable = NIL;
XNODE *s_car = NIL, *s_cdr = NIL;
XNODE *s_get = NIL, *s_svalue = NIL, *s_splist = NIL;
XNODE *s_eql = NIL, *k_test = NIL, *k_tnot = NIL;
XNODE *k_optional = NIL, *k_rest = NIL, *k_aux = NIL;
XNODE *a_subr = NIL, *a_fsubr = NIL;
XNODE *a_list = NIL, *a_sym = NIL, *a_int = NIL, *a_float = NIL;
XNODE *a_str = NIL, *a_obj = NIL, *a_fptr = NIL;
XNODE *oblist = NIL, *keylist = NIL, *s_unbound = NIL;
X
X/* evaluation variables */
XNODE *xlstack = NIL;
XNODE *xlenv = NIL;
X
X/* exception handling variables */
XCONTEXT *xlcontext = NULL; /* current exception handler */
XNODE *xlvalue = NIL; /* exception value */
X
X/* debugging variables */
Xint xldebug = 0; /* debug level */
Xint xltrace = -1; /* trace stack pointer */
XNODE **trace_stack = NULL; /* trace stack */
X
X/* gensym variables */
Xchar gsprefix[STRMAX+1] = { 'G',0 }; /* gensym prefix string */
Xint gsnumber = 1; /* gensym number */
X
X/* i/o variables */
Xint xlplevel = 0; /* prompt nesting level */
Xint xlfsize = 0; /* flat size of current print call */
Xint prompt = TRUE; /* input prompt flag */
X
X/* dynamic memory variables */
Xlong total = 0L; /* total memory in use */
Xint anodes = 0; /* number of nodes to allocate */
Xint nnodes = 0; /* number of nodes allocated */
Xint nsegs = 0; /* number of segments allocated */
Xint nfree = 0; /* number of nodes free */
Xint gccalls = 0; /* number of gc calls */
Xstruct segment *segs = NULL; /* list of allocated segments */
XNODE *fnodes = NIL; /* list of free nodes */
X
X/* object programming variables */
XNODE *self = NIL, *class = NIL, *object = NIL;
XNODE *new = NIL, *isnew = NIL, *msgcls = NIL, *msgclass = NIL;
Xint varcnt = 0;
X
X/* general purpose string buffer */
Xchar buf[STRMAX+1] = { 0 };
SHAR_EOF
if test 2197 -ne "`wc -c 'xlglob.c'`"
then
echo shar: error transmitting "'xlglob.c'" '(should have been 2197 characters)'
fi
echo shar: extracting "'xlinit.c'" '(3534 characters)'
if test -f 'xlinit.c'
then
echo shar: over-writing existing file "'xlinit.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlinit.c'
X/* xlinit.c - xlisp initialization module */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern NODE *true;
Xextern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
Xextern NODE *s_lambda,*s_macro;
Xextern NODE *s_stdin,*s_stdout;
Xextern NODE *s_evalhook,*s_applyhook;
Xextern NODE *s_tracenable,*s_tlimit,*s_breakenable;
Xextern NODE *s_car,*s_cdr,*s_get,*s_svalue,*s_splist,*s_eql;
Xextern NODE *k_test,*k_tnot,*k_optional,*k_rest,*k_aux;
Xextern NODE *a_subr,*a_fsubr;
Xextern NODE *a_list,*a_sym,*a_int,*a_float,*a_str,*a_obj,*a_fptr;
Xextern struct fdef ftab1[],ftab2[];
X
X/* xlinit - xlisp initialization routine */
Xxlinit()
X{
X struct fdef *fptr;
X NODE *sym;
X
X /* initialize xlisp (must be in this order) */
X xlminit(); /* initialize xldmem.c */
X xlsinit(); /* initialize xlsym.c */
X xldinit(); /* initialize xldbug.c */
X xloinit(); /* initialize xlobj.c */
X
X /* enter the builtin functions */
X for (fptr = ftab1; fptr->f_name; fptr++)
X xlsubr(fptr->f_name,fptr->f_type,fptr->f_fcn);
X for (fptr = ftab2; fptr->f_name; fptr++)
X xlsubr(fptr->f_name,fptr->f_type,fptr->f_fcn);
X#ifdef CPM68K
X xlginit();
X#endif
X#ifdef MEGAMAX
X macfinit();
X#endif
X
X /* enter the 't' symbol */
X true = xlsenter("T");
X true->n_symvalue = true;
X
X /* enter some important symbols */
X s_quote = xlsenter("QUOTE");
X s_function = xlsenter("FUNCTION");
X s_bquote = xlsenter("BACKQUOTE");
X s_comma = xlsenter("COMMA");
X s_comat = xlsenter("COMMA-AT");
X s_lambda = xlsenter("LAMBDA");
X s_macro = xlsenter("MACRO");
X s_eql = xlsenter("EQL");
X
X /* enter setf place specifiers */
X s_car = xlsenter("CAR");
X s_cdr = xlsenter("CDR");
X s_get = xlsenter("GET");
X s_svalue = xlsenter("SYMBOL-VALUE");
X s_splist = xlsenter("SYMBOL-PLIST");
X
X /* enter parameter list keywords */
X k_test = xlsenter(":TEST");
X k_tnot = xlsenter(":TEST-NOT");
X
X /* enter lambda list keywords */
X k_optional = xlsenter("&OPTIONAL");
X k_rest = xlsenter("&REST");
X k_aux = xlsenter("&AUX");
X
X /* enter *standard-input* and *standard-output* */
X s_stdin = xlsenter("*STANDARD-INPUT*");
X s_stdin->n_symvalue = newnode(FPTR);
X s_stdin->n_symvalue->n_fp = stdin;
X s_stdin->n_symvalue->n_savech = 0;
X s_stdout = xlsenter("*STANDARD-OUTPUT*");
X s_stdout->n_symvalue = newnode(FPTR);
X s_stdout->n_symvalue->n_fp = stdout;
X s_stdout->n_symvalue->n_savech = 0;
X
X /* enter the eval and apply hook variables */
X s_evalhook = xlsenter("*EVALHOOK*");
X s_evalhook->n_symvalue = NIL;
X s_applyhook = xlsenter("*APPLYHOOK*");
X s_applyhook->n_symvalue = NIL;
X
X /* enter the error traceback and the error break enable flags */
X s_tracenable = xlsenter("*TRACENABLE*");
X s_tracenable->n_symvalue = NIL;
X s_tlimit = xlsenter("*TRACELIMIT*");
X s_tlimit->n_symvalue = NIL;
X s_breakenable = xlsenter("*BREAKENABLE*");
X s_breakenable->n_symvalue = true;
X
X /* enter a copyright notice into the oblist */
X sym = xlsenter("**Copyright-1985-by-David-Betz**");
X sym->n_symvalue = true;
X
X /* enter type names */
X a_subr = xlsenter(":SUBR");
X a_fsubr = xlsenter(":FSUBR");
X a_list = xlsenter(":CONS");
X a_sym = xlsenter(":SYMBOL");
X a_int = xlsenter(":FIXNUM");
X a_float = xlsenter(":FLONUM");
X a_str = xlsenter(":STRING");
X a_obj = xlsenter(":OBJECT");
X a_fptr = xlsenter(":FILE");
X}
SHAR_EOF
if test 3534 -ne "`wc -c 'xlinit.c'`"
then
echo shar: error transmitting "'xlinit.c'" '(should have been 3534 characters)'
fi
echo shar: extracting "'xlio.c'" '(3109 characters)'
if test -f 'xlio.c'
then
echo shar: over-writing existing file "'xlio.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlio.c'
X/* xlio - xlisp i/o routines */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X#ifdef MEGAMAX
Xoverlay "io"
X#endif
X
X/* external variables */
Xextern int xlplevel;
Xextern int xlfsize;
Xextern NODE *xlstack;
Xextern NODE *s_stdin;
Xextern int xldebug;
Xextern int prompt;
Xextern char buf[];
X
X/* xlgetc - get a character from a file or stream */
Xint xlgetc(fptr)
X NODE *fptr;
X{
X NODE *lptr,*cptr;
X FILE *fp;
X int ch;
X
X /* check for input from nil */
X if (fptr == NIL)
X ch = EOF;
X
X /* otherwise, check for input from a stream */
X else if (consp(fptr)) {
X if ((lptr = car(fptr)) == NIL)
X ch = EOF;
X else {
X if (!consp(lptr) ||
X (cptr = car(lptr)) == NIL || !fixp(cptr))
X xlfail("bad stream");
X if (rplaca(fptr,cdr(lptr)) == NIL)
X rplacd(fptr,NIL);
X ch = cptr->n_int;
X }
X }
X
X /* otherwise, check for a buffered file character */
X else if (ch = fptr->n_savech)
X fptr->n_savech = 0;
X
X /* otherwise, get a new character */
X else {
X
X /* get the file pointer */
X fp = fptr->n_fp;
X
X /* prompt if necessary */
X if (prompt && fp == stdin) {
X
X /* print the debug level */
X if (xldebug)
X { sprintf(buf,"%d:",xldebug); stdputstr(buf); }
X
X /* print the nesting level */
X if (xlplevel > 0)
X { sprintf(buf,"%d",xlplevel); stdputstr(buf); }
X
X /* print the prompt */
X stdputstr("> ");
X prompt = FALSE;
X }
X
X /* get the character */
X if (((ch = getc(fp)) == '\n' || ch == EOF) && fp == stdin)
X prompt = TRUE;
X
X /* check for input abort */
X if (fp == stdin && ch == '\007') {
X putchar('\n');
X xlabort("input aborted");
X }
X }
X
X /* return the character */
X return (ch);
X}
X
X/* xlpeek - peek at a character from a file or stream */
Xint xlpeek(fptr)
X NODE *fptr;
X{
X NODE *lptr,*cptr;
X int ch;
X
X /* check for input from nil */
X if (fptr == NIL)
X ch = EOF;
X
X /* otherwise, check for input from a stream */
X else if (consp(fptr)) {
X if ((lptr = car(fptr)) == NIL)
X ch = EOF;
X else {
X if (!consp(lptr) ||
X (cptr = car(lptr)) == NIL || !fixp(cptr))
X xlfail("bad stream");
X ch = cptr->n_int;
X }
X }
X
X /* otherwise, get the next file character and save it */
X else
X ch = fptr->n_savech = xlgetc(fptr);
X
X /* return the character */
X return (ch);
X}
X
X/* xlputc - put a character to a file or stream */
Xxlputc(fptr,ch)
X NODE *fptr; int ch;
X{
X NODE *oldstk,lptr;
X
X /* count the character */
X xlfsize++;
X
X /* check for output to nil */
X if (fptr == NIL)
X ;
X
X /* otherwise, check for output to a stream */
X else if (consp(fptr)) {
X oldstk = xlsave(&lptr,NULL);
X lptr.n_ptr = newnode(LIST);
X rplaca(lptr.n_ptr,cvfixnum((FIXNUM)ch));
X if (cdr(fptr))
X rplacd(cdr(fptr),lptr.n_ptr);
X else
X rplaca(fptr,lptr.n_ptr);
X rplacd(fptr,lptr.n_ptr);
X xlstack = oldstk;
X }
X
X /* otherwise, output the character to a file */
X else
X putc(ch,fptr->n_fp);
X}
X
X/* xlflush - flush the input buffer */
Xint xlflush()
X{
X if (!prompt)
X while (xlgetc(getvalue(s_stdin)) != '\n')
X ;
X}
SHAR_EOF
if test 3109 -ne "`wc -c 'xlio.c'`"
then
echo shar: error transmitting "'xlio.c'" '(should have been 3109 characters)'
fi
echo shar: extracting "'xlisp.c'" '(2176 characters)'
if test -f 'xlisp.c'
then
echo shar: over-writing existing file "'xlisp.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlisp.c'
X/* xlisp - an small version of lisp that supports object-oriented programming */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* define the banner line string */
X#define BANNER "XLISP version 1.5b, Copyright (c) 1985, by David Betz"
X
X/* external variables */
Xextern NODE *s_stdin,*s_stdout;
Xextern NODE *s_evalhook,*s_applyhook;
Xextern NODE *true;
X
X/* main - the main routine */
Xmain(argc,argv)
X int argc; char *argv[];
X{
X char fname[50];
X CONTEXT cntxt;
X NODE expr;
X int i;
X
X /* print the banner line */
X#ifdef MEGAMAX
X macinit(BANNER);
X#else
X printf("%s\n",BANNER);
X#endif
X
X /* setup initialization error handler */
X xlbegin(&cntxt,CF_ERROR,(NODE *) 1);
X if (setjmp(cntxt.c_jmpbuf)) {
X printf("fatal initialization error\n");
X exit();
X }
X
X /* initialize xlisp */
X xlinit();
X xlend(&cntxt);
X
X /* reset the error handler */
X xlbegin(&cntxt,CF_ERROR,true);
X
X /* load "init.lsp" */
X if (setjmp(cntxt.c_jmpbuf) == 0)
X#ifndef INITPATH
X xlload("init.lsp",FALSE,FALSE);
X#else
X xlload(INITPATH,FALSE,FALSE);
X#endif
X
X /* load any files mentioned on the command line */
X#ifndef MEGAMAX
X if (setjmp(cntxt.c_jmpbuf) == 0)
X for (i = 1; i < argc; i++) {
X sprintf(fname,"%s.lsp",argv[i]);
X if (!xlload(fname,TRUE,FALSE))
X xlfail("can't load file");
X }
X#endif
X
X /* create a new stack frame */
X xlsave(&expr,NULL);
X
X /* main command processing loop */
X while (TRUE) {
X
X /* setup the error return */
X if (setjmp(cntxt.c_jmpbuf)) {
X setvalue(s_evalhook,NIL);
X setvalue(s_applyhook,NIL);
X xlflush();
X }
X
X /* read an expression */
X if (!xlread(getvalue(s_stdin),&expr.n_ptr))
X break;
X
X /* evaluate the expression */
X expr.n_ptr = xleval(expr.n_ptr);
X
X /* print it */
X stdprint(expr.n_ptr);
X }
X xlend(&cntxt);
X}
X
X/* stdprint - print to standard output */
Xstdprint(expr)
X NODE *expr;
X{
X xlprint(getvalue(s_stdout),expr,TRUE);
X xlterpri(getvalue(s_stdout));
X}
X
X/* stdputstr - print a string to standard output */
Xstdputstr(str)
X char *str;
X{
X xlputstr(getvalue(s_stdout),str);
X}
X
SHAR_EOF
if test 2176 -ne "`wc -c 'xlisp.c'`"
then
echo shar: error transmitting "'xlisp.c'" '(should have been 2176 characters)'
fi
echo shar: extracting "'xljump.c'" '(2937 characters)'
if test -f 'xljump.c'
then
echo shar: over-writing existing file "'xljump.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xljump.c'
X/* xljump - execution context routines */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern CONTEXT *xlcontext;
Xextern NODE *xlvalue;
Xextern NODE *xlstack,*xlenv;
Xextern int xltrace,xldebug;
X
X/* xlbegin - beginning of an execution context */
Xxlbegin(cptr,flags,expr)
X CONTEXT *cptr; int flags; NODE *expr;
X{
X cptr->c_flags = flags;
X cptr->c_expr = expr;
X cptr->c_xlstack = xlstack;
X cptr->c_xlenv = xlenv;
X cptr->c_xltrace = xltrace;
X cptr->c_xlcontext = xlcontext;
X xlcontext = cptr;
X}
X
X/* xlend - end of an execution context */
Xxlend(cptr)
X CONTEXT *cptr;
X{
X xlcontext = cptr->c_xlcontext;
X}
X
X/* xljump - jump to a saved execution context */
Xxljump(cptr,type,val)
X CONTEXT *cptr; int type; NODE *val;
X{
X /* restore the state */
X xlcontext = cptr;
X xlstack = xlcontext->c_xlstack;
X xlenv = xlcontext->c_xlenv;
X xltrace = xlcontext->c_xltrace;
X xlvalue = val;
X
X /* call the handler */
X longjmp(xlcontext->c_jmpbuf,type);
X}
X
X/* xlcleanup - clean-up after an error */
Xxlcleanup()
X{
X CONTEXT *cptr;
X
X /* find a block context */
X for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X if (cptr->c_flags & CF_CLEANUP)
X xljump(cptr,CF_CLEANUP,NIL);
X xlfail("not in a break loop");
X}
X
X/* xlcontinue - continue from an error */
Xxlcontinue()
X{
X CONTEXT *cptr;
X
X /* find a block context */
X for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X if (cptr->c_flags & CF_CONTINUE)
X xljump(cptr,CF_CONTINUE,NIL);
X xlfail("not in a break loop");
X}
X
X/* xlgo - go to a label */
Xxlgo(label)
X NODE *label;
X{
X CONTEXT *cptr;
X NODE *p;
X
X /* find a tagbody context */
X for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X if (cptr->c_flags & CF_GO)
X for (p = cptr->c_expr; consp(p); p = cdr(p))
X if (car(p) == label)
X xljump(cptr,CF_GO,p);
X xlfail("no target for GO");
X}
X
X/* xlreturn - return from a block */
Xxlreturn(val)
X NODE *val;
X{
X CONTEXT *cptr;
X
X /* find a block context */
X for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X if (cptr->c_flags & CF_RETURN)
X xljump(cptr,CF_RETURN,val);
X xlfail("no target for RETURN");
X}
X
X/* xlthrow - throw to a catch */
Xxlthrow(tag,val)
X NODE *tag,*val;
X{
X CONTEXT *cptr;
X
X /* find a catch context */
X for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X if ((cptr->c_flags & CF_THROW) && cptr->c_expr == tag)
X xljump(cptr,CF_THROW,val);
X xlfail("no target for THROW");
X}
X
X/* xlsignal - signal an error */
Xxlsignal(emsg,arg)
X char *emsg; NODE *arg;
X{
X CONTEXT *cptr;
X
X /* find an error catcher */
X for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X if (cptr->c_flags & CF_ERROR) {
X if (cptr->c_expr)
X xlerrprint("error",NULL,emsg,arg);
X xljump(cptr,CF_ERROR,NIL);
X }
X xlfail("no target for error");
X}
SHAR_EOF
if test 2937 -ne "`wc -c 'xljump.c'`"
then
echo shar: error transmitting "'xljump.c'" '(should have been 2937 characters)'
fi
echo shar: extracting "'xllist.c'" '(18035 characters)'
if test -f 'xllist.c'
then
echo shar: over-writing existing file "'xllist.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xllist.c'
X/* xllist - xlisp built-in list functions */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X#ifdef MEGAMAX
Xoverlay "overflow"
X#endif
X
X/* external variables */
Xextern NODE *xlstack;
Xextern NODE *s_unbound;
Xextern NODE *true;
X
X/* external routines */
Xextern int eq(),eql(),equal();
X
X/* forward declarations */
XFORWARD NODE *cxr();
XFORWARD NODE *nth(),*assoc();
XFORWARD NODE *subst(),*sublis(),*map();
XFORWARD NODE *cequal();
X
X/* xcar - return the car of a list */
XNODE *xcar(args)
X NODE *args;
X{
X return (cxr(args,"a"));
X}
X
X/* xcdr - return the cdr of a list */
XNODE *xcdr(args)
X NODE *args;
X{
X return (cxr(args,"d"));
X}
X
X/* xcaar - return the caar of a list */
XNODE *xcaar(args)
X NODE *args;
X{
X return (cxr(args,"aa"));
X}
X
X/* xcadr - return the cadr of a list */
XNODE *xcadr(args)
X NODE *args;
X{
X return (cxr(args,"da"));
X}
X
X/* xcdar - return the cdar of a list */
XNODE *xcdar(args)
X NODE *args;
X{
X return (cxr(args,"ad"));
X}
X
X/* xcddr - return the cddr of a list */
XNODE *xcddr(args)
X NODE *args;
X{
X return (cxr(args,"dd"));
X}
X
X/* cxr - common car/cdr routine */
XLOCAL NODE *cxr(args,adstr)
X NODE *args; char *adstr;
X{
X NODE *list;
X
X /* get the list */
X list = xlmatch(LIST,&args);
X xllastarg(args);
X
X /* perform the car/cdr operations */
X while (*adstr && consp(list))
X list = (*adstr++ == 'a' ? car(list) : cdr(list));
X
X /* make sure the operation succeeded */
X if (*adstr && list)
X xlfail("bad argument");
X
X /* return the result */
X return (list);
X}
X
X/* xcons - construct a new list cell */
XNODE *xcons(args)
X NODE *args;
X{
X NODE *arg1,*arg2,*val;
X
X /* get the two arguments */
X arg1 = xlarg(&args);
X arg2 = xlarg(&args);
X xllastarg(args);
X
X /* construct a new list element */
X val = newnode(LIST);
X rplaca(val,arg1);
X rplacd(val,arg2);
X
X /* return the list */
X return (val);
X}
X
X/* xlist - built a list of the arguments */
XNODE *xlist(args)
X NODE *args;
X{
X NODE *oldstk,arg,list,val,*last,*lptr;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&list,&val,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* evaluate and append each argument */
X for (last = NIL; arg.n_ptr != NIL; last = lptr) {
X
X /* evaluate the next argument */
X val.n_ptr = xlarg(&arg.n_ptr);
X
X /* append this argument to the end of the list */
X lptr = newnode(LIST);
X if (last == NIL)
X list.n_ptr = lptr;
X else
X rplacd(last,lptr);
X rplaca(lptr,val.n_ptr);
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the list */
X return (list.n_ptr);
X}
X
X/* xappend - built-in function append */
XNODE *xappend(args)
X NODE *args;
X{
X NODE *oldstk,arg,list,last,val,*lptr;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&list,&last,&val,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* evaluate and append each argument */
X while (arg.n_ptr) {
X
X /* evaluate the next argument */
X list.n_ptr = xlmatch(LIST,&arg.n_ptr);
X
X /* append each element of this list to the result list */
X while (consp(list.n_ptr)) {
X
X /* append this element */
X lptr = newnode(LIST);
X if (last.n_ptr == NIL)
X val.n_ptr = lptr;
X else
X rplacd(last.n_ptr,lptr);
X rplaca(lptr,car(list.n_ptr));
X
X /* save the new last element */
X last.n_ptr = lptr;
X
X /* move to the next element */
X list.n_ptr = cdr(list.n_ptr);
X }
X }
X
X /* restore previous stack frame */
X xlstack = oldstk;
X
X /* return the list */
X return (val.n_ptr);
X}
X
X/* xreverse - built-in function reverse */
XNODE *xreverse(args)
X NODE *args;
X{
X NODE *oldstk,list,val,*lptr;
X
X /* create a new stack frame */
X oldstk = xlsave(&list,&val,NULL);
X
X /* get the list to reverse */
X list.n_ptr = xlmatch(LIST,&args);
X xllastarg(args);
X
X /* append each element of this list to the result list */
X while (consp(list.n_ptr)) {
X
X /* append this element */
X lptr = newnode(LIST);
X rplaca(lptr,car(list.n_ptr));
X rplacd(lptr,val.n_ptr);
X val.n_ptr = lptr;
X
X /* move to the next element */
X list.n_ptr = cdr(list.n_ptr);
X }
X
X /* restore previous stack frame */
X xlstack = oldstk;
X
X /* return the list */
X return (val.n_ptr);
X}
X
X/* xlast - return the last cons of a list */
XNODE *xlast(args)
X NODE *args;
X{
X NODE *list;
X
X /* get the list */
X list = xlmatch(LIST,&args);
X xllastarg(args);
X
X /* find the last cons */
X while (consp(list) && cdr(list))
X list = cdr(list);
X
X /* return the last element */
X return (list);
X}
X
X/* xmember - built-in function 'member' */
XNODE *xmember(args)
X NODE *args;
X{
X NODE *oldstk,x,list,fcn,*val;
X int tresult;
X
X /* create a new stack frame */
X oldstk = xlsave(&x,&list,&fcn,NULL);
X
X /* get the expression to look for and the list */
X x.n_ptr = xlarg(&args);
X list.n_ptr = xlmatch(LIST,&args);
X xltest(&fcn.n_ptr,&tresult,&args);
X xllastarg(args);
X
X /* look for the expression */
X for (val = NIL; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr))
X if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) == tresult) {
X val = list.n_ptr;
X break;
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* xassoc - built-in function 'assoc' */
XNODE *xassoc(args)
X NODE *args;
X{
X NODE *oldstk,x,alist,fcn,*pair,*val;
X int tresult;
X
X /* create a new stack frame */
X oldstk = xlsave(&x,&alist,&fcn,NULL);
X
X /* get the expression to look for and the association list */
X x.n_ptr = xlarg(&args);
X alist.n_ptr = xlmatch(LIST,&args);
X xltest(&fcn.n_ptr,&tresult,&args);
X xllastarg(args);
X
X /* look for the expression */
X for (val = NIL; consp(alist.n_ptr); alist.n_ptr = cdr(alist.n_ptr))
X if ((pair = car(alist.n_ptr)) && consp(pair))
X if (dotest(x.n_ptr,car(pair),fcn.n_ptr) == tresult) {
X val = pair;
X break;
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* xsubst - substitute one expression for another */
XNODE *xsubst(args)
X NODE *args;
X{
X NODE *oldstk,to,from,expr,fcn,*val;
X int tresult;
X
X /* create a new stack frame */
X oldstk = xlsave(&to,&from,&expr,&fcn,NULL);
X
X /* get the to value, the from value and the expression */
X to.n_ptr = xlarg(&args);
X from.n_ptr = xlarg(&args);
X expr.n_ptr = xlarg(&args);
X xltest(&fcn.n_ptr,&tresult,&args);
X xllastarg(args);
X
X /* do the substitution */
X val = subst(to.n_ptr,from.n_ptr,expr.n_ptr,fcn.n_ptr,tresult);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* subst - substitute one expression for another */
XLOCAL NODE *subst(to,from,expr,fcn,tresult)
X NODE *to,*from,*expr,*fcn; int tresult;
X{
X NODE *oldstk,carval,cdrval,*val;
X
X if (dotest(expr,from,fcn) == tresult)
X val = to;
X else if (consp(expr)) {
X oldstk = xlsave(&carval,&cdrval,NULL);
X carval.n_ptr = subst(to,from,car(expr),fcn,tresult);
X cdrval.n_ptr = subst(to,from,cdr(expr),fcn,tresult);
X val = newnode(LIST);
X rplaca(val,carval.n_ptr);
X rplacd(val,cdrval.n_ptr);
X xlstack = oldstk;
X }
X else
X val = expr;
X return (val);
X}
X
X/* xsublis - substitute using an association list */
XNODE *xsublis(args)
X NODE *args;
X{
X NODE *oldstk,alist,expr,fcn,*val;
X int tresult;
X
X /* create a new stack frame */
X oldstk = xlsave(&alist,&expr,&fcn,NULL);
X
X /* get the assocation list and the expression */
X alist.n_ptr = xlmatch(LIST,&args);
X expr.n_ptr = xlarg(&args);
X xltest(&fcn.n_ptr,&tresult,&args);
X xllastarg(args);
X
X /* do the substitution */
X val = sublis(alist.n_ptr,expr.n_ptr,fcn.n_ptr,tresult);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* sublis - substitute using an association list */
XLOCAL NODE *sublis(alist,expr,fcn,tresult)
X NODE *alist,*expr,*fcn; int tresult;
X{
X NODE *oldstk,carval,cdrval,*val;
X
X if (val = assoc(expr,alist,fcn,tresult))
X val = cdr(val);
X else if (consp(expr)) {
X oldstk = xlsave(&carval,&cdrval,NULL);
X carval.n_ptr = sublis(alist,car(expr),fcn,tresult);
X cdrval.n_ptr = sublis(alist,cdr(expr),fcn,tresult);
X val = newnode(LIST);
X rplaca(val,carval.n_ptr);
X rplacd(val,cdrval.n_ptr);
X xlstack = oldstk;
X }
X else
X val = expr;
X return (val);
X}
X
X/* assoc - find a pair in an association list */
XLOCAL NODE *assoc(expr,alist,fcn,tresult)
X NODE *expr,*alist,*fcn; int tresult;
X{
X NODE *pair;
X
X for (; consp(alist); alist = cdr(alist))
X if ((pair = car(alist)) && consp(pair))
X if (dotest(expr,car(pair),fcn) == tresult)
X return (pair);
X return (NIL);
X}
X
X/* xremove - built-in function 'remove' */
XNODE *xremove(args)
X NODE *args;
X{
X NODE *oldstk,x,list,fcn,val,*p,*last;
X int tresult;
X
X /* create a new stack frame */
X oldstk = xlsave(&x,&list,&fcn,&val,NULL);
X
X /* get the expression to remove and the list */
X x.n_ptr = xlarg(&args);
X list.n_ptr = xlmatch(LIST,&args);
X xltest(&fcn.n_ptr,&tresult,&args);
X xllastarg(args);
X
X /* remove matches */
X while (consp(list.n_ptr)) {
X
X /* check to see if this element should be deleted */
X if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) != tresult) {
X p = newnode(LIST);
X rplaca(p,car(list.n_ptr));
X if (val.n_ptr) rplacd(last,p);
X else val.n_ptr = p;
X last = p;
X }
X
X /* move to the next element */
X list.n_ptr = cdr(list.n_ptr);
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the updated list */
X return (val.n_ptr);
X}
X
X/* dotest - call a test function */
Xint dotest(arg1,arg2,fcn)
X NODE *arg1,*arg2,*fcn;
X{
X NODE *oldstk,args,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&args,NULL);
X
X /* build an argument list */
X args.n_ptr = newnode(LIST);
X rplaca(args.n_ptr,arg1);
X rplacd(args.n_ptr,newnode(LIST));
X rplaca(cdr(args.n_ptr),arg2);
X
X /* apply the test function */
X val = xlapply(fcn,args.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result of the test */
X return (val != NIL);
X}
X
X/* xnth - return the nth element of a list */
XNODE *xnth(args)
X NODE *args;
X{
X return (nth(args,TRUE));
X}
X
X/* xnthcdr - return the nth cdr of a list */
XNODE *xnthcdr(args)
X NODE *args;
X{
X return (nth(args,FALSE));
X}
X
X/* nth - internal nth function */
XLOCAL NODE *nth(args,carflag)
X NODE *args; int carflag;
X{
X NODE *list;
X int n;
X
X /* get n and the list */
X if ((n = xlmatch(INT,&args)->n_int) < 0)
X xlfail("bad argument");
X if ((list = xlmatch(LIST,&args)) == NIL)
X xlfail("bad argument");
X xllastarg(args);
X
X /* find the nth element */
X while (consp(list) && n--)
X list = cdr(list);
X
X /* return the list beginning at the nth element */
X return (carflag && consp(list) ? car(list) : list);
X}
X
X/* xlength - return the length of a list or string */
XNODE *xlength(args)
X NODE *args;
X{
X NODE *arg;
X int n;
X
X /* get the list or string */
X arg = xlarg(&args);
X xllastarg(args);
X
X /* find the length of a list */
X if (listp(arg))
X for (n = 0; consp(arg); n++)
X arg = cdr(arg);
X
X /* find the length of a string */
X else if (stringp(arg))
X n = strlen(arg->n_str);
X
X /* otherwise, bad argument type */
X else
X xlerror("bad argument type",arg);
X
X /* return the length */
X return (cvfixnum((FIXNUM)n));
X}
X
X/* xmapc - built-in function 'mapc' */
XNODE *xmapc(args)
X NODE *args;
X{
X return (map(args,TRUE,FALSE));
X}
X
X/* xmapcar - built-in function 'mapcar' */
XNODE *xmapcar(args)
X NODE *args;
X{
X return (map(args,TRUE,TRUE));
X}
X
X/* xmapl - built-in function 'mapl' */
XNODE *xmapl(args)
X NODE *args;
X{
X return (map(args,FALSE,FALSE));
X}
X
X/* xmaplist - built-in function 'maplist' */
XNODE *xmaplist(args)
X NODE *args;
X{
X return (map(args,FALSE,TRUE));
X}
X
X/* map - internal mapping function */
XLOCAL NODE *map(args,carflag,valflag)
X NODE *args; int carflag,valflag;
X{
X NODE *oldstk,fcn,lists,arglist,val,*last,*p,*x,*y;
X
X /* create a new stack frame */
X oldstk = xlsave(&fcn,&lists,&arglist,&val,NULL);
X
X /* get the function to apply and the first list */
X fcn.n_ptr = xlarg(&args);
X lists.n_ptr = xlmatch(LIST,&args);
X
X /* save the first list if not saving function values */
X if (!valflag)
X val.n_ptr = lists.n_ptr;
X
X /* set up the list of argument lists */
X p = newnode(LIST);
X rplaca(p,lists.n_ptr);
X lists.n_ptr = p;
X
X /* get the remaining argument lists */
X while (args) {
X p = newnode(LIST);
X rplacd(p,lists.n_ptr);
X lists.n_ptr = p;
X rplaca(p,xlmatch(LIST,&args));
X }
X
X /* if the function is a symbol, get its value */
X if (symbolp(fcn.n_ptr))
X fcn.n_ptr = xleval(fcn.n_ptr);
X
X /* loop through each of the argument lists */
X for (;;) {
X
X /* build an argument list from the sublists */
X arglist.n_ptr = NIL;
X for (x = lists.n_ptr; x && (y = car(x)) && consp(y); x = cdr(x)) {
X p = newnode(LIST);
X rplacd(p,arglist.n_ptr);
X arglist.n_ptr = p;
X rplaca(p,carflag ? car(y) : y);
X rplaca(x,cdr(y));
X }
X
X /* quit if any of the lists were empty */
X if (x) break;
X
X /* apply the function to the arguments */
X if (valflag) {
X p = newnode(LIST);
X if (val.n_ptr) rplacd(last,p);
X else val.n_ptr = p;
X rplaca(p,xlapply(fcn.n_ptr,arglist.n_ptr));
X last = p;
X }
X else
X xlapply(fcn.n_ptr,arglist.n_ptr);
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the last test expression value */
X return (val.n_ptr);
X}
X
X/* xrplca - replace the car of a list node */
XNODE *xrplca(args)
X NODE *args;
X{
X NODE *list,*newcar;
X
X /* get the list and the new car */
X if ((list = xlmatch(LIST,&args)) == NIL)
X xlfail("bad argument");
X newcar = xlarg(&args);
X xllastarg(args);
X
X /* replace the car */
X rplaca(list,newcar);
X
X /* return the list node that was modified */
X return (list);
X}
X
X/* xrplcd - replace the cdr of a list node */
XNODE *xrplcd(args)
X NODE *args;
X{
X NODE *list,*newcdr;
X
X /* get the list and the new cdr */
X if ((list = xlmatch(LIST,&args)) == NIL)
X xlfail("bad argument");
X newcdr = xlarg(&args);
X xllastarg(args);
X
X /* replace the cdr */
X rplacd(list,newcdr);
X
X /* return the list node that was modified */
X return (list);
X}
X
X/* xnconc - destructively append lists */
XNODE *xnconc(args)
X NODE *args;
X{
X NODE *list,*last,*val;
X
X /* concatenate each argument */
X for (val = NIL; args; ) {
X
X /* concatenate this list */
X if (list = xlmatch(LIST,&args)) {
X
X /* check for this being the first non-empty list */
X if (val)
X rplacd(last,list);
X else
X val = list;
X
X /* find the end of the list */
X while (consp(cdr(list)))
X list = cdr(list);
X
X /* save the new last element */
X last = list;
X }
X }
X
X /* return the list */
X return (val);
X}
X
X/* xdelete - built-in function 'delete' */
XNODE *xdelete(args)
X NODE *args;
X{
X NODE *oldstk,x,list,fcn,*last,*val;
X int tresult;
X
X /* create a new stack frame */
X oldstk = xlsave(&x,&list,&fcn,NULL);
X
X /* get the expression to delete and the list */
X x.n_ptr = xlarg(&args);
X list.n_ptr = xlmatch(LIST,&args);
X xltest(&fcn.n_ptr,&tresult,&args);
X xllastarg(args);
X
X /* delete leading matches */
X while (consp(list.n_ptr)) {
X if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) != tresult)
X break;
X list.n_ptr = cdr(list.n_ptr);
X }
X val = last = list.n_ptr;
X
X /* delete embedded matches */
X if (consp(list.n_ptr)) {
X
X /* skip the first non-matching element */
X list.n_ptr = cdr(list.n_ptr);
X
X /* look for embedded matches */
X while (consp(list.n_ptr)) {
X
X /* check to see if this element should be deleted */
X if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) == tresult)
X rplacd(last,cdr(list.n_ptr));
X else
X last = list.n_ptr;
X
X /* move to the next element */
X list.n_ptr = cdr(list.n_ptr);
X }
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the updated list */
X return (val);
X}
X
X/* xatom - is this an atom? */
XNODE *xatom(args)
X NODE *args;
X{
X NODE *arg;
X arg = xlarg(&args);
X xllastarg(args);
X return (atom(arg) ? true : NIL);
X}
X
X/* xsymbolp - is this an symbol? */
XNODE *xsymbolp(args)
X NODE *args;
X{
X NODE *arg;
X arg = xlarg(&args);
X xllastarg(args);
X return (arg == NIL || symbolp(arg) ? true : NIL);
X}
X
X/* xnumberp - is this a number? */
XNODE *xnumberp(args)
X NODE *args;
X{
X NODE *arg;
X arg = xlarg(&args);
X xllastarg(args);
X return (fixp(arg) || floatp(arg) ? true : NIL);
X}
X
X/* xboundp - is this a value bound to this symbol? */
XNODE *xboundp(args)
X NODE *args;
X{
X NODE *sym;
X sym = xlmatch(SYM,&args);
X xllastarg(args);
X return (xlxgetvalue(sym) == s_unbound ? NIL : true);
X}
X
X/* xnull - is this null? */
XNODE *xnull(args)
X NODE *args;
X{
X NODE *arg;
X arg = xlarg(&args);
X xllastarg(args);
X return (null(arg) ? true : NIL);
X}
X
X/* xlistp - is this a list? */
XNODE *xlistp(args)
X NODE *args;
X{
X NODE *arg;
X arg = xlarg(&args);
X xllastarg(args);
X return (listp(arg) ? true : NIL);
X}
X
X/* xconsp - is this a cons? */
XNODE *xconsp(args)
X NODE *args;
X{
X NODE *arg;
X arg = xlarg(&args);
X xllastarg(args);
X return (consp(arg) ? true : NIL);
X}
X
X/* xeq - are these equal? */
XNODE *xeq(args)
X NODE *args;
X{
X return (cequal(args,eq));
X}
X
X/* xeql - are these equal? */
XNODE *xeql(args)
X NODE *args;
X{
X return (cequal(args,eql));
X}
X
X/* xequal - are these equal? */
XNODE *xequal(args)
X NODE *args;
X{
X return (cequal(args,equal));
X}
X
X/* cequal - common eq/eql/equal function */
XLOCAL NODE *cequal(args,fcn)
X NODE *args; int (*fcn)();
X{
X NODE *arg1,*arg2;
X
X /* get the two arguments */
X arg1 = xlarg(&args);
X arg2 = xlarg(&args);
X xllastarg(args);
X
X /* compare the arguments */
X return ((*fcn)(arg1,arg2) ? true : NIL);
X}
SHAR_EOF
if test 18035 -ne "`wc -c 'xllist.c'`"
then
echo shar: error transmitting "'xllist.c'" '(should have been 18035 characters)'
fi
echo shar: extracting "'xlmath.c'" '(10134 characters)'
if test -f 'xlmath.c'
then
echo shar: over-writing existing file "'xlmath.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlmath.c'
X/* xlmath - xlisp builtin arithmetic functions */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include
X#include "xlisp.h"
X
X#ifdef MEGAMAX
Xoverlay "math"
X#endif
X
X/* external variables */
Xextern NODE *xlstack;
Xextern NODE *true;
X
X/* forward declarations */
XFORWARD NODE *unary();
XFORWARD NODE *binary();
XFORWARD NODE *predicate();
XFORWARD NODE *compare();
X
X/* xadd - builtin function for addition */
XNODE *xadd(args)
X NODE *args;
X{
X return (binary(args,'+'));
X}
X
X/* xsub - builtin function for subtraction */
XNODE *xsub(args)
X NODE *args;
X{
X return (binary(args,'-'));
X}
X
X/* xmul - builtin function for multiplication */
XNODE *xmul(args)
X NODE *args;
X{
X return (binary(args,'*'));
X}
X
X/* xdiv - builtin function for division */
XNODE *xdiv(args)
X NODE *args;
X{
X return (binary(args,'/'));
X}
X
X/* xrem - builtin function for remainder */
XNODE *xrem(args)
X NODE *args;
X{
X return (binary(args,'%'));
X}
X
X/* xmin - builtin function for minimum */
XNODE *xmin(args)
X NODE *args;
X{
X return (binary(args,'m'));
X}
X
X/* xmax - builtin function for maximum */
XNODE *xmax(args)
X NODE *args;
X{
X return (binary(args,'M'));
X}
X
X/* xexpt - built-in function 'expt' */
XNODE *xexpt(args)
X NODE *args;
X{
X return (binary(args,'E'));
X}
X
X/* xbitand - builtin function for bitwise and */
XNODE *xbitand(args)
X NODE *args;
X{
X return (binary(args,'&'));
X}
X
X/* xbitior - builtin function for bitwise inclusive or */
XNODE *xbitior(args)
X NODE *args;
X{
X return (binary(args,'|'));
X}
X
X/* xbitxor - builtin function for bitwise exclusive or */
XNODE *xbitxor(args)
X NODE *args;
X{
X return (binary(args,'^'));
X}
X
X/* binary - handle binary operations */
XLOCAL NODE *binary(args,fcn)
X NODE *args; int fcn;
X{
X FIXNUM ival,iarg;
X FLONUM fval,farg;
X NODE *arg;
X int imode;
X
X /* get the first argument */
X arg = xlarg(&args);
X
X /* set the type of the first argument */
X if (fixp(arg)) {
X ival = arg->n_int;
X imode = TRUE;
X }
X else if (floatp(arg)) {
X fval = arg->n_float;
X imode = FALSE;
X }
X else
X xlerror("bad argument type",arg);
X
X /* treat '-' with a single argument as a special case */
X if (fcn == '-' && args == NIL)
X if (imode)
X ival = -ival;
X else
X fval = -fval;
X
X /* handle each remaining argument */
X while (args) {
X
X /* get the next argument */
X arg = xlarg(&args);
X
X /* check its type */
X if (fixp(arg))
X if (imode) iarg = arg->n_int;
X else farg = (FLONUM)arg->n_int;
X else if (floatp(arg))
X if (imode) { fval = (FLONUM)ival; farg = arg->n_float; imode = FALSE; }
X else farg = arg->n_float;
X else
X xlerror("bad argument type",arg);
X
X /* accumulate the result value */
X if (imode)
X switch (fcn) {
X case '+': ival += iarg; break;
X case '-': ival -= iarg; break;
X case '*': ival *= iarg; break;
X case '/': checkizero(iarg); ival /= iarg; break;
X case '%': checkizero(iarg); ival %= iarg; break;
X case 'M': if (iarg > ival) ival = iarg; break;
X case 'm': if (iarg < ival) ival = iarg; break;
X case '&': ival &= iarg; break;
X case '|': ival |= iarg; break;
X case '^': ival ^= iarg; break;
X default: badiop();
X }
X else
X switch (fcn) {
X case '+': fval += farg; break;
X case '-': fval -= farg; break;
X case '*': fval *= farg; break;
X case '/': checkfzero(farg); fval /= farg; break;
X case 'M': if (farg > fval) fval = farg; break;
X case 'm': if (farg < fval) fval = farg; break;
X case 'E': fval = pow(fval,farg); break;
X default: badfop();
X }
X }
X
X /* return the result */
X return (imode ? cvfixnum(ival) : cvflonum(fval));
X}
X
X/* checkizero - check for integer division by zero */
Xcheckizero(iarg)
X FIXNUM iarg;
X{
X if (iarg == 0)
X xlfail("division by zero");
X}
X
X/* checkfzero - check for floating point division by zero */
Xcheckfzero(farg)
X FLONUM farg;
X{
X if (farg == 0.0)
X xlfail("division by zero");
X}
X
X/* checkfneg - check for square root of a negative number */
Xcheckfneg(farg)
X FLONUM farg;
X{
X if (farg < 0.0)
X xlfail("square root of a negative number");
X}
X
X/* xbitnot - bitwise not */
XNODE *xbitnot(args)
X NODE *args;
X{
X return (unary(args,'~'));
X}
X
X/* xabs - builtin function for absolute value */
XNODE *xabs(args)
X NODE *args;
X{
X return (unary(args,'A'));
X}
X
X/* xadd1 - builtin function for adding one */
XNODE *xadd1(args)
X NODE *args;
X{
X return (unary(args,'+'));
X}
X
X/* xsub1 - builtin function for subtracting one */
XNODE *xsub1(args)
X NODE *args;
X{
X return (unary(args,'-'));
X}
X
X/* xsin - built-in function 'sin' */
XNODE *xsin(args)
X NODE *args;
X{
X return (unary(args,'S'));
X}
X
X/* xcos - built-in function 'cos' */
XNODE *xcos(args)
X NODE *args;
X{
X return (unary(args,'C'));
X}
X
X/* xtan - built-in function 'tan' */
XNODE *xtan(args)
X NODE *args;
X{
X return (unary(args,'T'));
X}
X
X/* xexp - built-in function 'exp' */
XNODE *xexp(args)
X NODE *args;
X{
X return (unary(args,'E'));
X}
X
X/* xsqrt - built-in function 'sqrt' */
XNODE *xsqrt(args)
X NODE *args;
X{
X return (unary(args,'R'));
X}
X
X/* xfix - built-in function 'fix' */
XNODE *xfix(args)
X NODE *args;
X{
X return (unary(args,'I'));
X}
X
X/* xfloat - built-in function 'float' */
XNODE *xfloat(args)
X NODE *args;
X{
X return (unary(args,'F'));
X}
X
X/* unary - handle unary operations */
XLOCAL NODE *unary(args,fcn)
X NODE *args; int fcn;
X{
X FLONUM fval;
X FIXNUM ival;
X NODE *arg;
X
X /* get the argument */
X arg = xlarg(&args);
X xllastarg(args);
X
X /* check its type */
X if (fixp(arg)) {
X ival = arg->n_int;
X switch (fcn) {
X case '~': ival = ~ival; break;
X case 'A': ival = abs(ival); break;
X case '+': ival++; break;
X case '-': ival--; break;
X case 'I': break;
X case 'F': return (cvflonum((FLONUM)ival));
X default: badiop();
X }
X return (cvfixnum(ival));
X }
X else if (floatp(arg)) {
X fval = arg->n_float;
X switch (fcn) {
X case 'A': fval = fabs(fval); break;
X case '+': fval += 1.0; break;
X case '-': fval -= 1.0; break;
X case 'S': fval = sin(fval); break;
X case 'C': fval = cos(fval); break;
X case 'T': fval = tan(fval); break;
X case 'E': fval = exp(fval); break;
X case 'R': checkfneg(fval); fval = sqrt(fval); break;
X case 'I': return (cvfixnum((FIXNUM)fval));
X case 'F': break;
X default: badfop();
X }
X return (cvflonum(fval));
X }
X else
X xlerror("bad argument type",arg);
X}
X
X/* xminusp - is this number negative? */
XNODE *xminusp(args)
X NODE *args;
X{
X return (predicate(args,'-'));
X}
X
X/* xzerop - is this number zero? */
XNODE *xzerop(args)
X NODE *args;
X{
X return (predicate(args,'Z'));
X}
X
X/* xplusp - is this number positive? */
XNODE *xplusp(args)
X NODE *args;
X{
X return (predicate(args,'+'));
X}
X
X/* xevenp - is this number even? */
XNODE *xevenp(args)
X NODE *args;
X{
X return (predicate(args,'E'));
X}
X
X/* xoddp - is this number odd? */
XNODE *xoddp(args)
X NODE *args;
X{
X return (predicate(args,'O'));
X}
X
X/* predicate - handle a predicate function */
XLOCAL NODE *predicate(args,fcn)
X NODE *args; int fcn;
X{
X FLONUM fval;
X FIXNUM ival;
X NODE *arg;
X
X /* get the argument */
X arg = xlarg(&args);
X xllastarg(args);
X
X /* check the argument type */
X if (fixp(arg)) {
X ival = arg->n_int;
X switch (fcn) {
X case '-': ival = (ival < 0); break;
X case 'Z': ival = (ival == 0); break;
X case '+': ival = (ival > 0); break;
X case 'E': ival = ((ival & 1) == 0); break;
X case 'O': ival = ((ival & 1) != 0); break;
X default: badiop();
X }
X }
X else if (floatp(arg)) {
X fval = arg->n_float;
X switch (fcn) {
X case '-': ival = (fval < 0); break;
X case 'Z': ival = (fval == 0); break;
X case '+': ival = (fval > 0); break;
X default: badfop();
X }
X }
X else
X xlerror("bad argument type",arg);
X
X /* return the result value */
X return (ival ? true : NIL);
X}
X
X/* xlss - builtin function for < */
XNODE *xlss(args)
X NODE *args;
X{
X return (compare(args,'<'));
X}
X
X/* xleq - builtin function for <= */
XNODE *xleq(args)
X NODE *args;
X{
X return (compare(args,'L'));
X}
X
X/* equ - builtin function for = */
XNODE *xequ(args)
X NODE *args;
X{
X return (compare(args,'='));
X}
X
X/* xneq - builtin function for /= */
XNODE *xneq(args)
X NODE *args;
X{
X return (compare(args,'#'));
X}
X
X/* xgeq - builtin function for >= */
XNODE *xgeq(args)
X NODE *args;
X{
X return (compare(args,'G'));
X}
X
X/* xgtr - builtin function for > */
XNODE *xgtr(args)
X NODE *args;
X{
X return (compare(args,'>'));
X}
X
X/* compare - common compare function */
XLOCAL NODE *compare(args,fcn)
X NODE *args; int fcn;
X{
X NODE *arg1,*arg2;
X FIXNUM icmp;
X FLONUM fcmp;
X int imode;
X
X /* get the two arguments */
X arg1 = xlarg(&args);
X arg2 = xlarg(&args);
X xllastarg(args);
X
X /* do the compare */
X if (stringp(arg1) && stringp(arg2)) {
X icmp = strcmp(arg1->n_str,arg2->n_str);
X imode = TRUE;
X }
X else if (fixp(arg1) && fixp(arg2)) {
X icmp = arg1->n_int - arg2->n_int;
X imode = TRUE;
X }
X else if (floatp(arg1) && floatp(arg2)) {
X fcmp = arg1->n_float - arg2->n_float;
X imode = FALSE;
X }
X else if (fixp(arg1) && floatp(arg2)) {
X fcmp = (FLONUM)arg1->n_int - arg2->n_float;
X imode = FALSE;
X }
X else if (floatp(arg1) && fixp(arg2)) {
X fcmp = arg1->n_float - (FLONUM)arg2->n_int;
X imode = FALSE;
X }
X else
X xlfail("expecting strings, integers or floats");
X
X /* compute result of the compare */
X if (imode)
X switch (fcn) {
X case '<': icmp = (icmp < 0); break;
X case 'L': icmp = (icmp <= 0); break;
X case '=': icmp = (icmp == 0); break;
X case '#': icmp = (icmp != 0); break;
X case 'G': icmp = (icmp >= 0); break;
X case '>': icmp = (icmp > 0); break;
X }
X else
X switch (fcn) {
X case '<': icmp = (fcmp < 0.0); break;
X case 'L': icmp = (fcmp <= 0.0); break;
X case '=': icmp = (fcmp == 0.0); break;
X case '#': icmp = (fcmp != 0.0); break;
X case 'G': icmp = (fcmp >= 0.0); break;
X case '>': icmp = (fcmp > 0.0); break;
X }
X
X /* return the result */
X return (icmp ? true : NIL);
X}
X
X/* badiop - bad integer operation */
XLOCAL badiop()
X{
X xlfail("bad integer operation");
X}
X
X/* badfop - bad floating point operation */
XLOCAL badfop()
X{
X xlfail("bad floating point operation");
X}
SHAR_EOF
if test 10134 -ne "`wc -c 'xlmath.c'`"
then
echo shar: error transmitting "'xlmath.c'" '(should have been 10134 characters)'
fi
# End of shell archive
exit 0
--
Jwahar R. Bammi
Usenet: .....!decvax!cwruecmp!bammi
CSnet: bammi@case
Arpa: bammi%case@csnet-relay
CompuServe: 71515,155