home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lisp / interpre / xlispplu / xlisp2tc / xlisp.h < prev    next >
Encoding:
C/C++ Source or Header  |  1988-04-09  |  10.4 KB  |  350 lines
  1. /* xlisp - a small subset of lisp */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. /* system specific definitions */
  7. #define _TURBOC_
  8.  
  9. #include <stdio.h>
  10. #include <ctype.h>
  11. #include <setjmp.h>
  12. #ifdef _TURBOC_
  13. #  include <stdlib.h>
  14. #  include <string.h>  /* get prototypes for string functions */
  15. #  include <alloc.h>   /* get prototypes for malloc/calloc/free */
  16. #endif
  17.  
  18. /* NNODES    number of nodes to allocate in each request (1000) */
  19. /* EDEPTH    evaluation stack depth (2000) */
  20. /* ADEPTH    argument stack depth (1000) */
  21. /* FORWARD    type of a forward declaration () */
  22. /* LOCAL    type of a local function (static) */
  23. /* AFMT        printf format for addresses ("%x") */
  24. /* FIXTYPE    data type for fixed point numbers (long) */
  25. /* ITYPE    fixed point input conversion routine type (long atol()) */
  26. /* ICNV        fixed point input conversion routine (atol) */
  27. /* IFMT        printf format for fixed point numbers ("%ld") */
  28. /* FLOTYPE    data type for floating point numbers (float) */
  29. /* OFFTYPE    number the size of an address (int) */
  30.  
  31. /* for the Turbo C compiler - MS-DOS, large model */
  32. #ifdef _TURBOC_
  33. #define NNODES        2000
  34. #define AFMT            "%Fp"
  35. #define OFFTYPE        long
  36. #define SAVERESTORE
  37. #define PROTOTYPES
  38. #define HSIZE           391
  39. #endif
  40.  
  41. /* for the AZTEC C compiler - MS-DOS, large model */
  42. #ifdef AZTEC_LM
  43. #define NNODES        2000
  44. #define AFMT        "%lx"
  45. #define OFFTYPE        long
  46. #define CVPTR(x)    ptrtoabs(x)
  47. #define NIL        (void *)0
  48. extern long ptrtoabs();
  49. #define SAVERESTORE
  50. #endif
  51.  
  52. /* for the AZTEC C compiler - Macintosh */
  53. #ifdef AZTEC_MAC
  54. #define NNODES        2000
  55. #define AFMT        "%lx"
  56. #define OFFTYPE        long
  57. #define NIL        (void *)0
  58. #define SAVERESTORE
  59. #endif
  60.  
  61. /* for the AZTEC C compiler - Amiga */
  62. #ifdef AZTEC_AMIGA
  63. #define NNODES        2000
  64. #define AFMT        "%lx"
  65. #define OFFTYPE        long
  66. #define NIL        (void *)0
  67. #define SAVERESTORE
  68. #endif
  69.  
  70. /* for the Lightspeed C compiler - Macintosh */
  71. #ifdef LSC
  72. #define NNODES        2000
  73. #define AFMT        "%lx"
  74. #define OFFTYPE        long
  75. #define NIL        (void *)0
  76. #define SAVERESTORE
  77. #endif
  78.  
  79. /* for the Microsoft C compiler - MS-DOS, large model */
  80. #ifdef MSC
  81. #define NNODES        2000
  82. #define AFMT        "%lx"
  83. #define OFFTYPE        long
  84. #endif
  85.  
  86. /* for the Mark Williams C compiler - Atari ST */
  87. #ifdef MWC
  88. #define AFMT        "%lx"
  89. #define OFFTYPE        long
  90. #endif
  91.  
  92. /* for the Lattice C compiler - Atari ST */
  93. #ifdef LATTICE
  94. #define FIXTYPE        int
  95. #define ITYPE        int atoi()
  96. #define ICNV(n)        atoi(n)
  97. #define IFMT        "%d"
  98. #endif
  99.  
  100. /* for the Digital Research C compiler - Atari ST */
  101. #ifdef DR
  102. #define LOCAL
  103. #define AFMT        "%lx"
  104. #define OFFTYPE        long
  105. #undef NULL
  106. #define NULL        0L
  107. #endif
  108.  
  109. /* default important definitions */
  110. #ifndef NNODES
  111. #define NNODES        1000
  112. #endif
  113. #ifndef EDEPTH
  114. #define EDEPTH        2000
  115. #endif
  116. #ifndef ADEPTH
  117. #define ADEPTH        1000
  118. #endif
  119. #ifndef FORWARD
  120. #define FORWARD
  121. #endif
  122. #ifndef LOCAL
  123. #define LOCAL        static
  124. #endif
  125. #ifndef AFMT
  126. #define AFMT        "%x"
  127. #endif
  128. #ifndef FIXTYPE
  129. #define FIXTYPE        long
  130. #endif
  131. #ifndef ITYPE
  132. #define ITYPE        long atol()
  133. #endif
  134. #ifndef ICNV
  135. #define ICNV(n)        atol(n)
  136. #endif
  137. #ifndef IFMT
  138. #define IFMT        "%ld"
  139. #endif
  140. #ifndef FLOTYPE
  141. #define FLOTYPE        double
  142. #endif
  143. #ifndef OFFTYPE
  144. #define OFFTYPE        int
  145. #endif
  146. #ifndef CVPTR
  147. #define CVPTR(x)    (x)
  148. #endif
  149. #ifndef UCHAR
  150. #define UCHAR        unsigned char
  151. #endif
  152.  
  153. /* useful definitions */
  154. #define TRUE    1
  155. #define FALSE    0
  156. #ifndef NIL
  157. #define NIL    (LVAL )0
  158. #endif
  159.  
  160. /* include the dynamic memory definitions */
  161. #include "xldmem.h"
  162.  
  163. /* program limits */
  164. #define STRMAX        100        /* maximum length of a string constant */
  165. #ifndef HSIZE
  166. #  define HSIZE         199             /* symbol hash table size */
  167. #endif HSIZE
  168. #define SAMPLE        100        /* control character sample rate */
  169.  
  170. /* function table offsets for the initialization functions */
  171. #define FT_RMHASH    0
  172. #define FT_RMQUOTE    1
  173. #define FT_RMDQUOTE    2
  174. #define FT_RMBQUOTE    3
  175. #define FT_RMCOMMA    4
  176. #define FT_RMLPAR    5
  177. #define FT_RMRPAR    6
  178. #define FT_RMSEMI    7
  179. #define FT_CLNEW    10
  180. #define FT_CLISNEW    11
  181. #define FT_CLANSWER    12
  182. #define FT_OBISNEW    13
  183. #define FT_OBCLASS    14
  184. #define FT_OBSHOW    15
  185.     
  186. /* macro to push a value onto the argument stack */
  187. #define pusharg(x)    {if (xlsp >= xlargstktop) xlargstkoverflow();\
  188.              *xlsp++ = (x);}
  189.  
  190. /* macros to protect pointers */
  191. #define xlstkcheck(n)    {if (xlstack - (n) < xlstkbase) xlstkoverflow();}
  192. #define xlsave(n)    {*--xlstack = &n; n = NIL;}
  193. #define xlprotect(n)    {*--xlstack = &n;}
  194.  
  195. /* check the stack and protect a single pointer */
  196. #define xlsave1(n)    {if (xlstack <= xlstkbase) xlstkoverflow();\
  197.                          *--xlstack = &n; n = NIL;}
  198. #define xlprot1(n)    {if (xlstack <= xlstkbase) xlstkoverflow();\
  199.                          *--xlstack = &n;}
  200.  
  201. /* macros to pop pointers off the stack */
  202. #define xlpop()        {++xlstack;}
  203. #define xlpopn(n)    {xlstack+=(n);}
  204.  
  205. /* macros to manipulate the lexical environment */
  206. #define xlframe(e)    cons(NIL,e)
  207. #define xlbind(s,v)    xlpbind(s,v,xlenv)
  208. #define xlfbind(s,v)    xlpbind(s,v,xlfenv);
  209. #define xlpbind(s,v,e)    {rplaca(e,cons(cons(s,v),car(e)));}
  210.  
  211. /* macros to manipulate the dynamic environment */
  212. #define xldbind(s,v)    {xldenv = cons(cons(s,getvalue(s)),xldenv);\
  213.              setvalue(s,v);}
  214. #define xlunbind(e)    {for (; xldenv != (e); xldenv = cdr(xldenv))\
  215.                setvalue(car(car(xldenv)),cdr(car(xldenv)));}
  216.  
  217. /* type predicates */                   
  218. #define atom(x)        ((x) == NIL || ntype(x) != CONS)
  219. #define null(x)        ((x) == NIL)
  220. #define listp(x)    ((x) == NIL || ntype(x) == CONS)
  221. #define consp(x)    ((x) && ntype(x) == CONS)
  222. #define subrp(x)    ((x) && ntype(x) == SUBR)
  223. #define fsubrp(x)    ((x) && ntype(x) == FSUBR)
  224. #define stringp(x)    ((x) && ntype(x) == STRING)
  225. #define symbolp(x)    ((x) && ntype(x) == SYMBOL)
  226. #define streamp(x)    ((x) && ntype(x) == STREAM)
  227. #define objectp(x)    ((x) && ntype(x) == OBJECT)
  228. #define fixp(x)        ((x) && ntype(x) == FIXNUM)
  229. #define floatp(x)    ((x) && ntype(x) == FLONUM)
  230. #define vectorp(x)    ((x) && ntype(x) == VECTOR)
  231. #define closurep(x)    ((x) && ntype(x) == CLOSURE)
  232. #define charp(x)    ((x) && ntype(x) == CHAR)
  233. #define ustreamp(x)    ((x) && ntype(x) == USTREAM)
  234. #define boundp(x)    (getvalue(x) != s_unbound)
  235. #define fboundp(x)    (getfunction(x) != s_unbound)
  236.  
  237. /* shorthand functions */
  238. #define consa(x)    cons(x,NIL)
  239. #define consd(x)    cons(NIL,x)
  240.  
  241. /* argument list parsing macros */
  242. #define xlgetarg()    (testarg(nextarg()))
  243. #define xllastarg()    {if (xlargc != 0) xltoomany();}
  244. #define testarg(e)    (moreargs() ? (e) : xltoofew())
  245. #define typearg(tp)    (tp(*xlargv) ? nextarg() : xlbadtype(*xlargv))
  246. #define nextarg()    (--xlargc, *xlargv++)
  247. #define moreargs()    (xlargc > 0)
  248.  
  249. /* macros to get arguments of a particular type */
  250. #define xlgacons()    (testarg(typearg(consp)))
  251. #define xlgalist()    (testarg(typearg(listp)))
  252. #define xlgasymbol()    (testarg(typearg(symbolp)))
  253. #define xlgastring()    (testarg(typearg(stringp)))
  254. #define xlgaobject()    (testarg(typearg(objectp)))
  255. #define xlgafixnum()    (testarg(typearg(fixp)))
  256. #define xlgaflonum()    (testarg(typearg(floatp)))
  257. #define xlgachar()    (testarg(typearg(charp)))
  258. #define xlgavector()    (testarg(typearg(vectorp)))
  259. #define xlgastream()    (testarg(typearg(streamp)))
  260. #define xlgaustream()    (testarg(typearg(ustreamp)))
  261. #define xlgaclosure()    (testarg(typearg(closurep)))
  262.  
  263. /* function definition structure */
  264. typedef struct {
  265.     char *fd_name;    /* function name */
  266.     int fd_type;    /* function type */
  267.     LVAL (*fd_subr)();    /* function entry point */
  268. } FUNDEF;
  269.  
  270. /* execution context flags */
  271. #define CF_GO        0x0001
  272. #define CF_RETURN    0x0002
  273. #define CF_THROW    0x0004
  274. #define CF_ERROR    0x0008
  275. #define CF_CLEANUP    0x0010
  276. #define CF_CONTINUE    0x0020
  277. #define CF_TOPLEVEL    0x0040
  278. #define CF_BRKLEVEL    0x0080
  279. #define CF_UNWIND    0x0100
  280.  
  281. /* execution context */
  282. typedef struct context {
  283.     int c_flags;            /* context type flags */
  284.     LVAL c_expr;            /* expression (type dependant) */
  285.     jmp_buf c_jmpbuf;            /* longjmp context */
  286.     struct context *c_xlcontext;    /* old value of xlcontext */
  287.     LVAL **c_xlstack;            /* old value of xlstack */
  288.     LVAL *c_xlargv;            /* old value of xlargv */
  289.     int c_xlargc;            /* old value of xlargc */
  290.     LVAL *c_xlfp;            /* old value of xlfp */
  291.     LVAL *c_xlsp;            /* old value of xlsp */
  292.     LVAL c_xlenv;            /* old value of xlenv */
  293.     LVAL c_xlfenv;            /* old value of xlfenv */
  294.     LVAL c_xldenv;            /* old value of xldenv */
  295. } CONTEXT;
  296.  
  297. /* external variables */
  298. extern LVAL **xlstktop;           /* top of the evaluation stack */
  299. extern LVAL **xlstkbase;    /* base of the evaluation stack */
  300. extern LVAL **xlstack;        /* evaluation stack pointer */
  301. extern LVAL *xlargstkbase;    /* base of the argument stack */
  302. extern LVAL *xlargstktop;    /* top of the argument stack */
  303. extern LVAL *xlfp;        /* argument frame pointer */
  304. extern LVAL *xlsp;        /* argument stack pointer */
  305. extern LVAL *xlargv;        /* current argument vector */
  306. extern int xlargc;        /* current argument count */
  307.  
  308. #ifdef PROTOTYPES
  309. #  include "xlproto.h"
  310. #else
  311. /* external procedure declarations */
  312. extern LVAL xleval();        /* evaluate an expression */
  313. extern LVAL xlapply();        /* apply a function to arguments */
  314. extern LVAL xlsubr();        /* enter a subr/fsubr */
  315. extern LVAL xlenter();        /* enter a symbol */
  316. extern LVAL xlmakesym();    /* make an uninterned symbol */
  317. extern LVAL xlgetvalue();    /* get value of a symbol (checked) */
  318. extern LVAL xlxgetvalue();    /* get value of a symbol */
  319. extern LVAL xlgetfunction();    /* get functional value of a symbol */
  320. extern LVAL xlxgetfunction();    /* get functional value of a symbol (checked) */
  321. extern LVAL xlexpandmacros();    /* expand macros in a form */
  322. extern LVAL xlgetprop();    /* get the value of a property */
  323. extern LVAL xlclose();        /* create a function closure */
  324.  
  325. /* argument list parsing functions */
  326. extern LVAL xlgetfile();          /* get a file/stream argument */
  327. extern LVAL xlgetfname();    /* get a filename argument */
  328.  
  329. /* error reporting functions (don't *really* return at all) */
  330. extern LVAL xltoofew();        /* report "too few arguments" error */
  331. extern LVAL xlbadtype();    /* report "bad argument type" error */
  332.  
  333. #endif PROTOTYPES
  334.  
  335. #ifdef _TURBOC_
  336. /* minor efficiency hack: since these functions simply call the other function
  337.    with the same args, we define those functions to be the func they call */
  338. #  define osaopen fopen
  339. #  define osclose fclose
  340. #  define osagetc getc
  341. #  define osaputc putc
  342. #  define osbgetc getc
  343. #  define osbputc putc
  344. #endif _TURBOC_
  345.  
  346. #ifndef _TURBOC_
  347. extern char *malloc() ;  /* if TurboC, we already have prototypes */
  348. extern char *calloc() ;
  349. #endif _TURBOC_
  350.