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