home *** CD-ROM | disk | FTP | other *** search
/ Boldly Go Collection / version40.iso / TS / 25D / XSCHEM20.ZIP / XSCHEME.H < prev    next >
C/C++ Source or Header  |  1989-11-06  |  13KB  |  426 lines
  1. /* xscheme.h - xscheme definitions */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. /* system specific definitions */
  7. #define UNIX
  8.  
  9. #include <stdio.h>
  10. #include <ctype.h>
  11. #include <setjmp.h>
  12.  
  13. /* FORWARD    type of a forward declaration () */
  14. /* LOCAL    type of a local function (static) */
  15. /* AFMT        printf format for addresses ("%x") */
  16. /* OFFTYPE    number the size of an address (int) */
  17. /* FIXTYPE    data type for fixed point numbers (long) */
  18. /* ITYPE    fixed point input conversion routine type (long atol()) */
  19. /* ICNV        fixed point input conversion routine (atol) */
  20. /* IFMT        printf format for fixed point numbers ("%ld") */
  21. /* FLOTYPE    data type for floating point numbers (float) */
  22. /* FFMT        printf format for floating point numbers (%.15g) */
  23.  
  24. /* for the Lightspeed C compiler - Macintosh */
  25. #ifdef LSC
  26. #define AFMT        "%lx"
  27. #define OFFTYPE        long
  28. #define NIL        (void *)0
  29. #define MACINTOSH
  30. #endif
  31.  
  32. /* for the UNIX System V C compiler */
  33. #ifdef UNIX
  34. #endif
  35.  
  36. /* for the Aztec C compiler - Amiga */
  37. #ifdef AZTEC_AMIGA
  38. #define AFMT        "%lx"
  39. #define OFFTYPE        long
  40. #endif
  41.  
  42. /* for the Mark Williams C compiler - Atari ST */
  43. #ifdef MWC
  44. #define AFMT        "%lx"
  45. #define OFFTYPE        long
  46. #endif
  47.  
  48. /* for the Microsoft C 5.0 compiler */
  49. #ifdef MSC
  50. #define AFMT        "%lx"
  51. #define OFFTYPE        long
  52. #define INSEGMENT(n,s)    (((OFFTYPE)(n) >> 16) == ((OFFTYPE)(s) >> 16))
  53. #define VCOMPARE(f,s,t)    ((LVAL huge *)(f) + (s) < (LVAL huge *)(t))
  54. /* #define MSDOS -- MSC 5.0 defines this automatically */
  55. #endif
  56.  
  57. /* for the Turbo C compiler */
  58. #ifdef _TURBOC_
  59. #define AFMT        "%lx"
  60. #define OFFTYPE        long
  61. #define INSEGMENT(n,s)    (((OFFTYPE)(n) >> 16) == ((OFFTYPE)(s) >> 16))
  62. #define VCOMPARE(f,s,t)    ((LVAL huge *)(f) + (s) < (LVAL huge *)(t))
  63. #define MSDOS
  64. #endif
  65.  
  66. /* size of each type of memory segment */
  67. #ifndef NSSIZE
  68. #define NSSIZE    4000    /* number of nodes per node segment */
  69. #endif
  70. #ifndef VSSIZE
  71. #define VSSIZE    10000    /* number of LVAL's per vector segment */
  72. #endif
  73.  
  74. /* default important definitions */
  75. #ifndef FORWARD
  76. #define FORWARD
  77. #endif
  78. #ifndef LOCAL
  79. #define LOCAL        static
  80. #endif
  81. #ifndef AFMT
  82. #define AFMT        "%x"
  83. #endif
  84. #ifndef OFFTYPE
  85. #define OFFTYPE        int
  86. #endif
  87. #ifndef FIXTYPE
  88. #define FIXTYPE        long
  89. #endif
  90. #ifndef ITYPE
  91. #define ITYPE        long atol()
  92. #endif
  93. #ifndef ICNV
  94. #define ICNV(n)        atol(n)
  95. #endif
  96. #ifndef IFMT
  97. #define IFMT        "%ld"
  98. #endif
  99. #ifndef FLOTYPE
  100. #define FLOTYPE        double
  101. #endif
  102. #ifndef FFMT
  103. #define FFMT        "%.15g"
  104. #endif
  105. #ifndef SFIXMIN
  106. #define SFIXMIN        -1048576
  107. #define SFIXMAX        1048575
  108. #endif
  109. #ifndef INSEGMENT
  110. #define INSEGMENT(n,s)    ((n) >= &(s)->ns_data[0] \
  111.                       && (n) <  &(s)->ns_data[0] + (s)->ns_size)
  112. #endif
  113. #ifndef VCOMPARE
  114. #define VCOMPARE(f,s,t)    ((f) + (s) < (t))
  115. #endif
  116.  
  117. /* useful definitions */
  118. #define TRUE    1
  119. #define FALSE    0
  120. #ifndef NIL
  121. #define NIL    (LVAL)0
  122. #endif
  123.  
  124. /* program limits */
  125. #define STRMAX        100        /* maximum length of a string constant */
  126. #define HSIZE        199        /* symbol hash table size */
  127. #define SAMPLE        100        /* control character sample rate */
  128.  
  129. /* stack manipulation macros */
  130. #define check(n)    { if (xlsp - (n) < xlstkbase) xlstkover(); }
  131. #define cpush(v)    { if (xlsp > xlstkbase) push(v); else xlstkover(); }
  132. #define push(v)        (*--xlsp = (v))
  133. #define pop()        (*xlsp++)
  134. #define top()        (*xlsp)
  135. #define settop(v)    (*xlsp = (v))
  136. #define drop(n)        (xlsp += (n))
  137.  
  138. /* argument list parsing macros */
  139. #define xlgetarg()    (testarg(nextarg()))
  140. #define xllastarg()    {if (xlargc != 0) xltoomany();}
  141. #define xlpoprest()    {xlsp += xlargc;}
  142. #define testarg(e)    (moreargs() ? (e) : xltoofew())
  143. #define typearg(tp)    (tp(*xlsp) ? nextarg() : xlbadtype(*xlsp))
  144. #define nextarg()    (--xlargc, *xlsp++)
  145. #define moreargs()    (xlargc > 0)
  146.  
  147. /* macros to get arguments of a particular type */
  148. #define xlgacons()    (testarg(typearg(consp)))
  149. #define xlgalist()    (testarg(typearg(listp)))
  150. #define xlgasymbol()    (testarg(typearg(symbolp)))
  151. #define xlgastring()    (testarg(typearg(stringp)))
  152. #define xlgaobject()    (testarg(typearg(objectp)))
  153. #define xlgafixnum()    (testarg(typearg(fixp)))
  154. #define xlganumber()    (testarg(typearg(numberp)))
  155. #define xlgachar()    (testarg(typearg(charp)))
  156. #define xlgavector()    (testarg(typearg(vectorp)))
  157. #define xlgaport()    (testarg(typearg(portp)))
  158. #define xlgaiport()    (testarg(typearg(iportp)))
  159. #define xlgaoport()    (testarg(typearg(oportp)))
  160. #define xlgaclosure()    (testarg(typearg(closurep)))
  161. #define xlgaenv()    (testarg(typearg(envp)))
  162.  
  163. /* node types */
  164. #define FREE        0
  165. #define CONS        1
  166. #define SYMBOL        2
  167. #define FIXNUM        3
  168. #define FLONUM        4
  169. #define STRING        5
  170. #define OBJECT        6
  171. #define PORT        7
  172. #define VECTOR        8
  173. #define CLOSURE        9
  174. #define METHOD        10
  175. #define CODE        11
  176. #define SUBR        12
  177. #define XSUBR        13
  178. #define CSUBR        14
  179. #define CONTINUATION    15
  180. #define CHAR        16
  181. #define PROMISE        17
  182. #define ENV        18
  183.  
  184. /* node flags */
  185. #define MARK        1
  186. #define LEFT        2
  187.  
  188. /* port flags */
  189. #define PF_INPUT    1
  190. #define PF_OUTPUT    2
  191. #define PF_BINARY    4
  192.  
  193. /* new node access macros */
  194. #define ntype(x)    ((OFFTYPE)(x) & 1 ? FIXNUM : (x)->n_type)
  195.  
  196. /* macro to determine if a non-nil value is a pointer */
  197. #define ispointer(x)    (((OFFTYPE)(x) & 1) == 0)
  198.  
  199. /* type predicates */                   
  200. #define atom(x)        ((x) == NIL || ntype(x) != CONS)
  201. #define null(x)        ((x) == NIL)
  202. #define listp(x)    ((x) == NIL || ntype(x) == CONS)
  203. #define numberp(x)    ((x) && ntype(x) == FIXNUM || ntype(x) == FLONUM)
  204. #define boundp(x)    (getvalue(x) != s_unbound)
  205. #define iportp(x)    (portp(x) && (getpflags(x) & PF_INPUT) != 0)
  206. #define oportp(x)    (portp(x) && (getpflags(x) & PF_OUTPUT) != 0)
  207.  
  208. /* basic type predicates */                   
  209. #define consp(x)    ((x) && ntype(x) == CONS)
  210. #define stringp(x)    ((x) && ntype(x) == STRING)
  211. #define symbolp(x)    ((x) && ntype(x) == SYMBOL)
  212. #define portp(x)    ((x) && ntype(x) == PORT)
  213. #define objectp(x)    ((x) && ntype(x) == OBJECT)
  214. #define fixp(x)        ((x) && ntype(x) == FIXNUM)
  215. #define floatp(x)    ((x) && ntype(x) == FLONUM)
  216. #define vectorp(x)    ((x) && ntype(x) == VECTOR)
  217. #define closurep(x)    ((x) && ntype(x) == CLOSURE)
  218. #define codep(x)    ((x) && ntype(x) == CODE)
  219. #define methodp(x)    ((x) && ntype(x) == METHOD)
  220. #define subrp(x)    ((x) && ntype(x) == SUBR)
  221. #define xsubrp(x)    ((x) && ntype(x) == XSUBR)
  222. #define charp(x)    ((x) && ntype(x) == CHAR)
  223. #define promisep(x)    ((x) && ntype(x) == PROMISE)
  224. #define envp(x)        ((x) && ntype(x) == ENV)
  225. #define booleanp(x)    ((x) == NIL || ntype(x) == BOOLEAN)
  226.  
  227. /* cons access macros */
  228. #define car(x)        ((x)->n_car)
  229. #define cdr(x)        ((x)->n_cdr)
  230. #define rplaca(x,y)    ((x)->n_car = (y))
  231. #define rplacd(x,y)    ((x)->n_cdr = (y))
  232.  
  233. /* symbol access macros */
  234. #define getvalue(x)     ((x)->n_vdata[0])
  235. #define setvalue(x,v)     ((x)->n_vdata[0] = (v))
  236. #define getpname(x)     ((x)->n_vdata[1])
  237. #define setpname(x,v)     ((x)->n_vdata[1] = (v))
  238. #define getplist(x)     ((x)->n_vdata[2])
  239. #define setplist(x,v)     ((x)->n_vdata[2] = (v))
  240. #define SYMSIZE        3
  241.  
  242. /* vector access macros */
  243. #define getsize(x)    ((x)->n_vsize)
  244. #define getelement(x,i)    ((x)->n_vdata[i])
  245. #define setelement(x,i,v) ((x)->n_vdata[i] = (v))
  246.  
  247. /* object access macros */
  248. #define getclass(x)    ((x)->n_vdata[1])
  249. #define setclass(x,v)    ((x)->n_vdata[1] = (v))
  250. #define getivar(x,i)    ((x)->n_vdata[i])
  251. #define setivar(x,i,v)    ((x)->n_vdata[i] = (v))
  252.  
  253. /* promise access macros */
  254. #define getpproc(x)    ((x)->n_car)
  255. #define setpproc(x,v)    ((x)->n_car = (v))
  256. #define getpvalue(x)    ((x)->n_cdr)
  257. #define setpvalue(x,v)    ((x)->n_cdr = (v))
  258.  
  259. /* closure access macros */
  260. #define getcode(x)    ((x)->n_car)
  261. #define getenv(x)    ((x)->n_cdr)
  262.  
  263. /* code access macros */
  264. #define getbcode(x)        ((x)->n_vdata[0])
  265. #define setbcode(x,v)        ((x)->n_vdata[0] = (v))
  266. #define getcname(x)        ((x)->n_vdata[1])
  267. #define setcname(x,v)        ((x)->n_vdata[1] = (v))
  268. #define getvnames(x)        ((x)->n_vdata[2])
  269. #define setvnames(x,v)        ((x)->n_vdata[2] = (v))
  270. #define FIRSTLIT        3
  271.  
  272. /* fixnum/flonum/character access macros */
  273. #define getfixnum(x)    ((OFFTYPE)(x) & 1 ? getsfixnum(x) : (x)->n_int)
  274. #define getflonum(x)    ((x)->n_flonum)
  275. #define getchcode(x)    ((x)->n_chcode)
  276.  
  277. /* small fixnum access macros */
  278. #define cvsfixnum(x)    ((LVAL)(((OFFTYPE)x << 1) | 1))
  279. #define getsfixnum(x)    ((FIXTYPE)((OFFTYPE)(x) >> 1))
  280.  
  281. /* string access macros */
  282. #define getstring(x)    ((unsigned char *)(x)->n_vdata)
  283. #define getslength(x)    ((x)->n_vsize)
  284.  
  285. /* iport/oport access macros */
  286. #define getfile(x)    ((x)->n_fp)
  287. #define setfile(x,v)    ((x)->n_fp = (v))
  288. #define getsavech(x)    ((x)->n_savech)
  289. #define setsavech(x,v)    ((x)->n_savech = (v))
  290. #define getpflags(x)    ((x)->n_pflags)
  291. #define setpflags(x,v)    ((x)->n_pflags = (v))
  292.  
  293. /* subr access macros */
  294. #define getsubr(x)    ((x)->n_subr)
  295. #define getoffset(x)    ((x)->n_offset)
  296.  
  297. /* list node */
  298. #define n_car        n_info.n_xlist.xl_car
  299. #define n_cdr        n_info.n_xlist.xl_cdr
  300.  
  301. /* integer node */
  302. #define n_int        n_info.n_xint.xi_int
  303.  
  304. /* flonum node */
  305. #define n_flonum    n_info.n_xflonum.xf_flonum
  306.  
  307. /* character node */
  308. #define n_chcode    n_info.n_xchar.xc_chcode
  309.  
  310. /* string node */
  311. #define n_str        n_info.n_xstr.xst_str
  312. #define n_strlen    n_info.n_xstr.xst_length
  313.  
  314. /* file pointer node */
  315. #define n_fp        n_info.n_xfptr.xf_fp
  316. #define n_savech    n_info.n_xfptr.xf_savech
  317. #define n_pflags    n_info.n_xfptr.xf_pflags
  318.  
  319. /* vector/object node */
  320. #define n_vsize        n_info.n_xvect.xv_size
  321. #define n_vdata        n_info.n_xvect.xv_data
  322.  
  323. /* subr node */
  324. #define n_subr        n_info.n_xsubr.xs_subr
  325. #define n_offset    n_info.n_xsubr.xs_offset
  326.  
  327. /* node structure */
  328. typedef struct node {
  329.     char n_type;        /* type of node */
  330.     char n_flags;        /* flag bits */
  331.     union ninfo {         /* value */
  332.     struct xlist {        /* list node (cons) */
  333.         struct node *xl_car;    /* the car pointer */
  334.         struct node *xl_cdr;    /* the cdr pointer */
  335.     } n_xlist;
  336.     struct xint {        /* integer node */
  337.         FIXTYPE xi_int;        /* integer value */
  338.     } n_xint;
  339.     struct xflonum {    /* flonum node */
  340.         FLOTYPE xf_flonum;        /* flonum value */
  341.     } n_xflonum;
  342.     struct xchar {        /* character node */
  343.         int xc_chcode;        /* character code */
  344.     } n_xchar;
  345.     struct xstr {        /* string node */
  346.         int xst_length;        /* string length */
  347.         unsigned char *xst_str;    /* string pointer */
  348.     } n_xstr;
  349.     struct xfptr {        /* file pointer node */
  350.         FILE *xf_fp;        /* the file pointer */
  351.         short xf_savech;        /* lookahead character for input files */
  352.         short xf_pflags;        /* port flags */
  353.     } n_xfptr;
  354.     struct xvect {        /* vector node */
  355.         int xv_size;        /* vector size */
  356.         struct node **xv_data;    /* vector data */
  357.     } n_xvect;
  358.     struct xsubr {        /* subr/fsubr node */
  359.         struct node *(*xs_subr)();    /* function pointer */
  360.         int xs_offset;        /* offset into funtab */
  361.     } n_xsubr;
  362.     } n_info;
  363. } NODE,*LVAL;
  364.  
  365. /* memory allocator definitions */
  366.  
  367. /* macros to compute the size of a segment */
  368. #define nsegsize(n) (sizeof(NSEGMENT)+((n)-1)*sizeof(struct node))
  369. #define vsegsize(n) (sizeof(VSEGMENT)+((n)-1)*sizeof(LVAL))
  370.  
  371. /* macro to convert a byte size to a word size */
  372. #define btow_size(n)    (((n) + sizeof(LVAL) - 1) / sizeof(LVAL))
  373.  
  374. /* node segment structure */
  375. typedef struct nsegment {
  376.     struct nsegment *ns_next;    /* next node segment */
  377.     unsigned int ns_size;    /* number of nodes in this segment */
  378.     struct node ns_data[1];    /* segment data */
  379. } NSEGMENT;
  380.  
  381. /* vector segment structure */
  382. typedef struct vsegment {
  383.     struct vsegment *vs_next;    /* next vector segment */
  384.     LVAL *vs_free;        /* next free location in this segment */
  385.     LVAL *vs_top;        /* top of segment (plus one) */
  386.     LVAL vs_data[1];        /* segment data */
  387. } VSEGMENT;
  388.  
  389. /* function definition structure */
  390. typedef struct {
  391.     char *fd_name;    /* function name */
  392.     LVAL (*fd_subr)();    /* function entry point */
  393. } FUNDEF;
  394.  
  395. /* external variables */
  396. extern LVAL *xlstkbase;     /* base of value stack */
  397. extern LVAL *xlstktop;        /* top of value stack */
  398. extern LVAL *xlsp;            /* value stack pointer */
  399. extern int xlargc;        /* argument count for current call */
  400.  
  401. /* external routine declarations */
  402. extern LVAL cons();        /* (cons x y) */
  403. extern LVAL xlenter();        /* enter a symbol */
  404. extern LVAL xlgetprop();    /* get the value of a property */
  405. extern LVAL cvsymbol();     /* convert a string to a symbol */
  406. extern LVAL cvstring();     /* convert a string */
  407. extern LVAL cvfixnum();     /* convert a fixnum */
  408. extern LVAL cvflonum();           /* convert a flonum */
  409. extern LVAL cvchar();         /* convert a character */
  410. extern LVAL cvclosure();    /* convert code and an env to a closure */
  411. extern LVAL cvmethod();        /* convert code and an env to a method */
  412. extern LVAL cvsubr();        /* convert a function into a subr */
  413. extern LVAL cvport();        /* convert a file pointer to an input port */
  414. extern LVAL cvpromise();    /* convert a procedure to a promise */
  415. extern LVAL newstring();    /* create a new string */
  416. extern LVAL newobject();    /* create a new object */
  417. extern LVAL newvector();    /* create a new vector */
  418. extern LVAL newcode();        /* create a new code object */
  419. extern LVAL newcontinuation();    /* create a new continuation object */
  420. extern LVAL newframe();        /* create a new environment frame */
  421. extern LVAL newnode();        /* create a new node */
  422. extern LVAL xltoofew();        /* report "too few arguments" */
  423. extern LVAL xlbadtype();    /* report "wrong argument type" */
  424. extern LVAL curinput();        /* get the current input port */
  425. extern LVAL curoutput();    /* get the current output port */
  426.