home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / unix / volume1 / xlisp1.4 / part5 < prev    next >
Encoding:
Text File  |  1986-11-30  |  8.2 KB  |  272 lines
  1. #include <stdio.h>
  2.  
  3.               /* xlisp - a small subset of lisp */
  4.  
  5.  
  6.             /* system specific definitions */
  7.  
  8. /* DEFEXT       define to enable default extension of '.lsp' on 'load' */
  9. /* FGETNAME     define if system supports 'fgetname' */
  10. /* NNODES       number of nodes to allocate in each request */
  11. /* xlisp - a small subset of lisp */
  12.  
  13. /* system specific definitions */
  14. #define UNIX
  15.  
  16. #ifdef AZTEC
  17. #include "stdio.h"
  18. #include "setjmp.h"
  19. #else
  20. #include <stdio.h>
  21. #include <setjmp.h>
  22. #include <ctype.h>
  23. #endif
  24.  
  25. /* NNODES       number of nodes to allocate in each request */
  26. /* TDEPTH       trace stack depth */
  27. /* FORWARD      type of a forward declaration (usually "") */
  28. /* LOCAL        type of a local function (usually "static") */
  29.  
  30. /* for the Computer Innovations compiler */
  31. #ifdef CI
  32. #define NNODES          1000
  33. #define TDEPTH          500
  34. #endif
  35.  
  36. /* for the CPM68K compiler */
  37. #ifdef CPM68K
  38. #define NNODES          1000
  39. #define TDEPTH          500
  40. #define LOCAL
  41. #define AFMT            "%lx"
  42. #undef NULL
  43. #define NULL            (char *)0
  44. #endif
  45.  
  46. /* for the DeSmet compiler */
  47. #ifdef DESMET
  48. #define NNODES          1000
  49. #define TDEPTH          500
  50. #define LOCAL
  51. #define getc(fp)        getcx(fp)
  52. #define putc(ch,fp)     putcx(ch,fp)
  53. #define EOF             -1
  54. #endif
  55.  
  56. /* for the MegaMax compiler */
  57. #ifdef MEGAMAX
  58. #define NNODES          200
  59. #define TDEPTH          100
  60. #define LOCAL
  61. #define AFMT            "%lx"
  62. #define TSTKSIZE        (4 * TDEPTH)
  63. #endif
  64.  
  65. /* for the VAX-11 C compiler */
  66. #ifdef vms
  67. #define NNODES          2000
  68. #define TDEPTH          1000
  69. #endif
  70.  
  71. /* for the DECUS C compiler */
  72. #ifdef decus
  73. #define NNODES          200
  74. #define TDEPTH          100
  75. #define FORWARD         extern
  76. #endif
  77.  
  78. /* for unix compilers */
  79. #ifdef unix
  80. #define NNODES          200
  81. #define TDEPTH          100
  82. #endif
  83.  
  84. /* for the AZTEC C compiler */
  85. #ifdef AZTEC
  86. #define NNODES          200
  87. #define TDEPTH          100
  88. #define getc(fp)        agetc(fp)
  89. #define putc(ch,fp)     aputc(ch,fp)
  90. #endif
  91.  
  92. /* default important definitions */
  93. #ifndef NNODES
  94. #define NNODES          200
  95. #endif
  96. #ifndef TDEPTH
  97. #define TDEPTH          100
  98. #endif
  99. #ifndef FORWARD
  100. #define FORWARD
  101. #endif
  102. #ifndef LOCAL
  103. #define LOCAL           static
  104. #endif
  105. #ifndef AFMT
  106. #define AFMT            "%x"
  107. #endif
  108. #ifndef TSTKSIZE
  109. #define TSTKSIZE        (sizeof(NODE *) * TDEPTH)
  110. #endif
  111.  
  112. /* useful definitions */
  113. #define TRUE    1
  114. #define FALSE   0
  115. #define NIL     (NODE *)0
  116.  
  117. /* program limits */
  118. #define STRMAX          100             /* maximum length of a string constant */
  119.         
  120. /* node types */
  121. #define FREE    0
  122. #define SUBR    1
  123. #define FSUBR   2
  124. #define LIST    3
  125. #define SYM     4
  126. #define INT     5
  127. #define STR     6
  128. #define OBJ     7
  129. #define FPTR    8
  130.  
  131. /* node flags */
  132. #define MARK    1
  133. #define LEFT    2
  134.  
  135. /* string types */
  136. #define DYNAMIC 0
  137. #define STATIC  1
  138.  
  139. /* new node access macros */
  140. #define ntype(x)        ((x)->n_type)
  141. #define atom(x)         ((x) == NIL || (x)->n_type != LIST)
  142. #define null(x)         ((x) == NIL)
  143. #define listp(x)        ((x) == NIL || (x)->n_type == LIST)
  144. #define consp(x)        ((x) && (x)->n_type == LIST)
  145. #define subrp(x)        ((x) && (x)->n_type == SUBR)
  146. #define fsubrp(x)       ((x) && (x)->n_type == FSUBR)
  147. #define stringp(x)      ((x) && (x)->n_type == STR)
  148. #define symbolp(x)      ((x) && (x)->n_type == SYM)
  149. #define filep(x)        ((x) && (x)->n_type == FPTR)
  150. #define objectp(x)      ((x) && (x)->n_type == OBJ)
  151. #define fixp(x)         ((x) && (x)->n_type == INT)
  152. #define car(x)          ((x)->n_car)
  153. #define cdr(x)          ((x)->n_cdr)
  154. #define rplaca(x,y)     ((x)->n_car = (y))
  155. #define rplacd(x,y)     ((x)->n_cdr = (y))
  156.  
  157. /* symbol node */
  158. #define n_symplist      n_info.n_xsym.xsy_plist
  159. #define n_symvalue      n_info.n_xsym.xsy_value
  160.  
  161. /* subr/fsubr node */
  162. #define n_subr          n_info.n_xsubr.xsu_subr
  163.  
  164. /* list node */
  165. #define n_car           n_info.n_xlist.xl_car
  166. #define n_cdr           n_info.n_xlist.xl_cdr
  167. #define n_ptr           n_info.n_xlist.xl_car
  168.  
  169. /* integer node */
  170. #define n_int           n_info.n_xint.xi_int
  171.  
  172. /* string node */
  173. #define n_str           n_info.n_xstr.xst_str
  174. #define n_strtype       n_info.n_xstr.xst_type
  175.  
  176. /* object node */
  177. #define n_obclass       n_info.n_xobj.xo_obclass
  178. #define n_obdata        n_info.n_xobj.xo_obdata
  179.  
  180. /* file pointer node */
  181. #define n_fp            n_info.n_xfptr.xf_fp
  182. #define n_savech        n_info.n_xfptr.xf_savech
  183.  
  184. /* node structure */
  185. typedef struct node {
  186.     char n_type;                /* type of node */
  187.     char n_flags;               /* flag bits */
  188.     union {                     /* value */
  189.         struct xsym {           /* symbol node */
  190.             struct node *xsy_plist;     /* symbol plist - (name . plist) */
  191.             struct node *xsy_value;     /* the current value */
  192.         } n_xsym;
  193.         struct xsubr {          /* subr/fsubr node */
  194.             struct node *(*xsu_subr)(); /* pointer to an internal routine */
  195.         } n_xsubr;
  196.         struct xlist {          /* list node (cons) */
  197.             struct node *xl_car;        /* the car pointer */
  198.             struct node *xl_cdr;        /* the cdr pointer */
  199.         } n_xlist;
  200.         struct xint {           /* integer node */
  201.             int xi_int;                 /* integer value */
  202.         } n_xint;
  203.         struct xstr {           /* string node */
  204.             int xst_type;               /* string type */
  205.             char *xst_str;              /* string pointer */
  206.         } n_xstr;
  207.         struct xobj {           /* object node */
  208.             struct node *xo_obclass;    /* class of object */
  209.             struct node *xo_obdata;     /* instance data */
  210.         } n_xobj;
  211.         struct xfptr {          /* file pointer node */
  212.             FILE *xf_fp;                /* the file pointer */
  213.             int xf_savech;              /* lookahead character for input files */
  214.         } n_xfptr;
  215.     } n_info;
  216. } NODE;
  217.  
  218. /* execution context flags */
  219. #define CF_GO           1
  220. #define CF_RETURN       2
  221. #define CF_THROW        4
  222. #define CF_ERROR        8
  223.  
  224. /* execution context */
  225. typedef struct context {
  226.     int c_flags;                        /* context type flags */
  227.     struct node *c_expr;                /* expression (type dependant) */
  228.     jmp_buf c_jmpbuf;                   /* longjmp context */
  229.     struct context *c_xlcontext;        /* old value of xlcontext */
  230.     struct node *c_xlstack;             /* old value of xlstack */
  231.     struct node *c_xlenv,*c_xlnewenv;   /* old values of xlenv and xlnewenv */
  232.     int c_xltrace;                      /* old value of xltrace */
  233. } CONTEXT;
  234.  
  235. /* function table entry structure */
  236. struct fdef {
  237.     char *f_name;                       /* function name */
  238.     int f_type;                         /* function type SUBR/FSUBR */
  239.     struct node *(*f_fcn)();            /* function code */
  240. };
  241.  
  242. /* memory segment structure definition */
  243. struct segment {
  244.     int sg_size;
  245.     struct segment *sg_next;
  246.     struct node sg_nodes[1];
  247. };
  248.  
  249. /* external procedure declarations */
  250. extern struct node *xleval();           /* evaluate an expression */
  251. extern struct node *xlapply();          /* apply a function to arguments */
  252. extern struct node *xlevlist();         /* evaluate a list of arguments */
  253. extern struct node *xlarg();            /* fetch an argument */
  254. extern struct node *xlevarg();          /* fetch and evaluate an argument */
  255. extern struct node *xlmatch();          /* fetch an typed argument */
  256. extern struct node *xlevmatch();        /* fetch and evaluate a typed arg */
  257. extern struct node *xlsend();           /* send a message to an object */
  258. extern struct node *xlenter();          /* enter a symbol */
  259. extern struct node *xlsenter();         /* enter a symbol with a static pname */
  260. extern struct node *xlintern();         /* intern a symbol */
  261. extern struct node *xlmakesym();        /* make an uninterned symbol */
  262. extern struct node *xlsave();           /* generate a stack frame */
  263. extern struct node *xlobsym();          /* find an object's class or instance
  264.                                            variable */
  265. extern struct node *xlgetprop();        /* get the value of a property */
  266. extern char *xlsymname();               /* get the print name of a symbol */
  267.  
  268. extern struct node *newnode();          /* allocate a new node */
  269. extern char *stralloc();                /* allocate string space */
  270. extern char *strsave();                 /* make a safe copy of a string */
  271.  
  272.