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

[John Woods]

[ Replace this line with your bug ]

Here is part two of the Newest XLISP 1.2 posting.

echo extract with sh, not csh
echo x XLFIO.C
cat > XLFIO.C << '!Funky!Stuff!'
/* xlfio.c - xlisp file i/o */

#ifdef AZTEC
#include "stdio.h"
#else
#include <stdio.h>
#include <ctype.h>
#endif

#include "xlisp.h"

/* external variables */
extern struct node *s_stdin,*s_stdout;
extern struct node *xlstack;
extern int xlfsize;

/* external routines */
extern FILE *fopen();

/* local variables */
static char buf[STRMAX+1];

/* forward declarations */
FORWARD struct node *printit();
FORWARD struct node *flatsize();
FORWARD struct node *explode();
FORWARD struct node *makesym();
FORWARD struct node *openit();
FORWARD struct node *getfile();

/* xread - read an expression */
struct node *xread(args)
  struct node *args;
{
    struct node *oldstk,fptr,eof,*val;

    /* create a new stack frame */
    oldstk = xlsave(&fptr,&eof,NULL);

    /* get file pointer and eof value */
    fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
    eof.n_ptr = (args ? xlarg(&args) : NULL);
    xllastarg(args);

    /* read an expression */
    if (!xlread(fptr.n_ptr,&val))
	val = eof.n_ptr;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the expression */
    return (val);
}

/* xprint - builtin function 'print' */
struct node *xprint(args)
  struct node *args;
{
    return (printit(args,TRUE,TRUE));
}

/* xprin1 - builtin function 'prin1' */
struct node *xprin1(args)
  struct node *args;
{
    return (printit(args,TRUE,FALSE));
}

/* xprinc - builtin function princ */
struct node *xprinc(args)
  struct node *args;
{
    return (printit(args,FALSE,FALSE));
}

/* xterpri - terminate the current print line */
struct node *xterpri(args)
  struct node *args;
{
    struct node *fptr;

    /* get file pointer */
    fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
    xllastarg(args);

    /* terminate the print line and return nil */
    xlterpri(fptr);
    return (NULL);
}

/* printit - common print function */
LOCAL struct node *printit(args,pflag,tflag)
  struct node *args; int pflag,tflag;
{
    struct node *oldstk,fptr,val;

    /* create a new stack frame */
    oldstk = xlsave(&fptr,&val,NULL);

    /* get expression to print and file pointer */
    val.n_ptr = xlarg(&args);
    fptr.n_ptr = (args ? getfile(&args) : s_stdout->n_symvalue);
    xllastarg(args);

    /* print the value */
    xlprint(fptr.n_ptr,val.n_ptr,pflag);

    /* terminate the print line if necessary */
    if (tflag)
	xlterpri(fptr.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result */
    return (val.n_ptr);
}

/* xflatsize - compute the size of a printed representation using prin1 */
struct node *xflatsize(args)
  struct node *args;
{
    return (flatsize(args,TRUE));
}

/* xflatc - compute the size of a printed representation using princ */
struct node *xflatc(args)
  struct node *args;
{
    return (flatsize(args,FALSE));
}

/* flatsize - compute the size of a printed expression */
LOCAL struct node *flatsize(args,pflag)
  struct node *args; int pflag;
{
    struct node *oldstk,val;

    /* create a new stack frame */
    oldstk = xlsave(&val,NULL);

    /* get the expression */
    val.n_ptr = xlarg(&args);
    xllastarg(args);

    /* print the value to compute its size */
    xlfsize = 0;
    xlprint(NULL,val.n_ptr,pflag);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the length of the expression */
    val.n_ptr = newnode(INT);
    val.n_ptr->n_int = xlfsize;
    return (val.n_ptr);
}

/* xexplode - explode an expression */
struct node *xexplode(args)
  struct node *args;
{
    return (explode(args,TRUE));
}

/* xexplc - explode an expression using princ */
struct node *xexplc(args)
  struct node *args;
{
    return (explode(args,FALSE));
}

/* explode - internal explode routine */
LOCAL struct node *explode(args,pflag)
  struct node *args; int pflag;
{
    struct node *oldstk,val,strm;

    /* create a new stack frame */
    oldstk = xlsave(&val,&strm,NULL);

    /* get the expression */
    val.n_ptr = xlarg(&args);
    xllastarg(args);

    /* create a stream */
    strm.n_ptr = newnode(LIST);

    /* print the value into the stream */
    xlprint(strm.n_ptr,val.n_ptr,pflag);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the list of characters */
    return (strm.n_ptr->n_listvalue);
}

/* ximplode - implode a list of characters into an expression */
struct node *ximplode(args)
  struct node *args;
{
    return (makesym(args,TRUE));
}

/* xmaknam - implode a list of characters into an uninterned symbol */
struct node *xmaknam(args)
  struct node *args;
{
    return (makesym(args,FALSE));
}

/* makesym - internal implode routine */
LOCAL struct node *makesym(args,intflag)
  struct node *args; int intflag;
{
    struct node *list,*val;
    char *p;

    /* get the list */
    list = xlarg(&args);
    xllastarg(args);

    /* assemble the symbol's pname */
    for (p = buf; list && list->n_type == LIST; list = list->n_listnext) {
	if ((val = list->n_listvalue) == NULL || val->n_type != INT)
	    xlfail("bad character list");
	if ((int)(p - buf) < STRMAX)
	    *p++ = val->n_int;
    }
    *p = 0;

