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 4 of 6)
Message-ID: <1382@cwruecmp.UUCP>
Date: Sat, 18-Jan-86 15:01:57 EST
Article-I.D.: cwruecmp.1382
Posted: Sat Jan 18 15:01:57 1986
Date-Received: Mon, 20-Jan-86 05:20:38 EST
Organization: CWRU Dept. Computer Eng., Cleveland, OH
Lines: 3009

#!/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:
#	ststuff.c
#	xlbfun.c
#	xlcont.c
#	xldbug.c
#	xldmem.c
#	xleval.c
#	xlfio.c
#	xlftab1.c
# This archive created: Sat Jan 18 14:32:22 1986
# By:	Jwahar R. Bammi ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'ststuff.c'" '(2963 characters)'
if test -f 'ststuff.c'
then
	echo shar: over-writing existing file "'ststuff.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'ststuff.c'
X/* ststuff.c - atari 520st specific routines */
X
X#include <stdio.h>
X#include <osbind.h>
X
X#define LBSIZE 200
X
X/* line buffer variables */
Xstatic char lbuf[LBSIZE];
Xstatic int  lpos[LBSIZE];
Xstatic int lindex = 0;
Xstatic int lcount = 0;
Xstatic int lposition = 0;
X
X/* external variables */
Xextern int prompt;
X
X/* external routines */
Xextern double sin(),cos();
X
X/* tan - tangent */
Xdouble tan(x)
X  double x;
X{
X    return (sin(x) / cos(x));
X}
X
X/* stcheck - check for a control key */
Xint stcheck()
X{
X    return (xcheck());
X}
X
X/* stgetc - get a character from the terminal */
Xint stgetc(fp)
X  FILE *fp;
X{
X    int ch;
X
X    /* check for input from a file other than stdin */
X    if (fp != stdin)
X	return (getc(fp));
X
X    /* check for a buffered character */
X    if (lcount--)
X	return (lbuf[lindex++]);
X
X    /* get an input line */
X    for (lcount = 0; ; )
X	switch (ch = xgetc()) {
X	case '\r':
X		stputc('\n',stdout);
X		lbuf[lcount++] = '\n';
X		lindex = 0; lcount--;
X		return (lbuf[lindex++]);
X	case '\010':
X	case '\177':
X		if (lcount) {
X		    lcount--;
X		    while (lposition && lposition > lpos[lcount]) {
X			stputc('\010',stdout);
X			stputc(' ',stdout);
X			stputc('\010',stdout);
X		    }
X		}
X		break;
X	default:
X
X		/* check for normal printing characters */
X		if (ch == '\t' || (ch >= ' ' && ch < '\177')) {
X		    lbuf[lcount] = ch;
X		    lpos[lcount] = lposition;
X		    stputc(ch,stdout);
X		    lcount++;
X		}
X
X		/* check for control codes */
X		else {
X		    stflush();
X		    if (ch == '\003')		/* control-c (exit) */
X			exit();
X		    else if (ch == '\007')	/* control-g (clean-up) */
X			xlcleanup();
X		    else if (ch == '\020')	/* control-p (continue) */
X			xlcontinue();
X		    else if (ch == '\032')	/* control-z (eof) */
X			return (EOF);
X		    return (ch);
X		}
X	}
X}
X
X/* stputc - put a character to the terminal */
Xstputc(ch,fp)
X  int ch; FILE *fp;
X{
X    /* check for output to something other than stdout */
X    if (fp != stdout)
X	return (putc(ch,fp));
X
X    /* check for newline */
X    if (ch == '\n') {
X	lposition = 0;
X	xputc('\r');
X	xputc('\n');
X    }
X
X    /* otherwise, check for tab */
X    else if (ch == '\t') {
X	do {
X	    stputc(' ',stdout);
X	} while (lposition & 7);
X    }
X
X    /* otherwise, check for a backspace */
X    else if (ch == '\010') {
X	lposition--;
X	xputc(ch);
X    }
X
X    /* otherwise, check for a printing character */
X    else if (ch >= ' ' && ch < '\177') {
X	xputc(ch);
X	if (++lposition >= 80)
X	    stputc('\n',stdout);
X    }
X
X    /* otherwise, it must be a nonprinting character */
X    else
X	xputc(ch);
X}
X
X/* stflush - flush the input buffer */
Xstflush()
X{
X    lcount = lindex = 0;
X    stputc('\n',stdout);
X    prompt = 1;
X}
X
X/* xgetc - get a character from the terminal without echo */
Xstatic int xgetc()
X{
X    return (Crawcin() & 0xFF);
X}
X
X/* xputc - put a character to the terminal */
Xstatic xputc(ch)
X  int ch;
X{
X    Crawio(ch);
X}
X
X/* xcheck - get a character if one is available */
Xstatic int xcheck()
X{
X    return (Crawio(0xFF) & 0xFF);
X}
SHAR_EOF
if test 2963 -ne "`wc -c 'ststuff.c'`"
then
	echo shar: error transmitting "'ststuff.c'" '(should have been 2963 characters)'
fi
echo shar: extracting "'xlbfun.c'" '(11528 characters)'
if test -f 'xlbfun.c'
then
	echo shar: over-writing existing file "'xlbfun.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlbfun.c'
