Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Posting-Version: version B 2.10.1 6/24/83; site mit-eddie.UUCP
Path: utzoo!watmath!clyde!burl!ulysses!allegra!mit-eddie!jfw
From: jfw@mit-eddie.UUCP (John Woods)
Newsgroups: net.sources
Subject: Dave Betz' XLISP 1.2 (The Real Thing) Part 4/5
Message-ID: <3552@mit-eddie.UUCP>
Date: Sun, 3-Feb-85 13:29:23 EST
Article-I.D.: mit-eddi.3552
Posted: Sun Feb  3 13:29:23 1985
Date-Received: Mon, 4-Feb-85 05:05:00 EST
Distribution: net.sources
Organization: MIT, Cambridge, MA
Lines: 1879

Replace this line with your cute comment

This is part 4 of 5 in a posting of Dave Betz' newest XLISP (mentioned on
net.sources some time back).  It is, as the other four parts, in shar format.

==================================
echo extract with sh, not csh
echo x XLLIST.C
cat > XLLIST.C << '!Funky!Stuff!'
/* xllist - xlisp list builtin functions */

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

#include "xlisp.h"

/* external variables */
extern struct node *xlstack;
extern struct node *s_unbound;
extern struct node *true;

/* forward declarations */
FORWARD struct node *nth(),*member(),*assoc(),*afind();
FORWARD struct node *delete(),*subst(),*sublis(),*map();
FORWARD int eq(),equal();

/* xcar - return the car of a list */
struct node *xcar(args)
  struct node *args;
{
    struct node *list;

    /* get the list and return its car */
    list = xlmatch(LIST,&args);
    xllastarg(args);
    return (list ? list->n_listvalue : NULL);
}

/* xcaar - return the caar of a list */
struct node *xcaar(args)
  struct node *args;
{
    struct node *list;

    /* get the list and return its caar */
    list = xlmatch(LIST,&args);
    xllastarg(args);
    if (list) list = list->n_listvalue;
    return (list ? list->n_listvalue : NULL);
}

/* xcadr - return the cadr of a list */
struct node *xcadr(args)
  struct node *args;
{
    struct node *list;

    /* get the list and return its cadr */
    list = xlmatch(LIST,&args);
    xllastarg(args);
    if (list) list = list->n_listnext;
    return (list ? list->n_listvalue : NULL);
}

/* xcdr - return the cdr of a list */
struct node *xcdr(args)
  struct node *args;
{
    struct node *list;

    /* get the list and return its cdr */
    list = xlmatch(LIST,&args);
    xllastarg(args);
    return (list ? list->n_listnext : NULL);
}

/* xcdar - return the cdar of a list */
struct node *xcdar(args)
  struct node *args;
{
    struct node *list;

    /* get the list and return its cdar */
    list = xlmatch(LIST,&args);
    xllastarg(args);
    if (list) list = list->n_listvalue;
    return (list ? list->n_listnext : NULL);
}

/* xcddr - return the cddr of a list */
struct node *xcddr(args)
  struct node *args;
{
    struct node *list;

    /* get the list and return its cddr */
    list = xlmatch(LIST,&args);
    xllastarg(args);
    if (list) list = list->n_listnext;
    return (list ? list->n_listnext : NULL);
}

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

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

    /* construct a new list element */
    val = newnode(LIST);
    val->n_listvalue = arg1;
    val->n_listnext  = arg2;

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

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

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

    /* initialize */
    arg.n_ptr = args;

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

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

	/* append this argument to the end of the list */
	lptr = newnode(LIST);
	if (last == NULL)
	    list.n_ptr = lptr;
	else
	    last->n_listnext = lptr;
	lptr->n_listvalue = val.n_ptr;
    }

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

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

/* xappend - builtin function append */
struct node *xappend(args)
  struct node *args;
{
    struct node *oldstk,arg,list,last,val,*lptr;

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

    /* initialize */
    arg.n_ptr = args;

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

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

	/* append each element of this list to the result list */
	while (list.n_ptr != NULL && list.n_ptr->n_type == LIST) {

	    /* append this element */
	    lptr = newnode(LIST);
	    if (last.n_ptr == NULL)
		val.n_ptr = lptr;
	    else
		last.n_ptr->n_listnext = lptr;
	    lptr->n_listvalue = list.n_ptr->n_listvalue;

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

	    /* move to the next element */
	    list.n_ptr = list.n_ptr->n_listnext;
	}

	/* make sure the list ended in a nil */
	if (list.n_ptr != NULL)
	    xlfail("bad list");
    }

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

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

/* xreverse - builtin function reverse */
struct node *xreverse(args)
  struct node *args;
{
    struct node *oldstk,list,val,*lptr;

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

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

    /* append each element of this list to the result list */
    while (list.n_ptr != NULL && list.n_ptr->n_type == LIST) {

	/* append this element */
	lptr = newnode(LIST);
	lptr->n_listvalue = list.n_ptr->n_listvalue;
	lptr->n_listnext = val.n_ptr;
	val.n_ptr = lptr;

	/* move to the next element */
	list.n_ptr = list.n_ptr->n_listnext;
    }