    /* create a symbol */
    val = (intflag ? xlenter(buf,DYNAMIC) : xlmakesym(buf,DYNAMIC));

    /* return the symbol */
    return (val);
}

/* xopeni - open an input file */
struct node *xopeni(args)
  struct node *args;
{
    return (openit(args,"r"));
}

/* xopeno - open an output file */
struct node *xopeno(args)
  struct node *args;
{
    return (openit(args,"w"));
}

/* openit - common file open routine */
LOCAL struct node *openit(args,mode)
  struct node *args; char *mode;
{
    struct node *fname,*val;
    FILE *fp;

    /* get the file name */
    fname = xlmatch(STR,&args);
    xllastarg(args);

    /* try to open the file */
    if ((fp = fopen(fname->n_str,mode)) != NULL) {
	val = newnode(FPTR);
	val->n_fp = fp;
	val->n_savech = 0;
    }
    else
	val = NULL;

    /* return the file pointer */
    return (val);
}

/* xclose - close a file */
struct node *xclose(args)
  struct node *args;
{
    struct node *fptr;

    /* get file pointer */
    fptr = xlmatch(FPTR,&args);
    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);
}

/* xrdchar - read a character from a file */
struct node *xrdchar(args)
  struct node *args;
{
    struct node *fptr,*val;
    int ch;

    /* get file pointer */
    fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
    xllastarg(args);

    /* get character and check for eof */
    if ((ch = xlgetc(fptr)) == EOF)
	val = NULL;
    else {
	val = newnode(INT);
	val->n_int = ch;
    }

    /* return the character */
    return (val);
}

/* xpkchar - peek at a character from a file */
struct node *xpkchar(args)
  struct node *args;
{
    struct node *flag,*fptr,*val;
    int ch;

    /* peek flag and get file pointer */
    flag = (args ? xlarg(&args) : NULL);
    fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
    xllastarg(args);

    /* skip leading white space and get a character */
    if (flag)
	while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
	    xlgetc(fptr);
    else
	ch = xlpeek(fptr);

    /* check for eof */
    if (ch == EOF)
	val = NULL;
    else {
	val = newnode(INT);
	val->n_int = ch;
    }

    /* return the character */
    return (val);
}

/* xwrchar - write a character to a file */
struct node *xwrchar(args)
  struct node *args;
{
    struct node *fptr,*chr;

    /* get the character and file pointer */
    chr = xlmatch(INT,&args);
    fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
    xllastarg(args);

    /* put character to the file */
    xlputc(fptr,chr->n_int);

    /* return the character */
    return (chr);
}

/* xreadline - read a line from a file */
struct node *xreadline(args)
  struct node *args;
{
    struct node *oldstk,fptr,str;
    char *p,*sptr;
    int len,ch;

    /* create a new stack frame */
    oldstk = xlsave(&fptr,&str,NULL);

    /* get file pointer */
    fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
    xllastarg(args);

    /* make a string node */
    str.n_ptr = newnode(STR);
    str.n_ptr->n_strtype = DYNAMIC;

    /* get character and check for eof */
    len = 0; p = buf;
    while ((ch = xlgetc(fptr.n_ptr)) != EOF && ch != '\n') {

	/* check for buffer overflow */
	if ((int)(p - buf) == STRMAX) {
	    *p = 0;
 	    sptr = stralloc(len + STRMAX); *sptr = 0;
	    if (len) {
		strcpy(sptr,str.n_ptr->n_str);
		strfree(str.n_ptr->n_str);
	    }
	    str.n_ptr->n_str = sptr;
	    strcat(sptr,buf);
	    len += STRMAX;
	    p = buf;
	}

	/* store the character */
	*p++ = ch;
    }

    /* check for end of file */
    if (len == 0 && p == buf && ch == EOF) {
	xlstack = oldstk;
	return (NULL);
    }

    /* append the last substring */
    *p = 0;
    sptr = stralloc(len + (int)(p - buf)); *sptr = 0;
    if (len) {
	strcpy(sptr,str.n_ptr->n_str);
	strfree(str.n_ptr->n_str);
    }
    str.n_ptr->n_str = sptr;
    strcat(sptr,buf);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the string */
    return (str.n_ptr);
}

/* getfile - get a file or stream */
LOCAL struct node *getfile(pargs)
  struct node **pargs;
{
    struct node *arg;

    /* get a file or stream (cons) or nil */
    if (arg = xlarg(pargs)) {
	if (arg->n_type == FPTR) {
	    if (arg->n_fp == NULL)
		xlfail("file closed");
	}
	else if (arg->n_type != LIST)
	    xlfail("bad file or stream");
    }
    return (arg);
}
!Funky!Stuff!
echo x XLFIO.C
cat > XLFIO.C << '!Funky!Stuff!'
/* xlfio.c - xlisp file i/o */

#ifdef AZTEC
#include "stdio.h"
#else
#include <stdio.h>
#include <ctype.h>
#endif

#include "xlisp.h"

/* external variables */
extern struct node *s_stdin,*s_stdout;
extern struct node *xlstack;
extern int xlfsize;

/* external routines */
extern FILE *fopen();

/* local variables */
static char buf[STRMAX+1];

/* forward declarations */
FORWARD struct node *printit();
FORWARD struct node *flatsize();
FORWARD struct node *explode();
FORWARD struct node *makesym();
FORWARD struct node *openit();
FORWARD struct node *getfile();

