v06i107: Xlisp version 1.6 (xlisp1.6), Part01/06

sources-request at mirror.UUCP sources-request at mirror.UUCP
Thu Aug 14 01:43:03 AEST 1986


Submitted by: seismo!utah-cs!b-davis (Brad Davis)
Mod.sources: Volume 6, Issue 107
Archive-name: xlisp1.6/Part01

[  This unpacks, compiles, and runs a couple of the demo programs on
   my 4.2BSD Vax750.  I have not tried it on a PC.  --r$  ]


-------------------------------- Cut Here --------------------------------
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#	xlbfun.c
#	xlcont.c
#	xldbug.c
#	xldmem.c
#	xleval.c
# This archive created: Mon Jul 14 10:21:31 1986
export PATH; PATH=/bin:$PATH
if test -f 'xlbfun.c'
then
	echo shar: will not over-write existing file "'xlbfun.c'"
else
cat << \SHAR_EOF > 'xlbfun.c'
/* xlbfun.c - xlisp basic built-in functions */
/*	Copyright (c) 1985, by David Michael Betz
	All Rights Reserved
	Permission is granted for unrestricted non-commercial use	*/

#include "xlisp.h"

/* external variables */
extern NODE ***xlstack,*xlenv;
extern NODE *s_car,*s_cdr,*s_nth,*s_get,*s_svalue,*s_splist,*s_aref;
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 built-in function 'eval' */
NODE *xeval(args)
  NODE *args;
{
    NODE ***oldstk,*expr,*val;

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

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

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

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

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

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

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

    /* get the function and argument list */
    fun = xlarg(&args);
    arglist = xlmatch(LIST,&args);
    xllastarg(args);

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

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

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

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

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

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

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

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

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

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

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

/* xquote - built-in function to quote an expression */
NODE *xquote(args)
  NODE *args;
{
    NODE *val;

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

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

/* xfunction - built-in function to quote a function */
NODE *xfunction(args)
  NODE *args;
{
    NODE *val;

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

    /* create a closure for lambda expressions */
    if (consp(val) && car(val) == s_lambda)
	val = cons(val,xlenv);

    /* otherwise, get the value of a symbol */
    else if (symbolp(val))
	val = xlgetvalue(val);

    /* otherwise, its an error */
    else
	xlerror("not a function",val);

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

/* xlambda - lambda function */
NODE *xlambda(args)
  NODE *args;
{
    NODE ***oldstk,*fargs,*closure;

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

    /* get the formal argument list */
    fargs = xlmatch(LIST,&args);

    /* create a new function definition */
    closure = cons(fargs,args);
    closure = cons(s_lambda,closure);
    closure = cons(closure,xlenv);

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

    /* return the closure */
    return (closure);
}

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

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

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

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

    /* 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 = expr;

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

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

    /* handle any other list */
    else {
	oldstk = xlsave(&val,(NODE **)NULL);
	val = consa(NIL);
	rplaca(val,bquote1(car(expr)));
	rplacd(val,bquote1(cdr(expr)));
	xlstack = oldstk;
    }

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

/* xset - built-in 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 */
    setvalue(sym,val);

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

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

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

    /* initialize */
    arg = args;

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

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

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

/* 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,(NODE **)NULL);

    /* initialize */
    arg = args;

    /* handle each pair of arguments */
    while (arg) {

	/* get place and value */
	place = xlarg(&arg);
	value = xlevarg(&arg);

	/* check the place form */
	if (symbolp(place))
	    xlsetvalue(place,value);
	else if (consp(place))
	    placeform(place,value);
	else
	    xlfail("bad place form");
    }

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

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

/* placeform - handle a place form other than a symbol */
LOCAL placeform(place,value)
  NODE *place,*value;
{
    NODE ***oldstk,*fun,*arg1,*arg2;
    int i;

    /* check the function name */
    if ((fun = xlmatch(SYM,&place)) == s_get) {
	oldstk = xlsave(&arg1,&arg2,(NODE **)NULL);
	arg1 = xlevmatch(SYM,&place);
	arg2 = xlevmatch(SYM,&place);
	xllastarg(place);
	xlputprop(arg1,value,arg2);
	xlstack = oldstk;
    }
    else if (fun == s_svalue || fun == s_splist) {
	oldstk = xlsave(&arg1,(NODE **)NULL);
	arg1 = xlevmatch(SYM,&place);
	xllastarg(place);
	if (fun == s_svalue)
	    setvalue(arg1,value);
	else
	    setplist(arg1,value);
	xlstack = oldstk;
    }
    else if (fun == s_car || fun == s_cdr) {
	oldstk = xlsave(&arg1,(NODE **)NULL);
	arg1 = xlevmatch(LIST,&place);
	xllastarg(place);
	if (consp(arg1))
	    if (fun == s_car)
		rplaca(arg1,value);
	    else
		rplacd(arg1,value);
	xlstack = oldstk;
    }
    else if (fun == s_nth) {
	oldstk = xlsave(&arg1,&arg2,(NODE **)NULL);
	arg1 = xlevmatch(INT,&place);
	arg2 = xlevmatch(LIST,&place);
	xllastarg(place);
	for (i = (int)getfixnum(arg1); i > 0 && consp(arg2); --i)
	    arg2 = cdr(arg2);
	if (consp(arg2))
	    rplaca(arg2,value);
	xlstack = oldstk;
    }

    else if (fun == s_aref) {
	oldstk = xlsave(&arg1,&arg2,(NODE **)NULL);
	arg1 = xlevmatch(VECT,&place);
	arg2 = xlevmatch(INT,&place); i = (int)getfixnum(arg2);
	xllastarg(place);
	if (i < 0 || i >= getsize(arg1))
	    xlerror("index out of range",arg2);
	setelement(arg1,i,value);
	xlstack = oldstk;
    }
    else
	xlfail("bad place form");
}
		       
/* xdefun - built-in function 'defun' */
NODE *xdefun(args)
  NODE *args;
{
    return (defun(args,s_lambda));
}

/* xdefmacro - built-in 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,*closure;

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

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

    /* create a new function definition */
    closure = cons(fargs,args);
    closure = cons(type,closure);
    closure = cons(closure,xlenv);

    /* make the symbol point to a new function definition */
    xlsetvalue(sym,closure);

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

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

/* 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,getstring(x));
		break;
	case INT:
		gsnumber = getfixnum(x);
		break;
	default:
		xlerror("bad argument type",x);
	}
    }
    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,(NODE **)NULL);

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

    /* make the symbol */
    str = getstring(pname);
    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 (getpname(sym));
}

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

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

    /* get the global value */
    while ((val = getvalue(sym)) == s_unbound)
	xlcerror("try evaluating symbol again","unbound variable",sym);

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

/* 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 (getplist(sym));
}

/* 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));
}

/* xputprop - set the value of a property */
NODE *xputprop(args)
  NODE *args;
{
    NODE *sym,*val,*prp;

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

    /* set the property value */
    xlputprop(sym,val,prp);

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

/* 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);
}

/* xhash - compute the hash value of a string or symbol */
NODE *xhash(args)
  NODE *args;
{
    char *str;
    NODE *val;
    int len;

    /* get the string and the table length */
    val = xlarg(&args);
    len = (int)getfixnum(xlmatch(INT,&args));
    xllastarg(args);

    /* get the string */
    if (symbolp(val))
	str = getstring(getpname(val));
    else if (stringp(val))
	str = getstring(val);
    else
	xlerror("bad argument type",val);

    /* return the hash index */
    return (cvfixnum((FIXNUM)hash(str,len)));
}

/* xaref - array reference function */
NODE *xaref(args)
  NODE *args;
{
    NODE *array,*index;
    int i;

    /* get the array and the index */
    array = xlmatch(VECT,&args);
    index = xlmatch(INT,&args); i = (int)getfixnum(index);
    xllastarg(args);

    /* range check the index */
    if (i < 0 || i >= getsize(array))
	xlerror("array index out of bounds",index);

    /* return the array element */
    return (getelement(array,i));
}

/* xmkarray - make a new array */
NODE *xmkarray(args)
  NODE *args;
{
    int size;

    /* get the size of the array */
    size = (int)getfixnum(xlmatch(INT,&args));
    xllastarg(args);

    /* create the array */
    return (newvector(size));
}

SHAR_EOF
fi # end of overwriting check
if test -f 'xlcont.c'
then
	echo shar: will not over-write existing file "'xlcont.c'"
else
cat << \SHAR_EOF > 'xlcont.c'
/* xlcont - xlisp control built-in functions */
/*	Copyright (c) 1985, by David Michael Betz
	All Rights Reserved
	Permission is granted for unrestricted non-commercial use	*/

#include "xlisp.h"

/* external variables */
extern NODE ***xlstack,*xlenv,*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,(NODE **)NULL);

    /* initialize */
    arg = args;

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

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

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

	/* evaluate the predicate part */
	if (val = xlevarg(&list)) {

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

	    /* exit the loop */
	    break;
	}
    }

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

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

/* xcase - built-in function 'case' */
NODE *xcase(args)
  NODE *args;
{
    NODE ***oldstk,*key,*arg,*clause,*list,*val;

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

    /* initialize */
    arg = args;

    /* get the key expression */
    key = xlevarg(&arg);

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

    /* find a case that matches */
    while (arg) {

	/* get the next case clause */
	clause = xlmatch(LIST,&arg);

	/* compare the key list against the key */
	if ((list = xlarg(&clause)) == true ||
            (listp(list) && keypresent(key,list)) ||
            eql(key,list)) {

	    /* evaluate each expression */
	    while (clause)
		val = xlevarg(&clause);

	    /* exit the loop */
	    break;
	}
    }

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

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

/* keypresent - check for the presence of a key in a list */
LOCAL int keypresent(key,list)
  NODE *key,*list;
{
    for (; consp(list); list = cdr(list))
	if (eql(car(list),key))
	    return (TRUE);
    return (FALSE);
}

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

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

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

    /* evaluate each argument */
    while (arg)

	/* get the next argument */
	if ((val = xlevarg(&arg)) == 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,(NODE **)NULL);

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

    /* evaluate each argument */
    while (arg)
	if ((val = xlevarg(&arg)))
	    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,(NODE **)NULL);

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

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

    /* 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,*newenv,*arg,*val;

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

    /* initialize */
    arg = args;

    /* create a new environment frame */
    newenv = xlframe(xlenv);

    /* get the list of bindings and bind the symbols */
    if (!pflag) xlenv = newenv;
    dobindings(xlmatch(LIST,&arg),newenv);
    if (pflag) xlenv = newenv;

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

    /* unbind the arguments */
    xlenv = cdr(xlenv);

    /* 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,*newenv,*arg,*val;

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

    /* initialize */
    arg = args;

    /* create a new environment frame */
    newenv = xlframe(xlenv);

    /* get the list of bindings and bind the symbols */
    if (!pflag) xlenv = newenv;
    dobindings(xlmatch(LIST,&arg),newenv);
    if (pflag) xlenv = newenv;

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

    /* unbind the arguments */
    xlenv = cdr(xlenv);

    /* 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,(NODE **)NULL);

    /* initialize */
    arg = args;

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

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

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

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

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

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

    /* initialize */
    arg = args;

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

    /* 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,*newenv,*arg,*blist,*clist,*test,*rval;
    int rbreak;

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

    /* initialize */
    arg = args;

    /* get the list of bindings */
    blist = xlmatch(LIST,&arg);

    /* create a new environment frame */
    newenv = xlframe(xlenv);

    /* bind the symbols */
    if (!pflag) xlenv = newenv;
    dobindings(blist,newenv);
    if (pflag) xlenv = newenv;

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

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

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

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

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

    /* unbind the arguments */
    xlenv = cdr(xlenv);

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

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

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

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

    /* initialize */
    arg = args;

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

    /* initialize the local environment */
    xlenv = xlframe(xlenv);
    xlbind(sym,NIL,xlenv);

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

	/* bind the symbol to the next list element */
	xlsetvalue(sym,car(list));

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

    /* evaluate the result expression */
    if (!rbreak) {
	xlsetvalue(sym,NIL);
	rval = xleval(val);
    }

    /* unbind the arguments */
    xlenv = cdr(xlenv);

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

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

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

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

    /* initialize */
    arg = args;

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

    /* initialize the local environment */
    xlenv = xlframe(xlenv);
    xlbind(sym,NIL,xlenv);

    /* 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 */
	xlsetvalue(sym,cvfixnum((FIXNUM)i));

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

    /* evaluate the result expression */
    if (!rbreak) {
	xlsetvalue(sym,cvfixnum((FIXNUM)cnt));
	rval = xleval(val);
    }

    /* unbind the arguments */
    xlenv = cdr(xlenv);

    /* 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,(NODE **)NULL);

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

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

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

    /* otherwise, evaluate the remainder of the arguments */
    else {
	while (arg)
	    val = xlevarg(&arg);
    }
    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 = getstring(xlmatch(STR,&args));
    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 = getstring(xlmatch(STR,&args));
    emsg = getstring(xlmatch(STR,&args));
    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 ? getstring(xlmatch(STR,&args)) : "**BREAK**");
    arg = (args ? xlarg(&args) : s_unbound);
    xllastarg(args);

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

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

