Dave Betz' XLISP 1.2 (The Real Thing) Part 2/5
John Woods
jfw at mit-eddie.UUCP
Sun Feb 3 07:51:55 AEST 1985
[ 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?
More information about the Comp.sources.unix
mailing list