/* xread - read an expression */
struct node *xread(args)
  struct node *args;
{
    struct node *oldstk,fptr,eof,*val;

    /* create a new stack frame */
    oldstk = xlsave(&fptr,&eof,NULL);

    /* get file pointer and eof value */
    fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
    eof.n_ptr = (args ? xlarg(&args) : NULL);
    xllastarg(args);

    /* read an expression */
    if (!xlread(fptr.n_ptr,&val))
	val = eof.n_ptr;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the expression */
    return (val);
}

/* xprint - builtin function 'print' */
struct node *xprint(args)
  struct node *args;
{
    return (printit(args,TRUE,TRUE));
}

/* xprin1 - builtin function 'prin1' */
struct node *xprin1(args)
  struct node *args;
{
    return (printit(args,TRUE,FALSE));
}

/* xprinc - builtin function princ */
struct node *xprinc(args)
  struct node *args;
{
    return (printit(args,FALSE,FALSE));
}

/* xterpri - terminate the current print line */
struct node *xterpri(args)
  struct node *args;
{
    struct node *fptr;

    /* get file pointer */
    fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
    xllastarg(args);

    /* terminate the print line and return nil */
    xlterpri(fptr);
    return (NULL);
}

/* printit - common print function */
LOCAL struct node *printit(args,pflag,tflag)
  struct node *args; int pflag,tflag;
{
    struct node *oldstk,fptr,val;

    /* create a new stack frame */
    oldstk = xlsave(&fptr,&val,NULL);

    /* get expression to print and file pointer */
    val.n_ptr = xlarg(&args);
    fptr.n_ptr = (args ? getfile(&args) : s_stdout->n_symvalue);
    xllastarg(args);

    /* print the value */
    xlprint(fptr.n_ptr,val.n_ptr,pflag);

    /* terminate the print line if necessary */
    if (tflag)
	xlterpri(fptr.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result */
    return (val.n_ptr);
}

/* xflatsize - compute the size of a printed representation using prin1 */
struct node *xflatsize(args)
  struct node *args;
{
    return (flatsize(args,TRUE));
}

/* xflatc - compute the size of a printed representation using princ */
struct node *xflatc(args)
  struct node *args;
{
    return (flatsize(args,FALSE));
}

/* flatsize - compute the size of a printed expression */
LOCAL struct node *flatsize(args,pflag)
  struct node *args; int pflag;
{
    struct node *oldstk,val;

    /* create a new stack frame */
    oldstk = xlsave(&val,NULL);

    /* get the expression */
    val.n_ptr = xlarg(&args);
    xllastarg(args);

    /* print the value to compute its size */
    xlfsize = 0;
    xlprint(NULL,val.n_ptr,pflag);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the length of the expression */
    val.n_ptr = newnode(INT);
    val.n_ptr->n_int = xlfsize;
    return (val.n_ptr);
}

/* xexplode - explode an expression */
struct node *xexplode(args)
  struct node *args;
{
    return (explode(args,TRUE));
}

/* xexplc - explode an expression using princ */
struct node *xexplc(args)
  struct node *args;
{
    return (explode(args,FALSE));
}

/* explode - internal explode routine */
LOCAL struct node *explode(args,pflag)
  struct node *args; int pflag;
{
    struct node *oldstk,val,strm;

    /* create a new stack frame */
    oldstk = xlsave(&val,&strm,NULL);

    /* get the expression */
    val.n_ptr = xlarg(&args);
    xllastarg(args);

    /* create a stream */
    strm.n_ptr = newnode(LIST);

    /* print the value into the stream */
    xlprint(strm.n_ptr,val.n_ptr,pflag);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the list of characters */
    return (strm.n_ptr->n_listvalue);
}

/* ximplode - implode a list of characters into an expression */
struct node *ximplode(args)
  struct node *args;
{
    return (makesym(args,TRUE));
}

/* xmaknam - implode a list of characters into an uninterned symbol */
struct node *xmaknam(args)
  struct node *args;
{
    return (makesym(args,FALSE));
}

/* makesym - internal implode routine */
LOCAL struct node *makesym(args,intflag)
  struct node *args; int intflag;
{
    struct node *list,*val;
    char *p;

    /* get the list */
    list = xlarg(&args);
    xllastarg(args);

    /* assemble the symbol's pname */
    for (p = buf; list && list->n_type == LIST; list = list->n_listnext) {
	if ((val = list->n_listvalue) == NULL || val->n_type != INT)
	    xlfail("bad character list");
	if ((int)(p - buf) < STRMAX)
	    *p++ = val->n_int;
    }
    *p = 0;

    /* create a symbol */
    val = (intflag ? xlenter(buf,DYNAMIC) : xlmakesym(buf,DYNAMIC));

    /* return the symbol */
    return (val);
}

/* xopeni - open an input file */
struct node *xopeni(args)
  struct node *args;
{
    return (openit(args,"r"));
}

/* xopeno - open an output file */
struct node *xopeno(args)
  struct node *args;
{
    return (openit(args,"w"));
}

/* openit - common file open routine */
LOCAL struct node *openit(args,mode)
  struct node *args; char *mode;
{
    struct node *fname,*val;
    FILE *fp;

    /* get the file name */
    fname = xlmatch(STR,&args);
    xllastarg(args);