/* xcleanup - built-in function 'clean-up' */
NODE *xcleanup(args)
  NODE *args;
{
    xllastarg(args);
    xlcleanup();
}

/* xcontinue - built-in function 'continue' */
NODE *xcontinue(args)
  NODE *args;
{
    xllastarg(args);
    xlcontinue();
}

/* 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,(NODE **)NULL);

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

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

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

    /* otherwise, evaluate the expression */
    else {
	expr = xleval(expr);
	val = consa(expr);
    }
    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,*expr,*ehook,*ahook,*env,*newehook,*newahook,*newenv,*val;

    /* create a new stack frame */
    oldstk = xlsave(&expr,&ehook,&ahook,&env,&newehook,&newahook,&newenv,(NODE **)NULL);

    /* get the expression, the new hook functions and the environment */
    expr = xlarg(&args);
    newehook = xlarg(&args);
    newahook = xlarg(&args);
    newenv = (args ? xlarg(&args) : xlenv);
    xllastarg(args);

    /* bind *evalhook* and *applyhook* to the hook functions */
    ehook = getvalue(s_evalhook);
    setvalue(s_evalhook,newehook);
    ahook = getvalue(s_applyhook);
    setvalue(s_applyhook,newahook);
    env = xlenv;
    xlenv = newenv;

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

    /* unbind the hook variables */
    setvalue(s_evalhook,ehook);
    setvalue(s_applyhook,ahook);
    xlenv = env;

    /* 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,env)
  NODE *blist,*env;
{
    NODE ***oldstk,*list,*bnd,*sym,*val;

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

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

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

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

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

	/* bind the value to the symbol */
	xlbind(sym,val,env);
    }

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

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

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

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

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

	/* handle a list of the form (symbol expr) */
	if (consp(bnd)) {
	    sym = xlmatch(SYM,&bnd);
	    bnd = cdr(bnd);
	    if (bnd) {
		val = xlevarg(&bnd);
		if (pflag) {
		    plist = consd(plist);
		    rplaca(plist,cons(sym,val));
		}
		else
		    xlsetvalue(sym,val);
	    }
	}
    }

    /* set the values for parallel updates */
    for (; plist; plist = cdr(plist))
	xlsetvalue(car(car(plist)),cdr(car(plist)));

    /* 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,(NODE **)NULL);

    /* initialize */
    arg = code;

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

    /* 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 = xlvalue;

	/* evaluate each expression in the body */
	while (consp(arg))
	    if (consp(car(arg)))
		xlevarg(&arg);
	    else
		arg = cdr(arg);

	/* fell out the bottom of the loop */
	*pval = NIL;
	sts = FALSE;
    }
    xlend(&cntxt);

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

    /* return status */
    return (sts);
}