    /* make sure the list ended in a nil */
    if (list.n_ptr != NULL)
	xlfail("bad list");

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

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

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

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

    /* find the last cons */
    while (list && list->n_type == LIST && list->n_listnext)
	list = list->n_listnext;

    /* make sure the list ended correctly */
    if (list == NULL && list->n_type != LIST)
	xlfail("bad list");

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

/* xmember - builtin function 'member' */
struct node *xmember(args)
  struct node *args;
{
    return (member(args,equal));
}

/* xmemq - builtin function 'memq' */
struct node *xmemq(args)
  struct node *args;
{
    return (member(args,eq));
}

/* member - internal member function */
LOCAL struct node *member(args,fcn)
  struct node *args; int (*fcn)();
{
    struct node *x,*list;

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

    /* look for the expression */
    for (; list && list->n_type == LIST; list = list->n_listnext)
	if ((*fcn)(x,list->n_listvalue))
	    return (list);

    /* return failure indication */
    return (NULL);
}

/* xassoc - builtin function 'assoc' */
struct node *xassoc(args)
  struct node *args;
{
    return (assoc(args,equal));
}

/* xassq - builtin function 'assq' */
struct node *xassq(args)
  struct node *args;
{
    return (assoc(args,eq));
}

/* assoc - internal assoc function */
LOCAL struct node *assoc(args,fcn)
  struct node *args; int (*fcn)();
{
    struct node *expr,*alist,*pair;

    /* get the expression to look for and the association list */
    expr = xlarg(&args);
    alist = xlmatch(LIST,&args);
    xllastarg(args);

    /* look for the expression */
    return (afind(expr,alist,fcn));
}

/* afind - find a pair in an association list */
LOCAL struct node *afind(expr,alist,fcn)
  struct node *expr,*alist; int (*fcn)();
{
    struct node *pair;

    for (; alist && alist->n_type == LIST; alist = alist->n_listnext)
	if ((pair = alist->n_listvalue) && pair->n_type == LIST)
	    if ((*fcn)(expr,pair->n_listvalue))
		return (pair);
    return (NULL);
}

/* xsubst - substitute one expression for another */
struct node *xsubst(args)
  struct node *args;
{
    struct node *oldstk,to,from,expr,*val;

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

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

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

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

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

/* subst - substitute one expression for another */
LOCAL struct node *subst(to,from,expr)
  struct node *to,*from,*expr;
{
    struct node *oldstk,car,cdr,*val;

    if (eq(expr,from))
	val = to;
    else if (expr == NULL || expr->n_type != LIST)
	val = expr;
    else {
	oldstk = xlsave(&car,&cdr,NULL);
	car.n_ptr = subst(to,from,expr->n_listvalue);
	cdr.n_ptr = subst(to,from,expr->n_listnext);
	val = newnode(LIST);
	val->n_listvalue = car.n_ptr;
	val->n_listnext = cdr.n_ptr;
	xlstack = oldstk;
    }
    return (val);
}

/* xsublis - substitute using an association list */
struct node *xsublis(args)
  struct node *args;
{
    struct node *oldstk,alist,expr,*val;

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

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

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

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

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

/* sublis - substitute using an association list */
LOCAL struct node *sublis(alist,expr)
  struct node *alist,*expr;
{
    struct node *oldstk,car,cdr,*val;

    if (val = afind(expr,alist,eq))
	val = val->n_listnext;
    else if (expr == NULL || expr->n_type != LIST)
	val = expr;
    else {
	oldstk = xlsave(&car,&cdr,NULL);
	car.n_ptr = sublis(alist,expr->n_listvalue);
	cdr.n_ptr = sublis(alist,expr->n_listnext);
	val = newnode(LIST);
	val->n_listvalue = car.n_ptr;
	val->n_listnext = cdr.n_ptr;
	xlstack = oldstk;
    }
    return (val);
}

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

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

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

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

    /* find the nth element */
    for (; n > 0; n--) {
	list = list->n_listnext;
	if (list == NULL || list->n_type != LIST)
	    xlfail("invalid argument");
    }

    /* return the list beginning at the nth element */
    return (cdrflag ? list : list->n_listvalue);
}

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

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

    /* find the length */
    for (n = 0; list != NULL; n++)
	list = list->n_listnext;

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

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

/* xmapcar - builtin function 'mapcar' */
struct node *xmapcar(args)
  struct node *args;
{
    return (map(args,TRUE));
}

/* xmaplist - builtin function 'maplist' */
struct node *xmaplist(args)
  struct node *args;
{
    return (map(args,FALSE));
}

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

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

    /* get the function to apply */
    fcn.n_ptr = xlarg(&args);

    /* make sure there is at least one argument list */
    if (args == NULL)
	xlfail("too few arguments");

    /* get the argument lists */
    while (args) {
	p = newnode(LIST);
	p->n_listnext = lists.n_ptr;
	lists.n_ptr = p;
	p->n_listvalue = xlmatch(LIST,&args);
    }

    /* if the function is a symbol, get its value */
    if (fcn.n_ptr && fcn.n_ptr->n_type == SYM)
	fcn.n_ptr = xleval(fcn.n_ptr);

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