    /* try to open the file */
    if ((fp = fopen(fname->n_str,mode)) != NULL) {
	val = newnode(FPTR);
	val->n_fp = fp;
	val->n_savech = 0;
    }
    else
	val = NULL;

    /* return the file pointer */
    return (val);
}

/* xclose - close a file */
struct node *xclose(args)
  struct node *args;
{
    struct node *fptr;

    /* get file pointer */
    fptr = xlmatch(FPTR,&args);
    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);
}

/* xrdchar - read a character from a file */
struct node *xrdchar(args)
  struct node *args;
{
    struct node *fptr,*val;
    int ch;

    /* get file pointer */
    fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
    xllastarg(args);

    /* get character and check for eof */
    if ((ch = xlgetc(fptr)) == EOF)
	val = NULL;
    else {
	val = newnode(INT);
	val->n_int = ch;
    }

    /* return the character */
    return (val);
}

/* xpkchar - peek at a character from a file */
struct node *xpkchar(args)
  struct node *args;
{
    struct node *flag,*fptr,*val;
    int ch;

    /* peek flag and get file pointer */
    flag = (args ? xlarg(&args) : NULL);
    fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
    xllastarg(args);

    /* skip leading white space and get a character */
    if (flag)
	while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
	    xlgetc(fptr);
    else
	ch = xlpeek(fptr);

    /* check for eof */
    if (ch == EOF)
	val = NULL;
    else {
	val = newnode(INT);
	val->n_int = ch;
    }

    /* return the character */
    return (val);
}

/* xwrchar - write a character to a file */
struct node *xwrchar(args)
  struct node *args;
{
    struct node *fptr,*chr;

    /* get the character and file pointer */
    chr = xlmatch(INT,&args);
    fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
    xllastarg(args);

    /* put character to the file */
    xlputc(fptr,chr->n_int);

    /* return the character */
    return (chr);
}

/* xreadline - read a line from a file */
struct node *xreadline(args)
  struct node *args;
{
    struct node *oldstk,fptr,str;
    char *p,*sptr;
    int len,ch;

    /* create a new stack frame */
    oldstk = xlsave(&fptr,&str,NULL);

    /* get file pointer */
    fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
    xllastarg(args);

    /* make a string node */
    str.n_ptr = newnode(STR);
    str.n_ptr->n_strtype = DYNAMIC;

    /* get character and check for eof */
    len = 0; p = buf;
    while ((ch = xlgetc(fptr.n_ptr)) != EOF && ch != '\n') {

	/* check for buffer overflow */
	if ((int)(p - buf) == STRMAX) {
	    *p = 0;
 	    sptr = stralloc(len + STRMAX); *sptr = 0;
	    if (len) {
		strcpy(sptr,str.n_ptr->n_str);
		strfree(str.n_ptr->n_str);
	    }
	    str.n_ptr->n_str = sptr;
	    strcat(sptr,buf);
	    len += STRMAX;
	    p = buf;
	}

	/* store the character */
	*p++ = ch;
    }

    /* check for end of file */
    if (len == 0 && p == buf && ch == EOF) {
	xlstack = oldstk;
	return (NULL);
    }

    /* append the last substring */
    *p = 0;
    sptr = stralloc(len + (int)(p - buf)); *sptr = 0;
    if (len) {
	strcpy(sptr,str.n_ptr->n_str);
	strfree(str.n_ptr->n_str);
    }
    str.n_ptr->n_str = sptr;
    strcat(sptr,buf);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the string */
    return (str.n_ptr);
}

/* getfile - get a file or stream */
LOCAL struct node *getfile(pargs)
  struct node **pargs;
{
    struct node *arg;

    /* get a file or stream (cons) or nil */
    if (arg = xlarg(pargs)) {
	if (arg->n_type == FPTR) {
	    if (arg->n_fp == NULL)
		xlfail("file closed");
	}
	else if (arg->n_type != LIST)
	    xlfail("bad file or stream");
    }
    return (arg);
}
!Funky!Stuff!
echo x XLFTAB.C
cat > XLFTAB.C << '!Funky!Stuff!'
/* xlftab.c - xlisp function table */

#ifdef AZTEC
#include "stdio.h"
#else
#include <stdio.h>
#endif

#include "xlisp.h"

/* external functions */
extern struct node
    *xeval(),*xapply(),*xfuncall(),*xquote(),
    *xset(),*xsetq(),*xdefun(),*xndefun(),
    *xgensym(),*xintern(),*xsymname(),*xsymplist(),
    *xget(),*xputprop(),*xremprop(),
    *xcar(),*xcaar(),*xcadr(),*xcdr(),*xcdar(),*xcddr(),
    *xcons(),*xlist(),*xappend(),*xreverse(),*xlast(),*xnth(),*xnthcdr(),
    *xmember(),*xmemq(),*xassoc(),*xassq(),*xsubst(),*xsublis(),*xlength(),
    *xmapcar(),*xmaplist(),
    *xrplca(),*xrplcd(),*xnconc(),*xdelete(),*xdelq(),
    *xatom(),*xsymbolp(),*xnumberp(),*xboundp(),*xnull(),*xlistp(),*xconsp(),
    *xeq(),*xequal(),
    *xcond(),*xand(),*xor(),*xlet(),*xif(),*xprogn(),
    *xwhile(),*xrepeat(),
    *xadd(),*xsub(),*xmul(),*xdiv(),*xrem(),*xminus(),*xmin(),*xmax(),*xabs(),
    *xadd1(),*xsub1(),*xbitand(),*xbitior(),*xbitxor(),*xbitnot(),
    *xlss(),*xleq(),*xeql(),*xneq(),*xgeq(),*xgtr(),
    *xstrlen(),*xstrcat(),*xsubstr(),*xascii(),*xchr(),*xatoi(),*xitoa(),
    *xread(),*xprint(),*xprin1(),*xprinc(),*xterpri(),
    *xflatsize(),*xflatc(),*xexplode(),*xexplc(),*ximplode(),*xmaknam(),
    *xopeni(),*xopeno(),*xclose(),*xrdchar(),*xpkchar(),*xwrchar(),*xreadline(),
    *xload(),*xgc(),*xexpand(),*xalloc(),*xmem(),*xtype(),*xexit();