SHAR_EOF
fi # end of overwriting check
if test -f 'xldbug.c'
then
	echo shar: will not over-write existing file "'xldbug.c'"
else
cat << \SHAR_EOF > 'xldbug.c'
/* xldebug - xlisp debugging support */
/*	Copyright (c) 1985, by David Michael Betz
	All Rights Reserved
	Permission is granted for unrestricted non-commercial use	*/

#include "xlisp.h"

/* external variables */
extern long total;
extern int xldebug;
extern int xltrace;
extern int xlsample;
extern NODE *s_unbound;
extern NODE *s_stdin,*s_stdout;
extern NODE *s_tracenable,*s_tlimit,*s_breakenable;
extern NODE ***xlstack;
extern NODE *true;
extern NODE **trace_stack;
extern char buf[];

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

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

/* xlfail - xlisp error handler */
/*VARARGS*/
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;
{
    sprintf(buf,"%s: %s",hdr,emsg); stdputstr(buf);
    if (arg != s_unbound) { stdputstr(" - "); stdprint(arg); }
    else xlterpri(getvalue(s_stdout));
    if (cmsg) { sprintf(buf,"if continued: %s\n",cmsg); stdputstr(buf); }
}

/* 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 (getvalue(s_breakenable) == 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;
    int type;

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

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

    /* do the back trace */
    if (getvalue(s_tracenable)) {
	val = getvalue(s_tlimit);
	xlbaktrace(fixp(val) ? (int)getfixnum(val) : -1);
    }

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

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

    /* debug command processing loop */
    xlbegin(&cntxt,CF_ERROR|CF_CLEANUP|CF_CONTINUE,true);
    for (type = 0; type == 0; ) {

	/* setup the continue trap */
	if (type = setjmp(cntxt.c_jmpbuf))
	    switch (type) {
	    case CF_ERROR:
		    xlflush();
		    type = 0;
		    continue;
	    case CF_CLEANUP:
		    continue;
	    case CF_CONTINUE:
		    if (cflag) {
			stdputstr("[ continue from break loop ]\n");
			continue;
		    }
		    else xlabort("this error can't be continued");
	    }

	/* read an expression and check for eof */
	if (!xlread(getvalue(s_stdin),&expr,FALSE)) {
	    type = CF_CLEANUP;
	    break;
	}

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

	/* print it */
	xlprint(getvalue(s_stdout),expr,TRUE);
	xlterpri(getvalue(s_stdout));
    }
    xlend(&cntxt);

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

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

    /* check for aborting to the previous level */
    if (type == CF_CLEANUP) {
	stdputstr("[ abort to previous level ]\n");
	xlsignal(NULL,NIL);
    }
}

