Dave Betz' XLISP 1.2 (The Real Thing) Part 4/5
John Woods
jfw at mit-eddie.UUCP
Mon Feb 4 04:29:23 AEST 1985
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 at MIT-XX
When your puppy goes off in another room,
is it because of the explosive charge?
More information about the Comp.sources.unix
mailing list