struct fdef ftab[] = {

	/* evaluator functions */
	"eval",		SUBR,	xeval,
	"apply",	SUBR,	xapply,
	"funcall",	SUBR,	xfuncall,
	"quote",	FSUBR,	xquote,

	/* symbol functions */
	"set",		SUBR,	xset,
	"setq",		FSUBR,	xsetq,
	"defun",	FSUBR,	xdefun,
	"ndefun",	FSUBR,	xndefun,
	"gensym",	SUBR,	xgensym,
	"intern",	SUBR,	xintern,
	"symbol-name",	SUBR,	xsymname,
	"symbol-plist",	SUBR,	xsymplist,
	"get",		SUBR,	xget,
	"putprop",	SUBR,	xputprop,
	"remprop",	SUBR,	xremprop,

	/* list functions */
	"car",		SUBR,	xcar,
	"caar",		SUBR,	xcaar,
	"cadr",		SUBR,	xcadr,
	"cdr",		SUBR,	xcdr,
	"cdar",		SUBR,	xcdar,
	"cddr",		SUBR,	xcddr,
	"cons",		SUBR,	xcons,
	"list",		SUBR,	xlist,
	"append",	SUBR,	xappend,
	"reverse",	SUBR,	xreverse,
	"last",		SUBR,	xlast,
	"nth",		SUBR,	xnth,
	"nthcdr",	SUBR,	xnthcdr,
	"member",	SUBR,	xmember,
	"memq",		SUBR,	xmemq,
	"assoc",	SUBR,	xassoc,
	"assq",		SUBR,	xassq,
	"subst",	SUBR,	xsubst,
	"sublis",	SUBR,	xsublis,
	"length",	SUBR,	xlength,
	"mapcar",	SUBR,	xmapcar,
	"maplist",	SUBR,	xmaplist,

	/* destructive list functions */
	"rplaca",	SUBR,	xrplca,
	"rplacd",	SUBR,	xrplcd,
	"nconc",	SUBR,	xnconc,
	"delete",	SUBR,	xdelete,
	"delq",		SUBR,	xdelq,

	/* predicate functions */
	"atom",		SUBR,	xatom,
	"symbolp",	SUBR,	xsymbolp,
	"numberp",	SUBR,	xnumberp,
	"boundp",	SUBR,	xboundp,
	"null",		SUBR,	xnull,
	"not",		SUBR,	xnull,
	"listp",	SUBR,	xlistp,
	"consp",	SUBR,	xconsp,
	"eq",		SUBR,	xeq,
	"equal",	SUBR,	xequal,

	/* control functions */
	"cond",		FSUBR,	xcond,
	"and",		FSUBR,	xand,
	"or",		FSUBR,	xor,
	"let",		FSUBR,	xlet,
	"if",		FSUBR,	xif,
	"progn",	FSUBR,	xprogn,
	"while",	FSUBR,	xwhile,
	"repeat",	FSUBR,	xrepeat,

	/* arithmetic functions */
	"+",		SUBR,	xadd,
	"-",		SUBR,	xsub,
	"*",		SUBR,	xmul,
	"/",		SUBR,	xdiv,
	"1+",		SUBR,	xadd1,
	"1-",		SUBR,	xsub1,
	"rem",		SUBR,	xrem,
	"minus",	SUBR,	xminus,
	"min",		SUBR,	xmin,
	"max",		SUBR,	xmax,
	"abs",		SUBR,	xabs,

	/* bitwise logical functions */
	"bit-and",	SUBR,	xbitand,
	"bit-ior",	SUBR,	xbitior,
	"bit-xor",	SUBR,	xbitxor,
	"bit-not",	SUBR,	xbitnot,

	/* numeric comparison functions */
	"<",		SUBR,	xlss,
	"<=",		SUBR,	xleq,
	"=",		SUBR,	xeql,
	"/=",		SUBR,	xneq,
	">=",		SUBR,	xgeq,
	">",		SUBR,	xgtr,

	/* string functions */
	"strlen",	SUBR,	xstrlen,
	"strcat",	SUBR,	xstrcat,
	"substr",	SUBR,	xsubstr,
	"ascii",	SUBR,	xascii,
	"chr",		SUBR,	xchr,
	"atoi",		SUBR,	xatoi,
	"itoa",		SUBR,	xitoa,

	/* I/O functions */
	"read",		SUBR,	xread,
	"print",	SUBR,	xprint,
	"prin1",	SUBR,	xprin1,
	"princ",	SUBR,	xprinc,
	"terpri",	SUBR,	xterpri,
	"flatsize",	SUBR,	xflatsize,
	"flatc",	SUBR,	xflatc,
	"explode",	SUBR,	xexplode,
	"explodec",	SUBR,	xexplc,
	"implode",	SUBR,	ximplode,
	"maknam",	SUBR,	xmaknam,