/* 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(TDEPTH * sizeof(NODE *))) == NULL) {
	printf("insufficient memory");
	osfinish();
	exit(1);
    }
    total += (long)(TDEPTH * sizeof(NODE *));
    xlsample = 0;
    xltrace = -1;
    xldebug = 0;
}


SHAR_EOF
fi # end of overwriting check
if test -f 'xldmem.c'
then
	echo shar: will not over-write existing file "'xldmem.c'"
else
cat << \SHAR_EOF > 'xldmem.c'
/* xldmem - xlisp dynamic memory management routines */
/*	Copyright (c) 1985, by David Michael Betz
	All Rights Reserved
	Permission is granted for unrestricted non-commercial use	*/

#include "xlisp.h"

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

/* external variables */
extern NODE ***xlstack,***xlstkbase,***xlstktop;
extern NODE *obarray;
extern NODE *xlenv;
extern long total;
extern int anodes,nnodes,nsegs,nfree,gccalls;
extern struct segment *segs;
extern NODE *fnodes;
extern char buf[];

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

/* forward declarations */
FORWARD NODE *newnode();
FORWARD char *strsave();
FORWARD char *stralloc();

/* cons - construct a new cons node */
NODE *cons(x,y)
  NODE *x,*y;
{
    NODE *val;
    val = newnode(LIST);
    rplaca(val,x);
    rplacd(val,y);
    return (val);
}

