home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / MISC / XLSP21TC.ZIP / XLISP.H < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-14  |  9.7 KB  |  323 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 Turbo C compiler - MS-DOS, large model */
  27. #ifdef _TURBOC_
  28. #define NNODES        2000
  29. #define AFMT        "%lx"
  30. #define OFFTYPE        long
  31. #define SAVERESTORE
  32. #endif
  33.  
  34. /* for the AZTEC C compiler - MS-DOS, large model */
  35. #ifdef AZTEC_LM
  36. #define NNODES        2000
  37. #define AFMT        "%lx"
  38. #define OFFTYPE        long
  39. #define CVPTR(x)    ptrtoabs(x)
  40. #define NIL        (void *)0
  41. extern long ptrtoabs();
  42. #define SAVERESTORE
  43. #endif
  44.  
  45. /* for the AZTEC C compiler - Macintosh */
  46. #ifdef AZTEC_MAC
  47. #define NNODES        2000
  48. #define AFMT        "%lx"
  49. #define OFFTYPE        long
  50. #define NIL        (void *)0
  51. #define SAVERESTORE
  52. #endif
  53.  
  54. /* for the AZTEC C compiler - Amiga */
  55. #ifdef AZTEC_AMIGA
  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 Lightspeed C compiler - Macintosh */
  64. #ifdef LSC
  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 Microsoft C compiler - MS-DOS, large model */
  73. #ifdef MSC
  74. #define NNODES        2000
  75. #define AFMT        "%lx"
  76. #define OFFTYPE        long
  77. #endif
  78.  
  79. /* for the Mark Williams C compiler - Atari ST */
  80. #ifdef MWC
  81. #define AFMT        "%lx"
  82. #define OFFTYPE        long
  83. #endif
  84.  
  85. /* for the Lattice C compiler - Atari ST */
  86. #ifdef LATTICE
  87. #define FIXTYPE        int
  88. #define ITYPE        int atoi()
  89. #define ICNV(n)        atoi(n)
  90. #define IFMT        "%d"
  91. #endif
  92.  
  93. /* for the Digital Research C compiler - Atari ST */
  94. #ifdef DR
  95. #define LOCAL
  96. #define AFMT        "%lx"
  97. #define OFFTYPE        long
  98. #undef NULL
  99. #define NULL        0L
  100. #endif
  101.  
  102. /* default important definitions */
  103. #ifndef NNODES
  104. #define NNODES        1000
  105. #endif
  106. #ifndef EDEPTH
  107. #define EDEPTH        2000
  108. #endif
  109. #ifndef ADEPTH
  110. #define ADEPTH        1000
  111. #endif
  112. #ifndef FORWARD
  113. #define FORWARD
  114. #endif
  115. #ifndef LOCAL
  116. #define LOCAL        static
  117. #endif
  118. #ifndef AFMT
  119. #define AFMT        "%x"
  120. #endif
  121. #ifndef FIXTYPE
  122. #define FIXTYPE        long
  123. #endif
  124. #ifndef ITYPE
  125. #define ITYPE        long atol()
  126. #endif
  127. #ifndef ICNV
  128. #define ICNV(n)        atol(n)
  129. #endif
  130. #ifndef IFMT
  131. #define IFMT        "%ld"
  132. #endif
  133. #ifndef FLOTYPE
  134. #define FLOTYPE        double
  135. #endif
  136. #ifndef OFFTYPE
  137. #define OFFTYPE        int
  138. #endif
  139. #ifndef CVPTR
  140. #define CVPTR(x)    (x)
  141. #endif
  142. #ifndef UCHAR
  143. #define UCHAR        unsigned char
  144. #endif
  145.  
  146. /* useful definitions */
  147. #define TRUE    1
  148. #define FALSE    0
  149. #ifndef NIL
  150. #define NIL    (LVAL )0
  151. #endif
  152.  
  153. /* include the dynamic memory definitions */
  154. #include "xldmem.h"
  155.  
  156. /* program limits */
  157. #define STRMAX        100        /* maximum length of a string constant */
  158. #define HSIZE        199        /* symbol hash table size */
  159. #define SAMPLE        100        /* control character sample rate */
  160.  
  161. /* function table offsets for the initialization functions */
  162. #define FT_RMHASH    0
  163. #define FT_RMQUOTE    1
  164. #define FT_RMDQUOTE    2
  165. #define FT_RMBQUOTE    3
  166. #define FT_RMCOMMA    4
  167. #define FT_RMLPAR    5
  168. #define FT_RMRPAR    6
  169. #define FT_RMSEMI    7
  170. #define FT_CLNEW    10
  171. #define FT_CLISNEW    11
  172. #define FT_CLANSWER    12
  173. #define FT_OBISNEW    13
  174. #define FT_OBCLASS    14
  175. #define FT_OBSHOW    15
  176.     
  177. /* macro to push a value onto the argument stack */
  178. #define pusharg(x)    {if (xlsp >= xlargstktop) xlargstkoverflow();\
  179.              *xlsp++ = (x);}
  180.  
  181. /* macros to protect pointers */
  182. #define xlstkcheck(n)    {if (xlstack - (n) < xlstkbase) xlstkoverflow();}
  183. #define xlsave(n)    {*--xlstack = &n; n = NIL;}
  184. #define xlprotect(n)    {*--xlstack = &n;}
  185.  
  186. /* check the stack and protect a single pointer */
  187. #define xlsave1(n)    {if (xlstack <= xlstkbase) xlstkoverflow();\
  188.                          *--xlstack = &n; n = NIL;}
  189. #define xlprot1(n)    {if (xlstack <= xlstkbase) xlstkoverflow();\
  190.                          *--xlstack = &n;}
  191.  
  192. /* macros to pop pointers off the stack */
  193. #define xlpop()        {++xlstack;}
  194. #define xlpopn(n)    {xlstack+=(n);}
  195.  
  196. /* macros to manipulate the lexical environment */
  197. #define xlframe(e)    cons(NIL,e)
  198. #define xlbind(s,v)    xlpbind(s,v,xlenv)
  199. #define xlfbind(s,v)    xlpbind(s,v,xlfenv);
  200. #define xlpbind(s,v,e)    {rplaca(e,cons(cons(s,v),car(e)));}
  201.  
  202. /* macros to manipulate the dynamic environment */
  203. #define xldbind(s,v)    {xldenv = cons(cons(s,getvalue(s)),xldenv);\
  204.              setvalue(s,v);}
  205. #define xlunbind(e)    {for (; xldenv != (e); xldenv = cdr(xldenv))\
  206.                setvalue(car(car(xldenv)),cdr(car(xldenv)));}
  207.  
  208. /* type predicates */                   
  209. #define atom(x)        ((x) == NIL || ntype(x) != CONS)
  210. #define null(x)        ((x) == NIL)
  211. #define listp(x)    ((x) == NIL || ntype(x) == CONS)
  212. #define consp(x)    ((x) && ntype(x) == CONS)
  213. #define subrp(x)    ((x) && ntype(x) == SUBR)
  214. #define fsubrp(x)    ((x) && ntype(x) == FSUBR)
  215. #define stringp(x)    ((x) && ntype(x) == STRING)
  216. #define symbolp(x)    ((x) && ntype(x) == SYMBOL)
  217. #define streamp(x)    ((x) && ntype(x) == STREAM)
  218. #define objectp(x)    ((x) && ntype(x) == OBJECT)
  219. #define fixp(x)        ((x) && ntype(x) == FIXNUM)
  220. #define floatp(x)    ((x) && ntype(x) == FLONUM)
  221. #define vectorp(x)    ((x) && ntype(x) == VECTOR)
  222. #define closurep(x)    ((x) && ntype(x) == CLOSURE)
  223. #define charp(x)    ((x) && ntype(x) == CHAR)
  224. #define ustreamp(x)    ((x) && ntype(x) == USTREAM)
  225. #define structp(x)    ((x) && ntype(x) == STRUCT)
  226. #define boundp(x)    (getvalue(x) != s_unbound)
  227. #define fboundp(x)    (getfunction(x) != s_unbound)
  228.  
  229. /* shorthand functions */
  230. #define consa(x)    cons(x,NIL)
  231. #define consd(x)    cons(NIL,x)
  232.  
  233. /* argument list parsing macros */
  234. #define xlgetarg()    (testarg(nextarg()))
  235. #define xllastarg()    {if (xlargc != 0) xltoomany();}
  236. #define testarg(e)    (moreargs() ? (e) : xltoofew())
  237. #define typearg(tp)    (tp(*xlargv) ? nextarg() : xlbadtype(*xlargv))
  238. #define nextarg()    (--xlargc, *xlargv++)
  239. #define moreargs()    (xlargc > 0)
  240.  
  241. /* macros to get arguments of a particular type */
  242. #define xlgacons()    (testarg(typearg(consp)))
  243. #define xlgalist()    (testarg(typearg(listp)))
  244. #define xlgasymbol()    (testarg(typearg(symbolp)))
  245. #define xlgastring()    (testarg(typearg(stringp)))
  246. #define xlgaobject()    (testarg(typearg(objectp)))
  247. #define xlgafixnum()    (testarg(typearg(fixp)))
  248. #define xlgaflonum()    (testarg(typearg(floatp)))
  249. #define xlgachar()    (testarg(typearg(charp)))
  250. #define xlgavector()    (testarg(typearg(vectorp)))
  251. #define xlgastream()    (testarg(typearg(streamp)))
  252. #define xlgaustream()    (testarg(typearg(ustreamp)))
  253. #define xlgaclosure()    (testarg(typearg(closurep)))
  254. #define xlgastruct()    (testarg(typearg(structp)))
  255.  
  256. /* function definition structure */
  257. typedef struct {
  258.     char *fd_name;    /* function name */
  259.     int fd_type;    /* function type */
  260.     LVAL (*fd_subr)();    /* function entry point */
  261. } FUNDEF;
  262.  
  263. /* execution context flags */
  264. #define CF_GO        0x0001
  265. #define CF_RETURN    0x0002
  266. #define CF_THROW    0x0004
  267. #define CF_ERROR    0x0008
  268. #define CF_CLEANUP    0x0010
  269. #define CF_CONTINUE    0x0020
  270. #define CF_TOPLEVEL    0x0040
  271. #define CF_BRKLEVEL    0x0080
  272. #define CF_UNWIND    0x0100
  273.  
  274. /* execution context */
  275. typedef struct context {
  276.     int c_flags;            /* context type flags */
  277.     LVAL c_expr;            /* expression (type dependant) */
  278.     jmp_buf c_jmpbuf;            /* longjmp context */
  279.     struct context *c_xlcontext;    /* old value of xlcontext */
  280.     LVAL **c_xlstack;            /* old value of xlstack */
  281.     LVAL *c_xlargv;            /* old value of xlargv */
  282.     int c_xlargc;            /* old value of xlargc */
  283.     LVAL *c_xlfp;            /* old value of xlfp */
  284.     LVAL *c_xlsp;            /* old value of xlsp */
  285.     LVAL c_xlenv;            /* old value of xlenv */
  286.     LVAL c_xlfenv;            /* old value of xlfenv */
  287.     LVAL c_xldenv;            /* old value of xldenv */
  288. } CONTEXT;
  289.  
  290. /* external variables */
  291. extern LVAL **xlstktop;           /* top of the evaluation stack */
  292. extern LVAL **xlstkbase;    /* base of the evaluation stack */
  293. extern LVAL **xlstack;        /* evaluation stack pointer */
  294. extern LVAL *xlargstkbase;    /* base of the argument stack */
  295. extern LVAL *xlargstktop;    /* top of the argument stack */
  296. extern LVAL *xlfp;        /* argument frame pointer */
  297. extern LVAL *xlsp;        /* argument stack pointer */
  298. extern LVAL *xlargv;        /* current argument vector */
  299. extern int xlargc;        /* current argument count */
  300.  
  301. /* external procedure declarations */
  302. extern LVAL xleval();        /* evaluate an expression */
  303. extern LVAL xlapply();        /* apply a function to arguments */
  304. extern LVAL xlsubr();        /* enter a subr/fsubr */
  305. extern LVAL xlenter();        /* enter a symbol */
  306. extern LVAL xlmakesym();    /* make an uninterned symbol */
  307. extern LVAL xlgetvalue();    /* get value of a symbol (checked) */
  308. extern LVAL xlxgetvalue();    /* get value of a symbol */
  309. extern LVAL xlgetfunction();    /* get functional value of a symbol */
  310. extern LVAL xlxgetfunction();    /* get functional value of a symbol (checked) */
  311. extern LVAL xlexpandmacros();    /* expand macros in a form */
  312. extern LVAL xlgetprop();    /* get the value of a property */
  313. extern LVAL xlclose();        /* create a function closure */
  314.  
  315. /* argument list parsing functions */
  316. extern LVAL xlgetfile();          /* get a file/stream argument */
  317. extern LVAL xlgetfname();    /* get a filename argument */
  318.  
  319. /* error reporting functions (don't *really* return at all) */
  320. extern LVAL xltoofew();        /* report "too few arguments" error */
  321. extern LVAL xlbadtype();    /* report "bad argument type" error */
  322.  
  323.