garym@cognos.UUCP (Gary Murphy) (02/27/90)
Posting-number: Volume 10, Issue 94
Submitted-by: garym@cognos.UUCP (Gary Murphy)
Archive-name: xlisp21/part07
#!/bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #!/bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# xljump.c
# xllist.c
# xlmath.c
# xlobj.c
# xlpp.c
# xlprin.c
# This archive created: Sun Feb 18 23:40:11 1990
# By: Gary Murphy ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'xljump.c'" '(3889 characters)'
if test -f 'xljump.c'
then
echo shar: over-writing existing file "'xljump.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xljump.c'
X/* xljump - execution context routines */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern CONTEXT *xlcontext,*xltarget;
Xextern LVAL xlvalue,xlenv,xlfenv,xldenv;
Xextern int xlmask;
X
X/* xlbegin - beginning of an execution context */
Xxlbegin(cptr,flags,expr)
X CONTEXT *cptr; int flags; LVAL expr;
X{
X cptr->c_flags = flags;
X cptr->c_expr = expr;
X cptr->c_xlstack = xlstack;
X cptr->c_xlenv = xlenv;
X cptr->c_xlfenv = xlfenv;
X cptr->c_xldenv = xldenv;
X cptr->c_xlcontext = xlcontext;
X cptr->c_xlargv = xlargv;
X cptr->c_xlargc = xlargc;
X cptr->c_xlfp = xlfp;
X cptr->c_xlsp = xlsp;
X xlcontext = cptr;
X}
X
X/* xlend - end of an execution context */
Xxlend(cptr)
X CONTEXT *cptr;
X{
X xlcontext = cptr->c_xlcontext;
X}
X
X/* xlgo - go to a label */
Xxlgo(label)
X LVAL label;
X{
X CONTEXT *cptr;
X LVAL *argv;
X int argc;
X
X /* find a tagbody context */
X for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X if (cptr->c_flags & CF_GO) {
X argc = cptr->c_xlargc;
X argv = cptr->c_xlargv;
X while (--argc >= 0)
X if (*argv++ == label) {
X cptr->c_xlargc = argc;
X cptr->c_xlargv = argv;
X xljump(cptr,CF_GO,NIL);
X }
X }
X xlfail("no target for GO");
X}
X
X/* xlreturn - return from a block */
Xxlreturn(name,val)
X LVAL name,val;
X{
X CONTEXT *cptr;
X
X /* find a block context */
X for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X if (cptr->c_flags & CF_RETURN && cptr->c_expr == name)
X xljump(cptr,CF_RETURN,val);
X xlfail("no target for RETURN");
X}
X
X/* xlthrow - throw to a catch */
Xxlthrow(tag,val)
X LVAL tag,val;
X{
X CONTEXT *cptr;
X
X /* find a catch context */
X for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X if ((cptr->c_flags & CF_THROW) && cptr->c_expr == tag)
X xljump(cptr,CF_THROW,val);
X xlfail("no target for THROW");
X}
X
X/* xlsignal - signal an error */
Xxlsignal(emsg,arg)
X char *emsg; LVAL arg;
X{
X CONTEXT *cptr;
X
X /* find an error catcher */
X for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X if (cptr->c_flags & CF_ERROR) {
X if (cptr->c_expr && emsg)
X xlerrprint("error",NULL,emsg,arg);
X xljump(cptr,CF_ERROR,NIL);
X }
X}
X
X/* xltoplevel - go back to the top level */
Xxltoplevel()
X{
X stdputstr("[ back to top level ]\n");
X findandjump(CF_TOPLEVEL,"no top level");
X}
X
X/* xlbrklevel - go back to the previous break level */
Xxlbrklevel()
X{
X findandjump(CF_BRKLEVEL,"no previous break level");
X}
X
X/* xlcleanup - clean-up after an error */
Xxlcleanup()
X{
X stdputstr("[ back to previous break level ]\n");
X findandjump(CF_CLEANUP,"not in a break loop");
X}
X
X/* xlcontinue - continue from an error */
Xxlcontinue()
X{
X findandjump(CF_CONTINUE,"not in a break loop");
X}
X
X/* xljump - jump to a saved execution context */
Xxljump(target,mask,val)
X CONTEXT *target; int mask; LVAL val;
X{
X /* unwind the execution stack */
X for (; xlcontext != target; xlcontext = xlcontext->c_xlcontext)
X
X /* check for an UNWIND-PROTECT */
X if ((xlcontext->c_flags & CF_UNWIND)) {
X xltarget = target;
X xlmask = mask;
X break;
X }
X
X /* restore the state */
X xlstack = xlcontext->c_xlstack;
X xlenv = xlcontext->c_xlenv;
X xlfenv = xlcontext->c_xlfenv;
X xlunbind(xlcontext->c_xldenv);
X xlargv = xlcontext->c_xlargv;
X xlargc = xlcontext->c_xlargc;
X xlfp = xlcontext->c_xlfp;
X xlsp = xlcontext->c_xlsp;
X xlvalue = val;
X
X /* call the handler */
X longjmp(xlcontext->c_jmpbuf,mask);
X}
X
X/* findandjump - find a target context frame and jump to it */
XLOCAL findandjump(mask,error)
X int mask; char *error;
X{
X CONTEXT *cptr;
X
X /* find a block context */
X for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X if (cptr->c_flags & mask)
X xljump(cptr,mask,NIL);
X xlabort(error);
X}
X
SHAR_EOF
if test 3889 -ne "`wc -c 'xljump.c'`"
then
echo shar: error transmitting "'xljump.c'" '(should have been 3889 characters)'
fi
echo shar: extracting "'xllist.c'" '(18761 characters)'
if test -f 'xllist.c'
then
echo shar: over-writing existing file "'xllist.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xllist.c'
X/* xllist.c - xlisp built-in list functions */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* forward declarations */
XFORWARD LVAL cxr();
XFORWARD LVAL nth(),assoc();
XFORWARD LVAL subst(),sublis(),map();
X
X/* xcar - take the car of a cons cell */
XLVAL xcar()
X{
X LVAL list;
X list = xlgalist();
X xllastarg();
X return (list ? car(list) : NIL);
X}
X
X/* xcdr - take the cdr of a cons cell */
XLVAL xcdr()
X{
X LVAL list;
X list = xlgalist();
X xllastarg();
X return (list ? cdr(list) : NIL);
X}
X
X/* cxxr functions */
XLVAL xcaar() { return (cxr("aa")); }
XLVAL xcadr() { return (cxr("da")); }
XLVAL xcdar() { return (cxr("ad")); }
XLVAL xcddr() { return (cxr("dd")); }
X
X/* cxxxr functions */
XLVAL xcaaar() { return (cxr("aaa")); }
XLVAL xcaadr() { return (cxr("daa")); }
XLVAL xcadar() { return (cxr("ada")); }
XLVAL xcaddr() { return (cxr("dda")); }
XLVAL xcdaar() { return (cxr("aad")); }
XLVAL xcdadr() { return (cxr("dad")); }
XLVAL xcddar() { return (cxr("add")); }
XLVAL xcdddr() { return (cxr("ddd")); }
X
X/* cxxxxr functions */
XLVAL xcaaaar() { return (cxr("aaaa")); }
XLVAL xcaaadr() { return (cxr("daaa")); }
XLVAL xcaadar() { return (cxr("adaa")); }
XLVAL xcaaddr() { return (cxr("ddaa")); }
XLVAL xcadaar() { return (cxr("aada")); }
XLVAL xcadadr() { return (cxr("dada")); }
XLVAL xcaddar() { return (cxr("adda")); }
XLVAL xcadddr() { return (cxr("ddda")); }
XLVAL xcdaaar() { return (cxr("aaad")); }
XLVAL xcdaadr() { return (cxr("daad")); }
XLVAL xcdadar() { return (cxr("adad")); }
XLVAL xcdaddr() { return (cxr("ddad")); }
XLVAL xcddaar() { return (cxr("aadd")); }
XLVAL xcddadr() { return (cxr("dadd")); }
XLVAL xcdddar() { return (cxr("addd")); }
XLVAL xcddddr() { return (cxr("dddd")); }
X
X/* cxr - common car/cdr routine */
XLOCAL LVAL cxr(adstr)
X char *adstr;
X{
X LVAL list;
X
X /* get the list */
X list = xlgalist();
X xllastarg();
X
X /* perform the car/cdr operations */
X while (*adstr && consp(list))
X list = (*adstr++ == 'a' ? car(list) : cdr(list));
X
X /* make sure the operation succeeded */
X if (*adstr && list)
X xlfail("bad argument");
X
X /* return the result */
X return (list);
X}
X
X/* xcons - construct a new list cell */
XLVAL xcons()
X{
X LVAL arg1,arg2;
X
X /* get the two arguments */
X arg1 = xlgetarg();
X arg2 = xlgetarg();
X xllastarg();
X
X /* construct a new list element */
X return (cons(arg1,arg2));
X}
X
X/* xlist - built a list of the arguments */
XLVAL xlist()
X{
X LVAL last,next,val;
X
X /* protect some pointers */
X xlsave1(val);
X
X /* add each argument to the list */
X for (val = NIL; moreargs(); ) {
X
X /* append this argument to the end of the list */
X next = consa(nextarg());
X if (val) rplacd(last,next);
X else val = next;
X last = next;
X }
X
X /* restore the stack */
X xlpop();
X
X /* return the list */
X return (val);
X}
X
X/* xappend - built-in function append */
XLVAL xappend()
X{
X LVAL list,last,next,val;
X
X /* protect some pointers */
X xlsave1(val);
X
X /* initialize */
X val = NIL;
X
X /* append each argument */
X if (moreargs()) {
X while (xlargc > 1) {
X
X /* append each element of this list to the result list */
X for (list = nextarg(); consp(list); list = cdr(list)) {
X next = consa(car(list));
X if (val) rplacd(last,next);
X else val = next;
X last = next;
X }
X }
X
X /* handle the last argument */
X if (val) rplacd(last,nextarg());
X else val = nextarg();
X }
X
X /* restore the stack */
X xlpop();
X
X /* return the list */
X return (val);
X}
X
X/* xreverse - built-in function reverse */
XLVAL xreverse()
X{
X LVAL list,val;
X
X /* protect some pointers */
X xlsave1(val);
X
X /* get the list to reverse */
X list = xlgalist();
X xllastarg();
X
X /* append each element to the head of the result list */
X for (val = NIL; consp(list); list = cdr(list))
X val = cons(car(list),val);
X
X /* restore the stack */
X xlpop();
X
X /* return the list */
X return (val);
X}
X
X/* xlast - return the last cons of a list */
XLVAL xlast()
X{
X LVAL list;
X
X /* get the list */
X list = xlgalist();
X xllastarg();
X
X /* find the last cons */
X while (consp(list) && cdr(list))
X list = cdr(list);
X
X /* return the last element */
X return (list);
X}
X
X/* xmember - built-in function 'member' */
XLVAL xmember()
X{
X LVAL x,list,fcn,val;
X int tresult;
X
X /* protect some pointers */
X xlsave1(fcn);
X
X /* get the expression to look for and the list */
X x = xlgetarg();
X list = xlgalist();
X xltest(&fcn,&tresult);
X
X /* look for the expression */
X for (val = NIL; consp(list); list = cdr(list))
X if (dotest2(x,car(list),fcn) == tresult) {
X val = list;
X break;
X }
X
X /* restore the stack */
X xlpop();
X
X /* return the result */
X return (val);
X}
X
X/* xassoc - built-in function 'assoc' */
XLVAL xassoc()
X{
X LVAL x,alist,fcn,pair,val;
X int tresult;
X
X /* protect some pointers */
X xlsave1(fcn);
X
X /* get the expression to look for and the association list */
X x = xlgetarg();
X alist = xlgalist();
X xltest(&fcn,&tresult);
X
X /* look for the expression */
X for (val = NIL; consp(alist); alist = cdr(alist))
X if ((pair = car(alist)) && consp(pair))
X if (dotest2(x,car(pair),fcn) == tresult) {
X val = pair;
X break;
X }
X
X /* restore the stack */
X xlpop();
X
X /* return result */
X return (val);
X}
X
X/* xsubst - substitute one expression for another */
XLVAL xsubst()
X{
X LVAL to,from,expr,fcn,val;
X int tresult;
X
X /* protect some pointers */
X xlsave1(fcn);
X
X /* get the to value, the from value and the expression */
X to = xlgetarg();
X from = xlgetarg();
X expr = xlgetarg();
X xltest(&fcn,&tresult);
X
X /* do the substitution */
X val = subst(to,from,expr,fcn,tresult);
X
X /* restore the stack */
X xlpop();
X
X /* return the result */
X return (val);
X}
X
X/* subst - substitute one expression for another */
XLOCAL LVAL subst(to,from,expr,fcn,tresult)
X LVAL to,from,expr,fcn; int tresult;
X{
X LVAL carval,cdrval;
X
X if (dotest2(expr,from,fcn) == tresult)
X return (to);
X else if (consp(expr)) {
X xlsave1(carval);
X carval = subst(to,from,car(expr),fcn,tresult);
X cdrval = subst(to,from,cdr(expr),fcn,tresult);
X xlpop();
X return (cons(carval,cdrval));
X }
X else
X return (expr);
X}
X
X/* xsublis - substitute using an association list */
XLVAL xsublis()
X{
X LVAL alist,expr,fcn,val;
X int tresult;
X
X /* protect some pointers */
X xlsave1(fcn);
X
X /* get the assocation list and the expression */
X alist = xlgalist();
X expr = xlgetarg();
X xltest(&fcn,&tresult);
X
X /* do the substitution */
X val = sublis(alist,expr,fcn,tresult);
X
X /* restore the stack */
X xlpop();
X
X /* return the result */
X return (val);
X}
X
X/* sublis - substitute using an association list */
XLOCAL LVAL sublis(alist,expr,fcn,tresult)
X LVAL alist,expr,fcn; int tresult;
X{
X LVAL carval,cdrval,pair;
X
X if (pair = assoc(expr,alist,fcn,tresult))
X return (cdr(pair));
X else if (consp(expr)) {
X xlsave1(carval);
X carval = sublis(alist,car(expr),fcn,tresult);
X cdrval = sublis(alist,cdr(expr),fcn,tresult);
X xlpop();
X return (cons(carval,cdrval));
X }
X else
X return (expr);
X}
X
X/* assoc - find a pair in an association list */
XLOCAL LVAL assoc(expr,alist,fcn,tresult)
X LVAL expr,alist,fcn; int tresult;
X{
X LVAL pair;
X
X for (; consp(alist); alist = cdr(alist))
X if ((pair = car(alist)) && consp(pair))
X if (dotest2(expr,car(pair),fcn) == tresult)
X return (pair);
X return (NIL);
X}
X
X/* xremove - built-in function 'remove' */
XLVAL xremove()
X{
X LVAL x,list,fcn,val,last,next;
X int tresult;
X
X /* protect some pointers */
X xlstkcheck(2);
X xlsave(fcn);
X xlsave(val);
X
X /* get the expression to remove and the list */
X x = xlgetarg();
X list = xlgalist();
X xltest(&fcn,&tresult);
X
X /* remove matches */
X for (; consp(list); list = cdr(list))
X
X /* check to see if this element should be deleted */
X if (dotest2(x,car(list),fcn) != tresult) {
X next = consa(car(list));
X if (val) rplacd(last,next);
X else val = next;
X last = next;
X }
X
X /* restore the stack */
X xlpopn(2);
X
X /* return the updated list */
X return (val);
X}
X
X/* xremif - built-in function 'remove-if' */
XLVAL xremif()
X{
X LVAL remif();
X return (remif(TRUE));
X}
X
X/* xremifnot - built-in function 'remove-if-not' */
XLVAL xremifnot()
X{
X LVAL remif();
X return (remif(FALSE));
X}
X
X/* remif - common code for 'remove-if' and 'remove-if-not' */
XLOCAL LVAL remif(tresult)
X int tresult;
X{
X LVAL list,fcn,val,last,next;
X
X /* protect some pointers */
X xlstkcheck(2);
X xlsave(fcn);
X xlsave(val);
X
X /* get the expression to remove and the list */
X fcn = xlgetarg();
X list = xlgalist();
X xllastarg();
X
X /* remove matches */
X for (; consp(list); list = cdr(list))
X
X /* check to see if this element should be deleted */
X if (dotest1(car(list),fcn) != tresult) {
X next = consa(car(list));
X if (val) rplacd(last,next);
X else val = next;
X last = next;
X }
X
X /* restore the stack */
X xlpopn(2);
X
X /* return the updated list */
X return (val);
X}
X
X/* dotest1 - call a test function with one argument */
Xint dotest1(arg,fun)
X LVAL arg,fun;
X{
X LVAL *newfp;
X
X /* create the new call frame */
X newfp = xlsp;
X pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X pusharg(fun);
X pusharg(cvfixnum((FIXTYPE)1));
X pusharg(arg);
X xlfp = newfp;
X
X /* return the result of applying the test function */
X return (xlapply(1) != NIL);
X
X}
X
X/* dotest2 - call a test function with two arguments */
Xint dotest2(arg1,arg2,fun)
X LVAL arg1,arg2,fun;
X{
X LVAL *newfp;
X
X /* create the new call frame */
X newfp = xlsp;
X pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X pusharg(fun);
X pusharg(cvfixnum((FIXTYPE)2));
X pusharg(arg1);
X pusharg(arg2);
X xlfp = newfp;
X
X /* return the result of applying the test function */
X return (xlapply(2) != NIL);
X
X}
X
X/* xnth - return the nth element of a list */
XLVAL xnth()
X{
X return (nth(TRUE));
X}
X
X/* xnthcdr - return the nth cdr of a list */
XLVAL xnthcdr()
X{
X return (nth(FALSE));
X}
X
X/* nth - internal nth function */
XLOCAL LVAL nth(carflag)
X int carflag;
X{
X LVAL list,num;
X FIXTYPE n;
X
X /* get n and the list */
X num = xlgafixnum();
X list = xlgacons();
X xllastarg();
X
X /* make sure the number isn't negative */
X if ((n = getfixnum(num)) < 0)
X xlfail("bad argument");
X
X /* find the nth element */
X while (consp(list) && --n >= 0)
X list = cdr(list);
X
X /* return the list beginning at the nth element */
X return (carflag && consp(list) ? car(list) : list);
X}
X
X/* xlength - return the length of a list or string */
XLVAL xlength()
X{
X FIXTYPE n;
X LVAL arg;
X
X /* get the list or string */
X arg = xlgetarg();
X xllastarg();
X
X /* find the length of a list */
X if (listp(arg))
X for (n = 0; consp(arg); n++)
X arg = cdr(arg);
X
X /* find the length of a string */
X else if (stringp(arg))
X n = (FIXTYPE)getslength(arg)-1;
X
X /* find the length of a vector */
X else if (vectorp(arg))
X n = (FIXTYPE)getsize(arg);
X
X /* otherwise, bad argument type */
X else
X xlerror("bad argument type",arg);
X
X /* return the length */
X return (cvfixnum(n));
X}
X
X/* xmapc - built-in function 'mapc' */
XLVAL xmapc()
X{
X return (map(TRUE,FALSE));
X}
X
X/* xmapcar - built-in function 'mapcar' */
XLVAL xmapcar()
X{
X return (map(TRUE,TRUE));
X}
X
X/* xmapl - built-in function 'mapl' */
XLVAL xmapl()
X{
X return (map(FALSE,FALSE));
X}
X
X/* xmaplist - built-in function 'maplist' */
XLVAL xmaplist()
X{
X return (map(FALSE,TRUE));
X}
X
X/* map - internal mapping function */
XLOCAL LVAL map(carflag,valflag)
X int carflag,valflag;
X{
X LVAL *newfp,fun,lists,val,last,p,x,y;
X int argc;
X
X /* protect some pointers */
X xlstkcheck(3);
X xlsave(fun);
X xlsave(lists);
X xlsave(val);
X
X /* get the function to apply and the first list */
X fun = xlgetarg();
X lists = xlgalist();
X
X /* initialize the result list */
X val = (valflag ? NIL : lists);
X
X /* build a list of argument lists */
X for (lists = last = consa(lists); moreargs(); last = cdr(last))
X rplacd(last,cons(xlgalist(),NIL));
X
X /* loop through each of the argument lists */
X for (;;) {
X
X /* build an argument list from the sublists */
X newfp = xlsp;
X pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X pusharg(fun);
X pusharg(NIL);
X argc = 0;
X for (x = lists; x && (y = car(x)) && consp(y); x = cdr(x)) {
X pusharg(carflag ? car(y) : y);
X rplaca(x,cdr(y));
X ++argc;
X }
X
X /* quit if any of the lists were empty */
X if (x) {
X xlsp = newfp;
X break;
X }
X
X /* apply the function to the arguments */
X newfp[2] = cvfixnum((FIXTYPE)argc);
X xlfp = newfp;
X if (valflag) {
X p = consa(xlapply(argc));
X if (val) rplacd(last,p);
X else val = p;
X last = p;
X }
X else
X xlapply(argc);
X }
X
X /* restore the stack */
X xlpopn(3);
X
X /* return the last test expression value */
X return (val);
X}
X
X/* xrplca - replace the car of a list node */
XLVAL xrplca()
X{
X LVAL list,newcar;
X
X /* get the list and the new car */
X list = xlgacons();
X newcar = xlgetarg();
X xllastarg();
X
X /* replace the car */
X rplaca(list,newcar);
X
X /* return the list node that was modified */
X return (list);
X}
X
X/* xrplcd - replace the cdr of a list node */
XLVAL xrplcd()
X{
X LVAL list,newcdr;
X
X /* get the list and the new cdr */
X list = xlgacons();
X newcdr = xlgetarg();
X xllastarg();
X
X /* replace the cdr */
X rplacd(list,newcdr);
X
X /* return the list node that was modified */
X return (list);
X}
X
X/* xnconc - destructively append lists */
XLVAL xnconc()
X{
X LVAL next,last,val;
X
X /* initialize */
X val = NIL;
X
X /* concatenate each argument */
X if (moreargs()) {
X while (xlargc > 1) {
X
X /* ignore everything except lists */
X if ((next = nextarg()) && consp(next)) {
X
X /* concatenate this list to the result list */
X if (val) rplacd(last,next);
X else val = next;
X
X /* find the end of the list */
X while (consp(cdr(next)))
X next = cdr(next);
X last = next;
X }
X }
X
X /* handle the last argument */
X if (val) rplacd(last,nextarg());
X else val = nextarg();
X }
X
X /* return the list */
X return (val);
X}
X
X/* xdelete - built-in function 'delete' */
XLVAL xdelete()
X{
X LVAL x,list,fcn,last,val;
X int tresult;
X
X /* protect some pointers */
X xlsave1(fcn);
X
X /* get the expression to delete and the list */
X x = xlgetarg();
X list = xlgalist();
X xltest(&fcn,&tresult);
X
X /* delete leading matches */
X while (consp(list)) {
X if (dotest2(x,car(list),fcn) != tresult)
X break;
X list = cdr(list);
X }
X val = last = list;
X
X /* delete embedded matches */
X if (consp(list)) {
X
X /* skip the first non-matching element */
X list = cdr(list);
X
X /* look for embedded matches */
X while (consp(list)) {
X
X /* check to see if this element should be deleted */
X if (dotest2(x,car(list),fcn) == tresult)
X rplacd(last,cdr(list));
X else
X last = list;
X
X /* move to the next element */
X list = cdr(list);
X }
X }
X
X /* restore the stack */
X xlpop();
X
X /* return the updated list */
X return (val);
X}
X
X/* xdelif - built-in function 'delete-if' */
XLVAL xdelif()
X{
X LVAL delif();
X return (delif(TRUE));
X}
X
X/* xdelifnot - built-in function 'delete-if-not' */
XLVAL xdelifnot()
X{
X LVAL delif();
X return (delif(FALSE));
X}
X
X/* delif - common routine for 'delete-if' and 'delete-if-not' */
XLOCAL LVAL delif(tresult)
X int tresult;
X{
X LVAL list,fcn,last,val;
X
X /* protect some pointers */
X xlsave1(fcn);
X
X /* get the expression to delete and the list */
X fcn = xlgetarg();
X list = xlgalist();
X xllastarg();
X
X /* delete leading matches */
X while (consp(list)) {
X if (dotest1(car(list),fcn) != tresult)
X break;
X list = cdr(list);
X }
X val = last = list;
X
X /* delete embedded matches */
X if (consp(list)) {
X
X /* skip the first non-matching element */
X list = cdr(list);
X
X /* look for embedded matches */
X while (consp(list)) {
X
X /* check to see if this element should be deleted */
X if (dotest1(car(list),fcn) == tresult)
X rplacd(last,cdr(list));
X else
X last = list;
X
X /* move to the next element */
X list = cdr(list);
X }
X }
X
X /* restore the stack */
X xlpop();
X
X /* return the updated list */
X return (val);
X}
X
X/* xsort - built-in function 'sort' */
XLVAL xsort()
X{
X LVAL sortlist();
X LVAL list,fcn;
X
X /* protect some pointers */
X xlstkcheck(2);
X xlsave(list);
X xlsave(fcn);
X
X /* get the list to sort and the comparison function */
X list = xlgalist();
X fcn = xlgetarg();
X xllastarg();
X
X /* sort the list */
X list = sortlist(list,fcn);
X
X /* restore the stack and return the sorted list */
X xlpopn(2);
X return (list);
X}
X
X/*
X This sorting algorithm is based on a Modula-2 sort written by
X Richie Bielak and published in the February 1988 issue of
X "Computer Language" magazine in a letter to the editor.
X*/
X
X/* sortlist - sort a list using quicksort */
XLOCAL LVAL sortlist(list,fcn)
X LVAL list,fcn;
X{
X LVAL gluelists();
X LVAL smaller,pivot,larger;
X
X /* protect some pointers */
X xlstkcheck(3);
X xlsave(smaller);
X xlsave(pivot);
X xlsave(larger);
X
X /* lists with zero or one element are already sorted */
X if (consp(list) && consp(cdr(list))) {
X pivot = list; list = cdr(list);
X splitlist(pivot,list,&smaller,&larger,fcn);
X smaller = sortlist(smaller,fcn);
X larger = sortlist(larger,fcn);
X list = gluelists(smaller,pivot,larger);
X }
X
X /* cleanup the stack and return the sorted list */
X xlpopn(3);
X return (list);
X}
X
X/* splitlist - split the list around the pivot */
XLOCAL splitlist(pivot,list,psmaller,plarger,fcn)
X LVAL pivot,list,*psmaller,*plarger,fcn;
X{
X LVAL next;
X
X /* initialize the result lists */
X *psmaller = *plarger = NIL;
X
X /* split the list */
X for (; consp(list); list = next) {
X next = cdr(list);
X if (dotest2(car(list),car(pivot),fcn)) {
X rplacd(list,*psmaller);
X *psmaller = list;
X }
X else {
X rplacd(list,*plarger);
X *plarger = list;
X }
X }
X}
X
X/* gluelists - glue the smaller and larger lists with the pivot */
XLOCAL LVAL gluelists(smaller,pivot,larger)
X LVAL smaller,pivot,larger;
X{
X LVAL last;
X
X /* larger always goes after the pivot */
X rplacd(pivot,larger);
X
X /* if the smaller list is empty, we're done */
X if (null(smaller))
X return (pivot);
X
X /* append the smaller to the front of the resulting list */
X for (last = smaller; consp(cdr(last)); last = cdr(last))
X ;
X rplacd(last,pivot);
X return (smaller);
X}
SHAR_EOF
if test 18761 -ne "`wc -c 'xllist.c'`"
then
echo shar: error transmitting "'xllist.c'" '(should have been 18761 characters)'
fi
echo shar: extracting "'xlmath.c'" '(9993 characters)'
if test -f 'xlmath.c'
then
echo shar: over-writing existing file "'xlmath.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlmath.c'
X/* xlmath - xlisp built-in arithmetic functions */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X#include <math.h>
X
X/* external variables */
Xextern LVAL true;
X
X/* forward declarations */
XFORWARD LVAL unary();
XFORWARD LVAL binary();
XFORWARD LVAL predicate();
XFORWARD LVAL compare();
X
X/* binary functions */
XLVAL xadd() { return (binary('+')); } /* + */
XLVAL xsub() { return (binary('-')); } /* - */
XLVAL xmul() { return (binary('*')); } /* * */
XLVAL xdiv() { return (binary('/')); } /* / */
XLVAL xrem() { return (binary('%')); } /* rem */
XLVAL xmin() { return (binary('m')); } /* min */
XLVAL xmax() { return (binary('M')); } /* max */
XLVAL xexpt() { return (binary('E')); } /* expt */
XLVAL xlogand() { return (binary('&')); } /* logand */
XLVAL xlogior() { return (binary('|')); } /* logior */
XLVAL xlogxor() { return (binary('^')); } /* logxor */
X
X/* xgcd - greatest common divisor */
XLVAL xgcd()
X{
X FIXTYPE m,n,r;
X LVAL arg;
X
X if (!moreargs()) /* check for identity case */
X return (cvfixnum((FIXTYPE)0));
X arg = xlgafixnum();
X n = getfixnum(arg);
X if (n < (FIXTYPE)0) n = -n; /* absolute value */
X while (moreargs()) {
X arg = xlgafixnum();
X m = getfixnum(arg);
X if (m < (FIXTYPE)0) m = -m; /* absolute value */
X for (;;) { /* euclid's algorithm */
X r = m % n;
X if (r == (FIXTYPE)0)
X break;
X m = n;
X n = r;
X }
X }
X return (cvfixnum(n));
X}
X
X/* binary - handle binary operations */
XLOCAL LVAL binary(fcn)
X int fcn;
X{
X FIXTYPE ival,iarg;
X FLOTYPE fval,farg;
X LVAL arg;
X int mode;
X
X /* get the first argument */
X arg = xlgetarg();
X
X /* set the type of the first argument */
X if (fixp(arg)) {
X ival = getfixnum(arg);
X mode = 'I';
X }
X else if (floatp(arg)) {
X fval = getflonum(arg);
X mode = 'F';
X }
X else
X xlerror("bad argument type",arg);
X
X /* treat a single argument as a special case */
X if (!moreargs()) {
X switch (fcn) {
X case '-':
X switch (mode) {
X case 'I':
X ival = -ival;
X break;
X case 'F':
X fval = -fval;
X break;
X }
X break;
X case '/':
X switch (mode) {
X case 'I':
X checkizero(ival);
X ival = 1 / ival;
X break;
X case 'F':
X checkfzero(fval);
X fval = 1.0 / fval;
X break;
X }
X }
X }
X
X /* handle each remaining argument */
X while (moreargs()) {
X
X /* get the next argument */
X arg = xlgetarg();
X
X /* check its type */
X if (fixp(arg)) {
X switch (mode) {
X case 'I':
X iarg = getfixnum(arg);
X break;
X case 'F':
X farg = (FLOTYPE)getfixnum(arg);
X break;
X }
X }
X else if (floatp(arg)) {
X switch (mode) {
X case 'I':
X fval = (FLOTYPE)ival;
X farg = getflonum(arg);
X mode = 'F';
X break;
X case 'F':
X farg = getflonum(arg);
X break;
X }
X }
X else
X xlerror("bad argument type",arg);
X
X /* accumulate the result value */
X switch (mode) {
X case 'I':
X switch (fcn) {
X case '+': ival += iarg; break;
X case '-': ival -= iarg; break;
X case '*': ival *= iarg; break;
X case '/': checkizero(iarg); ival /= iarg; break;
X case '%': checkizero(iarg); ival %= iarg; break;
X case 'M': if (iarg > ival) ival = iarg; break;
X case 'm': if (iarg < ival) ival = iarg; break;
X case '&': ival &= iarg; break;
X case '|': ival |= iarg; break;
X case '^': ival ^= iarg; break;
X default: badiop();
X }
X break;
X case 'F':
X switch (fcn) {
X case '+': fval += farg; break;
X case '-': fval -= farg; break;
X case '*': fval *= farg; break;
X case '/': checkfzero(farg); fval /= farg; break;
X case 'M': if (farg > fval) fval = farg; break;
X case 'm': if (farg < fval) fval = farg; break;
X case 'E': fval = pow(fval,farg); break;
X default: badfop();
X }
X break;
X }
X }
X
X /* return the result */
X switch (mode) {
X case 'I': return (cvfixnum(ival));
X case 'F': return (cvflonum(fval));
X }
X}
X
X/* checkizero - check for integer division by zero */
Xcheckizero(iarg)
X FIXTYPE iarg;
X{
X if (iarg == 0)
X xlfail("division by zero");
X}
X
X/* checkfzero - check for floating point division by zero */
Xcheckfzero(farg)
X FLOTYPE farg;
X{
X if (farg == 0.0)
X xlfail("division by zero");
X}
X
X/* checkfneg - check for square root of a negative number */
Xcheckfneg(farg)
X FLOTYPE farg;
X{
X if (farg < 0.0)
X xlfail("square root of a negative number");
X}
X
X/* unary functions */
XLVAL xlognot() { return (unary('~')); } /* lognot */
XLVAL xabs() { return (unary('A')); } /* abs */
XLVAL xadd1() { return (unary('+')); } /* 1+ */
XLVAL xsub1() { return (unary('-')); } /* 1- */
XLVAL xsin() { return (unary('S')); } /* sin */
XLVAL xcos() { return (unary('C')); } /* cos */
XLVAL xtan() { return (unary('T')); } /* tan */
XLVAL xasin() { return (unary('s')); } /* asin */
XLVAL xacos() { return (unary('c')); } /* acos */
XLVAL xatan() { return (unary('t')); } /* atan */
XLVAL xexp() { return (unary('E')); } /* exp */
XLVAL xsqrt() { return (unary('R')); } /* sqrt */
XLVAL xfix() { return (unary('I')); } /* truncate */
XLVAL xfloat() { return (unary('F')); } /* float */
XLVAL xrand() { return (unary('?')); } /* random */
X
X/* unary - handle unary operations */
XLOCAL LVAL unary(fcn)
X int fcn;
X{
X FLOTYPE fval;
X FIXTYPE ival;
X LVAL arg;
X
X /* get the argument */
X arg = xlgetarg();
X xllastarg();
X
X /* check its type */
X if (fixp(arg)) {
X ival = getfixnum(arg);
X switch (fcn) {
X case '~': ival = ~ival; break;
X case 'A': ival = (ival < 0 ? -ival : ival); break;
X case '+': ival++; break;
X case '-': ival--; break;
X case 'I': break;
X case 'F': return (cvflonum((FLOTYPE)ival));
X case '?': ival = (FIXTYPE)osrand((int)ival); break;
X default: badiop();
X }
X return (cvfixnum(ival));
X }
X else if (floatp(arg)) {
X fval = getflonum(arg);
X switch (fcn) {
X case 'A': fval = (fval < 0.0 ? -fval : fval); break;
X case '+': fval += 1.0; break;
X case '-': fval -= 1.0; break;
X case 'S': fval = sin(fval); break;
X case 'C': fval = cos(fval); break;
X case 'T': fval = tan(fval); break;
X case 's': fval = asin(fval); break;
X case 'c': fval = acos(fval); break;
X case 't': fval = atan(fval); break;
X case 'E': fval = exp(fval); break;
X case 'R': checkfneg(fval); fval = sqrt(fval); break;
X case 'I': return (cvfixnum((FIXTYPE)fval));
X case 'F': break;
X default: badfop();
X }
X return (cvflonum(fval));
X }
X else
X xlerror("bad argument type",arg);
X}
X
X/* unary predicates */
XLVAL xminusp() { return (predicate('-')); } /* minusp */
XLVAL xzerop() { return (predicate('Z')); } /* zerop */
XLVAL xplusp() { return (predicate('+')); } /* plusp */
XLVAL xevenp() { return (predicate('E')); } /* evenp */
XLVAL xoddp() { return (predicate('O')); } /* oddp */
X
X/* predicate - handle a predicate function */
XLOCAL LVAL predicate(fcn)
X int fcn;
X{
X FLOTYPE fval;
X FIXTYPE ival;
X LVAL arg;
X
X /* get the argument */
X arg = xlgetarg();
X xllastarg();
X
X /* check the argument type */
X if (fixp(arg)) {
X ival = getfixnum(arg);
X switch (fcn) {
X case '-': ival = (ival < 0); break;
X case 'Z': ival = (ival == 0); break;
X case '+': ival = (ival > 0); break;
X case 'E': ival = ((ival & 1) == 0); break;
X case 'O': ival = ((ival & 1) != 0); break;
X default: badiop();
X }
X }
X else if (floatp(arg)) {
X fval = getflonum(arg);
X switch (fcn) {
X case '-': ival = (fval < 0); break;
X case 'Z': ival = (fval == 0); break;
X case '+': ival = (fval > 0); break;
X default: badfop();
X }
X }
X else
X xlerror("bad argument type",arg);
X
X /* return the result value */
X return (ival ? true : NIL);
X}
X
X/* comparison functions */
XLVAL xlss() { return (compare('<')); } /* < */
XLVAL xleq() { return (compare('L')); } /* <= */
XLVAL xequ() { return (compare('=')); } /* = */
XLVAL xneq() { return (compare('#')); } /* /= */
XLVAL xgeq() { return (compare('G')); } /* >= */
XLVAL xgtr() { return (compare('>')); } /* > */
X
X/* compare - common compare function */
XLOCAL LVAL compare(fcn)
X int fcn;
X{
X FIXTYPE icmp,ival,iarg;
X FLOTYPE fcmp,fval,farg;
X LVAL arg;
X int mode;
X
X /* get the first argument */
X arg = xlgetarg();
X
X /* set the type of the first argument */
X if (fixp(arg)) {
X ival = getfixnum(arg);
X mode = 'I';
X }
X else if (floatp(arg)) {
X fval = getflonum(arg);
X mode = 'F';
X }
X else
X xlerror("bad argument type",arg);
X
X /* handle each remaining argument */
X for (icmp = TRUE; icmp && moreargs(); ival = iarg, fval = farg) {
X
X /* get the next argument */
X arg = xlgetarg();
X
X /* check its type */
X if (fixp(arg)) {
X switch (mode) {
X case 'I':
X iarg = getfixnum(arg);
X break;
X case 'F':
X farg = (FLOTYPE)getfixnum(arg);
X break;
X }
X }
X else if (floatp(arg)) {
X switch (mode) {
X case 'I':
X fval = (FLOTYPE)ival;
X farg = getflonum(arg);
X mode = 'F';
X break;
X case 'F':
X farg = getflonum(arg);
X break;
X }
X }
X else
X xlerror("bad argument type",arg);
X
X /* compute result of the compare */
X switch (mode) {
X case 'I':
X icmp = ival - iarg;
X switch (fcn) {
X case '<': icmp = (icmp < 0); break;
X case 'L': icmp = (icmp <= 0); break;
X case '=': icmp = (icmp == 0); break;
X case '#': icmp = (icmp != 0); break;
X case 'G': icmp = (icmp >= 0); break;
X case '>': icmp = (icmp > 0); break;
X }
X break;
X case 'F':
X fcmp = fval - farg;
X switch (fcn) {
X case '<': icmp = (fcmp < 0.0); break;
X case 'L': icmp = (fcmp <= 0.0); break;
X case '=': icmp = (fcmp == 0.0); break;
X case '#': icmp = (fcmp != 0.0); break;
X case 'G': icmp = (fcmp >= 0.0); break;
X case '>': icmp = (fcmp > 0.0); break;
X }
X break;
X }
X }
X
X /* return the result */
X return (icmp ? true : NIL);
X}
X
X/* badiop - bad integer operation */
XLOCAL badiop()
X{
X xlfail("bad integer operation");
X}
X
X/* badfop - bad floating point operation */
XLOCAL badfop()
X{
X xlfail("bad floating point operation");
X}
SHAR_EOF
if test 9993 -ne "`wc -c 'xlmath.c'`"
then
echo shar: error transmitting "'xlmath.c'" '(should have been 9993 characters)'
fi
echo shar: extracting "'xlobj.c'" '(11545 characters)'
if test -f 'xlobj.c'
then
echo shar: over-writing existing file "'xlobj.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlobj.c'
X/* xlobj - xlisp object functions */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL xlenv,xlfenv,xlvalue;
Xextern LVAL s_stdout,s_lambda;
X
X/* local variables */
Xstatic LVAL s_self,k_new,k_isnew;
Xstatic LVAL class,object;
X
X/* instance variable numbers for the class 'Class' */
X#define MESSAGES 0 /* list of messages */
X#define IVARS 1 /* list of instance variable names */
X#define CVARS 2 /* list of class variable names */
X#define CVALS 3 /* list of class variable values */
X#define SUPERCLASS 4 /* pointer to the superclass */
X#define IVARCNT 5 /* number of class instance variables */
X#define IVARTOTAL 6 /* total number of instance variables */
X
X/* number of instance variables for the class 'Class' */
X#define CLASSSIZE 7
X
X/* forward declarations */
XFORWARD LVAL entermsg();
XFORWARD LVAL sendmsg();
XFORWARD LVAL evmethod();
X
X/* xsend - send a message to an object */
XLVAL xsend()
X{
X LVAL obj;
X obj = xlgaobject();
X return (sendmsg(obj,getclass(obj),xlgasymbol()));
X}
X
X/* xsendsuper - send a message to the superclass of an object */
XLVAL xsendsuper()
X{
X LVAL env,p;
X for (env = xlenv; env; env = cdr(env))
X if ((p = car(env)) && objectp(car(p)))
X return (sendmsg(car(p),
X getivar(cdr(p),SUPERCLASS),
X xlgasymbol()));
X xlfail("not in a method");
X}
X
X/* xlclass - define a class */
XLVAL xlclass(name,vcnt)
X char *name; int vcnt;
X{
X LVAL sym,cls;
X
X /* create the class */
X sym = xlenter(name);
X cls = newobject(class,CLASSSIZE);
X setvalue(sym,cls);
X
X /* set the instance variable counts */
X setivar(cls,IVARCNT,cvfixnum((FIXTYPE)vcnt));
X setivar(cls,IVARTOTAL,cvfixnum((FIXTYPE)vcnt));
X
X /* set the superclass to 'Object' */
X setivar(cls,SUPERCLASS,object);
X
X /* return the new class */
X return (cls);
X}
X
X/* xladdivar - enter an instance variable */
Xxladdivar(cls,var)
X LVAL cls; char *var;
X{
X setivar(cls,IVARS,cons(xlenter(var),getivar(cls,IVARS)));
X}
X
X/* xladdmsg - add a message to a class */
Xxladdmsg(cls,msg,offset)
X LVAL cls; char *msg; int offset;
X{
X extern FUNDEF funtab[];
X LVAL mptr;
X
X /* enter the message selector */
X mptr = entermsg(cls,xlenter(msg));
X
X /* store the method for this message */
X rplacd(mptr,cvsubr(funtab[offset].fd_subr,funtab[offset].fd_type,offset));
X}
X
X/* xlobgetvalue - get the value of an instance variable */
Xint xlobgetvalue(pair,sym,pval)
X LVAL pair,sym,*pval;
X{
X LVAL cls,names;
X int ivtotal,n;
X
X /* find the instance or class variable */
X for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {
X
X /* check the instance variables */
X names = getivar(cls,IVARS);
X ivtotal = getivcnt(cls,IVARTOTAL);
X for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
X if (car(names) == sym) {
X *pval = getivar(car(pair),n);
X return (TRUE);
X }
X names = cdr(names);
X }
X
X /* check the class variables */
X names = getivar(cls,CVARS);
X for (n = 0; consp(names); ++n) {
X if (car(names) == sym) {
X *pval = getelement(getivar(cls,CVALS),n);
X return (TRUE);
X }
X names = cdr(names);
X }
X }
X
X /* variable not found */
X return (FALSE);
X}
X
X/* xlobsetvalue - set the value of an instance variable */
Xint xlobsetvalue(pair,sym,val)
X LVAL pair,sym,val;
X{
X LVAL cls,names;
X int ivtotal,n;
X
X /* find the instance or class variable */
X for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {
X
X /* check the instance variables */
X names = getivar(cls,IVARS);
X ivtotal = getivcnt(cls,IVARTOTAL);
X for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
X if (car(names) == sym) {
X setivar(car(pair),n,val);
X return (TRUE);
X }
X names = cdr(names);
X }
X
X /* check the class variables */
X names = getivar(cls,CVARS);
X for (n = 0; consp(names); ++n) {
X if (car(names) == sym) {
X setelement(getivar(cls,CVALS),n,val);
X return (TRUE);
X }
X names = cdr(names);
X }
X }
X
X /* variable not found */
X return (FALSE);
X}
X
X/* obisnew - default 'isnew' method */
XLVAL obisnew()
X{
X LVAL self;
X self = xlgaobject();
X xllastarg();
X return (self);
X}
X
X/* obclass - get the class of an object */
XLVAL obclass()
X{
X LVAL self;
X self = xlgaobject();
X xllastarg();
X return (getclass(self));
X}
X
X/* obshow - show the instance variables of an object */
XLVAL obshow()
X{
X LVAL self,fptr,cls,names;
X int ivtotal,n;
X
X /* get self and the file pointer */
X self = xlgaobject();
X fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
X xllastarg();
X
X /* get the object's class */
X cls = getclass(self);
X
X /* print the object and class */
X xlputstr(fptr,"Object is ");
X xlprint(fptr,self,TRUE);
X xlputstr(fptr,", Class is ");
X xlprint(fptr,cls,TRUE);
X xlterpri(fptr);
X
X /* print the object's instance variables */
X for (; cls; cls = getivar(cls,SUPERCLASS)) {
X names = getivar(cls,IVARS);
X ivtotal = getivcnt(cls,IVARTOTAL);
X for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
X xlputstr(fptr," ");
X xlprint(fptr,car(names),TRUE);
X xlputstr(fptr," = ");
X xlprint(fptr,getivar(self,n),TRUE);
X xlterpri(fptr);
X names = cdr(names);
X }
X }
X
X /* return the object */
X return (self);
X}
X
X/* clnew - create a new object instance */
XLVAL clnew()
X{
X LVAL self;
X self = xlgaobject();
X return (newobject(self,getivcnt(self,IVARTOTAL)));
X}
X
X/* clisnew - initialize a new class */
XLVAL clisnew()
X{
X LVAL self,ivars,cvars,super;
X int n;
X
X /* get self, the ivars, cvars and superclass */
X self = xlgaobject();
X ivars = xlgalist();
X cvars = (moreargs() ? xlgalist() : NIL);
X super = (moreargs() ? xlgaobject() : object);
X xllastarg();
X
X /* store the instance and class variable lists and the superclass */
X setivar(self,IVARS,ivars);
X setivar(self,CVARS,cvars);
X setivar(self,CVALS,(cvars ? newvector(listlength(cvars)) : NIL));
X setivar(self,SUPERCLASS,super);
X
X /* compute the instance variable count */
X n = listlength(ivars);
X setivar(self,IVARCNT,cvfixnum((FIXTYPE)n));
X n += getivcnt(super,IVARTOTAL);
X setivar(self,IVARTOTAL,cvfixnum((FIXTYPE)n));
X
X /* return the new class object */
X return (self);
X}
X
X/* clanswer - define a method for answering a message */
XLVAL clanswer()
X{
X LVAL self,msg,fargs,code,mptr;
X
X /* message symbol, formal argument list and code */
X self = xlgaobject();
X msg = xlgasymbol();
X fargs = xlgalist();
X code = xlgalist();
X xllastarg();
X
X /* make a new message list entry */
X mptr = entermsg(self,msg);
X
X /* setup the message node */
X xlprot1(fargs);
X fargs = cons(s_self,fargs); /* add 'self' as the first argument */
X rplacd(mptr,xlclose(msg,s_lambda,fargs,code,NIL,NIL));
X xlpop();
X
X /* return the object */
X return (self);
X}
X
X/* entermsg - add a message to a class */
XLOCAL LVAL entermsg(cls,msg)
X LVAL cls,msg;
X{
X LVAL lptr,mptr;
X
X /* lookup the message */
X for (lptr = getivar(cls,MESSAGES); lptr; lptr = cdr(lptr))
X if (car(mptr = car(lptr)) == msg)
X return (mptr);
X
X /* allocate a new message entry if one wasn't found */
X xlsave1(mptr);
X mptr = consa(msg);
X setivar(cls,MESSAGES,cons(mptr,getivar(cls,MESSAGES)));
X xlpop();
X
X /* return the symbol node */
X return (mptr);
X}
X
X/* sendmsg - send a message to an object */
XLOCAL LVAL sendmsg(obj,cls,sym)
X LVAL obj,cls,sym;
X{
X LVAL msg,msgcls,method,val,p;
X
X /* look for the message in the class or superclasses */
X for (msgcls = cls; msgcls; ) {
X
X /* lookup the message in this class */
X for (p = getivar(msgcls,MESSAGES); p; p = cdr(p))
X if ((msg = car(p)) && car(msg) == sym)
X goto send_message;
X
X /* look in class's superclass */
X msgcls = getivar(msgcls,SUPERCLASS);
X }
X
X /* message not found */
X xlerror("no method for this message",sym);
X
Xsend_message:
X
X /* insert the value for 'self' (overwrites message selector) */
X *--xlargv = obj;
X ++xlargc;
X
X /* invoke the method */
X if ((method = cdr(msg)) == NULL)
X xlerror("bad method",method);
X switch (ntype(method)) {
X case SUBR:
X val = (*getsubr(method))();
X break;
X case CLOSURE:
X if (gettype(method) != s_lambda)
X xlerror("bad method",method);
X val = evmethod(obj,msgcls,method);
X break;
X default:
X xlerror("bad method",method);
X }
X
X /* after creating an object, send it the ":isnew" message */
X if (car(msg) == k_new && val) {
X xlprot1(val);
X sendmsg(val,getclass(val),k_isnew);
X xlpop();
X }
X
X /* return the result value */
X return (val);
X}
X
X/* evmethod - evaluate a method */
XLOCAL LVAL evmethod(obj,msgcls,method)
X LVAL obj,msgcls,method;
X{
X LVAL oldenv,oldfenv,cptr,name,val;
X CONTEXT cntxt;
X
X /* protect some pointers */
X xlstkcheck(3);
X xlsave(oldenv);
X xlsave(oldfenv);
X xlsave(cptr);
X
X /* create an 'object' stack entry and a new environment frame */
X oldenv = xlenv;
X oldfenv = xlfenv;
X xlenv = cons(cons(obj,msgcls),getenv(method));
X xlenv = xlframe(xlenv);
X xlfenv = getfenv(method);
X
X /* bind the formal parameters */
X xlabind(method,xlargc,xlargv);
X
X /* setup the implicit block */
X if (name = getname(method))
X xlbegin(&cntxt,CF_RETURN,name);
X
X /* execute the block */
X if (name && setjmp(cntxt.c_jmpbuf))
X val = xlvalue;
X else
X for (cptr = getbody(method); consp(cptr); cptr = cdr(cptr))
X val = xleval(car(cptr));
X
X /* finish the block context */
X if (name)
X xlend(&cntxt);
X
X /* restore the environment */
X xlenv = oldenv;
X xlfenv = oldfenv;
X
X /* restore the stack */
X xlpopn(3);
X
X /* return the result value */
X return (val);
X}
X
X/* getivcnt - get the number of instance variables for a class */
XLOCAL int getivcnt(cls,ivar)
X LVAL cls; int ivar;
X{
X LVAL cnt;
X if ((cnt = getivar(cls,ivar)) == NIL || !fixp(cnt))
X xlfail("bad value for instance variable count");
X return ((int)getfixnum(cnt));
X}
X
X/* listlength - find the length of a list */
XLOCAL int listlength(list)
X LVAL list;
X{
X int len;
X for (len = 0; consp(list); len++)
X list = cdr(list);
X return (len);
X}
X
X/* obsymbols - initialize symbols */
Xobsymbols()
X{
X /* enter the object related symbols */
X s_self = xlenter("SELF");
X k_new = xlenter(":NEW");
X k_isnew = xlenter(":ISNEW");
X
X /* get the Object and Class symbol values */
X object = getvalue(xlenter("OBJECT"));
X class = getvalue(xlenter("CLASS"));
X}
X
X/* xloinit - object function initialization routine */
Xxloinit()
X{
X /* create the 'Class' object */
X class = xlclass("CLASS",CLASSSIZE);
X setelement(class,0,class);
X
X /* create the 'Object' object */
X object = xlclass("OBJECT",0);
X
X /* finish initializing 'class' */
X setivar(class,SUPERCLASS,object);
X xladdivar(class,"IVARTOTAL"); /* ivar number 6 */
X xladdivar(class,"IVARCNT"); /* ivar number 5 */
X xladdivar(class,"SUPERCLASS"); /* ivar number 4 */
X xladdivar(class,"CVALS"); /* ivar number 3 */
X xladdivar(class,"CVARS"); /* ivar number 2 */
X xladdivar(class,"IVARS"); /* ivar number 1 */
X xladdivar(class,"MESSAGES"); /* ivar number 0 */
X xladdmsg(class,":NEW",FT_CLNEW);
X xladdmsg(class,":ISNEW",FT_CLISNEW);
X xladdmsg(class,":ANSWER",FT_CLANSWER);
X
X /* finish initializing 'object' */
X setivar(object,SUPERCLASS,NIL);
X xladdmsg(object,":ISNEW",FT_OBISNEW);
X xladdmsg(object,":CLASS",FT_OBCLASS);
X xladdmsg(object,":SHOW",FT_OBSHOW);
X}
X
SHAR_EOF
if test 11545 -ne "`wc -c 'xlobj.c'`"
then
echo shar: error transmitting "'xlobj.c'" '(should have been 11545 characters)'
fi
echo shar: extracting "'xlpp.c'" '(2111 characters)'
if test -f 'xlpp.c'
then
echo shar: over-writing existing file "'xlpp.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlpp.c'
X/* xlpp.c - xlisp pretty printer */
X/* Copyright (c) 1985, by David Betz
X All Rights Reserved */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL s_stdout;
Xextern int xlfsize;
X
X/* local variables */
Xstatic int pplevel,ppmargin,ppmaxlen;
Xstatic LVAL ppfile;
X
X/* xpp - pretty-print an expression */
XLVAL xpp()
X{
X LVAL expr;
X
X /* get expression to print and file pointer */
X expr = xlgetarg();
X ppfile = (moreargs() ? xlgetfile() : getvalue(s_stdout));
X xllastarg();
X
X /* pretty print the expression */
X pplevel = ppmargin = 0; ppmaxlen = 40;
X pp(expr); ppterpri(ppfile);
X
X /* return nil */
X return (NIL);
X}
X
X/* pp - pretty print an expression */
XLOCAL pp(expr)
X LVAL expr;
X{
X if (consp(expr))
X pplist(expr);
X else
X ppexpr(expr);
X}
X
X/* pplist - pretty print a list */
XLOCAL pplist(expr)
X LVAL expr;
X{
X int n;
X
X /* if the expression will fit on one line, print it on one */
X if ((n = flatsize(expr)) < ppmaxlen) {
X xlprint(ppfile,expr,TRUE);
X pplevel += n;
X }
X
X /* otherwise print it on several lines */
X else {
X n = ppmargin;
X ppputc('(');
X if (atom(car(expr))) {
X ppexpr(car(expr));
X ppputc(' ');
X ppmargin = pplevel;
X expr = cdr(expr);
X }
X else
X ppmargin = pplevel;
X for (; consp(expr); expr = cdr(expr)) {
X pp(car(expr));
X if (consp(cdr(expr)))
X ppterpri();
X }
X if (expr != NIL) {
X ppputc(' '); ppputc('.'); ppputc(' ');
X ppexpr(expr);
X }
X ppputc(')');
X ppmargin = n;
X }
X}
X
X/* ppexpr - print an expression and update the indent level */
XLOCAL ppexpr(expr)
X LVAL expr;
X{
X xlprint(ppfile,expr,TRUE);
X pplevel += flatsize(expr);
X}
X
X/* ppputc - output a character and update the indent level */
XLOCAL ppputc(ch)
X int ch;
X{
X xlputc(ppfile,ch);
X pplevel++;
X}
X
X/* ppterpri - terminate the print line and indent */
XLOCAL ppterpri()
X{
X xlterpri(ppfile);
X for (pplevel = 0; pplevel < ppmargin; pplevel++)
X xlputc(ppfile,' ');
X}
X
X/* flatsize - compute the flat size of an expression */
XLOCAL int flatsize(expr)
X LVAL expr;
X{
X xlfsize = 0;
X xlprint(NIL,expr,TRUE);
X return (xlfsize);
X}
SHAR_EOF
if test 2111 -ne "`wc -c 'xlpp.c'`"
then
echo shar: error transmitting "'xlpp.c'" '(should have been 2111 characters)'
fi
echo shar: extracting "'xlprin.c'" '(7244 characters)'
if test -f 'xlprin.c'
then
echo shar: over-writing existing file "'xlprin.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlprin.c'
X/* xlprint - xlisp print routine */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL tentry();
Xextern LVAL s_printcase,k_downcase,k_const,k_nmacro;
Xextern LVAL s_ifmt,s_ffmt;
Xextern FUNDEF funtab[];
Xextern char buf[];
X
X/* xlprint - print an xlisp value */
Xxlprint(fptr,vptr,flag)
X LVAL fptr,vptr; int flag;
X{
X LVAL nptr,next;
X int n,i;
X
X /* print nil */
X if (vptr == NIL) {
X putsymbol(fptr,"NIL",flag);
X return;
X }
X
X /* check value type */
X switch (ntype(vptr)) {
X case SUBR:
X putsubr(fptr,"Subr",vptr);
X break;
X case FSUBR:
X putsubr(fptr,"FSubr",vptr);
X break;
X case CONS:
X xlputc(fptr,'(');
X for (nptr = vptr; nptr != NIL; nptr = next) {
X xlprint(fptr,car(nptr),flag);
X if (next = cdr(nptr))
X if (consp(next))
X xlputc(fptr,' ');
X else {
X xlputstr(fptr," . ");
X xlprint(fptr,next,flag);
X break;
X }
X }
X xlputc(fptr,')');
X break;
X case SYMBOL:
X putsymbol(fptr,getstring(getpname(vptr)),flag);
X break;
X case FIXNUM:
X putfixnum(fptr,getfixnum(vptr));
X break;
X case FLONUM:
X putflonum(fptr,getflonum(vptr));
X break;
X case CHAR:
X putchcode(fptr,getchcode(vptr),flag);
X break;
X case STRING:
X if (flag)
X putqstring(fptr,vptr);
X else
X putstring(fptr,vptr);
X break;
X case STREAM:
X putatm(fptr,"File-Stream",vptr);
X break;
X case USTREAM:
X putatm(fptr,"Unnamed-Stream",vptr);
X break;
X case OBJECT:
X putatm(fptr,"Object",vptr);
X break;
X case VECTOR:
X xlputc(fptr,'#'); xlputc(fptr,'(');
X for (i = 0, n = getsize(vptr) - 1; i <= n; ++i) {
X xlprint(fptr,getelement(vptr,i),flag);
X if (i != n) xlputc(fptr,' ');
X }
X xlputc(fptr,')');
X break;
X case STRUCT:
X xlprstruct(fptr,vptr,flag);
X break;
X case CLOSURE:
X putclosure(fptr,vptr);
X break;
X case FREE:
X putatm(fptr,"Free",vptr);
X break;
X default:
X putatm(fptr,"Foo",vptr);
X break;
X }
X}
X
X/* xlterpri - terminate the current print line */
Xxlterpri(fptr)
X LVAL fptr;
X{
X xlputc(fptr,'\n');
X}
X
X/* xlputstr - output a string */
Xxlputstr(fptr,str)
X LVAL fptr; char *str;
X{
X while (*str)
X xlputc(fptr,*str++);
X}
X
X/* putsymbol - output a symbol */
XLOCAL putsymbol(fptr,str,escflag)
X LVAL fptr; char *str; int escflag;
X{
X int downcase,ch;
X LVAL type;
X char *p;
X
X /* check for printing without escapes */
X if (!escflag) {
X xlputstr(fptr,str);
X return;
X }
X
X /* check to see if symbol needs escape characters */
X if (tentry(*str) == k_const) {
X for (p = str; *p; ++p)
X if (islower(*p)
X || ((type = tentry(*p)) != k_const
X && (!consp(type) || car(type) != k_nmacro))) {
X xlputc(fptr,'|');
X while (*str) {
X if (*str == '\\' || *str == '|')
X xlputc(fptr,'\\');
X xlputc(fptr,*str++);
X }
X xlputc(fptr,'|');
X return;
X }
X }
X
X /* get the case translation flag */
X downcase = (getvalue(s_printcase) == k_downcase);
X
X /* check for the first character being '#' */
X if (*str == '#' || *str == '.' || isnumber(str,NULL))
X xlputc(fptr,'\\');
X
X /* output each character */
X while ((ch = *str++) != '\0') {
X /* don't escape colon until we add support for packages */
X if (ch == '\\' || ch == '|' /* || ch == ':' */)
X xlputc(fptr,'\\');
X xlputc(fptr,(downcase && isupper(ch) ? tolower(ch) : ch));
X }
X}
X
X/* putstring - output a string */
XLOCAL putstring(fptr,str)
X LVAL fptr,str;
X{
X unsigned char *p;
X int ch;
X
X /* output each character */
X for (p = getstring(str); (ch = *p) != '\0'; ++p)
X xlputc(fptr,ch);
X}
X
X/* putqstring - output a quoted string */
XLOCAL putqstring(fptr,str)
X LVAL fptr,str;
X{
X unsigned char *p;
X int ch;
X
X /* get the string pointer */
X p = getstring(str);
X
X /* output the initial quote */
X xlputc(fptr,'"');
X
X /* output each character in the string */
X for (p = getstring(str); (ch = *p) != '\0'; ++p)
X
X /* check for a control character */
X if (ch < 040 || ch == '\\' || ch > 0176) {
X xlputc(fptr,'\\');
X switch (ch) {
X case '\011':
X xlputc(fptr,'t');
X break;
X case '\012':
X xlputc(fptr,'n');
X break;
X case '\014':
X xlputc(fptr,'f');
X break;
X case '\015':
X xlputc(fptr,'r');
X break;
X case '\\':
X xlputc(fptr,'\\');
X break;
X default:
X putoct(fptr,ch);
X break;
X }
X }
X
X /* output a normal character */
X else
X xlputc(fptr,ch);
X
X /* output the terminating quote */
X xlputc(fptr,'"');
X}
X
X/* putatm - output an atom */
XLOCAL putatm(fptr,tag,val)
X LVAL fptr; char *tag; LVAL val;
X{
X sprintf(buf,"#<%s: #",tag); xlputstr(fptr,buf);
X sprintf(buf,AFMT,val); xlputstr(fptr,buf);
X xlputc(fptr,'>');
X}
X
X/* putsubr - output a subr/fsubr */
XLOCAL putsubr(fptr,tag,val)
X LVAL fptr; char *tag; LVAL val;
X{
X sprintf(buf,"#<%s-%s: #",tag,funtab[getoffset(val)].fd_name);
X xlputstr(fptr,buf);
X sprintf(buf,AFMT,val); xlputstr(fptr,buf);
X xlputc(fptr,'>');
X}
X
X/* putclosure - output a closure */
XLOCAL putclosure(fptr,val)
X LVAL fptr,val;
X{
X LVAL name;
X if (name = getname(val))
X sprintf(buf,"#<Closure-%s: #",getstring(getpname(name)));
X else
X strcpy(buf,"#<Closure: #");
X xlputstr(fptr,buf);
X sprintf(buf,AFMT,val); xlputstr(fptr,buf);
X xlputc(fptr,'>');
X/*
X xlputstr(fptr,"\nName: "); xlprint(fptr,getname(val),TRUE);
X xlputstr(fptr,"\nType: "); xlprint(fptr,gettype(val),TRUE);
X xlputstr(fptr,"\nLambda: "); xlprint(fptr,getlambda(val),TRUE);
X xlputstr(fptr,"\nArgs: "); xlprint(fptr,getargs(val),TRUE);
X xlputstr(fptr,"\nOargs: "); xlprint(fptr,getoargs(val),TRUE);
X xlputstr(fptr,"\nRest: "); xlprint(fptr,getrest(val),TRUE);
X xlputstr(fptr,"\nKargs: "); xlprint(fptr,getkargs(val),TRUE);
X xlputstr(fptr,"\nAargs: "); xlprint(fptr,getaargs(val),TRUE);
X xlputstr(fptr,"\nBody: "); xlprint(fptr,getbody(val),TRUE);
X xlputstr(fptr,"\nEnv: "); xlprint(fptr,getenv(val),TRUE);
X xlputstr(fptr,"\nFenv: "); xlprint(fptr,getfenv(val),TRUE);
X*/
X}
X
X/* putfixnum - output a fixnum */
XLOCAL putfixnum(fptr,n)
X LVAL fptr; FIXTYPE n;
X{
X unsigned char *fmt;
X LVAL val;
X fmt = ((val = getvalue(s_ifmt)) && stringp(val) ? getstring(val)
X : (unsigned char *)IFMT);
X sprintf(buf,fmt,n);
X xlputstr(fptr,buf);
X}
X
X/* putflonum - output a flonum */
XLOCAL putflonum(fptr,n)
X LVAL fptr; FLOTYPE n;
X{
X unsigned char *fmt;
X LVAL val;
X fmt = ((val = getvalue(s_ffmt)) && stringp(val) ? getstring(val)
X : (unsigned char *)"%g");
X sprintf(buf,fmt,n);
X xlputstr(fptr,buf);
X}
X
X/* putchcode - output a character */
XLOCAL putchcode(fptr,ch,escflag)
X LVAL fptr; int ch,escflag;
X{
X if (escflag) {
X switch (ch) {
X case '\n':
X xlputstr(fptr,"#\\Newline");
X break;
X case ' ':
X xlputstr(fptr,"#\\Space");
X break;
X default:
X sprintf(buf,"#\\%c",ch);
X xlputstr(fptr,buf);
X break;
X }
X }
X else
X xlputc(fptr,ch);
X}
X
X/* putoct - output an octal byte value */
XLOCAL putoct(fptr,n)
X LVAL fptr; int n;
X{
X sprintf(buf,"%03o",n);
X xlputstr(fptr,buf);
X}
SHAR_EOF
if test 7244 -ne "`wc -c 'xlprin.c'`"
then
echo shar: error transmitting "'xlprin.c'" '(should have been 7244 characters)'
fi
# End of shell archive
exit 0
--
Gary Murphy uunet!mitel!sce!cognos!garym
(garym%cognos.uucp@uunet.uu.net)
(613) 738-1338 x5537 Cognos Inc. P.O. Box 9707 Ottawa K1G 3N3
"There are many things which do not concern the process" - Joan of Arc