	/* build an argument list from the sublists */
	arglist.n_ptr = NULL;
	for (x = lists.n_ptr; x && (y = x->n_listvalue); x = x->n_listnext) {
	    p = newnode(LIST);
	    p->n_listnext = arglist.n_ptr;
	    arglist.n_ptr = p;
	    p->n_listvalue = (carflag ? y->n_listvalue : y);
	    x->n_listvalue = y->n_listnext;
	}

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

	/* apply the function to the arguments */
	p = newnode(LIST);
	if (val.n_ptr)
	    last->n_listnext = p;
	else
	    val.n_ptr = p;
	last = p;
	p->n_listvalue = xlapply(fcn.n_ptr,arglist.n_ptr);
    }

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

    /* return the last test expression value */
    return (val.n_ptr);
}
/* xrplca - replace the car of a list node */
struct node *xrplca(args)
  struct node *args;
{
    struct node *list,*newcar;

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

    /* replace the car */
    list->n_listvalue = newcar;

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

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

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

    /* replace the cdr */
    list->n_listnext = newcdr;

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

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

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

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

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

	    /* find the end of the list */
	    while (list && list->n_type == LIST && list->n_listnext)
		list = list->n_listnext;

	    /* make sure the list ended correctly */
	    if (list == NULL || list->n_type != LIST)
		xlfail("bad list");

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

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

/* xdelete - builtin function 'delete' */
struct node *xdelete(args)
  struct node *args;
{
    return (delete(args,equal));
}

/* xdelq - builtin function 'delq' */
struct node *xdelq(args)
  struct node *args;
{
    return (delete(args,eq));
}

/* delete - internal delete function */
LOCAL struct node *delete(args,fcn)
  struct node *args; int (*fcn)();
{
    struct node *x,*list,*last,*val;

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

    /* delete leading matches */
    while (list && list->n_type == LIST) {
	if (!(*fcn)(x,list->n_listvalue))
	    break;
	list = list->n_listnext;
    }
    val = last = list;

    /* delete embedded matches */
    if (list && list->n_type == LIST) {

	/* skip the first non-matching element */
	list = list->n_listnext;

	/* look for embedded matches */
	while (list && list->n_type == LIST) {

	    /* check to see if this element should be deleted */
	    if ((*fcn)(x,list->n_listvalue))
		last->n_listnext = list->n_listnext;
	    else
		last = list;

	    /* move to the next element */
	    list = list->n_listnext;
 	}
    }

    /* make sure the list ended in a nil */
    if (list != NULL)
	xlfail("bad list");

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

/* xatom - is this an atom? */
struct node *xatom(args)
  struct node *args;
{
    struct node *arg;
    return ((arg = xlarg(&args)) == NULL || arg->n_type != LIST ? true : NULL);
}

/* xsymbolp - is this an symbol? */
struct node *xsymbolp(args)
  struct node *args;
{
    struct node *arg;
    return ((arg = xlarg(&args)) && arg->n_type == SYM ? true : NULL);
}

/* xnumberp - is this an number? */
struct node *xnumberp(args)
  struct node *args;
{
    struct node *arg;
    return ((arg = xlarg(&args)) && arg->n_type == INT ? true : NULL);
}

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

/* xnull - is this null? */
struct node *xnull(args)
  struct node *args;
{
    return (xlarg(&args) == NULL ? true : NULL);
}

/* xlistp - is this a list? */
struct node *xlistp(args)
  struct node *args;
{
    struct node *arg;
    return ((arg = xlarg(&args)) == NULL || arg->n_type == LIST ? true : NULL);
}

/* xconsp - is this a cons? */
struct node *xconsp(args)
  struct node *args;
{
    struct node *arg;
    return ((arg = xlarg(&args)) != NULL && arg->n_type == LIST ? true : NULL);
}

/* xeq - are these equal? */
struct node *xeq(args)
  struct node *args;
{
    struct node *arg1,*arg2;

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

    /* compare the arguments */
    return (eq(arg1,arg2) ? true : NULL);
}

/* eq - internal eq function */
LOCAL int eq(arg1,arg2)
  struct node *arg1,*arg2;
{
    /* compare the arguments */
    if (arg1 != NULL && arg1->n_type == INT &&
    	arg2 != NULL && arg2->n_type == INT)
	return (arg1->n_int == arg2->n_int);
    else
	return (arg1 == arg2);
}

/* xequal - are these equal? */
struct node *xequal(args)
  struct node *args;
{
    struct node *arg1,*arg2;

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

