jfw@mit-eddie.UUCP (John Woods) (02/03/85)
[ Replace this line with your bug ]
I am FINALLY getting around to posting Dave Betz' XLISP 1.2 (his newest version,
which has little to do with my 1.2 version). I haven't done anything with it
at all yet (including compiling it...), and he's asked me to send changes to
him rather than posting them, to lessen the general confusion.
There are 5 shar files, of which this is the first. Forgive the file names,
but the only interchange medium we shared was CP/M floppies...
echo extract with sh, not csh
echo x PT.LSP
cat > PT.LSP << '!Funky!Stuff!'
; This is a sample XLISP program.
; It implements a simple form of programmable turtle for VT100 compatible
; terminals.
; To run it:
; A>xlisp pt
; This should cause the screen to be cleared and two turtles to appear.
; They should each execute their simple programs and then the prompt
; should return. Look at the code to see how all of this works.
; Clear the screen
(defun clear ()
(princ "\e[H\e[J"))
; Move the cursor
(defun setpos (x y)
(princ "\e[") (princ y) (princ ";") (princ x) (princ "H"))
; Kill the remainder of the line
(defun kill ()
(princ "\e[K"))
; Move the cursor to the currently set bottom position and clear the line
; under it
(defun bottom ()
(setpos bx (+ by 1))
(kill)
(setpos bx by)
(kill))
; Clear the screen and go to the bottom
(defun cb ()
(clear)
(bottom))
; ::::::::::::
; :: Turtle ::
; ::::::::::::
; Define "Turtle" class
(setq Turtle (Class 'new))
; Define instance variables
(Turtle 'ivars '(xpos ypos char))
; Answer "isnew" by initing a position and char and displaying.
(Turtle 'answer 'isnew '() '(
(setq xpos (setq newx (+ newx 1)))
(setq ypos 12)
(setq char "*")
(self 'display)
self))
; Message "display" prints its char at its current position
(Turtle 'answer 'display '() '(
(setpos xpos ypos)
(princ char)
(bottom)
self))
; Message "char" sets char to its arg and displays it
(Turtle 'answer 'char '(c) '(
(setq char c)
(self 'display)))
; Message "goto" goes to a new place after clearing old one
(Turtle 'answer 'goto '(x y) '(
(setpos xpos ypos) (princ " ")
(setq xpos x)
(setq ypos y)
(self 'display)))
; Message "up" moves up if not at top
(Turtle 'answer 'up '() '(
(if (> ypos 0)
(self 'goto xpos (- ypos 1))
(bottom))))
; Message "down" moves down if not at bottom
(Turtle 'answer 'down '() '(
(if (< ypos by)
(self 'goto xpos (+ ypos 1))
(bottom))))
; Message "right" moves right if not at right
(Turtle 'answer 'right '() '(
(if (< xpos 80)
(self 'goto (+ xpos 1) ypos)
(bottom))))
; Message "left" moves left if not at left
(Turtle 'answer 'left '() '(
(if (> xpos 0)
(self 'goto (- xpos 1) ypos)
(bottom))))
; :::::::::::::
; :: PTurtle ::
; :::::::::::::
; Define "DPurtle" programable turtle class
(setq PTurtle (Class 'new Turtle))
; Define instance variables
(PTurtle 'ivars '(prog pc))
; Message "program" stores a program
(PTurtle 'answer 'program '(p) '(
(setq prog p)
(setq pc prog)
self))
; Message "step" executes a single program step
(PTurtle 'answer 'step '() '(
(if (null pc)
(setq pc prog))
(if pc
(progn (self (car pc))
(setq pc (cdr pc))))
self))
; Message "step:" steps each turtle program n times
(PTurtle 'answer 'step: '(n) '(
(repeat n (self 'step))
self))
; ::::::::::::::
; :: PTurtles ::
; ::::::::::::::
; Define "PTurtles" class
(setq PTurtles (Class 'new))
; Define instance variables
(PTurtles 'ivars '(turtles))
; Message "make" makes a programable turtle and adds it to the collection
(PTurtles 'answer 'make '(x y &aux newturtle) '(
(setq newturtle (PTurtle 'new))
(newturtle 'goto x y)
(setq turtles (cons newturtle turtles))
newturtle))
; Message "step" steps each turtle program once
(PTurtles 'answer 'step '() '(
(mapcar '(lambda (turtle) (turtle 'step)) turtles)
self))
; Message "step:" steps each turtle program n times
(PTurtles 'answer 'step: '(n) '(
(repeat n (self 'step))
self))
; Initialize things and start up
(setq bx 0)
(setq by 20)
(setq newx 0)
; Create some programmable turtles
(cb)
(setq turtles (PTurtles 'new))
(setq t1 (turtles 'make 40 10))
(setq t2 (turtles 'make 41 10))
(t1 'program '(left right up down))
(t2 'program '(right left down up))
!Funky!Stuff!
echo x XLBFUN.C
cat > XLBFUN.C << '!Funky!Stuff!'
/* xlbfun.c - xlisp basic 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_lambda,*s_nlambda,*s_unbound;
/* local variables */
static char gsprefix[STRMAX+1] = { 'G',0 };
static char gsnumber = 1;
/* forward declarations */
FORWARD struct node *defun();
/* xeval - the builtin function 'eval' */
struct node *xeval(args)
struct node *args;
{
struct node *oldstk,expr,*val;
/* create a new stack frame */
oldstk = xlsave(&expr,NULL);
/* get the expression to evaluate */
expr.n_ptr = xlarg(&args);
xllastarg(args);
/* evaluate the expression */
val = xleval(expr.n_ptr);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the expression evaluated */
return (val);
}
/* xapply - the builtin function 'apply' */
struct node *xapply(args)
struct node *args;
{
struct node *oldstk,fun,arglist,*val;
/* create a new stack frame */
oldstk = xlsave(&fun,&arglist,NULL);
/* get the function and argument list */
fun.n_ptr = xlarg(&args);
arglist.n_ptr = xlarg(&args);
xllastarg(args);
/* if the function is a symbol, get its value */
if (fun.n_ptr && fun.n_ptr->n_type == SYM)
fun.n_ptr = xleval(fun.n_ptr);
/* apply the function to the arguments */
val = xlapply(fun.n_ptr,arglist.n_ptr);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the expression evaluated */
return (val);
}
/* xfuncall - the builtin function 'funcall' */
struct node *xfuncall(args)
struct node *args;
{
struct node *oldstk,fun,arglist,*val;
/* create a new stack frame */
oldstk = xlsave(&fun,&arglist,NULL);
/* get the function and argument list */
fun.n_ptr = xlarg(&args);
arglist.n_ptr = args;
/* if the function is a symbol, get its value */
if (fun.n_ptr && fun.n_ptr->n_type == SYM)
fun.n_ptr = xleval(fun.n_ptr);
/* apply the function to the arguments */
val = xlapply(fun.n_ptr,arglist.n_ptr);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the expression evaluated */
return (val);
}
/* xquote - builtin function to quote an expression */
struct node *xquote(args)
struct node *args;
{
/* make sure there is exactly one argument */
if (args == NULL || args->n_listnext != NULL)
xlfail("incorrect number of arguments");
/* return the quoted expression */
return (args->n_listvalue);
}
/* xset - builtin function set */
struct node *xset(args)
struct node *args;
{
struct node *sym,*val;
/* get the symbol and new value */
sym = xlmatch(SYM,&args);
val = xlarg(&args);
xllastarg(args);
/* assign the symbol the value of argument 2 and the return value */
assign(sym,val);
/* return the result value */
return (val);
}
/* xsetq - builtin function setq */
struct node *xsetq(args)
struct node *args;
{
struct node *oldstk,arg,sym,val;
/* create a new stack frame */
oldstk = xlsave(&arg,&sym,&val,NULL);
/* initialize */
arg.n_ptr = args;
/* get the symbol and new value */
sym.n_ptr = xlmatch(SYM,&arg.n_ptr);
val.n_ptr = xlevarg(&arg.n_ptr);
xllastarg(arg.n_ptr);
/* assign the symbol the value of argument 2 and the return value */
assign(sym.n_ptr,val.n_ptr);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result value */
return (val.n_ptr);
}
/* xdefun - builtin function 'defun' */
struct node *xdefun(args)
struct node *args;
{
return (defun(args,s_lambda));
}
/* xndefun - builtin function 'ndefun' */
struct node *xndefun(args)
struct node *args;
{
return (defun(args,s_nlambda));
}
/* defun - internal function definition routine */
LOCAL struct node *defun(args,type)
struct node *args,*type;
{
struct node *oldstk,sym,fargs,fun;
/* create a new stack frame */
oldstk = xlsave(&sym,&fargs,&fun,NULL);
/* get the function symbol and formal argument list */
sym.n_ptr = xlmatch(SYM,&args);
fargs.n_ptr = xlmatch(LIST,&args);
/* create a new function definition */
fun.n_ptr = newnode(LIST);
fun.n_ptr->n_listvalue = type;
fun.n_ptr->n_listnext = newnode(LIST);
fun.n_ptr->n_listnext->n_listvalue = fargs.n_ptr;
fun.n_ptr->n_listnext->n_listnext = args;
/* make the symbol point to a new function definition */
assign(sym.n_ptr,fun.n_ptr);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the function symbol */
return (sym.n_ptr);
}
/* xgensym - generate a symbol */
struct node *xgensym(args)
struct node *args;
{
char sym[STRMAX+1];
struct node *x;
/* get the prefix or number */
if (args) {
x = xlarg(&args);
switch (x->n_type) {
case SYM:
strcpy(gsprefix,xlsymname(x));
break;
case STR:
strcpy(gsprefix,x->n_str);
break;
case INT:
gsnumber = x->n_int;
break;
default:
xlfail("bad argument type");
}
}
xllastarg(args);
/* create the pname of the new symbol */
sprintf(sym,"%s%d",gsprefix,gsnumber++);
/* make a symbol with this print name */
return (xlmakesym(sym,DYNAMIC));
}
/* xintern - intern a symbol */
struct node *xintern(args)
struct node *args;
{
struct node *oldstk,sym;
/* create a new stack frame */
oldstk = xlsave(&sym,NULL);
/* get the symbol to intern */
sym.n_ptr = xlmatch(SYM,&args);
xllastarg(args);
/* intern the symbol */
sym.n_ptr = xlintern(sym.n_ptr);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the symbol */
return (sym.n_ptr);
}
/* xsymname - get the print name of a symbol */
struct node *xsymname(args)
struct node *args;
{
struct node *sym;
/* get the symbol */
sym = xlmatch(SYM,&args);
xllastarg(args);
/* return the print name */
return (sym->n_symplist->n_listvalue);
}
/* xsymplist - get the property list of a symbol */
struct node *xsymplist(args)
struct node *args;
{
struct node *sym;
/* get the symbol */
sym = xlmatch(SYM,&args);
xllastarg(args);
/* return the property list */
return (sym->n_symplist->n_listnext);
}
/* xget - get the value of a property */
struct node *xget(args)
struct node *args;
{
struct node *sym,*prp;
/* get the symbol and property */
sym = xlmatch(SYM,&args);
prp = xlmatch(SYM,&args);
xllastarg(args);
/* retrieve the property value */
return (xlgetprop(sym,prp));
}
/* xputprop - put a property value onto a property list */
struct node *xputprop(args)
struct node *args;
{
struct node *oldstk,sym,val,prp;
/* create a new stack frame */
oldstk = xlsave(&sym,&val,&prp,NULL);
/* get the symbol, value and property */
sym.n_ptr = xlmatch(SYM,&args);
val.n_ptr = xlarg(&args);
prp.n_ptr = xlmatch(SYM,&args);
xllastarg(args);
/* put the property onto the property list */
xlputprop(sym.n_ptr,val.n_ptr,prp.n_ptr);
/* restore the previouse stack frame */
xlstack = oldstk;
/* return the value */
return (val.n_ptr);
}
/* xremprop - remove a property value from a property list */
struct node *xremprop(args)
struct node *args;
{
struct node *sym,*prp;
/* get the symbol and property */
sym = xlmatch(SYM,&args);
prp = xlmatch(SYM,&args);
xllastarg(args);
/* remove the property */
xlremprop(sym,prp);
/* return nil */
return (NULL);
}
!Funky!Stuff!
echo x XLBIND.C
cat > XLBIND.C << '!Funky!Stuff!'
/* xlbind - xlisp symbol binding routines */
#ifdef AZTEC
#include "stdio.h"
#else
#include <stdio.h>
#endif
#include "xlisp.h"
/* global variables */
struct node *xlenv;
/* xlunbind - unbind symbols bound in this environment */
xlunbind(env)
struct node *env;
{
struct node *bnd;
/* unbind each symbol in the environment chain */
for (; xlenv != env; xlenv = xlenv->n_listnext) {
bnd = xlenv->n_listvalue;
bnd->n_bndsym->n_symvalue = bnd->n_bndvalue;
}
}
/* xlbind - bind a symbol to a value */
xlbind(sym,val)
struct node *sym,*val;
{
struct node *lptr,*bptr;
/* create a new environment list entry */
lptr = newnode(LIST);
lptr->n_listnext = xlenv;
xlenv = lptr;
/* create a new variable binding */
lptr->n_listvalue = bptr = newnode(LIST);
bptr->n_bndsym = sym;
bptr->n_bndvalue = val;
}
/* xlfixbindings - make a new set of bindings visible */
xlfixbindings(env)
struct node *env;
{
struct node *eptr,*bnd,*sym,*oldvalue;
/* fix the bound value of each symbol in the environment chain */
for (eptr = xlenv; eptr != env; eptr = eptr->n_listnext) {
bnd = eptr->n_listvalue;
sym = bnd->n_bndsym;
oldvalue = sym->n_symvalue;
sym->n_symvalue = bnd->n_bndvalue;
bnd->n_bndvalue = oldvalue;
}
}
!Funky!Stuff!
echo x XLCONT.C
cat > XLCONT.C << '!Funky!Stuff!'
/* xlcont - xlisp control builtin functions */
#ifdef AZTEC
#include "stdio.h"
#else
#include <stdio.h>
#endif
#include "xlisp.h"
/* external variables */
extern struct node *xlstack,*xlenv;
extern struct node *true;
/* xcond - builtin function cond */
struct node *xcond(args)
struct node *args;
{
struct node *oldstk,arg,list,*val;
/* create a new stack frame */
oldstk = xlsave(&arg,&list,NULL);
/* initialize */
arg.n_ptr = args;
/* initialize the return value */
val = NULL;
/* find a predicate that is true */
while (arg.n_ptr != NULL) {
/* get the next conditional */
list.n_ptr = xlmatch(LIST,&arg.n_ptr);
/* evaluate the predicate part */
if (xlevarg(&list.n_ptr) != NULL) {
/* evaluate each expression */
while (list.n_ptr != NULL)
val = xlevarg(&list.n_ptr);
/* exit the loop */
break;
}
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the value */
return (val);
}
/* xand - builtin function 'and; */
struct node *xand(args)
struct node *args;
{
struct node *oldstk,arg,*val;
/* create a new stack frame */
oldstk = xlsave(&arg,NULL);
/* initialize */
arg.n_ptr = args;
val = true;
/* evaluate each argument */
while (arg.n_ptr != NULL)
/* get the next argument */
if ((val = xlevarg(&arg.n_ptr)) == NULL)
break;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result value */
return (val);
}
/* xor - builtin function 'or' */
struct node *xor(args)
struct node *args;
{
struct node *oldstk,arg,*val;
/* create a new stack frame */
oldstk = xlsave(&arg,NULL);
/* initialize */
arg.n_ptr = args;
val = NULL;
/* evaluate each argument */
while (arg.n_ptr != NULL)
if ((val = xlevarg(&arg.n_ptr)) != NULL)
break;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result value */
return (val);
}
/* xlet - establish some local bindings and execute some code */
struct node *xlet(args)
struct node *args;
{
struct node *oldstk,*oldenv,arg,bnd,sym,val,*p;
/* create a new stack frame */
oldstk = xlsave(&arg,&bnd,&sym,&val,NULL);
/* initialize */
arg.n_ptr = args;
/* get the list of bindings */
bnd.n_ptr = xlmatch(LIST,&arg.n_ptr);
/* initialize the local environment */
oldenv = xlenv;
/* bind each symbol in the list of bindings */
while (bnd.n_ptr && bnd.n_ptr->n_type == LIST) {
/* get the next binding */
p = bnd.n_ptr->n_listvalue;
/* check its type */
switch (p->n_type) {
case SYM:
sym.n_ptr = p;
val.n_ptr = NULL;
break;
case LIST:
sym.n_ptr = p->n_listvalue;
val.n_ptr = p->n_listnext->n_listvalue;
val.n_ptr = xleval(val.n_ptr);
break;
default:
xlfail("bad binding");
}
/* bind the value to the symbol */
xlbind(sym.n_ptr,val.n_ptr);
/* get next binding */
bnd.n_ptr = bnd.n_ptr->n_listnext;
}
/* fix the bindings */
xlfixbindings(oldenv);
/* execute the code */
for (val.n_ptr = NULL; arg.n_ptr; )
val.n_ptr = xlevarg(&arg.n_ptr);
/* unbind the arguments */
xlunbind(oldenv);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result */
return (val.n_ptr);
}
/* xwhile - builtin function while */
struct node *xwhile(args)
struct node *args;
{
struct node *oldstk,farg,arg,*val;
/* create a new stack frame */
oldstk = xlsave(&farg,&arg,NULL);
/* initialize */
farg.n_ptr = arg.n_ptr = args;
/* loop until test fails */
val = NULL;
for (; TRUE; arg.n_ptr = farg.n_ptr) {
/* evaluate the test expression */
if (xlevarg(&arg.n_ptr) == NULL)
break;
/* evaluate each remaining argument */
while (arg.n_ptr != NULL)
val = xlevarg(&arg.n_ptr);
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the last test expression value */
return (val);
}
/* xrepeat - builtin function repeat */
struct node *xrepeat(args)
struct node *args;
{
struct node *oldstk,farg,arg,*val;
int cnt;
/* create a new stack frame */
oldstk = xlsave(&farg,&arg,NULL);
/* initialize */
arg.n_ptr = args;
/* evaluate the repeat count */
cnt = xlevmatch(INT,&arg.n_ptr)->n_int;
/* save the first expression to repeat */
farg.n_ptr = arg.n_ptr;
/* loop until test fails */
val = NULL;
for (; cnt > 0; cnt--) {
/* evaluate each remaining argument */
while (arg.n_ptr != NULL)
val = xlevarg(&arg.n_ptr);
/* restore pointer to first expression */
arg.n_ptr = farg.n_ptr;
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the last test expression value */
return (val);
}
/* xif - builtin function 'if' */
struct node *xif(args)
struct node *args;
{
struct node *oldstk,testexpr,thenexpr,elseexpr,*val;
/* create a new stack frame */
oldstk = xlsave(&testexpr,&thenexpr,&elseexpr,NULL);
/* get the test expression, then clause and else clause */
testexpr.n_ptr = xlarg(&args);
thenexpr.n_ptr = xlarg(&args);
elseexpr.n_ptr = (args ? xlarg(&args) : NULL);
xllastarg(args);
/* evaluate the appropriate clause */
val = xleval(xleval(testexpr.n_ptr) ? thenexpr.n_ptr : elseexpr.n_ptr);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the last value */
return (val);
}
/* xprogn - builtin function 'progn' */
struct node *xprogn(args)
struct node *args;
{
struct node *oldstk,arg,*val;
int cnt;
/* create a new stack frame */
oldstk = xlsave(&arg,NULL);
/* initialize */
arg.n_ptr = args;
/* evaluate each remaining argument */
for (val = NULL; arg.n_ptr != NULL; )
val = xlevarg(&arg.n_ptr);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the last test expression value */
return (val);
}
!Funky!Stuff!
echo x XLDMEM.C
cat > XLDMEM.C << '!Funky!Stuff!'
/* xldmem - xlisp dynamic memory management routines */
#ifdef AZTEC
#include "stdio.h"
#else
#include <stdio.h>
#endif
#include "xlisp.h"
/* useful definitions */
#define ALLOCSIZE (sizeof(struct segment) + (anodes-1) * sizeof(struct node))
/* memory segment structure definition */
struct segment {
int sg_size;
struct segment *sg_next;
struct node sg_nodes[1];
};
/* external variables */
extern struct node *oblist;
extern struct node *xlstack;
extern struct node *xlenv;
/* external procedures */
extern char *malloc();
extern char *calloc();
/* local variables */
int anodes,nnodes,nsegs,nfree,gccalls;
static struct segment *segs;
static struct node *fnodes;
/* newnode - allocate a new node */
struct node *newnode(type)
int type;
{
struct node *nnode;
/* get a free node */
if ((nnode = fnodes) == NULL) {
gc();
if ((nnode = fnodes) == NULL)
xlfail("insufficient node space");
}
/* unlink the node from the free list */
fnodes = nnode->n_right;
nfree -= 1;
/* initialize the new node */
nnode->n_type = type;
nnode->n_right = NULL;
/* return the new node */
return (nnode);
}
/* stralloc - allocate memory for a string adding a byte for the terminator */
char *stralloc(size)
int size;
{
char *sptr;
/* allocate memory for the string copy */
if ((sptr = malloc(size+1)) == NULL) {
gc();
if ((sptr = malloc(size+1)) == NULL)
xlfail("insufficient string space");
}
/* return the new string memory */
return (sptr);
}
/* strsave - generate a dynamic copy of a string */
char *strsave(str)
char *str;
{
char *sptr;
/* create a new string */
sptr = stralloc(strlen(str));
strcpy(sptr,str);
/* return the new string */
return (sptr);
}
/* strfree - free string memory */
strfree(str)
char *str;
{
free(str);
}
/* gc - garbage collect */
gc()
{
struct node *p;
/* mark all accessible nodes */
mark(oblist);
mark(xlenv);
/* mark the evaluation stack */
for (p = xlstack; p; p = p->n_listnext)
mark(p->n_listvalue);
/* sweep memory collecting all unmarked nodes */
sweep();
/* if there's still nothing available, allocate more memory */
if (fnodes == NULL)
addseg();
/* count the gc call */
gccalls += 1;
}
/* mark - mark all accessible nodes */
LOCAL mark(ptr)
struct node *ptr;
{
struct node *this,*prev,*tmp;
/* just return on null */
if (ptr == NULL)
return;
/* initialize */
prev = NULL;
this = ptr;
/* mark this list */
while (TRUE) {
/* descend as far as we can */
while (TRUE) {
/* check for this node being marked */
if (this->n_flags & MARK)
break;
/* mark it and its descendants */
else {
/* mark the node */
this->n_flags |= MARK;
/* follow the left sublist if there is one */
if (left(this)) {
this->n_flags |= LEFT;
tmp = prev;
prev = this;
this = prev->n_left;
prev->n_left = tmp;
}
else if (right(this)) {
this->n_flags &= ~LEFT;
tmp = prev;
prev = this;
this = prev->n_right;
prev->n_right = tmp;
}
else
break;
}
}
/* backup to a point where we can continue descending */
while (TRUE) {
/* check for termination condition */
if (prev == NULL)
return;
/* check for coming from the left side */
if (prev->n_flags & LEFT)
if (right(prev)) {
prev->n_flags &= ~LEFT;
tmp = prev->n_left;
prev->n_left = this;
this = prev->n_right;
prev->n_right = tmp;
break;
}
else {
tmp = prev;
prev = tmp->n_left;
tmp->n_left = this;
this = tmp;
}
/* came from the right side */
else {
tmp = prev;
prev = tmp->n_right;
tmp->n_right = this;
this = tmp;
}
}
}
}
/* sweep - sweep all unmarked nodes and add them to the free list */
LOCAL sweep()
{
struct segment *seg;
struct node *p;
int n;
/* empty the free list */
fnodes = NULL;
nfree = 0;
/* add all unmarked nodes */
for (seg = segs; seg != NULL; seg = seg->sg_next) {
p = &seg->sg_nodes[0];
for (n = seg->sg_size; n--; p++)
if (!(p->n_flags & MARK)) {
switch (p->n_type) {
case STR:
if (p->n_strtype == DYNAMIC && p->n_str != NULL)
strfree(p->n_str);
break;
}
p->n_type = FREE;
p->n_flags = 0;
p->n_left = NULL;
p->n_right = fnodes;
fnodes = p;
nfree += 1;
}
else
p->n_flags &= ~(MARK | LEFT);
}
}
/* addseg - add a segment to the available memory */
int addseg()
{
struct segment *newseg;
struct node *p;
int n;
/* check for zero allocation */
if (anodes == 0)
return (FALSE);
/* allocate a new segment */
if ((newseg = (struct segment *) calloc(1,ALLOCSIZE)) != NULL) {
/* initialize the new segment */
newseg->sg_size = anodes;
newseg->sg_next = segs;
segs = newseg;
/* add each new node to the free list */
p = &newseg->sg_nodes[0];
for (n = anodes; n--; ) {
p->n_right = fnodes;
fnodes = p++;
}
/* update the statistics */
nnodes += anodes;
nfree += anodes;
nsegs += 1;
/* return successfully */
return (TRUE);
}
else
return (FALSE);
}
/* left - check for a left sublist */
LOCAL int left(n)
struct node *n;
{
switch (n->n_type) {
case SUBR:
case FSUBR:
case INT:
case STR:
case FPTR:
return (FALSE);
case SYM:
case LIST:
case OBJ:
return (n->n_left != NULL);
default:
printf("bad node type (%d) found during left scan\n",n->n_type);
exit();
}
}
/* right - check for a right sublist */
LOCAL int right(n)
struct node *n;
{
switch (n->n_type) {
case SUBR:
case FSUBR:
case INT:
case STR:
case FPTR:
return (FALSE);
case SYM:
case LIST:
case OBJ:
return (n->n_right != NULL);
default:
printf("bad node type (%d) found during right scan\n",n->n_type);
exit();
}
}
/* stats - print memory statistics */
stats()
{
printf("Nodes: %d\n",nnodes);
printf("Free nodes: %d\n",nfree);
printf("Segments: %d\n",nsegs);
printf("Allocate: %d\n",anodes);
printf("Collections: %d\n",gccalls);
}
/* xlminit - initialize the dynamic memory module */
xlminit()
{
/* initialize our internal variables */
anodes = NNODES;
nnodes = nsegs = nfree = gccalls = 0;
segs = fnodes = NULL;
/* initialize structures that are marked by the collector */
xlstack = xlenv = oblist = NULL;
}
!Funky!Stuff!
echo x XLEVAL.C
cat > XLEVAL.C << '!Funky!Stuff!'
/* xleval - xlisp evaluator */
#ifdef AZTEC
#include "stdio.h"
#include "setjmp.h"
#else
#include <stdio.h>
#include <setjmp.h>
#endif
#include "xlisp.h"
/* global variables */
struct node *xlstack;
/* trace stack */
static struct node *trace_stack[TDEPTH];
static int trace_pointer;
/* external variables */
extern jmp_buf *xljmpbuf;
extern struct node *xlenv;
extern struct node *s_lambda,*s_nlambda;
extern struct node *s_unbound;
extern struct node *s_stdout;
extern struct node *s_tracenable;
extern struct node *k_rest;
extern struct node *k_aux;
/* forward declarations */
FORWARD struct node *evform();
FORWARD struct node *evsym();
FORWARD struct node *evfun();
/* xleval - evaluate an xlisp expression */
struct node *xleval(expr)
struct node *expr;
{
/* evaluate null to itself */
if (expr == NULL)
return (NULL);
/* add trace entry */
tpush(expr);
/* check type of value */
switch (expr->n_type) {
case LIST:
expr = evform(expr);
break;
case SYM:
expr = evsym(expr);
break;
case INT:
case STR:
case SUBR:
case FSUBR:
break;
default:
xlfail("can't evaluate expression");
}
/* remove trace entry */
tpop();
/* return the value */
return (expr);
}
/* xlapply - apply a function to a list of arguments */
struct node *xlapply(fun,args)
struct node *fun,*args;
{
struct node *val;
/* check for a null function */
if (fun == NULL)
xlfail("null function");
/* evaluate the function */
switch (fun->n_type) {
case SUBR:
val = (*fun->n_subr)(args);
break;
case LIST:
if (fun->n_listvalue != s_lambda)
xlfail("bad function type");
val = evfun(fun,args);
break;
default:
xlfail("bad function");
}
/* return the result value */
return (val);
}
/* evform - evaluate a form */
LOCAL struct node *evform(nptr)
struct node *nptr;
{
struct node *oldstk,fun,args,*val,*type;
/* create a stack frame */
oldstk = xlsave(&fun,&args,NULL);
/* get the function and the argument list */
fun.n_ptr = nptr->n_listvalue;
args.n_ptr = nptr->n_listnext;
/* evaluate the first expression */
if ((fun.n_ptr = xleval(fun.n_ptr)) == NULL)
xlfail("null function");
/* evaluate the function */
switch (fun.n_ptr->n_type) {
case SUBR:
args.n_ptr = xlevlist(args.n_ptr);
case FSUBR:
val = (*fun.n_ptr->n_subr)(args.n_ptr);
break;
case LIST:
if ((type = fun.n_ptr->n_listvalue) == s_lambda)
args.n_ptr = xlevlist(args.n_ptr);
else if (type != s_nlambda)
xlfail("bad function type");
val = evfun(fun.n_ptr,args.n_ptr);
break;
case OBJ:
val = xlsend(fun.n_ptr,args.n_ptr);
break;
default:
xlfail("bad function");
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result value */
return (val);
}
/* xlevlist - evaluate a list of arguments */
struct node *xlevlist(args)
struct node *args;
{
struct node *oldstk,src,dst,*new,*last,*val;
/* create a stack frame */
oldstk = xlsave(&src,&dst,NULL);
/* initialize */
src.n_ptr = args;
/* evaluate each argument */
for (val = NULL; src.n_ptr; src.n_ptr = src.n_ptr->n_listnext) {
/* check this entry */
if (src.n_ptr->n_type != LIST)
xlfail("bad argument list");
/* allocate a new list entry */
new = newnode(LIST);
if (val)
last->n_listnext = new;
else
val = dst.n_ptr = new;
new->n_listvalue = xleval(src.n_ptr->n_listvalue);
last = new;
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the new list */
return (val);
}
/* evsym - evaluate a symbol */
LOCAL struct node *evsym(sym)
struct node *sym;
{
struct node *p;
/* check for a current object */
if ((p = xlobsym(sym)) != NULL)
return (p->n_listvalue);
else if ((p = sym->n_symvalue) == s_unbound)
xlfail("unbound variable");
else
return (p);
}
/* evfun - evaluate a function */
LOCAL struct node *evfun(fun,args)
struct node *fun,*args;
{
struct node *oldenv,*oldstk,cptr,*fargs,*val;
/* create a stack frame */
oldstk = xlsave(&cptr,NULL);
/* skip the function type */
if ((fun = fun->n_listnext) == NULL)
xlfail("bad function definition");
/* get the formal argument list */
if ((fargs = fun->n_listvalue) != NULL && fargs->n_type != LIST)
xlfail("bad formal argument list");
/* bind the formal parameters */
oldenv = xlenv;
xlabind(fargs,args);
xlfixbindings(oldenv);
/* execute the code */
for (cptr.n_ptr = fun->n_listnext; cptr.n_ptr != NULL; )
val = xlevarg(&cptr.n_ptr);
/* restore the environment */
xlunbind(oldenv);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result value */
return (val);
}
/* xlabind - bind the arguments for a function */
xlabind(fargs,aargs)
struct node *fargs,*aargs;
{
struct node *oldstk,farg,aarg,*arg;
/* create a stack frame */
oldstk = xlsave(&farg,&aarg,NULL);
/* initialize the pointers */
farg.n_ptr = fargs;
aarg.n_ptr = aargs;
/* evaluate and bind each argument */
while (farg.n_ptr != NULL && aarg.n_ptr != NULL) {
/* check for a keyword */
if (iskeyword(arg = farg.n_ptr->n_listvalue))
break;
/* bind the formal variable to the argument value */
xlbind(arg,aarg.n_ptr->n_listvalue);
/* move the argument list pointers ahead */
farg.n_ptr = farg.n_ptr->n_listnext;
aarg.n_ptr = aarg.n_ptr->n_listnext;
}
/* check for the '&rest' keyword */
if (farg.n_ptr && farg.n_ptr->n_listvalue == k_rest) {
farg.n_ptr = farg.n_ptr->n_listnext;
if (farg.n_ptr && (arg = farg.n_ptr->n_listvalue) && !iskeyword(arg))
xlbind(arg,aarg.n_ptr);
else
xlfail("symbol missing after &rest");
farg.n_ptr = farg.n_ptr->n_listnext;
aarg.n_ptr = NULL;
}
/* check for the '&aux' keyword */
if (farg.n_ptr && farg.n_ptr->n_listvalue == k_aux)
while ((farg.n_ptr = farg.n_ptr->n_listnext) != NULL)
xlbind(farg.n_ptr->n_listvalue,NULL);
/* make sure the correct number of arguments were supplied */
if (farg.n_ptr != aarg.n_ptr)
xlfail("incorrect number of arguments to a function");
/* restore the previous stack frame */
xlstack = oldstk;
}
/* iskeyword - check to see if a symbol is a keyword */
LOCAL int iskeyword(sym)
struct node *sym;
{
return (sym == k_rest || sym == k_aux);
}
/* xlsave - save nodes on the stack */
struct node *xlsave(n)
struct node *n;
{
struct node **nptr,*oldstk;
/* save the old stack pointer */
oldstk = xlstack;
/* save each node */
for (nptr = &n; *nptr != NULL; nptr++) {
(*nptr)->n_type = LIST;
(*nptr)->n_listvalue = NULL;
(*nptr)->n_listnext = xlstack;
xlstack = *nptr;
}
/* return the old stack pointer */
return (oldstk);
}
/* xlfail - error handling routine */
xlfail(err)
char *err;
{
/* print the error message */
printf("error: %s\n",err);
/* flush the terminal input buffer */
xlflush();
/* unbind bound symbols */
xlunbind(NULL);
/* do the back trace */
if (s_tracenable->n_symvalue)
baktrace();
trace_pointer = -1;
/* restart */
longjmp(xljmpbuf,1);
}
/* tpush - add an entry to the trace stack */
LOCAL tpush(nptr)
struct node *nptr;
{
if (++trace_pointer < TDEPTH)
trace_stack[trace_pointer] = nptr;
}
/* tpop - pop an entry from the trace stack */
LOCAL tpop()
{
trace_pointer--;
}
/* baktrace - do a back trace */
LOCAL baktrace()
{
for (; trace_pointer >= 0; trace_pointer--)
if (trace_pointer < TDEPTH)
stdprint(trace_stack[trace_pointer]);
}
/* stdprint - print to standard output */
stdprint(expr)
struct node *expr;
{
xlprint(s_stdout->n_symvalue,expr,TRUE);
xlterpri(s_stdout->n_symvalue);
}
/* xleinit - initialize the evaluator */
xleinit()
{
/* initialize debugging stuff */
trace_pointer = -1;
}
!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?jfw@mit-eddie.UUCP (John Woods) (02/03/85)
[ Replace this line with your bug ]
Here is part two of the Newest XLISP 1.2 posting.
echo extract with sh, not csh
echo x XLFIO.C
cat > XLFIO.C << '!Funky!Stuff!'
/* xlfio.c - xlisp file i/o */
#ifdef AZTEC
#include "stdio.h"
#else
#include <stdio.h>
#include <ctype.h>
#endif
#include "xlisp.h"
/* external variables */
extern struct node *s_stdin,*s_stdout;
extern struct node *xlstack;
extern int xlfsize;
/* external routines */
extern FILE *fopen();
/* local variables */
static char buf[STRMAX+1];
/* forward declarations */
FORWARD struct node *printit();
FORWARD struct node *flatsize();
FORWARD struct node *explode();
FORWARD struct node *makesym();
FORWARD struct node *openit();
FORWARD struct node *getfile();
/* xread - read an expression */
struct node *xread(args)
struct node *args;
{
struct node *oldstk,fptr,eof,*val;
/* create a new stack frame */
oldstk = xlsave(&fptr,&eof,NULL);
/* get file pointer and eof value */
fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
eof.n_ptr = (args ? xlarg(&args) : NULL);
xllastarg(args);
/* read an expression */
if (!xlread(fptr.n_ptr,&val))
val = eof.n_ptr;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the expression */
return (val);
}
/* xprint - builtin function 'print' */
struct node *xprint(args)
struct node *args;
{
return (printit(args,TRUE,TRUE));
}
/* xprin1 - builtin function 'prin1' */
struct node *xprin1(args)
struct node *args;
{
return (printit(args,TRUE,FALSE));
}
/* xprinc - builtin function princ */
struct node *xprinc(args)
struct node *args;
{
return (printit(args,FALSE,FALSE));
}
/* xterpri - terminate the current print line */
struct node *xterpri(args)
struct node *args;
{
struct node *fptr;
/* get file pointer */
fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
xllastarg(args);
/* terminate the print line and return nil */
xlterpri(fptr);
return (NULL);
}
/* printit - common print function */
LOCAL struct node *printit(args,pflag,tflag)
struct node *args; int pflag,tflag;
{
struct node *oldstk,fptr,val;
/* create a new stack frame */
oldstk = xlsave(&fptr,&val,NULL);
/* get expression to print and file pointer */
val.n_ptr = xlarg(&args);
fptr.n_ptr = (args ? getfile(&args) : s_stdout->n_symvalue);
xllastarg(args);
/* print the value */
xlprint(fptr.n_ptr,val.n_ptr,pflag);
/* terminate the print line if necessary */
if (tflag)
xlterpri(fptr.n_ptr);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result */
return (val.n_ptr);
}
/* xflatsize - compute the size of a printed representation using prin1 */
struct node *xflatsize(args)
struct node *args;
{
return (flatsize(args,TRUE));
}
/* xflatc - compute the size of a printed representation using princ */
struct node *xflatc(args)
struct node *args;
{
return (flatsize(args,FALSE));
}
/* flatsize - compute the size of a printed expression */
LOCAL struct node *flatsize(args,pflag)
struct node *args; int pflag;
{
struct node *oldstk,val;
/* create a new stack frame */
oldstk = xlsave(&val,NULL);
/* get the expression */
val.n_ptr = xlarg(&args);
xllastarg(args);
/* print the value to compute its size */
xlfsize = 0;
xlprint(NULL,val.n_ptr,pflag);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the length of the expression */
val.n_ptr = newnode(INT);
val.n_ptr->n_int = xlfsize;
return (val.n_ptr);
}
/* xexplode - explode an expression */
struct node *xexplode(args)
struct node *args;
{
return (explode(args,TRUE));
}
/* xexplc - explode an expression using princ */
struct node *xexplc(args)
struct node *args;
{
return (explode(args,FALSE));
}
/* explode - internal explode routine */
LOCAL struct node *explode(args,pflag)
struct node *args; int pflag;
{
struct node *oldstk,val,strm;
/* create a new stack frame */
oldstk = xlsave(&val,&strm,NULL);
/* get the expression */
val.n_ptr = xlarg(&args);
xllastarg(args);
/* create a stream */
strm.n_ptr = newnode(LIST);
/* print the value into the stream */
xlprint(strm.n_ptr,val.n_ptr,pflag);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the list of characters */
return (strm.n_ptr->n_listvalue);
}
/* ximplode - implode a list of characters into an expression */
struct node *ximplode(args)
struct node *args;
{
return (makesym(args,TRUE));
}
/* xmaknam - implode a list of characters into an uninterned symbol */
struct node *xmaknam(args)
struct node *args;
{
return (makesym(args,FALSE));
}
/* makesym - internal implode routine */
LOCAL struct node *makesym(args,intflag)
struct node *args; int intflag;
{
struct node *list,*val;
char *p;
/* get the list */
list = xlarg(&args);
xllastarg(args);
/* assemble the symbol's pname */
for (p = buf; list && list->n_type == LIST; list = list->n_listnext) {
if ((val = list->n_listvalue) == NULL || val->n_type != INT)
xlfail("bad character list");
if ((int)(p - buf) < STRMAX)
*p++ = val->n_int;
}
*p = 0;
/* create a symbol */
val = (intflag ? xlenter(buf,DYNAMIC) : xlmakesym(buf,DYNAMIC));
/* return the symbol */
return (val);
}
/* xopeni - open an input file */
struct node *xopeni(args)
struct node *args;
{
return (openit(args,"r"));
}
/* xopeno - open an output file */
struct node *xopeno(args)
struct node *args;
{
return (openit(args,"w"));
}
/* openit - common file open routine */
LOCAL struct node *openit(args,mode)
struct node *args; char *mode;
{
struct node *fname,*val;
FILE *fp;
/* get the file name */
fname = xlmatch(STR,&args);
xllastarg(args);
/* try to open the file */
if ((fp = fopen(fname->n_str,mode)) != NULL) {
val = newnode(FPTR);
val->n_fp = fp;
val->n_savech = 0;
}
else
val = NULL;
/* return the file pointer */
return (val);
}
/* xclose - close a file */
struct node *xclose(args)
struct node *args;
{
struct node *fptr;
/* get file pointer */
fptr = xlmatch(FPTR,&args);
xllastarg(args);
/* make sure the file exists */
if (fptr->n_fp == NULL)
xlfail("file not open");
/* close the file */
fclose(fptr->n_fp);
fptr->n_fp = NULL;
/* return nil */
return (NULL);
}
/* xrdchar - read a character from a file */
struct node *xrdchar(args)
struct node *args;
{
struct node *fptr,*val;
int ch;
/* get file pointer */
fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
xllastarg(args);
/* get character and check for eof */
if ((ch = xlgetc(fptr)) == EOF)
val = NULL;
else {
val = newnode(INT);
val->n_int = ch;
}
/* return the character */
return (val);
}
/* xpkchar - peek at a character from a file */
struct node *xpkchar(args)
struct node *args;
{
struct node *flag,*fptr,*val;
int ch;
/* peek flag and get file pointer */
flag = (args ? xlarg(&args) : NULL);
fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
xllastarg(args);
/* skip leading white space and get a character */
if (flag)
while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
xlgetc(fptr);
else
ch = xlpeek(fptr);
/* check for eof */
if (ch == EOF)
val = NULL;
else {
val = newnode(INT);
val->n_int = ch;
}
/* return the character */
return (val);
}
/* xwrchar - write a character to a file */
struct node *xwrchar(args)
struct node *args;
{
struct node *fptr,*chr;
/* get the character and file pointer */
chr = xlmatch(INT,&args);
fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
xllastarg(args);
/* put character to the file */
xlputc(fptr,chr->n_int);
/* return the character */
return (chr);
}
/* xreadline - read a line from a file */
struct node *xreadline(args)
struct node *args;
{
struct node *oldstk,fptr,str;
char *p,*sptr;
int len,ch;
/* create a new stack frame */
oldstk = xlsave(&fptr,&str,NULL);
/* get file pointer */
fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
xllastarg(args);
/* make a string node */
str.n_ptr = newnode(STR);
str.n_ptr->n_strtype = DYNAMIC;
/* get character and check for eof */
len = 0; p = buf;
while ((ch = xlgetc(fptr.n_ptr)) != EOF && ch != '\n') {
/* check for buffer overflow */
if ((int)(p - buf) == STRMAX) {
*p = 0;
sptr = stralloc(len + STRMAX); *sptr = 0;
if (len) {
strcpy(sptr,str.n_ptr->n_str);
strfree(str.n_ptr->n_str);
}
str.n_ptr->n_str = sptr;
strcat(sptr,buf);
len += STRMAX;
p = buf;
}
/* store the character */
*p++ = ch;
}
/* check for end of file */
if (len == 0 && p == buf && ch == EOF) {
xlstack = oldstk;
return (NULL);
}
/* append the last substring */
*p = 0;
sptr = stralloc(len + (int)(p - buf)); *sptr = 0;
if (len) {
strcpy(sptr,str.n_ptr->n_str);
strfree(str.n_ptr->n_str);
}
str.n_ptr->n_str = sptr;
strcat(sptr,buf);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the string */
return (str.n_ptr);
}
/* getfile - get a file or stream */
LOCAL struct node *getfile(pargs)
struct node **pargs;
{
struct node *arg;
/* get a file or stream (cons) or nil */
if (arg = xlarg(pargs)) {
if (arg->n_type == FPTR) {
if (arg->n_fp == NULL)
xlfail("file closed");
}
else if (arg->n_type != LIST)
xlfail("bad file or stream");
}
return (arg);
}
!Funky!Stuff!
echo x XLFIO.C
cat > XLFIO.C << '!Funky!Stuff!'
/* xlfio.c - xlisp file i/o */
#ifdef AZTEC
#include "stdio.h"
#else
#include <stdio.h>
#include <ctype.h>
#endif
#include "xlisp.h"
/* external variables */
extern struct node *s_stdin,*s_stdout;
extern struct node *xlstack;
extern int xlfsize;
/* external routines */
extern FILE *fopen();
/* local variables */
static char buf[STRMAX+1];
/* forward declarations */
FORWARD struct node *printit();
FORWARD struct node *flatsize();
FORWARD struct node *explode();
FORWARD struct node *makesym();
FORWARD struct node *openit();
FORWARD struct node *getfile();
/* xread - read an expression */
struct node *xread(args)
struct node *args;
{
struct node *oldstk,fptr,eof,*val;
/* create a new stack frame */
oldstk = xlsave(&fptr,&eof,NULL);
/* get file pointer and eof value */
fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
eof.n_ptr = (args ? xlarg(&args) : NULL);
xllastarg(args);
/* read an expression */
if (!xlread(fptr.n_ptr,&val))
val = eof.n_ptr;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the expression */
return (val);
}
/* xprint - builtin function 'print' */
struct node *xprint(args)
struct node *args;
{
return (printit(args,TRUE,TRUE));
}
/* xprin1 - builtin function 'prin1' */
struct node *xprin1(args)
struct node *args;
{
return (printit(args,TRUE,FALSE));
}
/* xprinc - builtin function princ */
struct node *xprinc(args)
struct node *args;
{
return (printit(args,FALSE,FALSE));
}
/* xterpri - terminate the current print line */
struct node *xterpri(args)
struct node *args;
{
struct node *fptr;
/* get file pointer */
fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
xllastarg(args);
/* terminate the print line and return nil */
xlterpri(fptr);
return (NULL);
}
/* printit - common print function */
LOCAL struct node *printit(args,pflag,tflag)
struct node *args; int pflag,tflag;
{
struct node *oldstk,fptr,val;
/* create a new stack frame */
oldstk = xlsave(&fptr,&val,NULL);
/* get expression to print and file pointer */
val.n_ptr = xlarg(&args);
fptr.n_ptr = (args ? getfile(&args) : s_stdout->n_symvalue);
xllastarg(args);
/* print the value */
xlprint(fptr.n_ptr,val.n_ptr,pflag);
/* terminate the print line if necessary */
if (tflag)
xlterpri(fptr.n_ptr);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result */
return (val.n_ptr);
}
/* xflatsize - compute the size of a printed representation using prin1 */
struct node *xflatsize(args)
struct node *args;
{
return (flatsize(args,TRUE));
}
/* xflatc - compute the size of a printed representation using princ */
struct node *xflatc(args)
struct node *args;
{
return (flatsize(args,FALSE));
}
/* flatsize - compute the size of a printed expression */
LOCAL struct node *flatsize(args,pflag)
struct node *args; int pflag;
{
struct node *oldstk,val;
/* create a new stack frame */
oldstk = xlsave(&val,NULL);
/* get the expression */
val.n_ptr = xlarg(&args);
xllastarg(args);
/* print the value to compute its size */
xlfsize = 0;
xlprint(NULL,val.n_ptr,pflag);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the length of the expression */
val.n_ptr = newnode(INT);
val.n_ptr->n_int = xlfsize;
return (val.n_ptr);
}
/* xexplode - explode an expression */
struct node *xexplode(args)
struct node *args;
{
return (explode(args,TRUE));
}
/* xexplc - explode an expression using princ */
struct node *xexplc(args)
struct node *args;
{
return (explode(args,FALSE));
}
/* explode - internal explode routine */
LOCAL struct node *explode(args,pflag)
struct node *args; int pflag;
{
struct node *oldstk,val,strm;
/* create a new stack frame */
oldstk = xlsave(&val,&strm,NULL);
/* get the expression */
val.n_ptr = xlarg(&args);
xllastarg(args);
/* create a stream */
strm.n_ptr = newnode(LIST);
/* print the value into the stream */
xlprint(strm.n_ptr,val.n_ptr,pflag);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the list of characters */
return (strm.n_ptr->n_listvalue);
}
/* ximplode - implode a list of characters into an expression */
struct node *ximplode(args)
struct node *args;
{
return (makesym(args,TRUE));
}
/* xmaknam - implode a list of characters into an uninterned symbol */
struct node *xmaknam(args)
struct node *args;
{
return (makesym(args,FALSE));
}
/* makesym - internal implode routine */
LOCAL struct node *makesym(args,intflag)
struct node *args; int intflag;
{
struct node *list,*val;
char *p;
/* get the list */
list = xlarg(&args);
xllastarg(args);
/* assemble the symbol's pname */
for (p = buf; list && list->n_type == LIST; list = list->n_listnext) {
if ((val = list->n_listvalue) == NULL || val->n_type != INT)
xlfail("bad character list");
if ((int)(p - buf) < STRMAX)
*p++ = val->n_int;
}
*p = 0;
/* create a symbol */
val = (intflag ? xlenter(buf,DYNAMIC) : xlmakesym(buf,DYNAMIC));
/* return the symbol */
return (val);
}
/* xopeni - open an input file */
struct node *xopeni(args)
struct node *args;
{
return (openit(args,"r"));
}
/* xopeno - open an output file */
struct node *xopeno(args)
struct node *args;
{
return (openit(args,"w"));
}
/* openit - common file open routine */
LOCAL struct node *openit(args,mode)
struct node *args; char *mode;
{
struct node *fname,*val;
FILE *fp;
/* get the file name */
fname = xlmatch(STR,&args);
xllastarg(args);
/* try to open the file */
if ((fp = fopen(fname->n_str,mode)) != NULL) {
val = newnode(FPTR);
val->n_fp = fp;
val->n_savech = 0;
}
else
val = NULL;
/* return the file pointer */
return (val);
}
/* xclose - close a file */
struct node *xclose(args)
struct node *args;
{
struct node *fptr;
/* get file pointer */
fptr = xlmatch(FPTR,&args);
xllastarg(args);
/* make sure the file exists */
if (fptr->n_fp == NULL)
xlfail("file not open");
/* close the file */
fclose(fptr->n_fp);
fptr->n_fp = NULL;
/* return nil */
return (NULL);
}
/* xrdchar - read a character from a file */
struct node *xrdchar(args)
struct node *args;
{
struct node *fptr,*val;
int ch;
/* get file pointer */
fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
xllastarg(args);
/* get character and check for eof */
if ((ch = xlgetc(fptr)) == EOF)
val = NULL;
else {
val = newnode(INT);
val->n_int = ch;
}
/* return the character */
return (val);
}
/* xpkchar - peek at a character from a file */
struct node *xpkchar(args)
struct node *args;
{
struct node *flag,*fptr,*val;
int ch;
/* peek flag and get file pointer */
flag = (args ? xlarg(&args) : NULL);
fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
xllastarg(args);
/* skip leading white space and get a character */
if (flag)
while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
xlgetc(fptr);
else
ch = xlpeek(fptr);
/* check for eof */
if (ch == EOF)
val = NULL;
else {
val = newnode(INT);
val->n_int = ch;
}
/* return the character */
return (val);
}
/* xwrchar - write a character to a file */
struct node *xwrchar(args)
struct node *args;
{
struct node *fptr,*chr;
/* get the character and file pointer */
chr = xlmatch(INT,&args);
fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
xllastarg(args);
/* put character to the file */
xlputc(fptr,chr->n_int);
/* return the character */
return (chr);
}
/* xreadline - read a line from a file */
struct node *xreadline(args)
struct node *args;
{
struct node *oldstk,fptr,str;
char *p,*sptr;
int len,ch;
/* create a new stack frame */
oldstk = xlsave(&fptr,&str,NULL);
/* get file pointer */
fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
xllastarg(args);
/* make a string node */
str.n_ptr = newnode(STR);
str.n_ptr->n_strtype = DYNAMIC;
/* get character and check for eof */
len = 0; p = buf;
while ((ch = xlgetc(fptr.n_ptr)) != EOF && ch != '\n') {
/* check for buffer overflow */
if ((int)(p - buf) == STRMAX) {
*p = 0;
sptr = stralloc(len + STRMAX); *sptr = 0;
if (len) {
strcpy(sptr,str.n_ptr->n_str);
strfree(str.n_ptr->n_str);
}
str.n_ptr->n_str = sptr;
strcat(sptr,buf);
len += STRMAX;
p = buf;
}
/* store the character */
*p++ = ch;
}
/* check for end of file */
if (len == 0 && p == buf && ch == EOF) {
xlstack = oldstk;
return (NULL);
}
/* append the last substring */
*p = 0;
sptr = stralloc(len + (int)(p - buf)); *sptr = 0;
if (len) {
strcpy(sptr,str.n_ptr->n_str);
strfree(str.n_ptr->n_str);
}
str.n_ptr->n_str = sptr;
strcat(sptr,buf);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the string */
return (str.n_ptr);
}
/* getfile - get a file or stream */
LOCAL struct node *getfile(pargs)
struct node **pargs;
{
struct node *arg;
/* get a file or stream (cons) or nil */
if (arg = xlarg(pargs)) {
if (arg->n_type == FPTR) {
if (arg->n_fp == NULL)
xlfail("file closed");
}
else if (arg->n_type != LIST)
xlfail("bad file or stream");
}
return (arg);
}
!Funky!Stuff!
echo x XLFTAB.C
cat > XLFTAB.C << '!Funky!Stuff!'
/* xlftab.c - xlisp function table */
#ifdef AZTEC
#include "stdio.h"
#else
#include <stdio.h>
#endif
#include "xlisp.h"
/* external functions */
extern struct node
*xeval(),*xapply(),*xfuncall(),*xquote(),
*xset(),*xsetq(),*xdefun(),*xndefun(),
*xgensym(),*xintern(),*xsymname(),*xsymplist(),
*xget(),*xputprop(),*xremprop(),
*xcar(),*xcaar(),*xcadr(),*xcdr(),*xcdar(),*xcddr(),
*xcons(),*xlist(),*xappend(),*xreverse(),*xlast(),*xnth(),*xnthcdr(),
*xmember(),*xmemq(),*xassoc(),*xassq(),*xsubst(),*xsublis(),*xlength(),
*xmapcar(),*xmaplist(),
*xrplca(),*xrplcd(),*xnconc(),*xdelete(),*xdelq(),
*xatom(),*xsymbolp(),*xnumberp(),*xboundp(),*xnull(),*xlistp(),*xconsp(),
*xeq(),*xequal(),
*xcond(),*xand(),*xor(),*xlet(),*xif(),*xprogn(),
*xwhile(),*xrepeat(),
*xadd(),*xsub(),*xmul(),*xdiv(),*xrem(),*xminus(),*xmin(),*xmax(),*xabs(),
*xadd1(),*xsub1(),*xbitand(),*xbitior(),*xbitxor(),*xbitnot(),
*xlss(),*xleq(),*xeql(),*xneq(),*xgeq(),*xgtr(),
*xstrlen(),*xstrcat(),*xsubstr(),*xascii(),*xchr(),*xatoi(),*xitoa(),
*xread(),*xprint(),*xprin1(),*xprinc(),*xterpri(),
*xflatsize(),*xflatc(),*xexplode(),*xexplc(),*ximplode(),*xmaknam(),
*xopeni(),*xopeno(),*xclose(),*xrdchar(),*xpkchar(),*xwrchar(),*xreadline(),
*xload(),*xgc(),*xexpand(),*xalloc(),*xmem(),*xtype(),*xexit();
struct fdef ftab[] = {
/* evaluator functions */
"eval", SUBR, xeval,
"apply", SUBR, xapply,
"funcall", SUBR, xfuncall,
"quote", FSUBR, xquote,
/* symbol functions */
"set", SUBR, xset,
"setq", FSUBR, xsetq,
"defun", FSUBR, xdefun,
"ndefun", FSUBR, xndefun,
"gensym", SUBR, xgensym,
"intern", SUBR, xintern,
"symbol-name", SUBR, xsymname,
"symbol-plist", SUBR, xsymplist,
"get", SUBR, xget,
"putprop", SUBR, xputprop,
"remprop", SUBR, xremprop,
/* list functions */
"car", SUBR, xcar,
"caar", SUBR, xcaar,
"cadr", SUBR, xcadr,
"cdr", SUBR, xcdr,
"cdar", SUBR, xcdar,
"cddr", SUBR, xcddr,
"cons", SUBR, xcons,
"list", SUBR, xlist,
"append", SUBR, xappend,
"reverse", SUBR, xreverse,
"last", SUBR, xlast,
"nth", SUBR, xnth,
"nthcdr", SUBR, xnthcdr,
"member", SUBR, xmember,
"memq", SUBR, xmemq,
"assoc", SUBR, xassoc,
"assq", SUBR, xassq,
"subst", SUBR, xsubst,
"sublis", SUBR, xsublis,
"length", SUBR, xlength,
"mapcar", SUBR, xmapcar,
"maplist", SUBR, xmaplist,
/* destructive list functions */
"rplaca", SUBR, xrplca,
"rplacd", SUBR, xrplcd,
"nconc", SUBR, xnconc,
"delete", SUBR, xdelete,
"delq", SUBR, xdelq,
/* predicate functions */
"atom", SUBR, xatom,
"symbolp", SUBR, xsymbolp,
"numberp", SUBR, xnumberp,
"boundp", SUBR, xboundp,
"null", SUBR, xnull,
"not", SUBR, xnull,
"listp", SUBR, xlistp,
"consp", SUBR, xconsp,
"eq", SUBR, xeq,
"equal", SUBR, xequal,
/* control functions */
"cond", FSUBR, xcond,
"and", FSUBR, xand,
"or", FSUBR, xor,
"let", FSUBR, xlet,
"if", FSUBR, xif,
"progn", FSUBR, xprogn,
"while", FSUBR, xwhile,
"repeat", FSUBR, xrepeat,
/* arithmetic functions */
"+", SUBR, xadd,
"-", SUBR, xsub,
"*", SUBR, xmul,
"/", SUBR, xdiv,
"1+", SUBR, xadd1,
"1-", SUBR, xsub1,
"rem", SUBR, xrem,
"minus", SUBR, xminus,
"min", SUBR, xmin,
"max", SUBR, xmax,
"abs", SUBR, xabs,
/* bitwise logical functions */
"bit-and", SUBR, xbitand,
"bit-ior", SUBR, xbitior,
"bit-xor", SUBR, xbitxor,
"bit-not", SUBR, xbitnot,
/* numeric comparison functions */
"<", SUBR, xlss,
"<=", SUBR, xleq,
"=", SUBR, xeql,
"/=", SUBR, xneq,
">=", SUBR, xgeq,
">", SUBR, xgtr,
/* string functions */
"strlen", SUBR, xstrlen,
"strcat", SUBR, xstrcat,
"substr", SUBR, xsubstr,
"ascii", SUBR, xascii,
"chr", SUBR, xchr,
"atoi", SUBR, xatoi,
"itoa", SUBR, xitoa,
/* I/O functions */
"read", SUBR, xread,
"print", SUBR, xprint,
"prin1", SUBR, xprin1,
"princ", SUBR, xprinc,
"terpri", SUBR, xterpri,
"flatsize", SUBR, xflatsize,
"flatc", SUBR, xflatc,
"explode", SUBR, xexplode,
"explodec", SUBR, xexplc,
"implode", SUBR, ximplode,
"maknam", SUBR, xmaknam,
/* file I/O functions */
"openi", SUBR, xopeni,
"openo", SUBR, xopeno,
"close", SUBR, xclose,
"read-char", SUBR, xrdchar,
"peek-char", SUBR, xpkchar,
"write-char", SUBR, xwrchar,
"readline", SUBR, xreadline,
/* system functions */
"load", SUBR, xload,
"gc", SUBR, xgc,
"expand", SUBR, xexpand,
"alloc", SUBR, xalloc,
"mem", SUBR, xmem,
"type", SUBR, xtype,
"exit", SUBR, xexit,
0
};
!Funky!Stuff!
echo x XLINIT.C
cat > XLINIT.C << '!Funky!Stuff!'
/* xlinit.c - xlisp initialization module */
#ifdef AZTEC
#include "stdio.h"
#else
#include <stdio.h>
#endif
#include "xlisp.h"
/* global variables */
struct node *true;
struct node *s_quote;
struct node *s_lambda,*s_nlambda;
struct node *s_stdin,*s_stdout;
struct node *s_tracenable;
struct node *k_rest,*k_aux;
struct node *a_subr;
struct node *a_fsubr;
struct node *a_list;
struct node *a_sym;
struct node *a_int;
struct node *a_str;
struct node *a_obj;
struct node *a_fptr;
/* external variables */
extern struct fdef ftab[];
/* xlinit - xlisp initialization routine */
xlinit()
{
struct fdef *fptr;
struct node *sym;
/* initialize xlisp (must be in this order) */
xlminit(); /* initialize xldmem.c */
xlsinit(); /* initialize xlsym.c */
xleinit(); /* initialize xleval.c */
xloinit(); /* initialize xlobj.c */
/* enter the builtin functions */
for (fptr = ftab; fptr->f_name; fptr++)
xlsubr(fptr->f_name,fptr->f_type,fptr->f_fcn);
/* enter the 't' symbol */
true = xlsenter("t");
true->n_symvalue = true;
/* enter some important symbols */
s_quote = xlsenter("quote");
s_lambda = xlsenter("lambda");
s_nlambda = xlsenter("nlambda");
k_rest = xlsenter("&rest");
k_aux = xlsenter("&aux");
/* enter *standard-input* and *standard-output* */
s_stdin = xlsenter("*standard-input*");
s_stdin->n_symvalue = newnode(FPTR);
s_stdin->n_symvalue->n_fp = stdin;
s_stdin->n_symvalue->n_savech = 0;
s_stdout = xlsenter("*standard-output*");
s_stdout->n_symvalue = newnode(FPTR);
s_stdout->n_symvalue->n_fp = stdout;
s_stdout->n_symvalue->n_savech = 0;
/* enter the error traceback enable flag */
s_tracenable = xlsenter("*tracenable*");
s_tracenable->n_symvalue = true;
/* enter a copyright notice into the oblist */
sym = xlsenter("**Copyright-1984-by-David-Betz**");
sym->n_symvalue = true;
/* enter type names */
a_subr = xlsenter("SUBR");
a_fsubr = xlsenter("FSUBR");
a_list = xlsenter("LIST");
a_sym = xlsenter("SYM");
a_int = xlsenter("INT");
a_str = xlsenter("STR");
a_obj = xlsenter("OBJ");
a_fptr = xlsenter("FPTR");
}
!Funky!Stuff!
echo x XLIO.C
cat > XLIO.C << '!Funky!Stuff!'
/* xlio - xlisp i/o routines */
#ifdef AZTEC
#include "stdio.h"
#else
#include <stdio.h>
#endif
#include "xlisp.h"
/* global variables */
int xlplevel=0;
int xlfsize=0;
/* external variables */
extern struct node *xlstack;
extern struct node *s_stdin;
/* local variables */
static int prompt=TRUE;
/* xlgetc - get a character from a file or stream */
int xlgetc(fptr)
struct node *fptr;
{
struct node *lptr,*cptr;
FILE *fp;
int ch;
/* check for input from nil */
if (fptr == NULL)
ch = EOF;
/* otherwise, check for input from a stream */
else if (fptr->n_type == LIST) {
if ((lptr = fptr->n_listvalue) == NULL)
ch = EOF;
else {
if (lptr->n_type != LIST ||
(cptr = lptr->n_listvalue) == NULL || cptr->n_type != INT)
xlfail("bad stream");
if ((fptr->n_listvalue = lptr->n_listnext) == NULL)
fptr->n_listnext = NULL;
ch = cptr->n_int;
}
}
/* otherwise, check for a buffered file character */
else if (ch = fptr->n_savech)
fptr->n_savech = 0;
/* otherwise, get a new character */
else {
/* get the file pointer */
fp = fptr->n_fp;
/* prompt if necessary */
if (prompt && fp == stdin) {
if (xlplevel > 0)
printf("%d> ",xlplevel);
else
printf("> ");
prompt = FALSE;
}
/* get the character */
if ((ch = getc(fp)) == '\n' && fp == stdin)
prompt = TRUE;
/* check for input abort */
if (fp == stdin && ch == '\007') {
putchar('\n');
xlfail("input aborted");
}
}
/* return the character */
return (ch);
}
/* xlpeek - peek at a character from a file or stream */
int xlpeek(fptr)
struct node *fptr;
{
struct node *lptr,*cptr;
int ch;
/* check for input from nil */
if (fptr == NULL)
ch = EOF;
/* otherwise, check for input from a stream */
else if (fptr->n_type == LIST) {
if ((lptr = fptr->n_listvalue) == NULL)
ch = EOF;
else {
if (lptr->n_type != LIST ||
(cptr = lptr->n_listvalue) == NULL || cptr->n_type != INT)
xlfail("bad stream");
ch = cptr->n_int;
}
}
/* otherwise, get the next file character and save it */
else
ch = fptr->n_savech = xlgetc(fptr);
/* return the character */
return (ch);
}
/* xlputc - put a character to a file or stream */
xlputc(fptr,ch)
struct node *fptr; int ch;
{
struct node *oldstk,lptr;
/* count the character */
xlfsize++;
/* check for output to nil */
if (fptr == NULL)
;
/* otherwise, check for output to a stream */
else if (fptr->n_type == LIST) {
oldstk = xlsave(&lptr,NULL);
lptr.n_ptr = newnode(LIST);
lptr.n_ptr->n_listvalue = newnode(INT);
lptr.n_ptr->n_listvalue->n_int = ch;
if (fptr->n_listnext)
fptr->n_listnext->n_listnext = lptr.n_ptr;
else
fptr->n_listvalue = lptr.n_ptr;
fptr->n_listnext = lptr.n_ptr;
xlstack = oldstk;
}
/* otherwise, output the character to a file */
else
putc(ch,fptr->n_fp);
}
/* xlflush - flush the input buffer */
int xlflush()
{
if (!prompt)
while (xlgetc(s_stdin->n_symvalue) != '\n')
;
}
!Funky!Stuff!
echo x XLISP.C
cat > XLISP.C << '!Funky!Stuff!'
/* xlisp - a small subset of lisp */
#ifdef AZTEC
#include "stdio.h"
#include "setjmp.h"
#else
#include <stdio.h>
#include <setjmp.h>
#endif
#include "xlisp.h"
/* global variables */
jmp_buf *xljmpbuf;
jmp_buf topjmpbuf;
/* external variables */
extern struct node *xlenv;
extern struct node *xlstack;
extern struct node *s_stdin,*s_stdout;
/* main - the main routine */
main(argc,argv)
int argc; char *argv[];
{
struct node expr;
int i;
/* print the banner line */
printf("XLISP version 1.2\n");
/* setup the error handler context buffer */
xljmpbuf = topjmpbuf;
/* setup initialization error handler */
if (setjmp(xljmpbuf)) {
printf("fatal initialization error\n");
exit();
}
/* initialize xlisp */
xlinit();
/* load "init.lsp" */
if (setjmp(xljmpbuf) == 0)
xlload("init");
/* load any files mentioned on the command line */
if (setjmp(xljmpbuf) == 0)
for (i = 1; i < argc; i++) {
printf("[ loading \"%s\" ]\n",argv[i]);
if (!xlload(argv[i]))
xlfail("can't load file");
}
/* main command processing loop */
while (TRUE) {
/* setup the error return */
setjmp(xljmpbuf);
/* free any previous expression and leftover context */
xlstack = xlenv = NULL;
/* create a new stack frame */
xlsave(&expr,NULL);
/* read an expression */
if (!xlread(s_stdin->n_symvalue,&expr.n_ptr))
break;
/* evaluate the expression */
expr.n_ptr = xleval(expr.n_ptr);
/* print it */
xlprint(s_stdout->n_symvalue,expr.n_ptr,TRUE);
xlterpri(s_stdout->n_symvalue);
}
}
!Funky!Stuff!
echo x XLISP.H
cat > XLISP.H << '!Funky!Stuff!'
/* xlisp - a small subset of lisp */
/* system specific definitions */
/* NNODES number of nodes to allocate in each request */
/* TDEPTH trace stack depth */
/* FORWARD type of a forward declaration (usually "") */
/* LOCAL type of a local function (usually "static") */
/* for the Computer Innovations compiler */
#ifdef CI
#define NNODES 1000
#define TDEPTH 500
#endif
/* for the CPM68K compiler */
#ifdef CPM68K
#define NNODES 1000
#define TDEPTH 500
#define LOCAL
#undef NULL
#define NULL (char *)0
#endif
/* for the DeSmet compiler */
#ifdef DESMET
#define NNODES 1000
#define TDEPTH 500
#define LOCAL
#define getc(fp) getcx(fp)
#define EOF -1
#endif
/* for the VAX-11 C compiler */
#ifdef vms
#define NNODES 2000
#define TDEPTH 1000
#endif
/* for the DECUS C compiler */
#ifdef decus
#define NNODES 200
#define TDEPTH 100
#define FORWARD extern
#endif
/* for unix compilers */
#ifdef unix
#define NNODES 200
#define TDEPTH 100
#endif
/* for the AZTEC C compiler */
#ifdef AZTEC
#define NNODES 200
#define TDEPTH 100
#define getc(fp) getcx(fp)
#define putc(ch,fp) aputc(ch,fp)
#define malloc alloc
#define strchr index
#endif
/* default important definitions */
#ifndef NNODES
#define NNODES 200
#endif
#ifndef TDEPTH
#define TDEPTH 100
#endif
#ifndef FORWARD
#define FORWARD
#endif
#ifndef LOCAL
#define LOCAL static
#endif
/* useful definitions */
#define TRUE 1
#define FALSE 0
/* program limits */
#define STRMAX 100 /* maximum length of a string constant */
/* node types */
#define FREE 0
#define SUBR 1
#define FSUBR 2
#define LIST 3
#define SYM 4
#define INT 5
#define STR 6
#define OBJ 7
#define FPTR 8
/* node flags */
#define MARK 1
#define LEFT 2
/* string types */
#define DYNAMIC 0
#define STATIC 1
/* symbol structure */
struct xsym {
struct node *xsy_plist; /* symbol plist - points to (name.plist) */
struct node *xsy_value; /* the current value */
};
/* subr/fsubr node structure */
struct xsubr {
struct node *(*xsu_subr)(); /* pointer to an internal routine */
};
/* list node structure */
struct xlist {
struct node *xl_value; /* value at this node */
struct node *xl_next; /* next node */
};
/* integer node structure */
struct xint {
int xi_int; /* integer value */
};
/* string node structure */
struct xstr {
int xst_type; /* string type */
char *xst_str; /* string pointer */
};
/* object node structure */
struct xobj {
struct node *xo_obclass; /* class of object */
struct node *xo_obdata; /* instance data */
};
/* file pointer node structure */
struct xfptr {
FILE *xf_fp; /* the file pointer */
int xf_savech; /* lookahead character for input files */
};
/* shorthand macros for accessing node substructures */
/* symbol node */
#define n_symplist n_info.n_xsym.xsy_plist
#define n_symvalue n_info.n_xsym.xsy_value
/* subr/fsubr node */
#define n_subr n_info.n_xsubr.xsu_subr
/* list node (and message node and binding node) */
#define n_listvalue n_info.n_xlist.xl_value
#define n_listnext n_info.n_xlist.xl_next
#define n_msg n_info.n_xlist.xl_value
#define n_msgcode n_info.n_xlist.xl_next
#define n_bndsym n_info.n_xlist.xl_value
#define n_bndvalue n_info.n_xlist.xl_next
#define n_left n_info.n_xlist.xl_value
#define n_right n_info.n_xlist.xl_next
#define n_ptr n_info.n_xlist.xl_value
/* integer node */
#define n_int n_info.n_xint.xi_int
/* string node */
#define n_str n_info.n_xstr.xst_str
#define n_strtype n_info.n_xstr.xst_type
/* object node */
#define n_obclass n_info.n_xobj.xo_obclass
#define n_obdata n_info.n_xobj.xo_obdata
/* file pointer node */
#define n_fp n_info.n_xfptr.xf_fp
#define n_savech n_info.n_xfptr.xf_savech
/* node structure */
struct node {
char n_type; /* type of node */
char n_flags; /* flag bits */
union { /* value */
struct xsym n_xsym; /* symbol node */
struct xsubr n_xsubr; /* subr/fsubr node */
struct xlist n_xlist; /* list node */
struct xint n_xint; /* integer node */
struct xstr n_xstr; /* string node */
struct xobj n_xobj; /* object node */
struct xfptr n_xfptr; /* file pointer node */
} n_info;
};
/* function table entry structure */
struct fdef {
char *f_name;
int f_type;
struct node *(*f_fcn)();
};
/* external procedure declarations */
extern struct node *xleval(); /* evaluate an expression */
extern struct node *xlapply(); /* apply a function to arguments */
extern struct node *xlevlist(); /* evaluate a list of arguments */
extern struct node *xlarg(); /* fetch an argument */
extern struct node *xlevarg(); /* fetch and evaluate an argument */
extern struct node *xlmatch(); /* fetch an typed argument */
extern struct node *xlevmatch(); /* fetch and evaluate a typed arg */
extern struct node *xlsend(); /* send a message to an object */
extern struct node *xlenter(); /* enter a symbol */
extern struct node *xlsenter(); /* enter a symbol with a static pname */
extern struct node *xlintern(); /* intern a symbol */
extern struct node *xlmakesym(); /* make an uninterned symbol */
extern struct node *xlsave(); /* generate a stack frame */
extern struct node *xlobsym(); /* find an object's class or instance
variable */
extern struct node *xlgetprop(); /* get the value of a property */
extern char *xlsymname(); /* get the print name of a symbol */
extern struct node *newnode(); /* allocate a new node */
extern char *stralloc(); /* allocate string space */
extern char *strsave(); /* make a safe copy of a string */
!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?jfw@mit-eddie.UUCP (John Woods) (02/03/85)
Replace this line with your message
Ok, I will:
This is the third of five parts in my posting of Dave Betz' XLISP 1.2.
echo extract with sh, not csh
echo x XLISP.MEM
cat > XLISP.MEM << '!Funky!Stuff!'
XLISP: An Experimental Object Oriented Language
Version 1.2
October 11, 1984
by
David Betz
114 Davenport Ave.
Manchester, NH 03103
(603) 625-4691 (home)
XLISP: An Experimental Object Oriented Language Page 2
TABLE OF CONTENTS
1.0 INTRODUCTION . . . . . . . . . . . . . . . . . . . . 3
2.0 A NOTE FROM THE AUTHOR . . . . . . . . . . . . . . . 4
3.0 XLISP COMMAND LOOP . . . . . . . . . . . . . . . . . 5
4.0 DATA TYPES . . . . . . . . . . . . . . . . . . . . . 6
5.0 THE EVALUATOR . . . . . . . . . . . . . . . . . . . 7
6.0 LEXICAL CONVENTIONS . . . . . . . . . . . . . . . . 8
7.0 OBJECTS . . . . . . . . . . . . . . . . . . . . . . 9
8.0 SYMBOLS . . . . . . . . . . . . . . . . . . . . . 12
9.0 EVALUATION FUNCTIONS . . . . . . . . . . . . . . . 13
10.0 SYMBOL FUNCTIONS . . . . . . . . . . . . . . . . . 14
11.0 PROPERTY LIST FUNCTIONS . . . . . . . . . . . . . 15
12.0 LIST FUNCTIONS . . . . . . . . . . . . . . . . . . 16
13.0 DESTRUCTIVE LIST FUNCTIONS . . . . . . . . . . . . 18
14.0 PREDICATE FUNCTIONS . . . . . . . . . . . . . . . 19
15.0 CONTROL FUNCTIONS . . . . . . . . . . . . . . . . 20
16.0 ARITHMETIC FUNCTIONS . . . . . . . . . . . . . . . 22
17.0 BITWISE LOGICAL FUNCTIONS . . . . . . . . . . . . 23
18.0 RELATIONAL FUNCTIONS . . . . . . . . . . . . . . . 24
19.0 STRING FUNCTIONS . . . . . . . . . . . . . . . . . 25
20.0 INPUT/OUTPUT FUNCTIONS . . . . . . . . . . . . . . 26
21.0 FILE I/O FUNCTIONS . . . . . . . . . . . . . . . . 27
22.0 SYSTEM FUNCTIONS . . . . . . . . . . . . . . . . . 28
XLISP: An Experimental Object Oriented Language Page 3
INTRODUCTION
1.0 INTRODUCTION
XLISP is an experimental programming language combining some
of the features of LISP with an object oriented extension
capability. It was implemented to allow experimentation
with object oriented programming on small computers. There
are currently implementations running on the PDP-11 under
RSX-11, RT-11, and UNIX V7, on the VAX-11 under VAX/VMS and
Berkeley VAX/UNIX, on the Z-80 under CP/M-80, on the Z8000
under UNIX V7, and on the 8088/8086 under CP/M-86 or MS-DOS.
A version is currently being developed for the 68000 under
CP/M-68K. It is completely written in the programming
language 'C' and is easily extended with user written
built-in functions and classes. It is available in source
form free of charge to non-commercial users. Prospective
commercial users should contact the author for permission to
use XLISP.
Many traditional LISP functions are built into XLISP. In
addition, XLISP defines the objects 'Object' and 'Class' as
primitives. 'Object' is the only class that has no
superclass and hence is the root of the class heirarchy
tree. 'Class' is the class of which all classes are
instances (it is the only object that is an instance of
itself).
This document is intended to be a brief description of
XLISP. It assumes some knowledge of LISP and some
understanding of the concepts of object oriented
programming.
Version 1.2 of XLISP differs from version 1.1 in several
ways. It supports many more Lisp functions. Also, many
version 1.1 functions have been renamed and/or changed
slightly to follow traditional Lisp usage. One of the most
frequently reported problems in version 1.1 resulted from
many functions being named after their equivilent functions
in the C language. This turned out to be confusing for
people who were trying to learn XLISP using traditional LISP
texts as references. Version 1.2 renames these functions to
be compatible with more traditional dialects of LISP.
A recommended text for learning LISP programming is the book
"LISP" by Winston and Horn and published by Addison Wesley.
The first edition of this book is based on MacLisp and the
second edition is based on Common Lisp. Future version of
XLISP will migrate towards compatiblility with Common Lisp.
XLISP: An Experimental Object Oriented Language Page 4
A NOTE FROM THE AUTHOR
2.0 A NOTE FROM THE AUTHOR
If you have any problems with XLISP, feel free to contact me
for help or advice. Please remember that since XLISP is
available in source form in a high level language, many
users have been making versions available on a variety of
machines. If you call to report a problem with a specific
version, I may not be able to help you if that version runs
on a machine to which I don't have access.
If you find a bug in XLISP, first try to fix the bug
yourself using the source code provided. If you are
successful in fixing the bug, send the bug report along with
the fix to me. If you don't have access to a C compiler or
are unable to fix a bug, please send the bug report to me
and I'll try to fix it.
Any suggestions for improvements will be welcomed. Feel
free to extend the language in whatever way suits your
needs. However, PLEASE DO NOT RELEASE ENHANCED VERSIONS
WITHOUT CHECKING WITH ME FIRST!! I would like to be the
clearing house for new features added to XLISP. If you want
to add features for your own personal use, go ahead. But,
if you want to distribute your enhanced version, contact me
first. Please remember that the goal of XLISP is to provide
a language to learn and experiment with LISP and object
oriented programming on small computers. Version 1.2 barely
fits on a 64K Z-80 running CP/M-80.
XLISP: An Experimental Object Oriented Language Page 5
XLISP COMMAND LOOP
3.0 XLISP COMMAND LOOP
When XLISP is started, it first tries to load "init.lsp"
from the default directory. It then loads any files named
as parameters on the command line (after appending ".lsp" to
their names). It then issues the following prompt:
>
This indicates that XLISP is waiting for an expression to be
typed. When an incomplete expression has been typed (one
where the left and right parens don't match) XLISP changes
its prompt to:
n>
where n is an integer indicating how many levels of left
parens remain unclosed.
When a complete expression has been entered, XLISP attempts
to evaluate that expression. If the expression evaluates
successfully, XLISP prints the result of the evaluation and
then returns to the initial prompt waiting for another
expression to be typed.
Input can be aborted at any time by typing the CONTROL-G key
(it may be necessary to follow CONTROL-G by return).
XLISP: An Experimental Object Oriented Language Page 6
DATA TYPES
4.0 DATA TYPES
There are several different data types available to XLISP
programmers.
o lists
o symbols
o strings
o integers
o objects
o file pointers
o subrs/fsubrs (built-in functions)
Another data type is the stream. A stream is a list node
whose car points to the head of a list of integers and whose
cdr points to the last list node of the list. An empty
stream is a list node whose car and cdr are nil. Each of
the integers in the list represent characters in the stream.
When a character is read from a stream, the first integer
from the head of the list is removed and returned. When a
character is written to a stream, the integer representing
the character code of the character is appended to the end
of the list. When a function indicates that it takes an
input source as a parameter, this parameter can either be an
input file pointer or a stream. Similarly, when a function
indicates that it takes an output sink as a parameter, this
parameter can either be an output file pointer or a stream.
XLISP: An Experimental Object Oriented Language Page 7
THE EVALUATOR
5.0 THE EVALUATOR
The process of evaluation in XLISP:
o Integers, strings, objects, file pointers, and
subrs evaluate to themselves
o Symbols evaluate to the value associated with their
current binding
o Lists are evaluated by evaluating the first element
of the list
o If it evaluates to a subr, the remaining list
elements are evaluated and the subr is called
with these evaluated expressions as arguments.
o If it evaluates to an fsubr, the fsubr is
called using the remaining list elements as
arguments (they are evaluated by the subr
itself if necessary)
o If it evaluates to a list and the car of the
list is 'lambda', the remaining list elements
are evaluated and the resulting expressions are
bound to the formal arguments of the lambda
expression. The body of the function is
executed within this new binding environment.
o If it evaluates to a list and the car of the
list is 'nlambda', the remaining list elements
are bound to the formal arguments of the
nlambda expression. The body of the function
is executed within this new binding
environment.
o If it evaluates to an object, the second list
element is evaluated and used as a message
selector. The message formed by combining the
selector with the values of the remaining list
elements is sent to the object.
XLISP: An Experimental Object Oriented Language Page 8
LEXICAL CONVENTIONS
6.0 LEXICAL CONVENTIONS
The following conventions are followed when entering XLISP
programs:
Comments in XLISP code begin with a semi-colon character and
continue to the end of the line.
Symbol names in XLISP can consist of any sequence of
non-blank printable characters except the following:
( ) . ' " ;
Upper and lower case characters are distinct. The symbols
'CAR' and 'car' are not the same. The names of all built-in
functions are in lower case. The names of all built-in
objects are lower case with an initial capital. Symbol
names must not begin with a digit.
Integer literals consist of a sequence of digits optionally
beginning with a '+' or '-'. The range of values an integer
can represent is limited by the size of a C 'int' on the
machine that XLISP is running on.
Literal strings are sequences of characters surrounded by
double quotes. Within quoted strings the '\' character is
used to allow non-printable characters to be included. The
codes recognized are:
\\ means the character '\'
\n means newline
\t means tab
\r means return
\e means escape
\nnn means the character whose octal code is nnn
The single quote character can be used as a shorthand for a
call on the function 'quote':
'foo
is equivalent to:
(quote foo)
XLISP: An Experimental Object Oriented Language Page 9
OBJECTS
7.0 OBJECTS
Definitions:
o selector - a symbol used to select an appropriate
method
o message - a selector and a list of actual arguments
o method - the code that implements a message
Since XLISP was created to provide a simple basis for
experimenting with object oriented programming, one of the
primitive data types included was 'object'. In XLISP, an
object consists of a data structure containing a pointer to
the object's class as well as a list containing the values
of the object's instance variables.
Officially, there is no way to see inside an object (look at
the values of its instance variables). The only way to
communicate with an object is by sending it a message. When
the XLISP evaluator evaluates a list the value of whose
first element is an object, it interprets the value of the
second element of the list (which must be a symbol) as the
message selector. The evaluator determines the class of the
receiving object and attempts to find a method corresponding
to the message selector in the set of messages defined for
that class. If the message is not found in the object's
class and the class has a super-class, the search continues
by looking at the messages defined for the super-class.
This process continues from one super-class to the next
until a method for the message is found. If no method is
found, an error occurs.
When a method is found, the evaluator binds the receiving
object to the symbol 'self', binds the class in which the
method was found to the symbol 'msgclass', and evaluates the
method using the remaining elements of the original list as
arguments to the method. These arguments are always
evaluated prior to being bound to their corresponding formal
arguments. The result of evaluating the method becomes the
result of the expression.
XLISP: An Experimental Object Oriented Language Page 10
OBJECTS
Classes:
Object THE TOP OF THE CLASS HEIRARCHY
Messages:
show SHOW AN OBJECT'S INSTANCE VARIABLES
returns the object
class RETURN THE CLASS OF AN OBJECT
returns the class of the object
isnew THE DEFAULT OBJECT INITIALIZATION ROUTINE
returns the object
sendsuper <sel> [<args>...] SEND SUPERCLASS A MESSAGE
<sel> the message selector
<args> the message arguments
returns the result of sending the message
XLISP: An Experimental Object Oriented Language Page 11
OBJECTS
Class THE CLASS OF ALL OBJECT CLASSES (including itself)
Messages:
new CREATE A NEW INSTANCE OF A CLASS
returns the new class object
isnew [<scls>] INITIALIZE A NEW CLASS
<scls> the superclass
returns the new class object
answer <msg> <fargs> <code> ADD A MESSAGE TO A CLASS
<msg> the message symbol
<fargs> the formal argument list
this list is of the form:
(<farg>... [&rest <rarg>] [&aux <aux>...])
where
<farg> a formal argument
<rarg> bound to the rest of the arguments
<aux> a auxiliary variable
<code> a list of executable expressions
returns the object
ivars <vars> DEFINE THE LIST OF INSTANCE VARIABLES
<vars> the list of instance variable symbols
returns the object
cvars <vars> DEFINE THE LIST OF CLASS VARIABLES
<vars> the list of class variable symbols
returns the object
When a new instance of a class is created by sending the
message 'new' to an existing class, the message 'isnew'
followed by whatever parameters were passed to the 'new'
message is sent to the newly created object.
When a new class is created by sending the 'new' message to
the object 'Class', an optional parameter may be specified
indicating the superclass of the new class. If this
parameter is omitted, the new class will be a subclass of
'Object'. A class inherits all instance variables, class
variables, and methods from its super-class.
XLISP: An Experimental Object Oriented Language Page 12
SYMBOLS
8.0 SYMBOLS
o self - the current object (within a message
context)
o msgclass - the class in which the current method
was found
o *oblist* - the object list
o *standard-input* - the standard input file
o *standard-output* - the standard output file
o *tracenable* - flag controlling trace back printout
on errors
o *unbound* - indicator for unbound symbols
XLISP: An Experimental Object Oriented Language Page 13
EVALUATION FUNCTIONS
9.0 EVALUATION FUNCTIONS
(eval <expr>) EVALUATE AN XLISP EXPRESSION
<expr> the expression to be evaluated
returns the result of evaluating the expression
(apply <fun> <args>) APPLY A FUNCTION TO A LIST OF ARGUMENTS
<fun> the function to apply (or function symbol)
<args> the argument list
returns the result of applying the function to the argument list
(funcall <fun> <arg>...) CALL A FUNCTION WITH ARGUMENTS
<fun> the function to call (or function symbol)
<arg> arguments to pass to the function
returns the result of calling the function with the arguments
(quote <expr>) RETURN AN EXPRESSION UNEVALUATED
<expr> the expression to be quoted (quoted)
returns <expr> unevaluated
XLISP: An Experimental Object Oriented Language Page 14
SYMBOL FUNCTIONS
10.0 SYMBOL FUNCTIONS
(set <sym> <expr>) SET THE VALUE OF A SYMBOL
<sym> the symbol being set
<expr> the new value
returns the new value
(setq <sym> <expr>) SET THE VALUE OF A SYMBOL
<sym> the symbol being set (quoted)
<expr> the new value
returns the new value
(defun <sym> <fargs> <expr>...) DEFINE A FUNCTION WITH EVALUATED ARGS
(ndefun <sym> <fargs> <expr>...) DEFINE A FUNCTION WITH UNEVALUATED ARGS
<sym> symbol being defined (quoted)
<fargs> list of formal arguments (quoted)
this list is of the form:
(<farg>... [&rest <rarg>] [&aux <aux>...])
where
<farg> is a formal argument
<rarg> bound to the rest of the arguments
<aux> is an auxiliary variable
<expr> expressions constituting the body of the
function (quoted)
returns the function symbol
(gensym <tag>) GENERATE A SYMBOL
<tag> symbol/string/number
returns the new symbol
(intern <sym>) INTERN A SYMBOL ON THE OBLIST
<sym> the symbol
returns the interned symbol
(symbol-name <sym>) GET THE PRINT NAME OF A SYMBOL
<sym> the symbol
returns the symbol's print name
(symbol-plist <sym>) GET THE PROPERTY LIST OF A SYMBOL
<sym> the symbol
returns the symbol's property list
XLISP: An Experimental Object Oriented Language Page 15
PROPERTY LIST FUNCTIONS
11.0 PROPERTY LIST FUNCTIONS
(get <sym> <prop>) GET THE VALUE OF A PROPERTY
<sym> the symbol
<prop> the property symbol
returns the property value or nil
(putprop <sym> <value> <prop>) PUT A PROPERTY ONTO A PROPERTY LIST
<sym> the symbol
<value> the property value
<prop> the property symbol
returns the value
(remprop <prop> <sym>) REMOVE A PROPERTY
<sym> the symbol
<prop> the property symbol
returns nil
XLISP: An Experimental Object Oriented Language Page 16
LIST FUNCTIONS
12.0 LIST FUNCTIONS
(car <expr>) RETURN THE CAR OF A LIST NODE
<expr> the list node
returns the car of the list node
(cdr <expr>) RETURN THE CDR OF A LIST NODE
<expr> the list node
returns the cdr of the list node
(caar <expr>) == (car (car <expr>))
(cadr <expr>) == (car (cdr <expr>))
(cdar <expr>) == (cdr (car <expr>))
(cddr <expr>) == (cdr (cdr <expr>))
(cons <expr1> <expr2>) CONSTRUCT A NEW LIST NODE
<expr1> the car of the new list node
<expr2> the cdr of the new list node
returns the new list node
(list <expr>...) CREATE A LIST OF VALUES
<expr> expressions to be combined into a list
returns the new list
(append <expr>...) APPEND LISTS
<expr> lists whose elements are to be appended
returns the new list
(reverse <expr>) REVERSE A LIST
<expr> the list to reverse
returns a new list in the reverse order
(last <list>) RETURN THE LAST LIST NODE OF A LIST
<list> the list
returns the last list node in the list
(member <expr> <list>) FIND AN EXPRESSION IN A LIST
<expr> the expression to find (equal test)
<list> the list to search
returns the remainder of the list starting with the expression
(memq <expr> <list>) FIND AN EXPRESSION IN A LIST
<expr> the expression to find (eq test)
<list> the list to find it in
returns the remainder of the list starting with the expression
XLISP: An Experimental Object Oriented Language Page 17
LIST FUNCTIONS
(assoc <expr> <alist>) FIND AN EXPRESSION IN AN ASSOCIATION LIST
<expr> the expression to find (equal test)
<alist> the association list
returns the alist entry or nil
(assq <expr> <alist>) FIND AN EXPRESSION IN AN ASSOCIATION LIST
<expr> the expression to find (eq test)
<alist> the association list
returns the alist entry or nil
(length <expr>) FIND THE LENGTH OF A LIST
<expr> the list
returns the length of the list
(nth <n> <list>) RETURN THE NTH ELEMENT OF A LIST
<n> the number of the element to return (zero origin)
<list> the list
returns the nth element or nil if the list isn't that long
(nthcdr <n> <list>) RETURN THE NTH CDR OF A LIST
<n> the number of the element to return (zero origin)
<list> the list
returns the nth cdr or nil if the list isn't that long
(mapcar <fcn> <list1>...<listn>) APPLY FUNCTION TO SUCCESSIVE CARS
<fcn> the function or function name
<list1..n> a list for each argument of the function
returns the list of values returned by each function invocation
(maplist <fcn> <list1>...<listn>) APPLY FUNCTION TO SUCCESSIVE CDRS
<fcn> the function or function name
<list1..n> a list for each argument of the function
returns the list of values returned by each function invocation
(subst <to> <from> <expr>) SUBSTITUTE ONE EXPRESSION FOR ANOTHER
<to> the new expression
<from> the old expression
<expr> the expression in which to do the substitutions
returns the expression with substitutions
(sublis <alist> <expr>) SUBSTITUTE USING AN ASSOCIATION LIST
<alist> the association list
<expr> the expression in which to do the substitutions
returns the expression with substitutions
XLISP: An Experimental Object Oriented Language Page 18
DESTRUCTIVE LIST FUNCTIONS
13.0 DESTRUCTIVE LIST FUNCTIONS
(rplaca <list> <expr>) REPLACE THE CAR OF A LIST NODE
<list> the list node
<expr> the new value for the car of the list node
returns the list node after updating the car
(rplacd <list> <expr>) REPLACE THE CDR OF A LIST NODE
<list> the list node
<expr> the new value for the cdr of the list node
returns the list node after updating the cdr
(nconc <list>...) DESTRUCTIVELY CONCATENATE LISTS
<list> lists to concatenate
returns the result of concatenating the lists
(delete <expr> <list>) DELETE OCCURANCES OF AN EXPRESSION FROM A LIST
<expr> the expression to delete (equal test)
<list> the list
returns the list with the matching expressions deleted
(delq <expr> <list>) DELETE OCCURANCES OF AN EXPRESSION FROM A LIST
<expr> the expression to delete (eq test)
<list> the list
returns the list with the matching expressions deleted
XLISP: An Experimental Object Oriented Language Page 19
PREDICATE FUNCTIONS
14.0 PREDICATE FUNCTIONS
(atom <expr>) IS THIS AN ATOM?
<expr> the expression to check
returns t if the value is an atom, nil otherwise
(symbolp <expr>) IS THIS A SYMBOL?
<expr> the expression to check
returns t if the expression is a symbol, nil otherwise
(numberp <expr>) IS THIS A NUMBER?
<expr> the expression to check
returns t if the expression is a symbol, nil otherwise
(null <expr>) IS THIS AN EMPTY LIST?
<expr> the list to check
returns t if the list is empty, nil otherwise
(not <expr>) IS THIS FALSE?
<expr> the expression to check
return t if the expression is nil, nil otherwise
(listp <expr>) IS THIS A LIST?
<expr> the expression to check
returns t if the value is a list node or nil, nil otherwise
(consp <expr>) IS THIS A NON-EMPTY LIST?
<expr> the expression to check
returns t if the value is a list node, nil otherwise
(boundp <sym>) IS THIS A BOUND SYMBOL?
<sym> the symbol
returns t if a value is bound to the symbol, nil otherwise
(eq <expr1> <expr2>) ARE THE EXPRESSIONS IDENTICAL?
<expr1> the first expression
<expr2> the second expression
returns t if they are equal, nil otherwise
(equal <expr1> <expr2>) ARE THE EXPRESSIONS EQUAL?
<expr1> the first expression
<expr2> the second expression
returns t if they are equal, nil otherwise
XLISP: An Experimental Object Oriented Language Page 20
CONTROL FUNCTIONS
15.0 CONTROL FUNCTIONS
(cond <pair>...) EVALUATE CONDITIONALLY
<pair> pair consisting of:
(<pred> <expr>...)
where
<pred> is a predicate expression
<expr> evaluated if the predicate
is not nil
returns the value of the first expression whose predicate
is not nil
(let (<binding>...) <expr>...) BIND SYMBOLS AND EVALUATE EXPRESSIONS
<binding> the variable bindings each of which is either:
1) a symbol (which is initialized to nil)
2) a list whose car is a symbol and whose cadr
is an initialization expression
<expr>... the expressions to be evaluated with the specified bindings
returns the value of the last expression
(and <expr>...) THE LOGICAL AND OF A LIST OF EXPRESSIONS
<expr>... the expressions to be ANDed
returns nil if any expression evaluates to nil,
otherwise the value of the last expression
(evaluation of expressions stops after the first
expression that evaluates to nil)
(or <expr>...) THE LOGICAL OR OF A LIST OF EXPRESSIONS
<expr>... the expressions to be ORed
returns nil if all expressions evaluate to nil,
otherwise the value of the first non-nil expression
(evaluation of expressions stops after the first
expression that does not evaluate to nil)
(if <texpr> <expr1> [<expr2>]) EXECUTE EXPRESSIONS CONDITIONALLY
<texpr> the test expression
<expr1> the expression to be evaluated if texpr is non-nil
<expr2> the expression to be evaluated if texpr is nil
returns the value of the selected expression
(progn <expr>...) EXECUTE EXPRESSIONS SEQUENTIALLY
<expr>... the expressions to evaluate
returns the value of the last expression
(while <texpr> <expr>...) ITERATE WHILE AN EXPRESSION IS TRUE
<texpr> the test expression evaluated at start of each iteration
<expr>... the expressions evaluated as long as <texpr> evaluates to
non-nil
returns the value of the last expression
XLISP: An Experimental Object Oriented Language Page 21
CONTROL FUNCTIONS
(repeat <iexpr> <expr>...) ITERATE USING A REPEAT COUNT
<iexpr> the integer expression indicating the repeat count
<expr>... the expressions evaluated <iexpr> times
returns the value of the last expression
XLISP: An Experimental Object Oriented Language Page 22
ARITHMETIC FUNCTIONS
16.0 ARITHMETIC FUNCTIONS
(+ <expr>...) ADD A LIST OF NUMBERS
<expr>... the numbers
returns the result of the addition
(- <expr>...) SUBTRACT A LIST OF NUMBERS
<expr>... the numbers
returns the result of the subtraction
(* <expr>...) MULTIPLY A LIST OF NUMBERS
<expr>... the numbers
returns the result of the multiplication
(/ <expr>...) DIVIDE A LIST OF NUMBERS
<expr>... the numbers
returns the result of the division
(1+ <expr>) ADD ONE TO A NUMBER
<expr> the number
returns the number plus one
(1- <expr>) SUBTRACT ONE FROM A NUMBER
<expr> the number
returns the number minus one
(rem <expr>...) REMAINDER OF A LIST OF NUMBERS
<expr>... the numbers
returns the result of the remainder operation
(minus <expr>) NEGATE A NUMBER
<expr> the number
returns the number negated
(min <expr>...) THE SMALLEST OF A LIST OF NUMBERS
<expr>... the expressions to be checked
returns the smallest number in the list
(max <expr>...) THE LARGEST OF A LIST OF NUMBERS
<expr>... the expressions to be checked
returns the largest number in the list
(abs <expr>) THE ABSOLUTE VALUE OF A NUMBER
<expr> the number
returns the absolute value of the number
XLISP: An Experimental Object Oriented Language Page 23
BITWISE LOGICAL FUNCTIONS
17.0 BITWISE LOGICAL FUNCTIONS
(bit-and <expr>...) THE BITWISE AND OF A LIST OF NUMBERS
<expr> the numbers
returns the result of the and operation
(bit-ior <expr...) THE BITWISE INCLUSIVE OR OF A LIST OF NUMBERS
<expr> the numbers
returns the result of the inclusive or operation
(bit-xor <expr...) THE BITWISE EXCLUSIVE OR OF A LIST OF NUMBERS
<expr> the numbers
returns the result of the exclusive or operation
(bit-not <expr>) THE BITWISE NOT OF A NUMBER
<expr> the number
returns the bitwise inversion of number
XLISP: An Experimental Object Oriented Language Page 24
RELATIONAL FUNCTIONS
18.0 RELATIONAL FUNCTIONS
The relational functions can be used to compare integers or
strings. The functions '=' and '/=' can also be used to
compare other types. The result of these comparisons is
computed the same way as for 'eq'.
(< <e1> <e2>) TEST FOR LESS THAN
<e1> the left operand of the comparison
<e2> the right operand of the comparison
returns the result of comparing <e1> with <e2>
(<= <e1> <e2>) TEST FOR LESS THAN OR EQUAL TO
<e1> the left operand of the comparison
<e2> the right operand of the comparison
returns the result of comparing <e1> with <e2>
(= <e1> <e2>) TEST FOR EQUAL TO
<e1> the left operand of the comparison
<e2> the right operand of the comparison
returns the result of comparing <e1> with <e2>
(/= <e1> <e2>) TEST FOR NOT EQUAL TO
<e1> the left operand of the comparison
<e2> the right operand of the comparison
returns the result of comparing <e1> with <e2>
(>= <e1> <e2>) TEST FOR GREATER THAN OR EQUAL TO
<e1> the left operand of the comparison
<e2> the right operand of the comparison
returns the result of comparing <e1> with <e2>
(> <e1> <e2>) TEST FOR GREATER THAN
<e1> the left operand of the comparison
<e2> the right operand of the comparison
returns the result of comparing <e1> with <e2>
XLISP: An Experimental Object Oriented Language Page 25
STRING FUNCTIONS
19.0 STRING FUNCTIONS
(strcat <expr>...) CONCATENATE STRINGS
<expr>... the strings to concatenate
returns the result of concatenating the strings
(strlen <expr>) COMPUTE THE LENGTH OF A STRING
<expr> the string
returns the length of the string
(substr <expr> <sexpr> [<lexpr>]) EXTRACT A SUBSTRING
<expr> the string
<sexpr> the starting position
<lexpr> the length (default is rest of string)
returns substring starting at <sexpr> for <lexpr>
(ascii <expr>) NUMERIC VALUE OF CHARACTER
<expr> the string
returns the ascii code of the first character
(chr <expr>) CHARACTER EQUIVALENT OF ASCII VALUE
<expr> the numeric expression
returns a one character string whose first character is <expr>
(atoi <expr>) CONVERT AN ASCII STRING TO AN INTEGER
<expr> the string
returns the integer value of the string expression
(itoa <expr>) CONVERT AN INTEGER TO AN ASCII STRING
<expr> the integer
returns the string representation of the integer value
XLISP: An Experimental Object Oriented Language Page 26
INPUT/OUTPUT FUNCTIONS
20.0 INPUT/OUTPUT FUNCTIONS
(read [<source>[<eof>]]) READ AN XLISP EXPRESSION
<source> the input source (default is standard input)
<eof> the value to return on end of file (default is nil)
returns the expression read
(print <expr> [<sink>]) PRINT A LIST OF VALUES ON A NEW LINE
<expr> the expressions to be printed
<sink> the output sink (default is standard output)
returns nil
(prin1 <expr> [<sink>]) PRINT A LIST OF VALUES
<expr> the expressions to be printed
<sink> the output sink (default is standard output)
returns nil
(princ <expr> [<sink>]) PRINT A LIST OF VALUES WITHOUT QUOTING
<expr> the expressions to be printed
<sink> the output sink (default is standard output)
returns nil
(terpri [<sink>]) TERMINATE THE CURRENT PRINT LINE
<sink> the output sink (default is standard output)
returns nil
(flatsize <expr>) LENGTH OF PRINTED REPRESENTATION USING PRIN1
<expr> the expression
returns the length
(flatc <expr>) LENGTH OF PRINTED REPRESENTATION USING PRINC
<expr> the expression
returns the length
(explode <expr>) CHARACTERS IN PRINTED REPRESENTATION USING PRIN1
<expr> the expression
returns the list of characters
(explodec <expr>) CHARACTERS IN PRINTED REPRESENTATION USING PRINC
<expr> the expression
returns the list of characters
(maknam <list>) BUILD AN UNINTERNED SYMBOL FROM A LIST OF CHARACTERS
<list> list of characters in symbol name
returns the symbol
(implode <list>) BUILD AN INTERNED SYMBOL FROM A LIST OF CHARACTERS
<list> list of characters in symbol name
returns the symbol
XLISP: An Experimental Object Oriented Language Page 27
FILE I/O FUNCTIONS
21.0 FILE I/O FUNCTIONS
(openi <fname>) OPEN AN INPUT FILE
<fname> the file name string
returns a file pointer
(openo <fname>) OPEN AN OUTPUT FILE
<fname> the file name string
returns a file pointer
(close <fp>) CLOSE A FILE
<fp> the file pointer
returns nil
(read-char [<source>]) READ A CHARACTER FROM A FILE OR STREAM
<source> the input source (default is standard input)
returns the character (integer)
(peek-char [<flag> [<source>]]) PEEK AT THE NEXT CHARACTER
<flag> flag for skipping white space (default is nil)
<source> the input source (default is standard input)
returns the character (integer)
(write-char <ch> [<sink>]) WRITE A CHARACTER TO A FILE OR STREAM
<ch> the character to put (integer)
<sink> the output sink (default is standard output)
returns the character (integer)
(readline [<source>]) READ A LINE FROM A FILE OR STREAM
<source> the input source (default is standard input)
returns the input string
XLISP: An Experimental Object Oriented Language Page 28
SYSTEM FUNCTIONS
22.0 SYSTEM FUNCTIONS
(load <fname>) LOAD AN XLISP SOURCE FILE
<fname> the filename string (".lsp" is appended)
returns the filename
(gc) FORCE GARBAGE COLLECTION
returns nil
(expand <num>) EXPAND MEMORY BY ADDING SEGMENTS
<num> the number of segments to add
returns the number of segments added
(alloc <num>) CHANGE NUMBER OF NODES TO ALLOCATE IN EACH SEGMENT
<num> the number of nodes to allocate
returns the old number of nodes to allocate
(mem) SHOW MEMORY ALLOCATION STATISTICS
returns nil
(type <expr>) RETURNS THE TYPE OF THE EXPRESSION
<expr> the expression to return the type of
returns nil if the value is nil otherwise one of the symbols:
SYM for symbols
OBJ for objects
LIST for list nodes
SUBR for subroutine nodes with evaluated arguments
FSUBR for subroutine nodes with unevaluated arguments
STR for string nodes
INT for integer nodes
FPTR for file pointer nodes
(exit) EXIT XLISP
returns never returns
!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?jfw@mit-eddie.UUCP (John Woods) (02/03/85)
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?jfw@mit-eddie.UUCP (John Woods) (02/03/85)
Replace this line with your message, but I'm out of cute things to say here.
This is part five of five in my posting of Dave Betz' newest XLISP 1.2. If you
don't seem to have all five parts, send me mail at ...!mit-eddie!jfw and I'll
figure out how to get you the missing parts.
/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
echo extract with sh, not csh
echo x XLPRIN.C
cat > XLPRIN.C << '!Funky!Stuff!'
/* xlprint - xlisp print routine */
#ifdef AZTEC
#include "stdio.h"
#else
#include <stdio.h>
#endif
#include "xlisp.h"
/* external variables */
extern struct node *xlstack;
/* local variables */
static char buf[STRMAX+1];
/* xlprint - print an xlisp value */
xlprint(fptr,vptr,flag)
struct node *fptr,*vptr; int flag;
{
struct node *nptr,*next,*msg;
/* print null as the empty list */
if (vptr == NULL) {
putstr(fptr,"nil");
return;
}
/* check value type */
switch (vptr->n_type) {
case SUBR:
putatm(fptr,"Subr",vptr);
break;
case FSUBR:
putatm(fptr,"FSubr",vptr);
break;
case LIST:
xlputc(fptr,'(');
for (nptr = vptr; nptr != NULL; nptr = next) {
xlprint(fptr,nptr->n_listvalue,flag);
if ((next = nptr->n_listnext) != NULL)
if (next->n_type == LIST)
xlputc(fptr,' ');
else {
putstr(fptr," . ");
xlprint(fptr,next,flag);
break;
}
}
xlputc(fptr,')');
break;
case SYM:
putstr(fptr,xlsymname(vptr));
break;
case INT:
putdec(fptr,vptr->n_int);
break;
case STR:
if (flag)
putstring(fptr,vptr->n_str);
else
putstr(fptr,vptr->n_str);
break;
case FPTR:
putatm(fptr,"File",vptr);
break;
case OBJ:
putatm(fptr,"Object",vptr);
break;
default:
putatm(fptr,"Foo",vptr);
break;
}
}
/* xlterpri - terminate the current print line */
xlterpri(fptr)
struct node *fptr;
{
xlputc(fptr,'\n');
}
/* putstring - output a string */
LOCAL putstring(fptr,str)
struct node *fptr; char *str;
{
int ch;
/* output the initial quote */
xlputc(fptr,'"');
/* output each character in the string */
while (ch = *str++)
/* check for a control character */
if (ch < 040 || ch == '\\') {
xlputc(fptr,'\\');
switch (ch) {
case '\033':
xlputc(fptr,'e');
break;
case '\n':
xlputc(fptr,'n');
break;
case '\r':
xlputc(fptr,'r');
break;
case '\t':
xlputc(fptr,'t');
break;
case '\\':
xlputc(fptr,'\\');
break;
default:
putoct(fptr,ch);
break;
}
}
/* output a normal character */
else
xlputc(fptr,ch);
/* output the terminating quote */
xlputc(fptr,'"');
}
/* putatm - output an atom */
LOCAL putatm(fptr,tag,val)
struct node *fptr; char *tag; int val;
{
sprintf(buf,"<%s: #%x>",tag,val);
putstr(fptr,buf);
}
/* putdec - output a decimal number */
LOCAL putdec(fptr,n)
struct node *fptr; int n;
{
sprintf(buf,"%d",n);
putstr(fptr,buf);
}
/* puthex - output a hexadecimal number */
LOCAL puthex(fptr,n)
struct node *fptr; unsigned int n;
{
sprintf(buf,"%x",n);
putstr(fptr,buf);
}
/* putoct - output an octal byte value */
LOCAL putoct(fptr,n)
struct node *fptr; int n;
{
sprintf(buf,"%03o",n);
putstr(fptr,buf);
}
/* putstr - output a string */
LOCAL putstr(fptr,str)
struct node *fptr; char *str;
{
while (*str)
xlputc(fptr,*str++);
}
!Funky!Stuff!
echo x XLREAD.C
cat > XLREAD.C << '!Funky!Stuff!'
/* xlread - xlisp expression input routine */
#ifdef AZTEC
#include "stdio.h"
#include "setjmp.h"
#else
#include <stdio.h>
#include <setjmp.h>
#include <ctype.h>
#endif
#include "xlisp.h"
/* external variables */
extern jmp_buf *xljmpbuf;
extern struct node *s_quote;
extern struct node *xlstack;
extern int xlplevel;
/* external routines */
extern FILE *fopen();
/* forward declarations */
FORWARD struct node *plist();
FORWARD struct node *pstring();
FORWARD struct node *pquote();
FORWARD struct node *pname();
/* xlload - load a file of xlisp expressions */
int xlload(name)
char *name;
{
jmp_buf loadjmpbuf,*oldjmpbuf;
struct node *oldstk,fptr,val;
char fname[50];
FILE *fp;
/* create a new stack frame */
oldstk = xlsave(&fptr,&val,NULL);
/* add the default extension */
strcpy(fname,name); strcat(fname,".lsp");
/* open the file */
if ((fp = fopen(fname,"r")) == NULL)
return (FALSE);
/* allocate a file node */
fptr.n_ptr = newnode(FPTR);
fptr.n_ptr->n_fp = fp;
fptr.n_ptr->n_savech = 0;
/* setup to trap errors */
oldjmpbuf = xljmpbuf;
if (setjmp(xljmpbuf = loadjmpbuf)) {
fclose(fp);
longjmp(xljmpbuf = oldjmpbuf,1);
}
/* read and evaluate each expression in the file */
while (xlread(fptr.n_ptr,&val.n_ptr))
xleval(val.n_ptr);
/* restore error trapping context and previous stack frame */
xljmpbuf = oldjmpbuf;
xlstack = oldstk;
/* close the file */
fclose(fp);
/* return successfully */
return (TRUE);
}
/* xlread - read an xlisp expression */
int xlread(fptr,pval)
struct node *fptr,**pval;
{
/* initialize */
xlplevel = 0;
/* parse an expression */
return (parse(fptr,pval));
}
/* parse - parse an xlisp expression */
LOCAL int parse(fptr,pval)
struct node *fptr,**pval;
{
int ch;
/* keep looking for a node skipping comments */
while (TRUE)
/* check next character for type of node */
switch (ch = nextch(fptr)) {
case EOF:
return (FALSE);
case '\'': /* a quoted expression */
*pval = pquote(fptr);
return (TRUE);
case '(': /* a sublist */
*pval = plist(fptr);
return (TRUE);
case ')': /* closing paren - shouldn't happen */
xlfail("extra right paren");
case '.': /* dot - shouldn't happen */
xlfail("misplaced dot");
case ';': /* a comment */
pcomment(fptr);
break;
case '"': /* a string */
*pval = pstring(fptr);
return (TRUE);
default:
if (issym(ch)) /* a name */
*pval = pname(fptr);
else
xlfail("invalid character");
return (TRUE);
}
}
/* pcomment - parse a comment */
LOCAL pcomment(fptr)
struct node *fptr;
{
int ch;
/* skip to end of line */
while ((ch = checkeof(fptr)) != EOF && ch != '\n')
;
}
/* plist - parse a list */
LOCAL struct node *plist(fptr)
struct node *fptr;
{
struct node *oldstk,val,*lastnptr,*nptr;
int ch;
/* increment the nesting level */
xlplevel += 1;
/* create a new stack frame */
oldstk = xlsave(&val,NULL);
/* skip the opening paren */
xlgetc(fptr);
/* keep appending nodes until a closing paren is found */
lastnptr = NULL;
for (lastnptr = NULL; (ch = nextch(fptr)) != ')'; lastnptr = nptr) {
/* check for end of file */
if (ch == EOF)
badeof();
/* check for a dotted pair */
if (ch == '.') {
/* skip the dot */
xlgetc(fptr);
/* make sure there's a node */
if (lastnptr == NULL)
xlfail("invalid dotted pair");
/* parse the expression after the dot */
if (!parse(fptr,&lastnptr->n_listnext))
badeof();
/* make sure its followed by a close paren */
if (nextch(fptr) != ')')
xlfail("invalid dotted pair");
/* done with this list */
break;
}
/* allocate a new node and link it into the list */
nptr = newnode(LIST);
if (lastnptr == NULL)
val.n_ptr = nptr;
else
lastnptr->n_listnext = nptr;
/* initialize the new node */
if (!parse(fptr,&nptr->n_listvalue))
badeof();
}
/* skip the closing paren */
xlgetc(fptr);
/* restore the previous stack frame */
xlstack = oldstk;
/* decrement the nesting level */
xlplevel -= 1;
/* return successfully */
return (val.n_ptr);
}
/* pstring - parse a string */
LOCAL struct node *pstring(fptr)
struct node *fptr;
{
struct node *oldstk,val;
char sbuf[STRMAX+1];
int ch,i,d1,d2,d3;
/* create a new stack frame */
oldstk = xlsave(&val,NULL);
/* skip the opening quote */
xlgetc(fptr);
/* loop looking for a closing quote */
for (i = 0; i < STRMAX && (ch = checkeof(fptr)) != '"'; i++) {
switch (ch) {
case EOF:
badeof();
case '\\':
switch (ch = checkeof(fptr)) {
case 'e':
ch = '\033';
break;
case 'n':
ch = '\n';
break;
case 'r':
ch = '\r';
break;
case 't':
ch = '\t';
break;
default:
if (ch >= '0' && ch <= '7') {
d1 = ch - '0';
d2 = checkeof(fptr) - '0';
d3 = checkeof(fptr) - '0';
ch = (d1 << 6) + (d2 << 3) + d3;
}
break;
}
}
sbuf[i] = ch;
}
sbuf[i] = 0;
/* initialize the node */
val.n_ptr = newnode(STR);
val.n_ptr->n_str = strsave(sbuf);
val.n_ptr->n_strtype = DYNAMIC;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the new string */
return (val.n_ptr);
}
/* pquote - parse a quoted expression */
LOCAL struct node *pquote(fptr)
struct node *fptr;
{
struct node *oldstk,val;
/* create a new stack frame */
oldstk = xlsave(&val,NULL);
/* skip the quote character */
xlgetc(fptr);
/* allocate two nodes */
val.n_ptr = newnode(LIST);
val.n_ptr->n_listvalue = s_quote;
val.n_ptr->n_listnext = newnode(LIST);
/* initialize the second to point to the quoted expression */
if (!parse(fptr,&val.n_ptr->n_listnext->n_listvalue))
badeof();
/* restore the previous stack frame */
xlstack = oldstk;
/* return the quoted expression */
return (val.n_ptr);
}
/* pname - parse a symbol name */
LOCAL struct node *pname(fptr)
struct node *fptr;
{
char sname[STRMAX+1];
struct node *val;
int ch,i;
/* get symbol name */
for (i = 0; i < STRMAX && issym(xlpeek(fptr)); )
sname[i++] = xlgetc(fptr);
sname[i] = 0;
/* check for a number or enter the symbol into the oblist */
return (isnumber(sname,&val) ? val : xlenter(sname,DYNAMIC));
}
/* nextch - look at the next non-blank character */
LOCAL int nextch(fptr)
struct node *fptr;
{
int ch;
/* return and save the next non-blank character */
while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
xlgetc(fptr);
return (ch);
}
/* checkeof - get a character and check for end of file */
LOCAL int checkeof(fptr)
struct node *fptr;
{
int ch;
if ((ch = xlgetc(fptr)) == EOF)
badeof();
return (ch);
}
/* badeof - unexpected eof */
LOCAL badeof()
{
xlfail("unexpected EOF");
}
/* isnumber - check if this string is a number */
int isnumber(str,pval)
char *str; struct node **pval;
{
char *p;
int d;
/* initialize */
p = str; d = 0;
/* check for a sign */
if (*p == '+' || *p == '-')
p++;
/* check for a string of digits */
while (isdigit(*p))
p++, d++;
/* make sure there was at least one digit and this is the end */
if (d == 0 || *p)
return (FALSE);
/* convert the string to an integer and return successfully */
*pval = newnode(INT);
(*pval)->n_int = atoi(*str == '+' ? ++str : str);
return (TRUE);
}
/* issym - check whether a character if valid in a symbol name */
LOCAL int issym(ch)
int ch;
{
if (ch <= ' ' ||
ch == '(' ||
ch == ')' ||
ch == ';' ||
ch == '.' ||
ch == '"' ||
ch == '\'')
return (FALSE);
else
return (TRUE);
}
!Funky!Stuff!
echo x XLSTR.C
cat > XLSTR.C << '!Funky!Stuff!'
/* xlstr - xlisp string builtin functions */
#ifdef AZTEC
#include "stdio.h"
#else
#include <stdio.h>
#endif
#include "xlisp.h"
/* external variables */
extern struct node *xlstack;
/* external procedures */
extern char *strcat();
/* xstrlen - length of a string */
struct node *xstrlen(args)
struct node *args;
{
struct node *val;
int total;
/* initialize */
total = 0;
/* loop over args and total */
while (args != NULL)
total += strlen(xlmatch(STR,&args)->n_str);
/* create the value node */
val = newnode(INT);
val->n_int = total;
/* return the total */
return (val);
}
/* xstrcat - concatenate a bunch of strings */
struct node *xstrcat(args)
struct node *args;
{
struct node *oldstk,val,*p;
char *str;
int len;
/* create a new stack frame */
oldstk = xlsave(&val,NULL);
/* find the length of the new string */
for (p = args, len = 0; p; )
len += strlen(xlmatch(STR,&p)->n_str);
/* create the result string */
val.n_ptr = newnode(STR);
val.n_ptr->n_str = str = stralloc(len);
*str = 0;
/* combine the strings */
while (args)
strcat(str,xlmatch(STR,&args)->n_str);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the new string */
return (val.n_ptr);
}
/* xsubstr - return a substring */
struct node *xsubstr(args)
struct node *args;
{
struct node *oldstk,arg,src,val;
int start,forlen,srclen;
char *srcptr,*dstptr;
/* create a new stack frame */
oldstk = xlsave(&arg,&src,&val,NULL);
/* initialize */
arg.n_ptr = args;
/* get string and its length */
src.n_ptr = xlmatch(STR,&arg.n_ptr);
srcptr = src.n_ptr->n_str;
srclen = strlen(srcptr);
/* get starting pos -- must be present */
start = xlmatch(INT,&arg.n_ptr)->n_int;
/* get length -- if not present use remainder of string */
if (arg.n_ptr != NULL)
forlen = xlmatch(INT,&arg.n_ptr)->n_int;
else
forlen = srclen; /* use len and fix below */
/* make sure there aren't any more arguments */
xllastarg(arg.n_ptr);
/* don't take more than exists */
if (start + forlen > srclen)
forlen = srclen - start + 1;
/* if start beyond string -- return null string */
if (start > srclen) {
start = 1;
forlen = 0; }
/* create return node */
val.n_ptr = newnode(STR);
val.n_ptr->n_str = dstptr = stralloc(forlen);
/* move string */
for (srcptr += start-1; forlen--; *dstptr++ = *srcptr++)
;
*dstptr = 0;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the substring */
return (val.n_ptr);
}
/* xascii - return ascii value */
struct node *xascii(args)
struct node *args;
{
struct node *val;
/* build return node */
val = newnode(INT);
val->n_int = *(xlmatch(STR,&args)->n_str);
/* make sure there aren't any more arguments */
xllastarg(args);
/* return the character */
return (val);
}
/* xchr - convert an INT into a one character ascii string */
struct node *xchr(args)
struct node *args;
{
struct node *oldstk,val;
char *sptr;
/* create a new stack frame */
oldstk = xlsave(&val,NULL);
/* build return node */
val.n_ptr = newnode(STR);
val.n_ptr->n_str = sptr = stralloc(1);
*sptr++ = xlmatch(INT,&args)->n_int;
*sptr = 0;
/* make sure there aren't any more arguments */
xllastarg(args);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the new string */
return (val.n_ptr);
}
/* xatoi - convert an ascii string to an integer */
struct node *xatoi(args)
struct node *args;
{
struct node *val;
int n;
/* get the string and convert it */
n = atoi(xlmatch(STR,&args)->n_str);
/* make sure there aren't any more arguments */
xllastarg(args);
/* create the value node */
val = newnode(INT);
val->n_int = n;
/* return the number */
return (val);
}
/* xitoa - convert an integer to an ascii string */
struct node *xitoa(args)
struct node *args;
{
struct node *val;
char buf[20];
int n;
/* get the integer */
n = xlmatch(INT,&args)->n_int;
xllastarg(args);
/* convert it to ascii */
sprintf(buf,"%d",n);
/* create the value node */
val = newnode(STR);
val->n_str = strsave(buf);
/* return the string */
return (val);
}
!Funky!Stuff!
echo x XLSTUB.C
cat > XLSTUB.C << '!Funky!Stuff!'
/* xlstub.c - stubs for replacing the 'xlobj' module */
#ifdef AZTEC
#include "stdio.h"
#else
#include <stdio.h>
#endif
#include "xlisp.h"
struct node *xloinit() {}
struct node *xlsend() { return (NULL); }
struct node *xlobsym() { return (NULL); }
!Funky!Stuff!
echo x XLSUBR.C
cat > XLSUBR.C << '!Funky!Stuff!'
/* xlsubr - xlisp builtin function support routines */
#ifdef AZTEC
#include "stdio.h"
#else
#include <stdio.h>
#endif
#include "xlisp.h"
/* external variables */
extern struct node *xlstack;
/* xlsubr - define a builtin function */
xlsubr(sname,type,subr)
char *sname; int type; struct node *(*subr)();
{
struct node *sym;
/* enter the symbol */
sym = xlsenter(sname);
/* initialize the value */
sym->n_symvalue = newnode(type);
sym->n_symvalue->n_subr = subr;
}
/* xlarg - get the next argument */
struct node *xlarg(pargs)
struct node **pargs;
{
struct node *arg;
/* make sure the argument exists */
if (*pargs == NULL)
xlfail("too few arguments");
/* get the argument value */
arg = (*pargs)->n_listvalue;
/* move the argument pointer ahead */
*pargs = (*pargs)->n_listnext;
/* return the argument */
return (arg);
}
/* xlmatch - get an argument and match its type */
struct node *xlmatch(type,pargs)
int type; struct node **pargs;
{
struct node *arg;
/* get the argument */
arg = xlarg(pargs);
/* check its type */
if (type == LIST) {
if (arg != NULL && arg->n_type != LIST)
xlfail("bad argument type");
}
else {
if (arg == NULL || arg->n_type != type)
xlfail("bad argument type");
}
/* return the argument */
return (arg);
}
/* xlevarg - get the next argument and evaluate it */
struct node *xlevarg(pargs)
struct node **pargs;
{
struct node *oldstk,val;
/* create a new stack frame */
oldstk = xlsave(&val,NULL);
/* get the argument */
val.n_ptr = xlarg(pargs);
/* evaluate the argument */
val.n_ptr = xleval(val.n_ptr);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the argument */
return (val.n_ptr);
}
/* xlevmatch - get an evaluated argument and match its type */
struct node *xlevmatch(type,pargs)
int type; struct node **pargs;
{
struct node *arg;
/* get the argument */
arg = xlevarg(pargs);
/* check its type */
if (type == LIST) {
if (arg != NULL && arg->n_type != LIST)
xlfail("bad argument type");
}
else {
if (arg == NULL || arg->n_type != type)
xlfail("bad argument type");
}
/* return the argument */
return (arg);
}
/* xllastarg - make sure the remainder of the argument list is empty */
xllastarg(args)
struct node *args;
{
if (args != NULL)
xlfail("too many arguments");
}
/* assign - assign a value to a symbol */
assign(sym,val)
struct node *sym,*val;
{
struct node *lptr;
/* check for a current object */
if ((lptr = xlobsym(sym)) != NULL)
lptr->n_listvalue = val;
else
sym->n_symvalue = val;
}
!Funky!Stuff!
echo x XLSYM.C
cat > XLSYM.C << '!Funky!Stuff!'
/* xlsym - symbol handling routines */
#ifdef AZTEC
#include "stdio.h"
#else
#include <stdio.h>
#endif
#include "xlisp.h"
/* global variables */
struct node *oblist;
struct node *s_unbound;
/* external variables */
extern struct node *xlstack;
/* forward declarations */
FORWARD struct node *xlmakesym();
FORWARD struct node *findprop();
/* xlenter - enter a symbol into the oblist */
struct node *xlenter(name,type)
char *name;
{
struct node *oldstk,*lsym,*nsym,newsym;
int cmp;
/* check for nil */
if (strcmp(name,"nil") == 0)
return (NULL);
/* check for symbol already in table */
lsym = NULL;
nsym = oblist->n_symvalue;
while (nsym) {
if ((cmp = strcmp(name,xlsymname(nsym->n_listvalue))) <= 0)
break;
lsym = nsym;
nsym = nsym->n_listnext;
}
/* check to see if we found it */
if (nsym && cmp == 0)
return (nsym->n_listvalue);
/* make a new symbol node and link it into the oblist */
oldstk = xlsave(&newsym,NULL);
newsym.n_ptr = newnode(LIST);
newsym.n_ptr->n_listvalue = xlmakesym(name,type);
newsym.n_ptr->n_listnext = nsym;
if (lsym)
lsym->n_listnext = newsym.n_ptr;
else
oblist->n_symvalue = newsym.n_ptr;
xlstack = oldstk;
/* return the new symbol */
return (newsym.n_ptr->n_listvalue);
}
/* xlsenter - enter a symbol with a static print name */
struct node *xlsenter(name)
char *name;
{
return (xlenter(name,STATIC));
}
/* xlintern - intern a symbol onto the oblist */
struct node *xlintern(sym)
struct node *sym;
{
struct node *oldstk,*lsym,*nsym,newsym;
char *name;
int cmp;
/* get the symbol's print name */
name = xlsymname(sym);
/* check for nil */
if (strcmp(name,"nil") == 0)
return (NULL);
/* check for symbol already in table */
lsym = NULL;
nsym = oblist->n_symvalue;
while (nsym) {
if ((cmp = strcmp(name,xlsymname(nsym->n_listvalue))) <= 0)
break;
lsym = nsym;
nsym = nsym->n_listnext;
}
/* check to see if we found it */
if (nsym && cmp == 0)
return (nsym->n_listvalue);
/* link the symbol into the oblist */
oldstk = xlsave(&newsym,NULL);
newsym.n_ptr = newnode(LIST);
newsym.n_ptr->n_listvalue = sym;
newsym.n_ptr->n_listnext = nsym;
if (lsym)
lsym->n_listnext = newsym.n_ptr;
else
oblist->n_symvalue = newsym.n_ptr;
xlstack = oldstk;
/* return the symbol */
return (sym);
}
/* xlmakesym - make a new symbol node */
struct node *xlmakesym(name,type)
char *name;
{
struct node *oldstk,sym,*str;
/* create a new stack frame */
oldstk = xlsave(&sym,NULL);
/* make a new symbol node */
sym.n_ptr = newnode(SYM);
sym.n_ptr->n_symvalue = s_unbound;
sym.n_ptr->n_symplist = newnode(LIST);
sym.n_ptr->n_symplist->n_listvalue = str = newnode(STR);
str->n_str = (type == DYNAMIC ? strsave(name) : name);
str->n_strtype = type;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the new symbol node */
return (sym.n_ptr);
}
/* xlsymname - return the print name of a symbol */
char *xlsymname(sym)
struct node *sym;
{
return (sym->n_symplist->n_listvalue->n_str);
}
/* xlgetprop - get the value of a property */
struct node *xlgetprop(sym,prp)
struct node *sym,*prp;
{
struct node *p;
if ((p = findprop(sym,prp)) == NULL)
return (NULL);
return (p->n_listnext);
}
/* xlputprop - put a property value onto the property list */
xlputprop(sym,val,prp)
struct node *sym,*val,*prp;
{
struct node *oldstk,p,*pair;
if ((pair = findprop(sym,prp)) == NULL) {
oldstk = xlsave(&p,NULL);
p.n_ptr = newnode(LIST);
p.n_ptr->n_listvalue = pair = newnode(LIST);
p.n_ptr->n_listnext = sym->n_symplist->n_listnext;
sym->n_symplist->n_listnext = p.n_ptr;
pair->n_listvalue = prp;
xlstack = oldstk;
}
pair->n_listnext = val;
}
/* xlremprop - remove a property from a property list */
xlremprop(sym,prp)
struct node *sym,*prp;
{
struct node *last,*p;
last = NULL;
for (p = sym->n_symplist->n_listnext; p; p = p->n_listnext) {
if (p->n_listvalue->n_listvalue == prp)
if (last)
last->n_listnext = p->n_listnext;
else
sym->n_symplist->n_listnext = p->n_listnext;
last = p;
}
}
/* findprop - find a property pair */
LOCAL struct node *findprop(sym,prp)
struct node *sym,*prp;
{
struct node *p;
for (p = sym->n_symplist->n_listnext; p; p = p->n_listnext)
if (p->n_listvalue->n_listvalue == prp)
return (p->n_listvalue);
return (NULL);
}
/* xlsinit - symbol initialization routine */
xlsinit()
{
/* initialize the oblist */
oblist = xlmakesym("*oblist*",STATIC);
oblist->n_symvalue = newnode(LIST);
oblist->n_symvalue->n_listvalue = oblist;
/* enter the unbound symbol indicator */
s_unbound = xlsenter("*unbound*");
s_unbound->n_symvalue = s_unbound;
}
!Funky!Stuff!
echo x XLSYS.C
cat > XLSYS.C << '!Funky!Stuff!'
/* xlsys.c - xlisp builtin system functions */
#ifdef AZTEC
#include "stdio.h"
#else
#include <stdio.h>
#endif
#include "xlisp.h"
/* external variables */
extern struct node *xlstack;
extern int anodes;
/* external symbols */
extern struct node *a_subr;
extern struct node *a_fsubr;
extern struct node *a_list;
extern struct node *a_sym;
extern struct node *a_int;
extern struct node *a_str;
extern struct node *a_obj;
extern struct node *a_fptr;
/* xload - direct input from a file */
struct node *xload(args)
struct node *args;
{
struct node *oldstk,fname,*val;
/* create a new stack frame */
oldstk = xlsave(&fname,NULL);
/* get the file name */
fname.n_ptr = xlmatch(STR,&args);
xllastarg(args);
/* load the file */
val = (xlload(fname.n_ptr->n_str) ? fname.n_ptr : NULL);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the status */
return (val);
}
/* xgc - xlisp function to force garbage collection */
struct node *xgc(args)
struct node *args;
{
/* make sure there aren't any arguments */
xllastarg(args);
/* garbage collect */
gc();
/* return null */
return (NULL);
}
/* xexpand - xlisp function to force memory expansion */
struct node *xexpand(args)
struct node *args;
{
struct node *val;
int n,i;
/* get the new number to allocate */
if (args == NULL)
n = 1;
else
n = xlmatch(INT,&args)->n_int;
/* make sure there aren't any more arguments */
xllastarg(args);
/* allocate more segments */
for (i = 0; i < n; i++)
if (!addseg())
break;
/* return the number of segments added */
val = newnode(INT);
val->n_int = i;
return (val);
}
/* xalloc - xlisp function to set the number of nodes to allocate */
struct node *xalloc(args)
struct node *args;
{
struct node *val;
int n,oldn;
/* get the new number to allocate */
n = xlmatch(INT,&args)->n_int;
/* make sure there aren't any more arguments */
xllastarg(args);
/* set the new number of nodes to allocate */
oldn = anodes;
anodes = n;
/* return the old number */
val = newnode(INT);
val->n_int = oldn;
return (val);
}
/* xmem - xlisp function to print memory statistics */
struct node *xmem(args)
struct node *args;
{
/* make sure there aren't any arguments */
xllastarg(args);
/* print the statistics */
stats();
/* return null */
return (NULL);
}
/* xtype - return type of a thing */
struct node *xtype(args)
struct node *args;
{
struct node *arg;
if (!(arg = xlarg(&args)))
return (NULL);
switch (arg->n_type) {
case SUBR: return (a_subr);
case FSUBR: return (a_fsubr);
case LIST: return (a_list);
case SYM: return (a_sym);
case INT: return (a_int);
case STR: return (a_str);
case OBJ: return (a_obj);
case FPTR: return (a_fptr);
default: xlfail("bad node type");
}
}
/* xexit - get out of xlisp */
xexit()
{
exit();
}
!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?