home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / 32XLISP.ZIP / XLISP.H < prev    next >
Text File  |  1991-04-30  |  10KB  |  333 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.  
  13. /* NNODES    number of nodes to allocate in each request (1000) */
  14. /* EDEPTH    evaluation stack depth (2000) */
  15. /* ADEPTH    argument stack depth (1000) */
  16. /* FORWARD    type of a forward declaration () */
  17. /* LOCAL    type of a local function (static) */
  18. /* AFMT        printf format for addresses ("%x") */
  19. /* FIXTYPE    data type for fixed point numbers (long) */
  20. /* ITYPE    fixed point input conversion routine type (long atol()) */
  21. /* ICNV        fixed point input conversion routine (atol) */
  22. /* IFMT        printf format for fixed point numbers ("%ld") */
  23. /* FLOTYPE    data type for floating point numbers (float) */
  24. /* OFFTYPE    number the size of an address (int) */
  25.  
  26. /* for the OS/2 2.0 (32bit) environment */
  27. #ifdef M_I386
  28. #define NNODES        8000
  29. #define EDEPTH        8000
  30. #define ADEPTH        4000
  31. #define AFMT        "%lx"
  32. #define SAVERESTORE
  33. #endif
  34.  
  35. /* for the Turbo C compiler - MS-DOS, large model */
  36. #ifdef _TURBOC_
  37. #define NNODES        2000
  38. #define AFMT        "%lx"
  39. #define OFFTYPE        long
  40. #define SAVERESTORE
  41. #endif
  42.  
  43. /* for the AZTEC C compiler - MS-DOS, large model */
  44. #ifdef AZTEC_LM
  45. #define NNODES        2000
  46. #define AFMT        "%lx"
  47. #define OFFTYPE        long
  48. #define CVPTR(x)    ptrtoabs(x)
  49. #define NIL        (void *)0
  50. extern long ptrtoabs();
  51. #define SAVERESTORE
  52. #endif
  53.  
  54. /* for the AZTEC C compiler - Macintosh */
  55. #ifdef AZTEC_MAC
  56. #define NNODES        2000
  57. #define AFMT        "%lx"
  58. #define OFFTYPE        long
  59. #define NIL        (void *)0
  60. #define SAVERESTORE
  61. #endif
  62.  
  63. /* for the AZTEC C compiler - Amiga */
  64. #ifdef AZTEC_AMIGA
  65. #define NNODES        2000
  66. #define AFMT        "%lx"
  67. #define OFFTYPE        long
  68. #define NIL        (void *)0
  69. #define SAVERESTORE
  70. #endif
  71.  
  72. /* for the Lightspeed C compiler - Macintosh */
  73. #ifdef LSC
  74. #define NNODES        2000
  75. #define AFMT        "%lx"
  76. #define OFFTYPE        long
  77. #define NIL        (void *)0
  78. #define SAVERESTORE
  79. #endif
  80.  
  81. /* for the Microsoft C compiler - MS-DOS, large model */
  82. #ifdef MSC
  83. #define NNODES        2000
  84. #define AFMT        "%lx"
  85. #define OFFTYPE        long
  86. #endif
  87.  
  88. /* for the Mark Williams C compiler - Atari ST */
  89. #ifdef MWC
  90. #define AFMT        "%lx"
  91. #define OFFTYPE        long
  92. #endif
  93.  
  94. /* for the Lattice C compiler - Atari ST */
  95. #ifdef LATTICE
  96. #define FIXTYPE        int
  97. #define ITYPE        int atoi()
  98. #define ICNV(n)        atoi(n)
  99. #define IFMT        "%d"
  100. #endif
  101.  
  102. /* for the Digital Research C compiler - Atari ST */
  103. #ifdef DR
  104. #define LOCAL
  105. #define AFMT        "%lx"
  106. #define OFFTYPE        long
  107. #undef NULL
  108. #define NULL        0L
  109. #endif
  110.  
  111. /* default important definitions */
  112. #ifndef NNODES
  113. #define NNODES        1000
  114. #endif
  115. #ifndef EDEPTH
  116. #define EDEPTH        2000
  117. #endif
  118. #ifndef ADEPTH
  119. #define ADEPTH        1000
  120. #endif
  121. #ifndef FORWARD
  122. #define FORWARD
  123. #endif
  124. #ifndef LOCAL
  125. #define LOCAL        static
  126. #endif
  127. #ifndef AFMT
  128. #define AFMT        "%x"
  129. #endif
  130. #ifndef FIXTYPE
  131. #define FIXTYPE        long
  132. #endif
  133. #ifndef ITYPE
  134. #define ITYPE        long atol()
  135. #endif
  136. #ifndef ICNV
  137. #define ICNV(n)        atol(n)
  138. #endif
  139. #ifndef IFMT
  140. #define IFMT        "%ld"
  141. #endif
  142. #ifndef FLOTYPE
  143. #define FLOTYPE        double
  144. #endif
  145. #ifndef OFFTYPE
  146. #define OFFTYPE        int
  147. #endif
  148. #ifndef CVPTR
  149. #define CVPTR(x)    (x)
  150. #endif
  151. #ifndef UCHAR
  152. #define UCHAR        unsigned char
  153. #endif
  154.  
  155. /* useful definitions */
  156. #define TRUE    1
  157. #define FALSE    0
  158. #ifndef NIL
  159. #define NIL    (LVAL )0
  160. #endif
  161.  
  162. /* include the dynamic memory definitions */
  163. #include "xldmem.h"
  164.  
  165. /* program limits */
  166. #define STRMAX        100        /* maximum length of a string constant */
  167. #define HSIZE        199        /* symbol hash table size */
  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 structp(x)    ((x) && ntype(x) == STRUCT)
  235. #define boundp(x)    (getvalue(x) != s_unbound)
  236. #define fboundp(x)    (getfunction(x) != s_unbound)
  237.  
  238. /* shorthand functions */
  239. #define consa(x)    cons(x,NIL)
  240. #define consd(x)    cons(NIL,x)
  241.  
  242. /* argument list parsing macros */
  243. #define xlgetarg()    (testarg(nextarg()))
  244. #define xllastarg()    {if (xlargc != 0) xltoomany();}
  245. #define testarg(e)    (moreargs() ? (e) : xltoofew())
  246. #define typearg(tp)    (tp(*xlargv) ? nextarg() : xlbadtype(*xlargv))
  247. #define nextarg()    (--xlargc, *xlargv++)
  248. #define moreargs()    (xlargc > 0)
  249.  
  250. /* macros to get arguments of a particular type */
  251. #define xlgacons()    (testarg(typearg(consp)))
  252. #define xlgalist()    (testarg(typearg(listp)))
  253. #define xlgasymbol()    (testarg(typearg(symbolp)))
  254. #define xlgastring()    (testarg(typearg(stringp)))
  255. #define xlgaobject()    (testarg(typearg(objectp)))
  256. #define xlgafixnum()    (testarg(typearg(fixp)))
  257. #define xlgaflonum()    (testarg(typearg(floatp)))
  258. #define xlgachar()    (testarg(typearg(charp)))
  259. #define xlgavector()    (testarg(typearg(vectorp)))
  260. #define xlgastream()    (testarg(typearg(streamp)))
  261. #define xlgaustream()    (testarg(typearg(ustreamp)))
  262. #define xlgaclosure()    (testarg(typearg(closurep)))
  263. #define xlgastruct()    (testarg(typearg(structp)))
  264.  
  265. /* function definition structure */
  266. typedef struct {
  267.     char *fd_name;    /* function name */
  268.     int fd_type;    /* function type */
  269.     LVAL (*fd_subr)();    /* function entry point */
  270. } FUNDEF;
  271.  
  272. /* execution context flags */
  273. #define CF_GO        0x0001
  274. #define CF_RETURN    0x0002
  275. #define CF_THROW    0x0004
  276. #define CF_ERROR    0x0008
  277. #define CF_CLEANUP    0x0010
  278. #define CF_CONTINUE    0x0020
  279. #define CF_TOPLEVEL    0x0040
  280. #define CF_BRKLEVEL    0x0080
  281. #define CF_UNWIND    0x0100
  282.  
  283. /* execution context */
  284. typedef struct context {
  285.     int c_flags;            /* context type flags */
  286.     LVAL c_expr;            /* expression (type dependant) */
  287.     jmp_buf c_jmpbuf;            /* longjmp context */
  288.     struct context *c_xlcontext;    /* old value of xlcontext */
  289.     LVAL **c_xlstack;            /* old value of xlstack */
  290.     LVAL *c_xlargv;            /* old value of xlargv */
  291.     int c_xlargc;            /* old value of xlargc */
  292.     LVAL *c_xlfp;            /* old value of xlfp */
  293.     LVAL *c_xlsp;            /* old value of xlsp */
  294.     LVAL c_xlenv;            /* old value of xlenv */
  295.     LVAL c_xlfenv;            /* old value of xlfenv */
  296.     LVAL c_xldenv;            /* old value of xldenv */
  297. } CONTEXT;
  298.  
  299. /* external variables */
  300. extern LVAL **xlstktop;           /* top of the evaluation stack */
  301. extern LVAL **xlstkbase;    /* base of the evaluation stack */
  302. extern LVAL **xlstack;        /* evaluation stack pointer */
  303. extern LVAL *xlargstkbase;    /* base of the argument stack */
  304. extern LVAL *xlargstktop;    /* top of the argument stack */
  305. extern LVAL *xlfp;        /* argument frame pointer */
  306. extern LVAL *xlsp;        /* argument stack pointer */
  307. extern LVAL *xlargv;        /* current argument vector */
  308. extern int xlargc;        /* current argument count */
  309.  
  310. /* external procedure declarations */
  311. extern LVAL xleval();        /* evaluate an expression */
  312. extern LVAL xlapply();        /* apply a function to arguments */
  313. extern LVAL xlsubr();        /* enter a subr/fsubr */
  314. extern LVAL xlenter();        /* enter a symbol */
  315. extern LVAL xlmakesym();    /* make an uninterned symbol */
  316. extern LVAL xlgetvalue();    /* get value of a symbol (checked) */
  317. extern LVAL xlxgetvalue();    /* get value of a symbol */
  318. extern LVAL xlgetfunction();    /* get functional value of a symbol */
  319. extern LVAL xlxgetfunction();    /* get functional value of a symbol (checked) */
  320. extern LVAL xlexpandmacros();    /* expand macros in a form */
  321. extern LVAL xlgetprop();    /* get the value of a property */
  322. extern LVAL xlclose();        /* create a function closure */
  323.  
  324. /* argument list parsing functions */
  325. extern LVAL xlgetfile();          /* get a file/stream argument */
  326. extern LVAL xlgetfname();    /* get a filename argument */
  327.  
  328. /* error reporting functions (don't *really* return at all) */
  329. extern LVAL xltoofew();        /* report "too few arguments" error */
  330. extern LVAL xlbadtype();    /* report "bad argument type" error */
  331.  
  332. 
  333.