    /* compare the arguments */
    return (equal(arg1,arg2) ? true : NULL);
}

/* equal - internal equal function */
LOCAL int equal(arg1,arg2)
  struct node *arg1,*arg2;
{
    /* compare the arguments */
    if (eq(arg1,arg2))
	return (TRUE);
    else if (arg1 && arg1->n_type == LIST &&
	     arg2 && arg2->n_type == LIST)
	return (equal(arg1->n_listvalue,arg2->n_listvalue) &&
		equal(arg1->n_listnext, arg2->n_listnext));
    else
	return (FALSE);
}
!Funky!Stuff!
echo x XLMATH.C
cat > XLMATH.C << '!Funky!Stuff!'
/* xlmath - xlisp builtin arithmetic functions */

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

#include "xlisp.h"

/* external variables */
extern struct node *xlstack;
extern struct node *true;

/* forward declarations */
FORWARD struct node *unary();
FORWARD struct node *binary();
FORWARD struct node *compare();

/* xadd - builtin function for addition */
LOCAL int add(val,arg)
  int val,arg;
{
    return (val + arg);
}
struct node *xadd(args)
  struct node *args;
{
    return (binary(args,add));
}

/* xsub - builtin function for subtraction */
LOCAL int sub(val,arg)
  int val,arg;
{
    return (val - arg);
}
struct node *xsub(args)
  struct node *args;
{
    return (binary(args,sub));
}

/* xmul - builtin function for multiplication */
LOCAL int mul(val,arg)
  int val,arg;
{
    return (val * arg);
}
struct node *xmul(args)
  struct node *args;
{
    return (binary(args,mul));
}

/* xdiv - builtin function for division */
LOCAL int div(val,arg)
  int val,arg;
{
    return (val / arg);
}
struct node *xdiv(args)
  struct node *args;
{
    return (binary(args,div));
}

/* xrem - builtin function for remainder */
LOCAL int rem(val,arg)
  int val,arg;
{
    return (val % arg);
}
struct node *xrem(args)
  struct node *args;
{
    return (binary(args,rem));
}

/* xmin - builtin function for minimum */
LOCAL int min(val,arg)
  int val,arg;
{
    return (val < arg ? val : arg);
}
struct node *xmin(args)
  struct node *args;
{
    return (binary(args,min));
}

/* xmax - builtin function for maximum */
LOCAL int max(val,arg)
  int val,arg;
{
    return (val > arg ? val : arg);
}
struct node *xmax(args)
  struct node *args;
{
    return (binary(args,max));
}

/* xbitand - builtin function for bitwise and */
LOCAL int bitand(val,arg)
  int val,arg;
{
    return (val & arg);
}
struct node *xbitand(args)
  struct node *args;
{
    return (binary(args,bitand));
}

/* xbitior - builtin function for bitwise inclusive or */
LOCAL int bitior(val,arg)
  int val,arg;
{
    return (val | arg);
}
struct node *xbitior(args)
  struct node *args;
{
    return (binary(args,bitior));
}

/* xbitxor - builtin function for bitwise exclusive or */
LOCAL int bitxor(val,arg)
  int val,arg;
{
    return (val ^ arg);
}
struct node *xbitxor(args)
  struct node *args;
{
    return (binary(args,bitxor));
}

/* xbitnot - bitwise not */
LOCAL int bitnot(arg)
  int arg;
{
    return (~arg);
}
struct node *xbitnot(args)
  struct node *args;
{
    return (unary(args,bitnot));
}

/* xabs - builtin function for absolute value */
LOCAL int abs(arg)
  int arg;
{
    return (arg >= 0 ? arg : -arg);
}
struct node *xabs(args)
  struct node *args;
{
    return (unary(args,abs));
}

/* xadd1 - builtin function for adding one */
LOCAL int add1(arg)
  int arg;
{
    return (arg + 1);
}
struct node *xadd1(args)
  struct node *args;
{
    return (unary(args,add1));
}

/* xsub1 - builtin function for subtracting one */
LOCAL int sub1(arg)
  int arg;
{
    return (arg - 1);
}
struct node *xsub1(args)
  struct node *args;
{
    return (unary(args,sub1));
}

/* xminus - negate a value */
LOCAL int minus(arg)
  int arg;
{
    return (-arg);
}
struct node *xminus(args)
  struct node *args;
{
    return (unary(args,minus));
}

/* unary - handle unary operations */
LOCAL struct node *unary(args,fcn)
  struct node *args; int (*fcn)();
{
    struct node *rval;
    int val;

    /* evaluate the argument */
    val = xlmatch(INT,&args)->n_int;

    /* make sure there aren't any more arguments */
    xllastarg(args);

    /* convert and check the value  */
    rval = newnode(INT);
    rval->n_int = (*fcn)(val);

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

/* binary - handle binary operations */
LOCAL struct node *binary(args,funct)
  struct node *args; int (*funct)();
{
    int first,ival,iarg;
    struct node *val;

    /* initialize */
    first = TRUE;
    ival = 0;

    /* evaluate and sum each argument */
    while (args != NULL) {

	/* get the next argument */
	iarg = xlmatch(INT,&args)->n_int;

	/* accumulate the result value */
	if (first) {
	    ival = iarg;
	    first = FALSE;
	}
	else
	    ival = (*funct)(ival,iarg);
    }