X/* xlbfun.c - xlisp basic built-in 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/* external variables */
Xextern NODE *xlstack,*xlenv;
Xextern NODE *s_car,*s_cdr,*s_get,*s_svalue,*s_splist;
Xextern NODE *s_lambda,*s_macro;
Xextern NODE *s_comma,*s_comat;
Xextern char gsprefix[];
Xextern int gsnumber;
X
X/* forward declarations */
XFORWARD NODE *bquote1();
XFORWARD NODE *defun();
XFORWARD NODE *makesymbol();
X
X/* xeval - the built-in function 'eval' */
XNODE *xeval(args)
X  NODE *args;
X{
X    NODE *oldstk,expr,*val;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&expr,NULL);
X
X    /* get the expression to evaluate */
X    expr.n_ptr = xlarg(&args);
X    xllastarg(args);
X
X    /* evaluate the expression */
X    val = xleval(expr.n_ptr);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the expression evaluated */
X    return (val);
X}
X
X/* xapply - the built-in function 'apply' */
XNODE *xapply(args)
X  NODE *args;
X{
X    NODE *oldstk,fun,arglist,*val;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&fun,&arglist,NULL);
X
X    /* get the function and argument list */
X    fun.n_ptr = xlarg(&args);
X    arglist.n_ptr = xlmatch(LIST,&args);
X    xllastarg(args);
X
X    /* if the function is a symbol, get its value */
X    if (symbolp(fun.n_ptr))
X	fun.n_ptr = xleval(fun.n_ptr);
X
X    /* apply the function to the arguments */
X    val = xlapply(fun.n_ptr,arglist.n_ptr);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the expression evaluated */
X    return (val);
X}
X
X/* xfuncall - the built-in function 'funcall' */
XNODE *xfuncall(args)
X  NODE *args;
X{
X    NODE *oldstk,fun,arglist,*val;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&fun,&arglist,NULL);
X
X    /* get the function and argument list */
X    fun.n_ptr = xlarg(&args);
X    arglist.n_ptr = args;
X
X    /* if the function is a symbol, get its value */
X    if (symbolp(fun.n_ptr))
X	fun.n_ptr = xleval(fun.n_ptr);
X
X    /* apply the function to the arguments */
X    val = xlapply(fun.n_ptr,arglist.n_ptr);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the expression evaluated */
X    return (val);
X}
X
X/* xquote - built-in function to quote an expression */
XNODE *xquote(args)
X  NODE *args;
X{
X    NODE *val;
X
X    /* get the argument */
X    val = xlarg(&args);
X    xllastarg(args);
X
X    /* return the quoted expression */
X    return (val);
X}
X
X/* xfunction - built-in function to quote a function */
XNODE *xfunction(args)
X  NODE *args;
X{
X    NODE *val,*n;
X
X    /* get the argument */
X    val = xlarg(&args);
X    xllastarg(args);
X
X    /* create a closure for lambda expressions */
X    if (consp(val) && car(val) == s_lambda) {
X	n = newnode(LIST);
X	rplaca(n,val);
X	rplacd(n,xlenv);
X	val = n;
X    }
X
X    /* otherwise, get the value of a symbol */
X    else if (symbolp(val))
X	val = xlgetvalue(val);
X
X    /* otherwise, its an error */
X    else
X	xlerror("not a function",val);
X
X    /* return the function */
X    return (val);
X}
X
X/* xbquote - back quote function */
XNODE *xbquote(args)
X  NODE *args;
X{
X    NODE *oldstk,expr,*val;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&expr,NULL);
X
X    /* get the expression */
X    expr.n_ptr = xlarg(&args);
X    xllastarg(args);
X
X    /* fill in the template */
X    val = bquote1(expr.n_ptr);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the result */
X    return (val);
X}
X
X/* bquote1 - back quote helper function */
XLOCAL NODE *bquote1(expr)
X  NODE *expr;
X{
X    NODE *oldstk,val,list,*last,*new;
X
X    /* handle atoms */
X    if (atom(expr))
X	val.n_ptr = expr;
X
X    /* handle (comma <expr>) */
X    else if (car(expr) == s_comma) {
X	if (atom(cdr(expr)))
X	    xlfail("bad comma expression");
X	val.n_ptr = xleval(car(cdr(expr)));
X    }
X
X    /* handle ((comma-at <expr>) ... ) */
X    else if (consp(car(expr)) && car(car(expr)) == s_comat) {
X	oldstk = xlsave(&list,&val,NULL);
X	if (atom(cdr(car(expr))))
X	    xlfail("bad comma-at expression");
X	list.n_ptr = xleval(car(cdr(car(expr))));
X	for (last = NIL; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
X	    new = newnode(LIST);
X	    rplaca(new,car(list.n_ptr));
X	    if (last)
X		rplacd(last,new);
X	    else
X		val.n_ptr = new;
X	    last = new;
X	}
X	if (last)
X	    rplacd(last,bquote1(cdr(expr)));
X	else
X	    val.n_ptr = bquote1(cdr(expr));
X	xlstack = oldstk;
X    }
X
X    /* handle any other list */
X    else {
X	oldstk = xlsave(&val,NULL);
X	val.n_ptr = newnode(LIST);
X	rplaca(val.n_ptr,bquote1(car(expr)));
X	rplacd(val.n_ptr,bquote1(cdr(expr)));
X	xlstack = oldstk;
X    }
X
X    /* return the result */
X    return (val.n_ptr);
X}
X
X/* xset - built-in function set */
XNODE *xset(args)
X  NODE *args;
X{
X    NODE *sym,*val;
X
X    /* get the symbol and new value */
X    sym = xlmatch(SYM,&args);
X    val = xlarg(&args);
X    xllastarg(args);
X
X    /* assign the symbol the value of argument 2 and the return value */
X    xlsetvalue(sym,val);
X
X    /* return the result value */
X    return (val);
X}
X
X/* xsetq - built-in function setq */
XNODE *xsetq(args)
X  NODE *args;
X{
X    NODE *oldstk,arg,sym,val;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&arg,&sym,&val,NULL);
X
X    /* initialize */
X    arg.n_ptr = args;
X
X    /* handle each pair of arguments */
X    while (arg.n_ptr) {
X	sym.n_ptr = xlmatch(SYM,&arg.n_ptr);
X	val.n_ptr = xlevarg(&arg.n_ptr);
X	xlsetvalue(sym.n_ptr,val.n_ptr);
X    }
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the result value */
X    return (val.n_ptr);
X}
X
X/* xsetf - built-in function 'setf' */
XNODE *xsetf(args)
X  NODE *args;
X{
X    NODE *oldstk,arg,place,value;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&arg,&place,&value,NULL);
X
X    /* initialize */
X    arg.n_ptr = args;
X
X    /* handle each pair of arguments */
X    while (arg.n_ptr) {
X
X	/* get place and value */
X	place.n_ptr = xlarg(&arg.n_ptr);
X	value.n_ptr = xlevarg(&arg.n_ptr);
X
X	/* check the place form */
X	if (symbolp(place.n_ptr))
X	    xlsetvalue(place.n_ptr,value.n_ptr);
X	else if (consp(place.n_ptr))
X	    placeform(place.n_ptr,value.n_ptr);
X	else
X	    xlfail("bad place form");
X    }
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the value */
X    return (value.n_ptr);
X}
X
X/* placeform - handle a place form other than a symbol */
XLOCAL placeform(place,value)
X  NODE *place,*value;
X{
X    NODE *fun,*oldstk,arg1,arg2;
X
X    /* check the function name */
X    if ((fun = xlmatch(SYM,&place)) == s_get) {
X	oldstk = xlsave(&arg1,&arg2,NULL);
X	arg1.n_ptr = xlevmatch(SYM,&place);
X	arg2.n_ptr = xlevmatch(SYM,&place);
X	xllastarg(place);
X	xlputprop(arg1.n_ptr,value,arg2.n_ptr);
X	xlstack = oldstk;
X    }
X    else if (fun == s_svalue || fun == s_splist) {
X	oldstk = xlsave(&arg1,NULL);
X	arg1.n_ptr = xlevmatch(SYM,&place);
X	xllastarg(place);
X	if (fun == s_svalue)
X	    setvalue(arg1.n_ptr,value);
X	else
X	    rplacd(arg1.n_ptr->n_symplist,value);
X	xlstack = oldstk;
X    }
X    else if (fun == s_car || fun == s_cdr) {
X	oldstk = xlsave(&arg1,NULL);
X	arg1.n_ptr = xlevmatch(LIST,&place);
X	xllastarg(place);
X	if (consp(arg1.n_ptr))
X	    if (fun == s_car)
X		rplaca(arg1.n_ptr,value);
X	    else
X		rplacd(arg1.n_ptr,value);
X	xlstack = oldstk;
X    }
X    else
X	xlfail("bad place form");
X}
X
X/* xdefun - built-in function 'defun' */
XNODE *xdefun(args)
X  NODE *args;
X{
X    return (defun(args,s_lambda));
X}
X
X/* xdefmacro - built-in function 'defmacro' */
XNODE *xdefmacro(args)
X  NODE *args;
X{
X    return (defun(args,s_macro));
X}
X
X/* defun - internal function definition routine */
XLOCAL NODE *defun(args,type)
X  NODE *args,*type;
X{
X    NODE *oldstk,sym,fargs,closure,*fun;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&sym,&fargs,&closure,NULL);
X
X    /* get the function symbol and formal argument list */
X    sym.n_ptr = xlmatch(SYM,&args);
X    fargs.n_ptr = xlmatch(LIST,&args);
X
X    /* create a new function definition */
X    closure.n_ptr = newnode(LIST);
X    rplaca(closure.n_ptr,fun = newnode(LIST));
X    rplacd(closure.n_ptr,xlenv);
X    rplaca(fun,type);
X    rplacd(fun,newnode(LIST));
X    rplaca(cdr(fun),fargs.n_ptr);
X    rplacd(cdr(fun),args);
X
X    /* make the symbol point to a new function definition */
X    xlsetvalue(sym.n_ptr,closure.n_ptr);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the function symbol */
X    return (sym.n_ptr);
X}
X
X/* xgensym - generate a symbol */
XNODE *xgensym(args)
X  NODE *args;
X{
X    char sym[STRMAX+1];
X    NODE *x;
X
X    /* get the prefix or number */
X    if (args) {
X	x = xlarg(&args);
X	switch (ntype(x)) {
X	case STR:
X		strcpy(gsprefix,x->n_str);
X		break;
X	case INT:
X		gsnumber = x->n_int;
X		break;
X	default:
X		xlerror("bad argument type",x);
X	}
X    }
X    xllastarg(args);
X
X    /* create the pname of the new symbol */
X    sprintf(sym,"%s%d",gsprefix,gsnumber++);
X
X    /* make a symbol with this print name */
X    return (xlmakesym(sym,DYNAMIC));
X}
X
X/* xmakesymbol - make a new uninterned symbol */
XNODE *xmakesymbol(args)
X  NODE *args;
X{
X    return (makesymbol(args,FALSE));
X}
X
X/* xintern - make a new interned symbol */
XNODE *xintern(args)
X  NODE *args;
X{
X    return (makesymbol(args,TRUE));
X}
X
X/* makesymbol - make a new symbol */
XLOCAL NODE *makesymbol(args,iflag)
X  NODE *args; int iflag;
X{
X    NODE *oldstk,pname,*val;
X    char *str;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&pname,NULL);
X
X    /* get the print name of the symbol to intern */
X    pname.n_ptr = xlmatch(STR,&args);
X    xllastarg(args);
X
X    /* make the symbol */
X    str = pname.n_ptr->n_str;
X    val = (iflag ? xlenter(str,DYNAMIC) : xlmakesym(str,DYNAMIC));
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the symbol */
X    return (val);
X}
X
X/* xsymname - get the print name of a symbol */
XNODE *xsymname(args)
X  NODE *args;
X{
X    NODE *sym;
X
X    /* get the symbol */
X    sym = xlmatch(SYM,&args);
X    xllastarg(args);
X
X    /* return the print name */
X    return (car(sym->n_symplist));
X}
X
X/* xsymvalue - get the value of a symbol */
XNODE *xsymvalue(args)
X  NODE *args;
X{
X    NODE *sym;
X
X    /* get the symbol */
X    sym = xlmatch(SYM,&args);
X    xllastarg(args);
X
X    /* return its value */
X    return (xlgetvalue(sym));
X}
X
X/* xsymplist - get the property list of a symbol */
XNODE *xsymplist(args)
X  NODE *args;
X{
X    NODE *sym;
X
X    /* get the symbol */
X    sym = xlmatch(SYM,&args);
X    xllastarg(args);
X
X    /* return the property list */
X    return (cdr(sym->n_symplist));
X}
X
X/* xget - get the value of a property */
XNODE *xget(args)
X  NODE *args;
X{
X    NODE *sym,*prp;
X
X    /* get the symbol and property */
X    sym = xlmatch(SYM,&args);
X    prp = xlmatch(SYM,&args);
X    xllastarg(args);
X
X    /* retrieve the property value */
X    return (xlgetprop(sym,prp));
X}
X
X/* xputprop - set the value of a property */
XNODE *xputprop(args)
X  NODE *args;
X{
X    NODE *sym,*val,*prp;
X
X    /* get the symbol and property */
X    sym = xlmatch(SYM,&args);
X    val = xlarg(&args);
X    prp = xlmatch(SYM,&args);
X    xllastarg(args);
X
X    /* set the property value */
X    xlputprop(sym,val,prp);
X
X    /* return the value */
X    return (val);
X}
X
X/* xremprop - remove a property value from a property list */
XNODE *xremprop(args)
X  NODE *args;
X{
X    NODE *sym,*prp;
X
X    /* get the symbol and property */
X    sym = xlmatch(SYM,&args);
X    prp = xlmatch(SYM,&args);
X    xllastarg(args);
X
X    /* remove the property */
X    xlremprop(sym,prp);
X
X    /* return nil */
X    return (NIL);
X}
SHAR_EOF
if test 11528 -ne "`wc -c 'xlbfun.c'`"
then
	echo shar: error transmitting "'xlbfun.c'" '(should have been 11528 characters)'
fi
echo shar: extracting "'xlcont.c'" '(17682 characters)'
if test -f 'xlcont.c'
then
	echo shar: over-writing existing file "'xlcont.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlcont.c'
