xlisp v1.4 (5 of 5)
Chuck Wegrzyn
wegrzyn at encore.UUCP
Wed Mar 13 23:57:43 AEST 1985
# 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
More information about the Comp.sources.unix
mailing list