    /* initialize value */
    val = newnode(INT);
    val->n_int = ival;

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

/* xlss - builtin function for < */
LOCAL int lss(cmp)
  int cmp;
{
    return (cmp < 0);
}
struct node *xlss(args)
  struct node *args;
{
    return (compare(args,lss));
}

/* xleq - builtin function for <= */
LOCAL int leq(cmp)
  int cmp;
{
    return (cmp <= 0);
}
struct node *xleq(args)
  struct node *args;
{
    return (compare(args,leq));
}

/* eql - builtin function for = */
LOCAL int eql(cmp)
  int cmp;
{
    return (cmp == 0);
}
struct node *xeql(args)
  struct node *args;
{
    return (compare(args,eql));
}

/* xneq - builtin function for /= */
LOCAL int neq(cmp)
  int cmp;
{
    return (cmp != 0);
}
struct node *xneq(args)
  struct node *args;
{
    return (compare(args,neq));
}

/* xgeq - builtin function for >= */
LOCAL int geq(cmp)
  int cmp;
{
    return (cmp >= 0);
}
struct node *xgeq(args)
  struct node *args;
{
    return (compare(args,geq));
}

/* xgtr - builtin function for > */
LOCAL int gtr(cmp)
  int cmp;
{
    return (cmp > 0);
}
struct node *xgtr(args)
  struct node *args;
{
    return (compare(args,gtr));
}

/* compare - common compare function */
LOCAL struct node *compare(args,funct)
  struct node *args; int (*funct)();
{
    struct node *arg1,*arg2;
    int type1,type2,cmp;

    /* get argument 1 */
    arg1 = xlarg(&args);
    type1 = gettype(arg1);

    /* get argument 2 */
    arg2 = xlarg(&args);
    type2 = gettype(arg2);

    /* make sure there aren't any more arguments */
    xllastarg(args);

    /* do the compare */
    if (type1 == STR && type2 == STR)
	cmp = strcmp(arg1->n_str,arg2->n_str);
    else if (type1 == INT && type2 == INT)
	cmp = arg1->n_int - arg2->n_int;
    else
	cmp = arg1 - arg2;

    /* return result of the compare */
    if ((*funct)(cmp))
	return (true);
    else
	return (NULL);
}

/* gettype - return the type of an argument */
LOCAL int gettype(arg)
  struct node *arg;
{
    if (arg == NULL)
	return (LIST);
    else
	return (arg->n_type);
}
!Funky!Stuff!
echo x XLOBJ.C
cat > XLOBJ.C << '!Funky!Stuff!'
/* xlobj - xlisp object functions */

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

#include "xlisp.h"

/* global variables */
struct node *self;

/* external variables */
extern struct node *xlstack;
extern struct node *xlenv;
extern struct node *s_stdout;

/* local variables */
static struct node *class;
static struct node *object;
static struct node *new;
static struct node *isnew;
static struct node *msgcls;
static struct node *msgclass;
static int varcnt;

/* instance variable numbers for the class 'Class' */
#define MESSAGES	0	/* list of messages */
#define IVARS		1	/* list of instance variable names */
#define CVARS		2	/* list of class variable names */
#define CVALS		3	/* list of class variable values */
#define SUPERCLASS	4	/* pointer to the superclass */
#define IVARCNT		5	/* number of class instance variables */
#define IVARTOTAL	6	/* total number of instance variables */

/* number of instance variables for the class 'Class' */
#define CLASSSIZE	7

/* forward declarations */
FORWARD struct node *xlivar();
FORWARD struct node *xlcvar();
FORWARD struct node *findmsg();
FORWARD struct node *findvar();
FORWARD struct node *defvars();
FORWARD struct node *makelist();

/* xlclass - define a class */
struct node *xlclass(name,vcnt)
  char *name; int vcnt;
{
    struct node *sym,*cls;

    /* create the class */
    sym = xlsenter(name);
    cls = sym->n_symvalue = newnode(OBJ);
    cls->n_obclass = class;
    cls->n_obdata = makelist(CLASSSIZE);

    /* set the instance variable counts */
    if (vcnt > 0) {
	(xlivar(cls,IVARCNT)->n_listvalue = newnode(INT))->n_int = vcnt;
	(xlivar(cls,IVARTOTAL)->n_listvalue = newnode(INT))->n_int = vcnt;
    }

    /* set the superclass to 'Object' */
    xlivar(cls,SUPERCLASS)->n_listvalue = object;

    /* return the new class */
    return (cls);
}

/* xlmfind - find the message binding for a message to an object */
struct node *xlmfind(obj,msym)
  struct node *obj,*msym;
{
    return (findmsg(obj->n_obclass,msym));
}

/* xlxsend - send a message to an object */
struct node *xlxsend(obj,msg,args)
  struct node *obj,*msg,*args;
{
    struct node *oldstk,method,cptr,eargs,val,*isnewmsg,*oldenv;

    /* save the old environment */
    oldenv = xlenv;

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

    /* get the method for this message */
    method.n_ptr = msg->n_msgcode;

    /* make sure its a function or a subr */
    if (method.n_ptr->n_type != SUBR && method.n_ptr->n_type != LIST)
	xlfail("bad method");

    /* bind the symbols 'self' and 'msgclass' */
    xlbind(self,obj);
    xlbind(msgclass,msgcls);

    /* evaluate the function call */
    eargs.n_ptr = xlevlist(args);
    if (method.n_ptr->n_type == SUBR) {
	xlfixbindings(oldenv);
	val.n_ptr = (*method.n_ptr->n_subr)(eargs.n_ptr);
    }
    else {

	/* bind the formal arguments */
	xlabind(method.n_ptr->n_listvalue,eargs.n_ptr);
	xlfixbindings(oldenv);

	/* execute the code */
	cptr.n_ptr = method.n_ptr->n_listnext;
	while (cptr.n_ptr != NULL)
	    val.n_ptr = xlevarg(&cptr.n_ptr);
    }