X/* xlcont - xlisp control built-in 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/* external variables */
Xextern NODE *xlstack,*xlenv,*xlvalue;
Xextern NODE *s_unbound;
Xextern NODE *s_evalhook,*s_applyhook;
Xextern NODE *true;
X
X/* external routines */
Xextern NODE *xlxeval();
X
X/* forward declarations */
XFORWARD NODE *let();
XFORWARD NODE *prog();
XFORWARD NODE *progx();
XFORWARD NODE *doloop();
X
X/* xcond - built-in function 'cond' */
XNODE *xcond(args)
X  NODE *args;
X{
X    NODE *oldstk,arg,list,*val;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&arg,&list,NULL);
X
X    /* initialize */
X    arg.n_ptr = args;
X
X    /* initialize the return value */
X    val = NIL;
X
X    /* find a predicate that is true */
X    while (arg.n_ptr) {
X
X	/* get the next conditional */
X	list.n_ptr = xlmatch(LIST,&arg.n_ptr);
X
X	/* evaluate the predicate part */
X	if (xlevarg(&list.n_ptr)) {
X
X	    /* evaluate each expression */
X	    while (list.n_ptr)
X		val = xlevarg(&list.n_ptr);
X
X	    /* exit the loop */
X	    break;
X	}
X    }
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the value */
X    return (val);
X}
X
X/* xand - built-in function 'and' */
XNODE *xand(args)
X  NODE *args;
X{
X    NODE *oldstk,arg,*val;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&arg,NULL);
X
X    /* initialize */
X    arg.n_ptr = args;
X    val = true;
X
X    /* evaluate each argument */
X    while (arg.n_ptr)
X
X	/* get the next argument */
X	if ((val = xlevarg(&arg.n_ptr)) == NIL)
X	    break;
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the result value */
X    return (val);
X}
X
X/* xor - built-in function 'or' */
XNODE *xor(args)
X  NODE *args;
X{
X    NODE *oldstk,arg,*val;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&arg,NULL);
X
X    /* initialize */
X    arg.n_ptr = args;
X    val = NIL;
X
X    /* evaluate each argument */
X    while (arg.n_ptr)
X	if ((val = xlevarg(&arg.n_ptr)))
X	    break;
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the result value */
X    return (val);
X}
X
X/* xif - built-in function 'if' */
XNODE *xif(args)
X  NODE *args;
X{
X    NODE *oldstk,testexpr,thenexpr,elseexpr,*val;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&testexpr,&thenexpr,&elseexpr,NULL);
X
X    /* get the test expression, then clause and else clause */
X    testexpr.n_ptr = xlarg(&args);
X    thenexpr.n_ptr = xlarg(&args);
X    elseexpr.n_ptr = (args ? xlarg(&args) : NIL);
X    xllastarg(args);
X
X    /* evaluate the appropriate clause */
X    val = xleval(xleval(testexpr.n_ptr) ? thenexpr.n_ptr : elseexpr.n_ptr);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the last value */
X    return (val);
X}
X
X/* xlet - built-in function 'let' */
XNODE *xlet(args)
X  NODE *args;
X{
X    return (let(args,TRUE));
X}
X
X/* xletstar - built-in function 'let*' */
XNODE *xletstar(args)
X  NODE *args;
X{
X    return (let(args,FALSE));
X}
X
X/* let - common let routine */
XLOCAL NODE *let(args,pflag)
X  NODE *args; int pflag;
X{
X    NODE *oldstk,newenv,arg,*val;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&newenv,&arg,NULL);
X
X    /* initialize */
X    arg.n_ptr = args;
X
X    /* create a new environment frame */
X    newenv.n_ptr = xlframe(xlenv);
X
X    /* get the list of bindings and bind the symbols */
X    if (!pflag) xlenv = newenv.n_ptr;
X    dobindings(xlmatch(LIST,&arg.n_ptr),newenv.n_ptr);
X    if (pflag) xlenv = newenv.n_ptr;
X
X    /* execute the code */
X    for (val = NIL; arg.n_ptr; )
X	val = xlevarg(&arg.n_ptr);
X
X    /* unbind the arguments */
X    xlenv = cdr(xlenv);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the result */
X    return (val);
X}
X
X/* xprog - built-in function 'prog' */
XNODE *xprog(args)
X  NODE *args;
X{
X    return (prog(args,TRUE));
X}
X
X/* xprogstar - built-in function 'prog*' */
XNODE *xprogstar(args)
X  NODE *args;
X{
X    return (prog(args,FALSE));
X}
X
X/* prog - common prog routine */
XLOCAL NODE *prog(args,pflag)
X  NODE *args; int pflag;
X{
X    NODE *oldstk,newenv,arg,*val;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&newenv,&arg,NULL);
X
X    /* initialize */
X    arg.n_ptr = args;
X
X    /* create a new environment frame */
X    newenv.n_ptr = xlframe(xlenv);
X
X    /* get the list of bindings and bind the symbols */
X    if (!pflag) xlenv = newenv.n_ptr;
X    dobindings(xlmatch(LIST,&arg.n_ptr),newenv.n_ptr);
X    if (pflag) xlenv = newenv.n_ptr;
X
X    /* execute the code */
X    tagblock(arg.n_ptr,&val);
X
X    /* unbind the arguments */
X    xlenv = cdr(xlenv);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the result */
X    return (val);
X}
X
X/* xgo - built-in function 'go' */
XNODE *xgo(args)
X  NODE *args;
X{
X    NODE *label;
X
X    /* get the target label */
X    label = xlarg(&args);
X    xllastarg(args);
X
X    /* transfer to the label */
X    xlgo(label);
X}
X
X/* xreturn - built-in function 'return' */
XNODE *xreturn(args)
X  NODE *args;
X{
X    NODE *val;
X
X    /* get the return value */
X    val = (args ? xlarg(&args) : NIL);
X    xllastarg(args);
X
X    /* return from the inner most block */
X    xlreturn(val);
X}
X
X/* xprog1 - built-in function 'prog1' */
XNODE *xprog1(args)
X  NODE *args;
X{
X    return (progx(args,1));
X}
X
X/* xprog2 - built-in function 'prog2' */
XNODE *xprog2(args)
X  NODE *args;
X{
X    return (progx(args,2));
X}
X
X/* progx - common progx code */
XLOCAL NODE *progx(args,n)
X  NODE *args; int n;
X{
X    NODE *oldstk,arg,val;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&arg,&val,NULL);
X
X    /* initialize */
X    arg.n_ptr = args;
X
X    /* evaluate the first n expressions */
X    while (n--)
X	val.n_ptr = xlevarg(&arg.n_ptr);
X
X    /* evaluate each remaining argument */
X    while (arg.n_ptr)
X	xlevarg(&arg.n_ptr);
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/* xprogn - built-in function 'progn' */
XNODE *xprogn(args)
X  NODE *args;
X{
X    NODE *oldstk,arg,*val;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&arg,NULL);
X
X    /* initialize */
X    arg.n_ptr = args;
X
X    /* evaluate each remaining argument */
X    for (val = NIL; arg.n_ptr; )
X	val = xlevarg(&arg.n_ptr);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the last test expression value */
X    return (val);
X}
X
X/* xdo - built-in function 'do' */
XNODE *xdo(args)
X  NODE *args;
X{
X    return (doloop(args,TRUE));
X}
X
X/* xdostar - built-in function 'do*' */
XNODE *xdostar(args)
X  NODE *args;
X{
X    return (doloop(args,FALSE));
X}
X
X/* doloop - common do routine */
XLOCAL NODE *doloop(args,pflag)
X  NODE *args; int pflag;
X{
X    NODE *oldstk,newenv,arg,blist,clist,test,*rval;
X    int rbreak;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&newenv,&arg,&blist,&clist,&test,NULL);
X
X    /* initialize */
X    arg.n_ptr = args;
X
X    /* get the list of bindings */
X    blist.n_ptr = xlmatch(LIST,&arg.n_ptr);
X
X    /* create a new environment frame */
X    newenv.n_ptr = xlframe(xlenv);
X
X    /* bind the symbols */
X    if (!pflag) xlenv = newenv.n_ptr;
X    dobindings(blist.n_ptr,newenv.n_ptr);
X    if (pflag) xlenv = newenv.n_ptr;
X
X    /* get the exit test and result forms */
X    clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
X    test.n_ptr = xlarg(&clist.n_ptr);
X
X    /* execute the loop as long as the test is false */
X    rbreak = FALSE;
X    while (xleval(test.n_ptr) == NIL) {
X
X	/* execute the body of the loop */
X	if (tagblock(arg.n_ptr,&rval)) {
X	    rbreak = TRUE;
X	    break;
X	}
X
X	/* update the looping variables */
X	doupdates(blist.n_ptr,pflag);
X    }
X
X    /* evaluate the result expression */
X    if (!rbreak)
X	for (rval = NIL; consp(clist.n_ptr); )
X	    rval = xlevarg(&clist.n_ptr);
X
X    /* unbind the arguments */
X    xlenv = cdr(xlenv);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the result */
X    return (rval);
X}
X
X/* xdolist - built-in function 'dolist' */
XNODE *xdolist(args)
X  NODE *args;
X{
X    NODE *oldstk,arg,clist,sym,list,val,*rval;
X    int rbreak;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&arg,&clist,&sym,&list,&val,NULL);
X
X    /* initialize */
X    arg.n_ptr = args;
X
X    /* get the control list (sym list result-expr) */
X    clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
X    sym.n_ptr = xlmatch(SYM,&clist.n_ptr);
X    list.n_ptr = xlevmatch(LIST,&clist.n_ptr);
X    val.n_ptr = (clist.n_ptr ? xlarg(&clist.n_ptr) : NIL);
X
X    /* initialize the local environment */
X    xlenv = xlframe(xlenv);
X    xlbind(sym.n_ptr,NIL,xlenv);
X
X    /* loop through the list */
X    rbreak = FALSE;
X    for (; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
X
X	/* bind the symbol to the next list element */
X	xlsetvalue(sym.n_ptr,car(list.n_ptr));
X
X	/* execute the loop body */
X	if (tagblock(arg.n_ptr,&rval)) {
X	    rbreak = TRUE;
X	    break;
X	}
X    }
X
X    /* evaluate the result expression */
X    if (!rbreak) {
X	xlsetvalue(sym.n_ptr,NIL);
X	rval = xleval(val.n_ptr);
X    }
X
X    /* unbind the arguments */
X    xlenv = cdr(xlenv);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the result */
X    return (rval);
X}
X
X/* xdotimes - built-in function 'dotimes' */
XNODE *xdotimes(args)
X  NODE *args;
X{
X    NODE *oldstk,arg,clist,sym,val,*rval;
X    int rbreak,cnt,i;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&arg,&clist,&sym,&val,NULL);
X
X    /* initialize */
X    arg.n_ptr = args;
X
X    /* get the control list (sym list result-expr) */
X    clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
X    sym.n_ptr = xlmatch(SYM,&clist.n_ptr);
X    cnt = xlevmatch(INT,&clist.n_ptr)->n_int;
X    val.n_ptr = (clist.n_ptr ? xlarg(&clist.n_ptr) : NIL);
X
X    /* initialize the local environment */
X    xlenv = xlframe(xlenv);
X    xlbind(sym.n_ptr,NIL,xlenv);
X
X    /* loop through for each value from zero to cnt-1 */
X    rbreak = FALSE;
X    for (i = 0; i < cnt; i++) {
X
X	/* bind the symbol to the next list element */
X	xlsetvalue(sym.n_ptr,cvfixnum((FIXNUM)i));
X
X	/* execute the loop body */
X	if (tagblock(arg.n_ptr,&rval)) {
X	    rbreak = TRUE;
X	    break;
X	}
X    }
X
X    /* evaluate the result expression */
X    if (!rbreak) {
X	xlsetvalue(sym.n_ptr,cvfixnum((FIXNUM)cnt));
X	rval = xleval(val.n_ptr);
X    }
X
X    /* unbind the arguments */
X    xlenv = cdr(xlenv);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the result */
X    return (rval);
X}
X
X/* xcatch - built-in function 'catch' */
XNODE *xcatch(args)
X  NODE *args;
X{
X    NODE *oldstk,tag,arg,*val;
X    CONTEXT cntxt;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&tag,&arg,NULL);
X
X    /* initialize */
X    tag.n_ptr = xlevarg(&args);
X    arg.n_ptr = args;
X    val = NIL;
X
X    /* establish an execution context */
X    xlbegin(&cntxt,CF_THROW,tag.n_ptr);
X
X    /* check for 'throw' */
X    if (setjmp(cntxt.c_jmpbuf))
X	val = xlvalue;
X
X    /* otherwise, evaluate the remainder of the arguments */
X    else {
X	while (arg.n_ptr)
X	    val = xlevarg(&arg.n_ptr);
X    }
X    xlend(&cntxt);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the result */
X    return (val);
X}
X
X/* xthrow - built-in function 'throw' */
XNODE *xthrow(args)
X  NODE *args;
X{
X    NODE *tag,*val;
X
X    /* get the tag and value */
X    tag = xlarg(&args);
X    val = (args ? xlarg(&args) : NIL);
X    xllastarg(args);
X
X    /* throw the tag */
X    xlthrow(tag,val);
X}
X
X/* xerror - built-in function 'error' */
XNODE *xerror(args)
X  NODE *args;
X{
X    char *emsg; NODE *arg;
X
X    /* get the error message and the argument */
X    emsg = xlmatch(STR,&args)->n_str;
X    arg = (args ? xlarg(&args) : s_unbound);
X    xllastarg(args);
X
X    /* signal the error */
X    xlerror(emsg,arg);
X}
X
X/* xcerror - built-in function 'cerror' */
XNODE *xcerror(args)
X  NODE *args;
X{
X    char *cmsg,*emsg; NODE *arg;
X
X    /* get the correction message, the error message, and the argument */
X    cmsg = xlmatch(STR,&args)->n_str;
X    emsg = xlmatch(STR,&args)->n_str;
X    arg = (args ? xlarg(&args) : s_unbound);
X    xllastarg(args);
X
X    /* signal the error */
X    xlcerror(cmsg,emsg,arg);
X
X    /* return nil */
X    return (NIL);
X}
X
X/* xbreak - built-in function 'break' */
XNODE *xbreak(args)
X  NODE *args;
X{
X    char *emsg; NODE *arg;
X
X    /* get the error message */
X    emsg = (args ? xlmatch(STR,&args)->n_str : "**BREAK**");
X    arg = (args ? xlarg(&args) : s_unbound);
X    xllastarg(args);
X
X    /* enter the break loop */
X    xlbreak(emsg,arg);
X
X    /* return nil */
X    return (NIL);
X}
X
X/* xcleanup - built-in function 'clean-up' */
XNODE *xcleanup(args)
X  NODE *args;
X{
X    xllastarg(args);
X    xlcleanup();
X}
X
X/* xcontinue - built-in function 'continue' */
XNODE *xcontinue(args)
X  NODE *args;
X{
X    xllastarg(args);
X    xlcontinue();
X}
X
X/* xerrset - built-in function 'errset' */
XNODE *xerrset(args)
X  NODE *args;
X{
X    NODE *oldstk,expr,flag,*val;
X    CONTEXT cntxt;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&expr,&flag,NULL);
X
X    /* get the expression and the print flag */
X    expr.n_ptr = xlarg(&args);
X    flag.n_ptr = (args ? xlarg(&args) : true);
X    xllastarg(args);
X
X    /* establish an execution context */
X    xlbegin(&cntxt,CF_ERROR,flag.n_ptr);
X
X    /* check for error */
X    if (setjmp(cntxt.c_jmpbuf))
X	val = NIL;
X
X    /* otherwise, evaluate the expression */
X    else {
X	expr.n_ptr = xleval(expr.n_ptr);
X	val = newnode(LIST);
X	rplaca(val,expr.n_ptr);
X    }
X    xlend(&cntxt);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the result */
X    return (val);
X}
X
X/* xevalhook - eval hook function */
XNODE *xevalhook(args)
X  NODE *args;
X{
X    NODE *oldstk,expr,ehook,ahook,env,newehook,newahook,newenv,*val;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&expr,&ehook,&ahook,&env,&newehook,&newahook,&newenv,NULL);
X
X    /* get the expression, the new hook functions and the environment */
X    expr.n_ptr = xlarg(&args);
X    newehook.n_ptr = xlarg(&args);
X    newahook.n_ptr = xlarg(&args);
X    newenv.n_ptr = (args ? xlarg(&args) : xlenv);
X    xllastarg(args);
X
X    /* bind *evalhook* and *applyhook* to the hook functions */
X    ehook.n_ptr = getvalue(s_evalhook);
X    setvalue(s_evalhook,newehook.n_ptr);
X    ahook.n_ptr = getvalue(s_applyhook);
X    setvalue(s_applyhook,newahook.n_ptr);
X    env.n_ptr = xlenv;
X    xlenv = newenv.n_ptr;
X
X    /* evaluate the expression (bypassing *evalhook*) */
X    val = xlxeval(expr.n_ptr);
X
X    /* unbind the hook variables */
X    setvalue(s_evalhook,ehook.n_ptr);
X    setvalue(s_applyhook,ahook.n_ptr);
X    xlenv = env.n_ptr;
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the result */
X    return (val);
X}
X
X/* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
XLOCAL dobindings(blist,env)
X  NODE *blist,*env;
X{
X    NODE *oldstk,list,bnd,sym,val;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&list,&bnd,&sym,&val,NULL);
X
X    /* bind each symbol in the list of bindings */
X    for (list.n_ptr = blist; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
X
X	/* get the next binding */
X	bnd.n_ptr = car(list.n_ptr);
X
X	/* handle a symbol */
X	if (symbolp(bnd.n_ptr)) {
X	    sym.n_ptr = bnd.n_ptr;
X	    val.n_ptr = NIL;
X	}
X
X	/* handle a list of the form (symbol expr) */
X	else if (consp(bnd.n_ptr)) {
X	    sym.n_ptr = xlmatch(SYM,&bnd.n_ptr);
X	    val.n_ptr = xlevarg(&bnd.n_ptr);
X	}
X	else
X	    xlfail("bad binding");
X
X	/* bind the value to the symbol */
X	xlbind(sym.n_ptr,val.n_ptr,env);
X    }
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X}
X
X/* doupdates - handle updates for do/do* */
Xdoupdates(blist,pflag)
X  NODE *blist; int pflag;
X{
X    NODE *oldstk,plist,list,bnd,sym,val,*p;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&plist,&list,&bnd,&sym,&val,NULL);
X
X    /* bind each symbol in the list of bindings */
X    for (list.n_ptr = blist; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
X
X	/* get the next binding */
X	bnd.n_ptr = car(list.n_ptr);
X
X	/* handle a list of the form (symbol expr) */
X	if (consp(bnd.n_ptr)) {
X	    sym.n_ptr = xlmatch(SYM,&bnd.n_ptr);
X	    bnd.n_ptr = cdr(bnd.n_ptr);
X	    if (bnd.n_ptr) {
X		val.n_ptr = xlevarg(&bnd.n_ptr);
X		if (pflag) {
X		    p = newnode(LIST);
X		    rplacd(p,plist.n_ptr);
X		    plist.n_ptr = p;
X		    rplaca(p,newnode(LIST));
X		    rplaca(car(p),sym.n_ptr);
X		    rplacd(car(p),val.n_ptr);
X		}
X		else
X		    xlsetvalue(sym.n_ptr,val.n_ptr);
X	    }
X	}
X    }
X
X    /* set the values for parallel updates */
X    for (; plist.n_ptr; plist.n_ptr = cdr(plist.n_ptr))
X	xlsetvalue(car(car(plist.n_ptr)),cdr(car(plist.n_ptr)));
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X}
X
X/* tagblock - execute code within a block and tagbody */
Xint tagblock(code,pval)
X  NODE *code,**pval;
X{
X    NODE *oldstk,arg;
X    CONTEXT cntxt;
X    int type,sts;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&arg,NULL);
X
X    /* initialize */
X    arg.n_ptr = code;
X
X    /* establish an execution context */
X    xlbegin(&cntxt,CF_GO|CF_RETURN,arg.n_ptr);
X
X    /* check for a 'return' */
X    if ((type = setjmp(cntxt.c_jmpbuf)) == CF_RETURN) {
X	*pval = xlvalue;
X	sts = TRUE;
X    }
X
X    /* otherwise, enter the body */
X    else {
X
X	/* check for a 'go' */
X	if (type == CF_GO)
X	    arg.n_ptr = xlvalue;
X
X	/* evaluate each expression in the body */
X	while (consp(arg.n_ptr))
X	    if (consp(car(arg.n_ptr)))
X		xlevarg(&arg.n_ptr);
X	    else
X		arg.n_ptr = cdr(arg.n_ptr);
X
X	/* fell out the bottom of the loop */
X	*pval = NIL;
X	sts = FALSE;
X    }
X    xlend(&cntxt);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return status */
X    return (sts);
X}
SHAR_EOF
if test 17682 -ne "`wc -c 'xlcont.c'`"
then
	echo shar: error transmitting "'xlcont.c'" '(should have been 17682 characters)'
