betz (04/01/83)
<<<<<<<<<< xlbind.c >>>>>>>>>>
/* xlbind - xlisp symbol binding routines */
#include <stdio.h>
#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;
}
}
<<<<<<<<<< xldmem.c >>>>>>>>>>
/* xldmem - xlisp dynamic memory management routines */
#include <stdio.h>
#include "xlisp.h"
/* useful definitions */
#define ALLOCSIZE (sizeof(struct segment) + anodes * sizeof(struct node))
/* memory segment structure definition */
struct segment {
int sg_size;
struct segment *sg_next;
struct node sg_nodes[];
};
/* 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_left = NULL;
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 */
static gc()
{
/* unmark all nodes */
unmark();
/* mark all accessible nodes */
mark(oblist);
mark(xlstack);
mark(xlenv);
/* 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;
}
/* unmark - unmark each node */
static unmark()
{
struct node *n;
/* unmark the stack */
for (n = xlstack; n != NULL ; n = n->n_listnext)
n->n_flags &= ~(MARK | LEFT);
}
/* mark - mark all accessible nodes */
static 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 */
static sweep()
{
struct segment *seg;
struct node *n;
int i;
/* empty the free list */
fnodes = NULL;
nfree = 0;
/* add all unmarked nodes */
for (seg = segs; seg != NULL; seg = seg->sg_next)
for (i = 0; i < seg->sg_size; i++)
if (!((n = &seg->sg_nodes[i])->n_flags & MARK)) {
switch (n->n_type) {
case STR:
if (n->n_strtype == DYNAMIC && n->n_str != NULL)
strfree(n->n_str);
break;
case SYM:
if (n->n_symname != NULL)
strfree(n->n_symname);
break;
case KMAP:
xlkmfree(n);
break;
}
n->n_type = FREE;
n->n_left = NULL;
n->n_right = fnodes;
fnodes = n;
nfree += 1;
}
else
n->n_flags &= ~MARK;
}
/* addseg - add a segment to the available memory */
static int addseg()
{
struct segment *newseg;
int i;
/* 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 */
for (i = 0; i < newseg->sg_size; i++) {
newseg->sg_nodes[i].n_right = fnodes;
fnodes = &newseg->sg_nodes[i];
}
/* update the statistics */
nnodes += anodes;
nfree += anodes;
nsegs += 1;
/* return successfully */
return (TRUE);
}
else
return (FALSE);
}
/* left - check for a left sublist */
static int left(n)
struct node *n;
{
switch (n->n_type) {
case SYM:
case SUBR:
case INT:
case STR:
case FPTR:
return (FALSE);
case KMAP:
xlkmmark(n);
return (FALSE);
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 */
static int right(n)
struct node *n;
{
switch (n->n_type) {
case SUBR:
case INT:
case STR:
case FPTR:
case KMAP:
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 */
static stats()
{
putchar('\n');
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);
putchar('\n');
}
/* fgc - xlisp function to force garbage collection */
static struct node *fgc(args)
struct node *args;
{
/* make sure there aren't any arguments */
xllastarg(args);
/* garbage collect */
gc();
/* return null */
return (NULL);
}
/* fexpand - xlisp function to force memory expansion */
static struct node *fexpand(args)
struct node *args;
{
struct node *val;
int n,i;
/* get the new number to allocate */
if (args == NULL)
n = 1;
else
n = xlevmatch(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);
}
/* falloc - xlisp function to set the number of nodes to allocate */
static struct node *falloc(args)
struct node *args;
{
struct node *val;
int n,oldn;
/* get the new number to allocate */
n = xlevmatch(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);
}
/* fmem - xlisp function to print memory statistics */
static struct node *fmem(args)
struct node *args;
{
/* make sure there aren't any arguments */
xllastarg(args);
/* print the statistics */
stats();
/* return null */
return (NULL);
}
/* xldmeminit - initialize the dynamic memory module */
xldmeminit()
{
/* setup the default number of nodes to allocate */
anodes = NNODES;
nnodes = nsegs = nfree = gccalls = 0;
/* define some xlisp functions */
xlsubr("gc",fgc);
xlsubr("expand",fexpand);
xlsubr("alloc",falloc);
xlsubr("mem",fmem);
}
<<<<<<<<<< xleval.c >>>>>>>>>>
/* xleval - xlisp evaluator */
#include <stdio.h>
#include <setjmp.h>
#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;
/* local variables */
static struct node *slash;
/* forward declarations (the extern hack is for decusc) */
extern struct node *evlist();
extern struct node *evsym();
extern struct node *evfun();
/* eval - the builtin function 'eval' */
static struct node *eval(args)
struct node *args;
{
struct node *expr;
/* get the expression to evaluate */
expr = xlevarg(&args);
/* make sure there aren't any more arguments */
xllastarg(args);
/* return the expression evaluated */
return (xleval(expr));
}
/* xleval - evaluate an xlisp expression */
struct node *xleval(expr)
struct node *expr;
{
/* evaluate null to itself */
if (expr == NULL)
return (NULL);
/* check type of value */
switch (expr->n_type) {
case LIST:
return (evlist(expr));
case SYM:
return (evsym(expr));
case INT:
case STR:
case SUBR:
return (expr);
default:
xlfail("can't evaluate expression");
}
}
/* 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);
}
/* evlist - evaluate a list */
static struct node *evlist(nptr)
struct node *nptr;
{
struct node *oldstk,fun,args,*val;
/* 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;
/* add trace entry */
tpush(nptr);
/* 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:
val = (*fun.n_ptr->n_subr)(args.n_ptr);
break;
case LIST:
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;
/* remove trace entry */
tpop();
/* return the result value */
return (val);
}
/* evsym - evaluate a symbol */
static struct node *evsym(sym)
struct node *sym;
{
struct node *lptr;
/* check for a current object */
if ((lptr = xlobsym(sym)) != NULL)
return (lptr->n_listvalue);
else
return (sym->n_symvalue);
}
/* evfun - evaluate a function */
static struct node *evfun(fun,args)
struct node *fun,*args;
{
struct node *oldenv,*oldstk,cptr,*val;
/* create a stack frame */
oldstk = xlsave(&cptr,NULL);
/* bind the formal parameters */
oldenv = xlenv;
xlabind(fun->n_listvalue,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,val;
/* create a stack frame */
oldstk = xlsave(&farg,&aarg,&val,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 local variable separator */
if (farg.n_ptr->n_listvalue == slash)
break;
/* evaluate the argument */
val.n_ptr = xlevarg(&aarg.n_ptr);
/* bind the formal variable to the argument value */
xlbind(farg.n_ptr->n_listvalue,val.n_ptr);
/* move the formal argument list pointer ahead */
farg.n_ptr = farg.n_ptr->n_listnext;
}
/* check for local variables */
if (farg.n_ptr != NULL && farg.n_ptr->n_listvalue == slash)
while ((farg.n_ptr = farg.n_ptr->n_listnext) != NULL)
xlbind(farg.n_ptr->n_listvalue,NULL);
/* restore the previous stack frame */
xlstack = oldstk;
/* make sure the correct number of arguments were supplied */
if (farg.n_ptr != aarg.n_ptr)
xlfail("incorrect number of arguments to a function");
}
/* xlfail - error handling routine */
xlfail(err)
char *err;
{
/* print the error message */
printf("error: %s\n",err);
/* unbind bound symbols */
xlunbind(NULL);
/* restore input to the terminal */
xltin(TRUE);
/* do the back trace */
trace();
trace_pointer = -1;
/* restart */
longjmp(xljmpbuf,1);
}
/* tpush - add an entry to the trace stack */
static tpush(nptr)
struct node *nptr;
{
if (++trace_pointer < TDEPTH)
trace_stack[trace_pointer] = nptr;
}
/* tpop - pop an entry from the trace stack */
static tpop()
{
trace_pointer--;
}
/* trace - do a back trace */
static trace()
{
for (; trace_pointer >= 0; trace_pointer--)
if (trace_pointer < TDEPTH) {
xlprint(trace_stack[trace_pointer],TRUE);
putchar('\n');
}
}
/* xleinit - initialize the evaluator */
xleinit()
{
/* enter the local variable separator symbol */
slash = xlenter("/");
/* initialize debugging stuff */
trace_pointer = -1;
/* builtin functions */
xlsubr("eval",eval);
}
<<<<<<<<<< xlfio.c >>>>>>>>>>
/* xlfio - xlisp file i/o */
#include <stdio.h>
#include "xlisp.h"
/* external variables */
extern struct node *xlstack;
/* local variables */
static char buf[STRMAX+1];
/* xlfopen - open a file */
static struct node *xlfopen(args)
struct node *args;
{
struct node *oldstk,arg,fname,mode,*val;
FILE *fp;
/* create a new stack frame */
oldstk = xlsave(&arg,&fname,&mode,NULL);
/* initialize */
arg.n_ptr = args;
/* get the file name */
fname.n_ptr = xlevmatch(STR,&arg.n_ptr);
/* get the mode */
mode.n_ptr = xlevmatch(STR,&arg.n_ptr);
/* make sure there aren't any more arguments */
xllastarg(arg.n_ptr);
/* try to open the file */
if ((fp = fopen(fname.n_ptr->n_str,
mode.n_ptr->n_str)) != NULL) {
val = newnode(FPTR);
val->n_fp = fp;
}
else
val = NULL;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the file pointer */
return (val);
}
/* xlfclose - close a file */
static struct node *xlfclose(args)
struct node *args;
{
struct node *fptr;
/* get file pointer */
fptr = xlevmatch(FPTR,&args);
/* make sure there aren't any more arguments */
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);
}
/* xlgetc - get a character from a file */
static struct node *xlgetc(args)
struct node *args;
{
struct node *val;
FILE *fp;
int ch;
/* get file pointer */
if (args != NULL)
fp = xlevmatch(FPTR,&args)->n_fp;
else
fp = stdin;
/* make sure there aren't any more arguments */
xllastarg(args);
/* make sure the file exists */
if (fp == NULL)
xlfail("file not open");
/* get character and check for eof */
if ((ch = getc(fp)) != EOF) {
/* create return node */
val = newnode(INT);
val->n_int = ch;
}
else
val = NULL;
/* return the character */
return (val);
}
/* xlputc - put a character to a file */
static struct node *xlputc(args)
struct node *args;
{
struct node *oldstk,arg,chr;
FILE *fp;
/* create a new stack frame */
oldstk = xlsave(&arg,&chr,NULL);
/* initialize */
arg.n_ptr = args;
/* get the character */
chr.n_ptr = xlevmatch(INT,&arg.n_ptr);
/* get file pointer */
if (arg.n_ptr != NULL)
fp = xlevmatch(FPTR,&arg.n_ptr)->n_fp;
else
fp = stdout;
/* make sure there aren't any more arguments */
xllastarg(arg.n_ptr);
/* make sure the file exists */
if (fp == NULL)
xlfail("file not open");
/* put character to the file */
putc(chr.n_ptr->n_int,fp);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the character */
return (chr.n_ptr);
}
/* xlfgets - get a string from a file */
static struct node *xlfgets(args)
struct node *args;
{
struct node *str;
char *sptr;
FILE *fp;
/* get file pointer */
if (args != NULL)
fp = xlevmatch(FPTR,&args)->n_fp;
else
fp = stdin;
/* make sure there aren't any more arguments */
xllastarg(args);
/* make sure the file exists */
if (fp == NULL)
xlfail("file not open");
/* get character and check for eof */
if (fgets(buf,STRMAX,fp) != NULL) {
/* create return node */
str = newnode(STR);
str->n_str = strsave(buf);
/* make sure we got the whole string */
while (buf[strlen(buf)-1] != '\n') {
if (fgets(buf,STRMAX,fp) == NULL)
break;
sptr = str->n_str;
str->n_str = stralloc(strlen(sptr) + strlen(buf));
strcpy(str->n_str,sptr);
strcat(buf);
strfree(sptr);
}
}
else
str = NULL;
/* return the string */
return (str);
}
/* xlfputs - put a string to a file */
static struct node *xlfputs(args)
struct node *args;
{
struct node *oldstk,arg,str;
FILE *fp;
/* create a new stack frame */
oldstk = xlsave(&arg,&str,NULL);
/* initialize */
arg.n_ptr = args;
/* get the string */
str.n_ptr = xlevmatch(STR,&arg.n_ptr);
/* get file pointer */
if (arg.n_ptr != NULL)
fp = xlevmatch(FPTR,&arg.n_ptr)->n_fp;
else
fp = stdout;
/* make sure there aren't any more arguments */
xllastarg(arg.n_ptr);
/* make sure the file exists */
if (fp == NULL)
xlfail("file not open");
/* put string to the file */
fputs(str.n_ptr->n_str,fp);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the string */
return (str.n_ptr);
}
/* xlfinit - initialize file stuff */
xlfinit()
{
xlsubr("fopen",xlfopen);
xlsubr("fclose",xlfclose);
xlsubr("getc",xlgetc);
xlsubr("putc",xlputc);
xlsubr("fgets",xlfgets);
xlsubr("fputs",xlfputs);
}