    /* restore the environment */
    xlunbind(oldenv);

    /* after creating an object, send it the "isnew" message */
    if (msg->n_msg == new && val.n_ptr != NULL) {
	if ((isnewmsg = xlmfind(val.n_ptr,isnew)) == NULL)
	    xlfail("no method for the isnew message");
	val.n_ptr = xlxsend(val.n_ptr,isnewmsg,args);
    }

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

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

/* xlsend - send a message to an object (message in arg list) */
struct node *xlsend(obj,args)
  struct node *obj,*args;
{
    struct node *msg;

    /* find the message binding for this message */
    if ((msg = xlmfind(obj,xlevmatch(SYM,&args))) == NULL)
	xlfail("no method for this message");

    /* send the message */
    return (xlxsend(obj,msg,args));
}

/* xlobsym - find a class or instance variable for the current object */
struct node *xlobsym(sym)
  struct node *sym;
{
    struct node *obj;

    if ((obj = self->n_symvalue) != NULL && obj->n_type == OBJ)
	return (findvar(obj,sym));
    else
	return (NULL);
}

/* mnew - create a new object instance */
LOCAL struct node *mnew()
{
    struct node *oldstk,obj,*cls;

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

    /* get the class */
    cls = self->n_symvalue;

    /* generate a new object */
    obj.n_ptr = newnode(OBJ);
    obj.n_ptr->n_obclass = cls;
    obj.n_ptr->n_obdata = makelist(getivcnt(cls,IVARTOTAL));

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

    /* return the new object */
    return (obj.n_ptr);
}

/* misnew - initialize a new class */
LOCAL struct node *misnew(args)
  struct node *args;
{
    struct node *oldstk,super,*obj;

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

    /* get the superclass if there is one */
    if (args != NULL)
	super.n_ptr = xlmatch(OBJ,&args);
    else
	super.n_ptr = object;
    xllastarg(args);

    /* get the object */
    obj = self->n_symvalue;

    /* store the superclass */
    xlivar(obj,SUPERCLASS)->n_listvalue = super.n_ptr;
    (xlivar(obj,IVARTOTAL)->n_listvalue = newnode(INT))->n_int =
    	 getivcnt(super.n_ptr,IVARTOTAL);

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

    /* return the new object */
    return (obj);
}

/* xladdivar - enter an instance variable */
xladdivar(cls,var)
  struct node *cls; char *var;
{
    struct node *ivar,*lptr;

    /* find the 'ivars' instance variable */
    ivar = xlivar(cls,IVARS);

    /* add the instance variable */
    lptr = newnode(LIST);
    lptr->n_listnext = ivar->n_listvalue;
    ivar->n_listvalue = lptr;
    lptr->n_listvalue = xlsenter(var);
}

/* entermsg - add a message to a class */
LOCAL struct node *entermsg(cls,msg)
  struct node *cls,*msg;
{
    struct node *ivar,*lptr,*mptr;

    /* find the 'messages' instance variable */
    ivar = xlivar(cls,MESSAGES);

    /* lookup the message */
    for (lptr = ivar->n_listvalue; lptr != NULL; lptr = lptr->n_listnext)
	if ((mptr = lptr->n_listvalue)->n_msg == msg)
	    return (mptr);

    /* allocate a new message entry if one wasn't found */
    lptr = newnode(LIST);
    lptr->n_listnext = ivar->n_listvalue;
    ivar->n_listvalue = lptr;
    lptr->n_listvalue = mptr = newnode(LIST);
    mptr->n_msg = msg;

    /* return the symbol node */
    return (mptr);
}

/* answer - define a method for answering a message */
LOCAL struct node *answer(args)
  struct node *args;
{
    struct node *oldstk,arg,msg,fargs,code;
    struct node *obj,*mptr,*fptr;

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

    /* initialize */
    arg.n_ptr = args;

    /* message symbol, formal argument list and code */
    msg.n_ptr = xlmatch(SYM,&arg.n_ptr);
    fargs.n_ptr = xlmatch(LIST,&arg.n_ptr);
    code.n_ptr = xlmatch(LIST,&arg.n_ptr);
    xllastarg(arg.n_ptr);

    /* get the object node */
    obj = self->n_symvalue;

    /* make a new message list entry */
    mptr = entermsg(obj,msg.n_ptr);

    /* setup the message node */
    mptr->n_msgcode = fptr = newnode(LIST);
    fptr->n_listvalue = fargs.n_ptr;
    fptr->n_listnext = code.n_ptr;

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

    /* return the object */
    return (obj);
}

/* mivars - define the list of instance variables */
LOCAL struct node *mivars(args)
  struct node *args;
{
    struct node *cls,*super;
    int scnt;

    /* define the list of instance variables */
    cls = defvars(args,IVARS);

    /* get the superclass instance variable count */
    if ((super = xlivar(cls,SUPERCLASS)->n_listvalue) != NULL)
	scnt = getivcnt(super,IVARTOTAL);
    else
	scnt = 0;