fi
echo shar: extracting "'xldbug.c'" '(4177 characters)'
if test -f 'xldbug.c'
then
	echo shar: over-writing existing file "'xldbug.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xldbug.c'
X/* xldebug - xlisp debugging support */
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 long total;
Xextern int xldebug;
Xextern int xltrace;
Xextern NODE *s_unbound;
Xextern NODE *s_stdin,*s_stdout;
Xextern NODE *s_tracenable,*s_tlimit,*s_breakenable;
Xextern NODE *xlstack;
Xextern NODE *true;
Xextern NODE **trace_stack;
Xextern char buf[];
X
X/* external routines */
Xextern char *malloc();
X
X/* forward declarations */
XFORWARD NODE *stacktop();
X
X/* xlfail - xlisp error handler */
Xxlfail(emsg)
X  char *emsg;
X{
X    xlerror(emsg,stacktop());
X}
X
X/* xlabort - xlisp serious error handler */
Xxlabort(emsg)
X  char *emsg;
X{
X    xlsignal(emsg,s_unbound);
X}
X
X/* xlbreak - enter a break loop */
Xxlbreak(emsg,arg)
X  char *emsg; NODE *arg;
X{
X    breakloop("break",NULL,emsg,arg,TRUE);
X}
X
X/* xlerror - handle a fatal error */
Xxlerror(emsg,arg)
X  char *emsg; NODE *arg;
X{
X    doerror(NULL,emsg,arg,FALSE);
X}
X
X/* xlcerror - handle a recoverable error */
Xxlcerror(cmsg,emsg,arg)
X  char *cmsg,*emsg; NODE *arg;
X{
X    doerror(cmsg,emsg,arg,TRUE);
X}
X
X/* xlerrprint - print an error message */
Xxlerrprint(hdr,cmsg,emsg,arg)
X  char *hdr,*cmsg,*emsg; NODE *arg;
X{
X    sprintf(buf,"%s: %s",hdr,emsg); stdputstr(buf);
X    if (arg != s_unbound) { stdputstr(" - "); stdprint(arg); }
X    else xlterpri(s_stdout->n_symvalue);
X    if (cmsg) { sprintf(buf,"if continued: %s\n",cmsg); stdputstr(buf); }
X}
X
X/* doerror - handle xlisp errors */
XLOCAL doerror(cmsg,emsg,arg,cflag)
X  char *cmsg,*emsg; NODE *arg; int cflag;
X{
X    /* make sure the break loop is enabled */
X    if (getvalue(s_breakenable) == NIL)
X	xlsignal(emsg,arg);
X
X    /* call the debug read-eval-print loop */
X    breakloop("error",cmsg,emsg,arg,cflag);
X}
X
X/* breakloop - the debug read-eval-print loop */
XLOCAL int breakloop(hdr,cmsg,emsg,arg,cflag)
X  char *hdr,*cmsg,*emsg; NODE *arg; int cflag;
X{
X    NODE *oldstk,expr,*val;
X    CONTEXT cntxt;
X    int type;
X
X    /* print the error message */
X    xlerrprint(hdr,cmsg,emsg,arg);
X
X    /* flush the input buffer */
X    xlflush();
X
X    /* do the back trace */
X    if (getvalue(s_tracenable)) {
X	val = getvalue(s_tlimit);
X	xlbaktrace(fixp(val) ? (int)val->n_int : -1);
X    }
X
X    /* create a new stack frame */
X    oldstk = xlsave(&expr,NULL);
X
X    /* increment the debug level */
X    xldebug++;
X
X    /* debug command processing loop */
X    xlbegin(&cntxt,CF_ERROR|CF_CLEANUP|CF_CONTINUE,true);
X    for (type = 0; type == 0; ) {
X
X	/* setup the continue trap */
X	if (type = setjmp(cntxt.c_jmpbuf))
X	    switch (type) {
X	    case CF_ERROR:
X		    xlflush();
X		    type = 0;
X		    continue;
X	    case CF_CLEANUP:
X		    continue;
X	    case CF_CONTINUE:
X		    if (cflag) continue;
X		    else xlabort("this error can't be continued");
X	    }
X
X	/* read an expression and check for eof */
X	if (!xlread(getvalue(s_stdin),&expr.n_ptr)) {
X	    type = CF_CLEANUP;
X	    break;
X	}
X
X	/* evaluate the expression */
X	expr.n_ptr = xleval(expr.n_ptr);
X
X	/* print it */
X	xlprint(getvalue(s_stdout),expr.n_ptr,TRUE);
X	xlterpri(getvalue(s_stdout));
X    }
X    xlend(&cntxt);
X
X    /* decrement the debug level */
X    xldebug--;
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* continue the next higher break loop on clean-up */
X    if (type == CF_CLEANUP)
X	xlsignal("quit from break loop",s_unbound);
X}
X
X/* tpush - add an entry to the trace stack */
Xxltpush(nptr)
X    NODE *nptr;
X{
X    if (++xltrace < TDEPTH)
X	trace_stack[xltrace] = nptr;
X}
X
X/* tpop - pop an entry from the trace stack */
Xxltpop()
X{
X    xltrace--;
X}
X
X/* stacktop - return the top node on the stack */
XLOCAL NODE *stacktop()
X{
X    return (xltrace >= 0 && xltrace < TDEPTH ? trace_stack[xltrace] : s_unbound);
X}
X
X/* baktrace - do a back trace */
Xxlbaktrace(n)
X  int n;
X{
X    int i;
X
X    for (i = xltrace; (n < 0 || n--) && i >= 0; i--)
X	if (i < TDEPTH)
X	    stdprint(trace_stack[i]);
X}
X
X/* xldinit - debug initialization routine */
Xxldinit()
X{
X    if ((trace_stack = (NODE **) malloc(TSTKSIZE)) == NULL)
X	xlabort("insufficient memory");
X    total += (long) TSTKSIZE;
X    xltrace = -1;
X    xldebug = 0;
X}
SHAR_EOF
if test 4177 -ne "`wc -c 'xldbug.c'`"
then
	echo shar: error transmitting "'xldbug.c'" '(should have been 4177 characters)'
