/* xlisp - a small subset of lisp */ /* Copyright (c) 1985, by David Michael Betz All Rights Reserved Permission is granted for unrestricted non-commercial use */ /* system specific definitions */ #include #include #include /* NNODES number of nodes to allocate in each request (1000) */ /* EDEPTH evaluation stack depth (2000) */ /* ADEPTH argument stack depth (1000) */ /* FORWARD type of a forward declaration () */ /* LOCAL type of a local function (static) */ /* AFMT printf format for addresses ("%x") */ /* FIXTYPE data type for fixed point numbers (long) */ /* ITYPE fixed point input conversion routine type (long atol()) */ /* ICNV fixed point input conversion routine (atol) */ /* IFMT printf format for fixed point numbers ("%ld") */ /* FLOTYPE data type for floating point numbers (float) */ /* OFFTYPE number the size of an address (int) */ /* Costs indicated for Borland Turbo C++ V1.0 (as a C compiler) */ #define ADDEDTAA /* added functions by TAA: GENERIC TIME COUNT-IF FIND-IF (2.2k) */ #define BETTERIO /* improved io (binary files, file positioning) (1.3k) */ #define PRINDEPTH /* added ability to control print depth (384 bytes)*/ #define OBJPRNT /* friendly object printing feature TAA and Mikael Pettersson, Dept. of Computer and Info. Science, University of Linkoping, Sweden (944 bytes) */ #define ENHFORMAT /* enhanced FORMAT function (Neal Holtz) (1.3k)*/ #define JMAC /* performance enhancing macros, Johnny Greenblatt (7.5K at full config) */ #define JGC /* improved garbage collection, Johnny Greenblatt (48 bytes!)*/ /* using dldmem.c and dlimage.c adds 1184 bytes of code */ #define COMMONLISP /* more CommonLisp like definitions for some functions */ /* as well as functions ELT SEARCH MAP COERCE POSITION-IF CONCATENATE SOME EVERY NOTANY NOTEVERY; function XLSTRCAT is deleted (11.5k)*/ #define STRUCTS /* DEFSTRUCT (xlisp 2.1) (7.5k)*/ #define APPLYHOOK /* adds applyhook support, strangely missing before (1312 bytes)*/ /*#define PROFILES */ /* for execution profiles */ #ifdef PROFILES #define LOCAL /*no local procedures*/ #endif /* for BSD & SYSV Unix. */ #ifdef UNIX #define NNODES 2000 #define AFMT "%lx" /* added by NPM */ #define OFFTYPE long /* added by NPM */ #define SAVERESTORE #else /* The following two options are only available for the compilers noted below */ #define BUFFERED /* Makes code slightly bigger, but screen writing much faster when nansi.sys or fansi-console used (384 bytes)*/ #define GRAPHICS /* add graphics commands MODE COLOR MOVE DRAW MOVEREL DRAWREL (2.7k) */ #endif /* UNIX */ /* for Zortech C -- Versions after 1988 only */ /* BUFFERED and GRAPHICS ok */ #ifdef __ZTC__ #define ANSI #define NNODES 2000 #define EDEPTH 650 /* stacksize/25 is appropriate */ #define AFMT "%lx" #define OFFTYPE long #define SAVERESTORE #define CVPTR(x) ((((unsigned long)(x) >> 16) << 4) + ((unsigned) x)) #endif /* for the Turbo C compiler - MS-DOS, large model */ /* Version 1.5 and 2.0. 1.5 won't compile with ADDEDTAA */ /* BUFFERED and GRAPHICS ok */ #ifdef __TURBOC__ #define ANSI #define NNODES 2000 #define EDEPTH 650 /* stacksize/25 is appropriate */ #define AFMT "%lx" #define OFFTYPE long #define CVPTR(x) ((((unsigned long)(x) >> 16) << 4) + ((unsigned) x)) #define SAVERESTORE #endif /* for the Microsoft C compiler - MS-DOS, large model */ /* Version 5.0. Should work with earlier as well */ /* BUFFERED and GRAPHICS ok */ #ifdef MSC #define ANSI #define NNODES 2000 #define EDEPTH 650 #define AFMT "%lx" #define OFFTYPE long #define CVPTR(x) ((((unsigned long)(x) >> 16) << 4) + ((unsigned) x)) #define SAVERESTORE #endif /* for 80386, Metaware High-C386 */ /* BUFFERED and GRAPHICS ok -- Special fast graphics code, this version works only for EGA/VGA/Enhanced EorVGA modes! */ #ifdef __HIGHC__ /* default EDEPTH=2000, at stacksize/34, requires stack of 68000 */ #define EDEPTH 4000 /* want deeper stack yet.. 136k system stack */ #define ANSI #define ADEPTH 6000 #define NNODES 2000 #define FLOTYPE double #define SAVERESTORE #define ftell myftell /* ftell is broken at least through v1.62) */ extern long myftell(FILE *fp); #endif /* for NDP386 system */ #ifdef NDP386 #define ADEPTH 3000 #define NNODES 2000 #define FLOTYPE double #define SAVERESTORE /* these definitions point out the deficiencies of NDP */ extern void *malloc(); extern void *calloc(); extern void free(); #define SEEK_CUR 1 #define SEEK_END 2 #define SEEK_SET 0 #undef GRAPHICS #undef BUFFERED #endif /* for the AZTEC C compiler - MS-DOS, large model */ #ifdef AZTEC_LM #define NNODES 2000 #define AFMT "%lx" #define OFFTYPE long #define CVPTR(x) ptrtoabs(x) #define NIL (void *)0 extern long ptrtoabs(); #define SAVERESTORE #endif /* for the AZTEC C compiler - Macintosh */ #ifdef AZTEC_MAC #define NNODES 2000 #define AFMT "%lx" #define OFFTYPE long #define NIL (void *)0 #define SAVERESTORE #endif /* for the AZTEC C compiler - Amiga */ #ifdef AZTEC_AMIGA #define NNODES 2000 #define AFMT "%lx" #define OFFTYPE long #define NIL (void *)0 #define SAVERESTORE #endif /* for the Lightspeed C compiler - Macintosh */ #ifdef LSC #define NNODES 2000 #define AFMT "%lx" #define OFFTYPE long #define NIL (void *)0 #define SAVERESTORE #endif /* for the Mark Williams C compiler - Atari ST */ #ifdef MWC #define AFMT "%lx" #define OFFTYPE long #endif /* for the Lattice C compiler - Atari ST */ #ifdef LATTICE #define FIXTYPE int #define ITYPE int atoi() #define ICNV(n) atoi(n) #define IFMT "%d" #endif /* for the Digital Research C compiler - Atari ST */ #ifdef DR #define LOCAL #define AFMT "%lx" #define OFFTYPE long #undef NULL #define NULL 0L #endif /* for the GNU C compiler - Atari ST */ #ifdef atarist #define NNODES 2000 #define AFMT "%lx" #define OFFTYPE long #define SAVERESTORE #endif /* default important definitions */ #ifndef NNODES #define NNODES 1000 #endif #ifndef EDEPTH #define EDEPTH 2000 #endif #ifndef ADEPTH #define ADEPTH 1000 #endif #ifndef FORWARD #define FORWARD #endif #ifndef LOCAL #define LOCAL static #endif #ifndef AFMT #define AFMT "%x" #endif #ifndef FIXTYPE #define FIXTYPE long #endif #ifndef ITYPE #define ITYPE long atol() #endif #ifndef ICNV #define ICNV(n) atol(n) #endif #ifndef IFMT #define IFMT "%ld" #endif #ifndef FLOTYPE #define FLOTYPE double #endif #ifndef OFFTYPE #define OFFTYPE int #endif #ifndef CVPTR #define CVPTR(x) ((OFFTYPE)(x)) #endif #ifndef VOID #define VOID void #endif /* useful definitions */ #define TRUE 1 #define FALSE 0 #ifndef NIL #define NIL (LVAL )0 #endif /* include the dynamic memory definitions */ #include "xldmem.h" /* program limits */ #define STRMAX 100 /* maximum length of a string constant */ #define HSIZE 199 /* symbol hash table size */ #define SAMPLE 100 /* control character sample rate */ /* function table offsets for the initialization functions */ #define FT_RMHASH 0 #define FT_RMQUOTE 1 #define FT_RMDQUOTE 2 #define FT_RMBQUOTE 3 #define FT_RMCOMMA 4 #define FT_RMLPAR 5 #define FT_RMRPAR 6 #define FT_RMSEMI 7 #define FT_CLNEW 10 #define FT_CLISNEW 11 #define FT_CLANSWER 12 #define FT_OBISNEW 13 #define FT_OBCLASS 14 #define FT_OBSHOW 15 #ifdef OBJPRNT #define FT_OBPRIN1 16 #endif /* macro to push a value onto the argument stack */ #define pusharg(x) {if (xlsp >= xlargstktop) xlargstkoverflow();\ *xlsp++ = (x);} /* macros to protect pointers */ #define xlstkcheck(n) {if (xlstack - (n) < xlstkbase) xlstkoverflow();} #define xlsave(n) {*--xlstack = &n; n = NIL;} #define xlprotect(n) {*--xlstack = &n;} /* check the stack and protect a single pointer */ #define xlsave1(n) {if (xlstack <= xlstkbase) xlstkoverflow();\ *--xlstack = &n; n = NIL;} #define xlprot1(n) {if (xlstack <= xlstkbase) xlstkoverflow();\ *--xlstack = &n;} /* macros to pop pointers off the stack */ #define xlpop() {++xlstack;} #define xlpopn(n) {xlstack+=(n);} /* macros to manipulate the lexical environment */ #define xlframe(e) cons(NIL,e) #define xlbind(s,v) xlpbind(s,v,xlenv) #define xlfbind(s,v) xlpbind(s,v,xlfenv); #define xlpbind(s,v,e) {rplaca(e,cons(cons(s,v),car(e)));} /* macros to manipulate the dynamic environment */ #define xldbind(s,v) {xldenv = cons(cons(s,getvalue(s)),xldenv);\ setvalue(s,v);} #define xlunbind(e) {for (; xldenv != (e); xldenv = cdr(xldenv))\ setvalue(car(car(xldenv)),cdr(car(xldenv)));} /* type predicates */ #define atom(x) ((x) == NIL || ntype(x) != CONS) #define null(x) ((x) == NIL) #define listp(x) ((x) == NIL || ntype(x) == CONS) #define consp(x) ((x) && ntype(x) == CONS) #define subrp(x) ((x) && ntype(x) == SUBR) #define fsubrp(x) ((x) && ntype(x) == FSUBR) #define stringp(x) ((x) && ntype(x) == STRING) #define symbolp(x) ((x) && ntype(x) == SYMBOL) #define streamp(x) ((x) && ntype(x) == STREAM) #define objectp(x) ((x) && ntype(x) == OBJECT) #define fixp(x) ((x) && ntype(x) == FIXNUM) #define floatp(x) ((x) && ntype(x) == FLONUM) #define vectorp(x) ((x) && ntype(x) == VECTOR) #define closurep(x) ((x) && ntype(x) == CLOSURE) #define charp(x) ((x) && ntype(x) == CHAR) #define ustreamp(x) ((x) && ntype(x) == USTREAM) #ifdef STRUCTS #define structp(x) ((x) && ntype(x) == STRUCT) #endif #define boundp(x) (getvalue(x) != s_unbound) #define fboundp(x) (getfunction(x) != s_unbound) /* shorthand functions */ #define consa(x) cons(x,NIL) #define consd(x) cons(NIL,x) /* argument list parsing macros */ #define xlgetarg() (testarg(nextarg())) #define xllastarg() {if (xlargc != 0) xltoomany();} #define testarg(e) (moreargs() ? (e) : xltoofew()) #define typearg(tp) (tp(*xlargv) ? nextarg() : xlbadtype(*xlargv)) #define nextarg() (--xlargc, *xlargv++) #define moreargs() (xlargc > 0) /* macros to get arguments of a particular type */ #define xlgacons() (testarg(typearg(consp))) #define xlgalist() (testarg(typearg(listp))) #define xlgasymbol() (testarg(typearg(symbolp))) #define xlgasymornil() (*xlargv==NIL || symbolp(*xlargv) ? nextarg() : xlbadtype(*xlargv)) #define xlgastring() (testarg(typearg(stringp))) #ifdef COMMONLISP #define xlgastrorsym() (testarg(symbolp(*xlargv) ? getpname(nextarg()) : typearg(stringp))) #else #define xlgastrorsym() xlgastring() #endif #define xlgaobject() (testarg(typearg(objectp))) #define xlgafixnum() (testarg(typearg(fixp))) #define xlgaflonum() (testarg(typearg(floatp))) #define xlgachar() (testarg(typearg(charp))) #define xlgavector() (testarg(typearg(vectorp))) #define xlgastream() (testarg(typearg(streamp))) #define xlgaustream() (testarg(typearg(ustreamp))) #define xlgaclosure() (testarg(typearg(closurep))) #ifdef STRUCTS #define xlgastruct() (testarg(typearg(structp))) #endif /* function definition structure */ typedef struct { char *fd_name; /* function name */ int fd_type; /* function type */ LVAL (*fd_subr)(); /* function entry point */ } FUNDEF; /* execution context flags */ #define CF_GO 0x0001 #define CF_RETURN 0x0002 #define CF_THROW 0x0004 #define CF_ERROR 0x0008 #define CF_CLEANUP 0x0010 #define CF_CONTINUE 0x0020 #define CF_TOPLEVEL 0x0040 #define CF_BRKLEVEL 0x0080 #define CF_UNWIND 0x0100 /* execution context */ typedef struct context { int c_flags; /* context type flags */ LVAL c_expr; /* expression (type dependant) */ jmp_buf c_jmpbuf; /* longjmp context */ struct context *c_xlcontext; /* old value of xlcontext */ LVAL **c_xlstack; /* old value of xlstack */ LVAL *c_xlargv; /* old value of xlargv */ int c_xlargc; /* old value of xlargc */ LVAL *c_xlfp; /* old value of xlfp */ LVAL *c_xlsp; /* old value of xlsp */ LVAL c_xlenv; /* old value of xlenv */ LVAL c_xlfenv; /* old value of xlfenv */ LVAL c_xldenv; /* old value of xldenv */ } CONTEXT; /* external variables */ extern LVAL **xlstktop; /* top of the evaluation stack */ extern LVAL **xlstkbase; /* base of the evaluation stack */ extern LVAL **xlstack; /* evaluation stack pointer */ extern LVAL *xlargstkbase; /* base of the argument stack */ extern LVAL *xlargstktop; /* top of the argument stack */ extern LVAL *xlfp; /* argument frame pointer */ extern LVAL *xlsp; /* argument stack pointer */ extern LVAL *xlargv; /* current argument vector */ extern int xlargc; /* current argument count */ #ifdef ANSI /* We need to be more thorough here!*/ /* OS system interface */ extern VOID oscheck(void); /* check for control character during exec */ extern VOID osinit(char *banner); /* initialize os interface */ extern VOID osfinish(void); /* restore os interface */ extern VOID osflush(void); /* flush terminal input buffer */ extern int osrand(int n); /* random number between 0 and n-1 */ extern int osclose(FILE *fp); /* close file */ extern FILE *osaopen(char *name, char *mode); /* open ascii file */ extern FILE *osbopen(char *name, char *mode); /* open binary file */ extern VOID oserror(char *msg); /* print an error message */ extern int ostgetc(void); /* get a character from the terminal */ extern VOID ostputc(int ch); /* put a character to the terminal */ /* for xlisp.c */ extern void xlrdsave(LVAL expr); extern void xlevsave(LVAL expr); extern void xlfatal(char *msg); extern void wrapup(void); /* for xleval */ extern LVAL xlxeval(LVAL expr); extern void xlabind(LVAL fun, int argc, LVAL *argv); extern void xlfunbound(LVAL sym); extern void xlargstkoverflow(void); extern int macroexpand(LVAL fun, LVAL args, LVAL *pval); extern int pushargs(LVAL fun, LVAL args); extern LVAL makearglist(int argc, LVAL *argv); extern void xlunbound(LVAL sym); extern void xlstkoverflow(void); /* for xlio */ extern int xlgetc(LVAL fptr); extern void xlungetc(LVAL fptr, int ch); extern int xlpeek(LVAL fptr); extern void xlputc(LVAL fptr, int ch); extern void xlflush(void); extern void stdprint(LVAL expr); extern void stdputstr(char *str); extern void errprint(LVAL expr); extern void errputstr(char *str); extern void dbgprint(LVAL expr); extern void dbgputstr(char *str); extern void trcprin1(LVAL expr); extern void trcputstr(char *str); /* for xlprin */ extern void xlputstr(LVAL fptr, char *str); extern void xlprint(LVAL fptr, LVAL vptr, int flag); extern void xlterpri(LVAL fptr); extern void xlputstr(LVAL fptr, char* str); /* for xljump */ extern void xljump(CONTEXT *target, int mask, LVAL val); extern void xlbegin(CONTEXT *cptr, int flags, LVAL expr); extern void xlend(CONTEXT *cptr); extern void xlgo(LVAL label); extern void xlreturn(LVAL name, LVAL val); extern void xlthrow(LVAL tag, LVAL val); extern void xlsignal(char *emsg, LVAL arg); extern void xltoplevel(void); extern void xlbrklevel(void); extern void xlcleanup(void); extern void xlcontinue(void); /* for xllist */ extern int dotest2(LVAL arg1, LVAL arg2, LVAL fun); /* for xlsubr */ extern int xlgetkeyarg(LVAL key, LVAL *pval); extern int xlgkfixnum(LVAL key, LVAL *pval); extern void xltest(LVAL *pfcn, int *ptresult); extern int needsextension(char *name); extern int eql(LVAL arg1, LVAL arg2); extern int equal(LVAL arg, LVAL arg2); /* for xlobj */ extern int xlobsetvalue(LVAL pair, LVAL sym, LVAL val); extern int xlobgetvalue(LVAL pair, LVAL sym, LVAL *pval); #ifdef OBJPRNT extern void putobj(LVAL fptr, LVAL obj); #endif /* for xlread */ extern LVAL tentry(int ch); extern int xlload(char *fname, int vflag, int pflag); extern int xlread(LVAL fptr, LVAL *pval); extern int isnumber(char *str, LVAL *pval); #ifdef STRUCTS /* for xlstruct */ extern LVAL xlrdstruct(LVAL list); extern void xlprstruct(LVAL fptr, LVAL vptr, int flag); #endif /* save/restore functions */ #ifdef SAVERESTORE extern int xlirestore(char *fname); extern int xlisave(char *fname); #endif /* external procedure declarations */ extern VOID obsymbols(void); /* initialize oop symbols */ extern VOID ossymbols(void); /* initialize os symbols */ extern VOID xlsymbols(void); /* initialize interpreter symbols */ extern VOID xloinit(void); /* initialize object functions */ extern VOID xlsinit(void); /* initialize xlsym.c */ extern VOID xlrinit(void); /* initialize xlread.c */ extern VOID xlminit(void); /* init xldmem */ extern VOID xldinit(void); /* initilaixe debugger */ extern int xlinit(int nores); /* xlisp initialization routine */ extern LVAL xleval(LVAL expr); /* evaluate an expression */ extern LVAL xlapply(int argc); /* apply a function to arguments */ extern LVAL xlsubr(char *sname, int type, LVAL (*fcn)(void),int offset); /* enter a subr/fsubr */ extern LVAL xlenter(char *name);/* enter a symbol */ extern LVAL xlmakesym(char *name); /* make an uninterned symbol */ extern LVAL xlgetvalue(LVAL sym); /* get value of a symbol (checked) */ extern void xlsetvalue(LVAL sym, LVAL val); /* set the value of symbol */ extern LVAL xlxgetvalue(LVAL sym); /* get value of a symbol */ extern LVAL xlgetfunction(LVAL sym);/* get functional value of a symbol */ extern LVAL xlxgetfunction(LVAL sym); /* get functional value of a symbol (checked) */ extern void xlsetfunction(LVAL sym, LVAL val); /* set the functional value */ extern LVAL xlexpandmacros(LVAL form); /* expand macros in a form */ extern LVAL xlgetprop(LVAL sym, LVAL prp); /* get the value of a property */ extern void xlputprop(LVAL sym, LVAL val, LVAL prp); /*set value of property*/ extern void xlremprop(LVAL sym, LVAL prp); /* remove a property */ extern LVAL xlclose(LVAL name, LVAL type, LVAL fargs, LVAL body, LVAL env, LVAL fenv); /* create a function closure */ extern int hash(char *str, int len); /* Hash the string */ /* argument list parsing functions */ extern LVAL xlgetfile(void); /* get a file/stream argument */ extern LVAL xlgetfname(void); /* get a filename argument */ /* error reporting functions (don't *really* return at all) */ extern LVAL xltoofew(void); /* report "too few arguments" error */ extern void xltoomany(void); /* report "too many arguments" error */ extern LVAL xlbadtype(LVAL arg);/* report "bad argument type" error */ extern LVAL xlerror(char *emsg, LVAL arg); /* report arbitrary error */ extern void xlcerror(char *cmsg, char *emsg, LVAL arg); /*recoverable error*/ extern void xlerrprint(char *hdr,char *cmsg, char *emsg, LVAL arg); extern void xlbaktrace(int n); /* do a backtrace */ extern void xlabort(char *emsg); /* serious error handler */ extern void xlfail(char *emsg); /* xlisp error handler */ extern void xlbreak(char *emsg, LVAL arg); /* enter break look */ #ifdef COMMONLISP extern int xlcvttype(LVAL arg); #endif #else /* io interface */ extern FILE *osaopen(); /* open ascii file */ extern FILE *osbopen(); /* open binary file */ /* for xlisp.c */ extern VOID xlrdsave(); extern VOID xlevsave(); extern VOID xlfatal(); extern VOID wrapup(); /* for xleval */ extern LVAL xlxeval(); extern VOID xlabind(); extern VOID xlfunbound(); extern VOID xlargstkoverflow(); extern VOID xlstkoverflow(); extern LVAL makearglist(); extern VOID xlunbound(); /* for xlprin */ extern VOID xlputstr(); /* for xljump */ extern VOID xljump(); /* for xlread */ extern LVAL tentry(); /* for xlstruct */ extern LVAL xlrdstruct(); /* external procedure declarations */ extern VOID oscheck(); /* check for control character during exec */ extern VOID xlsymbols(); /* initialize symbols */ extern LVAL xleval(); /* evaluate an expression */ extern LVAL xlapply(); /* apply a function to arguments */ extern LVAL xlsubr(); /* enter a subr/fsubr */ extern LVAL xlenter(); /* enter a symbol */ extern LVAL xlmakesym(); /* make an uninterned symbol */ extern LVAL xlgetvalue(); /* get value of a symbol (checked) */ extern LVAL xlxgetvalue(); /* get value of a symbol */ extern LVAL xlgetfunction(); /* get functional value of a symbol */ extern LVAL xlxgetfunction(); /*get functional value of a symbol (checked)*/ extern LVAL xlexpandmacros(); /* expand macros in a form */ extern LVAL xlgetprop(); /* get the value of a property */ extern LVAL xlclose(); /* create a function closure */ /* argument list parsing functions */ extern LVAL xlgetfile(); /* get a file/stream argument */ extern LVAL xlgetfname(); /* get a filename argument */ /* error reporting functions (don't *really* return at all) */ extern LVAL xltoofew(); /* report "too few arguments" error */ extern VOID xltoomany(); /* report too many arguments error */ extern LVAL xlbadtype(); /* report "bad argument type" error */ extern LVAL xlerror(); /* report arbitrary error */ extern VOID xlerrprint(); /* print an error message */ extern VOID xlbaktrace(); /* do a backtrace */ #endif #include "xlftab.h"