    /* save the number of instance variables */
    (xlivar(cls,IVARCNT)->n_listvalue = newnode(INT))->n_int = varcnt;
    (xlivar(cls,IVARTOTAL)->n_listvalue = newnode(INT))->n_int = scnt+varcnt;

    /* return the class */
    return (cls);
}

/* getivcnt - get the number of instance variables for a class */
LOCAL int getivcnt(cls,ivar)
  struct node *cls; int ivar;
{
    struct node *cnt;

    if ((cnt = xlivar(cls,ivar)->n_listvalue) != NULL)
	if (cnt->n_type == INT)
	    return (cnt->n_int);
	else
	    xlfail("bad value for instance variable count");
    else
	return (0);
}

/* mcvars - define the list of class variables */
LOCAL struct node *mcvars(args)
  struct node *args;
{
    struct node *cls;

    /* define the list of class variables */
    cls = defvars(args,CVARS);

    /* make a new list of values */
    xlivar(cls,CVALS)->n_listvalue = makelist(varcnt);

    /* return the class */
    return (cls);
}

/* defvars - define a class or instance variable list */
LOCAL struct node *defvars(args,varnum)
  struct node *args; int varnum;
{
    struct node *oldstk,vars,*vptr,*cls,*sym;

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

    /* get ivar list */
    vars.n_ptr = xlmatch(LIST,&args);
    xllastarg(args);

    /* get the class node */
    cls = self->n_symvalue;

    /* check each variable in the list */
    varcnt = 0;
    for (vptr = vars.n_ptr;
	 vptr != NULL && vptr->n_type == LIST;
	 vptr = vptr->n_listnext) {

	/* make sure this is a valid symbol in the list */
	if ((sym = vptr->n_listvalue) == NULL || sym->n_type != SYM)
	    xlfail("bad variable list");

	/* make sure its not already defined */
	if (checkvar(cls,sym))
	    xlfail("multiply defined variable");

	/* count the variable */
	varcnt++;
    }

    /* make sure the list ended properly */
    if (vptr != NULL)
	xlfail("bad variable list");

    /* define the new variable list */
    xlivar(cls,varnum)->n_listvalue = vars.n_ptr;

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

    /* return the class */
    return (cls);
}

/* xladdmsg - add a message to a class */
xladdmsg(cls,msg,code)
  struct node *cls; char *msg; struct node *(*code)();
{
    struct node *mptr;

    /* enter the message selector */
    mptr = entermsg(cls,xlsenter(msg));

    /* store the method for this message */
    mptr->n_msgcode = newnode(SUBR);
    mptr->n_msgcode->n_subr = code;
}

/* getclass - get the class of an object */
LOCAL struct node *getclass(args)
  struct node *args;
{
    /* make sure there aren't any arguments */
    xllastarg(args);

    /* return the object's class */
    return (self->n_symvalue->n_obclass);
}

/* obshow - show the instance variables of an object */
LOCAL struct node *obshow(args)
  struct node *args;
{
    struct node *fptr;

    /* get the file pointer */
    fptr = (args ? xlmatch(FPTR,&args) : s_stdout->n_symvalue);
    xllastarg(args);

    /* print the object's instance variables */
    xlprint(fptr,self->n_symvalue->n_obdata,TRUE);
    xlterpri(fptr);

    /* return the object */
    return (self->n_symvalue);
}

/* defisnew - default 'isnew' method */
LOCAL struct node *defisnew(args)
  struct node *args;
{
    /* make sure there aren't any arguments */
    xllastarg(args);

    /* return the object */
    return (self->n_symvalue);
}

/* sendsuper - send a message to an object's superclass */
LOCAL struct node *sendsuper(args)
  struct node *args;
{
    struct node *obj,*super,*msg;

    /* get the object */
    obj = self->n_symvalue;

    /* get the object's superclass */
    super = xlivar(obj->n_obclass,SUPERCLASS)->n_listvalue;

    /* find the message binding for this message */
    if ((msg = findmsg(super,xlmatch(SYM,&args))) == NULL)
	xlfail("no method for this message");

    /* send the message */
    return (xlxsend(obj,msg,args));
}

/* findmsg - find the message binding given an object and a class */
LOCAL struct node *findmsg(cls,sym)
  struct node *cls,*sym;
{
    struct node *lptr,*msg;

    /* start at the specified class */
    msgcls = cls;

    /* look for the message in the class or superclasses */
    while (msgcls != NULL) {

	/* lookup the message in this class */
	for (lptr = xlivar(msgcls,MESSAGES)->n_listvalue;
	     lptr != NULL;
	     lptr = lptr->n_listnext)
	    if ((msg = lptr->n_listvalue) != NULL && msg->n_msg == sym)
		return (msg);

	/* look in class's superclass */
	msgcls = xlivar(msgcls,SUPERCLASS)->n_listvalue;
    }

    /* message not found */
    return (NULL);
}

/* findvar - find a class or instance variable */
LOCAL struct node *findvar(obj,sym)
  struct node *obj,*sym;
{
    struct node *cls,*lptr;
    int base,varnum;
    int found;

    /* get the class of the object */
    cls = obj->n_obclass;