fi
echo shar: extracting "'xldmem.c'" '(7170 characters)'
if test -f 'xldmem.c'
then
	echo shar: over-writing existing file "'xldmem.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xldmem.c'
X/* xldmem - xlisp dynamic memory management 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/* useful definitions */
X#define ALLOCSIZE (sizeof(struct segment) + (anodes-1) * sizeof(NODE))
X
X/* external variables */
Xextern NODE *oblist,*keylist;
Xextern NODE *xlstack;
Xextern NODE *xlenv;
Xextern long total;
Xextern int anodes,nnodes,nsegs,nfree,gccalls;
Xextern struct segment *segs;
Xextern NODE *fnodes;
Xextern char buf[];
X
X/* external procedures */
Xextern char *malloc();
Xextern char *calloc();
X
X/* newnode - allocate a new node */
XNODE *newnode(type)
X  int type;
X{
X    NODE *nnode;
X
X    /* get a free node */
X    if ((nnode = fnodes) == NIL) {
X	gc();
X	if ((nnode = fnodes) == NIL)
X	    xlabort("insufficient node space");
X    }
X
X    /* unlink the node from the free list */
X    fnodes = cdr(nnode);
X    nfree -= 1;
X
X    /* initialize the new node */
X    nnode->n_type = type;
X    rplacd(nnode,NIL);
X
X    /* return the new node */
X    return (nnode);
X}
X
X/* cvfixnum - convert an integer to a fixnum node */
XNODE *cvfixnum(n)
X  FIXNUM n;
X{
X    NODE *val;
X    val = newnode(INT);
X    val->n_int = n;
X    return (val);
X}
X
X/* cvflonum - convert a floating point number to a flonum node */
XNODE *cvflonum(n)
X  FLONUM n;
X{
X    NODE *val;
X    val = newnode(FLOAT);
X    val->n_float = n;
X    return (val);
X}
X
X/* stralloc - allocate memory for a string adding a byte for the terminator */
Xchar *stralloc(size)
X  int size;
X{
X    char *sptr;
X
X    /* allocate memory for the string copy */
X    if ((sptr = malloc(size+1)) == NULL) {
X	gc();
X	if ((sptr = malloc(size+1)) == NULL)
X	    xlfail("insufficient string space");
X    }
X    total += (long) (size+1);
X
X    /* return the new string memory */
X    return (sptr);
X}
X
X/* strsave - generate a dynamic copy of a string */
Xchar *strsave(str)
X  char *str;
X{
X    char *sptr;
X
X    /* create a new string */
X    sptr = stralloc(strlen(str));
X    strcpy(sptr,str);
X
X    /* return the new string */
X    return (sptr);
X}
X
X/* strfree - free string memory */
Xstrfree(str)
X  char *str;
X{
X    total -= (long) (strlen(str)+1);
X    free(str);
X}
X
X/* gc - garbage collect */
Xgc()
X{
X    NODE *p;
X
X    /* mark all accessible nodes */
X    mark(oblist); mark(keylist);
X    mark(xlenv);
X
X    /* mark the evaluation stack */
X    for (p = xlstack; p; p = cdr(p))
X	mark(car(p));
X
X    /* sweep memory collecting all unmarked nodes */
X    sweep();
X
X    /* if there's still nothing available, allocate more memory */
X    if (fnodes == NIL)
X	addseg();
X
X    /* count the gc call */
X    gccalls++;
X}
X
X/* mark - mark all accessible nodes */
XLOCAL mark(ptr)
X  NODE *ptr;
X{
X    NODE *this,*prev,*tmp;
X
X    /* just return on nil */
X    if (ptr == NIL)
X	return;
X
X    /* initialize */
X    prev = NIL;
X    this = ptr;
X
X    /* mark this list */
X    while (TRUE) {
X
X	/* descend as far as we can */
X	while (TRUE) {
X
X	    /* check for this node being marked */
X	    if (this->n_flags & MARK)
X		break;
X
X	    /* mark it and its descendants */
X	    else {
X
X		/* mark the node */
X		this->n_flags |= MARK;
X
X		/* follow the left sublist if there is one */
X		if (livecar(this)) {
X		    this->n_flags |= LEFT;
X		    tmp = prev;
X		    prev = this;
X		    this = car(prev);
X		    rplaca(prev,tmp);
X		}
X
X		/* otherwise, follow the right sublist if there is one */
X		else if (livecdr(this)) {
X		    this->n_flags &= ~LEFT;
X		    tmp = prev;
X		    prev = this;
X		    this = cdr(prev);
X		    rplacd(prev,tmp);
X		}
X		else
X		    break;
X	    }
X	}
X
X	/* backup to a point where we can continue descending */
X	while (TRUE) {
X
X	    /* check for termination condition */
X	    if (prev == NIL)
X		return;
X
X	    /* check for coming from the left side */
X	    if (prev->n_flags & LEFT)
X		if (livecdr(prev)) {
X		    prev->n_flags &= ~LEFT;
X		    tmp = car(prev);
X		    rplaca(prev,this);
X		    this = cdr(prev);
X		    rplacd(prev,tmp);
X		    break;
X		}
X		else {
X		    tmp = prev;
X		    prev = car(tmp);
X		    rplaca(tmp,this);
X		    this = tmp;
X		}
X
X	    /* otherwise, came from the right side */
X	    else {
X		tmp = prev;
X		prev = cdr(tmp);
X		rplacd(tmp,this);
X		this = tmp;
X	    }
X	}
X    }
X}
X
X/* sweep - sweep all unmarked nodes and add them to the free list */
XLOCAL sweep()
X{
X    struct segment *seg;
X    NODE *p;
X    int n;
X
X    /* empty the free list */
X    fnodes = NIL;
X    nfree = 0;
X
X    /* add all unmarked nodes */
X    for (seg = segs; seg != NULL; seg = seg->sg_next) {
X	p = &seg->sg_nodes[0];
X	for (n = seg->sg_size; n--; p++)
X	    if (!(p->n_flags & MARK)) {
X		switch (ntype(p)) {
X		case STR:
X			if (p->n_strtype == DYNAMIC && p->n_str != NULL)
X			    strfree(p->n_str);
X			break;
X		case FPTR:
X			if (p->n_fp)
X			    fclose(p->n_fp);
X			break;
X		}
X		p->n_type = FREE;
X		p->n_flags = 0;
X		rplaca(p,NIL);
X		rplacd(p,fnodes);
X		fnodes = p;
X		nfree++;
X	    }
X	    else
X		p->n_flags &= ~(MARK | LEFT);
X    }
X}
X
X/* addseg - add a segment to the available memory */
Xint addseg()
X{
X    struct segment *newseg;
X    NODE *p;
X    int n;
X
X    /* check for zero allocation */
X    if (anodes == 0)
X	return (FALSE);
X
X    /* allocate a new segment */
X    if ((newseg = (struct segment *) calloc(1,ALLOCSIZE)) != NULL) {
X
X	/* initialize the new segment */
X	newseg->sg_size = anodes;
X	newseg->sg_next = segs;
X	segs = newseg;
X
X	/* add each new node to the free list */
X	p = &newseg->sg_nodes[0];
X	for (n = anodes; n--; ) {
X	    rplacd(p,fnodes);
X	    fnodes = p++;
X	}
X
X	/* update the statistics */
X	total += (long) ALLOCSIZE;
X	nnodes += anodes;
X	nfree += anodes;
X	nsegs++;
X
X	/* return successfully */
X	return (TRUE);
X    }
X    else
X	return (FALSE);
X}
X 
X/* livecar - do we need to follow the car? */
XLOCAL int livecar(n)
X  NODE *n;
X{
X    switch (ntype(n)) {
X    case SUBR:
X    case FSUBR:
X    case INT:
X    case FLOAT:
X    case STR:
X    case FPTR:
X	    return (FALSE);
X    case SYM:
X    case LIST:
X    case OBJ:
X	    return (car(n) != NIL);
X    default:
X	    printf("bad node type (%d) found during left scan\n",ntype(n));
X	    exit();
X    }
X}
X
X/* livecdr - do we need to follow the cdr? */
XLOCAL int livecdr(n)
X  NODE *n;
X{
X    switch (ntype(n)) {
X    case SUBR:
X    case FSUBR:
X    case INT:
X    case FLOAT:
X    case STR:
X    case FPTR:
X	    return (FALSE);
X    case SYM:
X    case LIST:
X    case OBJ:
X	    return (cdr(n) != NIL);
X    default:
X	    printf("bad node type (%d) found during right scan\n",ntype(n));
X	    exit();
X    }
X}
X
X/* stats - print memory statistics */
Xstats()
X{
X    sprintf(buf,"Nodes:       %d\n",nnodes);  stdputstr(buf);
X    sprintf(buf,"Free nodes:  %d\n",nfree);   stdputstr(buf);
X    sprintf(buf,"Segments:    %d\n",nsegs);   stdputstr(buf);
X    sprintf(buf,"Allocate:    %d\n",anodes);  stdputstr(buf);
X    sprintf(buf,"Total:       %ld\n",total);  stdputstr(buf);
X    sprintf(buf,"Collections: %d\n",gccalls); stdputstr(buf);
X}
X
X/* xlminit - initialize the dynamic memory module */
Xxlminit()
X{
X    /* initialize our internal variables */
X    anodes = NNODES;
X    total = 0L;
X    nnodes = nsegs = nfree = gccalls = 0;
X    fnodes = NIL;
X    segs = NULL;
X
X    /* initialize structures that are marked by the collector */
X    xlstack = xlenv = oblist = keylist = NIL;
X}
SHAR_EOF
if test 7170 -ne "`wc -c 'xldmem.c'`"
then
	echo shar: error transmitting "'xldmem.c'" '(should have been 7170 characters)'