/* consa - (cons x nil) */
NODE *consa(x)
  NODE *x;
{
    NODE *val;
    val = newnode(LIST);
    rplaca(val,x);
    return (val);
}

/* consd - (cons nil x) */
NODE *consd(x)
  NODE *x;
{
    NODE *val;
    val = newnode(LIST);
    rplacd(val,x);
    return (val);
}

/* cvstring - convert a string to a string node */
NODE *cvstring(str)
  char *str;
{
    NODE ***oldstk,*val;
    oldstk = xlsave(&val,(NODE **)NULL);
    val = newnode(STR);
    val->n_str = strsave(str);
    val->n_strtype = DYNAMIC;
    xlstack = oldstk;
    return (val);
}

/* cvcstring - convert a constant string to a string node */
NODE *cvcstring(str)
  char *str;
{
    NODE *val;
    val = newnode(STR);
    val->n_str = str;
    val->n_strtype = STATIC;
    return (val);
}

/* cvsymbol - convert a string to a symbol */
NODE *cvsymbol(pname)
  char *pname;
{
    NODE ***oldstk,*val;
    oldstk = xlsave(&val,(NODE **)NULL);
    val = newnode(SYM);
    val->n_symplist = newnode(LIST);
    rplaca(val->n_symplist,cvstring(pname));
    xlstack = oldstk;
    return (val);
}

