/* xlisp - a small subset of lisp *//*	Copyright (c) 1985, by David Michael Betz        All Rights Reserved        Permission is granted for unrestricted non-commercial useHISTORY02-Apr-04   Matt Brubeck (patch from Stephen Gildea)                Remove broken PMAX-specific code (fixes                 compilation on Linux/MIPS).28-Apr-03   Mazzoni                Added declarations for path.c (new file)30-Mar-88	Dale Amon CMU-CSD                Set it up for unix. Picked _TURBOC_  because defs                are reasonable.*/#include <stdlib.h>#include <stdio.h>#include <ctype.h>#include <setjmp.h>/* 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) *//* for the Win32 environment */#ifdef WIN32#define NNODES		2000#define AFMT		"%lx"#define OFFTYPE		long#define SAVERESTORE#define XL_LITTLE_ENDIAN #endif/* for the Turbo C compiler - MS-DOS, large model */#ifdef _TURBOC_#define NNODES		2000#define AFMT		"%lx"#define OFFTYPE		long#define SAVERESTORE#define XL_LITTLE_ENDIAN#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 *)0extern long ptrtoabs();#define SAVERESTORE#define XL_LITTLE_ENDIAN#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#define XL_BIG_ENDIAN#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#define XL_BIG_ENDIAN#endif/* for the Lightspeed C compiler - Macintosh */#ifdef LSC#define NNODES		2000#define AFMT		"%lx"#define OFFTYPE		long#define NIL		(void *)0#define SAVERESTORE#define XL_BIG_ENDIAN#endif/* for the Microsoft C compiler - MS-DOS, large model */#ifdef MSC#define NNODES		2000#define AFMT		"%lx"#define OFFTYPE		long#define XL_LITTLE_ENDIAN#endif/* for the Mark Williams C compiler - Atari ST */#ifdef MWC#define AFMT		"%lx"#define OFFTYPE		long#define XL_BIG_ENDIAN#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"#define XL_BIG_ENDIAN#endif/* for the Digital Research C compiler - Atari ST */#ifdef DR#define LOCAL#define AFMT		"%lx"#define OFFTYPE		long#undef NULL#define NULL		0L#define XL_BIG_ENDIAN#endif#ifdef ANDREW#define STDERR stdout#endif/* Mac Metrowerks CW 6 */#ifdef __MWERKS__#define LSC#undef PATHNAMES#undef FILETABLE#undef SAVERESTORE#undef MEDMEM#define EDEPTH 4000#define ADEPTH 3000#define OSAOPEN osaopen#define OSBOPEN osbopen#define NO_EXTENSIONS  /* don't add ".lsp" onto filenames */#define XL_BIG_ENDIAN#endif/* Linux on Pentium */#ifdef __linux__#ifdef __i386__#define LINUX_INTEL#endif#endif#ifdef LINUX_INTEL#define XL_LITTLE_ENDIAN#endif/* default important definitions */#ifndef NNODES#define NNODES		1000#endif#ifndef NTYPES#define NTYPES		20#endif#ifndef EDEPTH/* originally was 2000 */#define EDEPTH		4000#endif#ifndef ADEPTH/* originally was 1000 */#define ADEPTH		2000#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#ifndef atol  /* if atol is a macro, this will mess things up */#define ITYPE		long atol()#endif#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)	(x)#endif#ifndef UCHAR#define UCHAR		unsigned char#endif#ifndef STDERR#define STDERR stderr#endif/* useful definitions */#ifndef TRUE#define TRUE	1#define FALSE	0#endif#define externp(x) ((x) && ntype(x) == EXTERN)#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		1499		/* symbol hash table size */#define SAMPLE		1000		/* 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        /* macro to push a value onto the argument stack */#define pusharg(x)	{if (xlsp >= xlargstktop) xlargstkoverflow();\                         *xlsp++ = (x);}/* #define DEBUG_GC *//* macros to protect pointers */#ifdef DEBUG_GCvoid dbg_gc_xlsave(LVAL *n);#define xlstkcheck(n)	{if (xlstack - (n) < xlstkbase) xlstkoverflow();}#define xlsave(n)	{*--xlstack = &n; n = NIL; dbg_gc_xlsave(&n);}#define xlprotect(n)	{*--xlstack = &n; dbg_gc_xlsave(&n);}/* check the stack and protect a single pointer */#define xlsave1(n)	{if (xlstack <= xlstkbase) xlstkoverflow();\                         *--xlstack = &n; n = NIL; dbg_gc_xlsave(&n);}#define xlprot1(n)	{if (xlstack <= xlstkbase) xlstkoverflow();\                         *--xlstack = &n; dbg_gc_xlsave(&n);}/* macros to pop pointers off the stack */#define xlpop()		{++xlstack;}#define xlpopn(n)	{xlstack+=(n);}#else#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);}#endif/* 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 atomp(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)#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 xlgastring()	(testarg(typearg(stringp)))#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)))/* function definition structure */typedef struct {    char *fd_name;	/* function name */    int fd_type;	/* function type */    LVAL (*fd_subr)(void);	/* 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 */} XLCONTEXT;/* 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 *//* more external variables */extern LVAL xlenv,xlfenv,xldenv,xlvalue,s_true;extern LVAL lk_optional,lk_rest,lk_key,lk_aux,lk_allow_other_keys;extern LVAL s_evalhook,s_applyhook,s_tracelist;extern LVAL s_lambda,s_macro;extern LVAL s_unbound;extern int xlsample;extern char buf[];extern LVAL obarray,s_gcflag,s_gchook;extern int xldebug;extern LVAL s_debugio;extern LVAL s_tracenable,s_tlimit,s_breakenable;extern LVAL s_loadingfiles;extern LVAL k_direction,k_input,k_output;extern LVAL s_stdin,s_stdout;extern int xlfsize;/* external variables */extern LVAL s_car,s_cdr,s_nth,s_get,s_svalue,s_splist,s_aref;extern LVAL s_comma,s_comat;extern char gsprefix[];extern int gsnumber;/* additional prototypes */extern FILE *osaopen (char *name, char *mode);extern FILE *osbopen (char *name, char *mode);#ifdef __MWERKS__/* macfun.c */LVAL xptsize(void);LVAL xhidepen(void);LVAL xshowpen(void);LVAL xgetpen(void);LVAL xpenmode(void);LVAL xpensize(void);LVAL xpenpat(void);LVAL xpennormal(void);LVAL xmoveto(void);LVAL xmove(void);LVAL xdrawto(void);LVAL xdraw(void);LVAL xshowgraphics(void);LVAL xhidegraphics(void);LVAL xcleargraphics(void);LVAL xtool(void);LVAL xtool16(void);LVAL xtool32(void);LVAL xnewhandle(void);LVAL xnewptr(void);LVAL xhiword(void);LVAL xloword(void);LVAL xrdnohang(void);/* #include "macstuff.h" */#endif/* for extern.c */void inval_caches();/* for xlbfun.c */LVAL xeval(void);LVAL xapply(void);LVAL xfuncall(void);LVAL xmacroexpand(void);LVAL x1macroexpand(void);LVAL xatom(void);LVAL xsymbolp(void);LVAL xnumberp(void);LVAL xintegerp(void);LVAL xfloatp(void);LVAL xcharp(void);LVAL xstringp(void);LVAL xarrayp(void);LVAL xstreamp(void);LVAL xobjectp(void);LVAL xboundp(void);LVAL xfboundp(void);LVAL xnull(void);LVAL xlistp(void);LVAL xendp(void);LVAL xconsp(void);LVAL xeq(void);LVAL xeql(void);LVAL xequal(void);LVAL xset(void);LVAL xgensym(void);LVAL xmakesymbol(void);LVAL xintern(void);LVAL xsymname(void);LVAL xsymvalue(void);LVAL xsymfunction(void);LVAL xsymplist(void);LVAL xget(void);LVAL xputprop(void);LVAL xremprop(void);