fi
echo shar: extracting "'xleval.c'" '(7937 characters)'
if test -f 'xleval.c'
then
	echo shar: over-writing existing file "'xleval.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xleval.c'
X/* xleval - xlisp evaluator */
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 *xlstack,*xlenv;
Xextern NODE *s_lambda,*s_macro;
Xextern NODE *k_optional,*k_rest,*k_aux;
Xextern NODE *s_evalhook,*s_applyhook;
Xextern NODE *s_unbound;
Xextern NODE *s_stdout;
X
X/* forward declarations */
XFORWARD NODE *xlxeval();
XFORWARD NODE *evalhook();
XFORWARD NODE *evform();
XFORWARD NODE *evfun();
X
X/* xleval - evaluate an xlisp expression (checking for *evalhook*) */
XNODE *xleval(expr)
X  NODE *expr;
X{
X    return (getvalue(s_evalhook) ? evalhook(expr) : xlxeval(expr));
X}
X
X/* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
XNODE *xlxeval(expr)
X  NODE *expr;
X{
X#ifdef MEGAMAX
X    macidle();
X#endif
X
X    /* evaluate nil to itself */
X    if (expr == NIL)
X	return (NIL);
X
X    /* add trace entry */
X    xltpush(expr);
X
X    /* check type of value */
X    if (consp(expr))
X	expr = evform(expr);
X    else if (symbolp(expr))
X	expr = xlgetvalue(expr);
X
X    /* remove trace entry */
X    xltpop();
X
X    /* return the value */
X    return (expr);
X}
X
X/* xlapply - apply a function to a list of arguments */
XNODE *xlapply(fun,args)
X  NODE *fun,*args;
X{
X    NODE *env,*val;
X
X    /* check for a null function */
X    if (fun == NIL)
X	xlfail("bad function");
X
X    /* evaluate the function */
X    if (subrp(fun))
X	val = (*fun->n_subr)(args);
X    else if (consp(fun)) {
X	if (consp(car(fun))) {
X	    env = cdr(fun);
X	    fun = car(fun);
X	}
X	else
X	    env = xlenv;
X	if (car(fun) != s_lambda)
X	    xlfail("bad function type");
X	val = evfun(fun,args,env);
X    }
X    else
X	xlfail("bad function");
X
X    /* return the result value */
X    return (val);
X}
X
X/* evform - evaluate a form */
XLOCAL NODE *evform(expr)
X  NODE *expr;
X{
X    NODE *oldstk,fun,args,*env,*val,*type;
X
X    /* create a stack frame */
X    oldstk = xlsave(&fun,&args,NULL);
X
X    /* get the function and the argument list */
X    fun.n_ptr = car(expr);
X    args.n_ptr = cdr(expr);
X
X    /* evaluate the first expression */
X    if ((fun.n_ptr = xleval(fun.n_ptr)) == NIL)
X	xlfail("bad function");
X
X    /* evaluate the function */
X    if (subrp(fun.n_ptr) || fsubrp(fun.n_ptr)) {
X	if (subrp(fun.n_ptr))
X	    args.n_ptr = xlevlist(args.n_ptr);
X	val = (*fun.n_ptr->n_subr)(args.n_ptr);
X    }
X    else if (consp(fun.n_ptr)) {
X	if (consp(car(fun.n_ptr))) {
X	    env = cdr(fun.n_ptr);
X	    fun.n_ptr = car(fun.n_ptr);
X	}
X	else
X	    env = xlenv;
X	if ((type = car(fun.n_ptr)) == s_lambda) {
X	    args.n_ptr = xlevlist(args.n_ptr);
X	    val = evfun(fun.n_ptr,args.n_ptr,env);
X	}
X	else if (type == s_macro) {
X	    args.n_ptr = evfun(fun.n_ptr,args.n_ptr,env);
X	    val = xleval(args.n_ptr);
X	}
X	else
X	    xlfail("bad function type");
X    }
X    else if (objectp(fun.n_ptr))
X	val = xlsend(fun.n_ptr,args.n_ptr);
X    else
X	xlfail("bad function");
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the result value */
X    return (val);
X}
X
X/* evalhook - call the evalhook function */
XLOCAL NODE *evalhook(expr)
X  NODE *expr;
X{
X    NODE *oldstk,ehook,ahook,args,*val;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&ehook,&ahook,&args,NULL);
X
X    /* make an argument list */
X    args.n_ptr = newnode(LIST);
X    rplaca(args.n_ptr,expr);
X    rplacd(args.n_ptr,newnode(LIST));
X    rplaca(cdr(args.n_ptr),xlenv);
X
X    /* rebind the hook functions to nil */
X    ehook.n_ptr = getvalue(s_evalhook);
X    setvalue(s_evalhook,NIL);
X    ahook.n_ptr = getvalue(s_applyhook);
X    setvalue(s_applyhook,NIL);
X
X    /* call the hook function */
X    val = xlapply(ehook.n_ptr,args.n_ptr);
X
X    /* unbind the symbols */
X    setvalue(s_evalhook,ehook.n_ptr);
X    setvalue(s_applyhook,ahook.n_ptr);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the value */
X    return (val);
X}
X
X/* xlevlist - evaluate a list of arguments */
XNODE *xlevlist(args)
X  NODE *args;
X{
X    NODE *oldstk,src,dst,*new,*last,*val;
X
X    /* create a stack frame */
X    oldstk = xlsave(&src,&dst,NULL);
X
X    /* initialize */
X    src.n_ptr = args;
X
X    /* evaluate each argument */
X    for (val = NIL; src.n_ptr; src.n_ptr = cdr(src.n_ptr)) {
X
X	/* check this entry */
X	if (!consp(src.n_ptr))
X	    xlfail("bad argument list");
X
X	/* allocate a new list entry */
X	new = newnode(LIST);
X	if (val)
X	    rplacd(last,new);
X	else
X	    val = dst.n_ptr = new;
X	rplaca(new,xleval(car(src.n_ptr)));
X	last = new;
X    }
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the new list */
X    return (val);
X}
X
X/* xlunbound - signal an unbound variable error */
Xxlunbound(sym)
X  NODE *sym;
X{
X    xlcerror("try evaluating symbol again","unbound variable",sym);
X}
X
X/* evfun - evaluate a function */
XLOCAL NODE *evfun(fun,args,env)
X  NODE *fun,*args,*env;
X{
X    NODE *oldstk,oldenv,newenv,cptr,*fargs,*val;
X
X    /* create a stack frame */
X    oldstk = xlsave(&oldenv,&newenv,&cptr,NULL);
X
X    /* skip the function type */
X    if ((fun = cdr(fun)) == NIL || !consp(fun))
X	xlfail("bad function definition");
X
X    /* get the formal argument list */
X    if ((fargs = car(fun)) && !consp(fargs))
X	xlfail("bad formal argument list");
X
X    /* create a new environment frame */
X    newenv.n_ptr = xlframe(env);
X    oldenv.n_ptr = xlenv;
X
X    /* bind the formal parameters */
X    xlabind(fargs,args,newenv.n_ptr);
X    xlenv = newenv.n_ptr;
X
X    /* execute the code */
X    for (cptr.n_ptr = cdr(fun); cptr.n_ptr != NIL; )
X	val = xlevarg(&cptr.n_ptr);
X
X    /* restore the environment */
X    xlenv = oldenv.n_ptr;
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the result value */
X    return (val);
X}
X
X/* xlabind - bind the arguments for a function */
Xxlabind(fargs,aargs,env)
X  NODE *fargs,*aargs,*env;
X{
X    NODE *arg;
X
X    /* evaluate and bind each required argument */
X    while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
X
X	/* bind the formal variable to the argument value */
X	xlbind(arg,car(aargs),env);
X
X	/* move the argument list pointers ahead */
X	fargs = cdr(fargs);
X	aargs = cdr(aargs);
X    }
X
X    /* check for the '&optional' keyword */
X    if (consp(fargs) && car(fargs) == k_optional) {
X	fargs = cdr(fargs);
X
X	/* bind the arguments that were supplied */
X	while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
X
X	    /* bind the formal variable to the argument value */
X	    xlbind(arg,car(aargs),env);
X
X	    /* move the argument list pointers ahead */
X	    fargs = cdr(fargs);
X	    aargs = cdr(aargs);
X	}
X
X	/* bind the rest to nil */
X	while (consp(fargs) && !iskeyword(arg = car(fargs))) {
X
X	    /* bind the formal variable to nil */
X	    xlbind(arg,NIL,env);
X
X	    /* move the argument list pointer ahead */
X	    fargs = cdr(fargs);
X	}
X    }
X
X    /* check for the '&rest' keyword */
X    if (consp(fargs) && car(fargs) == k_rest) {
X	fargs = cdr(fargs);
X	if (consp(fargs) && (arg = car(fargs)) && !iskeyword(arg))
X	    xlbind(arg,aargs,env);
X	else
X	    xlfail("symbol missing after &rest");
X	fargs = cdr(fargs);
X	aargs = NIL;
X    }
X
X    /* check for the '&aux' keyword */
X    if (consp(fargs) && car(fargs) == k_aux)
X	while ((fargs = cdr(fargs)) != NIL && consp(fargs))
X	    xlbind(car(fargs),NIL,env);
X
X    /* make sure the correct number of arguments were supplied */
X    if (fargs != aargs)
X	xlfail(fargs ? "too few arguments" : "too many arguments");
X}
X
X/* iskeyword - check to see if a symbol is a keyword */
XLOCAL int iskeyword(sym)
X  NODE *sym;
X{
X    return (sym == k_optional || sym == k_rest || sym == k_aux);
X}
X
X/* xlsave - save nodes on the stack */
XNODE *xlsave(n)
X  NODE *n;
X{
X    NODE **nptr,*oldstk;
X
X    /* save the old stack pointer */
X    oldstk = xlstack;
X
X    /* save each node */
X    for (nptr = &n; *nptr != NULL; nptr++) {
X	rplaca(*nptr,NIL);
X	rplacd(*nptr,xlstack);
X	xlstack = *nptr;
X    }
X
X    /* return the old stack pointer */
X    return (oldstk);
X}
SHAR_EOF
if test 7937 -ne "`wc -c 'xleval.c'`"
then
	echo shar: error transmitting "'xleval.c'" '(should have been 7937 characters)'
