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