home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / xlisp / XLisp 1.7 ƒ / xlisp sources / xlisp.h < prev    next >
Encoding:
C/C++ Source or Header  |  1985-12-21  |  9.8 KB  |  362 lines  |  [TEXT/????]
  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 MEGAMAX
  8.  
  9. #include <stdio.h>
  10. #include <ctype.h>
  11. #ifndef MEGAMAX
  12. #include <setjmp.h>
  13. #endif
  14.  
  15. /* NNODES    number of nodes to allocate in each request (1000) */
  16. /* TDEPTH    trace stack depth (500) */
  17. /* EDEPTH    evaluation stack depth (1000) */
  18. /* FORWARD    type of a forward declaration () */
  19. /* LOCAL    type of a local function (static) */
  20. /* AFMT        printf format for addresses ("%x") */
  21. /* FIXNUM    data type for fixed point numbers (long) */
  22. /* ITYPE    fixed point input conversion routine type (long atol()) */
  23. /* ICNV        fixed point input conversion routine (atol) */
  24. /* IFMT        printf format for fixed point numbers ("%ld") */
  25. /* FLONUM    data type for floating point numbers (float) */
  26. /* SYSTEM    enable the control-d command */
  27.  
  28. /* for the Computer Innovations compiler */
  29. #ifdef CI
  30. #define ITYPE        long atoi()
  31. #define ICNV(n)        atoi(n)
  32. #define NIL        0
  33. #define getc(fp)    osgetc(fp)
  34. #define putc(ch,fp)    osputc(ch,fp)
  35. #define SYSTEM
  36. #endif
  37.  
  38. /* for the CPM68K compiler */
  39. #ifdef CPM68K
  40. #define LOCAL
  41. #define AFMT        "%lx"
  42. #define FLONUM        double
  43. #undef NULL
  44. #define NULL        0L
  45. #endif
  46.  
  47. /* for the DeSmet compiler */
  48. #ifdef DESMET
  49. #define LOCAL
  50. #define getc(fp)    getcx(fp)
  51. #define putc(ch,fp)    putcx(ch,fp)
  52. #define EOF        -1
  53. #endif
  54.  
  55. /* for the MegaMax compiler */
  56. #ifdef MEGAMAX
  57. #define LOCAL
  58. #define AFMT        "%lx"
  59. #define getc(fp)    osgetc(fp)
  60. #define putc(ch,fp)    osputc(ch,fp)
  61. #endif
  62.  
  63. /* for the VAX-11 C compiler */
  64. #ifdef vms
  65. #define NNODES        2000
  66. #define TDEPTH        1000
  67. #define EDEPTH        2000
  68. #endif
  69.  
  70. /* for unix compilers */
  71. #ifdef unix
  72. #define NNODES        200
  73. #define TDEPTH        100
  74. #endif
  75.  
  76. /* for the AZTEC C compiler - small model */
  77. #ifdef AZTEC_SM
  78. #define SYSTEM
  79. #define getc(fp)    osgetc(fp)
  80. #define putc(ch,fp)    osputc(ch,fp)
  81. #define NIL        0
  82. #endif
  83.  
  84. /* for the AZTEC C compiler - large model */
  85. #ifdef AZTEC_LM
  86. #define FLONUM        double
  87. #define SYSTEM
  88. #define getc(fp)    osgetc(fp)
  89. #define putc(ch,fp)    osputc(ch,fp)
  90. #define NIL        0L
  91. #endif
  92.  
  93. /* default important definitions */
  94. #ifndef NNODES
  95. #define NNODES        1000
  96. #endif
  97. #ifndef TDEPTH
  98. #define TDEPTH        500
  99. #endif
  100. #ifndef EDEPTH
  101. #define EDEPTH        1000
  102. #endif
  103. #ifndef FORWARD
  104. #define FORWARD
  105. #endif
  106. #ifndef LOCAL
  107. #define LOCAL        static
  108. #endif
  109. #ifndef AFMT
  110. #define AFMT        "%x"
  111. #endif
  112. #ifndef FIXNUM
  113. #define FIXNUM        long
  114. #endif
  115. #ifndef ITYPE
  116. #define ITYPE        long atol()
  117. #endif
  118. #ifndef ICNV
  119. #define ICNV(n)        atol(n)
  120. #endif
  121. #ifndef IFMT
  122. #define IFMT        "%ld"
  123. #endif
  124. #ifndef FLONUM
  125. #define FLONUM        float
  126. #endif
  127.  
  128. /* useful definitions */
  129. #define TRUE    1
  130. #define FALSE    0
  131. #ifndef NIL
  132. #define NIL    (NODE *)0
  133. #endif
  134.  
  135. /* absolute value macros */
  136. #define abs(n)    ((n) < 0 ? -(n) : (n))
  137. #define fabs(n)    ((n) < 0.0 ? -(n) : (n))
  138.  
  139. /* program limits */
  140. #define STRMAX        100        /* maximum length of a string constant */
  141. #define HSIZE        199        /* symbol hash table size */
  142. #define SAMPLE        100        /* control character sample rate */
  143.     
  144. /* node types */
  145. #define FREE    0
  146. #define SUBR    1
  147. #define FSUBR    2
  148. #define LIST    3
  149. #define SYM    4
  150. #define INT    5
  151. #define STR    6
  152. #define OBJ    7
  153. #define FPTR    8
  154. #define FLOAT    9
  155. #define VECT    10
  156.  
  157. /* node flags */
  158. #define MARK    1
  159. #define LEFT    2
  160.  
  161. /* string types */
  162. #define DYNAMIC    0
  163. #define STATIC    1
  164.  
  165. /* new node access macros */
  166. #define ntype(x)    ((x)->n_type)
  167.  
  168. /* type predicates */
  169. #define atom(x)        ((x) == NIL || (x)->n_type != LIST)
  170. #define null(x)        ((x) == NIL)
  171. #define listp(x)    ((x) == NIL || (x)->n_type == LIST)
  172. #define consp(x)    ((x) && (x)->n_type == LIST)
  173. #define subrp(x)    ((x) && (x)->n_type == SUBR)
  174. #define fsubrp(x)    ((x) && (x)->n_type == FSUBR)
  175. #define stringp(x)    ((x) && (x)->n_type == STR)
  176. #define symbolp(x)    ((x) && (x)->n_type == SYM)
  177. #define filep(x)    ((x) && (x)->n_type == FPTR)
  178. #define objectp(x)    ((x) && (x)->n_type == OBJ)
  179. #define fixp(x)        ((x) && (x)->n_type == INT)
  180. #define floatp(x)    ((x) && (x)->n_type == FLOAT)
  181. #define vectorp(x)    ((x) && (x)->n_type == VECT)
  182.  
  183. /* cons access macros */
  184. #define car(x)        ((x)->n_car)
  185. #define cdr(x)        ((x)->n_cdr)
  186. #define rplaca(x,y)    ((x)->n_car = (y))
  187. #define rplacd(x,y)    ((x)->n_cdr = (y))
  188.  
  189. /* symbol access macros */
  190. #define getvalue(x)    ((x)->n_symvalue)
  191. #define setvalue(x,v)    ((x)->n_symvalue = (v))
  192. #define getplist(x)    ((x)->n_symplist->n_cdr)
  193. #define setplist(x,v)    ((x)->n_symplist->n_cdr = (v))
  194. #define getpname(x)    ((x)->n_symplist->n_car)
  195.  
  196. /* vector access macros */
  197. #define getsize(x)    ((x)->n_vsize)
  198. #define getelement(x,i)    ((x)->n_vdata[i])
  199. #define setelement(x,i,v) ((x)->n_vdata[i] = (v))
  200.  
  201. /* object access macros */
  202. #define getclass(x)    ((x)->n_vdata[0])
  203. #define getivar(x,i)    ((x)->n_vdata[i+1])
  204. #define setivar(x,i,v)    ((x)->n_vdata[i+1] = (v))
  205.  
  206. /* subr/fsubr access macros */
  207. #define getsubr(x)    ((x)->n_subr)
  208.  
  209. /* fixnum/flonum access macros */
  210. #define getfixnum(x)    ((x)->n_int)
  211. #define getflonum(x)    ((x)->n_float)
  212.  
  213. /* string access macros */
  214. #define getstring(x)    ((x)->n_str)
  215. #define setstring(x,v)    ((x)->n_str = (v))
  216.  
  217. /* file access macros */
  218. #define getfile(x)    ((x)->n_fp)
  219. #define setfile(x,v)    ((x)->n_fp = (v))
  220. #define getsavech(x)    ((x)->n_savech)
  221. #define setsavech(x,v)    ((x)->n_savech = (v))
  222.  
  223. /* symbol node */
  224. #define n_symplist    n_info.n_xsym.xsy_plist
  225. #define n_symvalue    n_info.n_xsym.xsy_value
  226.  
  227. /* subr/fsubr node */
  228. #define n_subr        n_info.n_xsubr.xsu_subr
  229.  
  230. /* list node */
  231. #define n_car        n_info.n_xlist.xl_car
  232. #define n_cdr        n_info.n_xlist.xl_cdr
  233.  
  234. /* integer node */
  235. #define n_int        n_info.n_xint.xi_int
  236.  
  237. /* float node */
  238. #define n_float        n_info.n_xfloat.xf_float
  239.  
  240. /* string node */
  241. #define n_str        n_info.n_xstr.xst_str
  242. #define n_strtype    n_info.n_xstr.xst_type
  243.  
  244. /* file pointer node */
  245. #define n_fp        n_info.n_xfptr.xf_fp
  246. #define n_savech    n_info.n_xfptr.xf_savech
  247.  
  248. /* vector/object node */
  249. #define n_vsize        n_info.n_xvect.xv_size
  250. #define n_vdata        n_info.n_xvect.xv_data
  251.  
  252. /* node structure */
  253. typedef struct node {
  254.     char n_type;        /* type of node */
  255.     char n_flags;        /* flag bits */
  256.     union {            /* value */
  257.     struct xsym {        /* symbol node */
  258.         struct node *xsy_plist;    /* symbol plist - (name . plist) */
  259.         struct node *xsy_value;    /* the current value */
  260.     } n_xsym;
  261.     struct xsubr {        /* subr/fsubr node */
  262.         struct node *(*xsu_subr)();    /* pointer to an internal routine */
  263.     } n_xsubr;
  264.     struct xlist {        /* list node (cons) */
  265.         struct node *xl_car;    /* the car pointer */
  266.         struct node *xl_cdr;    /* the cdr pointer */
  267.     } n_xlist;
  268.     struct xint {        /* integer node */
  269.         FIXNUM xi_int;        /* integer value */
  270.     } n_xint;
  271.     struct xfloat {        /* float node */
  272.         FLONUM xf_float;        /* float value */
  273.     } n_xfloat;
  274.     struct xstr {        /* string node */
  275.         int xst_type;        /* string type */
  276.         char *xst_str;        /* string pointer */
  277.     } n_xstr;
  278.     struct xfptr {        /* file pointer node */
  279.         FILE *xf_fp;        /* the file pointer */
  280.         int xf_savech;        /* lookahead character for input files */
  281.     } n_xfptr;
  282.     struct xvect {        /* vector node */
  283.         int xv_size;        /* vector size */
  284.         struct node **xv_data;    /* vector data */
  285.     } n_xvect;
  286.     } n_info;
  287. } NODE;
  288.  
  289. /* execution context flags */
  290. #define CF_GO        1
  291. #define CF_RETURN    2
  292. #define CF_THROW    4
  293. #define CF_ERROR    8
  294. #define CF_CLEANUP    16
  295. #define CF_CONTINUE    32
  296. #define CF_TOPLEVEL    64
  297.  
  298. /* execution context */
  299. typedef struct context {
  300.     int c_flags;            /* context type flags */
  301.     struct node *c_expr;        /* expression (type dependant) */
  302.     jmp_buf c_jmpbuf;            /* longjmp context */
  303.     struct context *c_xlcontext;    /* old value of xlcontext */
  304.     struct node ***c_xlstack;        /* old value of xlstack */
  305.     struct node *c_xlenv;        /* old value of xlenv */
  306.     int c_xltrace;            /* old value of xltrace */
  307. } CONTEXT;
  308.  
  309. /* function table entry structure */
  310. struct fdef {
  311.     char *f_name;            /* function name */
  312.     int f_type;                /* function type SUBR/FSUBR */
  313.     struct node *(*f_fcn)();        /* function code */
  314. };
  315.  
  316. /* memory segment structure definition */
  317. struct segment {
  318.     int sg_size;
  319.     struct segment *sg_next;
  320.     struct node sg_nodes[1];
  321. };
  322.  
  323. /* external procedure declarations */
  324. extern struct node ***xlsave();        /* generate a stack frame */
  325. extern struct node *xleval();        /* evaluate an expression */
  326. extern struct node *xlapply();        /* apply a function to arguments */
  327. extern struct node *xlevlist();        /* evaluate a list of arguments */
  328. extern struct node *xlarg();        /* fetch an argument */
  329. extern struct node *xlevarg();        /* fetch and evaluate an argument */
  330. extern struct node *xlmatch();        /* fetch an typed argument */
  331. extern struct node *xlevmatch();    /* fetch and evaluate a typed arg */
  332. extern struct node *xlgetfile();    /* fetch a file/stream argument */
  333. extern struct node *xlsend();        /* send a message to an object */
  334. extern struct node *xlenter();        /* enter a symbol */
  335. extern struct node *xlsenter();        /* enter a symbol with a static pname */
  336. extern struct node *xlmakesym();    /* make an uninterned symbol */
  337. extern struct node *xlframe();        /* establish a new environment frame */
  338. extern struct node *xlgetvalue();    /* get value of a symbol (checked) */
  339. extern struct node *xlxgetvalue();    /* get value of a symbol */
  340. extern struct node *xlygetvalue();    /* get value of a symbol (no ivars) */
  341.  
  342. extern struct node *cons();        /* (cons x y) */
  343. extern struct node *consa();        /* (cons x nil) */
  344. extern struct node *consd();        /* (cons nil x) */
  345.  
  346. extern struct node *cvsymbol();        /* convert a string to a symbol */
  347. extern struct node *cvcsymbol();    /* (same but constant string) */
  348. extern struct node *cvstring();        /* convert a string */
  349. extern struct node *cvcstring();    /* (same but constant string) */
  350. extern struct node *cvfile();        /* convert a FILE * to a file */
  351. extern struct node *cvsubr();        /* convert a function to a subr/fsubr */
  352. extern struct node *cvfixnum();        /* convert a fixnum */
  353. extern struct node *cvflonum();        /* convert a flonum */
  354.  
  355. extern struct node *newstring();    /* create a new string */
  356. extern struct node *newvector();    /* create a new vector */
  357. extern struct node *newobject();    /* create a new object */
  358.  
  359. extern struct node *xlgetprop();    /* get the value of a property */
  360. extern char *xlsymname();        /* get the print name of a symbol */
  361.  
  362.