/* cvcsymbol - convert a constant string to a symbol */
NODE *cvcsymbol(pname)
  char *pname;
{
    NODE ***oldstk,*val;
    oldstk = xlsave(&val,(NODE **)NULL);
    val = newnode(SYM);
    val->n_symplist = newnode(LIST);
    rplaca(val->n_symplist,cvcstring(pname));
    xlstack = oldstk;
    return (val);
}

/* cvsubr - convert a function to a subr or fsubr */
NODE *cvsubr(fcn,type)
  NODE *(*fcn)(); int type;
{
    NODE *val;
    val = newnode(type);
    val->n_subr = fcn;
    return (val);
}

/* cvfile - convert a file pointer to a file */
NODE *cvfile(fp)
  FILE *fp;
{
    NODE *val;
    val = newnode(FPTR);
    setfile(val,fp);
    setsavech(val,0);
    return (val);
}

/* cvfixnum - convert an integer to a fixnum node */
NODE *cvfixnum(n)
  FIXNUM n;
{
    NODE *val;
    val = newnode(INT);
    val->n_int = n;
    return (val);
}

/* cvflonum - convert a floating point number to a flonum node */
NODE *cvflonum(n)
  FLONUM n;
{
    NODE *val;
    val = newnode(FLOAT);
    val->n_float = n;
    return (val);
}

/* newstring - allocate and initialize a new string */
NODE *newstring(size)
  int size;
{
    NODE ***oldstk,*val;
    oldstk = xlsave(&val,(NODE **)NULL);
    val = newnode(STR);
    val->n_str = stralloc(size);
    *getstring(val) = 0;
    val->n_strtype = DYNAMIC;
    xlstack = oldstk;
    return (val);
}

/* newobject - allocate and initialize a new object */
NODE *newobject(cls,size)
  NODE *cls; int size;
{
    NODE *val;
    val = newvector(size+1);
    setelement(val,0,cls);
    val->n_type = OBJ;
    return (val);
}