fi
echo shar: extracting "'xlfio.c'" '(6777 characters)'
if test -f 'xlfio.c'
then
	echo shar: over-writing existing file "'xlfio.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlfio.c'
X/* xlfio.c - xlisp file i/o */
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 *s_stdin,*s_stdout;
Xextern NODE *xlstack;
Xextern int xlfsize;
Xextern char buf[];
X
X/* external routines */
Xextern FILE *fopen();
X
X/* forward declarations */
XFORWARD NODE *printit();
XFORWARD NODE *flatsize();
XFORWARD NODE *openit();
X
X/* xread - read an expression */
XNODE *xread(args)
X  NODE *args;
X{
X    NODE *oldstk,fptr,eof,*val;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&fptr,&eof,NULL);
X
X    /* get file pointer and eof value */
X    fptr.n_ptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
X    eof.n_ptr = (args ? xlarg(&args) : NIL);
X    xllastarg(args);
X
X    /* read an expression */
X    if (!xlread(fptr.n_ptr,&val))
X	val = eof.n_ptr;
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the expression */
X    return (val);
X}
X
X/* xprint - builtin function 'print' */
XNODE *xprint(args)
X  NODE *args;
X{
X    return (printit(args,TRUE,TRUE));
X}
X
X/* xprin1 - builtin function 'prin1' */
XNODE *xprin1(args)
X  NODE *args;
X{
X    return (printit(args,TRUE,FALSE));
X}
X
X/* xprinc - builtin function princ */
XNODE *xprinc(args)
X  NODE *args;
X{
X    return (printit(args,FALSE,FALSE));
X}
X
X/* xterpri - terminate the current print line */
XNODE *xterpri(args)
X  NODE *args;
X{
X    NODE *fptr;
X
X    /* get file pointer */
X    fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
X    xllastarg(args);
X
X    /* terminate the print line and return nil */
X    xlterpri(fptr);
X    return (NIL);
X}
X
X/* printit - common print function */
XLOCAL NODE *printit(args,pflag,tflag)
X  NODE *args; int pflag,tflag;
X{
X    NODE *oldstk,fptr,val;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&fptr,&val,NULL);
X
X    /* get expression to print and file pointer */
X    val.n_ptr = xlarg(&args);
X    fptr.n_ptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
X    xllastarg(args);
X
X    /* print the value */
X    xlprint(fptr.n_ptr,val.n_ptr,pflag);
X
X    /* terminate the print line if necessary */
X    if (tflag)
X	xlterpri(fptr.n_ptr);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the result */
X    return (val.n_ptr);
X}
X
X/* xflatsize - compute the size of a printed representation using prin1 */
XNODE *xflatsize(args)
X  NODE *args;
X{
X    return (flatsize(args,TRUE));
X}
X
X/* xflatc - compute the size of a printed representation using princ */
XNODE *xflatc(args)
X  NODE *args;
X{
X    return (flatsize(args,FALSE));
X}
X
X/* flatsize - compute the size of a printed expression */
XLOCAL NODE *flatsize(args,pflag)
X  NODE *args; int pflag;
X{
X    NODE *oldstk,val;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&val,NULL);
X
X    /* get the expression */
X    val.n_ptr = xlarg(&args);
X    xllastarg(args);
X
X    /* print the value to compute its size */
X    xlfsize = 0;
X    xlprint(NIL,val.n_ptr,pflag);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the length of the expression */
X    return (cvfixnum((FIXNUM)xlfsize));
X}
X
X/* xopeni - open an input file */
XNODE *xopeni(args)
X  NODE *args;
X{
X    return (openit(args,"r"));
X}
X
X/* xopeno - open an output file */
XNODE *xopeno(args)
X  NODE *args;
X{
X    return (openit(args,"w"));
X}
X
X/* openit - common file open routine */
XLOCAL NODE *openit(args,mode)
X  NODE *args; char *mode;
X{
X    NODE *fname,*val;
X    FILE *fp;
X
X    /* get the file name */
X    fname = xlmatch(STR,&args);
X    xllastarg(args);
X
X    /* try to open the file */
X    if ((fp = fopen(fname->n_str,mode)) != NULL) {
X	val = newnode(FPTR);
X	val->n_fp = fp;
X	val->n_savech = 0;
X    }
X    else
X	val = NIL;
X
X    /* return the file pointer */
X    return (val);
X}
X
X/* xclose - close a file */
XNODE *xclose(args)
X  NODE *args;
X{
X    NODE *fptr;
X
X    /* get file pointer */
X    fptr = xlmatch(FPTR,&args);
X    xllastarg(args);
X
X    /* make sure the file exists */
X    if (fptr->n_fp == NULL)
X	xlfail("file not open");
X
X    /* close the file */
X    fclose(fptr->n_fp);
X    fptr->n_fp = NULL;
X
X    /* return nil */
X    return (NIL);
X}
X
X/* xrdchar - read a character from a file */
XNODE *xrdchar(args)
X  NODE *args;
X{
X    NODE *fptr;
X    int ch;
X
X    /* get file pointer */
X    fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
X    xllastarg(args);
X
X    /* get character and check for eof */
X    return ((ch = xlgetc(fptr)) == EOF ? NIL : cvfixnum((FIXNUM)ch));
X}
X
X/* xpkchar - peek at a character from a file */
XNODE *xpkchar(args)
X  NODE *args;
X{
X    NODE *flag,*fptr;
X    int ch;
X
X    /* peek flag and get file pointer */
X    flag = (args ? xlarg(&args) : NIL);
X    fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
X    xllastarg(args);
X
X    /* skip leading white space and get a character */
X    if (flag)
X	while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
X	    xlgetc(fptr);
X    else
X	ch = xlpeek(fptr);
X
X    /* return the character */
X    return (ch == EOF ? NIL : cvfixnum((FIXNUM)ch));
X}
X
X/* xwrchar - write a character to a file */
XNODE *xwrchar(args)
X  NODE *args;
X{
X    NODE *fptr,*chr;
X
X    /* get the character and file pointer */
X    chr = xlmatch(INT,&args);
X    fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
X    xllastarg(args);
X
X    /* put character to the file */
X    xlputc(fptr,(int)chr->n_int);
X
X    /* return the character */
X    return (chr);
X}
X
X/* xreadline - read a line from a file */
XNODE *xreadline(args)
X  NODE *args;
X{
X    NODE *oldstk,fptr,str;
X    char *p,*sptr;
X    int len,ch;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&fptr,&str,NULL);
X
X    /* get file pointer */
X    fptr.n_ptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
X    xllastarg(args);
X
X    /* make a string node */
X    str.n_ptr = newnode(STR);
X    str.n_ptr->n_strtype = DYNAMIC;
X
X    /* get character and check for eof */
X    len = 0; p = buf;
X    while ((ch = xlgetc(fptr.n_ptr)) != EOF && ch != '\n') {
X
X	/* check for buffer overflow */
X	if ((int)(p - buf) == STRMAX) {
X	    *p = 0;
X 	    sptr = stralloc(len + STRMAX); *sptr = 0;
X	    if (len) {
X		strcpy(sptr,str.n_ptr->n_str);
X		strfree(str.n_ptr->n_str);
X	    }
X	    str.n_ptr->n_str = sptr;
X	    strcat(sptr,buf);
X	    len += STRMAX;
X	    p = buf;
X	}
X
X	/* store the character */
X	*p++ = ch;
X    }
X
X    /* check for end of file */
X    if (len == 0 && p == buf && ch == EOF) {
X	xlstack = oldstk;
X	return (NIL);
X    }
X
X    /* append the last substring */
X    *p = 0;
X    sptr = stralloc(len + (int)(p - buf)); *sptr = 0;
X    if (len) {
X	strcpy(sptr,str.n_ptr->n_str);
X	strfree(str.n_ptr->n_str);
X    }
X    str.n_ptr->n_str = sptr;
X    strcat(sptr,buf);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the string */
X    return (str.n_ptr);
X}
SHAR_EOF
if test 6777 -ne "`wc -c 'xlfio.c'`"
then
	echo shar: error transmitting "'xlfio.c'" '(should have been 6777 characters)'