	/* file I/O functions */
	"openi",	SUBR,	xopeni,
	"openo",	SUBR,	xopeno,
	"close",	SUBR,	xclose,
	"read-char",	SUBR,	xrdchar,
	"peek-char",	SUBR,	xpkchar,
	"write-char",	SUBR,	xwrchar,
	"readline",	SUBR,	xreadline,

	/* system functions */
	"load",		SUBR,	xload,
	"gc",		SUBR,	xgc,
	"expand",	SUBR,	xexpand,
	"alloc",	SUBR,	xalloc,
	"mem",		SUBR,	xmem,
	"type",		SUBR,	xtype,
	"exit",		SUBR,	xexit,

	0
};
!Funky!Stuff!
echo x XLINIT.C
cat > XLINIT.C << '!Funky!Stuff!'
/* xlinit.c - xlisp initialization module */

#ifdef AZTEC
#include "stdio.h"
#else
#include <stdio.h>
#endif

#include "xlisp.h"

/* global variables */
struct node *true;
struct node *s_quote;
struct node *s_lambda,*s_nlambda;
struct node *s_stdin,*s_stdout;
struct node *s_tracenable;
struct node *k_rest,*k_aux;
struct node *a_subr;
struct node *a_fsubr;
struct node *a_list;
struct node *a_sym;
struct node *a_int;
struct node *a_str;
struct node *a_obj;
struct node *a_fptr;

/* external variables */
extern struct fdef ftab[];

/* xlinit - xlisp initialization routine */
xlinit()
{
    struct fdef *fptr;
    struct node *sym;

    /* initialize xlisp (must be in this order) */
    xlminit();	/* initialize xldmem.c */
    xlsinit();	/* initialize xlsym.c */
    xleinit();	/* initialize xleval.c */
    xloinit();	/* initialize xlobj.c */

    /* enter the builtin functions */
    for (fptr = ftab; fptr->f_name; fptr++)
	xlsubr(fptr->f_name,fptr->f_type,fptr->f_fcn);

    /* enter the 't' symbol */
    true = xlsenter("t");
    true->n_symvalue = true;

    /* enter some important symbols */
    s_quote	= xlsenter("quote");
    s_lambda	= xlsenter("lambda");
    s_nlambda	= xlsenter("nlambda");
    k_rest	= xlsenter("&rest");
    k_aux	= xlsenter("&aux");

    /* enter *standard-input* and *standard-output* */
    s_stdin = xlsenter("*standard-input*");
    s_stdin->n_symvalue = newnode(FPTR);
    s_stdin->n_symvalue->n_fp = stdin;
    s_stdin->n_symvalue->n_savech = 0;
    s_stdout = xlsenter("*standard-output*");
    s_stdout->n_symvalue = newnode(FPTR);
    s_stdout->n_symvalue->n_fp = stdout;
    s_stdout->n_symvalue->n_savech = 0;

    /* enter the error traceback enable flag */
    s_tracenable = xlsenter("*tracenable*");
    s_tracenable->n_symvalue = true;

    /* enter a copyright notice into the oblist */
    sym = xlsenter("**Copyright-1984-by-David-Betz**");
    sym->n_symvalue = true;

    /* enter type names */
    a_subr	= xlsenter("SUBR");
    a_fsubr	= xlsenter("FSUBR");
    a_list	= xlsenter("LIST");
    a_sym	= xlsenter("SYM");
    a_int	= xlsenter("INT");
    a_str	= xlsenter("STR");
    a_obj	= xlsenter("OBJ");
    a_fptr	= xlsenter("FPTR");
}
!Funky!Stuff!
echo x XLIO.C
cat > XLIO.C << '!Funky!Stuff!'
/* xlio - xlisp i/o routines */

#ifdef AZTEC
#include "stdio.h"
#else
#include <stdio.h>
#endif

#include "xlisp.h"

/* global variables */
int xlplevel=0;
int xlfsize=0;

/* external variables */
extern struct node *xlstack;
extern struct node *s_stdin;

/* local variables */
static int prompt=TRUE;

/* xlgetc - get a character from a file or stream */
int xlgetc(fptr)
  struct node *fptr;
{
    struct node *lptr,*cptr;
    FILE *fp;
    int ch;

    /* check for input from nil */
    if (fptr == NULL)
	ch = EOF;

    /* otherwise, check for input from a stream */
    else if (fptr->n_type == LIST) {
	if ((lptr = fptr->n_listvalue) == NULL)
	    ch = EOF;
	else {
	    if (lptr->n_type != LIST ||
		(cptr = lptr->n_listvalue) == NULL || cptr->n_type != INT)
		xlfail("bad stream");
	    if ((fptr->n_listvalue = lptr->n_listnext) == NULL)
		fptr->n_listnext = NULL;
	    ch = cptr->n_int;
	}
    }

    /* otherwise, check for a buffered file character */
    else if (ch = fptr->n_savech)
	fptr->n_savech = 0;