/* newvector - allocate and initialize a new vector node */
NODE *newvector(size)
  int size;
{
    NODE ***oldstk,*vect;
    int bsize;

    /* establish a new stack frame */
    oldstk = xlsave(&vect,(NODE **)NULL);

    /* allocate a vector node and set the size to zero (in case of gc) */
    vect = newnode(VECT);
    vect->n_vsize = 0;

    /* allocate memory for the vector */
    bsize = size * sizeof(NODE *);
    if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL) {
	findmem();
	if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL)
	    xlfail("insufficient vector space");
    }
    vect->n_vsize = size;
    total += (long) bsize;
 
    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the new vector */
    return (vect);
}

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

    /* get a free node */
    if ((nnode = fnodes) == NIL) {
	findmem();
	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 */
LOCAL char *stralloc(size)
  int size;
{
    char *sptr;

    /* allocate memory for the string copy */
    if ((sptr = malloc(size+1)) == NULL) {
	findmem();  
	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 */
LOCAL 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 a string                 UNUSED
LOCAL strfree(str)
  char *str;
{
    total -= (long) (strlen(str)+1);
    free(str);
}
*/

/* findmem - find more memory by collecting then expanding */
findmem()
{
    gc();
    if (nfree < anodes)
	addseg();
}

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

    /* mark the obarray and the current environment */
    mark(obarray);
    mark(xlenv);

    /* mark the evaluation stack */
    for (p = xlstack; p < xlstktop; )
	mark(**p++);

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

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

/* mark - mark all accessible nodes */
void 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;
	    }
	}
    }
}

/* vmark - mark a vector */
vmark(n)
  NODE *n;
{
    int i;
    for (i = 0; i < getsize(n); ++i)
	mark(getelement(n,i));
}

/* 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) {
			    total -= (long) (strlen(p->n_str)+1);
			    free(p->n_str);
			}
			break;
		case FPTR:
			if (p->n_fp)
			    fclose(p->n_fp);
			break;
		case VECT:
			if (p->n_vsize) {
			    total -= (long) (p->n_vsize * sizeof(NODE **));
			    free(p->n_vdata);
			}
			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 OBJ:
    case VECT:
	    vmark(n);
    case SUBR:
    case FSUBR:
    case INT:
    case FLOAT:
    case STR:
    case FPTR:
	    return (FALSE);
    case SYM:
    case LIST:
	    return (car(n) != NIL);
    default:
	    printf("bad node type (%d) found during left scan\n",ntype(n));
	    osfinish ();
	    exit(1);
    }
    /*NOTREACHED*/
}

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

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

/* 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 */
    xlenv = obarray = NIL;

    /* allocate the evaluation stack */
    if ((xlstkbase = (NODE ***)malloc(EDEPTH * sizeof(NODE **))) == NULL) {
	printf("insufficient memory");
	osfinish ();
	exit(1);
    }
    total += (long)(EDEPTH * sizeof(NODE **));
    xlstack = xlstktop = xlstkbase + EDEPTH;
}

SHAR_EOF
fi # end of overwriting check
if test -f 'xleval.c'
then
	echo shar: will not over-write existing file "'xleval.c'"
else
cat << \SHAR_EOF > 'xleval.c'
/* xleval - xlisp evaluator */
/*	Copyright (c) 1985, by David Michael Betz
	All Rights Reserved
	Permission is granted for unrestricted non-commercial use	*/

#include "xlisp.h"

/* external variables */
extern int xlsample;
extern NODE ***xlstack,***xlstkbase,*xlenv;
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;

/* trace variables */
extern NODE **trace_stack;
extern int xltrace;

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

