Relay-Version: version B 2.10.2 2/19/85; site seismo.UUCP
Posting-Version: version B 2.10 beta 3/9/83; site encore.UUCP
Path: seismo!harvard!talcott!encore!wegrzyn
From: wegrzyn@encore.UUCP (Chuck Wegrzyn)
Newsgroups: net.sources
Subject: xlisp v1.4 (5 of 5)
Message-ID: <190@encore.UUCP>
Date: 13 Mar 85 13:57:43 GMT
Organization: Encore Computer Corp., Wellesley Hills, MA
Lines: 2373

#	This is a shell archive.
#	Remove everything above and including the cut line.
#	Then run the rest of the file through sh.
-----cut here-----cut here-----cut here-----cut here-----
#!/bin/sh
# shar:	Shell Archiver
#	Run the following text with /bin/sh to create:
#	xlcont.c
#	xllist.c
#	xlobj.c
# This archive created: Wed Mar 13 08:37:26 1985
echo shar: extracting xlcont.c '(16880 characters)'
sed 's/^XX//' << \SHAR_EOF > xlcont.c
XX/* xlcont - xlisp control built-in functions */
XX
XX#include "xlisp.h"
XX
XX/* external variables */
XXextern NODE *xlstack,*xlenv,*xlnewenv,*xlvalue;
XXextern NODE *s_unbound;
XXextern NODE *s_evalhook,*s_applyhook;
XXextern NODE *true;
XX
XX/* external routines */
XXextern NODE *xlxeval();
XX
XX/* forward declarations */
XXFORWARD NODE *let();
XXFORWARD NODE *prog();
XXFORWARD NODE *progx();
XXFORWARD NODE *doloop();
XX
XX/* xcond - built-in function 'cond' */
XXNODE *xcond(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,arg,list,*val;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&arg,&list,NULL);
XX
XX    /* initialize */
XX    arg.n_ptr = args;
XX
XX    /* initialize the return value */
XX    val = NIL;
XX
XX    /* find a predicate that is true */
XX    while (arg.n_ptr) {
XX
XX	/* get the next conditional */
XX	list.n_ptr = xlmatch(LIST,&arg.n_ptr);
XX
XX	/* evaluate the predicate part */
XX	if (xlevarg(&list.n_ptr)) {
XX
XX	    /* evaluate each expression */
XX	    while (list.n_ptr)
XX		val = xlevarg(&list.n_ptr);
XX
XX	    /* exit the loop */
XX	    break;
XX	}
XX    }
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the value */
XX    return (val);
XX}
XX
XX/* xand - built-in function 'and' */
XXNODE *xand(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,arg,*val;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&arg,NULL);
XX
XX    /* initialize */
XX    arg.n_ptr = args;
XX    val = true;
XX
XX    /* evaluate each argument */
XX    while (arg.n_ptr)
XX
XX	/* get the next argument */
XX	if ((val = xlevarg(&arg.n_ptr)) == NIL)
XX	    break;
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the result value */
XX    return (val);
XX}
XX
XX/* xor - built-in function 'or' */
XXNODE *xor(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,arg,*val;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&arg,NULL);
XX
XX    /* initialize */
XX    arg.n_ptr = args;
XX    val = NIL;
XX
XX    /* evaluate each argument */
XX    while (arg.n_ptr)
XX	if ((val = xlevarg(&arg.n_ptr)))
XX	    break;
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the result value */
XX    return (val);
XX}
XX
XX/* xif - built-in function 'if' */
XXNODE *xif(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,testexpr,thenexpr,elseexpr,*val;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&testexpr,&thenexpr,&elseexpr,NULL);
XX
XX    /* get the test expression, then clause and else clause */
XX    testexpr.n_ptr = xlarg(&args);
XX    thenexpr.n_ptr = xlarg(&args);
XX    elseexpr.n_ptr = (args ? xlarg(&args) : NIL);
XX    xllastarg(args);
XX
XX    /* evaluate the appropriate clause */
XX    val = xleval(xleval(testexpr.n_ptr) ? thenexpr.n_ptr : elseexpr.n_ptr);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the last value */
XX    return (val);
XX}
XX
XX/* xlet - built-in function 'let' */
XXNODE *xlet(args)
XX  NODE *args;
XX{
XX    return (let(args,TRUE));
XX}
XX
XX/* xletstar - built-in function 'let*' */
XXNODE *xletstar(args)
XX  NODE *args;
XX{
XX    return (let(args,FALSE));
XX}
XX
XX/* let - common let routine */
XXLOCAL NODE *let(args,pflag)
XX  NODE *args; int pflag;
XX{
XX    NODE *oldstk,*oldenv,*oldnewenv,arg,*val;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&arg,NULL);
XX
XX    /* initialize */
XX    arg.n_ptr = args;
XX
XX    /* get the list of bindings and bind the symbols */
XX    oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
XX    dobindings(xlmatch(LIST,&arg.n_ptr),pflag);
XX
XX    /* execute the code */
XX    for (val = NIL; arg.n_ptr; )
XX	val = xlevarg(&arg.n_ptr);
XX
XX    /* unbind the arguments */
XX    xlunbind(oldenv); xlnewenv = oldnewenv;
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the result */
XX    return (val);
XX}
XX
XX/* xprog - built-in function 'prog' */
XXNODE *xprog(args)
XX  NODE *args;
XX{
XX    return (prog(args,TRUE));
XX}
XX
XX/* xprogstar - built-in function 'prog*' */
XXNODE *xprogstar(args)
XX  NODE *args;
XX{
XX    return (prog(args,FALSE));
XX}
XX
XX/* prog - common prog routine */
XXLOCAL NODE *prog(args,pflag)
XX  NODE *args; int pflag;
XX{
XX    NODE *oldstk,*oldenv,*oldnewenv,arg,*val;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&arg,NULL);
XX
XX    /* initialize */
XX    arg.n_ptr = args;
XX
XX    /* get the list of bindings and bind the symbols */
XX    oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
XX    dobindings(xlmatch(LIST,&arg.n_ptr),pflag);
XX
XX    /* execute the code */
XX    tagblock(arg.n_ptr,&val);
XX
XX    /* unbind the arguments */
XX    xlunbind(oldenv); xlnewenv = oldnewenv;
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the result */
XX    return (val);
XX}
XX
XX/* xgo - built-in function 'go' */
XXNODE *xgo(args)
XX  NODE *args;
XX{
XX    NODE *label;
XX
XX    /* get the target label */
XX    label = xlarg(&args);
XX    xllastarg(args);
XX
XX    /* transfer to the label */
XX    xlgo(label);
XX}
XX
XX/* xreturn - built-in function 'return' */
XXNODE *xreturn(args)
XX  NODE *args;
XX{
XX    NODE *val;
XX
XX    /* get the return value */
XX    val = (args ? xlarg(&args) : NIL);
XX    xllastarg(args);
XX
XX    /* return from the inner most block */
XX    xlreturn(val);
XX}
XX
XX/* xprog1 - built-in function 'prog1' */
XXNODE *xprog1(args)
XX  NODE *args;
XX{
XX    return (progx(args,1));
XX}
XX
XX/* xprog2 - built-in function 'prog2' */
XXNODE *xprog2(args)
XX  NODE *args;
XX{
XX    return (progx(args,2));
XX}
XX
XX/* progx - common progx code */
XXLOCAL NODE *progx(args,n)
XX  NODE *args; int n;
XX{
XX    NODE *oldstk,arg,val;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&arg,&val,NULL);
XX
XX    /* initialize */
XX    arg.n_ptr = args;
XX
XX    /* evaluate the first n expressions */
XX    while (n--)
XX	val.n_ptr = xlevarg(&arg.n_ptr);
XX
XX    /* evaluate each remaining argument */
XX    while (arg.n_ptr)
XX	xlevarg(&arg.n_ptr);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the last test expression value */
XX    return (val.n_ptr);
XX}
XX
XX/* xprogn - built-in function 'progn' */
XXNODE *xprogn(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,arg,*val;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&arg,NULL);
XX
XX    /* initialize */
XX    arg.n_ptr = args;
XX
XX    /* evaluate each remaining argument */
XX    for (val = NIL; arg.n_ptr; )
XX	val = xlevarg(&arg.n_ptr);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the last test expression value */
XX    return (val);
XX}
XX
XX/* xdo - built-in function 'do' */
XXNODE *xdo(args)
XX  NODE *args;
XX{
XX    return (doloop(args,TRUE));
XX}
XX
XX/* xdostar - built-in function 'do*' */
XXNODE *xdostar(args)
XX  NODE *args;
XX{
XX    return (doloop(args,FALSE));
XX}
XX
XX/* doloop - common do routine */
XXLOCAL NODE *doloop(args,pflag)
XX  NODE *args; int pflag;
XX{
XX    NODE *oldstk,*oldenv,*oldnewenv,arg,blist,clist,test,*rval;
XX    int rbreak;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&arg,&blist,&clist,&test,NULL);
XX
XX    /* initialize */
XX    arg.n_ptr = args;
XX
XX    /* get the list of bindings and bind the symbols */
XX    blist.n_ptr = xlmatch(LIST,&arg.n_ptr);
XX    oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
XX    dobindings(blist.n_ptr,pflag);
XX
XX    /* get the exit test and result forms */
XX    clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
XX    test.n_ptr = xlarg(&clist.n_ptr);
XX
XX    /* execute the loop as long as the test is false */
XX    rbreak = FALSE;
XX    while (xleval(test.n_ptr) == NIL) {
XX
XX	/* execute the body of the loop */
XX	if (tagblock(arg.n_ptr,&rval)) {
XX	    rbreak = TRUE;
XX	    break;
XX	}
XX
XX	/* update the looping variables */
XX	doupdates(blist.n_ptr,pflag);
XX    }
XX
XX    /* evaluate the result expression */
XX    if (!rbreak)
XX	for (rval = NIL; consp(clist.n_ptr); )
XX	    rval = xlevarg(&clist.n_ptr);
XX
XX    /* unbind the arguments */
XX    xlunbind(oldenv); xlnewenv = oldnewenv;
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the result */
XX    return (rval);
XX}
XX
XX/* xdolist - built-in function 'dolist' */
XXNODE *xdolist(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,*oldenv,arg,clist,sym,list,val,*rval;
XX    int rbreak;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&arg,&clist,&sym,&list,&val,NULL);
XX
XX    /* initialize */
XX    arg.n_ptr = args;
XX
XX    /* get the control list (sym list result-expr) */
XX    clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
XX    sym.n_ptr = xlmatch(SYM,&clist.n_ptr);
XX    list.n_ptr = xlevmatch(LIST,&clist.n_ptr);
XX    val.n_ptr = (clist.n_ptr ? xlarg(&clist.n_ptr) : NIL);
XX
XX    /* initialize the local environment */
XX    oldenv = xlenv;
XX    xlsbind(sym.n_ptr,NIL);
XX
XX    /* loop through the list */
XX    rbreak = FALSE;
XX    for (; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
XX
XX	/* bind the symbol to the next list element */
XX	sym.n_ptr->n_symvalue = car(list.n_ptr);
XX
XX	/* execute the loop body */
XX	if (tagblock(arg.n_ptr,&rval)) {
XX	    rbreak = TRUE;
XX	    break;
XX	}
XX    }
XX
XX    /* evaluate the result expression */
XX    if (!rbreak) {
XX	sym.n_ptr->n_symvalue = NIL;
XX	rval = xleval(val.n_ptr);
XX    }
XX
XX    /* unbind the arguments */
XX    xlunbind(oldenv);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the result */
XX    return (rval);
XX}
XX
XX/* xdotimes - built-in function 'dotimes' */
XXNODE *xdotimes(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,*oldenv,arg,clist,sym,val,*rval;
XX    int rbreak,cnt,i;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&arg,&clist,&sym,&val,NULL);
XX
XX    /* initialize */
XX    arg.n_ptr = args;
XX
XX    /* get the control list (sym list result-expr) */
XX    clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
XX    sym.n_ptr = xlmatch(SYM,&clist.n_ptr);
XX    cnt = xlevmatch(INT,&clist.n_ptr)->n_int;
XX    val.n_ptr = (clist.n_ptr ? xlarg(&clist.n_ptr) : NIL);
XX
XX    /* initialize the local environment */
XX    oldenv = xlenv;
XX    xlsbind(sym.n_ptr,NIL);
XX
XX    /* loop through for each value from zero to cnt-1 */
XX    rbreak = FALSE;
XX    for (i = 0; i < cnt; i++) {
XX
XX	/* bind the symbol to the next list element */
XX	sym.n_ptr->n_symvalue = newnode(INT);
XX	sym.n_ptr->n_symvalue->n_int = i;
XX
XX	/* execute the loop body */
XX	if (tagblock(arg.n_ptr,&rval)) {
XX	    rbreak = TRUE;
XX	    break;
XX	}
XX    }
XX
XX    /* evaluate the result expression */
XX    if (!rbreak) {
XX	sym.n_ptr->n_symvalue = newnode(INT);
XX	sym.n_ptr->n_symvalue->n_int = cnt;
XX	rval = xleval(val.n_ptr);
XX    }
XX
XX    /* unbind the arguments */
XX    xlunbind(oldenv);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the result */
XX    return (rval);
XX}
XX
XX/* xcatch - built-in function 'catch' */
XXNODE *xcatch(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,tag,arg,*val;
XX    CONTEXT cntxt;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&tag,&arg,NULL);
XX
XX    /* initialize */
XX    tag.n_ptr = xlevarg(&args);
XX    arg.n_ptr = args;
XX    val = NIL;
XX
XX    /* establish an execution context */
XX    xlbegin(&cntxt,CF_THROW,tag.n_ptr);
XX
XX    /* check for 'throw' */
XX    if (setjmp(cntxt.c_jmpbuf))
XX	val = xlvalue;
XX
XX    /* otherwise, evaluate the remainder of the arguments */
XX    else {
XX	while (arg.n_ptr)
XX	    val = xlevarg(&arg.n_ptr);
XX    }
XX    xlend(&cntxt);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the result */
XX    return (val);
XX}
XX
XX/* xthrow - built-in function 'throw' */
XXNODE *xthrow(args)
XX  NODE *args;
XX{
XX    NODE *tag,*val;
XX
XX    /* get the tag and value */
XX    tag = xlarg(&args);
XX    val = (args ? xlarg(&args) : NIL);
XX    xllastarg(args);
XX
XX    /* throw the tag */
XX    xlthrow(tag,val);
XX}
XX
XX/* xerror - built-in function 'error' */
XXNODE *xerror(args)
XX  NODE *args;
XX{
XX    char *emsg; NODE *arg;
XX
XX    /* get the error message and the argument */
XX    emsg = xlmatch(STR,&args)->n_str;
XX    arg = (args ? xlarg(&args) : s_unbound);
XX    xllastarg(args);
XX
XX    /* signal the error */
XX    xlerror(emsg,arg);
XX}
XX
XX/* xcerror - built-in function 'cerror' */
XXNODE *xcerror(args)
XX  NODE *args;
XX{
XX    char *cmsg,*emsg; NODE *arg;
XX
XX    /* get the correction message, the error message, and the argument */
XX    cmsg = xlmatch(STR,&args)->n_str;
XX    emsg = xlmatch(STR,&args)->n_str;
XX    arg = (args ? xlarg(&args) : s_unbound);
XX    xllastarg(args);
XX
XX    /* signal the error */
XX    xlcerror(cmsg,emsg,arg);
XX
XX    /* return nil */
XX    return (NIL);
XX}
XX
XX/* xbreak - built-in function 'break' */
XXNODE *xbreak(args)
XX  NODE *args;
XX{
XX    char *emsg; NODE *arg;
XX
XX    /* get the error message */
XX    emsg = (args ? xlmatch(STR,&args)->n_str : "**BREAK**");
XX    arg = (args ? xlarg(&args) : s_unbound);
XX    xllastarg(args);
XX
XX    /* enter the break loop */
XX    xlbreak(emsg,arg);
XX
XX    /* return nil */
XX    return (NIL);
XX}
XX
XX/* xerrset - built-in function 'errset' */
XXNODE *xerrset(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,expr,flag,*val;
XX    CONTEXT cntxt;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&expr,&flag,NULL);
XX
XX    /* get the expression and the print flag */
XX    expr.n_ptr = xlarg(&args);
XX    flag.n_ptr = (args ? xlarg(&args) : true);
XX    xllastarg(args);
XX
XX    /* establish an execution context */
XX    xlbegin(&cntxt,CF_ERROR,flag.n_ptr);
XX
XX    /* check for error */
XX    if (setjmp(cntxt.c_jmpbuf))
XX	val = NIL;
XX
XX    /* otherwise, evaluate the expression */
XX    else {
XX	expr.n_ptr = xleval(expr.n_ptr);
XX	val = newnode(LIST);
XX	rplaca(val,expr.n_ptr);
XX    }
XX    xlend(&cntxt);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the result */
XX    return (val);
XX}
XX
XX/* xevalhook - eval hook function */
XXNODE *xevalhook(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,*oldenv,expr,ehook,ahook,*val;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&expr,&ehook,&ahook,NULL);
XX
XX    /* get the expression and the hook functions */
XX    expr.n_ptr = xlarg(&args);
XX    ehook.n_ptr = xlarg(&args);
XX    ahook.n_ptr = xlarg(&args);
XX    xllastarg(args);
XX
XX    /* bind *evalhook* and *applyhook* to the hook functions */
XX    oldenv = xlenv;
XX    xlsbind(s_evalhook,ehook.n_ptr);
XX    xlsbind(s_applyhook,ahook.n_ptr);
XX
XX    /* evaluate the expression (bypassing *evalhook*) */
XX    val = xlxeval(expr.n_ptr);
XX
XX    /* unbind the hook variables */
XX    xlunbind(oldenv);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the result */
XX    return (val);
XX}
XX
XX/* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
XXLOCAL dobindings(blist,pflag)
XX  NODE *blist; int pflag;
XX{
XX    NODE *oldstk,list,bnd,sym,val;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&list,&bnd,&sym,&val,NULL);
XX
XX   /* bind each symbol in the list of bindings */
XX    for (list.n_ptr = blist; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
XX
XX	/* get the next binding */
XX	bnd.n_ptr = car(list.n_ptr);
XX
XX	/* handle a symbol */
XX	if (symbolp(bnd.n_ptr)) {
XX	    sym.n_ptr = bnd.n_ptr;
XX	    val.n_ptr = NIL;
XX	}
XX
XX	/* handle a list of the form (symbol expr) */
XX	else if (consp(bnd.n_ptr)) {
XX	    sym.n_ptr = xlmatch(SYM,&bnd.n_ptr);
XX	    val.n_ptr = xlevarg(&bnd.n_ptr);
XX	}
XX	else
XX	    xlfail("bad binding");
XX
XX	/* bind the value to the symbol */
XX	if (pflag)
XX	    xlbind(sym.n_ptr,val.n_ptr);
XX	else
XX	    xlsbind(sym.n_ptr,val.n_ptr);
XX    }
XX
XX    /* fix the bindings on a parallel let */
XX    if (pflag)
XX	xlfixbindings();
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX}
XX
XX/* doupdates - handle updates for do/do* */
XXdoupdates(blist,pflag)
XX  NODE *blist; int pflag;
XX{
XX    NODE *oldstk,*oldenv,*oldnewenv,list,bnd,sym,val;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&list,&bnd,&sym,&val,NULL);
XX
XX    /* initialize the local environment */
XX    if (pflag) {
XX	oldenv = xlenv; oldnewenv = xlnewenv;
XX    }
XX
XX    /* bind each symbol in the list of bindings */
XX    for (list.n_ptr = blist; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
XX
XX	/* get the next binding */
XX	bnd.n_ptr = car(list.n_ptr);
XX
XX	/* handle a list of the form (symbol expr) */
XX	if (consp(bnd.n_ptr)) {
XX	    sym.n_ptr = xlmatch(SYM,&bnd.n_ptr);
XX	    bnd.n_ptr = cdr(bnd.n_ptr);
XX	    if (bnd.n_ptr) {
XX		val.n_ptr = xlevarg(&bnd.n_ptr);
XX		if (pflag)
XX		    xlbind(sym.n_ptr,val.n_ptr);
XX		else
XX		    sym.n_ptr->n_symvalue = val.n_ptr;
XX	    }
XX	}
XX    }
XX
XX    /* fix the bindings on a parallel let */
XX    if (pflag) {
XX	xlfixbindings();
XX	xlenv = oldenv; xlnewenv = oldnewenv;
XX    }
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX}
XX
XX/* tagblock - execute code within a block and tagbody */
XXint tagblock(code,pval)
XX  NODE *code,**pval;
XX{
XX    NODE *oldstk,arg;
XX    CONTEXT cntxt;
XX    int type,sts;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&arg,NULL);
XX
XX    /* initialize */
XX    arg.n_ptr = code;
XX
XX    /* establish an execution context */
XX    xlbegin(&cntxt,CF_GO|CF_RETURN,arg.n_ptr);
XX
XX    /* check for a 'return' */
XX    if ((type = setjmp(cntxt.c_jmpbuf)) == CF_RETURN) {
XX	*pval = xlvalue;
XX	sts = TRUE;
XX    }
XX
XX    /* otherwise, enter the body */
XX    else {
XX
XX	/* check for a 'go' */
XX	if (type == CF_GO)
XX	    arg.n_ptr = xlvalue;
XX
XX	/* evaluate each expression in the body */
XX	while (consp(arg.n_ptr))
XX	    if (consp(car(arg.n_ptr)))
XX		xlevarg(&arg.n_ptr);
XX	    else
XX		arg.n_ptr = cdr(arg.n_ptr);
XX	
XX	/* indicate that we fell through the bottom of the tagbody */
XX	*pval = NIL;
XX	sts = FALSE;
XX    }
XX    xlend(&cntxt);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return status */
XX    return (sts);
XX}
SHAR_EOF
if test 16880 -ne "`wc -c xlcont.c`"
then
echo shar: error transmitting xlcont.c '(should have been 16880 characters)'
fi
echo shar: extracting xllist.c '(17752 characters)'
sed 's/^XX//' << \SHAR_EOF > xllist.c
XX/* xllist - xlisp built-in list functions */
XX
XX#include "xlisp.h"
XX
XX#ifdef MEGAMAX
XXoverlay "overflow"
XX#endif
XX
XX/* external variables */
XXextern NODE *xlstack;
XXextern NODE *s_unbound;
XXextern NODE *true;
XX
XX/* external routines */
XXextern int eq(),eql(),equal();
XX
XX/* forward declarations */
XXFORWARD NODE *cxr();
XXFORWARD NODE *nth(),*assoc();
XXFORWARD NODE *subst(),*sublis(),*map();
XXFORWARD NODE *cequal();
XX
XX/* xcar - return the car of a list */
XXNODE *xcar(args)
XX  NODE *args;
XX{
XX    return (cxr(args,"a"));
XX}
XX
XX/* xcdr - return the cdr of a list */
XXNODE *xcdr(args)
XX  NODE *args;
XX{
XX    return (cxr(args,"d"));
XX}
XX
XX/* xcaar - return the caar of a list */
XXNODE *xcaar(args)
XX  NODE *args;
XX{
XX    return (cxr(args,"aa"));
XX}
XX
XX/* xcadr - return the cadr of a list */
XXNODE *xcadr(args)
XX  NODE *args;
XX{
XX    return (cxr(args,"da"));
XX}
XX
XX/* xcdar - return the cdar of a list */
XXNODE *xcdar(args)
XX  NODE *args;
XX{
XX    return (cxr(args,"ad"));
XX}
XX
XX/* xcddr - return the cddr of a list */
XXNODE *xcddr(args)
XX  NODE *args;
XX{
XX    return (cxr(args,"dd"));
XX}
XX
XX/* cxr - common car/cdr routine */
XXLOCAL NODE *cxr(args,adstr)
XX  NODE *args; char *adstr;
XX{
XX    NODE *list;
XX
XX    /* get the list */
XX    list = xlmatch(LIST,&args);
XX    xllastarg(args);
XX
XX    /* perform the car/cdr operations */
XX    while (*adstr && consp(list))
XX	list = (*adstr++ == 'a' ? car(list) : cdr(list));
XX
XX    /* make sure the operation succeeded */
XX    if (*adstr && list)
XX	xlfail("bad argument");
XX
XX    /* return the result */
XX    return (list);
XX}
XX
XX/* xcons - construct a new list cell */
XXNODE *xcons(args)
XX  NODE *args;
XX{
XX    NODE *arg1,*arg2,*val;
XX
XX    /* get the two arguments */
XX    arg1 = xlarg(&args);
XX    arg2 = xlarg(&args);
XX    xllastarg(args);
XX
XX    /* construct a new list element */
XX    val = newnode(LIST);
XX    rplaca(val,arg1);
XX    rplacd(val,arg2);
XX
XX    /* return the list */
XX    return (val);
XX}
XX
XX/* xlist - built a list of the arguments */
XXNODE *xlist(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,arg,list,val,*last,*lptr;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&arg,&list,&val,NULL);
XX
XX    /* initialize */
XX    arg.n_ptr = args;
XX
XX    /* evaluate and append each argument */
XX    for (last = NIL; arg.n_ptr != NIL; last = lptr) {
XX
XX	/* evaluate the next argument */
XX	val.n_ptr = xlarg(&arg.n_ptr);
XX
XX	/* append this argument to the end of the list */
XX	lptr = newnode(LIST);
XX	if (last == NIL)
XX	    list.n_ptr = lptr;
XX	else
XX	    rplacd(last,lptr);
XX	rplaca(lptr,val.n_ptr);
XX    }
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the list */
XX    return (list.n_ptr);
XX}
XX
XX/* xappend - built-in function append */
XXNODE *xappend(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,arg,list,last,val,*lptr;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&arg,&list,&last,&val,NULL);
XX
XX    /* initialize */
XX    arg.n_ptr = args;
XX
XX    /* evaluate and append each argument */
XX    while (arg.n_ptr) {
XX
XX	/* evaluate the next argument */
XX	list.n_ptr = xlmatch(LIST,&arg.n_ptr);
XX
XX	/* append each element of this list to the result list */
XX	while (consp(list.n_ptr)) {
XX
XX	    /* append this element */
XX	    lptr = newnode(LIST);
XX	    if (last.n_ptr == NIL)
XX		val.n_ptr = lptr;
XX	    else
XX		rplacd(last.n_ptr,lptr);
XX	    rplaca(lptr,car(list.n_ptr));
XX
XX	    /* save the new last element */
XX	    last.n_ptr = lptr;
XX
XX	    /* move to the next element */
XX	    list.n_ptr = cdr(list.n_ptr);
XX	}
XX    }
XX
XX    /* restore previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the list */
XX    return (val.n_ptr);
XX}
XX
XX/* xreverse - built-in function reverse */
XXNODE *xreverse(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,list,val,*lptr;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&list,&val,NULL);
XX
XX    /* get the list to reverse */
XX    list.n_ptr = xlmatch(LIST,&args);
XX    xllastarg(args);
XX
XX    /* append each element of this list to the result list */
XX    while (consp(list.n_ptr)) {
XX
XX	/* append this element */
XX	lptr = newnode(LIST);
XX	rplaca(lptr,car(list.n_ptr));
XX	rplacd(lptr,val.n_ptr);
XX	val.n_ptr = lptr;
XX
XX	/* move to the next element */
XX	list.n_ptr = cdr(list.n_ptr);
XX    }
XX
XX    /* restore previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the list */
XX    return (val.n_ptr);
XX}
XX
XX/* xlast - return the last cons of a list */
XXNODE *xlast(args)
XX  NODE *args;
XX{
XX    NODE *list;
XX
XX    /* get the list */
XX    list = xlmatch(LIST,&args);
XX    xllastarg(args);
XX
XX    /* find the last cons */
XX    while (consp(list) && cdr(list))
XX	list = cdr(list);
XX
XX    /* return the last element */
XX    return (list);
XX}
XX
XX/* xmember - built-in function 'member' */
XXNODE *xmember(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,x,list,fcn,*val;
XX    int tresult;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&x,&list,&fcn,NULL);
XX
XX    /* get the expression to look for and the list */
XX    x.n_ptr = xlarg(&args);
XX    list.n_ptr = xlmatch(LIST,&args);
XX    xltest(&fcn.n_ptr,&tresult,&args);
XX    xllastarg(args);
XX
XX    /* look for the expression */
XX    for (val = NIL; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr))
XX	if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) == tresult) {
XX	    val = list.n_ptr;
XX	    break;
XX	}
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the result */
XX    return (val);
XX}
XX
XX/* xassoc - built-in function 'assoc' */
XXNODE *xassoc(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,x,alist,fcn,*pair,*val;
XX    int tresult;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&x,&alist,&fcn,NULL);
XX
XX    /* get the expression to look for and the association list */
XX    x.n_ptr = xlarg(&args);
XX    alist.n_ptr = xlmatch(LIST,&args);
XX    xltest(&fcn.n_ptr,&tresult,&args);
XX    xllastarg(args);
XX
XX    /* look for the expression */
XX    for (val = NIL; consp(alist.n_ptr); alist.n_ptr = cdr(alist.n_ptr))
XX	if ((pair = car(alist.n_ptr)) && consp(pair))
XX	    if (dotest(x.n_ptr,car(pair),fcn.n_ptr) == tresult) {
XX		val = pair;
XX		break;
XX	    }
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the result */
XX    return (val);
XX}
XX
XX/* xsubst - substitute one expression for another */
XXNODE *xsubst(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,to,from,expr,fcn,*val;
XX    int tresult;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&to,&from,&expr,&fcn,NULL);
XX
XX    /* get the to value, the from value and the expression */
XX    to.n_ptr = xlarg(&args);
XX    from.n_ptr = xlarg(&args);
XX    expr.n_ptr = xlarg(&args);
XX    xltest(&fcn.n_ptr,&tresult,&args);
XX    xllastarg(args);
XX
XX    /* do the substitution */
XX    val = subst(to.n_ptr,from.n_ptr,expr.n_ptr,fcn.n_ptr,tresult);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the result */
XX    return (val);
XX}
XX
XX/* subst - substitute one expression for another */
XXLOCAL NODE *subst(to,from,expr,fcn,tresult)
XX  NODE *to,*from,*expr,*fcn; int tresult;
XX{
XX    NODE *oldstk,carval,cdrval,*val;
XX
XX    if (dotest(expr,from,fcn) == tresult)
XX	val = to;
XX    else if (consp(expr)) {
XX	oldstk = xlsave(&carval,&cdrval,NULL);
XX	carval.n_ptr = subst(to,from,car(expr),fcn,tresult);
XX	cdrval.n_ptr = subst(to,from,cdr(expr),fcn,tresult);
XX	val = newnode(LIST);
XX	rplaca(val,carval.n_ptr);
XX	rplacd(val,cdrval.n_ptr);
XX	xlstack = oldstk;
XX    }
XX    else
XX	val = expr;
XX    return (val);
XX}
XX
XX/* xsublis - substitute using an association list */
XXNODE *xsublis(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,alist,expr,fcn,*val;
XX    int tresult;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&alist,&expr,&fcn,NULL);
XX
XX    /* get the assocation list and the expression */
XX    alist.n_ptr = xlmatch(LIST,&args);
XX    expr.n_ptr = xlarg(&args);
XX    xltest(&fcn.n_ptr,&tresult,&args);
XX    xllastarg(args);
XX
XX    /* do the substitution */
XX    val = sublis(alist.n_ptr,expr.n_ptr,fcn.n_ptr,tresult);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the result */
XX    return (val);
XX}
XX
XX/* sublis - substitute using an association list */
XXLOCAL NODE *sublis(alist,expr,fcn,tresult)
XX  NODE *alist,*expr,*fcn; int tresult;
XX{
XX    NODE *oldstk,carval,cdrval,*val;
XX
XX    if (val = assoc(expr,alist,fcn,tresult))
XX	val = cdr(val);
XX    else if (consp(expr)) {
XX	oldstk = xlsave(&carval,&cdrval,NULL);
XX	carval.n_ptr = sublis(alist,car(expr),fcn,tresult);
XX	cdrval.n_ptr = sublis(alist,cdr(expr),fcn,tresult);
XX	val = newnode(LIST);
XX	rplaca(val,carval.n_ptr);
XX	rplacd(val,cdrval.n_ptr);
XX	xlstack = oldstk;
XX    }
XX    else
XX	val = expr;
XX    return (val);
XX}
XX
XX/* assoc - find a pair in an association list */
XXLOCAL NODE *assoc(expr,alist,fcn,tresult)
XX  NODE *expr,*alist,*fcn; int tresult;
XX{
XX    NODE *pair;
XX
XX    for (; consp(alist); alist = cdr(alist))
XX	if ((pair = car(alist)) && consp(pair))
XX	    if (dotest(expr,car(pair),fcn) == tresult)
XX		return (pair);
XX    return (NIL);
XX}
XX
XX/* xremove - built-in function 'remove' */
XXNODE *xremove(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,x,list,fcn,val,*p,*last;
XX    int tresult;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&x,&list,&fcn,&val,NULL);
XX
XX    /* get the expression to remove and the list */
XX    x.n_ptr = xlarg(&args);
XX    list.n_ptr = xlmatch(LIST,&args);
XX    xltest(&fcn.n_ptr,&tresult,&args);
XX    xllastarg(args);
XX
XX    /* remove matches */
XX    while (consp(list.n_ptr)) {
XX
XX	/* check to see if this element should be deleted */
XX	if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) != tresult) {
XX	    p = newnode(LIST);
XX	    rplaca(p,car(list.n_ptr));
XX	    if (val.n_ptr) rplacd(last,p);
XX	    else val.n_ptr = p;
XX	    last = p;
XX	}
XX
XX	/* move to the next element */
XX	list.n_ptr = cdr(list.n_ptr);
XX    }
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the updated list */
XX    return (val.n_ptr);
XX}
XX
XX/* dotest - call a test function */
XXint dotest(arg1,arg2,fcn)
XX  NODE *arg1,*arg2,*fcn;
XX{
XX    NODE *oldstk,args,*val;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&args,NULL);
XX
XX    /* build an argument list */
XX    args.n_ptr = newnode(LIST);
XX    rplaca(args.n_ptr,arg1);
XX    rplacd(args.n_ptr,newnode(LIST));
XX    rplaca(cdr(args.n_ptr),arg2);
XX
XX    /* apply the test function */
XX    val = xlapply(fcn,args.n_ptr);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the result of the test */
XX    return (val != NIL);
XX}
XX
XX/* xnth - return the nth element of a list */
XXNODE *xnth(args)
XX  NODE *args;
XX{
XX    return (nth(args,FALSE));
XX}
XX
XX/* xnthcdr - return the nth cdr of a list */
XXNODE *xnthcdr(args)
XX  NODE *args;
XX{
XX    return (nth(args,TRUE));
XX}
XX
XX/* nth - internal nth function */
XXLOCAL NODE *nth(args,cdrflag)
XX  NODE *args; int cdrflag;
XX{
XX    NODE *list;
XX    int n;
XX
XX    /* get n and the list */
XX    if ((n = xlmatch(INT,&args)->n_int) < 0)
XX	xlfail("bad argument");
XX    if ((list = xlmatch(LIST,&args)) == NIL)
XX	xlfail("bad argument");
XX    xllastarg(args);
XX
XX    /* find the nth element */
XX    for (; n > 0 && consp(list); n--)
XX	list = cdr(list);
XX
XX    /* return the list beginning at the nth element */
XX    return (cdrflag || !consp(list) ? list : car(list));
XX}
XX
XX/* xlength - return the length of a list */
XXNODE *xlength(args)
XX  NODE *args;
XX{
XX    NODE *list,*val;
XX    int n;
XX
XX    /* get the list */
XX    list = xlmatch(LIST,&args);
XX    xllastarg(args);
XX
XX    /* find the length */
XX    for (n = 0; consp(list); n++)
XX	list = cdr(list);
XX
XX    /* create the value node */
XX    val = newnode(INT);
XX    val->n_int = n;
XX
XX    /* return the length */
XX    return (val);
XX}
XX
XX/* xmapc - built-in function 'mapc' */
XXNODE *xmapc(args)
XX  NODE *args;
XX{
XX    return (map(args,TRUE,FALSE));
XX}
XX
XX/* xmapcar - built-in function 'mapcar' */
XXNODE *xmapcar(args)
XX  NODE *args;
XX{
XX    return (map(args,TRUE,TRUE));
XX}
XX
XX/* xmapl - built-in function 'mapl' */
XXNODE *xmapl(args)
XX  NODE *args;
XX{
XX    return (map(args,FALSE,FALSE));
XX}
XX
XX/* xmaplist - built-in function 'maplist' */
XXNODE *xmaplist(args)
XX  NODE *args;
XX{
XX    return (map(args,FALSE,TRUE));
XX}
XX
XX/* map - internal mapping function */
XXLOCAL NODE *map(args,carflag,valflag)
XX  NODE *args; int carflag,valflag;
XX{
XX    NODE *oldstk,fcn,lists,arglist,val,*last,*p,*x,*y;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&fcn,&lists,&arglist,&val,NULL);
XX
XX    /* get the function to apply and the first list */
XX    fcn.n_ptr = xlarg(&args);
XX    lists.n_ptr = xlmatch(LIST,&args);
XX
XX    /* save the first list if not saving function values */
XX    if (!valflag)
XX	val.n_ptr = lists.n_ptr;
XX
XX    /* set up the list of argument lists */
XX    p = newnode(LIST);
XX    rplaca(p,lists.n_ptr);
XX    lists.n_ptr = p;
XX
XX    /* get the remaining argument lists */
XX    while (args) {
XX	p = newnode(LIST);
XX	rplacd(p,lists.n_ptr);
XX	lists.n_ptr = p;
XX	rplaca(p,xlmatch(LIST,&args));
XX    }
XX
XX    /* if the function is a symbol, get its value */
XX    if (symbolp(fcn.n_ptr))
XX	fcn.n_ptr = xleval(fcn.n_ptr);
XX
XX    /* loop through each of the argument lists */
XX    for (;;) {
XX
XX	/* build an argument list from the sublists */
XX	arglist.n_ptr = NIL;
XX	for (x = lists.n_ptr; x && (y = car(x)) && consp(y); x = cdr(x)) {
XX	    p = newnode(LIST);
XX	    rplacd(p,arglist.n_ptr);
XX	    arglist.n_ptr = p;
XX	    rplaca(p,carflag ? car(y) : y);
XX	    rplaca(x,cdr(y));
XX	}
XX
XX	/* quit if any of the lists were empty */
XX	if (x) break;
XX
XX	/* apply the function to the arguments */
XX	if (valflag) {
XX	    p = newnode(LIST);
XX	    if (val.n_ptr) rplacd(last,p);
XX	    else val.n_ptr = p;
XX	    rplaca(p,xlapply(fcn.n_ptr,arglist.n_ptr));
XX	    last = p;
XX	}
XX	else
XX	    xlapply(fcn.n_ptr,arglist.n_ptr);
XX    }
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the last test expression value */
XX    return (val.n_ptr);
XX}
XX
XX/* xrplca - replace the car of a list node */
XXNODE *xrplca(args)
XX  NODE *args;
XX{
XX    NODE *list,*newcar;
XX
XX    /* get the list and the new car */
XX    if ((list = xlmatch(LIST,&args)) == NIL)
XX	xlfail("bad argument");
XX    newcar = xlarg(&args);
XX    xllastarg(args);
XX
XX    /* replace the car */
XX    rplaca(list,newcar);
XX
XX    /* return the list node that was modified */
XX    return (list);
XX}
XX
XX/* xrplcd - replace the cdr of a list node */
XXNODE *xrplcd(args)
XX  NODE *args;
XX{
XX    NODE *list,*newcdr;
XX
XX    /* get the list and the new cdr */
XX    if ((list = xlmatch(LIST,&args)) == NIL)
XX	xlfail("bad argument");
XX    newcdr = xlarg(&args);
XX    xllastarg(args);
XX
XX    /* replace the cdr */
XX    rplacd(list,newcdr);
XX
XX    /* return the list node that was modified */
XX    return (list);
XX}
XX
XX/* xnconc - destructively append lists */
XXNODE *xnconc(args)
XX  NODE *args;
XX{
XX    NODE *list,*last,*val;
XX
XX    /* concatenate each argument */
XX    for (val = NIL; args; ) {
XX
XX	/* concatenate this list */
XX	if (list = xlmatch(LIST,&args)) {
XX
XX	    /* check for this being the first non-empty list */
XX	    if (val)
XX		rplacd(last,list);
XX	    else
XX		val = list;
XX
XX	    /* find the end of the list */
XX	    while (consp(cdr(list)))
XX		list = cdr(list);
XX
XX	    /* save the new last element */
XX	    last = list;
XX	}
XX    }
XX
XX    /* return the list */
XX    return (val);
XX}
XX
XX/* xdelete - built-in function 'delete' */
XXNODE *xdelete(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,x,list,fcn,*last,*val;
XX    int tresult;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&x,&list,&fcn,NULL);
XX
XX    /* get the expression to delete and the list */
XX    x.n_ptr = xlarg(&args);
XX    list.n_ptr = xlmatch(LIST,&args);
XX    xltest(&fcn.n_ptr,&tresult,&args);
XX    xllastarg(args);
XX
XX    /* delete leading matches */
XX    while (consp(list.n_ptr)) {
XX	if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) != tresult)
XX	    break;
XX	list.n_ptr = cdr(list.n_ptr);
XX    }
XX    val = last = list.n_ptr;
XX
XX    /* delete embedded matches */
XX    if (consp(list.n_ptr)) {
XX
XX	/* skip the first non-matching element */
XX	list.n_ptr = cdr(list.n_ptr);
XX
XX	/* look for embedded matches */
XX	while (consp(list.n_ptr)) {
XX
XX	    /* check to see if this element should be deleted */
XX	    if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) == tresult)
XX		rplacd(last,cdr(list.n_ptr));
XX	    else
XX		last = list.n_ptr;
XX
XX	    /* move to the next element */
XX	    list.n_ptr = cdr(list.n_ptr);
XX 	}
XX    }
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the updated list */
XX    return (val);
XX}
XX
XX/* xatom - is this an atom? */
XXNODE *xatom(args)
XX  NODE *args;
XX{
XX    NODE *arg;
XX    arg = xlarg(&args);
XX    xllastarg(args);
XX    return (atom(arg) ? true : NIL);
XX}
XX
XX/* xsymbolp - is this an symbol? */
XXNODE *xsymbolp(args)
XX  NODE *args;
XX{
XX    NODE *arg;
XX    arg = xlarg(&args);
XX    xllastarg(args);
XX    return (arg == NIL || symbolp(arg) ? true : NIL);
XX}
XX
XX/* xnumberp - is this an number? */
XXNODE *xnumberp(args)
XX  NODE *args;
XX{
XX    NODE *arg;
XX    arg = xlarg(&args);
XX    xllastarg(args);
XX    return (fixp(arg) ? true : NIL);
XX}
XX
XX/* xboundp - is this a value bound to this symbol? */
XXNODE *xboundp(args)
XX  NODE *args;
XX{
XX    NODE *sym;
XX    sym = xlmatch(SYM,&args);
XX    xllastarg(args);
XX    return (sym->n_symvalue == s_unbound ? NIL : true);
XX}
XX
XX/* xnull - is this null? */
XXNODE *xnull(args)
XX  NODE *args;
XX{
XX    NODE *arg;
XX    arg = xlarg(&args);
XX    xllastarg(args);
XX    return (null(arg) ? true : NIL);
XX}
XX
XX/* xlistp - is this a list? */
XXNODE *xlistp(args)
XX  NODE *args;
XX{
XX    NODE *arg;
XX    arg = xlarg(&args);
XX    xllastarg(args);
XX    return (listp(arg) ? true : NIL);
XX}
XX
XX/* xconsp - is this a cons? */
XXNODE *xconsp(args)
XX  NODE *args;
XX{
XX    NODE *arg;
XX    arg = xlarg(&args);
XX    xllastarg(args);
XX    return (consp(arg) ? true : NIL);
XX}
XX
XX/* xeq - are these equal? */
XXNODE *xeq(args)
XX  NODE *args;
XX{
XX    return (cequal(args,eq));
XX}
XX
XX/* xeql - are these equal? */
XXNODE *xeql(args)
XX  NODE *args;
XX{
XX    return (cequal(args,eql));
XX}
XX
XX/* xequal - are these equal? */
XXNODE *xequal(args)
XX  NODE *args;
XX{
XX    return (cequal(args,equal));
XX}
XX
XX/* cequal - common eq/eql/equal function */
XXLOCAL NODE *cequal(args,fcn)
XX  NODE *args; int (*fcn)();
XX{
XX    NODE *arg1,*arg2;
XX
XX    /* get the two arguments */
XX    arg1 = xlarg(&args);
XX    arg2 = xlarg(&args);
XX    xllastarg(args);
XX
XX    /* compare the arguments */
XX    return ((*fcn)(arg1,arg2) ? true : NIL);
XX}
SHAR_EOF
if test 17752 -ne "`wc -c xllist.c`"
then
echo shar: error transmitting xllist.c '(should have been 17752 characters)'
fi
echo shar: extracting xlobj.c '(16101 characters)'
sed 's/^XX//' << \SHAR_EOF > xlobj.c
XX/* xlobj - xlisp object functions */
XX
XX#include "xlisp.h"
XX
XX#ifdef MEGAMAX
XXoverlay "overflow"
XX#endif
XX
XX/* external variables */
XXextern NODE *xlstack;
XXextern NODE *xlenv,*xlnewenv;
XXextern NODE *s_stdout;
XXextern NODE *self;
XXextern NODE *class;
XXextern NODE *object;
XXextern NODE *new;
XXextern NODE *isnew;
XXextern NODE *msgcls;
XXextern NODE *msgclass;
XXextern int varcnt;
XX
XX/* instance variable numbers for the class 'Class' */
XX#define MESSAGES	0	/* list of messages */
XX#define IVARS		1	/* list of instance variable names */
XX#define CVARS		2	/* list of class variable names */
XX#define CVALS		3	/* list of class variable values */
XX#define SUPERCLASS	4	/* pointer to the superclass */
XX#define IVARCNT		5	/* number of class instance variables */
XX#define IVARTOTAL	6	/* total number of instance variables */
XX
XX/* number of instance variables for the class 'Class' */
XX#define CLASSSIZE	7
XX
XX/* forward declarations */
XXFORWARD NODE *xlgetivar();
XXFORWARD NODE *xlsetivar();
XXFORWARD NODE *xlivar();
XXFORWARD NODE *xlcvar();
XXFORWARD NODE *findmsg();
XXFORWARD NODE *findvar();
XXFORWARD NODE *defvars();
XXFORWARD NODE *makelist();
XX
XX/* xlclass - define a class */
XXNODE *xlclass(name,vcnt)
XX  char *name; int vcnt;
XX{
XX    NODE *sym,*cls;
XX
XX    /* create the class */
XX    sym = xlsenter(name);
XX    cls = sym->n_symvalue = newnode(OBJ);
XX    cls->n_obclass = class;
XX    cls->n_obdata = makelist(CLASSSIZE);
XX
XX    /* set the instance variable counts */
XX    if (vcnt > 0) {
XX	xlsetivar(cls,IVARCNT,newnode(INT))->n_int = vcnt;
XX	xlsetivar(cls,IVARTOTAL,newnode(INT))->n_int = vcnt;
XX    }
XX
XX    /* set the superclass to 'Object' */
XX    xlsetivar(cls,SUPERCLASS,object);
XX
XX    /* return the new class */
XX    return (cls);
XX}
XX
XX/* xlmfind - find the message binding for a message to an object */
XXNODE *xlmfind(obj,msym)
XX  NODE *obj,*msym;
XX{
XX    return (findmsg(obj->n_obclass,msym));
XX}
XX
XX/* xlxsend - send a message to an object */
XXNODE *xlxsend(obj,msg,args)
XX  NODE *obj,*msg,*args;
XX{
XX    NODE *oldstk,*oldenv,*oldnewenv,method,cptr,eargs,val,*isnewmsg;
XX
XX    /* save the old environment */
XX    oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&method,&cptr,&eargs,&val,NULL);
XX
XX    /* get the method for this message */
XX    method.n_ptr = cdr(msg);
XX
XX    /* make sure its a function or a subr */
XX    if (!subrp(method.n_ptr) && !consp(method.n_ptr))
XX	xlfail("bad method");
XX
XX    /* bind the symbols 'self' and 'msgclass' */
XX    xlbind(self,obj);
XX    xlbind(msgclass,msgcls);
XX
XX    /* evaluate the function call */
XX    eargs.n_ptr = xlevlist(args);
XX    if (subrp(method.n_ptr)) {
XX	xlfixbindings();
XX	val.n_ptr = (*method.n_ptr->n_subr)(eargs.n_ptr);
XX    }
XX    else {
XX
XX	/* bind the formal arguments */
XX	xlabind(car(method.n_ptr),eargs.n_ptr);
XX	xlfixbindings();
XX
XX	/* execute the code */
XX	cptr.n_ptr = cdr(method.n_ptr);
XX	while (cptr.n_ptr != NIL)
XX	    val.n_ptr = xlevarg(&cptr.n_ptr);
XX    }
XX
XX    /* restore the environment */
XX    xlunbind(oldenv); xlnewenv = oldnewenv;
XX
XX    /* after creating an object, send it the "isnew" message */
XX    if (car(msg) == new && val.n_ptr != NIL) {
XX	if ((isnewmsg = xlmfind(val.n_ptr,isnew)) == NIL)
XX	    xlfail("no method for the isnew message");
XX	val.n_ptr = xlxsend(val.n_ptr,isnewmsg,args);
XX    }
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the result value */
XX    return (val.n_ptr);
XX}
XX
XX/* xlsend - send a message to an object (message in arg list) */
XXNODE *xlsend(obj,args)
XX  NODE *obj,*args;
XX{
XX    NODE *msg;
XX
XX    /* find the message binding for this message */
XX    if ((msg = xlmfind(obj,xlevmatch(SYM,&args))) == NIL)
XX	xlfail("no method for this message");
XX
XX    /* send the message */
XX    return (xlxsend(obj,msg,args));
XX}
XX
XX/* xlobsym - find a class or instance variable for the current object */
XXNODE *xlobsym(sym)
XX  NODE *sym;
XX{
XX    NODE *obj;
XX
XX    if ((obj = self->n_symvalue) != NIL && objectp(obj))
XX	return (findvar(obj,sym));
XX    else
XX	return (NIL);
XX}
XX
XX/* mnew - create a new object instance */
XXLOCAL NODE *mnew()
XX{
XX    NODE *oldstk,obj,*cls;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&obj,NULL);
XX
XX    /* get the class */
XX    cls = self->n_symvalue;
XX
XX    /* generate a new object */
XX    obj.n_ptr = newnode(OBJ);
XX    obj.n_ptr->n_obclass = cls;
XX    obj.n_ptr->n_obdata = makelist(getivcnt(cls,IVARTOTAL));
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the new object */
XX    return (obj.n_ptr);
XX}
XX
XX/* misnew - initialize a new class */
XXLOCAL NODE *misnew(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,super,*obj;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&super,NULL);
XX
XX    /* get the superclass if there is one */
XX    if (args != NIL)
XX	super.n_ptr = xlmatch(OBJ,&args);
XX    else
XX	super.n_ptr = object;
XX    xllastarg(args);
XX
XX    /* get the object */
XX    obj = self->n_symvalue;
XX
XX    /* store the superclass */
XX    xlsetivar(obj,SUPERCLASS,super.n_ptr);
XX    xlsetivar(obj,IVARTOTAL,newnode(INT))->n_int =
XX        getivcnt(super.n_ptr,IVARTOTAL);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the new object */
XX    return (obj);
XX}
XX
XX/* xladdivar - enter an instance variable */
XXxladdivar(cls,var)
XX  NODE *cls; char *var;
XX{
XX    NODE *ivar,*lptr;
XX
XX    /* find the 'ivars' instance variable */
XX    ivar = xlivar(cls,IVARS);
XX
XX    /* add the instance variable */
XX    lptr = newnode(LIST);
XX    rplacd(lptr,car(ivar));
XX    rplaca(ivar,lptr);
XX    rplaca(lptr,xlsenter(var));
XX}
XX
XX/* entermsg - add a message to a class */
XXLOCAL NODE *entermsg(cls,msg)
XX  NODE *cls,*msg;
XX{
XX    NODE *ivar,*lptr,*mptr;
XX
XX    /* find the 'messages' instance variable */
XX    ivar = xlivar(cls,MESSAGES);
XX
XX    /* lookup the message */
XX    for (lptr = car(ivar); lptr != NIL; lptr = cdr(lptr))
XX	if (car(mptr = car(lptr)) == msg)
XX	    return (mptr);
XX
XX    /* allocate a new message entry if one wasn't found */
XX    lptr = newnode(LIST);
XX    rplacd(lptr,car(ivar));
XX    rplaca(ivar,lptr);
XX    rplaca(lptr,mptr = newnode(LIST));
XX    rplaca(mptr,msg);
XX
XX    /* return the symbol node */
XX    return (mptr);
XX}
XX
XX/* answer - define a method for answering a message */
XXLOCAL NODE *answer(args)
XX  NODE *args;
XX{
XX    NODE *oldstk,arg,msg,fargs,code;
XX    NODE *obj,*mptr,*fptr;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&arg,&msg,&fargs,&code,NULL);
XX
XX    /* initialize */
XX    arg.n_ptr = args;
XX
XX    /* message symbol, formal argument list and code */
XX    msg.n_ptr = xlmatch(SYM,&arg.n_ptr);
XX    fargs.n_ptr = xlmatch(LIST,&arg.n_ptr);
XX    code.n_ptr = xlmatch(LIST,&arg.n_ptr);
XX    xllastarg(arg.n_ptr);
XX
XX    /* get the object node */
XX    obj = self->n_symvalue;
XX
XX    /* make a new message list entry */
XX    mptr = entermsg(obj,msg.n_ptr);
XX
XX    /* setup the message node */
XX    rplacd(mptr,fptr = newnode(LIST));
XX    rplaca(fptr,fargs.n_ptr);
XX    rplacd(fptr,code.n_ptr);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the object */
XX    return (obj);
XX}
XX
XX/* mivars - define the list of instance variables */
XXLOCAL NODE *mivars(args)
XX  NODE *args;
XX{
XX    NODE *cls,*super;
XX    int scnt;
XX
XX    /* define the list of instance variables */
XX    cls = defvars(args,IVARS);
XX
XX    /* get the superclass instance variable count */
XX    if ((super = xlgetivar(cls,SUPERCLASS)) != NIL)
XX	scnt = getivcnt(super,IVARTOTAL);
XX    else
XX	scnt = 0;
XX
XX    /* save the number of instance variables */
XX    xlsetivar(cls,IVARCNT,newnode(INT))->n_int = varcnt;
XX    xlsetivar(cls,IVARTOTAL,newnode(INT))->n_int = scnt+varcnt;
XX
XX    /* return the class */
XX    return (cls);
XX}
XX
XX/* getivcnt - get the number of instance variables for a class */
XXLOCAL int getivcnt(cls,ivar)
XX  NODE *cls; int ivar;
XX{
XX    NODE *cnt;
XX
XX    if ((cnt = xlgetivar(cls,ivar)) != NIL)
XX	if (fixp(cnt))
XX	    return (cnt->n_int);
XX	else
XX	    xlfail("bad value for instance variable count");
XX    else
XX	return (0);
XX}
XX
XX/* mcvars - define the list of class variables */
XXLOCAL NODE *mcvars(args)
XX  NODE *args;
XX{
XX    NODE *cls;
XX
XX    /* define the list of class variables */
XX    cls = defvars(args,CVARS);
XX
XX    /* make a new list of values */
XX    xlsetivar(cls,CVALS,makelist(varcnt));
XX
XX    /* return the class */
XX    return (cls);
XX}
XX
XX/* defvars - define a class or instance variable list */
XXLOCAL NODE *defvars(args,varnum)
XX  NODE *args; int varnum;
XX{
XX    NODE *oldstk,vars,*vptr,*cls,*sym;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&vars,NULL);
XX
XX    /* get ivar list */
XX    vars.n_ptr = xlmatch(LIST,&args);
XX    xllastarg(args);
XX
XX    /* get the class node */
XX    cls = self->n_symvalue;
XX
XX    /* check each variable in the list */
XX    varcnt = 0;
XX    for (vptr = vars.n_ptr;
XX	 consp(vptr);
XX	 vptr = cdr(vptr)) {
XX
XX	/* make sure this is a valid symbol in the list */
XX	if ((sym = car(vptr)) == NIL || !symbolp(sym))
XX	    xlfail("bad variable list");
XX
XX	/* make sure its not already defined */
XX	if (checkvar(cls,sym))
XX	    xlfail("multiply defined variable");
XX
XX	/* count the variable */
XX	varcnt++;
XX    }
XX
XX    /* make sure the list ended properly */
XX    if (vptr != NIL)
XX	xlfail("bad variable list");
XX
XX    /* define the new variable list */
XX    xlsetivar(cls,varnum,vars.n_ptr);
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the class */
XX    return (cls);
XX}
XX
XX/* xladdmsg - add a message to a class */
XXxladdmsg(cls,msg,code)
XX  NODE *cls; char *msg; NODE *(*code)();
XX{
XX    NODE *mptr;
XX
XX    /* enter the message selector */
XX    mptr = entermsg(cls,xlsenter(msg));
XX
XX    /* store the method for this message */
XX    rplacd(mptr,newnode(SUBR));
XX    cdr(mptr)->n_subr = code;
XX}
XX
XX/* getclass - get the class of an object */
XXLOCAL NODE *getclass(args)
XX  NODE *args;
XX{
XX    /* make sure there aren't any arguments */
XX    xllastarg(args);
XX
XX    /* return the object's class */
XX    return (self->n_symvalue->n_obclass);
XX}
XX
XX/* obshow - show the instance variables of an object */
XXLOCAL NODE *obshow(args)
XX  NODE *args;
XX{
XX    NODE *fptr;
XX
XX    /* get the file pointer */
XX    fptr = (args ? xlmatch(FPTR,&args) : s_stdout->n_symvalue);
XX    xllastarg(args);
XX
XX    /* print the object's instance variables */
XX    xlprint(fptr,self->n_symvalue->n_obdata,TRUE);
XX    xlterpri(fptr);
XX
XX    /* return the object */
XX    return (self->n_symvalue);
XX}
XX
XX/* defisnew - default 'isnew' method */
XXLOCAL NODE *defisnew(args)
XX  NODE *args;
XX{
XX    /* make sure there aren't any arguments */
XX    xllastarg(args);
XX
XX    /* return the object */
XX    return (self->n_symvalue);
XX}
XX
XX/* sendsuper - send a message to an object's superclass */
XXLOCAL NODE *sendsuper(args)
XX  NODE *args;
XX{
XX    NODE *obj,*super,*msg;
XX
XX    /* get the object */
XX    obj = self->n_symvalue;
XX
XX    /* get the object's superclass */
XX    super = xlgetivar(obj->n_obclass,SUPERCLASS);
XX
XX    /* find the message binding for this message */
XX    if ((msg = findmsg(super,xlmatch(SYM,&args))) == NIL)
XX	xlfail("no method for this message");
XX
XX    /* send the message */
XX    return (xlxsend(obj,msg,args));
XX}
XX
XX/* findmsg - find the message binding given an object and a class */
XXLOCAL NODE *findmsg(cls,sym)
XX  NODE *cls,*sym;
XX{
XX    NODE *lptr,*msg;
XX
XX    /* start at the specified class */
XX    msgcls = cls;
XX
XX    /* look for the message in the class or superclasses */
XX    while (msgcls != NIL) {
XX
XX	/* lookup the message in this class */
XX	for (lptr = xlgetivar(msgcls,MESSAGES);
XX	     lptr != NIL;
XX	     lptr = cdr(lptr))
XX	    if ((msg = car(lptr)) != NIL && car(msg) == sym)
XX		return (msg);
XX
XX	/* look in class's superclass */
XX	msgcls = xlgetivar(msgcls,SUPERCLASS);
XX    }
XX
XX    /* message not found */
XX    return (NIL);
XX}
XX
XX/* findvar - find a class or instance variable */
XXLOCAL NODE *findvar(obj,sym)
XX  NODE *obj,*sym;
XX{
XX    NODE *cls,*lptr;
XX    int base,varnum;
XX    int found;
XX
XX    /* get the class of the object */
XX    cls = obj->n_obclass;
XX
XX    /* get the total number of instance variables */
XX    base = getivcnt(cls,IVARTOTAL);
XX
XX    /* find the variable */
XX    found = FALSE;
XX    for (; cls != NIL; cls = xlgetivar(cls,SUPERCLASS)) {
XX
XX	/* get the number of instance variables for this class */
XX	if ((base -= getivcnt(cls,IVARCNT)) < 0)
XX	    xlfail("error finding instance variable");
XX
XX	/* check for finding the class of the current message */
XX	if (!found && cls == msgclass->n_symvalue)
XX	    found = TRUE;
XX
XX	/* lookup the instance variable */
XX	varnum = 0;
XX	for (lptr = xlgetivar(cls,IVARS);
XX    	     lptr != NIL;
XX    	     lptr = cdr(lptr))
XX	    if (found && car(lptr) == sym)
XX		return (xlivar(obj,base + varnum));
XX	    else
XX		varnum++;
XX
XX	/* skip the class variables if the message class hasn't been found */
XX	if (!found)
XX	    continue;
XX
XX	/* lookup the class variable */
XX	varnum = 0;
XX	for (lptr = xlgetivar(cls,CVARS);
XX    	     lptr != NIL;
XX    	     lptr = cdr(lptr))
XX	    if (car(lptr) == sym)
XX		return (xlcvar(cls,varnum));
XX	    else
XX		varnum++;
XX    }
XX
XX    /* variable not found */
XX    return (NIL);
XX}
XX
XX/* checkvar - check for an existing class or instance variable */
XXLOCAL int checkvar(cls,sym)
XX  NODE *cls,*sym;
XX{
XX    NODE *lptr;
XX
XX    /* find the variable */
XX    for (; cls != NIL; cls = xlgetivar(cls,SUPERCLASS)) {
XX
XX	/* lookup the instance variable */
XX	for (lptr = xlgetivar(cls,IVARS);
XX    	     lptr != NIL;
XX    	     lptr = cdr(lptr))
XX	    if (car(lptr) == sym)
XX		return (TRUE);
XX
XX	/* lookup the class variable */
XX	for (lptr = xlgetivar(cls,CVARS);
XX    	     lptr != NIL;
XX    	     lptr = cdr(lptr))
XX	    if (car(lptr) == sym)
XX		return (TRUE);
XX    }
XX
XX    /* variable not found */
XX    return (FALSE);
XX}
XX
XX/* xlgetivar - get the value of an instance variable */
XXNODE *xlgetivar(obj,num)
XX  NODE *obj; int num;
XX{
XX    return (car(xlivar(obj,num)));
XX}
XX
XX/* xlsetivar - set the value of an instance variable */
XXNODE *xlsetivar(obj,num,val)
XX  NODE *obj; int num; NODE *val;
XX{
XX    rplaca(xlivar(obj,num),val);
XX    return (val);
XX}
XX
XX/* xlivar - get an instance variable */
XXNODE *xlivar(obj,num)
XX  NODE *obj; int num;
XX{
XX    NODE *ivar;
XX
XX    /* get the instance variable */
XX    for (ivar = obj->n_obdata; num > 0; num--)
XX	if (ivar != NIL)
XX	    ivar = cdr(ivar);
XX	else
XX	    xlfail("bad instance variable list");
XX
XX    /* return the instance variable */
XX    return (ivar);
XX}
XX
XX/* xlcvar - get a class variable */
XXNODE *xlcvar(cls,num)
XX  NODE *cls; int num;
XX{
XX    NODE *cvar;
XX
XX    /* get the class variable */
XX    for (cvar = xlgetivar(cls,CVALS); num > 0; num--)
XX	if (cvar != NIL)
XX	    cvar = cdr(cvar);
XX	else
XX	    xlfail("bad class variable list");
XX
XX    /* return the class variable */
XX    return (cvar);
XX}
XX
XX/* makelist - make a list of nodes */
XXLOCAL NODE *makelist(cnt)
XX  int cnt;
XX{
XX    NODE *oldstk,list,*lnew;
XX
XX    /* create a new stack frame */
XX    oldstk = xlsave(&list,NULL);
XX
XX    /* make the list */
XX    for (; cnt > 0; cnt--) {
XX	lnew = newnode(LIST);
XX	rplacd(lnew,list.n_ptr);
XX	list.n_ptr = lnew;
XX    }
XX
XX    /* restore the previous stack frame */
XX    xlstack = oldstk;
XX
XX    /* return the list */
XX    return (list.n_ptr);
XX}
XX
XX/* xloinit - object function initialization routine */
XXxloinit()
XX{
XX    /* don't confuse the garbage collector */
XX    class = object = NIL;
XX
XX    /* enter the object related symbols */
XX    new		= xlsenter("new");
XX    isnew	= xlsenter("isnew");
XX    self	= xlsenter("self");
XX    msgclass	= xlsenter("msgclass");
XX
XX    /* create the 'Class' object */
XX    class = xlclass("Class",CLASSSIZE);
XX    class->n_obclass = class;
XX
XX    /* create the 'Object' object */
XX    object = xlclass("Object",0);
XX
XX    /* finish initializing 'class' */
XX    xlsetivar(class,SUPERCLASS,object);
XX    xladdivar(class,"ivartotal");	/* ivar number 6 */
XX    xladdivar(class,"ivarcnt");		/* ivar number 5 */
XX    xladdivar(class,"superclass");	/* ivar number 4 */
XX    xladdivar(class,"cvals");		/* ivar number 3 */
XX    xladdivar(class,"cvars");		/* ivar number 2 */
XX    xladdivar(class,"ivars");		/* ivar number 1 */
XX    xladdivar(class,"messages");	/* ivar number 0 */
XX    xladdmsg(class,"new",mnew);
XX    xladdmsg(class,"answer",answer);
XX    xladdmsg(class,"ivars",mivars);
XX    xladdmsg(class,"cvars",mcvars);
XX    xladdmsg(class,"isnew",misnew);
XX
XX    /* finish initializing 'object' */
XX    xladdmsg(object,"class",getclass);
XX    xladdmsg(object,"show",obshow);
XX    xladdmsg(object,"isnew",defisnew);
XX    xladdmsg(object,"sendsuper",sendsuper);
XX}
SHAR_EOF
if test 16101 -ne "`wc -c xlobj.c`"
then
echo shar: error transmitting xlobj.c '(should have been 16101 characters)'
fi
#	End of shell archive
exit 0