Dave Betz' XLISP 1.2 (The Real Thing) Part 5/5 Hallelujah!

[John Woods]

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 at MIT-XX

When your puppy goes off in another room,
is it because of the explosive charge?