betz (01/06/83)
::::::::::::::
xlbind.c
::::::::::::::
/* xlbind - xlisp symbol binding routines */
#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(BND);
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 "xlisp.h"
/* useful definitions */
#define ALLOCSIZE (sizeof(struct segment) + anodes * sizeof(struct node))
/* memory segment structure definition */
struct segment {
int sg_size;
struct seg *sg_next;
struct node sg_nodes[];
};
/* external variables */
extern struct node *oblist;
extern struct node *xlstack;
extern struct node *xlenv;
/* 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 segment *seg;
struct node *n;
int i;
/* 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 = 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 DBPTR:
return (FALSE);
case KMAP:
xlkmmark(n);
return (FALSE);
case LIST:
case FUN:
case OBJ:
return (n->n_left != NULL);
default:
printf("bad node type found during garbage collection\n");
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 DBPTR:
case KMAP:
return (FALSE);
case SYM:
case LIST:
case FUN:
case OBJ:
return (n->n_right != NULL);
default:
printf("bad node type found during garbage collection\n");
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 */
if (args != NULL)
xlfail("too many arguments");
/* 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 */
if (args != NULL)
xlfail("too many arguments");
/* 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 */
if (args != NULL)
xlfail("too many arguments");
/* 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 */
if (args != NULL)
xlfail("too many arguments");
/* 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);
}
::::::::::::::
xlio.c
::::::::::::::
/* xlio - xlisp i/o routines */
#include <stdio.h>
#include "xlisp.h"
/* global variables */
int (*xlgetc)();
int xlpvals;
/* local variables */
static int prompt;
static FILE *ifp;
/* tgetc - get a character from the terminal */
static int tgetc()
{
int ch;
/* prompt if necessary */
if (prompt) {
printf("> ");
prompt = FALSE;
}
/* get the character */
if ((ch = getchar()) == '\n')
prompt = TRUE;
/* return the character */
return (ch);
}
/* xltin - setup terminal input */
int xltin()
{
/* initialize */
prompt = TRUE;
xlgetc = tgetc;
xlpvals = TRUE;
}
/* fgetc - get a character from a file */
static int fgetc()
{
int ch;
/* get a character */
if ((ch = getc(ifp)) <= 0) {
xlgetc = tgetc;
xlpvals = TRUE;
return (tgetc());
}
/* return it */
return (ch);
}
/* xlfin - setup file input */
xlfin(str)
char *str;
{
char fname[100];
/* create the file name */
strcpy(fname,str);
/* open the input file */
if ((ifp = fopen(fname,"r")) == NULL) {
printf("can't open \"%s\" for input\n",fname);
return;
}
/* setup input from the file */
xlgetc = fgetc;
xlpvals = FALSE;
}
::::::::::::::
xlkbin.c
::::::::::::::
kbin()
{ return (-1);
}