/* xlisp - a small subset of lisp */ /* system specific definitions */ #ifdef AZTEC #include "stdio.h" #include "setjmp.h" #define INCDONE #endif #ifdef vms #include stdio #include setjmp #include ctype #define INCDONE #endif #ifdef INCDONE #undef INCDONE #else #include #include #include #endif /* 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 #define AFMT "%lx" #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 putc(ch,fp) putcx(ch,fp) #define EOF -1 #endif /* for the MegaMax compiler */ #ifdef MEGAMAX #define NNODES 200 #define TDEPTH 100 #define LOCAL #define AFMT "%lx" #define TSTKSIZE (4 * TDEPTH) #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) agetc(fp) #define putc(ch,fp) aputc(ch,fp) #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 #ifndef AFMT #define AFMT "%x" #endif #ifndef TSTKSIZE #define TSTKSIZE (sizeof(NODE *) * TDEPTH) #endif /* useful definitions */ #define TRUE 1 #define FALSE 0 #define NIL (NODE *)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 /* new node access macros */ #define ntype(x) ((x)->n_type) #define atom(x) ((x) == NIL || (x)->n_type != LIST) #define null(x) ((x) == NIL) #define listp(x) ((x) == NIL || (x)->n_type == LIST) #define consp(x) ((x) && (x)->n_type == LIST) #define subrp(x) ((x) && (x)->n_type == SUBR) #define fsubrp(x) ((x) && (x)->n_type == FSUBR) #define stringp(x) ((x) && (x)->n_type == STR) #define symbolp(x) ((x) && (x)->n_type == SYM) #define filep(x) ((x) && (x)->n_type == FPTR) #define objectp(x) ((x) && (x)->n_type == OBJ) #define fixp(x) ((x) && (x)->n_type == INT) #define car(x) ((x)->n_car) #define cdr(x) ((x)->n_cdr) #define rplaca(x,y) ((x)->n_car = (y)) #define rplacd(x,y) ((x)->n_cdr = (y)) /* 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 */ #define n_car n_info.n_xlist.xl_car #define n_cdr n_info.n_xlist.xl_cdr #define n_ptr n_info.n_xlist.xl_car /* 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 */ typedef struct node { char n_type; /* type of node */ char n_flags; /* flag bits */ union { /* value */ struct xsym { /* symbol node */ struct node *xsy_plist; /* symbol plist - (name . plist) */ struct node *xsy_value; /* the current value */ } n_xsym; struct xsubr { /* subr/fsubr node */ struct node *(*xsu_subr)(); /* pointer to an internal routine */ } n_xsubr; struct xlist { /* list node (cons) */ struct node *xl_car; /* the car pointer */ struct node *xl_cdr; /* the cdr pointer */ } n_xlist; struct xint { /* integer node */ int xi_int; /* integer value */ } n_xint; struct xstr { /* string node */ int xst_type; /* string type */ char *xst_str; /* string pointer */ } n_xstr; struct xobj { /* object node */ struct node *xo_obclass; /* class of object */ struct node *xo_obdata; /* instance data */ } n_xobj; struct xfptr { /* file pointer node */ FILE *xf_fp; /* the file pointer */ int xf_savech; /* lookahead character for input files */ } n_xfptr; } n_info; } NODE; /* execution context flags */ #define CF_GO 1 #define CF_RETURN 2 #define CF_THROW 4 #define CF_ERROR 8 /* execution context */ typedef struct context { int c_flags; /* context type flags */ struct node *c_expr; /* expression (type dependant) */ jmp_buf c_jmpbuf; /* longjmp context */ struct context *c_xlcontext; /* old value of xlcontext */ struct node *c_xlstack; /* old value of xlstack */ struct node *c_xlenv,*c_xlnewenv; /* old values of xlenv and xlnewenv */ int c_xltrace; /* old value of xltrace */ } CONTEXT; /* function table entry structure */ struct fdef { char *f_name; /* function name */ int f_type; /* function type SUBR/FSUBR */ struct node *(*f_fcn)(); /* function code */ }; /* memory segment structure definition */ struct segment { int sg_size; struct segment *sg_next; struct node sg_nodes[1]; }; /* 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 */