Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Posting-Version: version B 2.10.2 9/17/84; site cwruecmp.UUCP
Path: utzoo!watmath!clyde!burl!ulysses!ucbvax!decvax!cwruecmp!bammi
From: bammi@cwruecmp.UUCP (Jwahar R. Bammi)
Newsgroups: net.micro.atari
Subject: xlisp (PART 5 of 6)
Message-ID: <1383@cwruecmp.UUCP>
Date: Sat, 18-Jan-86 15:03:26 EST
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 <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