xlisp.h

Audacity是一款用於錄音和編輯聲音的、免費的開放源碼軟體。它可以執行於Mac OS X、Microsoft Windows、GNU/Linux和其它作業系統

/* xlisp - a small subset of lisp */
/*	Copyright (c) 1985, by David Michael Betz
        All Rights Reserved
        Permission is granted for unrestricted non-commercial use

HISTORY
02-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 *)0
extern 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_GC
void 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);