/* xleval - evaluate an xlisp expression (checking for *evalhook*) */
NODE *xleval(expr)
  NODE *expr;
{
    /* check for control codes */
    if (--xlsample <= 0) {
	xlsample = SAMPLE;
	oscheck();
    }

    /* check for *evalhook* */
    if (getvalue(s_evalhook))
	return (evalhook(expr));

    /* add trace entry */
    if (++xltrace < TDEPTH)
	trace_stack[xltrace] = expr;

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

    /* remove trace entry */
    --xltrace;

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

/* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
NODE *xlxeval(expr)
  NODE *expr;
{
    /* check type of value */
    if (consp(expr))
	expr = evform(expr);
    else if (symbolp(expr))
	expr = xlgetvalue(expr);

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

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

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

    /* evaluate the function */
    if (subrp(fun))
	val = (*getsubr(fun))(args);
    else if (consp(fun)) {
	if (consp(car(fun))) {
	    env = cdr(fun);
	    fun = car(fun);
	}
	else
	    env = xlenv;
	if (car(fun) != s_lambda)
	    xlfail("bad function type");
	val = evfun(fun,args,env);
    }
    else
	xlfail("bad function");

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

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

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

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

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

    /* evaluate the function */
    if (subrp(fun) || fsubrp(fun)) {
	if (subrp(fun))
	    args = xlevlist(args);
	val = (*getsubr(fun))(args);
    }
    else if (consp(fun)) {
	if (consp(car(fun))) {
	    env = cdr(fun);
	    fun = car(fun);
	}
	else
	    env = xlenv;
	if ((type = car(fun)) == s_lambda) {
	    args = xlevlist(args);
	    val = evfun(fun,args,env);
	}
	else if (type == s_macro) {
	    args = evfun(fun,args,env);
	    val = xleval(args);
	}
	else
	    xlfail("bad function type");
    }
    else if (objectp(fun))
	val = xlsend(fun,args);
    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,*ehook,*ahook,*args,*val;

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

    /* make an argument list */
    args = consa(expr);
    rplacd(args,consa(xlenv));

    /* rebind the hook functions to nil */
    ehook = getvalue(s_evalhook);
    setvalue(s_evalhook,NIL);
    ahook = getvalue(s_applyhook);
    setvalue(s_applyhook,NIL);

    /* call the hook function */
    val = xlapply(ehook,args);

    /* unbind the symbols */
    setvalue(s_evalhook,ehook);
    setvalue(s_applyhook,ahook);

    /* 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,*val;
    NODE *last = NIL;

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

    /* initialize */
    src = args;

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

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

	/* allocate a new list entry */
	new = consa(NIL);
	if (val)
	    rplacd(last,new);
	else
	    val = dst = new;
	rplaca(new,xleval(car(src)));
	last = new;
    }

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

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

/* 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,env)
  NODE *fun,*args,*env;
{
    NODE ***oldstk,*oldenv,*newenv,*cptr,*fargs,*val;

    /* create a stack frame */
    oldstk = xlsave(&oldenv,&newenv,&cptr,(NODE **)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");

    /* create a new environment frame */
    newenv = xlframe(env);
    oldenv = xlenv;

    /* bind the formal parameters */
    xlabind(fargs,args,newenv);
    xlenv = newenv;

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

    /* restore the environment */
    xlenv = oldenv;

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

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

/* xlabind - bind the arguments for a function */
xlabind(fargs,aargs,env)
  NODE *fargs,*aargs,*env;
{
    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),env);

	/* 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),env);

	    /* 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,env);

	    /* 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,env);
	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,env);

    /* 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 */
/*VARARGS*/
NODE ***xlsave(n)
  NODE **n;
{
    NODE ***oldstk,***nptr;

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

    /* save each node pointer */
    for (nptr = &n; *nptr; nptr++) {
	if (xlstack <= xlstkbase)
	    xlabort("evaluation stack overflow");
	*--xlstack = *nptr;
	**nptr = NIL;
    }

    /* return the old stack pointer */
    return (oldstk);
}

SHAR_EOF
fi # end of overwriting check
#	End of shell archive
exit 0



More information about the Mod.sources mailing list