# This is a shell archive.  Remove anything before this line, then
# unpack it by saving it in a file and typing "sh file".  (Files
# unpacked will be owned by you and have default permissions.)
#
# This archive contains:
# xlisp.h xlbfun.c xlbind.c xlcont.c xldbug.c xldmem.c xleval.c xlfio.c xlftab.c xlglob.c xlinit.c xlio.c xlisp.c xljump.c xllist.c xlmath.c xlobj.c xlprin.c xlread.c xlsetf.c xlstr.c xlstub.c.NOTUSED xlsubr.c xlsym.c xlsys.c 

echo x - xlisp.h
cat > "xlisp.h" << '//E*O*F xlisp.h//'
/* xlisp - a small subset of lisp */

/* system specific definitions */
#define UNIX

#ifdef AZTEC
#include "stdio.h"
#include "setjmp.h"
#else
#include <stdio.h>
#include <setjmp.h>
#include <ctype.h>
#endif

/* NNODES	number of nodes to allocate in each request */
/* TDEPTH	trace stack depth */
/* FORWARD	type of a forward declaration (usually "") */
/* LOCAL	type of a local function (usually "static") */

/* for the Computer Innovations compiler */
#ifdef CI
#define NNODES		1000
#define TDEPTH		500
#endif

/* for the CPM68K compiler */
#ifdef CPM68K
#define NNODES		1000
#define TDEPTH		500
#define LOCAL
#define AFMT		"%lx"
#undef NULL
#define NULL		(char *)0
#endif

/* for the DeSmet compiler */
#ifdef DESMET
#define NNODES		1000
#define TDEPTH		500
#define LOCAL
#define getc(fp)	getcx(fp)
#define putc(ch,fp)	putcx(ch,fp)
#define EOF		-1
#endif

/* for the MegaMax compiler */
#ifdef MEGAMAX
#define NNODES		200
#define TDEPTH		100
#define LOCAL
#define AFMT		"%lx"
#define TSTKSIZE	(4 * TDEPTH)
#endif

/* for the VAX-11 C compiler */
#ifdef vms
#define NNODES		2000
#define TDEPTH		1000
#endif

/* for the DECUS C compiler */
#ifdef decus
#define NNODES		200
#define TDEPTH		100
#define FORWARD		extern
#endif

/* for unix compilers */
#ifdef unix
#define NNODES		200
#define TDEPTH		100
#endif

/* for the AZTEC C compiler */
#ifdef AZTEC
#define NNODES		200
#define TDEPTH		100
#define getc(fp)	agetc(fp)
#define putc(ch,fp)	aputc(ch,fp)
#endif

/* default important definitions */
#ifndef NNODES
#define NNODES		200
#endif
#ifndef TDEPTH
#define TDEPTH		100
#endif
#ifndef FORWARD
#define FORWARD
#endif
#ifndef LOCAL
#define LOCAL		static
#endif
#ifndef AFMT
#define AFMT		"%x"
#endif
#ifndef TSTKSIZE
#define TSTKSIZE	(sizeof(NODE *) * TDEPTH)
#endif

/* useful definitions */
#define TRUE	1
#define FALSE	0
#define NIL	(NODE *)0

/* program limits */
#define STRMAX		100		/* maximum length of a string constant */
	
/* node types */
#define FREE	0
#define SUBR	1
#define FSUBR	2
#define LIST	3
#define SYM	4
#define INT	5
#define STR	6
#define OBJ	7
#define FPTR	8

/* node flags */
#define MARK	1
#define LEFT	2

/* string types */
#define DYNAMIC	0
#define STATIC	1

/* new node access macros */
#define ntype(x)	((x)->n_type)
#define atom(x)		((x) == NIL || (x)->n_type != LIST)
#define null(x)		((x) == NIL)
#define listp(x)	((x) == NIL || (x)->n_type == LIST)
#define consp(x)	((x) && (x)->n_type == LIST)
#define subrp(x)	((x) && (x)->n_type == SUBR)
#define fsubrp(x)	((x) && (x)->n_type == FSUBR)
#define stringp(x)	((x) && (x)->n_type == STR)
#define symbolp(x)	((x) && (x)->n_type == SYM)
#define filep(x)	((x) && (x)->n_type == FPTR)
#define objectp(x)	((x) && (x)->n_type == OBJ)
#define fixp(x)		((x) && (x)->n_type == INT)
#define car(x)		((x)->n_car)
#define cdr(x)		((x)->n_cdr)
#define rplaca(x,y)	((x)->n_car = (y))
#define rplacd(x,y)	((x)->n_cdr = (y))

/* symbol node */
#define n_symplist	n_info.n_xsym.xsy_plist
#define n_symvalue	n_info.n_xsym.xsy_value

/* subr/fsubr node */
#define n_subr		n_info.n_xsubr.xsu_subr

/* list node */
#define n_car		n_info.n_xlist.xl_car
#define n_cdr		n_info.n_xlist.xl_cdr
#define n_ptr		n_info.n_xlist.xl_car

/* integer node */
#define n_int		n_info.n_xint.xi_int

/* string node */
#define n_str		n_info.n_xstr.xst_str
#define n_strtype	n_info.n_xstr.xst_type

/* object node */
#define n_obclass	n_info.n_xobj.xo_obclass
#define n_obdata	n_info.n_xobj.xo_obdata

/* file pointer node */
#define n_fp		n_info.n_xfptr.xf_fp
#define n_savech	n_info.n_xfptr.xf_savech

/* node structure */
typedef struct node {
    char n_type;		/* type of node */
    char n_flags;		/* flag bits */
    union {			/* value */
	struct xsym {		/* symbol node */
	    struct node *xsy_plist;	/* symbol plist - (name . plist) */
	    struct node *xsy_value;	/* the current value */
	} n_xsym;
	struct xsubr {		/* subr/fsubr node */
	    struct node *(*xsu_subr)();	/* pointer to an internal routine */
	} n_xsubr;
	struct xlist {		/* list node (cons) */
	    struct node *xl_car;	/* the car pointer */
	    struct node *xl_cdr;	/* the cdr pointer */
	} n_xlist;
	struct xint {		/* integer node */
	    int xi_int;			/* integer value */
	} n_xint;
	struct xstr {		/* string node */
	    int xst_type;		/* string type */
	    char *xst_str;		/* string pointer */
	} n_xstr;
	struct xobj {		/* object node */
	    struct node *xo_obclass;	/* class of object */
	    struct node *xo_obdata;	/* instance data */
	} n_xobj;
	struct xfptr {		/* file pointer node */
	    FILE *xf_fp;		/* the file pointer */
	    int xf_savech;		/* lookahead character for input files */
	} n_xfptr;
    } n_info;
} NODE;

/* execution context flags */
#define CF_GO		1
#define CF_RETURN	2
#define CF_THROW	4
#define CF_ERROR	8

/* execution context */
typedef struct context {
    int c_flags;			/* context type flags */
    struct node *c_expr;		/* expression (type dependant) */
    jmp_buf c_jmpbuf;			/* longjmp context */
    struct context *c_xlcontext;	/* old value of xlcontext */
    struct node *c_xlstack;		/* old value of xlstack */
    struct node *c_xlenv,*c_xlnewenv;	/* old values of xlenv and xlnewenv */
    int c_xltrace;			/* old value of xltrace */
} CONTEXT;

/* function table entry structure */
struct fdef {
    char *f_name;			/* function name */
    int f_type;				/* function type SUBR/FSUBR */
    struct node *(*f_fcn)();		/* function code */
};

/* memory segment structure definition */
struct segment {
    int sg_size;
    struct segment *sg_next;
    struct node sg_nodes[1];
};

/* external procedure declarations */
extern struct node *xleval();		/* evaluate an expression */
extern struct node *xlapply();		/* apply a function to arguments */
extern struct node *xlevlist();		/* evaluate a list of arguments */
extern struct node *xlarg();		/* fetch an argument */
extern struct node *xlevarg();		/* fetch and evaluate an argument */
extern struct node *xlmatch();		/* fetch an typed argument */
extern struct node *xlevmatch();	/* fetch and evaluate a typed arg */
extern struct node *xlsend();		/* send a message to an object */
extern struct node *xlenter();		/* enter a symbol */
extern struct node *xlsenter();		/* enter a symbol with a static pname */
extern struct node *xlintern();		/* intern a symbol */
extern struct node *xlmakesym();	/* make an uninterned symbol */
extern struct node *xlsave();		/* generate a stack frame */
extern struct node *xlobsym();		/* find an object's class or instance
					   variable */
extern struct node *xlgetprop();	/* get the value of a property */
extern char *xlsymname();		/* get the print name of a symbol */

extern struct node *newnode();		/* allocate a new node */
extern char *stralloc();		/* allocate string space */
extern char *strsave();			/* make a safe copy of a string */
//E*O*F xlisp.h//

echo x - xlbfun.c
cat > "xlbfun.c" << '//E*O*F xlbfun.c//'
/* xlbfun.c - xlisp basic builtin functions */

#include "xlisp.h"

/* external variables */
extern NODE *xlstack;
extern NODE *s_lambda,*s_macro;
extern NODE *s_comma,*s_comat;
extern NODE *s_unbound;
extern char gsprefix[];
extern int gsnumber;

/* forward declarations */
FORWARD NODE *bquote1();
FORWARD NODE *defun();
FORWARD NODE *makesymbol();

