Personal tools
You are here: Home Projects LISP XLISP XLISP 0.0 USENET net.sources 1983_01_06-net_sources-betz-xlisp10_4.txt
Document Actions

1983_01_06-net_sources-betz-xlisp10_4.txt

by Paul McJones last modified 2011-01-24 09:49

::::::::::::::
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);
}

« May 2013 »
Su Mo Tu We Th Fr Sa
1 2 3 4
5 6 7 8 9 10 11
12 13 14 15 16 17 18
19 20 21 22 23 24 25
26 27 28 29 30 31
 

Powered by Plone CMS, the Open Source Content Management System

This site conforms to the following standards: