Thread View: net.micro.atari
1 messages
1 total messages
Started by Jwahar R. Bammi
Sat, 18 Jan 1986 20:03
xlisp (PART 5 of 6)
Author: Jwahar R. Bammi
Date: Sat, 18 Jan 1986 20:03
Date: Sat, 18 Jan 1986 20:03
2150 lines
52537 bytes
52537 bytes
#!/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 <math.h>
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
Thread Navigation
This is a paginated view of messages in the thread with full content displayed inline.
Messages are displayed in chronological order, with the original post highlighted in green.
Use pagination controls to navigate through all messages in large threads.
Back to All Threads