/* xeval - the builtin function 'eval' */
NODE *xeval(args)
  NODE *args;
{
    NODE *oldstk,expr,*val;

    /* create a new stack frame */
    oldstk = xlsave(&expr,NULL);

    /* get the expression to evaluate */
    expr.n_ptr = xlarg(&args);
    xllastarg(args);

    /* evaluate the expression */
    val = xleval(expr.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the expression evaluated */
    return (val);
}

/* xapply - the builtin function 'apply' */
NODE *xapply(args)
  NODE *args;
{
    NODE *oldstk,fun,arglist,*val;

    /* create a new stack frame */
    oldstk = xlsave(&fun,&arglist,NULL);

    /* get the function and argument list */
    fun.n_ptr = xlarg(&args);
    arglist.n_ptr = xlarg(&args);
    xllastarg(args);

    /* if the function is a symbol, get its value */
    if (symbolp(fun.n_ptr))
	fun.n_ptr = xleval(fun.n_ptr);

    /* apply the function to the arguments */
    val = xlapply(fun.n_ptr,arglist.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the expression evaluated */
    return (val);
}

/* xfuncall - the builtin function 'funcall' */
NODE *xfuncall(args)
  NODE *args;
{
    NODE *oldstk,fun,arglist,*val;

    /* create a new stack frame */
    oldstk = xlsave(&fun,&arglist,NULL);

    /* get the function and argument list */
    fun.n_ptr = xlarg(&args);
    arglist.n_ptr = args;

    /* if the function is a symbol, get its value */
    if (symbolp(fun.n_ptr))
	fun.n_ptr = xleval(fun.n_ptr);

    /* apply the function to the arguments */
    val = xlapply(fun.n_ptr,arglist.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the expression evaluated */
    return (val);
}

/* xquote - builtin function to quote an expression */
NODE *xquote(args)
  NODE *args;
{
    NODE *arg;

    /* get the argument */
    arg = xlarg(&args);
    xllastarg(args);

    /* return the quoted expression */
    return (arg);
}

/* xbquote - back quote function */
NODE *xbquote(args)
  NODE *args;
{
    NODE *oldstk,expr,*val;

    /* create a new stack frame */
    oldstk = xlsave(&expr,NULL);

    /* get the expression */
    expr.n_ptr = xlarg(&args);
    xllastarg(args);

    /* fill in the template */
    val = bquote1(expr.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result */
    return (val);
}

/* bquote1 - back quote helper function */
LOCAL NODE *bquote1(expr)
  NODE *expr;
{
    NODE *oldstk,val,list,*last,*new;

    /* handle atoms */
    if (atom(expr))
	val.n_ptr = expr;

    /* handle (comma <expr>) */
    else if (car(expr) == s_comma) {
	if (atom(cdr(expr)))
	    xlfail("bad comma expression");
	val.n_ptr = xleval(car(cdr(expr)));
    }

    /* handle ((comma-at <expr>) ... ) */
    else if (consp(car(expr)) && car(car(expr)) == s_comat) {
	oldstk = xlsave(&list,&val,NULL);
	if (atom(cdr(car(expr))))
	    xlfail("bad comma-at expression");
	list.n_ptr = xleval(car(cdr(car(expr))));
	for (last = NIL; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
	    new = newnode(LIST);
	    rplaca(new,car(list.n_ptr));
	    if (last)
		rplacd(last,new);
	    else
		val.n_ptr = new;
	    last = new;
	}
	if (last)
	    rplacd(last,bquote1(cdr(expr)));
	else
	    val.n_ptr = bquote1(cdr(expr));
	xlstack = oldstk;
    }

    /* handle any other list */
    else {
	oldstk = xlsave(&val,NULL);
	val.n_ptr = newnode(LIST);
	rplaca(val.n_ptr,bquote1(car(expr)));
	rplacd(val.n_ptr,bquote1(cdr(expr)));
	xlstack = oldstk;
    }

    /* return the result */
    return (val.n_ptr);
}

/* xset - builtin function set */
NODE *xset(args)
  NODE *args;
{
    NODE *sym,*val;

    /* get the symbol and new value */
    sym = xlmatch(SYM,&args);
    val = xlarg(&args);
    xllastarg(args);

    /* assign the symbol the value of argument 2 and the return value */
    assign(sym,val);

    /* return the result value */
    return (val);
}

/* xsetq - builtin function setq */
NODE *xsetq(args)
  NODE *args;
{
    NODE *oldstk,arg,sym,val;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&sym,&val,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* handle each pair of arguments */
    while (arg.n_ptr) {
	sym.n_ptr = xlmatch(SYM,&arg.n_ptr);
	val.n_ptr = xlevarg(&arg.n_ptr);
	assign(sym.n_ptr,val.n_ptr);
    }

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result value */
    return (val.n_ptr);
}

/* xdefun - builtin function 'defun' */
NODE *xdefun(args)
  NODE *args;
{
    return (defun(args,s_lambda));
}

/* xdefmacro - builtin function 'defmacro' */
NODE *xdefmacro(args)
  NODE *args;
{
    return (defun(args,s_macro));
}

/* defun - internal function definition routine */
LOCAL NODE *defun(args,type)
  NODE *args,*type;
{
    NODE *oldstk,sym,fargs,fun;

    /* create a new stack frame */
    oldstk = xlsave(&sym,&fargs,&fun,NULL);

    /* get the function symbol and formal argument list */
    sym.n_ptr = xlmatch(SYM,&args);
    fargs.n_ptr = xlmatch(LIST,&args);

    /* create a new function definition */
    fun.n_ptr = newnode(LIST);
    rplaca(fun.n_ptr,type);
    rplacd(fun.n_ptr,newnode(LIST));
    rplaca(cdr(fun.n_ptr),fargs.n_ptr);
    rplacd(cdr(fun.n_ptr),args);

    /* make the symbol point to a new function definition */
    assign(sym.n_ptr,fun.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the function symbol */
    return (sym.n_ptr);
}

/* xgensym - generate a symbol */
NODE *xgensym(args)
  NODE *args;
{
    char sym[STRMAX+1];
    NODE *x;

    /* get the prefix or number */
    if (args) {
	x = xlarg(&args);
	switch (ntype(x)) {
	case STR:
		strcpy(gsprefix,x->n_str);
		break;
	case INT:
		gsnumber = x->n_int;
		break;
	default:
		xlfail("bad argument type");
	}
    }
    xllastarg(args);

    /* create the pname of the new symbol */
    sprintf(sym,"%s%d",gsprefix,gsnumber++);

    /* make a symbol with this print name */
    return (xlmakesym(sym,DYNAMIC));
}

/* xmakesymbol - make a new uninterned symbol */
NODE *xmakesymbol(args)
  NODE *args;
{
    return (makesymbol(args,FALSE));
}

/* xintern - make a new interned symbol */
NODE *xintern(args)
  NODE *args;
{
    return (makesymbol(args,TRUE));
}

/* makesymbol - make a new symbol */
LOCAL NODE *makesymbol(args,iflag)
  NODE *args; int iflag;
{
    NODE *oldstk,pname,*val;
    char *str;

    /* create a new stack frame */
    oldstk = xlsave(&pname,NULL);

    /* get the print name of the symbol to intern */
    pname.n_ptr = xlmatch(STR,&args);
    xllastarg(args);

    /* make the symbol */
    str = pname.n_ptr->n_str;
    val = (iflag ? xlenter(str,DYNAMIC) : xlmakesym(str,DYNAMIC));

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the symbol */
    return (val);
}

/* xsymname - get the print name of a symbol */
NODE *xsymname(args)
  NODE *args;
{
    NODE *sym;

    /* get the symbol */
    sym = xlmatch(SYM,&args);
    xllastarg(args);

    /* return the print name */
    return (car(sym->n_symplist));
}

/* xsymvalue - get the print value of a symbol */
NODE *xsymvalue(args)
  NODE *args;
{
    NODE *sym;

    /* get the symbol */
    sym = xlmatch(SYM,&args);
    xllastarg(args);

    /* check for an unbound symbol */
    while (sym->n_symvalue == s_unbound)
	xlunbound(sym);

    /* return the value */
    return (sym->n_symvalue);
}

/* xsymplist - get the property list of a symbol */
NODE *xsymplist(args)
  NODE *args;
{
    NODE *sym;

    /* get the symbol */
    sym = xlmatch(SYM,&args);
    xllastarg(args);

    /* return the property list */
    return (cdr(sym->n_symplist));
}

/* xget - get the value of a property */
NODE *xget(args)
  NODE *args;
{
    NODE *sym,*prp;

    /* get the symbol and property */
    sym = xlmatch(SYM,&args);
    prp = xlmatch(SYM,&args);
    xllastarg(args);

    /* retrieve the property value */
    return (xlgetprop(sym,prp));
}

/* xremprop - remove a property value from a property list */
NODE *xremprop(args)
  NODE *args;
{
    NODE *sym,*prp;

    /* get the symbol and property */
    sym = xlmatch(SYM,&args);
    prp = xlmatch(SYM,&args);
    xllastarg(args);

    /* remove the property */
    xlremprop(sym,prp);

    /* return nil */
    return (NIL);
}
//E*O*F xlbfun.c//

echo x - xlbind.c
cat > "xlbind.c" << '//E*O*F xlbind.c//'
/* xlbind - xlisp symbol binding routines */

#include "xlisp.h"

/* external variables */
extern NODE *xlenv,*xlnewenv;

/* xlsbind - bind a value to a symbol sequentially */
xlsbind(sym,val)
  NODE *sym,*val;
{
    NODE *ptr;

    /* create a new environment list entry */
    ptr = newnode(LIST);
    rplacd(ptr,xlenv);
    xlenv = ptr;

    /* create a new variable binding */
    rplaca(ptr,newnode(LIST));
    rplaca(car(ptr),sym);
    rplacd(car(ptr),sym->n_symvalue);
    sym->n_symvalue = val;
}

/* xlbind - bind a value to a symbol in parallel */
xlbind(sym,val)
  NODE *sym,*val;
{
    NODE *ptr;

    /* create a new environment list entry */
    ptr = newnode(LIST);
    rplacd(ptr,xlnewenv);
    xlnewenv = ptr;

    /* create a new variable binding */
    rplaca(ptr,newnode(LIST));
    rplaca(car(ptr),sym);
    rplacd(car(ptr),val);
}

/* xlfixbindings - make a new set of bindings visible */
xlfixbindings()
{
    NODE *eptr,*bnd,*sym,*oldvalue;

    /* fix the bound value of each symbol in the environment chain */
    for (eptr = xlnewenv; eptr != xlenv; eptr = cdr(eptr)) {
	bnd = car(eptr);
	sym = car(bnd);
	oldvalue = sym->n_symvalue;
	sym->n_symvalue = cdr(bnd);
	rplacd(bnd,oldvalue);
    }
    xlenv = xlnewenv;
}

/* xlunbind - unbind symbols bound in this environment */
xlunbind(env)
  NODE *env;
{
    NODE *bnd;

    /* unbind each symbol in the environment chain */
    for (; xlenv != env; xlenv = cdr(xlenv))
	if (bnd = car(xlenv))
	    car(bnd)->n_symvalue = cdr(bnd);
}
//E*O*F xlbind.c//

echo x - xlcont.c
cat > "xlcont.c" << '//E*O*F xlcont.c//'
/* xlcont - xlisp control built-in functions */

#include "xlisp.h"

/* external variables */
extern NODE *xlstack,*xlenv,*xlnewenv,*xlvalue;
extern NODE *s_unbound;
extern NODE *s_evalhook,*s_applyhook;
extern NODE *true;

/* external routines */
extern NODE *xlxeval();

/* forward declarations */
FORWARD NODE *let();
FORWARD NODE *prog();
FORWARD NODE *progx();
FORWARD NODE *doloop();

/* xcond - built-in function 'cond' */
NODE *xcond(args)
  NODE *args;
{
    NODE *oldstk,arg,list,*val;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&list,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* initialize the return value */
    val = NIL;

    /* find a predicate that is true */
    while (arg.n_ptr) {

	/* get the next conditional */
	list.n_ptr = xlmatch(LIST,&arg.n_ptr);

	/* evaluate the predicate part */
	if (xlevarg(&list.n_ptr)) {

	    /* evaluate each expression */
	    while (list.n_ptr)
		val = xlevarg(&list.n_ptr);

	    /* exit the loop */
	    break;
	}
    }

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the value */
    return (val);
}

/* xand - built-in function 'and' */
NODE *xand(args)
  NODE *args;
{
    NODE *oldstk,arg,*val;

    /* create a new stack frame */
    oldstk = xlsave(&arg,NULL);

    /* initialize */
    arg.n_ptr = args;
    val = true;

    /* evaluate each argument */
    while (arg.n_ptr)

	/* get the next argument */
	if ((val = xlevarg(&arg.n_ptr)) == NIL)
	    break;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result value */
    return (val);
}

/* xor - built-in function 'or' */
NODE *xor(args)
  NODE *args;
{
    NODE *oldstk,arg,*val;

    /* create a new stack frame */
    oldstk = xlsave(&arg,NULL);

    /* initialize */
    arg.n_ptr = args;
    val = NIL;

    /* evaluate each argument */
    while (arg.n_ptr)
	if ((val = xlevarg(&arg.n_ptr)))
	    break;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result value */
    return (val);
}

/* xif - built-in function 'if' */
NODE *xif(args)
  NODE *args;
{
    NODE *oldstk,testexpr,thenexpr,elseexpr,*val;

    /* create a new stack frame */
    oldstk = xlsave(&testexpr,&thenexpr,&elseexpr,NULL);

    /* get the test expression, then clause and else clause */
    testexpr.n_ptr = xlarg(&args);
    thenexpr.n_ptr = xlarg(&args);
    elseexpr.n_ptr = (args ? xlarg(&args) : NIL);
    xllastarg(args);

    /* evaluate the appropriate clause */
    val = xleval(xleval(testexpr.n_ptr) ? thenexpr.n_ptr : elseexpr.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the last value */
    return (val);
}

/* xlet - built-in function 'let' */
NODE *xlet(args)
  NODE *args;
{
    return (let(args,TRUE));
}

/* xletstar - built-in function 'let*' */
NODE *xletstar(args)
  NODE *args;
{
    return (let(args,FALSE));
}

/* let - common let routine */
LOCAL NODE *let(args,pflag)
  NODE *args; int pflag;
{
    NODE *oldstk,*oldenv,*oldnewenv,arg,*val;

    /* create a new stack frame */
    oldstk = xlsave(&arg,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* get the list of bindings and bind the symbols */
    oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
    dobindings(xlmatch(LIST,&arg.n_ptr),pflag);

    /* execute the code */
    for (val = NIL; arg.n_ptr; )
	val = xlevarg(&arg.n_ptr);

    /* unbind the arguments */
    xlunbind(oldenv); xlnewenv = oldnewenv;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result */
    return (val);
}

/* xprog - built-in function 'prog' */
NODE *xprog(args)
  NODE *args;
{
    return (prog(args,TRUE));
}

/* xprogstar - built-in function 'prog*' */
NODE *xprogstar(args)
  NODE *args;
{
    return (prog(args,FALSE));
}

/* prog - common prog routine */
LOCAL NODE *prog(args,pflag)
  NODE *args; int pflag;
{
    NODE *oldstk,*oldenv,*oldnewenv,arg,*val;

    /* create a new stack frame */
    oldstk = xlsave(&arg,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* get the list of bindings and bind the symbols */
    oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
    dobindings(xlmatch(LIST,&arg.n_ptr),pflag);

    /* execute the code */
    tagblock(arg.n_ptr,&val);

    /* unbind the arguments */
    xlunbind(oldenv); xlnewenv = oldnewenv;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result */
    return (val);
}

/* xgo - built-in function 'go' */
NODE *xgo(args)
  NODE *args;
{
    NODE *label;

    /* get the target label */
    label = xlarg(&args);
    xllastarg(args);

    /* transfer to the label */
    xlgo(label);
}

/* xreturn - built-in function 'return' */
NODE *xreturn(args)
  NODE *args;
{
    NODE *val;

    /* get the return value */
    val = (args ? xlarg(&args) : NIL);
    xllastarg(args);

    /* return from the inner most block */
    xlreturn(val);
}

/* xprog1 - built-in function 'prog1' */
NODE *xprog1(args)
  NODE *args;
{
    return (progx(args,1));
}

/* xprog2 - built-in function 'prog2' */
NODE *xprog2(args)
  NODE *args;
{
    return (progx(args,2));
}

/* progx - common progx code */
LOCAL NODE *progx(args,n)
  NODE *args; int n;
{
    NODE *oldstk,arg,val;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&val,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* evaluate the first n expressions */
    while (n--)
	val.n_ptr = xlevarg(&arg.n_ptr);

    /* evaluate each remaining argument */
    while (arg.n_ptr)
	xlevarg(&arg.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the last test expression value */
    return (val.n_ptr);
}

/* xprogn - built-in function 'progn' */
NODE *xprogn(args)
  NODE *args;
{
    NODE *oldstk,arg,*val;

    /* create a new stack frame */
    oldstk = xlsave(&arg,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* evaluate each remaining argument */
    for (val = NIL; arg.n_ptr; )
	val = xlevarg(&arg.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the last test expression value */
    return (val);
}

/* xdo - built-in function 'do' */
NODE *xdo(args)
  NODE *args;
{
    return (doloop(args,TRUE));
}

/* xdostar - built-in function 'do*' */
NODE *xdostar(args)
  NODE *args;
{
    return (doloop(args,FALSE));
}

/* doloop - common do routine */
LOCAL NODE *doloop(args,pflag)
  NODE *args; int pflag;
{
    NODE *oldstk,*oldenv,*oldnewenv,arg,blist,clist,test,*rval;
    int rbreak;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&blist,&clist,&test,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* get the list of bindings and bind the symbols */
    blist.n_ptr = xlmatch(LIST,&arg.n_ptr);
    oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
    dobindings(blist.n_ptr,pflag);

    /* get the exit test and result forms */
    clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
    test.n_ptr = xlarg(&clist.n_ptr);

    /* execute the loop as long as the test is false */
    rbreak = FALSE;
    while (xleval(test.n_ptr) == NIL) {

	/* execute the body of the loop */
	if (tagblock(arg.n_ptr,&rval)) {
	    rbreak = TRUE;
	    break;
	}

	/* update the looping variables */
	doupdates(blist.n_ptr,pflag);
    }

    /* evaluate the result expression */
    if (!rbreak)
	for (rval = NIL; consp(clist.n_ptr); )
	    rval = xlevarg(&clist.n_ptr);

    /* unbind the arguments */
    xlunbind(oldenv); xlnewenv = oldnewenv;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result */
    return (rval);
}

/* xdolist - built-in function 'dolist' */
NODE *xdolist(args)
  NODE *args;
{
    NODE *oldstk,*oldenv,arg,clist,sym,list,val,*rval;
    int rbreak;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&clist,&sym,&list,&val,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* get the control list (sym list result-expr) */
    clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
    sym.n_ptr = xlmatch(SYM,&clist.n_ptr);
    list.n_ptr = xlevmatch(LIST,&clist.n_ptr);
    val.n_ptr = (clist.n_ptr ? xlarg(&clist.n_ptr) : NIL);

    /* initialize the local environment */
    oldenv = xlenv;
    xlsbind(sym.n_ptr,NIL);

    /* loop through the list */
    rbreak = FALSE;
    for (; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {

	/* bind the symbol to the next list element */
	sym.n_ptr->n_symvalue = car(list.n_ptr);

	/* execute the loop body */
	if (tagblock(arg.n_ptr,&rval)) {
	    rbreak = TRUE;
	    break;
	}
    }

    /* evaluate the result expression */
    if (!rbreak) {
	sym.n_ptr->n_symvalue = NIL;
	rval = xleval(val.n_ptr);
    }

    /* unbind the arguments */
    xlunbind(oldenv);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result */
    return (rval);
}

/* xdotimes - built-in function 'dotimes' */
NODE *xdotimes(args)
  NODE *args;
{
    NODE *oldstk,*oldenv,arg,clist,sym,val,*rval;
    int rbreak,cnt,i;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&clist,&sym,&val,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* get the control list (sym list result-expr) */
    clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
    sym.n_ptr = xlmatch(SYM,&clist.n_ptr);
    cnt = xlevmatch(INT,&clist.n_ptr)->n_int;
    val.n_ptr = (clist.n_ptr ? xlarg(&clist.n_ptr) : NIL);

    /* initialize the local environment */
    oldenv = xlenv;
    xlsbind(sym.n_ptr,NIL);

    /* loop through for each value from zero to cnt-1 */
    rbreak = FALSE;
    for (i = 0; i < cnt; i++) {

	/* bind the symbol to the next list element */
	sym.n_ptr->n_symvalue = newnode(INT);
	sym.n_ptr->n_symvalue->n_int = i;

	/* execute the loop body */
	if (tagblock(arg.n_ptr,&rval)) {
	    rbreak = TRUE;
	    break;
	}
    }

    /* evaluate the result expression */
    if (!rbreak) {
	sym.n_ptr->n_symvalue = newnode(INT);
	sym.n_ptr->n_symvalue->n_int = cnt;
	rval = xleval(val.n_ptr);
    }

    /* unbind the arguments */
    xlunbind(oldenv);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result */
    return (rval);
}

/* xcatch - built-in function 'catch' */
NODE *xcatch(args)
  NODE *args;
{
    NODE *oldstk,tag,arg,*val;
    CONTEXT cntxt;

    /* create a new stack frame */
    oldstk = xlsave(&tag,&arg,NULL);

    /* initialize */
    tag.n_ptr = xlevarg(&args);
    arg.n_ptr = args;
    val = NIL;

    /* establish an execution context */
    xlbegin(&cntxt,CF_THROW,tag.n_ptr);

    /* check for 'throw' */
    if (setjmp(cntxt.c_jmpbuf))
	val = xlvalue;

    /* otherwise, evaluate the remainder of the arguments */
    else {
	while (arg.n_ptr)
	    val = xlevarg(&arg.n_ptr);
    }
    xlend(&cntxt);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result */
    return (val);
}

/* xthrow - built-in function 'throw' */
NODE *xthrow(args)
  NODE *args;
{
    NODE *tag,*val;

    /* get the tag and value */
    tag = xlarg(&args);
    val = (args ? xlarg(&args) : NIL);
    xllastarg(args);

    /* throw the tag */
    xlthrow(tag,val);
}

/* xerror - built-in function 'error' */
NODE *xerror(args)
  NODE *args;
{
    char *emsg; NODE *arg;

    /* get the error message and the argument */
    emsg = xlmatch(STR,&args)->n_str;
    arg = (args ? xlarg(&args) : s_unbound);
    xllastarg(args);

    /* signal the error */
    xlerror(emsg,arg);
}

/* xcerror - built-in function 'cerror' */
NODE *xcerror(args)
  NODE *args;
{
    char *cmsg,*emsg; NODE *arg;

    /* get the correction message, the error message, and the argument */
    cmsg = xlmatch(STR,&args)->n_str;
    emsg = xlmatch(STR,&args)->n_str;
    arg = (args ? xlarg(&args) : s_unbound);
    xllastarg(args);

    /* signal the error */
    xlcerror(cmsg,emsg,arg);

    /* return nil */
    return (NIL);
}

/* xbreak - built-in function 'break' */
NODE *xbreak(args)
  NODE *args;
{
    char *emsg; NODE *arg;

    /* get the error message */
    emsg = (args ? xlmatch(STR,&args)->n_str : "**BREAK**");
    arg = (args ? xlarg(&args) : s_unbound);
    xllastarg(args);

    /* enter the break loop */
    xlbreak(emsg,arg);

    /* return nil */
    return (NIL);
}

/* xerrset - built-in function 'errset' */
NODE *xerrset(args)
  NODE *args;
{
    NODE *oldstk,expr,flag,*val;
    CONTEXT cntxt;

    /* create a new stack frame */
    oldstk = xlsave(&expr,&flag,NULL);

    /* get the expression and the print flag */
    expr.n_ptr = xlarg(&args);
    flag.n_ptr = (args ? xlarg(&args) : true);
    xllastarg(args);

    /* establish an execution context */
    xlbegin(&cntxt,CF_ERROR,flag.n_ptr);

    /* check for error */
    if (setjmp(cntxt.c_jmpbuf))
	val = NIL;

    /* otherwise, evaluate the expression */
    else {
	expr.n_ptr = xleval(expr.n_ptr);
	val = newnode(LIST);
	rplaca(val,expr.n_ptr);
    }
    xlend(&cntxt);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result */
    return (val);
}

/* xevalhook - eval hook function */
NODE *xevalhook(args)
  NODE *args;
{
    NODE *oldstk,*oldenv,expr,ehook,ahook,*val;

    /* create a new stack frame */
    oldstk = xlsave(&expr,&ehook,&ahook,NULL);

    /* get the expression and the hook functions */
    expr.n_ptr = xlarg(&args);
    ehook.n_ptr = xlarg(&args);
    ahook.n_ptr = xlarg(&args);
    xllastarg(args);

    /* bind *evalhook* and *applyhook* to the hook functions */
    oldenv = xlenv;
    xlsbind(s_evalhook,ehook.n_ptr);
    xlsbind(s_applyhook,ahook.n_ptr);

    /* evaluate the expression (bypassing *evalhook*) */
    val = xlxeval(expr.n_ptr);

    /* unbind the hook variables */
    xlunbind(oldenv);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result */
    return (val);
}

/* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
LOCAL dobindings(blist,pflag)
  NODE *blist; int pflag;
{
    NODE *oldstk,list,bnd,sym,val;

    /* create a new stack frame */
    oldstk = xlsave(&list,&bnd,&sym,&val,NULL);

   /* bind each symbol in the list of bindings */
    for (list.n_ptr = blist; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {

	/* get the next binding */
	bnd.n_ptr = car(list.n_ptr);

	/* handle a symbol */
	if (symbolp(bnd.n_ptr)) {
	    sym.n_ptr = bnd.n_ptr;
	    val.n_ptr = NIL;
	}

	/* handle a list of the form (symbol expr) */
	else if (consp(bnd.n_ptr)) {
	    sym.n_ptr = xlmatch(SYM,&bnd.n_ptr);
	    val.n_ptr = xlevarg(&bnd.n_ptr);
	}
	else
	    xlfail("bad binding");

	/* bind the value to the symbol */
	if (pflag)
	    xlbind(sym.n_ptr,val.n_ptr);
	else
	    xlsbind(sym.n_ptr,val.n_ptr);
    }

    /* fix the bindings on a parallel let */
    if (pflag)
	xlfixbindings();

    /* restore the previous stack frame */
    xlstack = oldstk;
}

/* doupdates - handle updates for do/do* */
doupdates(blist,pflag)
  NODE *blist; int pflag;
{
    NODE *oldstk,*oldenv,*oldnewenv,list,bnd,sym,val;

    /* create a new stack frame */
    oldstk = xlsave(&list,&bnd,&sym,&val,NULL);

    /* initialize the local environment */
    if (pflag) {
	oldenv = xlenv; oldnewenv = xlnewenv;
    }

    /* bind each symbol in the list of bindings */
    for (list.n_ptr = blist; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {

	/* get the next binding */
	bnd.n_ptr = car(list.n_ptr);

	/* handle a list of the form (symbol expr) */
	if (consp(bnd.n_ptr)) {
	    sym.n_ptr = xlmatch(SYM,&bnd.n_ptr);
	    bnd.n_ptr = cdr(bnd.n_ptr);
	    if (bnd.n_ptr) {
		val.n_ptr = xlevarg(&bnd.n_ptr);
		if (pflag)
		    xlbind(sym.n_ptr,val.n_ptr);
		else
		    sym.n_ptr->n_symvalue = val.n_ptr;
	    }
	}
    }

    /* fix the bindings on a parallel let */
    if (pflag) {
	xlfixbindings();
	xlenv = oldenv; xlnewenv = oldnewenv;
    }

    /* restore the previous stack frame */
    xlstack = oldstk;
}

/* tagblock - execute code within a block and tagbody */
int tagblock(code,pval)
  NODE *code,**pval;
{
    NODE *oldstk,arg;
    CONTEXT cntxt;
    int type,sts;

    /* create a new stack frame */
    oldstk = xlsave(&arg,NULL);

    /* initialize */
    arg.n_ptr = code;

    /* establish an execution context */
    xlbegin(&cntxt,CF_GO|CF_RETURN,arg.n_ptr);

    /* check for a 'return' */
    if ((type = setjmp(cntxt.c_jmpbuf)) == CF_RETURN) {
	*pval = xlvalue;
	sts = TRUE;
    }

    /* otherwise, enter the body */
    else {

	/* check for a 'go' */
	if (type == CF_GO)
	    arg.n_ptr = xlvalue;

	/* evaluate each expression in the body */
	while (consp(arg.n_ptr))
	    if (consp(car(arg.n_ptr)))
		xlevarg(&arg.n_ptr);
	    else
		arg.n_ptr = cdr(arg.n_ptr);
	
	/* indicate that we fell through the bottom of the tagbody */
	*pval = NIL;
	sts = FALSE;
    }
    xlend(&cntxt);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return status */
    return (sts);
}
//E*O*F xlcont.c//

echo x - xldbug.c
cat > "xldbug.c" << '//E*O*F xldbug.c//'
/* xldebug - xlisp debugging support */

#include "xlisp.h"

/* external variables */
extern long total;
extern int xldebug;
extern int xltrace;
extern NODE *s_unbound;
extern NODE *s_stdin,*s_stdout;
extern NODE *s_tracenable,*s_tlimit,*s_breakenable;
extern NODE *s_continue,*s_quit;
extern NODE *xlstack;
extern NODE *true;
extern NODE **trace_stack;

/* external routines */
extern char *malloc();

/* forward declarations */
FORWARD NODE *stacktop();

/* xlfail - xlisp error handler */
xlfail(emsg)
  char *emsg;
{
    xlerror(emsg,stacktop());
}

/* xlabort - xlisp serious error handler */
xlabort(emsg)
  char *emsg;
{
    xlsignal(emsg,s_unbound);
}

/* xlbreak - enter a break loop */
xlbreak(emsg,arg)
  char *emsg; NODE *arg;
{
    breakloop("break",NULL,emsg,arg,TRUE);
}

/* xlerror - handle a fatal error */
xlerror(emsg,arg)
  char *emsg; NODE *arg;
{
    doerror(NULL,emsg,arg,FALSE);
}

/* xlcerror - handle a recoverable error */
xlcerror(cmsg,emsg,arg)
  char *cmsg,*emsg; NODE *arg;
{
    doerror(cmsg,emsg,arg,TRUE);
}

/* xlerrprint - print an error message */
xlerrprint(hdr,cmsg,emsg,arg)
  char *hdr,*cmsg,*emsg; NODE *arg;
{
    printf("%s: %s",hdr,emsg);
    if (arg != s_unbound) { printf(" - "); stdprint(arg); }
    else printf("\n");
    if (cmsg) printf("if continued: %s\n",cmsg);
}

/* doerror - handle xlisp errors */
LOCAL doerror(cmsg,emsg,arg,cflag)
  char *cmsg,*emsg; NODE *arg; int cflag;
{
    /* make sure the break loop is enabled */
    if (s_breakenable->n_symvalue == NIL)
	xlsignal(emsg,arg);

    /* call the debug read-eval-print loop */
    breakloop("error",cmsg,emsg,arg,cflag);
}

/* breakloop - the debug read-eval-print loop */
LOCAL int breakloop(hdr,cmsg,emsg,arg,cflag)
  char *hdr,*cmsg,*emsg; NODE *arg; int cflag;
{
    NODE *oldstk,expr,*val;
    CONTEXT cntxt;

    /* increment the debug level */
    xldebug++;

    /* flush the input buffer */
    xlflush();

    /* print the error message */
    xlerrprint(hdr,cmsg,emsg,arg);

    /* do the back trace */
    if (s_tracenable->n_symvalue) {
	val = s_tlimit->n_symvalue;
	xlbaktrace(fixp(val) ? val->n_int : -1);
    }

    /* create a new stack frame */
    oldstk = xlsave(&expr,NULL);

    /* debug command processing loop */
    xlbegin(&cntxt,CF_ERROR,true);
    while (TRUE) {

	/* setup the continue trap */
	if (setjmp(cntxt.c_jmpbuf)) {
	    xlflush();
	    continue;
	}

	/* read an expression and check for eof */
	if (!xlread(s_stdin->n_symvalue,&expr.n_ptr)) {
	    expr.n_ptr = s_quit;
	    break;
	}

	/* check for commands */
	if (expr.n_ptr == s_continue) {
	    if (cflag) break;
	    else xlabort("this error can't be continued");
	}
	else if (expr.n_ptr == s_quit)
	    break;

	/* evaluate the expression */
	expr.n_ptr = xleval(expr.n_ptr);

	/* print it */
	xlprint(s_stdout->n_symvalue,expr.n_ptr,TRUE);
	xlterpri(s_stdout->n_symvalue);
    }
    xlend(&cntxt);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* decrement the debug level */
    xldebug--;

    /* continue the next higher break loop on quit */
    if (expr.n_ptr == s_quit)
	xlsignal("quit from break loop",s_unbound);
}

/* tpush - add an entry to the trace stack */
xltpush(nptr)
    NODE *nptr;
{
    if (++xltrace < TDEPTH)
	trace_stack[xltrace] = nptr;
}

/* tpop - pop an entry from the trace stack */
xltpop()
{
    xltrace--;
}

/* stacktop - return the top node on the stack */
LOCAL NODE *stacktop()
{
    return (xltrace >= 0 && xltrace < TDEPTH ? trace_stack[xltrace] : s_unbound);
}

/* baktrace - do a back trace */
xlbaktrace(n)
  int n;
{
    int i;

    for (i = xltrace; (n < 0 || n--) && i >= 0; i--)
	if (i < TDEPTH)
	    stdprint(trace_stack[i]);
}

/* xldinit - debug initialization routine */
xldinit()
{
    if ((trace_stack = (NODE **) malloc(TSTKSIZE)) == NULL)
	xlabort("insufficient memory");
    total += (long) TSTKSIZE;
    xltrace = -1;
    xldebug = 0;
}
//E*O*F xldbug.c//

echo x - xldmem.c
cat > "xldmem.c" << '//E*O*F xldmem.c//'
/* xldmem - xlisp dynamic memory management routines */

#include "xlisp.h"

/* useful definitions */
#define ALLOCSIZE (sizeof(struct segment) + (anodes-1) * sizeof(NODE))

/* external variables */
extern NODE *oblist,*keylist;
extern NODE *xlstack;
extern NODE *xlenv,*xlnewenv;
extern long total;
extern int anodes,nnodes,nsegs,nfree,gccalls;
extern struct segment *segs;
extern NODE *fnodes;

/* external procedures */
extern char *malloc();
extern char *calloc();

/* newnode - allocate a new node */
NODE *newnode(type)
  int type;
{
    NODE *nnode;

    /* get a free node */
    if ((nnode = fnodes) == NIL) {
	gc();
	if ((nnode = fnodes) == NIL)
	    xlabort("insufficient node space");
    }

    /* unlink the node from the free list */
    fnodes = cdr(nnode);
    nfree -= 1;

    /* initialize the new node */
    nnode->n_type = type;
    rplacd(nnode,NIL);

    /* return the new node */
    return (nnode);
}

/* stralloc - allocate memory for a string adding a byte for the terminator */
char *stralloc(size)
  int size;
{
    char *sptr;

    /* allocate memory for the string copy */
    if ((sptr = malloc(size+1)) == NULL) {
	gc();
	if ((sptr = malloc(size+1)) == NULL)
	    xlfail("insufficient string space");
    }
    total += (long) (size+1);

    /* return the new string memory */
    return (sptr);
}

/* strsave - generate a dynamic copy of a string */
char *strsave(str)
  char *str;
{
    char *sptr;

    /* create a new string */
    sptr = stralloc(strlen(str));
    strcpy(sptr,str);

    /* return the new string */
    return (sptr);
}

/* strfree - free string memory */
strfree(str)
  char *str;
{
    total -= (long) (strlen(str)+1);
    free(str);
}

/* gc - garbage collect */
gc()
{
    NODE *p;

    /* mark all accessible nodes */
    mark(oblist); mark(keylist);
    mark(xlenv);
    mark(xlnewenv);

    /* mark the evaluation stack */
    for (p = xlstack; p; p = cdr(p))
	mark(car(p));

    /* sweep memory collecting all unmarked nodes */
    sweep();

    /* if there's still nothing available, allocate more memory */
    if (fnodes == NIL)
	addseg();

    /* count the gc call */
    gccalls++;
}

/* mark - mark all accessible nodes */
LOCAL mark(ptr)
  NODE *ptr;
{
    NODE *this,*prev,*tmp;

    /* just return on nil */
    if (ptr == NIL)
	return;

    /* initialize */
    prev = NIL;
    this = ptr;

    /* mark this list */
    while (TRUE) {

	/* descend as far as we can */
	while (TRUE) {

	    /* check for this node being marked */
	    if (this->n_flags & MARK)
		break;

	    /* mark it and its descendants */
	    else {

		/* mark the node */
		this->n_flags |= MARK;

		/* follow the left sublist if there is one */
		if (livecar(this)) {
		    this->n_flags |= LEFT;
		    tmp = prev;
		    prev = this;
		    this = car(prev);
		    rplaca(prev,tmp);
		}

		/* otherwise, follow the right sublist if there is one */
		else if (livecdr(this)) {
		    this->n_flags &= ~LEFT;
		    tmp = prev;
		    prev = this;
		    this = cdr(prev);
		    rplacd(prev,tmp);
		}
		else
		    break;
	    }
	}

	/* backup to a point where we can continue descending */
	while (TRUE) {

	    /* check for termination condition */
	    if (prev == NIL)
		return;

	    /* check for coming from the left side */
	    if (prev->n_flags & LEFT)
		if (livecdr(prev)) {
		    prev->n_flags &= ~LEFT;
		    tmp = car(prev);
		    rplaca(prev,this);
		    this = cdr(prev);
		    rplacd(prev,tmp);
		    break;
		}
		else {
		    tmp = prev;
		    prev = car(tmp);
		    rplaca(tmp,this);
		    this = tmp;
		}

	    /* otherwise, came from the right side */
	    else {
		tmp = prev;
		prev = cdr(tmp);
		rplacd(tmp,this);
		this = tmp;
	    }
	}
    }
}

/* sweep - sweep all unmarked nodes and add them to the free list */
LOCAL sweep()
{
    struct segment *seg;
    NODE *p;
    int n;

    /* empty the free list */
    fnodes = NIL;
    nfree = 0;

    /* add all unmarked nodes */
    for (seg = segs; seg != NULL; seg = seg->sg_next) {
	p = &seg->sg_nodes[0];
	for (n = seg->sg_size; n--; p++)
	    if (!(p->n_flags & MARK)) {
		switch (ntype(p)) {
		case STR:
			if (p->n_strtype == DYNAMIC && p->n_str != NULL)
			    strfree(p->n_str);
			break;
		case FPTR:
			if (p->n_fp)
			    fclose(p->n_fp);
			break;
		}
		p->n_type = FREE;
		p->n_flags = 0;
		rplaca(p,NIL);
		rplacd(p,fnodes);
		fnodes = p;
		nfree++;
	    }
	    else
		p->n_flags &= ~(MARK | LEFT);
    }
}

/* addseg - add a segment to the available memory */
int addseg()
{
    struct segment *newseg;
    NODE *p;
    int n;

    /* check for zero allocation */
    if (anodes == 0)
	return (FALSE);

    /* allocate a new segment */
    if ((newseg = (struct segment *) calloc(1,ALLOCSIZE)) != NULL) {

	/* initialize the new segment */
	newseg->sg_size = anodes;
	newseg->sg_next = segs;
	segs = newseg;

	/* add each new node to the free list */
	p = &newseg->sg_nodes[0];
	for (n = anodes; n--; ) {
	    rplacd(p,fnodes);
	    fnodes = p++;
	}

	/* update the statistics */
	total += (long) ALLOCSIZE;
	nnodes += anodes;
	nfree += anodes;
	nsegs++;

	/* return successfully */
	return (TRUE);
    }
    else
	return (FALSE);
}
 
/* livecar - do we need to follow the car? */
LOCAL int livecar(n)
  NODE *n;
{
    switch (ntype(n)) {
    case SUBR:
    case FSUBR:
    case INT:
    case STR:
    case FPTR:
	    return (FALSE);
    case SYM:
    case LIST:
    case OBJ:
	    return (car(n) != NIL);
    default:
	    printf("bad node type (%d) found during left scan\n",ntype(n));
	    exit();
    }
}

/* livecdr - do we need to follow the cdr? */
LOCAL int livecdr(n)
  NODE *n;
{
    switch (ntype(n)) {
    case SUBR:
    case FSUBR:
    case INT:
    case STR:
    case FPTR:
	    return (FALSE);
    case SYM:
    case LIST:
    case OBJ:
	    return (cdr(n) != NIL);
    default:
	    printf("bad node type (%d) found during right scan\n",ntype(n));
	    exit();
    }
}

/* stats - print memory statistics */
stats()
{
    printf("Nodes:       %d\n",nnodes);
    printf("Free nodes:  %d\n",nfree);
    printf("Segments:    %d\n",nsegs);
    printf("Allocate:    %d\n",anodes);
    printf("Total:       %ld\n",total);
    printf("Collections: %d\n",gccalls);
}

/* xlminit - initialize the dynamic memory module */
xlminit()
{
    /* initialize our internal variables */
    anodes = NNODES;
    total = 0L;
    nnodes = nsegs = nfree = gccalls = 0;
    fnodes = NIL;
    segs = NULL;

    /* initialize structures that are marked by the collector */
    xlstack = xlenv = xlnewenv = oblist = keylist = NIL;
}
//E*O*F xldmem.c//

echo x - xleval.c
cat > "xleval.c" << '//E*O*F xleval.c//'
/* xleval - xlisp evaluator */

#include "xlisp.h"

/* external variables */
extern NODE *xlstack,*xlenv,*xlnewenv;
extern NODE *s_lambda,*s_macro;
extern NODE *k_optional,*k_rest,*k_aux;
extern NODE *s_evalhook,*s_applyhook;
extern NODE *s_unbound;
extern NODE *s_stdout;

/* forward declarations */
FORWARD NODE *xlxeval();
FORWARD NODE *evalhook();
FORWARD NODE *evform();
FORWARD NODE *evsym();
FORWARD NODE *evfun();

/* xleval - evaluate an xlisp expression (checking for *evalhook*) */
NODE *xleval(expr)
  NODE *expr;
{
    return (s_evalhook->n_symvalue ? evalhook(expr) : xlxeval(expr));
}

/* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
NODE *xlxeval(expr)
  NODE *expr;
{
    /* evaluate nil to itself */
    if (expr == NIL)
	return (NIL);

    /* add trace entry */
    xltpush(expr);

    /* check type of value */
    if (consp(expr))
	expr = evform(expr);
    else if (symbolp(expr))
	expr = evsym(expr);

    /* remove trace entry */
    xltpop();

    /* return the value */
    return (expr);
}

/* xlapply - apply a function to a list of arguments */
NODE *xlapply(fun,args)
  NODE *fun,*args;
{
    NODE *val;

    /* check for a null function */
    if (fun == NIL)
	xlfail("bad function");

    /* evaluate the function */
    if (subrp(fun))
	val = (*fun->n_subr)(args);
    else if (consp(fun)) {
	if (car(fun) != s_lambda)
	    xlfail("bad function type");
	val = evfun(fun,args);
    }
    else
	xlfail("bad function");

    /* return the result value */
    return (val);
}

/* evform - evaluate a form */
LOCAL NODE *evform(expr)
  NODE *expr;
{
    NODE *oldstk,fun,args,*val,*type;

    /* create a stack frame */
    oldstk = xlsave(&fun,&args,NULL);

    /* get the function and the argument list */
    fun.n_ptr = car(expr);
    args.n_ptr = cdr(expr);

    /* evaluate the first expression */
    if ((fun.n_ptr = xleval(fun.n_ptr)) == NIL)
	xlfail("bad function");

    /* evaluate the function */
    if (subrp(fun.n_ptr) || fsubrp(fun.n_ptr)) {
	if (subrp(fun.n_ptr))
	    args.n_ptr = xlevlist(args.n_ptr);
	val = (*fun.n_ptr->n_subr)(args.n_ptr);
    }
    else if (consp(fun.n_ptr)) {
	if ((type = car(fun.n_ptr)) == s_lambda) {
	    args.n_ptr = xlevlist(args.n_ptr);
	    val = evfun(fun.n_ptr,args.n_ptr);
	}
	else if (type == s_macro) {
	    args.n_ptr = evfun(fun.n_ptr,args.n_ptr);
	    val = xleval(args.n_ptr);
	}
	else
	    xlfail("bad function type");
    }
    else if (objectp(fun.n_ptr))
	val = xlsend(fun.n_ptr,args.n_ptr);
    else
	xlfail("bad function");

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result value */
    return (val);
}

/* evalhook - call the evalhook function */
LOCAL NODE *evalhook(expr)
  NODE *expr;
{
    NODE *oldstk,*oldenv,fun,args,*val;

    /* create a new stack frame */
    oldstk = xlsave(&fun,&args,NULL);

    /* get the hook function */
    fun.n_ptr = s_evalhook->n_symvalue;

    /* make an argument list */
    args.n_ptr = newnode(LIST);
    rplaca(args.n_ptr,expr);

    /* rebind the hook functions to nil */
    oldenv = xlenv;
    xlsbind(s_evalhook,NIL);
    xlsbind(s_applyhook,NIL);

    /* call the hook function */
    val = xlapply(fun.n_ptr,args.n_ptr);

    /* unbind the symbols */
    xlunbind(oldenv);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the value */
    return (val);
}

/* xlevlist - evaluate a list of arguments */
NODE *xlevlist(args)
  NODE *args;
{
    NODE *oldstk,src,dst,*new,*last,*val;

    /* create a stack frame */
    oldstk = xlsave(&src,&dst,NULL);

    /* initialize */
    src.n_ptr = args;

    /* evaluate each argument */
    for (val = NIL; src.n_ptr; src.n_ptr = cdr(src.n_ptr)) {

	/* check this entry */
	if (!consp(src.n_ptr))
	    xlfail("bad argument list");

	/* allocate a new list entry */
	new = newnode(LIST);
	if (val)
	    rplacd(last,new);
	else
	    val = dst.n_ptr = new;
	rplaca(new,xleval(car(src.n_ptr)));
	last = new;
    }

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the new list */
    return (val);
}

/* evsym - evaluate a symbol */
LOCAL NODE *evsym(sym)
  NODE *sym;
{
    NODE *p;

    /* check for a reference to an instance variable */
    if ((p = xlobsym(sym)) != NIL)
	return (car(p));

    /* get the value of the variable */
    while ((p = sym->n_symvalue) == s_unbound)
	xlunbound(sym);

    /* return the value */
    return (p);
}

/* xlunbound - signal an unbound variable error */
xlunbound(sym)
  NODE *sym;
{
    xlcerror("try evaluating symbol again","unbound variable",sym);
}

/* evfun - evaluate a function */
LOCAL NODE *evfun(fun,args)
  NODE *fun,*args;
{
    NODE *oldstk,*oldenv,*oldnewenv,cptr,*fargs,*val;

    /* create a stack frame */
    oldstk = xlsave(&cptr,NULL);

    /* skip the function type */
    if ((fun = cdr(fun)) == NIL || !consp(fun))
	xlfail("bad function definition");

    /* get the formal argument list */
    if ((fargs = car(fun)) && !consp(fargs))
	xlfail("bad formal argument list");

    /* bind the formal parameters */
    oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
    xlabind(fargs,args);
    xlfixbindings();

    /* execute the code */
    for (cptr.n_ptr = cdr(fun); cptr.n_ptr != NIL; )
	val = xlevarg(&cptr.n_ptr);

    /* restore the environment */
    xlunbind(oldenv); xlnewenv = oldnewenv;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result value */
    return (val);
}

/* xlabind - bind the arguments for a function */
xlabind(fargs,aargs)
  NODE *fargs,*aargs;
{
    NODE *arg;

    /* evaluate and bind each required argument */
    while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {

	/* bind the formal variable to the argument value */
	xlbind(arg,car(aargs));

	/* move the argument list pointers ahead */
	fargs = cdr(fargs);
	aargs = cdr(aargs);
    }

    /* check for the '&optional' keyword */
    if (consp(fargs) && car(fargs) == k_optional) {
	fargs = cdr(fargs);

	/* bind the arguments that were supplied */
	while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {

	    /* bind the formal variable to the argument value */
	    xlbind(arg,car(aargs));

	    /* move the argument list pointers ahead */
	    fargs = cdr(fargs);
	    aargs = cdr(aargs);
	}

	/* bind the rest to nil */
	while (consp(fargs) && !iskeyword(arg = car(fargs))) {

	    /* bind the formal variable to nil */
	    xlbind(arg,NIL);

	    /* move the argument list pointer ahead */
	    fargs = cdr(fargs);
	}
    }

    /* check for the '&rest' keyword */
    if (consp(fargs) && car(fargs) == k_rest) {
	fargs = cdr(fargs);
	if (consp(fargs) && (arg = car(fargs)) && !iskeyword(arg))
	    xlbind(arg,aargs);
	else
	    xlfail("symbol missing after &rest");
	fargs = cdr(fargs);
	aargs = NIL;
    }

    /* check for the '&aux' keyword */
    if (consp(fargs) && car(fargs) == k_aux)
	while ((fargs = cdr(fargs)) != NIL && consp(fargs))
	    xlbind(car(fargs),NIL);

    /* make sure the correct number of arguments were supplied */
    if (fargs != aargs)
	xlfail(fargs ? "too few arguments" : "too many arguments");
}

/* iskeyword - check to see if a symbol is a keyword */
LOCAL int iskeyword(sym)
  NODE *sym;
{
    return (sym == k_optional || sym == k_rest || sym == k_aux);
}

/* xlsave - save nodes on the stack */
NODE *xlsave(n)
  NODE *n;
{
    NODE **nptr,*oldstk;

    /* save the old stack pointer */
    oldstk = xlstack;

    /* save each node */
    for (nptr = &n; *nptr != NULL; nptr++) {
	rplaca(*nptr,NIL);
	rplacd(*nptr,xlstack);
	xlstack = *nptr;
    }

    /* return the old stack pointer */
    return (oldstk);
}
//E*O*F xleval.c//

echo x - xlfio.c
cat > "xlfio.c" << '//E*O*F xlfio.c//'
/* xlfio.c - xlisp file i/o */

#include "xlisp.h"
#include "ctype.h"

/* external variables */
extern NODE *s_stdin,*s_stdout;
extern NODE *xlstack;
extern int xlfsize;
extern char buf[];

/* external routines */
extern FILE *fopen();

/* forward declarations */
FORWARD NODE *printit();
FORWARD NODE *flatsize();
FORWARD NODE *explode();
FORWARD NODE *implode();
FORWARD NODE *openit();
FORWARD NODE *getfile();

/* xread - read an expression */
NODE *xread(args)
  NODE *args;
{
    NODE *oldstk,fptr,eof,*val;

    /* create a new stack frame */
    oldstk = xlsave(&fptr,&eof,NULL);

    /* get file pointer and eof value */
    fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
    eof.n_ptr = (args ? xlarg(&args) : NIL);
    xllastarg(args);

    /* read an expression */
    if (!xlread(fptr.n_ptr,&val))
	val = eof.n_ptr;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the expression */
    return (val);
}

/* xprint - builtin function 'print' */
NODE *xprint(args)
  NODE *args;
{
    return (printit(args,TRUE,TRUE));
}

/* xprin1 - builtin function 'prin1' */
NODE *xprin1(args)
  NODE *args;
{
    return (printit(args,TRUE,FALSE));
}

/* xprinc - builtin function princ */
NODE *xprinc(args)
  NODE *args;
{
    return (printit(args,FALSE,FALSE));
}

/* xterpri - terminate the current print line */
NODE *xterpri(args)
  NODE *args;
{
    NODE *fptr;

    /* get file pointer */
    fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
    xllastarg(args);

    /* terminate the print line and return nil */
    xlterpri(fptr);
    return (NIL);
}

/* printit - common print function */
LOCAL NODE *printit(args,pflag,tflag)
  NODE *args; int pflag,tflag;
{
    NODE *oldstk,fptr,val;

    /* create a new stack frame */
    oldstk = xlsave(&fptr,&val,NULL);

    /* get expression to print and file pointer */
    val.n_ptr = xlarg(&args);
    fptr.n_ptr = (args ? getfile(&args) : s_stdout->n_symvalue);
    xllastarg(args);

    /* print the value */
    xlprint(fptr.n_ptr,val.n_ptr,pflag);

    /* terminate the print line if necessary */
    if (tflag)
	xlterpri(fptr.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result */
    return (val.n_ptr);
}

/* xflatsize - compute the size of a printed representation using prin1 */
NODE *xflatsize(args)
  NODE *args;
{
    return (flatsize(args,TRUE));
}

/* xflatc - compute the size of a printed representation using princ */
NODE *xflatc(args)
  NODE *args;
{
    return (flatsize(args,FALSE));
}

/* flatsize - compute the size of a printed expression */
LOCAL NODE *flatsize(args,pflag)
  NODE *args; int pflag;
{
    NODE *oldstk,val;

    /* create a new stack frame */
    oldstk = xlsave(&val,NULL);

    /* get the expression */
    val.n_ptr = xlarg(&args);
    xllastarg(args);

    /* print the value to compute its size */
    xlfsize = 0;
    xlprint(NIL,val.n_ptr,pflag);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the length of the expression */
    val.n_ptr = newnode(INT);
    val.n_ptr->n_int = xlfsize;
    return (val.n_ptr);
}

/* xexplode - explode an expression */
NODE *xexplode(args)
  NODE *args;
{
    return (explode(args,TRUE));
}

/* xexplc - explode an expression using princ */
NODE *xexplc(args)
  NODE *args;
{
    return (explode(args,FALSE));
}

/* explode - internal explode routine */
LOCAL NODE *explode(args,pflag)
  NODE *args; int pflag;
{
    NODE *oldstk,val,strm;

    /* create a new stack frame */
    oldstk = xlsave(&val,&strm,NULL);

    /* get the expression */
    val.n_ptr = xlarg(&args);
    xllastarg(args);

    /* create a stream */
    strm.n_ptr = newnode(LIST);

    /* print the value into the stream */
    xlprint(strm.n_ptr,val.n_ptr,pflag);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the list of characters */
    return (car(strm.n_ptr));
}

/* ximplode - implode a list of characters into a symbol */
NODE *ximplode(args)
  NODE *args;
{
    return (implode(args,TRUE));
}

/* xmaknam - implode a list of characters into an uninterned symbol */
NODE *xmaknam(args)
  NODE *args;
{
    return (implode(args,FALSE));
}

/* implode - internal implode routine */
LOCAL NODE *implode(args,intflag)
  NODE *args; int intflag;
{
    NODE *list,*val;
    char *p;

    /* get the list */
    list = xlarg(&args);
    xllastarg(args);

    /* assemble the symbol's pname */
    for (p = buf; consp(list); list = cdr(list)) {
	if ((val = car(list)) == NIL || !fixp(val))
	    xlfail("bad character list");
	if ((int)(p - buf) < STRMAX)
	    *p++ = val->n_int;
    }
    *p = 0;

    /* create a symbol */
    val = (intflag ? xlenter(buf,DYNAMIC) : xlmakesym(buf,DYNAMIC));

    /* return the symbol */
    return (val);
}

/* xopeni - open an input file */
NODE *xopeni(args)
  NODE *args;
{
    return (openit(args,"r"));
}

/* xopeno - open an output file */
NODE *xopeno(args)
  NODE *args;
{
    return (openit(args,"w"));
}

/* openit - common file open routine */
LOCAL NODE *openit(args,mode)
  NODE *args; char *mode;
{
    NODE *fname,*val;
    FILE *fp;

    /* get the file name */
    fname = xlmatch(STR,&args);
    xllastarg(args);

    /* try to open the file */
    if ((fp = fopen(fname->n_str,mode)) != NULL) {
	val = newnode(FPTR);
	val->n_fp = fp;
	val->n_savech = 0;
    }
    else
	val = NIL;

    /* return the file pointer */
    return (val);
}

/* xclose - close a file */
NODE *xclose(args)
  NODE *args;
{
    NODE *fptr;

    /* get file pointer */
    fptr = xlmatch(FPTR,&args);
    xllastarg(args);

    /* make sure the file exists */
    if (fptr->n_fp == NULL)
	xlfail("file not open");

    /* close the file */
    fclose(fptr->n_fp);
    fptr->n_fp = NULL;

    /* return nil */
    return (NIL);
}

/* xrdchar - read a character from a file */
NODE *xrdchar(args)
  NODE *args;
{
    NODE *fptr,*val;
    int ch;

    /* get file pointer */
    fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
    xllastarg(args);

    /* get character and check for eof */
    if ((ch = xlgetc(fptr)) == EOF)
	val = NIL;
    else {
	val = newnode(INT);
	val->n_int = ch;
    }

    /* return the character */
    return (val);
}

/* xpkchar - peek at a character from a file */
NODE *xpkchar(args)
  NODE *args;
{
    NODE *flag,*fptr,*val;
    int ch;

    /* peek flag and get file pointer */
    flag = (args ? xlarg(&args) : NIL);
    fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
    xllastarg(args);

    /* skip leading white space and get a character */
    if (flag)
	while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
	    xlgetc(fptr);
    else
	ch = xlpeek(fptr);

    /* check for eof */
    if (ch == EOF)
	val = NIL;
    else {
	val = newnode(INT);
	val->n_int = ch;
    }

    /* return the character */
    return (val);
}

/* xwrchar - write a character to a file */
NODE *xwrchar(args)
  NODE *args;
{
    NODE *fptr,*chr;

    /* get the character and file pointer */
    chr = xlmatch(INT,&args);
    fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
    xllastarg(args);

    /* put character to the file */
    xlputc(fptr,chr->n_int);

    /* return the character */
    return (chr);
}

/* xreadline - read a line from a file */
NODE *xreadline(args)
  NODE *args;
{
    NODE *oldstk,fptr,str;
    char *p,*sptr;
    int len,ch;

    /* create a new stack frame */
    oldstk = xlsave(&fptr,&str,NULL);

    /* get file pointer */
    fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
    xllastarg(args);

    /* make a string node */
    str.n_ptr = newnode(STR);
    str.n_ptr->n_strtype = DYNAMIC;

    /* get character and check for eof */
    len = 0; p = buf;
    while ((ch = xlgetc(fptr.n_ptr)) != EOF && ch != '\n') {

	/* check for buffer overflow */
	if ((int)(p - buf) == STRMAX) {
	    *p = 0;
 	    sptr = stralloc(len + STRMAX); *sptr = 0;
	    if (len) {
		strcpy(sptr,str.n_ptr->n_str);
		strfree(str.n_ptr->n_str);
	    }
	    str.n_ptr->n_str = sptr;
	    strcat(sptr,buf);
	    len += STRMAX;
	    p = buf;
	}

	/* store the character */
	*p++ = ch;
    }

    /* check for end of file */
    if (len == 0 && p == buf && ch == EOF) {
	xlstack = oldstk;
	return (NIL);
    }

    /* append the last substring */
    *p = 0;
    sptr = stralloc(len + (int)(p - buf)); *sptr = 0;
    if (len) {
	strcpy(sptr,str.n_ptr->n_str);
	strfree(str.n_ptr->n_str);
    }
    str.n_ptr->n_str = sptr;
    strcat(sptr,buf);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the string */
    return (str.n_ptr);
}

/* getfile - get a file or stream */
LOCAL NODE *getfile(pargs)
  NODE **pargs;
{
    NODE *arg;

    /* get a file or stream (cons) or nil */
    if (arg = xlarg(pargs)) {
	if (filep(arg)) {
	    if (arg->n_fp == NULL)
		xlfail("file not open");
	}
	else if (!consp(arg))
	    xlfail("bad argument type");
    }
    return (arg);
}
//E*O*F xlfio.c//

echo x - xlftab.c
cat > "xlftab.c" << '//E*O*F xlftab.c//'
/* xlftab.c - xlisp function table */

#include "xlisp.h"

/* external functions */
extern NODE
    *xeval(),*xapply(),*xfuncall(),*xquote(),*xbquote(),
    *xset(),*xsetq(),*xsetf(),*xdefun(),*xdefmacro(),
    *xgensym(),*xmakesymbol(),*xintern(),
    *xsymname(),*xsymvalue(),*xsymplist(),*xget(),*xremprop(),
    *xcar(),*xcaar(),*xcadr(),*xcdr(),*xcdar(),*xcddr(),
    *xcons(),*xlist(),*xappend(),*xreverse(),*xlast(),*xnth(),*xnthcdr(),
    *xmember(),*xassoc(),*xsubst(),*xsublis(),*xremove(),*xlength(),
    *xmapc(),*xmapcar(),*xmapl(),*xmaplist(),
    *xrplca(),*xrplcd(),*xnconc(),*xdelete(),
    *xatom(),*xsymbolp(),*xnumberp(),*xboundp(),*xnull(),*xlistp(),*xconsp(),
    *xeq(),*xeql(),*xequal(),
    *xcond(),*xand(),*xor(),*xlet(),*xletstar(),*xif(),
    *xprog(),*xprogstar(),*xprog1(),*xprog2(),*xprogn(),*xgo(),*xreturn(),
    *xcatch(),*xthrow(),
    *xerror(),*xcerror(),*xbreak(),*xerrset(),*xbaktrace(),*xevalhook(),
    *xdo(),*xdostar(),*xdolist(),*xdotimes(),
    *xadd(),*xsub(),*xmul(),*xdiv(),*xrem(),*xmin(),*xmax(),*xabs(),
    *xadd1(),*xsub1(),*xbitand(),*xbitior(),*xbitxor(),*xbitnot(),
    *xminusp(),*xzerop(),*xplusp(),*xevenp(),*xoddp(),
    *xlss(),*xleq(),*xequ(),*xneq(),*xgeq(),*xgtr(),
    *xstrlen(),*xstrcat(),*xsubstr(),*xascii(),*xchr(),*xatoi(),*xitoa(),
    *xread(),*xprint(),*xprin1(),*xprinc(),*xterpri(),
    *xflatsize(),*xflatc(),*xexplode(),*xexplc(),*ximplode(),*xmaknam(),
    *xopeni(),*xopeno(),*xclose(),*xrdchar(),*xpkchar(),*xwrchar(),*xreadline(),
    *xload(),*xgc(),*xexpand(),*xalloc(),*xmem(),*xtype(),*xexit();

/* the function table */
struct fdef ftab[] = {

	/* evaluator functions */
{	"eval",		SUBR,	xeval		},
{	"apply",	SUBR,	xapply		},
{	"funcall",	SUBR,	xfuncall	},
{	"quote",	FSUBR,	xquote		},
{	"function",	FSUBR,	xquote		},
{	"backquote",	FSUBR,	xbquote		},

	/* symbol functions */
{	"set",		SUBR,	xset		},
{	"setq",		FSUBR,	xsetq		},
{	"setf",		FSUBR,	xsetf		},
{	"defun",	FSUBR,	xdefun		},
{	"defmacro",	FSUBR,	xdefmacro	},
{	"gensym",	SUBR,	xgensym		},
{	"make-symbol",	SUBR,	xmakesymbol	},
{	"intern",	SUBR,	xintern		},
{	"symbol-name",	SUBR,	xsymname	},
{	"symbol-value",	SUBR,	xsymvalue	},
{	"symbol-plist",	SUBR,	xsymplist	},
{	"get",		SUBR,	xget		},
{	"remprop",	SUBR,	xremprop	},

	/* list functions */
{	"car",		SUBR,	xcar		},
{	"caar",		SUBR,	xcaar		},
{	"cadr",		SUBR,	xcadr		},
{	"cdr",		SUBR,	xcdr		},
{	"cdar",		SUBR,	xcdar		},
{	"cddr",		SUBR,	xcddr		},
{	"cons",		SUBR,	xcons		},
{	"list",		SUBR,	xlist		},
{	"append",	SUBR,	xappend		},
{	"reverse",	SUBR,	xreverse	},
{	"last",		SUBR,	xlast		},
{	"nth",		SUBR,	xnth		},
{	"nthcdr",	SUBR,	xnthcdr		},
{	"member",	SUBR,	xmember		},
{	"assoc",	SUBR,	xassoc		},
{	"subst",	SUBR,	xsubst		},
{	"sublis",	SUBR,	xsublis		},
{	"remove",	SUBR,	xremove		},
{	"length",	SUBR,	xlength		},
{	"mapc",		SUBR,	xmapc		},
{	"mapcar",	SUBR,	xmapcar		},
{	"mapl",		SUBR,	xmapl		},
{	"maplist",	SUBR,	xmaplist	},

	/* destructive list functions */
{	"rplaca",	SUBR,	xrplca		},
{	"rplacd",	SUBR,	xrplcd		},
{	"nconc",	SUBR,	xnconc		},
{	"delete",	SUBR,	xdelete		},

	/* predicate functions */
{	"atom",		SUBR,	xatom		},
{	"symbolp",	SUBR,	xsymbolp	},
{	"numberp",	SUBR,	xnumberp	},
{	"boundp",	SUBR,	xboundp		},
{	"null",		SUBR,	xnull		},
{	"not",		SUBR,	xnull		},
{	"listp",	SUBR,	xlistp		},
{	"consp",	SUBR,	xconsp		},
{	"minusp",	SUBR,	xminusp		},
{	"zerop",	SUBR,	xzerop		},
{	"plusp",	SUBR,	xplusp		},
{	"evenp",	SUBR,	xevenp		},
{	"oddp",		SUBR,	xoddp		},
{	"eq",		SUBR,	xeq		},
{	"eql",		SUBR,	xeql		},
{	"equal",	SUBR,	xequal		},

	/* control functions */
{	"cond",		FSUBR,	xcond		},
{	"and",		FSUBR,	xand		},
{	"or",		FSUBR,	xor		},
{	"let",		FSUBR,	xlet		},
{	"let*",		FSUBR,	xletstar	},
{	"if",		FSUBR,	xif		},
{	"prog",		FSUBR,	xprog		},
{	"prog*",	FSUBR,	xprogstar	},
{	"prog1",	FSUBR,	xprog1		},
{	"prog2",	FSUBR,	xprog2		},
{	"progn",	FSUBR,	xprogn		},
{	"go",		FSUBR,	xgo		},
{	"return",	SUBR,	xreturn		},
{	"do",		FSUBR,	xdo		},
{	"do*",		FSUBR,	xdostar		},
{	"dolist",	FSUBR,	xdolist		},
{	"dotimes",	FSUBR,	xdotimes	},
{	"catch",	FSUBR,	xcatch		},
{	"throw",	SUBR,	xthrow		},

	/* debugging and error handling functions */
{	"error",	SUBR,	xerror		},
{	"cerror",	SUBR,	xcerror		},
{	"break",	SUBR,	xbreak		},
{	"errset",	FSUBR,	xerrset		},
{	"baktrace",	SUBR,	xbaktrace	},
{	"evalhook",	SUBR,	xevalhook	},

	/* arithmetic functions */
{	"+",		SUBR,	xadd		},
{	"-",		SUBR,	xsub		},
{	"*",		SUBR,	xmul		},
{	"/",		SUBR,	xdiv		},
{	"1+",		SUBR,	xadd1		},
{	"1-",		SUBR,	xsub1		},
{	"rem",		SUBR,	xrem		},
{	"min",		SUBR,	xmin		},
{	"max",		SUBR,	xmax		},
{	"abs",		SUBR,	xabs		},

	/* bitwise logical functions */
{	"bit-and",	SUBR,	xbitand		},
{	"bit-ior",	SUBR,	xbitior		},
{	"bit-xor",	SUBR,	xbitxor		},
{	"bit-not",	SUBR,	xbitnot		},

	/* numeric comparison functions */
{	"<",		SUBR,	xlss		},
{	"<=",		SUBR,	xleq		},
{	"=",		SUBR,	xequ		},
{	"/=",		SUBR,	xneq		},
{	">=",		SUBR,	xgeq		},
{	">",		SUBR,	xgtr		},

	/* string functions */
{	"strlen",	SUBR,	xstrlen		},
{	"strcat",	SUBR,	xstrcat		},
{	"substr",	SUBR,	xsubstr		},
{	"ascii",	SUBR,	xascii		},
{	"chr",		SUBR,	xchr		},
{	"atoi",		SUBR,	xatoi		},
{	"itoa",		SUBR,	xitoa		},

	/* I/O functions */
{	"read",		SUBR,	xread		},
{	"print",	SUBR,	xprint		},
{	"prin1",	SUBR,	xprin1		},
{	"princ",	SUBR,	xprinc		},
{	"terpri",	SUBR,	xterpri		},
{	"flatsize",	SUBR,	xflatsize	},
{	"flatc",	SUBR,	xflatc		},
{	"explode",	SUBR,	xexplode	},
{	"explodec",	SUBR,	xexplc		},
{	"implode",	SUBR,	ximplode	},
{	"maknam",	SUBR,	xmaknam		},

	/* file I/O functions */
{	"openi",	SUBR,	xopeni		},
{	"openo",	SUBR,	xopeno		},
{	"close",	SUBR,	xclose		},
{	"read-char",	SUBR,	xrdchar		},
{	"peek-char",	SUBR,	xpkchar		},
{	"write-char",	SUBR,	xwrchar		},
{	"readline",	SUBR,	xreadline	},

	/* system functions */
{	"load",		SUBR,	xload		},
{	"gc",		SUBR,	xgc		},
{	"expand",	SUBR,	xexpand		},
{	"alloc",	SUBR,	xalloc		},
{	"mem",		SUBR,	xmem		},
{	"type",		SUBR,	xtype		},
{	"exit",		SUBR,	xexit		},

{	0					}
};
//E*O*F xlftab.c//

echo x - xlglob.c
cat > "xlglob.c" << '//E*O*F xlglob.c//'
/* xlglobals - xlisp global variables */

#include "xlisp.h"

/* symbols */
NODE *true = NIL;
NODE *s_quote = NIL, *s_function = NIL;
NODE *s_bquote = NIL, *s_comma = NIL, *s_comat = NIL;
NODE *s_evalhook = NIL, *s_applyhook = NIL;
NODE *s_lambda = NIL, *s_macro = NIL;
NODE *s_stdin = NIL, *s_stdout = NIL;
NODE *s_tracenable = NIL, *s_tlimit = NIL, *s_breakenable = NIL;
NODE *s_continue = NIL, *s_quit = NIL;
NODE *s_car = NIL, *s_cdr = NIL;
NODE *s_get = NIL, *s_svalue = NIL, *s_splist = NIL;
NODE *s_eql = NIL, *k_test = NIL, *k_tnot = NIL;
NODE *k_optional = NIL, *k_rest = NIL, *k_aux = NIL;
NODE *a_subr = NIL, *a_fsubr = NIL;
NODE *a_list = NIL, *a_sym = NIL, *a_int = NIL;
NODE *a_str = NIL, *a_obj = NIL, *a_fptr = NIL;
NODE *oblist = NIL, *keylist = NIL, *s_unbound = NIL;

/* evaluation variables */
NODE *xlstack = NIL;
NODE *xlenv = NIL;
NODE *xlnewenv = NIL;

/* exception handling variables */
CONTEXT *xlcontext = NULL;	/* current exception handler */
NODE *xlvalue = NIL;		/* exception value */

/* debugging variables */
int xldebug = 0;		/* debug level */
int xltrace = -1;		/* trace stack pointer */
NODE **trace_stack = NULL;	/* trace stack */

/* gensym variables */
char gsprefix[STRMAX+1] = { 'G',0 };	/* gensym prefix string */
int gsnumber = 1;		/* gensym number */

/* i/o variables */
int xlplevel = 0;		/* prompt nesting level */
int xlfsize = 0;		/* flat size of current print call */
int prompt = TRUE;		/* input prompt flag */

/* dynamic memory variables */
long total = 0L;		/* total memory in use */
int anodes = 0;			/* number of nodes to allocate */
int nnodes = 0;			/* number of nodes allocated */
int nsegs = 0;			/* number of segments allocated */
int nfree = 0;			/* number of nodes free */
int gccalls = 0;		/* number of gc calls */
struct segment *segs = NULL;	/* list of allocated segments */
NODE *fnodes = NIL;		/* list of free nodes */

/* object programming variables */
NODE *self = NIL, *class = NIL, *object = NIL;
NODE *new = NIL, *isnew = NIL, *msgcls = NIL, *msgclass = NIL;
int varcnt = 0;

/* general purpose string buffer */
char buf[STRMAX+1] = { 0 };
//E*O*F xlglob.c//

echo x - xlinit.c
cat > "xlinit.c" << '//E*O*F xlinit.c//'
/* xlinit.c - xlisp initialization module */

#include "xlisp.h"

/* external variables */
extern NODE *true;
extern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
extern NODE *s_lambda,*s_macro;
extern NODE *s_stdin,*s_stdout;
extern NODE *s_evalhook,*s_applyhook;
extern NODE *s_tracenable,*s_tlimit,*s_breakenable;
extern NODE *s_continue,*s_quit;
extern NODE *s_car,*s_cdr,*s_get,*s_svalue,*s_splist,*s_eql;
extern NODE *k_test,*k_tnot,*k_optional,*k_rest,*k_aux;
extern NODE *a_subr,*a_fsubr;
extern NODE *a_list,*a_sym,*a_int,*a_str,*a_obj,*a_fptr;
extern struct fdef ftab[];

/* xlinit - xlisp initialization routine */
xlinit()
{
    struct fdef *fptr;
    NODE *sym;

    /* initialize xlisp (must be in this order) */
    xlminit();	/* initialize xldmem.c */
    xlsinit();	/* initialize xlsym.c */
    xldinit();	/* initialize xldbug.c */
    xloinit();	/* initialize xlobj.c */

    /* enter the builtin functions */
    for (fptr = ftab; fptr->f_name; fptr++)
	xlsubr(fptr->f_name,fptr->f_type,fptr->f_fcn);

    /* enter the 't' symbol */
    true = xlsenter("t");
    true->n_symvalue = true;

    /* enter some important symbols */
    s_quote	= xlsenter("quote");
    s_function	= xlsenter("function");
    s_bquote	= xlsenter("backquote");
    s_comma	= xlsenter("comma");
    s_comat	= xlsenter("comma-at");
    s_lambda	= xlsenter("lambda");
    s_macro	= xlsenter("macro");
    s_eql	= xlsenter("eql");
    s_continue	= xlsenter("continue");
    s_quit	= xlsenter("quit");

    /* enter setf place specifiers */
    s_car	= xlsenter("car");
    s_cdr	= xlsenter("cdr");
    s_get	= xlsenter("get");
    s_svalue	= xlsenter("symbol-value");
    s_splist	= xlsenter("symbol-plist");

    /* enter parameter list keywords */
    k_test	= xlsenter(":test");
    k_tnot	= xlsenter(":test-not");

    /* enter lambda list keywords */
    k_optional	= xlsenter("&optional");
    k_rest	= xlsenter("&rest");
    k_aux	= xlsenter("&aux");

    /* enter *standard-input* and *standard-output* */
    s_stdin = xlsenter("*standard-input*");
    s_stdin->n_symvalue = newnode(FPTR);
    s_stdin->n_symvalue->n_fp = stdin;
    s_stdin->n_symvalue->n_savech = 0;
    s_stdout = xlsenter("*standard-output*");
    s_stdout->n_symvalue = newnode(FPTR);
    s_stdout->n_symvalue->n_fp = stdout;
    s_stdout->n_symvalue->n_savech = 0;

    /* enter the eval and apply hook variables */
    s_evalhook = xlsenter("*evalhook*");
    s_evalhook->n_symvalue = NIL;
    s_applyhook = xlsenter("*applyhook*");
    s_applyhook->n_symvalue = NIL;

    /* enter the error traceback and the error break enable flags */
    s_tracenable = xlsenter("*tracenable*");
    s_tracenable->n_symvalue = NIL;
    s_tlimit = xlsenter("*tracelimit*");
    s_tlimit->n_symvalue = NIL;
    s_breakenable = xlsenter("*breakenable*");
    s_breakenable->n_symvalue = true;

    /* enter a copyright notice into the oblist */
    sym = xlsenter("**Copyright-1985-by-David-Betz**");
    sym->n_symvalue = true;

    /* enter type names */
    a_subr	= xlsenter("SUBR");
    a_fsubr	= xlsenter("FSUBR");
    a_list	= xlsenter("LIST");
    a_sym	= xlsenter("SYM");
    a_int	= xlsenter("INT");
    a_str	= xlsenter("STR");
    a_obj	= xlsenter("OBJ");
    a_fptr	= xlsenter("FPTR");
}
//E*O*F xlinit.c//

echo x - xlio.c
cat > "xlio.c" << '//E*O*F xlio.c//'
/* xlio - xlisp i/o routines */

#include "xlisp.h"

/* external variables */
extern int xlplevel;
extern int xlfsize;
extern NODE *xlstack;
extern NODE *s_stdin;
extern int xldebug;
extern int prompt;

/* xlgetc - get a character from a file or stream */
int xlgetc(fptr)
  NODE *fptr;
{
    NODE *lptr,*cptr;
    FILE *fp;
    int ch;

    /* check for input from nil */
    if (fptr == NIL)
	ch = EOF;

    /* otherwise, check for input from a stream */
    else if (consp(fptr)) {
	if ((lptr = car(fptr)) == NIL)
	    ch = EOF;
	else {
	    if (!consp(lptr) ||
		(cptr = car(lptr)) == NIL || !fixp(cptr))
		xlfail("bad stream");
	    if (rplaca(fptr,cdr(lptr)) == NIL)
		rplacd(fptr,NIL);
	    ch = cptr->n_int;
	}
    }

    /* otherwise, check for a buffered file character */
    else if (ch = fptr->n_savech)
	fptr->n_savech = 0;

    /* otherwise, get a new character */
    else {

	/* get the file pointer */
	fp = fptr->n_fp;

	/* prompt if necessary */
	if (prompt && fp == stdin) {

	    /* print the debug level */
	    if (xldebug)
		printf("%d:",xldebug);

	    /* print the nesting level */
	    if (xlplevel > 0)
		printf("%d",xlplevel);

	    /* print the prompt */
	    printf("> ");
	    prompt = FALSE;
	}

	/* get the character */
	if (((ch = getc(fp)) == '\n' || ch == EOF) && fp == stdin)
	    prompt = TRUE;

	/* check for input abort */
	if (fp == stdin && ch == '\007') {
	    putchar('\n');
	    xlabort("input aborted");
	}
    }

    /* return the character */
    return (ch);
}

/* xlpeek - peek at a character from a file or stream */
int xlpeek(fptr)
  NODE *fptr;
{
    NODE *lptr,*cptr;
    int ch;

    /* check for input from nil */
    if (fptr == NIL)
	ch = EOF;

    /* otherwise, check for input from a stream */
    else if (consp(fptr)) {
	if ((lptr = car(fptr)) == NIL)
	    ch = EOF;
	else {
	    if (!consp(lptr) ||
		(cptr = car(lptr)) == NIL || !fixp(cptr))
		xlfail("bad stream");
	    ch = cptr->n_int;
	}
    }

    /* otherwise, get the next file character and save it */
    else
	ch = fptr->n_savech = xlgetc(fptr);

    /* return the character */
    return (ch);
}

/* xlputc - put a character to a file or stream */
xlputc(fptr,ch)
  NODE *fptr; int ch;
{
    NODE *oldstk,lptr;

    /* count the character */
    xlfsize++;

    /* check for output to nil */
    if (fptr == NIL)
	;

    /* otherwise, check for output to a stream */
    else if (consp(fptr)) {
	oldstk = xlsave(&lptr,NULL);
	lptr.n_ptr = newnode(LIST);
	rplaca(lptr.n_ptr,newnode(INT));
	car(lptr.n_ptr)->n_int = ch;
	if (cdr(fptr))
	    rplacd(cdr(fptr),lptr.n_ptr);
	else
	    rplaca(fptr,lptr.n_ptr);
	rplacd(fptr,lptr.n_ptr);
	xlstack = oldstk;
    }

    /* otherwise, output the character to a file */
    else
	putc(ch,fptr->n_fp);
}

/* xlflush - flush the input buffer */
int xlflush()
{
    if (!prompt)
	while (xlgetc(s_stdin->n_symvalue) != '\n')
	    ;
}
//E*O*F xlio.c//

echo x - xlisp.c
cat > "xlisp.c" << '//E*O*F xlisp.c//'
/* xlisp - an experimental version of lisp that supports object-oriented
           programming */

#include "xlisp.h"

/* define the banner line string */
#define BANNER	"XLISP version 1.4 - 14-FEB-1985, by David Betz"

/* external variables */
extern NODE *s_stdin,*s_stdout;
extern NODE *s_evalhook,*s_applyhook;
extern NODE *true;

/* main - the main routine */
main()
/*
main(argc,argv)
  int argc; char *argv[];
*/
{
    NODE expr;
    CONTEXT cntxt;
    int i;

    /* print the banner line */
#ifdef MEGAMAX
    _autowin(BANNER);
#else
    printf("%s\n",BANNER);
#endif

    /* setup initialization error handler */
    xlbegin(&cntxt,CF_ERROR,(NODE *) 1);
    if (setjmp(cntxt.c_jmpbuf)) {
	printf("fatal initialization error\n");
	exit();
    }

    /* initialize xlisp */
    xlinit();
    xlend(&cntxt);

    /* reset the error handler */
    xlbegin(&cntxt,CF_ERROR,true);

    /* load "init.lsp" */
    if (setjmp(cntxt.c_jmpbuf) == 0)
	xlload("init",FALSE,FALSE);

    /* load any files mentioned on the command line */
/**
    if (setjmp(cntxt.c_jmpbuf) == 0)
	for (i = 1; i < argc; i++)
	    if (!xlload(argv[i],TRUE,FALSE)) xlfail("can't load file");
**/

    /* create a new stack frame */
    xlsave(&expr,NULL);

    /* main command processing loop */
    while (TRUE) {

	/* setup the error return */
	if (setjmp(cntxt.c_jmpbuf)) {
	    s_evalhook->n_symvalue = NIL;
	    s_applyhook->n_symvalue = NIL;
	    xlflush();
	}

	/* read an expression */
	if (!xlread(s_stdin->n_symvalue,&expr.n_ptr))
	    break;

	/* evaluate the expression */
	expr.n_ptr = xleval(expr.n_ptr);

	/* print it */
	stdprint(expr.n_ptr);
    }
    xlend(&cntxt);
}

/* stdprint - print to standard output */
stdprint(expr)
  NODE *expr;
{
    xlprint(s_stdout->n_symvalue,expr,TRUE);
    xlterpri(s_stdout->n_symvalue);
}
//E*O*F xlisp.c//

echo x - xljump.c
cat > "xljump.c" << '//E*O*F xljump.c//'
/* xljump - execution context routines */

#include "xlisp.h"

/* external variables */
extern CONTEXT *xlcontext;
extern NODE *xlvalue;
extern NODE *xlstack,*xlenv,*xlnewenv;
extern int xltrace,xldebug;

/* xlbegin - beginning of an execution context */
xlbegin(cptr,flags,expr)
  CONTEXT *cptr; int flags; NODE *expr;
{
    cptr->c_flags = flags;
    cptr->c_expr = expr;
    cptr->c_xlstack = xlstack;
    cptr->c_xlenv = xlenv;
    cptr->c_xlnewenv = xlnewenv;
    cptr->c_xltrace = xltrace;
    cptr->c_xlcontext = xlcontext;
    xlcontext = cptr;
}

/* xlend - end of an execution context */
xlend(cptr)
  CONTEXT *cptr;
{
    xlcontext = cptr->c_xlcontext;
}

/* xljump - jump to a saved execution context */
xljump(cptr,type,val)
  CONTEXT *cptr; int type; NODE *val;
{
    /* restore the state */
    xlvalue = val;
    xlstack = cptr->c_xlstack;
    xlunbind(cptr->c_xlenv);
    xlnewenv = cptr->c_xlnewenv;
    xltrace = cptr->c_xltrace;

    /* call the handler */
    longjmp(cptr->c_jmpbuf,type);
}

/* xlgo - go to a label */
xlgo(label)
  NODE *label;
{
    CONTEXT *cptr;
    NODE *p;

    /* find a tagbody context */
    for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
	if (cptr->c_flags & CF_GO)
	    for (p = cptr->c_expr; consp(p); p = cdr(p))
		if (car(p) == label)
		    xljump(cptr,CF_GO,p);
    xlfail("no target for go");
}

/* xlreturn - return from a block */
xlreturn(val)
  NODE *val;
{
    CONTEXT *cptr;

    /* find a block context */
    for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
	if (cptr->c_flags & CF_RETURN)
	    xljump(cptr,CF_RETURN,val);
    xlfail("no target for return");
}

/* xlthrow - throw to a catch */
xlthrow(tag,val)
  NODE *tag,*val;
{
    CONTEXT *cptr;

    /* find a catch context */
    for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
	if ((cptr->c_flags & CF_THROW) && cptr->c_expr == tag)
	    xljump(cptr,CF_THROW,val);
    xlfail("no target for throw");
}

/* xlsignal - signal an error */
xlsignal(emsg,arg)
  char *emsg; NODE *arg;
{
    CONTEXT *cptr;

    /* find an error catcher */
    for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
	if (cptr->c_flags & CF_ERROR) {
	    if (cptr->c_expr)
		xlerrprint("error",NULL,emsg,arg);
	    xljump(cptr,CF_ERROR,NIL);
	}
    xlfail("no target for error");
}
//E*O*F xljump.c//

echo x - xllist.c
cat > "xllist.c" << '//E*O*F xllist.c//'
/* xllist - xlisp built-in list functions */

#include "xlisp.h"

#ifdef MEGAMAX
overlay "overflow"
#endif

/* external variables */
extern NODE *xlstack;
extern NODE *s_unbound;
extern NODE *true;

/* external routines */
extern int eq(),eql(),equal();

/* forward declarations */
FORWARD NODE *cxr();
FORWARD NODE *nth(),*assoc();
FORWARD NODE *subst(),*sublis(),*map();
FORWARD NODE *cequal();

/* xcar - return the car of a list */
NODE *xcar(args)
  NODE *args;
{
    return (cxr(args,"a"));
}

/* xcdr - return the cdr of a list */
NODE *xcdr(args)
  NODE *args;
{
    return (cxr(args,"d"));
}

/* xcaar - return the caar of a list */
NODE *xcaar(args)
  NODE *args;
{
    return (cxr(args,"aa"));
}

/* xcadr - return the cadr of a list */
NODE *xcadr(args)
  NODE *args;
{
    return (cxr(args,"da"));
}

/* xcdar - return the cdar of a list */
NODE *xcdar(args)
  NODE *args;
{
    return (cxr(args,"ad"));
}

/* xcddr - return the cddr of a list */
NODE *xcddr(args)
  NODE *args;
{
    return (cxr(args,"dd"));
}

/* cxr - common car/cdr routine */
LOCAL NODE *cxr(args,adstr)
  NODE *args; char *adstr;
{
    NODE *list;

    /* get the list */
    list = xlmatch(LIST,&args);
    xllastarg(args);

    /* perform the car/cdr operations */
    while (*adstr && consp(list))
	list = (*adstr++ == 'a' ? car(list) : cdr(list));

    /* make sure the operation succeeded */
    if (*adstr && list)
	xlfail("bad argument");

    /* return the result */
    return (list);
}

/* xcons - construct a new list cell */
NODE *xcons(args)
  NODE *args;
{
    NODE *arg1,*arg2,*val;

    /* get the two arguments */
    arg1 = xlarg(&args);
    arg2 = xlarg(&args);
    xllastarg(args);

    /* construct a new list element */
    val = newnode(LIST);
    rplaca(val,arg1);
    rplacd(val,arg2);

    /* return the list */
    return (val);
}

/* xlist - built a list of the arguments */
NODE *xlist(args)
  NODE *args;
{
    NODE *oldstk,arg,list,val,*last,*lptr;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&list,&val,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* evaluate and append each argument */
    for (last = NIL; arg.n_ptr != NIL; last = lptr) {

	/* evaluate the next argument */
	val.n_ptr = xlarg(&arg.n_ptr);

	/* append this argument to the end of the list */
	lptr = newnode(LIST);
	if (last == NIL)
	    list.n_ptr = lptr;
	else
	    rplacd(last,lptr);
	rplaca(lptr,val.n_ptr);
    }

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the list */
    return (list.n_ptr);
}

/* xappend - built-in function append */
NODE *xappend(args)
  NODE *args;
{
    NODE *oldstk,arg,list,last,val,*lptr;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&list,&last,&val,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* evaluate and append each argument */
    while (arg.n_ptr) {

	/* evaluate the next argument */
	list.n_ptr = xlmatch(LIST,&arg.n_ptr);

	/* append each element of this list to the result list */
	while (consp(list.n_ptr)) {

	    /* append this element */
	    lptr = newnode(LIST);
	    if (last.n_ptr == NIL)
		val.n_ptr = lptr;
	    else
		rplacd(last.n_ptr,lptr);
	    rplaca(lptr,car(list.n_ptr));

	    /* save the new last element */
	    last.n_ptr = lptr;

	    /* move to the next element */
	    list.n_ptr = cdr(list.n_ptr);
	}
    }

    /* restore previous stack frame */
    xlstack = oldstk;

    /* return the list */
    return (val.n_ptr);
}

/* xreverse - built-in function reverse */
NODE *xreverse(args)
  NODE *args;
{
    NODE *oldstk,list,val,*lptr;

    /* create a new stack frame */
    oldstk = xlsave(&list,&val,NULL);

    /* get the list to reverse */
    list.n_ptr = xlmatch(LIST,&args);
    xllastarg(args);

    /* append each element of this list to the result list */
    while (consp(list.n_ptr)) {

	/* append this element */
	lptr = newnode(LIST);
	rplaca(lptr,car(list.n_ptr));
	rplacd(lptr,val.n_ptr);
	val.n_ptr = lptr;

	/* move to the next element */
	list.n_ptr = cdr(list.n_ptr);
    }

    /* restore previous stack frame */
    xlstack = oldstk;

    /* return the list */
    return (val.n_ptr);
}

/* xlast - return the last cons of a list */
NODE *xlast(args)
  NODE *args;
{
    NODE *list;

    /* get the list */
    list = xlmatch(LIST,&args);
    xllastarg(args);

    /* find the last cons */
    while (consp(list) && cdr(list))
	list = cdr(list);

    /* return the last element */
    return (list);
}

/* xmember - built-in function 'member' */
NODE *xmember(args)
  NODE *args;
{
    NODE *oldstk,x,list,fcn,*val;
    int tresult;

    /* create a new stack frame */
    oldstk = xlsave(&x,&list,&fcn,NULL);

    /* get the expression to look for and the list */
    x.n_ptr = xlarg(&args);
    list.n_ptr = xlmatch(LIST,&args);
    xltest(&fcn.n_ptr,&tresult,&args);
    xllastarg(args);

    /* look for the expression */
    for (val = NIL; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr))
	if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) == tresult) {
	    val = list.n_ptr;
	    break;
	}

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result */
    return (val);
}

/* xassoc - built-in function 'assoc' */
NODE *xassoc(args)
  NODE *args;
{
    NODE *oldstk,x,alist,fcn,*pair,*val;
    int tresult;

    /* create a new stack frame */
    oldstk = xlsave(&x,&alist,&fcn,NULL);

    /* get the expression to look for and the association list */
    x.n_ptr = xlarg(&args);
    alist.n_ptr = xlmatch(LIST,&args);
    xltest(&fcn.n_ptr,&tresult,&args);
    xllastarg(args);

    /* look for the expression */
    for (val = NIL; consp(alist.n_ptr); alist.n_ptr = cdr(alist.n_ptr))
	if ((pair = car(alist.n_ptr)) && consp(pair))
	    if (dotest(x.n_ptr,car(pair),fcn.n_ptr) == tresult) {
		val = pair;
		break;
	    }

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result */
    return (val);
}

/* xsubst - substitute one expression for another */
NODE *xsubst(args)
  NODE *args;
{
    NODE *oldstk,to,from,expr,fcn,*val;
    int tresult;

    /* create a new stack frame */
    oldstk = xlsave(&to,&from,&expr,&fcn,NULL);

    /* get the to value, the from value and the expression */
    to.n_ptr = xlarg(&args);
    from.n_ptr = xlarg(&args);
    expr.n_ptr = xlarg(&args);
    xltest(&fcn.n_ptr,&tresult,&args);
    xllastarg(args);

    /* do the substitution */
    val = subst(to.n_ptr,from.n_ptr,expr.n_ptr,fcn.n_ptr,tresult);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result */
    return (val);
}

/* subst - substitute one expression for another */
LOCAL NODE *subst(to,from,expr,fcn,tresult)
  NODE *to,*from,*expr,*fcn; int tresult;
{
    NODE *oldstk,carval,cdrval,*val;

    if (dotest(expr,from,fcn) == tresult)
	val = to;
    else if (consp(expr)) {
	oldstk = xlsave(&carval,&cdrval,NULL);
	carval.n_ptr = subst(to,from,car(expr),fcn,tresult);
	cdrval.n_ptr = subst(to,from,cdr(expr),fcn,tresult);
	val = newnode(LIST);
	rplaca(val,carval.n_ptr);
	rplacd(val,cdrval.n_ptr);
	xlstack = oldstk;
    }
    else
	val = expr;
    return (val);
}

/* xsublis - substitute using an association list */
NODE *xsublis(args)
  NODE *args;
{
    NODE *oldstk,alist,expr,fcn,*val;
    int tresult;

    /* create a new stack frame */
    oldstk = xlsave(&alist,&expr,&fcn,NULL);

    /* get the assocation list and the expression */
    alist.n_ptr = xlmatch(LIST,&args);
    expr.n_ptr = xlarg(&args);
    xltest(&fcn.n_ptr,&tresult,&args);
    xllastarg(args);

    /* do the substitution */
    val = sublis(alist.n_ptr,expr.n_ptr,fcn.n_ptr,tresult);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result */
    return (val);
}

/* sublis - substitute using an association list */
LOCAL NODE *sublis(alist,expr,fcn,tresult)
  NODE *alist,*expr,*fcn; int tresult;
{
    NODE *oldstk,carval,cdrval,*val;

    if (val = assoc(expr,alist,fcn,tresult))
	val = cdr(val);
    else if (consp(expr)) {
	oldstk = xlsave(&carval,&cdrval,NULL);
	carval.n_ptr = sublis(alist,car(expr),fcn,tresult);
	cdrval.n_ptr = sublis(alist,cdr(expr),fcn,tresult);
	val = newnode(LIST);
	rplaca(val,carval.n_ptr);
	rplacd(val,cdrval.n_ptr);
	xlstack = oldstk;
    }
    else
	val = expr;
    return (val);
}

/* assoc - find a pair in an association list */
LOCAL NODE *assoc(expr,alist,fcn,tresult)
  NODE *expr,*alist,*fcn; int tresult;
{
    NODE *pair;

    for (; consp(alist); alist = cdr(alist))
	if ((pair = car(alist)) && consp(pair))
	    if (dotest(expr,car(pair),fcn) == tresult)
		return (pair);
    return (NIL);
}

/* xremove - built-in function 'remove' */
NODE *xremove(args)
  NODE *args;
{
    NODE *oldstk,x,list,fcn,val,*p,*last;
    int tresult;

    /* create a new stack frame */
    oldstk = xlsave(&x,&list,&fcn,&val,NULL);

    /* get the expression to remove and the list */
    x.n_ptr = xlarg(&args);
    list.n_ptr = xlmatch(LIST,&args);
    xltest(&fcn.n_ptr,&tresult,&args);
    xllastarg(args);

    /* remove matches */
    while (consp(list.n_ptr)) {

	/* check to see if this element should be deleted */
	if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) != tresult) {
	    p = newnode(LIST);
	    rplaca(p,car(list.n_ptr));
	    if (val.n_ptr) rplacd(last,p);
	    else val.n_ptr = p;
	    last = p;
	}

	/* move to the next element */
	list.n_ptr = cdr(list.n_ptr);
    }

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the updated list */
    return (val.n_ptr);
}

/* dotest - call a test function */
int dotest(arg1,arg2,fcn)
  NODE *arg1,*arg2,*fcn;
{
    NODE *oldstk,args,*val;

    /* create a new stack frame */
    oldstk = xlsave(&args,NULL);

    /* build an argument list */
    args.n_ptr = newnode(LIST);
    rplaca(args.n_ptr,arg1);
    rplacd(args.n_ptr,newnode(LIST));
    rplaca(cdr(args.n_ptr),arg2);

    /* apply the test function */
    val = xlapply(fcn,args.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result of the test */
    return (val != NIL);
}

/* xnth - return the nth element of a list */
NODE *xnth(args)
  NODE *args;
{
    return (nth(args,FALSE));
}

/* xnthcdr - return the nth cdr of a list */
NODE *xnthcdr(args)
  NODE *args;
{
    return (nth(args,TRUE));
}

/* nth - internal nth function */
LOCAL NODE *nth(args,cdrflag)
  NODE *args; int cdrflag;
{
    NODE *list;
    int n;

    /* get n and the list */
    if ((n = xlmatch(INT,&args)->n_int) < 0)
	xlfail("bad argument");
    if ((list = xlmatch(LIST,&args)) == NIL)
	xlfail("bad argument");
    xllastarg(args);

    /* find the nth element */
    for (; n > 0 && consp(list); n--)
	list = cdr(list);

    /* return the list beginning at the nth element */
    return (cdrflag || !consp(list) ? list : car(list));
}

/* xlength - return the length of a list */
NODE *xlength(args)
  NODE *args;
{
    NODE *list,*val;
    int n;

    /* get the list */
    list = xlmatch(LIST,&args);
    xllastarg(args);

    /* find the length */
    for (n = 0; consp(list); n++)
	list = cdr(list);

    /* create the value node */
    val = newnode(INT);
    val->n_int = n;

    /* return the length */
    return (val);
}

/* xmapc - built-in function 'mapc' */
NODE *xmapc(args)
  NODE *args;
{
    return (map(args,TRUE,FALSE));
}

/* xmapcar - built-in function 'mapcar' */
NODE *xmapcar(args)
  NODE *args;
{
    return (map(args,TRUE,TRUE));
}

/* xmapl - built-in function 'mapl' */
NODE *xmapl(args)
  NODE *args;
{
    return (map(args,FALSE,FALSE));
}

/* xmaplist - built-in function 'maplist' */
NODE *xmaplist(args)
  NODE *args;
{
    return (map(args,FALSE,TRUE));
}

/* map - internal mapping function */
LOCAL NODE *map(args,carflag,valflag)
  NODE *args; int carflag,valflag;
{
    NODE *oldstk,fcn,lists,arglist,val,*last,*p,*x,*y;

    /* create a new stack frame */
    oldstk = xlsave(&fcn,&lists,&arglist,&val,NULL);

    /* get the function to apply and the first list */
    fcn.n_ptr = xlarg(&args);
    lists.n_ptr = xlmatch(LIST,&args);

    /* save the first list if not saving function values */
    if (!valflag)
	val.n_ptr = lists.n_ptr;

    /* set up the list of argument lists */
    p = newnode(LIST);
    rplaca(p,lists.n_ptr);
    lists.n_ptr = p;

    /* get the remaining argument lists */
    while (args) {
	p = newnode(LIST);
	rplacd(p,lists.n_ptr);
	lists.n_ptr = p;
	rplaca(p,xlmatch(LIST,&args));
    }

    /* if the function is a symbol, get its value */
    if (symbolp(fcn.n_ptr))
	fcn.n_ptr = xleval(fcn.n_ptr);

    /* loop through each of the argument lists */
    for (;;) {

	/* build an argument list from the sublists */
	arglist.n_ptr = NIL;
	for (x = lists.n_ptr; x && (y = car(x)) && consp(y); x = cdr(x)) {
	    p = newnode(LIST);
	    rplacd(p,arglist.n_ptr);
	    arglist.n_ptr = p;
	    rplaca(p,carflag ? car(y) : y);
	    rplaca(x,cdr(y));
	}

	/* quit if any of the lists were empty */
	if (x) break;

	/* apply the function to the arguments */
	if (valflag) {
	    p = newnode(LIST);
	    if (val.n_ptr) rplacd(last,p);
	    else val.n_ptr = p;
	    rplaca(p,xlapply(fcn.n_ptr,arglist.n_ptr));
	    last = p;
	}
	else
	    xlapply(fcn.n_ptr,arglist.n_ptr);
    }

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the last test expression value */
    return (val.n_ptr);
}

/* xrplca - replace the car of a list node */
NODE *xrplca(args)
  NODE *args;
{
    NODE *list,*newcar;

    /* get the list and the new car */
    if ((list = xlmatch(LIST,&args)) == NIL)
	xlfail("bad argument");
    newcar = xlarg(&args);
    xllastarg(args);

    /* replace the car */
    rplaca(list,newcar);

    /* return the list node that was modified */
    return (list);
}

/* xrplcd - replace the cdr of a list node */
NODE *xrplcd(args)
  NODE *args;
{
    NODE *list,*newcdr;

    /* get the list and the new cdr */
    if ((list = xlmatch(LIST,&args)) == NIL)
	xlfail("bad argument");
    newcdr = xlarg(&args);
    xllastarg(args);

    /* replace the cdr */
    rplacd(list,newcdr);

    /* return the list node that was modified */
    return (list);
}

/* xnconc - destructively append lists */
NODE *xnconc(args)
  NODE *args;
{
    NODE *list,*last,*val;

    /* concatenate each argument */
    for (val = NIL; args; ) {

	/* concatenate this list */
	if (list = xlmatch(LIST,&args)) {

	    /* check for this being the first non-empty list */
	    if (val)
		rplacd(last,list);
	    else
		val = list;

	    /* find the end of the list */
	    while (consp(cdr(list)))
		list = cdr(list);

	    /* save the new last element */
	    last = list;
	}
    }

    /* return the list */
    return (val);
}

/* xdelete - built-in function 'delete' */
NODE *xdelete(args)
  NODE *args;
{
    NODE *oldstk,x,list,fcn,*last,*val;
    int tresult;

    /* create a new stack frame */
    oldstk = xlsave(&x,&list,&fcn,NULL);

    /* get the expression to delete and the list */
    x.n_ptr = xlarg(&args);
    list.n_ptr = xlmatch(LIST,&args);
    xltest(&fcn.n_ptr,&tresult,&args);
    xllastarg(args);

    /* delete leading matches */
    while (consp(list.n_ptr)) {
	if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) != tresult)
	    break;
	list.n_ptr = cdr(list.n_ptr);
    }
    val = last = list.n_ptr;

    /* delete embedded matches */
    if (consp(list.n_ptr)) {

	/* skip the first non-matching element */
	list.n_ptr = cdr(list.n_ptr);

	/* look for embedded matches */
	while (consp(list.n_ptr)) {

	    /* check to see if this element should be deleted */
	    if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) == tresult)
		rplacd(last,cdr(list.n_ptr));
	    else
		last = list.n_ptr;

	    /* move to the next element */
	    list.n_ptr = cdr(list.n_ptr);
 	}
    }

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the updated list */
    return (val);
}

/* xatom - is this an atom? */
NODE *xatom(args)
  NODE *args;
{
    NODE *arg;
    arg = xlarg(&args);
    xllastarg(args);
    return (atom(arg) ? true : NIL);
}

/* xsymbolp - is this an symbol? */
NODE *xsymbolp(args)
  NODE *args;
{
    NODE *arg;
    arg = xlarg(&args);
    xllastarg(args);
    return (arg == NIL || symbolp(arg) ? true : NIL);
}

/* xnumberp - is this an number? */
NODE *xnumberp(args)
  NODE *args;
{
    NODE *arg;
    arg = xlarg(&args);
    xllastarg(args);
    return (fixp(arg) ? true : NIL);
}

/* xboundp - is this a value bound to this symbol? */
NODE *xboundp(args)
  NODE *args;
{
    NODE *sym;
    sym = xlmatch(SYM,&args);
    xllastarg(args);
    return (sym->n_symvalue == s_unbound ? NIL : true);
}

/* xnull - is this null? */
NODE *xnull(args)
  NODE *args;
{
    NODE *arg;
    arg = xlarg(&args);
    xllastarg(args);
    return (null(arg) ? true : NIL);
}

/* xlistp - is this a list? */
NODE *xlistp(args)
  NODE *args;
{
    NODE *arg;
    arg = xlarg(&args);
    xllastarg(args);
    return (listp(arg) ? true : NIL);
}

/* xconsp - is this a cons? */
NODE *xconsp(args)
  NODE *args;
{
    NODE *arg;
    arg = xlarg(&args);
    xllastarg(args);
    return (consp(arg) ? true : NIL);
}

/* xeq - are these equal? */
NODE *xeq(args)
  NODE *args;
{
    return (cequal(args,eq));
}

/* xeql - are these equal? */
NODE *xeql(args)
  NODE *args;
{
    return (cequal(args,eql));
}

/* xequal - are these equal? */
NODE *xequal(args)
  NODE *args;
{
    return (cequal(args,equal));
}

/* cequal - common eq/eql/equal function */
LOCAL NODE *cequal(args,fcn)
  NODE *args; int (*fcn)();
{
    NODE *arg1,*arg2;

    /* get the two arguments */
    arg1 = xlarg(&args);
    arg2 = xlarg(&args);
    xllastarg(args);

    /* compare the arguments */
    return ((*fcn)(arg1,arg2) ? true : NIL);
}
//E*O*F xllist.c//

echo x - xlmath.c
cat > "xlmath.c" << '//E*O*F xlmath.c//'
/* xlmath - xlisp builtin arithmetic functions */

#include "xlisp.h"

/* external variables */
extern NODE *xlstack;
extern NODE *true;

/* forward declarations */
FORWARD NODE *unary();
FORWARD NODE *binary();
FORWARD NODE *predicate();
FORWARD NODE *compare();

/* xadd - builtin function for addition */
NODE *xadd(args)
  NODE *args;
{
    return (binary(args,'+'));
}

/* xsub - builtin function for subtraction */
NODE *xsub(args)
  NODE *args;
{
    return (binary(args,'-'));
}

/* xmul - builtin function for multiplication */
NODE *xmul(args)
  NODE *args;
{
    return (binary(args,'*'));
}

/* xdiv - builtin function for division */
NODE *xdiv(args)
  NODE *args;
{
    return (binary(args,'/'));
}

/* xrem - builtin function for remainder */
NODE *xrem(args)
  NODE *args;
{
    return (binary(args,'%'));
}

/* xmin - builtin function for minimum */
NODE *xmin(args)
  NODE *args;
{
    return (binary(args,'m'));
}

/* xmax - builtin function for maximum */
NODE *xmax(args)
  NODE *args;
{
    return (binary(args,'M'));
}

/* xbitand - builtin function for bitwise and */
NODE *xbitand(args)
  NODE *args;
{
    return (binary(args,'&'));
}

/* xbitior - builtin function for bitwise inclusive or */
NODE *xbitior(args)
  NODE *args;
{
    return (binary(args,'|'));
}

/* xbitxor - builtin function for bitwise exclusive or */
NODE *xbitxor(args)
  NODE *args;
{
    return (binary(args,'^'));
}

/* binary - handle binary operations */
LOCAL NODE *binary(args,fcn)
  NODE *args; int fcn;
{
    int ival,iarg;
    NODE *val;

    /* get the first argument */
    ival = xlmatch(INT,&args)->n_int;

    /* treat '-' with a single argument as a special case */
    if (fcn == '-' && args == NIL)
	ival = -ival;

    /* handle each remaining argument */
    while (args) {

	/* get the next argument */
	iarg = xlmatch(INT,&args)->n_int;

	/* accumulate the result value */
	switch (fcn) {
	case '+':	ival += iarg; break;
	case '-':	ival -= iarg; break;
	case '*':	ival *= iarg; break;
	case '/':	ival /= iarg; break;
	case '%':	ival %= iarg; break;
	case 'M':	if (iarg > ival) ival = iarg; break;
	case 'm':	if (iarg < ival) ival = iarg; break;
	case '&':	ival &= iarg; break;
	case '|':	ival |= iarg; break;
	case '^':	ival ^= iarg; break;
	}
    }

    /* initialize value */
    val = newnode(INT);
    val->n_int = ival;

    /* return the result value */
    return (val);
}

/* xbitnot - bitwise not */
NODE *xbitnot(args)
  NODE *args;
{
    return (unary(args,'~'));
}

/* xabs - builtin function for absolute value */
NODE *xabs(args)
  NODE *args;
{
    return (unary(args,'A'));
}

/* xadd1 - builtin function for adding one */
NODE *xadd1(args)
  NODE *args;
{
    return (unary(args,'+'));
}

/* xsub1 - builtin function for subtracting one */
NODE *xsub1(args)
  NODE *args;
{
    return (unary(args,'-'));
}

/* unary - handle unary operations */
LOCAL NODE *unary(args,fcn)
  NODE *args; int fcn;
{
    NODE *val;
    int ival;

    /* get the argument */
    ival = xlmatch(INT,&args)->n_int;
    xllastarg(args);

    /* compute the result */
    switch (fcn) {
    case '~':	ival = ~ival; break;
    case 'A':	if (ival < 0) ival = -ival; break;
    case '+':	ival++; break;
    case '-':	ival--; break;
    }

    /* convert the value  */
    val = newnode(INT);
    val->n_int = ival;

    /* return the result value */
    return (val);
}

/* xminusp - is this number negative? */
NODE *xminusp(args)
  NODE *args;
{
    return (predicate(args,'-'));
}

/* xzerop - is this number zero? */
NODE *xzerop(args)
  NODE *args;
{
    return (predicate(args,'Z'));
}

/* xplusp - is this number positive? */
NODE *xplusp(args)
  NODE *args;
{
    return (predicate(args,'+'));
}

/* xevenp - is this number even? */
NODE *xevenp(args)
  NODE *args;
{
    return (predicate(args,'E'));
}

/* xoddp - is this number odd? */
NODE *xoddp(args)
  NODE *args;
{
    return (predicate(args,'O'));
}

/* predicate - handle a predicate function */
LOCAL NODE *predicate(args,fcn)
  NODE *args; int fcn;
{
    NODE *val;
    int ival;

    /* get the argument */
    ival = xlmatch(INT,&args)->n_int;
    xllastarg(args);

    /* compute the result */
    switch (fcn) {
    case '-':	ival = (ival < 0); break;
    case 'Z':	ival = (ival == 0); break;
    case '+':	ival = (ival > 0); break;
    case 'E':	ival = ((ival & 1) == 0); break;
    case 'O':	ival = ((ival & 1) != 0); break;
    }

    /* return the result value */
    return (ival ? true : NIL);
}

/* xlss - builtin function for < */
NODE *xlss(args)
  NODE *args;
{
    return (compare(args,'<'));
}

/* xleq - builtin function for <= */
NODE *xleq(args)
  NODE *args;
{
    return (compare(args,'L'));
}

/* equ - builtin function for = */
NODE *xequ(args)
  NODE *args;
{
    return (compare(args,'='));
}

/* xneq - builtin function for /= */
NODE *xneq(args)
  NODE *args;
{
    return (compare(args,'#'));
}

/* xgeq - builtin function for >= */
NODE *xgeq(args)
  NODE *args;
{
    return (compare(args,'G'));
}

/* xgtr - builtin function for > */
NODE *xgtr(args)
  NODE *args;
{
    return (compare(args,'>'));
}

/* compare - common compare function */
LOCAL NODE *compare(args,fcn)
  NODE *args; int fcn;
{
    NODE *arg1,*arg2;
    int cmp;

    /* get the two arguments */
    arg1 = xlarg(&args);
    arg2 = xlarg(&args);
    xllastarg(args);

    /* do the compare */
    if (stringp(arg1) && stringp(arg2))
	cmp = strcmp(arg1->n_str,arg2->n_str);
    else if (fixp(arg1) && fixp(arg2))
	cmp = arg1->n_int - arg2->n_int;
    else
	cmp = (int)(arg1 - arg2);

    /* compute result of the compare */
    switch (fcn) {
    case '<':	cmp = (cmp < 0); break;
    case 'L':	cmp = (cmp <= 0); break;
    case '=':	cmp = (cmp == 0); break;
    case '#':	cmp = (cmp != 0); break;
    case 'G':	cmp = (cmp >= 0); break;
    case '>':	cmp = (cmp > 0); break;
    }

    /* return the result */
    return (cmp ? true : NIL);
}
//E*O*F xlmath.c//

echo x - xlobj.c
cat > "xlobj.c" << '//E*O*F xlobj.c//'
/* xlobj - xlisp object functions */

#include "xlisp.h"

#ifdef MEGAMAX
overlay "overflow"
#endif

/* external variables */
extern NODE *xlstack;
extern NODE *xlenv,*xlnewenv;
extern NODE *s_stdout;
extern NODE *self;
extern NODE *class;
extern NODE *object;
extern NODE *new;
extern NODE *isnew;
extern NODE *msgcls;
extern NODE *msgclass;
extern int varcnt;

/* instance variable numbers for the class 'Class' */
#define MESSAGES	0	/* list of messages */
#define IVARS		1	/* list of instance variable names */
#define CVARS		2	/* list of class variable names */
#define CVALS		3	/* list of class variable values */
#define SUPERCLASS	4	/* pointer to the superclass */
#define IVARCNT		5	/* number of class instance variables */
#define IVARTOTAL	6	/* total number of instance variables */

/* number of instance variables for the class 'Class' */
#define CLASSSIZE	7

/* forward declarations */
FORWARD NODE *xlgetivar();
FORWARD NODE *xlsetivar();
FORWARD NODE *xlivar();
FORWARD NODE *xlcvar();
FORWARD NODE *findmsg();
FORWARD NODE *findvar();
FORWARD NODE *defvars();
FORWARD NODE *makelist();

/* xlclass - define a class */
NODE *xlclass(name,vcnt)
  char *name; int vcnt;
{
    NODE *sym,*cls;

    /* create the class */
    sym = xlsenter(name);
    cls = sym->n_symvalue = newnode(OBJ);
    cls->n_obclass = class;
    cls->n_obdata = makelist(CLASSSIZE);

    /* set the instance variable counts */
    if (vcnt > 0) {
	xlsetivar(cls,IVARCNT,newnode(INT))->n_int = vcnt;
	xlsetivar(cls,IVARTOTAL,newnode(INT))->n_int = vcnt;
    }

    /* set the superclass to 'Object' */
    xlsetivar(cls,SUPERCLASS,object);

    /* return the new class */
    return (cls);
}

/* xlmfind - find the message binding for a message to an object */
NODE *xlmfind(obj,msym)
  NODE *obj,*msym;
{
    return (findmsg(obj->n_obclass,msym));
}

/* xlxsend - send a message to an object */
NODE *xlxsend(obj,msg,args)
  NODE *obj,*msg,*args;
{
    NODE *oldstk,*oldenv,*oldnewenv,method,cptr,eargs,val,*isnewmsg;

    /* save the old environment */
    oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;

    /* create a new stack frame */
    oldstk = xlsave(&method,&cptr,&eargs,&val,NULL);

    /* get the method for this message */
    method.n_ptr = cdr(msg);

    /* make sure its a function or a subr */
    if (!subrp(method.n_ptr) && !consp(method.n_ptr))
	xlfail("bad method");

    /* bind the symbols 'self' and 'msgclass' */
    xlbind(self,obj);
    xlbind(msgclass,msgcls);

    /* evaluate the function call */
    eargs.n_ptr = xlevlist(args);
    if (subrp(method.n_ptr)) {
	xlfixbindings();
	val.n_ptr = (*method.n_ptr->n_subr)(eargs.n_ptr);
    }
    else {

	/* bind the formal arguments */
	xlabind(car(method.n_ptr),eargs.n_ptr);
	xlfixbindings();

	/* execute the code */
	cptr.n_ptr = cdr(method.n_ptr);
	while (cptr.n_ptr != NIL)
	    val.n_ptr = xlevarg(&cptr.n_ptr);
    }

    /* restore the environment */
    xlunbind(oldenv); xlnewenv = oldnewenv;

    /* after creating an object, send it the "isnew" message */
    if (car(msg) == new && val.n_ptr != NIL) {
	if ((isnewmsg = xlmfind(val.n_ptr,isnew)) == NIL)
	    xlfail("no method for the isnew message");
	val.n_ptr = xlxsend(val.n_ptr,isnewmsg,args);
    }

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result value */
    return (val.n_ptr);
}

/* xlsend - send a message to an object (message in arg list) */
NODE *xlsend(obj,args)
  NODE *obj,*args;
{
    NODE *msg;

    /* find the message binding for this message */
    if ((msg = xlmfind(obj,xlevmatch(SYM,&args))) == NIL)
	xlfail("no method for this message");

    /* send the message */
    return (xlxsend(obj,msg,args));
}

/* xlobsym - find a class or instance variable for the current object */
NODE *xlobsym(sym)
  NODE *sym;
{
    NODE *obj;

    if ((obj = self->n_symvalue) != NIL && objectp(obj))
	return (findvar(obj,sym));
    else
	return (NIL);
}

/* mnew - create a new object instance */
LOCAL NODE *mnew()
{
    NODE *oldstk,obj,*cls;

    /* create a new stack frame */
    oldstk = xlsave(&obj,NULL);

    /* get the class */
    cls = self->n_symvalue;

    /* generate a new object */
    obj.n_ptr = newnode(OBJ);
    obj.n_ptr->n_obclass = cls;
    obj.n_ptr->n_obdata = makelist(getivcnt(cls,IVARTOTAL));

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the new object */
    return (obj.n_ptr);
}

/* misnew - initialize a new class */
LOCAL NODE *misnew(args)
  NODE *args;
{
    NODE *oldstk,super,*obj;

    /* create a new stack frame */
    oldstk = xlsave(&super,NULL);

    /* get the superclass if there is one */
    if (args != NIL)
	super.n_ptr = xlmatch(OBJ,&args);
    else
	super.n_ptr = object;
    xllastarg(args);

    /* get the object */
    obj = self->n_symvalue;

    /* store the superclass */
    xlsetivar(obj,SUPERCLASS,super.n_ptr);
    xlsetivar(obj,IVARTOTAL,newnode(INT))->n_int =
        getivcnt(super.n_ptr,IVARTOTAL);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the new object */
    return (obj);
}

/* xladdivar - enter an instance variable */
xladdivar(cls,var)
  NODE *cls; char *var;
{
    NODE *ivar,*lptr;

    /* find the 'ivars' instance variable */
    ivar = xlivar(cls,IVARS);

    /* add the instance variable */
    lptr = newnode(LIST);
    rplacd(lptr,car(ivar));
    rplaca(ivar,lptr);
    rplaca(lptr,xlsenter(var));
}

/* entermsg - add a message to a class */
LOCAL NODE *entermsg(cls,msg)
  NODE *cls,*msg;
{
    NODE *ivar,*lptr,*mptr;

    /* find the 'messages' instance variable */
    ivar = xlivar(cls,MESSAGES);

    /* lookup the message */
    for (lptr = car(ivar); lptr != NIL; lptr = cdr(lptr))
	if (car(mptr = car(lptr)) == msg)
	    return (mptr);

    /* allocate a new message entry if one wasn't found */
    lptr = newnode(LIST);
    rplacd(lptr,car(ivar));
    rplaca(ivar,lptr);
    rplaca(lptr,mptr = newnode(LIST));
    rplaca(mptr,msg);

    /* return the symbol node */
    return (mptr);
}

/* answer - define a method for answering a message */
LOCAL NODE *answer(args)
  NODE *args;
{
    NODE *oldstk,arg,msg,fargs,code;
    NODE *obj,*mptr,*fptr;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&msg,&fargs,&code,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* message symbol, formal argument list and code */
    msg.n_ptr = xlmatch(SYM,&arg.n_ptr);
    fargs.n_ptr = xlmatch(LIST,&arg.n_ptr);
    code.n_ptr = xlmatch(LIST,&arg.n_ptr);
    xllastarg(arg.n_ptr);

    /* get the object node */
    obj = self->n_symvalue;

    /* make a new message list entry */
    mptr = entermsg(obj,msg.n_ptr);

    /* setup the message node */
    rplacd(mptr,fptr = newnode(LIST));
    rplaca(fptr,fargs.n_ptr);
    rplacd(fptr,code.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the object */
    return (obj);
}

/* mivars - define the list of instance variables */
LOCAL NODE *mivars(args)
  NODE *args;
{
    NODE *cls,*super;
    int scnt;

    /* define the list of instance variables */
    cls = defvars(args,IVARS);

    /* get the superclass instance variable count */
    if ((super = xlgetivar(cls,SUPERCLASS)) != NIL)
	scnt = getivcnt(super,IVARTOTAL);
    else
	scnt = 0;

    /* save the number of instance variables */
    xlsetivar(cls,IVARCNT,newnode(INT))->n_int = varcnt;
    xlsetivar(cls,IVARTOTAL,newnode(INT))->n_int = scnt+varcnt;

    /* return the class */
    return (cls);
}

/* getivcnt - get the number of instance variables for a class */
LOCAL int getivcnt(cls,ivar)
  NODE *cls; int ivar;
{
    NODE *cnt;

    if ((cnt = xlgetivar(cls,ivar)) != NIL)
	if (fixp(cnt))
	    return (cnt->n_int);
	else
	    xlfail("bad value for instance variable count");
    else
	return (0);
}

/* mcvars - define the list of class variables */
LOCAL NODE *mcvars(args)
  NODE *args;
{
    NODE *cls;

    /* define the list of class variables */
    cls = defvars(args,CVARS);

    /* make a new list of values */
    xlsetivar(cls,CVALS,makelist(varcnt));

    /* return the class */
    return (cls);
}

/* defvars - define a class or instance variable list */
LOCAL NODE *defvars(args,varnum)
  NODE *args; int varnum;
{
    NODE *oldstk,vars,*vptr,*cls,*sym;

    /* create a new stack frame */
    oldstk = xlsave(&vars,NULL);

    /* get ivar list */
    vars.n_ptr = xlmatch(LIST,&args);
    xllastarg(args);

    /* get the class node */
    cls = self->n_symvalue;

    /* check each variable in the list */
    varcnt = 0;
    for (vptr = vars.n_ptr;
	 consp(vptr);
	 vptr = cdr(vptr)) {

	/* make sure this is a valid symbol in the list */
	if ((sym = car(vptr)) == NIL || !symbolp(sym))
	    xlfail("bad variable list");

	/* make sure its not already defined */
	if (checkvar(cls,sym))
	    xlfail("multiply defined variable");

	/* count the variable */
	varcnt++;
    }

    /* make sure the list ended properly */
    if (vptr != NIL)
	xlfail("bad variable list");

    /* define the new variable list */
    xlsetivar(cls,varnum,vars.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the class */
    return (cls);
}

/* xladdmsg - add a message to a class */
xladdmsg(cls,msg,code)
  NODE *cls; char *msg; NODE *(*code)();
{
    NODE *mptr;

    /* enter the message selector */
    mptr = entermsg(cls,xlsenter(msg));

    /* store the method for this message */
    rplacd(mptr,newnode(SUBR));
    cdr(mptr)->n_subr = code;
}

/* getclass - get the class of an object */
LOCAL NODE *getclass(args)
  NODE *args;
{
    /* make sure there aren't any arguments */
    xllastarg(args);

    /* return the object's class */
    return (self->n_symvalue->n_obclass);
}

/* obshow - show the instance variables of an object */
LOCAL NODE *obshow(args)
  NODE *args;
{
    NODE *fptr;

    /* get the file pointer */
    fptr = (args ? xlmatch(FPTR,&args) : s_stdout->n_symvalue);
    xllastarg(args);

    /* print the object's instance variables */
    xlprint(fptr,self->n_symvalue->n_obdata,TRUE);
    xlterpri(fptr);

    /* return the object */
    return (self->n_symvalue);
}

/* defisnew - default 'isnew' method */
LOCAL NODE *defisnew(args)
  NODE *args;
{
    /* make sure there aren't any arguments */
    xllastarg(args);

    /* return the object */
    return (self->n_symvalue);
}

/* sendsuper - send a message to an object's superclass */
LOCAL NODE *sendsuper(args)
  NODE *args;
{
    NODE *obj,*super,*msg;

    /* get the object */
    obj = self->n_symvalue;

    /* get the object's superclass */
    super = xlgetivar(obj->n_obclass,SUPERCLASS);

    /* find the message binding for this message */
    if ((msg = findmsg(super,xlmatch(SYM,&args))) == NIL)
	xlfail("no method for this message");

    /* send the message */
    return (xlxsend(obj,msg,args));
}

/* findmsg - find the message binding given an object and a class */
LOCAL NODE *findmsg(cls,sym)
  NODE *cls,*sym;
{
    NODE *lptr,*msg;

    /* start at the specified class */
    msgcls = cls;

    /* look for the message in the class or superclasses */
    while (msgcls != NIL) {

	/* lookup the message in this class */
	for (lptr = xlgetivar(msgcls,MESSAGES);
	     lptr != NIL;
	     lptr = cdr(lptr))
	    if ((msg = car(lptr)) != NIL && car(msg) == sym)
		return (msg);

	/* look in class's superclass */
	msgcls = xlgetivar(msgcls,SUPERCLASS);
    }

    /* message not found */
    return (NIL);
}

/* findvar - find a class or instance variable */
LOCAL NODE *findvar(obj,sym)
  NODE *obj,*sym;
{
    NODE *cls,*lptr;
    int base,varnum;
    int found;

    /* get the class of the object */
    cls = obj->n_obclass;

    /* get the total number of instance variables */
    base = getivcnt(cls,IVARTOTAL);

    /* find the variable */
    found = FALSE;
    for (; cls != NIL; cls = xlgetivar(cls,SUPERCLASS)) {

	/* get the number of instance variables for this class */
	if ((base -= getivcnt(cls,IVARCNT)) < 0)
	    xlfail("error finding instance variable");

	/* check for finding the class of the current message */
	if (!found && cls == msgclass->n_symvalue)
	    found = TRUE;

	/* lookup the instance variable */
	varnum = 0;
	for (lptr = xlgetivar(cls,IVARS);
    	     lptr != NIL;
    	     lptr = cdr(lptr))
	    if (found && car(lptr) == sym)
		return (xlivar(obj,base + varnum));
	    else
		varnum++;

	/* skip the class variables if the message class hasn't been found */
	if (!found)
	    continue;

	/* lookup the class variable */
	varnum = 0;
	for (lptr = xlgetivar(cls,CVARS);
    	     lptr != NIL;
    	     lptr = cdr(lptr))
	    if (car(lptr) == sym)
		return (xlcvar(cls,varnum));
	    else
		varnum++;
    }

    /* variable not found */
    return (NIL);
}

/* checkvar - check for an existing class or instance variable */
LOCAL int checkvar(cls,sym)
  NODE *cls,*sym;
{
    NODE *lptr;

    /* find the variable */
    for (; cls != NIL; cls = xlgetivar(cls,SUPERCLASS)) {

	/* lookup the instance variable */
	for (lptr = xlgetivar(cls,IVARS);
    	     lptr != NIL;
    	     lptr = cdr(lptr))
	    if (car(lptr) == sym)
		return (TRUE);

	/* lookup the class variable */
	for (lptr = xlgetivar(cls,CVARS);
    	     lptr != NIL;
    	     lptr = cdr(lptr))
	    if (car(lptr) == sym)
		return (TRUE);
    }

    /* variable not found */
    return (FALSE);
}

/* xlgetivar - get the value of an instance variable */
NODE *xlgetivar(obj,num)
  NODE *obj; int num;
{
    return (car(xlivar(obj,num)));
}

/* xlsetivar - set the value of an instance variable */
NODE *xlsetivar(obj,num,val)
  NODE *obj; int num; NODE *val;
{
    rplaca(xlivar(obj,num),val);
    return (val);
}

/* xlivar - get an instance variable */
NODE *xlivar(obj,num)
  NODE *obj; int num;
{
    NODE *ivar;

    /* get the instance variable */
    for (ivar = obj->n_obdata; num > 0; num--)
	if (ivar != NIL)
	    ivar = cdr(ivar);
	else
	    xlfail("bad instance variable list");

    /* return the instance variable */
    return (ivar);
}

/* xlcvar - get a class variable */
NODE *xlcvar(cls,num)
  NODE *cls; int num;
{
    NODE *cvar;

    /* get the class variable */
    for (cvar = xlgetivar(cls,CVALS); num > 0; num--)
	if (cvar != NIL)
	    cvar = cdr(cvar);
	else
	    xlfail("bad class variable list");

    /* return the class variable */
    return (cvar);
}

/* makelist - make a list of nodes */
LOCAL NODE *makelist(cnt)
  int cnt;
{
    NODE *oldstk,list,*lnew;

    /* create a new stack frame */
    oldstk = xlsave(&list,NULL);

    /* make the list */
    for (; cnt > 0; cnt--) {
	lnew = newnode(LIST);
	rplacd(lnew,list.n_ptr);
	list.n_ptr = lnew;
    }

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the list */
    return (list.n_ptr);
}

/* xloinit - object function initialization routine */
xloinit()
{
    /* don't confuse the garbage collector */
    class = object = NIL;

    /* enter the object related symbols */
    new		= xlsenter("new");
    isnew	= xlsenter("isnew");
    self	= xlsenter("self");
    msgclass	= xlsenter("msgclass");

    /* create the 'Class' object */
    class = xlclass("Class",CLASSSIZE);
    class->n_obclass = class;

    /* create the 'Object' object */
    object = xlclass("Object",0);

    /* finish initializing 'class' */
    xlsetivar(class,SUPERCLASS,object);
    xladdivar(class,"ivartotal");	/* ivar number 6 */
    xladdivar(class,"ivarcnt");		/* ivar number 5 */
    xladdivar(class,"superclass");	/* ivar number 4 */
    xladdivar(class,"cvals");		/* ivar number 3 */
    xladdivar(class,"cvars");		/* ivar number 2 */
    xladdivar(class,"ivars");		/* ivar number 1 */
    xladdivar(class,"messages");	/* ivar number 0 */
    xladdmsg(class,"new",mnew);
    xladdmsg(class,"answer",answer);
    xladdmsg(class,"ivars",mivars);
    xladdmsg(class,"cvars",mcvars);
    xladdmsg(class,"isnew",misnew);

    /* finish initializing 'object' */
    xladdmsg(object,"class",getclass);
    xladdmsg(object,"show",obshow);
    xladdmsg(object,"isnew",defisnew);
    xladdmsg(object,"sendsuper",sendsuper);
}
//E*O*F xlobj.c//

echo x - xlprin.c
cat > "xlprin.c" << '//E*O*F xlprin.c//'
/* xlprint - xlisp print routine */

#include "xlisp.h"

/* external variables */
extern NODE *xlstack;
extern char buf[];

/* xlprint - print an xlisp value */
xlprint(fptr,vptr,flag)
  NODE *fptr,*vptr; int flag;
{
    NODE *nptr,*next;

    /* print nil */
    if (vptr == NIL) {
	putstr(fptr,"nil");
	return;
    }

    /* check value type */
    switch (ntype(vptr)) {
    case SUBR:
	    putatm(fptr,"Subr",vptr);
	    break;
    case FSUBR:
	    putatm(fptr,"FSubr",vptr);
	    break;
    case LIST:
	    xlputc(fptr,'(');
	    for (nptr = vptr; nptr != NIL; nptr = next) {
	        xlprint(fptr,car(nptr),flag);
		if (next = cdr(nptr))
		    if (consp(next))
			xlputc(fptr,' ');
		    else {
			putstr(fptr," . ");
			xlprint(fptr,next,flag);
			break;
		    }
	    }
	    xlputc(fptr,')');
	    break;
    case SYM:
	    putstr(fptr,xlsymname(vptr));
	    break;
    case INT:
	    putdec(fptr,vptr->n_int);
	    break;
    case STR:
	    if (flag)
		putstring(fptr,vptr->n_str);
	    else
		putstr(fptr,vptr->n_str);
	    break;
    case FPTR:
	    putatm(fptr,"File",vptr);
	    break;
    case OBJ:
	    putatm(fptr,"Object",vptr);
	    break;
    case FREE:
	    putatm(fptr,"Free",vptr);
	    break;
    default:
	    putatm(fptr,"Foo",vptr);
	    break;
    }
}

/* xlterpri - terminate the current print line */
xlterpri(fptr)
  NODE *fptr;
{
    xlputc(fptr,'\n');
}

/* putstring - output a string */
LOCAL putstring(fptr,str)
  NODE *fptr; char *str;
{
    int ch;

    /* output the initial quote */
    xlputc(fptr,'"');

    /* output each character in the string */
    while (ch = *str++)

	/* check for a control character */
	if (ch < 040 || ch == '\\') {
	    xlputc(fptr,'\\');
	    switch (ch) {
	    case '\033':
		    xlputc(fptr,'e');
		    break;
	    case '\n':
		    xlputc(fptr,'n');
		    break;
	    case '\r':
		    xlputc(fptr,'r');
		    break;
	    case '\t':
		    xlputc(fptr,'t');
		    break;
	    case '\\':
		    xlputc(fptr,'\\');
		    break;
	    default:
		    putoct(fptr,ch);
		    break;
	    }
	}

	/* output a normal character */
	else
	    xlputc(fptr,ch);

    /* output the terminating quote */
    xlputc(fptr,'"');
}

/* putatm - output an atom */
LOCAL putatm(fptr,tag,val)
  NODE *fptr; char *tag; NODE *val;
{
    sprintf(buf,"#<%s: #",tag); putstr(fptr,buf);
    sprintf(buf,AFMT,val); putstr(fptr,buf);
    xlputc(fptr,'>');
}

/* putdec - output a decimal number */
LOCAL putdec(fptr,n)
  NODE *fptr; int n;
{
    sprintf(buf,"%d",n);
    putstr(fptr,buf);
}

/* putoct - output an octal byte value */
LOCAL putoct(fptr,n)
  NODE *fptr; int n;
{
    sprintf(buf,"%03o",n);
    putstr(fptr,buf);
}

/* putstr - output a string */
LOCAL putstr(fptr,str)
  NODE *fptr; char *str;
{
    while (*str)
	xlputc(fptr,*str++);
}
//E*O*F xlprin.c//

echo x - xlread.c
cat > "xlread.c" << '//E*O*F xlread.c//'
/* xlread - xlisp expression input routine */

#include "xlisp.h"
#include "ctype.h"

/* external variables */
extern NODE *s_stdout,*true;
extern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
extern NODE *xlstack;
extern int xlplevel;

/* external routines */
extern FILE *fopen();

/* forward declarations */
FORWARD NODE *plist();
FORWARD NODE *pstring();
FORWARD NODE *pquote();
FORWARD NODE *pname();

/* xlload - load a file of xlisp expressions */
int xlload(name,vflag,pflag)
  char *name; int vflag,pflag;
{
    NODE *oldstk,fptr,expr;
    char fname[50];
    CONTEXT cntxt;
    int sts;

    /* create a new stack frame */
    oldstk = xlsave(&fptr,&expr,NULL);

    /* allocate a file node */
    fptr.n_ptr = newnode(FPTR);
    fptr.n_ptr->n_fp = NULL;
    fptr.n_ptr->n_savech = 0;

    /* create the file name and print the information line */
    strcpy(fname,name); strcat(fname,".lsp");
    if (vflag)
	printf("; loading \"%s\"\n",fname);

    /* open the file */
    if ((fptr.n_ptr->n_fp = fopen(fname,"r")) == NULL) {
	xlstack = oldstk;
	return (FALSE);
    }

    /* read, evaluate and possibly print each expression in the file */
    xlbegin(&cntxt,CF_ERROR,true);
    if (setjmp(cntxt.c_jmpbuf))
	sts = FALSE;
    else {
	while (xlread(fptr.n_ptr,&expr.n_ptr)) {
	    expr.n_ptr = xleval(expr.n_ptr);
	    if (pflag)
		stdprint(expr.n_ptr);
	}
	sts = TRUE;
    }
    xlend(&cntxt);

    /* close the file */
    fclose(fptr.n_ptr->n_fp);
    fptr.n_ptr->n_fp = NULL;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return status */
    return (sts);
}

/* xlread - read an xlisp expression */
int xlread(fptr,pval)
  NODE *fptr,**pval;
{
    /* initialize */
    xlplevel = 0;

    /* parse an expression */
    return (parse(fptr,pval));
}

/* parse - parse an xlisp expression */
LOCAL int parse(fptr,pval)
  NODE *fptr,**pval;
{
    int ch;

    /* keep looking for a node skipping comments */
    while (TRUE)

	/* check next character for type of node */
	switch (ch = nextch(fptr)) {
	case EOF:
		xlgetc(fptr);
		return (FALSE);
	case '\'':			/* a quoted expression */
		xlgetc(fptr);
		*pval = pquote(fptr,s_quote);
		return (TRUE);
	case '#':			/* a quoted function */
		xlgetc(fptr);
		if ((ch = xlgetc(fptr)) == '<')
		    xlfail("unreadable atom");
		else if (ch != '\'')
		    xlfail("expected quote after #");
		*pval = pquote(fptr,s_function);
		return (TRUE);
	case '`':			/* a back quoted expression */
		xlgetc(fptr);
		*pval = pquote(fptr,s_bquote);
		return (TRUE);
	case ',':			/* a comma or comma-at expression */
		xlgetc(fptr);
		if (xlpeek(fptr) == '@') {
		    xlgetc(fptr);
		    *pval = pquote(fptr,s_comat);
		}
		else
		    *pval = pquote(fptr,s_comma);
		return (TRUE);
	case '(':			/* a sublist */
		*pval = plist(fptr);
		return (TRUE);
	case ')':			/* closing paren - shouldn't happen */
		xlfail("extra right paren");
	case '.':			/* dot - shouldn't happen */
		xlfail("misplaced dot");
	case ';':			/* a comment */
		pcomment(fptr);
		break;
	case '"':			/* a string */
		*pval = pstring(fptr);
		return (TRUE);
	default:
		if (issym(ch))		/* a name */
		    *pval = pname(fptr);
		else
		    xlfail("invalid character");
		return (TRUE);
	}
}

/* pcomment - parse a comment */
LOCAL pcomment(fptr)
  NODE *fptr;
{
    int ch;

    /* skip to end of line */
    while ((ch = checkeof(fptr)) != EOF && ch != '\n')
	;
}

/* plist - parse a list */
LOCAL NODE *plist(fptr)
  NODE *fptr;
{
    NODE *oldstk,val,*lastnptr,*nptr,*p;
    int ch;

    /* increment the nesting level */
    xlplevel += 1;

    /* create a new stack frame */
    oldstk = xlsave(&val,NULL);

    /* skip the opening paren */
    xlgetc(fptr);

    /* keep appending nodes until a closing paren is found */
    lastnptr = NIL;
    for (lastnptr = NIL; (ch = nextch(fptr)) != ')'; lastnptr = nptr) {

	/* check for end of file */
	if (ch == EOF)
	    badeof(fptr);

	/* check for a dotted pair */
	if (ch == '.') {

	    /* skip the dot */
	    xlgetc(fptr);

	    /* make sure there's a node */
	    if (lastnptr == NIL)
		xlfail("invalid dotted pair");

	    /* parse the expression after the dot */
	    if (!parse(fptr,&p))
		badeof(fptr);
	    rplacd(lastnptr,p);

	    /* make sure its followed by a close paren */
	    if (nextch(fptr) != ')')
		xlfail("invalid dotted pair");

	    /* done with this list */
	    break;
	}

	/* allocate a new node and link it into the list */
	nptr = newnode(LIST);
	if (lastnptr == NIL)
	    val.n_ptr = nptr;
	else
	    rplacd(lastnptr,nptr);

	/* initialize the new node */
	if (!parse(fptr,&p))
	    badeof(fptr);
	rplaca(nptr,p);
    }

    /* skip the closing paren */
    xlgetc(fptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* decrement the nesting level */
    xlplevel -= 1;

    /* return successfully */
    return (val.n_ptr);
}

/* pstring - parse a string */
LOCAL NODE *pstring(fptr)
  NODE *fptr;
{
    NODE *oldstk,val;
    char sbuf[STRMAX+1];
    int ch,i,d1,d2,d3;

    /* create a new stack frame */
    oldstk = xlsave(&val,NULL);

    /* skip the opening quote */
    xlgetc(fptr);

    /* loop looking for a closing quote */
    for (i = 0; i < STRMAX && (ch = checkeof(fptr)) != '"'; i++) {
	switch (ch) {
	case EOF:
		badeof(fptr);
	case '\\':
		switch (ch = checkeof(fptr)) {
		case 'e':
			ch = '\033';
			break;
		case 'n':
			ch = '\n';
			break;
		case 'r':
			ch = '\r';
			break;
		case 't':
			ch = '\t';
			break;
		default:
			if (ch >= '0' && ch <= '7') {
			    d1 = ch - '0';
			    d2 = checkeof(fptr) - '0';
			    d3 = checkeof(fptr) - '0';
			    ch = (d1 << 6) + (d2 << 3) + d3;
			}
			break;
		}
	}
	sbuf[i] = ch;
    }
    sbuf[i] = 0;

    /* initialize the node */
    val.n_ptr = newnode(STR);
    val.n_ptr->n_str = strsave(sbuf);
    val.n_ptr->n_strtype = DYNAMIC;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the new string */
    return (val.n_ptr);
}

/* pquote - parse a quoted expression */
LOCAL NODE *pquote(fptr,sym)
  NODE *fptr,*sym;
{
    NODE *oldstk,val,*p;

    /* create a new stack frame */
    oldstk = xlsave(&val,NULL);

    /* allocate two nodes */
    val.n_ptr = newnode(LIST);
    rplaca(val.n_ptr,sym);
    rplacd(val.n_ptr,newnode(LIST));

    /* initialize the second to point to the quoted expression */
    if (!parse(fptr,&p))
	badeof(fptr);
    rplaca(cdr(val.n_ptr),p);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the quoted expression */
    return (val.n_ptr);
}

/* pname - parse a symbol name */
LOCAL NODE *pname(fptr)
  NODE *fptr;
{
    char sname[STRMAX+1];
    NODE *val;
    int i;

    /* get symbol name */
    for (i = 0; i < STRMAX && issym(xlpeek(fptr)); )
	sname[i++] = xlgetc(fptr);
    sname[i] = 0;

    /* check for a number or enter the symbol into the oblist */
    return (isnumber(sname,&val) ? val : xlenter(sname,DYNAMIC));
}

/* nextch - look at the next non-blank character */
LOCAL int nextch(fptr)
  NODE *fptr;
{
    int ch;

    /* return and save the next non-blank character */
    while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
	xlgetc(fptr);
    return (ch);
}

/* checkeof - get a character and check for end of file */
LOCAL int checkeof(fptr)
  NODE *fptr;
{
    int ch;

    if ((ch = xlgetc(fptr)) == EOF)
	badeof(fptr);
    return (ch);
}

/* badeof - unexpected eof */
LOCAL badeof(fptr)
  NODE *fptr;
{
    xlgetc(fptr);
    xlfail("unexpected EOF");
}

/* isnumber - check if this string is a number */
int isnumber(str,pval)
  char *str; NODE **pval;
{
    char *p;
    int d;

    /* initialize */
    p = str; d = 0;

    /* check for a sign */
    if (*p == '+' || *p == '-')
	p++;

    /* check for a string of digits */
    while (isdigit(*p))
	p++, d++;

    /* make sure there was at least one digit and this is the end */
    if (d == 0 || *p)
	return (FALSE);

    /* convert the string to an integer and return successfully */
    *pval = newnode(INT);
    (*pval)->n_int = atoi(*str == '+' ? ++str : str);
    return (TRUE);
}

/* issym - check whether a character if valid in a symbol name */
LOCAL int issym(ch)
  int ch;
{
    if (ch <= ' ' || ch >= 0177 ||
    	ch == '(' ||
    	ch == ')' ||
    	ch == ';' || 
	ch == ',' ||
	ch == '`' ||
    	ch == '"' ||
    	ch == '\'')
	return (FALSE);
    else
	return (TRUE);
}
//E*O*F xlread.c//

echo x - xlsetf.c
cat > "xlsetf.c" << '//E*O*F xlsetf.c//'
/* xlsetf - set field function */

#include "xlisp.h"

/* external variables */
extern NODE *s_car,*s_cdr,*s_get,*s_svalue,*s_splist;
extern NODE *xlstack;

/* xsetf - built-in function 'setf' */
NODE *xsetf(args)
  NODE *args;
{
    NODE *oldstk,arg,place,value;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&place,&value,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* handle each pair of arguments */
    while (arg.n_ptr) {

	/* get place and value */
	place.n_ptr = xlarg(&arg.n_ptr);
	value.n_ptr = xlevarg(&arg.n_ptr);

	/* check the place form */
	if (symbolp(place.n_ptr))
	    assign(place.n_ptr,value.n_ptr);
	else if (consp(place.n_ptr))
	    placeform(place.n_ptr,value.n_ptr);
	else
	    xlfail("bad place form");
    }

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the value */
    return (value.n_ptr);
}

/* placeform - handle a place form other than a symbol */
LOCAL placeform(place,value)
  NODE *place,*value;
{
    NODE *fun,*oldstk,arg1,arg2;

    /* check the function name */
    if ((fun = xlmatch(SYM,&place)) == s_get) {
	oldstk = xlsave(&arg1,&arg2,NULL);
	arg1.n_ptr = xlevmatch(SYM,&place);
	arg2.n_ptr = xlevmatch(SYM,&place);
	xllastarg(place);
	xlputprop(arg1.n_ptr,value,arg2.n_ptr);
	xlstack = oldstk;
    }
    else if (fun == s_svalue || fun == s_splist) {
	oldstk = xlsave(&arg1,NULL);
	arg1.n_ptr = xlevmatch(SYM,&place);
	xllastarg(place);
	if (fun == s_svalue)
	    arg1.n_ptr->n_symvalue = value;
	else
	    rplacd(arg1.n_ptr->n_symplist,value);
	xlstack = oldstk;
    }
    else if (fun == s_car || fun == s_cdr) {
	oldstk = xlsave(&arg1,NULL);
	arg1.n_ptr = xlevmatch(LIST,&place);
	xllastarg(place);
	if (consp(arg1.n_ptr))
	    if (fun == s_car)
		rplaca(arg1.n_ptr,value);
	    else
		rplacd(arg1.n_ptr,value);
	xlstack = oldstk;
    }
    else
	xlfail("bad place form");
}
//E*O*F xlsetf.c//

echo x - xlstr.c
cat > "xlstr.c" << '//E*O*F xlstr.c//'
/* xlstr - xlisp string builtin functions */

#include "xlisp.h"

/* external variables */
extern NODE *xlstack;

/* external procedures */
extern char *strcat();

/* xstrlen - length of a string */
NODE *xstrlen(args)
  NODE *args;
{
    NODE *val;
    int total;

    /* initialize */
    total = 0;

    /* loop over args and total */
    while (args)
	total += strlen(xlmatch(STR,&args)->n_str);

    /* create the value node */
    val = newnode(INT);
    val->n_int = total;

    /* return the total */
    return (val);
}

/* xstrcat - concatenate a bunch of strings */
NODE *xstrcat(args)
  NODE *args;
{
    NODE *oldstk,val,*p;
    char *str;
    int len;

    /* create a new stack frame */
    oldstk = xlsave(&val,NULL);

    /* find the length of the new string */
    for (p = args, len = 0; p; )
	len += strlen(xlmatch(STR,&p)->n_str);

    /* create the result string */
    val.n_ptr = newnode(STR);
    val.n_ptr->n_str = str = stralloc(len);
    *str = 0;

    /* combine the strings */
    while (args)
	strcat(str,xlmatch(STR,&args)->n_str);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the new string */
    return (val.n_ptr);
}

/* xsubstr - return a substring */
NODE *xsubstr(args)
  NODE *args;
{
    NODE *oldstk,arg,src,val;
    int start,forlen,srclen;
    char *srcptr,*dstptr;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&src,&val,NULL);

    /* initialize */
    arg.n_ptr = args;
    
    /* get string and its length */
    src.n_ptr = xlmatch(STR,&arg.n_ptr);
    srcptr = src.n_ptr->n_str;
    srclen = strlen(srcptr);

    /* get starting pos -- must be present */
    start = xlmatch(INT,&arg.n_ptr)->n_int;

    /* get length -- if not present use remainder of string */
    forlen = (arg.n_ptr ? xlmatch(INT,&arg.n_ptr)->n_int : srclen);

    /* make sure there aren't any more arguments */
    xllastarg(arg.n_ptr);

    /* don't take more than exists */
    if (start + forlen > srclen)
	forlen = srclen - start + 1;

    /* if start beyond string -- return null string */
    if (start > srclen) {
	start = 1;
	forlen = 0; }
	
    /* create return node */
    val.n_ptr = newnode(STR);
    val.n_ptr->n_str = dstptr = stralloc(forlen);

    /* move string */
    for (srcptr += start-1; forlen--; *dstptr++ = *srcptr++)
	;
    *dstptr = 0;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the substring */
    return (val.n_ptr);
}

/* xascii - return ascii value */
NODE *xascii(args)
  NODE *args;
{
    NODE *val;

    /* build return node */
    val = newnode(INT);
    val->n_int = *(xlmatch(STR,&args)->n_str);

    /* make sure there aren't any more arguments */
    xllastarg(args);

    /* return the character */
    return (val);
}

/* xchr - convert an INT into a one character ascii string */
NODE *xchr(args)
  NODE *args;
{
    NODE *oldstk,val;
    char *sptr;

    /* create a new stack frame */
    oldstk = xlsave(&val,NULL);

    /* build return node */
    val.n_ptr = newnode(STR);
    val.n_ptr->n_str = sptr = stralloc(1);
    *sptr++ = xlmatch(INT,&args)->n_int;
    *sptr = 0;

    /* make sure there aren't any more arguments */
    xllastarg(args);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the new string */
    return (val.n_ptr);
}

/* xatoi - convert an ascii string to an integer */
NODE *xatoi(args)
  NODE *args;
{
    NODE *val;
    int n;

    /* get the string and convert it */
    n = atoi(xlmatch(STR,&args)->n_str);

    /* make sure there aren't any more arguments */
    xllastarg(args);

    /* create the value node */
    val = newnode(INT);
    val->n_int = n;

    /* return the number */
    return (val);
}

/* xitoa - convert an integer to an ascii string */
NODE *xitoa(args)
  NODE *args;
{
    NODE *val;
    char buf[20];
    int n;

    /* get the integer */
    n = xlmatch(INT,&args)->n_int;
    xllastarg(args);

    /* convert it to ascii */
    sprintf(buf,"%d",n);

    /* create the value node */
    val = newnode(STR);
    val->n_str = strsave(buf);

    /* return the string */
    return (val);
}
//E*O*F xlstr.c//

echo x - xlstub.c.NOTUSED
cat > "xlstub.c.NOTUSED" << '//E*O*F xlstub.c.NOTUSED//'
/* xlstub.c - stubs for replacing the 'xlobj' module */

#include "xlisp.h"

xloinit() {}
NODE *xlsend() { return (NIL); }
NODE *xlobsym() { return (NIL); }

//E*O*F xlstub.c.NOTUSED//

echo x - xlsubr.c
cat > "xlsubr.c" << '//E*O*F xlsubr.c//'
/* xlsubr - xlisp builtin function support routines */

#include "xlisp.h"

/* external variables */
extern NODE *k_test,*k_tnot,*s_eql;
extern NODE *xlstack;

/* xlsubr - define a builtin function */
xlsubr(sname,type,subr)
  char *sname; int type; NODE *(*subr)();
{
    NODE *sym;

    /* enter the symbol */
    sym = xlsenter(sname);

    /* initialize the value */
    sym->n_symvalue = newnode(type);
    sym->n_symvalue->n_subr = subr;
}

/* xlarg - get the next argument */
NODE *xlarg(pargs)
  NODE **pargs;
{
    NODE *arg;

    /* make sure the argument exists */
    if (!consp(*pargs))
	xlfail("too few arguments");

    /* get the argument value */
    arg = car(*pargs);

    /* make sure its not a keyword */
    if (symbolp(arg) && *car(arg->n_symplist)->n_str == ':')
	xlfail("too few arguments");

    /* move the argument pointer ahead */
    *pargs = cdr(*pargs);

    /* return the argument */
    return (arg);
}

/* xlmatch - get an argument and match its type */
NODE *xlmatch(type,pargs)
  int type; NODE **pargs;
{
    NODE *arg;

    /* get the argument */
    arg = xlarg(pargs);

    /* check its type */
    if (type == LIST) {
	if (arg && ntype(arg) != LIST)
	    xlfail("bad argument type");
    }
    else {
	if (arg == NIL || ntype(arg) != type)
	    xlfail("bad argument type");
    }

    /* return the argument */
    return (arg);
}

/* xlevarg - get the next argument and evaluate it */
NODE *xlevarg(pargs)
  NODE **pargs;
{
    NODE *oldstk,val;

    /* create a new stack frame */
    oldstk = xlsave(&val,NULL);

    /* get the argument */
    val.n_ptr = xlarg(pargs);

    /* evaluate the argument */
    val.n_ptr = xleval(val.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the argument */
    return (val.n_ptr);
}

/* xlevmatch - get an evaluated argument and match its type */
NODE *xlevmatch(type,pargs)
  int type; NODE **pargs;
{
    NODE *arg;

    /* get the argument */
    arg = xlevarg(pargs);

    /* check its type */
    if (type == LIST) {
	if (arg && ntype(arg) != LIST)
	    xlfail("bad argument type");
    }
    else {
	if (arg == NIL || ntype(arg) != type)
	    xlfail("bad argument type");
    }

    /* return the argument */
    return (arg);
}

/* xltest - get the :test or :test-not keyword argument */
xltest(pfcn,ptresult,pargs)
  NODE **pfcn; int *ptresult; NODE **pargs;
{
    NODE *arg;

    /* default the argument to eql */
    if (!consp(*pargs)) {
	*pfcn = s_eql->n_symvalue;
	*ptresult = TRUE;
	return;
    }

    /* get the keyword */
    arg = car(*pargs);

    /* check the keyword */
    if (arg == k_test)
	*ptresult = TRUE;
    else if (arg == k_tnot)
	*ptresult = FALSE;
    else
	xlfail("expecting :test or :test-not");

    /* move the argument pointer ahead */
    *pargs = cdr(*pargs);

    /* make sure the argument exists */
    if (!consp(*pargs))
	xlfail("no value for keyword argument");

    /* get the argument value */
    *pfcn = car(*pargs);

    /* if its a symbol, get its value */
    if (symbolp(*pfcn))
	*pfcn = xleval(*pfcn);

    /* move the argument pointer ahead */
    *pargs = cdr(*pargs);
}

/* xllastarg - make sure the remainder of the argument list is empty */
xllastarg(args)
  NODE *args;
{
    if (args)
	xlfail("too many arguments");
}

/* assign - assign a value to a symbol */
assign(sym,val)
  NODE *sym,*val;
{
    NODE *lptr;

    /* check for a current object */
    if ((lptr = xlobsym(sym)) != NIL)
	rplaca(lptr,val);
    else
	sym->n_symvalue = val;
}

/* eq - internal eq function */
int eq(arg1,arg2)
  NODE *arg1,*arg2;
{
    return (arg1 == arg2);
}

/* eql - internal eql function */
int eql(arg1,arg2)
  NODE *arg1,*arg2;
{
    if (eq(arg1,arg2))
	return (TRUE);
    else if (fixp(arg1) && fixp(arg2))
	return (arg1->n_int == arg2->n_int);
    else if (stringp(arg1) && stringp(arg2))
	return (strcmp(arg1->n_str,arg2->n_str) == 0);
    else
	return (FALSE);
}

/* equal - internal equal function */
int equal(arg1,arg2)
  NODE *arg1,*arg2;
{
    /* compare the arguments */
    if (eql(arg1,arg2))
	return (TRUE);
    else if (consp(arg1) && consp(arg2))
	return (equal(car(arg1),car(arg2)) && equal(cdr(arg1),cdr(arg2)));
    else
	return (FALSE);
}
//E*O*F xlsubr.c//

echo x - xlsym.c
cat > "xlsym.c" << '//E*O*F xlsym.c//'
/* xlsym - symbol handling routines */

#include "xlisp.h"

/* external variables */
extern NODE *oblist,*keylist;
extern NODE *s_unbound;
extern NODE *xlstack;

/* forward declarations */
FORWARD NODE *symenter();
FORWARD NODE *xlmakesym();
FORWARD NODE *findprop();

/* xlenter - enter a symbol into the oblist or keylist */
NODE *xlenter(name,type)
  char *name;
{
    return (symenter(name,type,(*name == ':' ? keylist : oblist)));
}

/* symenter - enter a symbol into a package */
LOCAL NODE *symenter(name,type,listsym)
  char *name; int type; NODE *listsym;
{
    NODE *oldstk,*lsym,*nsym,newsym;
    int cmp;

    /* check for nil */
    if (strcmp(name,"nil") == 0)
	return (NIL);

    /* check for symbol already in table */
    lsym = NIL;
    nsym = listsym->n_symvalue;
    while (nsym) {
	if ((cmp = strcmp(name,xlsymname(car(nsym)))) <= 0)
	    break;
	lsym = nsym;
	nsym = cdr(nsym);
    }

    /* check to see if we found it */
    if (nsym && cmp == 0)
	return (car(nsym));

    /* make a new symbol node and link it into the list */
    oldstk = xlsave(&newsym,NULL);
    newsym.n_ptr = newnode(LIST);
    rplaca(newsym.n_ptr,xlmakesym(name,type));
    rplacd(newsym.n_ptr,nsym);
    if (lsym)
	rplacd(lsym,newsym.n_ptr);
    else
	listsym->n_symvalue = newsym.n_ptr;
    xlstack = oldstk;

    /* return the new symbol */
    return (car(newsym.n_ptr));
}

/* xlsenter - enter a symbol with a static print name */
NODE *xlsenter(name)
  char *name;
{
    return (xlenter(name,STATIC));
}

/* xlmakesym - make a new symbol node */
NODE *xlmakesym(name,type)
  char *name;
{
    NODE *oldstk,sym,*str;

    /* create a new stack frame */
    oldstk = xlsave(&sym,NULL);

    /* make a new symbol node */
    sym.n_ptr = newnode(SYM);
    sym.n_ptr->n_symvalue = (*name == ':' ? sym.n_ptr : s_unbound);
    sym.n_ptr->n_symplist = newnode(LIST);
    rplaca(sym.n_ptr->n_symplist,str = newnode(STR));
    str->n_str = (type == DYNAMIC ? strsave(name) : name);
    str->n_strtype = type;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the new symbol node */
    return (sym.n_ptr);
}

/* xlsymname - return the print name of a symbol */
char *xlsymname(sym)
  NODE *sym;
{
    return (car(sym->n_symplist)->n_str);
}

/* xlgetprop - get the value of a property */
NODE *xlgetprop(sym,prp)
  NODE *sym,*prp;
{
    NODE *p;

    return ((p = findprop(sym,prp)) ? car(p) : NIL);
}

/* xlputprop - put a property value onto the property list */
xlputprop(sym,val,prp)
  NODE *sym,*val,*prp;
{
    NODE *oldstk,p,*pair;

    if ((pair = findprop(sym,prp)) == NIL) {
	oldstk = xlsave(&p,NULL);
	p.n_ptr = newnode(LIST);
	rplaca(p.n_ptr,prp);
	rplacd(p.n_ptr,pair = newnode(LIST));
	rplaca(pair,val);
	rplacd(pair,cdr(sym->n_symplist));
	rplacd(sym->n_symplist,p.n_ptr);
	xlstack = oldstk;
    }
    rplaca(pair,val);
}

/* xlremprop - remove a property from a property list */
xlremprop(sym,prp)
  NODE *sym,*prp;
{
    NODE *last,*p;

    last = NIL;
    for (p = cdr(sym->n_symplist); consp(p) && consp(cdr(p)); p = cdr(last)) {
	if (car(p) == prp)
	    if (last)
		rplacd(last,cdr(cdr(p)));
	    else
		rplacd(sym->n_symplist,cdr(cdr(p)));
	last = cdr(p);
    }
}

/* findprop - find a property pair */
LOCAL NODE *findprop(sym,prp)
  NODE *sym,*prp;
{
    NODE *p;

    for (p = cdr(sym->n_symplist); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
	if (car(p) == prp)
	    return (cdr(p));
    return (NIL);
}

/* xlsinit - symbol initialization routine */
xlsinit()
{
    /* initialize the oblist */
    oblist = xlmakesym("*oblist*",STATIC);
    oblist->n_symvalue = newnode(LIST);
    rplaca(oblist->n_symvalue,oblist);

    /* initialize the keyword list */
    keylist = xlsenter("*keylist*");

    /* enter the unbound symbol indicator */
    s_unbound = xlsenter("*unbound*");
    s_unbound->n_symvalue = s_unbound;
}
//E*O*F xlsym.c//

echo x - xlsys.c
cat > "xlsys.c" << '//E*O*F xlsys.c//'
/* xlsys.c - xlisp builtin system functions */

#include "xlisp.h"

/* external variables */
extern NODE *xlstack;
extern int anodes;

/* external symbols */
extern NODE *a_subr,*a_fsubr;
extern NODE *a_list,*a_sym,*a_int,*a_str,*a_obj,*a_fptr;
extern NODE *true;

/* xload - direct input from a file */
NODE *xload(args)
  NODE *args;
{
    NODE *oldstk,fname,*val;
    int vflag,pflag;

    /* create a new stack frame */
    oldstk = xlsave(&fname,NULL);

    /* get the file name, verbose flag and print flag */
    fname.n_ptr = xlmatch(STR,&args);
    vflag = (args ? xlarg(&args) != NIL : TRUE);
    pflag = (args ? xlarg(&args) != NIL : FALSE);
    xllastarg(args);

    /* load the file */
    val = (xlload(fname.n_ptr->n_str,vflag,pflag) ? true : NIL);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the status */
    return (val);
}

/* xgc - xlisp function to force garbage collection */
NODE *xgc(args)
  NODE *args;
{
    /* make sure there aren't any arguments */
    xllastarg(args);

    /* garbage collect */
    gc();

    /* return nil */
    return (NIL);
}

/* xexpand - xlisp function to force memory expansion */
NODE *xexpand(args)
  NODE *args;
{
    NODE *val;
    int n,i;

    /* get the new number to allocate */
    n = (args ? xlmatch(INT,&args)->n_int : 1);
    xllastarg(args);

    /* allocate more segments */
    for (i = 0; i < n; i++)
	if (!addseg())
	    break;

    /* return the number of segments added */
    val = newnode(INT);
    val->n_int = i;
    return (val);
}

/* xalloc - xlisp function to set the number of nodes to allocate */
NODE *xalloc(args)
  NODE *args;
{
    NODE *val;
    int n,oldn;

    /* get the new number to allocate */
    n = xlmatch(INT,&args)->n_int;

    /* make sure there aren't any more arguments */
    xllastarg(args);

    /* set the new number of nodes to allocate */
    oldn = anodes;
    anodes = n;

    /* return the old number */
    val = newnode(INT);
    val->n_int = oldn;
    return (val);
}

/* xmem - xlisp function to print memory statistics */
NODE *xmem(args)
  NODE *args;
{
    /* make sure there aren't any arguments */
    xllastarg(args);

    /* print the statistics */
    stats();

    /* return nil */
    return (NIL);
}

/* xtype - return type of a thing */
NODE *xtype(args)
    NODE *args;
{
    NODE *arg;

    if (!(arg = xlarg(&args)))
	return (NIL);

    switch (ntype(arg)) {
	case SUBR:	return (a_subr);
	case FSUBR:	return (a_fsubr);
	case LIST:	return (a_list);
	case SYM:	return (a_sym);
	case INT:	return (a_int);
	case STR:	return (a_str);
	case OBJ:	return (a_obj);
	case FPTR:	return (a_fptr);
	default:	xlfail("bad node type");
    }
}

/* xbaktrace - print the trace back stack */
NODE *xbaktrace(args)
  NODE *args;
{
    int n;

    n = (args ? xlmatch(INT,&args)->n_int : -1);
    xllastarg(args);
    xlbaktrace(n);
    return (NIL);
}

/* xexit - get out of xlisp */
NODE *xexit(args)
  NODE *args;
{
    xllastarg(args);
    exit();
}
//E*O*F xlsys.c//

echo Possible errors detected by \'wc\' [hopefully none]:
temp=/tmp/shar$$
trap "rm -f $temp; exit" 0 1 2 3 15
cat > $temp <<\!!!
    260   1056   6810 xlisp.h
    419   1133   8689 xlbfun.c
     69    205   1509 xlbind.c
    798   2236  16880 xlcont.c
    188    523   3924 xldbug.c
    340    968   6552 xldmem.c
    343   1051   7688 xleval.c
    445   1279   8960 xlfio.c
    204    812   5998 xlftab.c
     62    400   2114 xlglob.c
    104    328   3268 xlinit.c
    149    446   2897 xlio.c
     89    220   1820 xlisp.c
    103    303   2300 xljump.c
    851   2388  17752 xllist.c
    316    916   5921 xlmath.c
    690   2149  16101 xlobj.c
    154    319   2789 xlprin.c
    406   1237   8381 xlread.c
     82    219   1884 xlsetf.c
    202    596   4134 xlstr.c
      8     26    158 xlstub.c.NOTUSED
    210    611   4232 xlsubr.c
    171    500   3869 xlsym.c
    153    447   3003 xlsys.c
!!!
wc  xlisp.h xlbfun.c xlbind.c xlcont.c xldbug.c xldmem.c xleval.c xlfio.c xlftab.c xlglob.c xlinit.c xlio.c xlisp.c xljump.c xllist.c xlmath.c xlobj.c xlprin.c xlread.c xlsetf.c xlstr.c xlstub.c.NOTUSED xlsubr.c xlsym.c xlsys.c | sed 's=[^ ]*/==' | diff -b $temp -
exit 0