fi
echo shar: extracting "'xlftab1.c'" '(4118 characters)'
if test -f 'xlftab1.c'
then
	echo shar: over-writing existing file "'xlftab1.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlftab1.c'
X/* xlftab1.c - xlisp function table - part 1 */
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    *xeval(),*xapply(),*xfuncall(),*xquote(),*xfunction(),*xbquote(),
X    *xset(),*xsetq(),*xsetf(),*xdefun(),*xdefmacro(),
X    *xgensym(),*xmakesymbol(),*xintern(),
X    *xsymname(),*xsymvalue(),*xsymplist(),*xget(),*xputprop(),*xremprop(),
X    *xcar(),*xcaar(),*xcadr(),*xcdr(),*xcdar(),*xcddr(),
X    *xcons(),*xlist(),*xappend(),*xreverse(),*xlast(),*xnth(),*xnthcdr(),
X    *xmember(),*xassoc(),*xsubst(),*xsublis(),*xremove(),*xlength(),
X    *xmapc(),*xmapcar(),*xmapl(),*xmaplist(),
X    *xrplca(),*xrplcd(),*xnconc(),*xdelete(),
X    *xatom(),*xsymbolp(),*xnumberp(),*xboundp(),*xnull(),*xlistp(),*xconsp(),
X    *xeq(),*xeql(),*xequal(),
X    *xcond(),*xand(),*xor(),*xlet(),*xletstar(),*xif(),
X    *xprog(),*xprogstar(),*xprog1(),*xprog2(),*xprogn(),*xgo(),*xreturn(),
X    *xcatch(),*xthrow(),
X    *xerror(),*xcerror(),*xbreak(),*xcleanup(),*xcontinue(),*xerrset(),
X    *xbaktrace(),*xevalhook(),
X    *xdo(),*xdostar(),*xdolist(),*xdotimes(),
X    *xminusp(),*xzerop(),*xplusp(),*xevenp(),*xoddp();
X
X/* the function table */
Xstruct fdef ftab1[] = {
X
X	/* evaluator functions */
X{	"EVAL",		SUBR,	xeval		},
X{	"APPLY",	SUBR,	xapply		},
X{	"FUNCALL",	SUBR,	xfuncall	},
X{	"QUOTE",	FSUBR,	xquote		},
X{	"FUNCTION",	FSUBR,	xfunction	},
X{	"BACKQUOTE",	FSUBR,	xbquote		},
X
X	/* symbol functions */
X{	"SET",		SUBR,	xset		},
X{	"SETQ",		FSUBR,	xsetq		},
X{	"SETF",		FSUBR,	xsetf		},
X{	"DEFUN",	FSUBR,	xdefun		},
X{	"DEFMACRO",	FSUBR,	xdefmacro	},
X{	"GENSYM",	SUBR,	xgensym		},
X{	"MAKE-SYMBOL",	SUBR,	xmakesymbol	},
X{	"INTERN",	SUBR,	xintern		},
X{	"SYMBOL-NAME",	SUBR,	xsymname	},
X{	"SYMBOL-VALUE",	SUBR,	xsymvalue	},
X{	"SYMBOL-PLIST",	SUBR,	xsymplist	},
X{	"GET",		SUBR,	xget		},
X{	"PUTPROP",	SUBR,	xputprop	},
X{	"REMPROP",	SUBR,	xremprop	},
X
X	/* list functions */
X{	"CAR",		SUBR,	xcar		},
X{	"CAAR",		SUBR,	xcaar		},
X{	"CADR",		SUBR,	xcadr		},
X{	"CDR",		SUBR,	xcdr		},
X{	"CDAR",		SUBR,	xcdar		},
X{	"CDDR",		SUBR,	xcddr		},
X{	"CONS",		SUBR,	xcons		},
X{	"LIST",		SUBR,	xlist		},
X{	"APPEND",	SUBR,	xappend		},
X{	"REVERSE",	SUBR,	xreverse	},
X{	"LAST",		SUBR,	xlast		},
X{	"NTH",		SUBR,	xnth		},
X{	"NTHCDR",	SUBR,	xnthcdr		},
X{	"MEMBER",	SUBR,	xmember		},
X{	"ASSOC",	SUBR,	xassoc		},
X{	"SUBST",	SUBR,	xsubst		},
X{	"SUBLIS",	SUBR,	xsublis		},
X{	"REMOVE",	SUBR,	xremove		},
X{	"LENGTH",	SUBR,	xlength		},
X{	"MAPC",		SUBR,	xmapc		},
X{	"MAPCAR",	SUBR,	xmapcar		},
X{	"MAPL",		SUBR,	xmapl		},
X{	"MAPLIST",	SUBR,	xmaplist	},
X
X	/* destructive list functions */
X{	"RPLACA",	SUBR,	xrplca		},
X{	"RPLACD",	SUBR,	xrplcd		},
X{	"NCONC",	SUBR,	xnconc		},
X{	"DELETE",	SUBR,	xdelete		},
X
X	/* predicate functions */
X{	"ATOM",		SUBR,	xatom		},
X{	"SYMBOLP",	SUBR,	xsymbolp	},
X{	"NUMBERP",	SUBR,	xnumberp	},
X{	"BOUNDP",	SUBR,	xboundp		},
X{	"NULL",		SUBR,	xnull		},
X{	"NOT",		SUBR,	xnull		},
X{	"LISTP",	SUBR,	xlistp		},
X{	"CONSP",	SUBR,	xconsp		},
X{	"MINUSP",	SUBR,	xminusp		},
X{	"ZEROP",	SUBR,	xzerop		},
X{	"PLUSP",	SUBR,	xplusp		},
X{	"EVENP",	SUBR,	xevenp		},
X{	"ODDP",		SUBR,	xoddp		},
X{	"EQ",		SUBR,	xeq		},
X{	"EQL",		SUBR,	xeql		},
X{	"EQUAL",	SUBR,	xequal		},
X
X	/* control functions */
X{	"COND",		FSUBR,	xcond		},
X{	"AND",		FSUBR,	xand		},
X{	"OR",		FSUBR,	xor		},
X{	"LET",		FSUBR,	xlet		},
X{	"LET*",		FSUBR,	xletstar	},
X{	"IF",		FSUBR,	xif		},
X{	"PROG",		FSUBR,	xprog		},
X{	"PROG*",	FSUBR,	xprogstar	},
X{	"PROG1",	FSUBR,	xprog1		},
X{	"PROG2",	FSUBR,	xprog2		},
X{	"PROGN",	FSUBR,	xprogn		},
X{	"GO",		FSUBR,	xgo		},
X{	"RETURN",	SUBR,	xreturn		},
X{	"DO",		FSUBR,	xdo		},
X{	"DO*",		FSUBR,	xdostar		},
X{	"DOLIST",	FSUBR,	xdolist		},
X{	"DOTIMES",	FSUBR,	xdotimes	},
X{	"CATCH",	FSUBR,	xcatch		},
X{	"THROW",	SUBR,	xthrow		},
X
X	/* debugging and error handling functions */
X{	"ERROR",	SUBR,	xerror		},
X{	"CERROR",	SUBR,	xcerror		},
X{	"BREAK",	SUBR,	xbreak		},
X{	"CLEAN-UP",	SUBR,	xcleanup	},
X{	"CONTINUE",	SUBR,	xcontinue	},
X{	"ERRSET",	FSUBR,	xerrset		},
X{	"BAKTRACE",	SUBR,	xbaktrace	},
X{	"EVALHOOK",	SUBR,	xevalhook	},
X
X{	0					}
X};
SHAR_EOF
if test 4118 -ne "`wc -c 'xlftab1.c'`"
then
	echo shar: error transmitting "'xlftab1.c'" '(should have been 4118 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