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