    /* otherwise, get a new character */
    else {

	/* get the file pointer */
	fp = fptr->n_fp;

	/* prompt if necessary */
	if (prompt && fp == stdin) {
	    if (xlplevel > 0)
		printf("%d> ",xlplevel);
	    else
		printf("> ");
	    prompt = FALSE;
	}

	/* get the character */
	if ((ch = getc(fp)) == '\n' && fp == stdin)
	    prompt = TRUE;

	/* check for input abort */
	if (fp == stdin && ch == '\007') {
	    putchar('\n');
	    xlfail("input aborted");
	}
    }

    /* return the character */
    return (ch);
}

/* xlpeek - peek at a character from a file or stream */
int xlpeek(fptr)
  struct node *fptr;
{
    struct node *lptr,*cptr;
    int ch;

    /* check for input from nil */
    if (fptr == NULL)
	ch = EOF;

    /* otherwise, check for input from a stream */
    else if (fptr->n_type == LIST) {
	if ((lptr = fptr->n_listvalue) == NULL)
	    ch = EOF;
	else {
	    if (lptr->n_type != LIST ||
		(cptr = lptr->n_listvalue) == NULL || cptr->n_type != INT)
		xlfail("bad stream");
	    ch = cptr->n_int;
	}
    }

    /* otherwise, get the next file character and save it */
    else
	ch = fptr->n_savech = xlgetc(fptr);

    /* return the character */
    return (ch);
}

/* xlputc - put a character to a file or stream */
xlputc(fptr,ch)
  struct node *fptr; int ch;
{
    struct node *oldstk,lptr;

    /* count the character */
    xlfsize++;

    /* check for output to nil */
    if (fptr == NULL)
	;

    /* otherwise, check for output to a stream */
    else if (fptr->n_type == LIST) {
	oldstk = xlsave(&lptr,NULL);
	lptr.n_ptr = newnode(LIST);
	lptr.n_ptr->n_listvalue = newnode(INT);
	lptr.n_ptr->n_listvalue->n_int = ch;
	if (fptr->n_listnext)
	    fptr->n_listnext->n_listnext = lptr.n_ptr;
	else
	    fptr->n_listvalue = lptr.n_ptr;
	fptr->n_listnext = lptr.n_ptr;
	xlstack = oldstk;
    }

    /* otherwise, output the character to a file */
    else
	putc(ch,fptr->n_fp);
}

/* xlflush - flush the input buffer */
int xlflush()
{
    if (!prompt)
	while (xlgetc(s_stdin->n_symvalue) != '\n')
	    ;
}
!Funky!Stuff!
echo x XLISP.C
cat > XLISP.C << '!Funky!Stuff!'
/* xlisp - a small subset of lisp */

#ifdef AZTEC
#include "stdio.h"
#include "setjmp.h"
#else
#include <stdio.h>
#include <setjmp.h>
#endif

#include "xlisp.h"

/* global variables */
jmp_buf *xljmpbuf;
jmp_buf topjmpbuf;

/* external variables */
extern struct node *xlenv;
extern struct node *xlstack;
extern struct node *s_stdin,*s_stdout;

/* main - the main routine */
main(argc,argv)
  int argc; char *argv[];
{
    struct node expr;
    int i;

    /* print the banner line */
    printf("XLISP version 1.2\n");

    /* setup the error handler context buffer */
    xljmpbuf = topjmpbuf;

    /* setup initialization error handler */
    if (setjmp(xljmpbuf)) {
	printf("fatal initialization error\n");
	exit();
    }

    /* initialize xlisp */
    xlinit();

    /* load "init.lsp" */
    if (setjmp(xljmpbuf) == 0)
	xlload("init");

    /* load any files mentioned on the command line */
    if (setjmp(xljmpbuf) == 0)
	for (i = 1; i < argc; i++) {
	    printf("[ loading \"%s\" ]\n",argv[i]);
	    if (!xlload(argv[i]))
		xlfail("can't load file");
	}

    /* main command processing loop */
    while (TRUE) {

	/* setup the error return */
	setjmp(xljmpbuf);

	/* free any previous expression and leftover context */
	xlstack = xlenv = NULL;

	/* create a new stack frame */
	xlsave(&expr,NULL);

	/* read an expression */
	if (!xlread(s_stdin->n_symvalue,&expr.n_ptr))
	    break;

	/* evaluate the expression */
	expr.n_ptr = xleval(expr.n_ptr);

	/* print it */
	xlprint(s_stdout->n_symvalue,expr.n_ptr,TRUE);
	xlterpri(s_stdout->n_symvalue);
    }
}
!Funky!Stuff!
echo x XLISP.H
cat > XLISP.H << '!Funky!Stuff!'
/* xlisp - a small subset of lisp */

/* system specific definitions */

/* NNODES	number of nodes to allocate in each request */
/* TDEPTH	trace stack depth */
/* FORWARD	type of a forward declaration (usually "") */
/* LOCAL	type of a local function (usually "static") */

/* for the Computer Innovations compiler */
#ifdef CI
#define NNODES		1000
#define TDEPTH		500
#endif

/* for the CPM68K compiler */
#ifdef CPM68K
#define NNODES		1000
#define TDEPTH		500
#define LOCAL
#undef NULL
#define NULL		(char *)0
#endif

/* for the DeSmet compiler */
#ifdef DESMET
#define NNODES		1000
#define TDEPTH		500
#define LOCAL
#define getc(fp)	getcx(fp)
#define EOF		-1
#endif

/* for the VAX-11 C compiler */
#ifdef vms
#define NNODES		2000
#define TDEPTH		1000
#endif