    /* get the total number of instance variables */
    base = getivcnt(cls,IVARTOTAL);

    /* find the variable */
    found = FALSE;
    for (; cls != NULL; cls = xlivar(cls,SUPERCLASS)->n_listvalue) {

	/* get the number of instance variables for this class */
	if ((base -= getivcnt(cls,IVARCNT)) < 0)
	    xlfail("error finding instance variable");

	/* check for finding the class of the current message */
	if (!found && cls == msgclass->n_symvalue)
	    found = TRUE;

	/* lookup the instance variable */
	varnum = 0;
	for (lptr = xlivar(cls,IVARS)->n_listvalue;
    	     lptr != NULL;
    	     lptr = lptr->n_listnext)
	    if (found && lptr->n_listvalue == sym)
		return (xlivar(obj,base + varnum));
	    else
		varnum++;

	/* skip the class variables if the message class hasn't been found */
	if (!found)
	    continue;

	/* lookup the class variable */
	varnum = 0;
	for (lptr = xlivar(cls,CVARS)->n_listvalue;
    	     lptr != NULL;
    	     lptr = lptr->n_listnext)
	    if (lptr->n_listvalue == sym)
		return (xlcvar(cls,varnum));
	    else
		varnum++;
    }

    /* variable not found */
    return (NULL);
}

/* checkvar - check for an existing class or instance variable */
LOCAL int checkvar(cls,sym)
  struct node *cls,*sym;
{
    struct node *lptr;

    /* find the variable */
    for (; cls != NULL; cls = xlivar(cls,SUPERCLASS)->n_listvalue) {

	/* lookup the instance variable */
	for (lptr = xlivar(cls,IVARS)->n_listvalue;
    	     lptr != NULL;
    	     lptr = lptr->n_listnext)
	    if (lptr->n_listvalue == sym)
		return (TRUE);

	/* lookup the class variable */
	for (lptr = xlivar(cls,CVARS)->n_listvalue;
    	     lptr != NULL;
    	     lptr = lptr->n_listnext)
	    if (lptr->n_listvalue == sym)
		return (TRUE);
    }

    /* variable not found */
    return (FALSE);
}

/* xlivar - get an instance variable */
struct node *xlivar(obj,num)
  struct node *obj; int num;
{
    struct node *ivar;

    /* get the instance variable */
    for (ivar = obj->n_obdata; num > 0; num--)
	if (ivar != NULL)
	    ivar = ivar->n_listnext;
	else
	    xlfail("bad instance variable list");

    /* return the instance variable */
    return (ivar);
}

/* xlcvar - get a class variable */
struct node *xlcvar(cls,num)
  struct node *cls; int num;
{
    struct node *cvar;

    /* get the class variable */
    for (cvar = xlivar(cls,CVALS)->n_listvalue; num > 0; num--)
	if (cvar != NULL)
	    cvar = cvar->n_listnext;
	else
	    xlfail("bad class variable list");

    /* return the class variable */
    return (cvar);
}

/* makelist - make a list of nodes */
LOCAL struct node *makelist(cnt)
  int cnt;
{
    struct node *oldstk,list,*lnew;

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

    /* make the list */
    for (; cnt > 0; cnt--) {
	lnew = newnode(LIST);
	lnew->n_listnext = list.n_ptr;
	list.n_ptr = lnew;
    }

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

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

/* xloinit - object function initialization routine */
xloinit()
{
    /* don't confuse the garbage collector */
    class = NULL;
    object = NULL;

    /* enter the object related symbols */
    new		= xlsenter("new");
    isnew	= xlsenter("isnew");
    self	= xlsenter("self");
    msgclass	= xlsenter("msgclass");

    /* create the 'Class' object */
    class = xlclass("Class",CLASSSIZE);
    class->n_obclass = class;

    /* create the 'Object' object */
    object = xlclass("Object",0);

    /* finish initializing 'class' */
    xlivar(class,SUPERCLASS)->n_listvalue = object;
    xladdivar(class,"ivartotal");	/* ivar number 6 */
    xladdivar(class,"ivarcnt");		/* ivar number 5 */
    xladdivar(class,"superclass");	/* ivar number 4 */
    xladdivar(class,"cvals");		/* ivar number 3 */
    xladdivar(class,"cvars");		/* ivar number 2 */
    xladdivar(class,"ivars");		/* ivar number 1 */
    xladdivar(class,"messages");	/* ivar number 0 */
    xladdmsg(class,"new",mnew);
    xladdmsg(class,"answer",answer);
    xladdmsg(class,"ivars",mivars);
    xladdmsg(class,"cvars",mcvars);
    xladdmsg(class,"isnew",misnew);

    /* finish initializing 'object' */
    xladdmsg(object,"class",getclass);
    xladdmsg(object,"show",obshow);
    xladdmsg(object,"isnew",defisnew);
    xladdmsg(object,"sendsuper",sendsuper);
}
!Funky!Stuff!
exit 0
-- 
John Woods, Charles River Data Systems
decvax!frog!john, mit-eddie!jfw, JFW%mit-ccc@MIT-XX

When your puppy goes off in another room,
is it because of the explosive charge?