/* for the DECUS C compiler */
#ifdef decus
#define NNODES		200
#define TDEPTH		100
#define FORWARD		extern
#endif

/* for unix compilers */
#ifdef unix
#define NNODES		200
#define TDEPTH		100
#endif

/* for the AZTEC C compiler */
#ifdef AZTEC
#define NNODES		200
#define TDEPTH		100
#define getc(fp)	getcx(fp)
#define putc(ch,fp)	aputc(ch,fp)
#define malloc		alloc
#define strchr		index
#endif

/* default important definitions */
#ifndef NNODES
#define NNODES	200
#endif
#ifndef TDEPTH
#define TDEPTH	100
#endif
#ifndef FORWARD
#define FORWARD
#endif
#ifndef LOCAL
#define LOCAL	static
#endif

/* useful definitions */
#define TRUE	1
#define FALSE	0

/* program limits */
#define STRMAX		100		/* maximum length of a string constant */
	
/* node types */
#define FREE	0
#define SUBR	1
#define FSUBR	2
#define LIST	3
#define SYM	4
#define INT	5
#define STR	6
#define OBJ	7
#define FPTR	8

/* node flags */
#define MARK	1
#define LEFT	2

/* string types */
#define DYNAMIC	0
#define STATIC	1

/* symbol structure */
struct xsym {
    struct node *xsy_plist;	/* symbol plist - points to (name.plist) */
    struct node *xsy_value;	/* the current value */
};

/* subr/fsubr node structure */
struct xsubr {
    struct node *(*xsu_subr)();	/* pointer to an internal routine */
};

/* list node structure */
struct xlist {
    struct node *xl_value;	/* value at this node */
    struct node *xl_next;	/* next node */
};

/* integer node structure */
struct xint {
    int xi_int;			/* integer value */
};

/* string node structure */
struct xstr {
    int xst_type;		/* string type */
    char *xst_str;		/* string pointer */
};

/* object node structure */
struct xobj {
    struct node *xo_obclass;	/* class of object */
    struct node *xo_obdata;	/* instance data */
};

/* file pointer node structure */
struct xfptr {
    FILE *xf_fp;		/* the file pointer */
    int xf_savech;		/* lookahead character for input files */
};


/* shorthand macros for accessing node substructures */

/* symbol node */
#define n_symplist	n_info.n_xsym.xsy_plist
#define n_symvalue	n_info.n_xsym.xsy_value

/* subr/fsubr node */
#define n_subr		n_info.n_xsubr.xsu_subr

/* list node (and message node and binding node) */
#define n_listvalue	n_info.n_xlist.xl_value
#define n_listnext	n_info.n_xlist.xl_next
#define n_msg		n_info.n_xlist.xl_value
#define n_msgcode	n_info.n_xlist.xl_next
#define n_bndsym	n_info.n_xlist.xl_value
#define n_bndvalue	n_info.n_xlist.xl_next
#define n_left		n_info.n_xlist.xl_value
#define n_right		n_info.n_xlist.xl_next
#define n_ptr		n_info.n_xlist.xl_value

/* integer node */
#define n_int		n_info.n_xint.xi_int

/* string node */
#define n_str		n_info.n_xstr.xst_str
#define n_strtype	n_info.n_xstr.xst_type

/* object node */
#define n_obclass	n_info.n_xobj.xo_obclass
#define n_obdata	n_info.n_xobj.xo_obdata

/* file pointer node */
#define n_fp		n_info.n_xfptr.xf_fp
#define n_savech	n_info.n_xfptr.xf_savech

/* node structure */
struct node {
    char n_type;		/* type of node */
    char n_flags;		/* flag bits */
    union {			/* value */
	struct xsym n_xsym;	/*     symbol node */
	struct xsubr n_xsubr;	/*     subr/fsubr node */
	struct xlist n_xlist;	/*     list node */
	struct xint n_xint;	/*     integer node */
	struct xstr n_xstr;	/*     string node */
	struct xobj n_xobj;	/*     object node */
	struct xfptr n_xfptr;	/*     file pointer node */
    } n_info;
};

/* function table entry structure */
struct fdef {
    char *f_name;
    int f_type;
    struct node *(*f_fcn)();
};

/* external procedure declarations */
extern struct node *xleval();		/* evaluate an expression */
extern struct node *xlapply();		/* apply a function to arguments */
extern struct node *xlevlist();		/* evaluate a list of arguments */
extern struct node *xlarg();		/* fetch an argument */
extern struct node *xlevarg();		/* fetch and evaluate an argument */
extern struct node *xlmatch();		/* fetch an typed argument */
extern struct node *xlevmatch();	/* fetch and evaluate a typed arg */
extern struct node *xlsend();		/* send a message to an object */
extern struct node *xlenter();		/* enter a symbol */
extern struct node *xlsenter();		/* enter a symbol with a static pname */
extern struct node *xlintern();		/* intern a symbol */
extern struct node *xlmakesym();	/* make an uninterned symbol */
extern struct node *xlsave();		/* generate a stack frame */
extern struct node *xlobsym();		/* find an object's class or instance
					   variable */
extern struct node *xlgetprop();	/* get the value of a property */
extern char *xlsymname();		/* get the print name of a symbol */

extern struct node *newnode();		/* allocate a new node */
extern char *stralloc();		/* allocate string space */
extern char *strsave();			/* make a safe copy of a string */
!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?