home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / gofer230.zip / Progs / Gofer / Lib / gofc.h < prev    next >
C/C++ Source or Header  |  1994-06-23  |  11KB  |  339 lines
  1. /* --------------------------------------------------------------------------
  2.  * gofc.h:      Copyright (c) Mark P Jones 1991-1994.   All rights reserved.
  3.  *              See goferite.h for details and conditions of use etc...
  4.  *        Gofer Compiler version 1.00 February 1992
  5.  *              Gofer version 2.30 March 1994
  6.  *
  7.  * Header file for Gofer Compiler runtime system.
  8.  * ------------------------------------------------------------------------*/
  9.  
  10. #include "prelude.h"
  11.  
  12. /*- Garbage collected heap ------------------------------------------------*/
  13.  
  14. #define GC_MARKSCAN    0            /* for mark/scan collector */
  15. #define GC_TWOSPACE    1            /* for twospace collector  */
  16.  
  17. typedef Int        Cell;            /* general cell value       */
  18. typedef Cell far    *Heap;            /* storage of heap       */
  19. extern  Int        heapSize;        /* Pairs are stored in the */
  20. extern  Void        garbageCollect Args((Void));
  21.  
  22. #if HASKELL_ARRAYS
  23. extern  Void        allocArray Args((Int,Cell,Cell));
  24. extern  Void        dupArray   Args((Cell));
  25. #endif
  26.  
  27. /*- Mark-scan collector ---------------------------------------------------*/
  28.  
  29. #if      GC_MARKSCAN
  30. #ifdef   GLOBALfst
  31. register Heap heapTopFst GLOBALfst;        /* Cells with -ve indices  */
  32. #else
  33. extern   Heap heapTopFst;
  34. #endif
  35. #ifdef   GLOBALsnd
  36. register Heap heapTopSnd GLOBALsnd;
  37. #else
  38. extern   Heap heapTopSnd;
  39. #endif
  40. #define fst(c)        heapTopFst[c]
  41. #define snd(c)        heapTopSnd[c]
  42. #define isPair(c)    ((c)<0)
  43. extern  Cell        pair    Args((Cell,Cell));
  44.  
  45. #if HASKELL_ARRAYS
  46. typedef Cell ArrEltPtr;
  47. #define arrElt(pa)          fst(pa)
  48. #define nextElt(pa)         (pa=snd(pa))
  49. #define arrBnds(arr)        fst(snd(arr))
  50. #define setEltPtr(pa,arr,i) {    Int j = i;                   \
  51.                 for (pa=snd(snd(arr)); j>0; --j)       \
  52.                     nextElt(pa);               \
  53.                 }
  54. #define arrMap(p,arr)       {   ArrEltPtr pa = snd(snd(arr));           \
  55.                                 while (isPair(pa)) { p(pa); nextElt(pa); } \
  56.                             }
  57. #endif
  58. #endif
  59.  
  60. /*- Two-space collector ---------------------------------------------------*/
  61.  
  62. #if    GC_TWOSPACE
  63. #ifdef  GLOBALfst
  64. register Heap        from GLOBALfst;
  65. #else
  66. extern  Heap        from;            /* top of from space       */
  67. #endif
  68. #ifdef  GLOBALsnd
  69. register Cell        hp GLOBALsnd;
  70. #else
  71. extern  Cell        hp;            /* last used heap loc       */
  72. #endif
  73. #define fst(c)        from[c]
  74. #define snd(c)        from[(c)+1]
  75. #define isPair(c)    ((c)<0)
  76. #define INLINE_ALLOC    0            /* 1 => allocate inline       */
  77. #if     INLINE_ALLOC
  78. #define pair(l,r)    ((from[++hp]=(l)), (from[++hp]=(r)), (hp-1))
  79. #else
  80. extern  Cell        pair    Args((Cell,Cell));
  81. #endif
  82.  
  83. #if HASKELL_ARRAYS
  84. typedef Cell ArrEltPtr;
  85. #define arrElt(pa)        from[pa]
  86. #define nextElt(pa)        (++pa)
  87. #define arrBnds(arr)        from[arr+2]
  88. #define setEltPtr(pa,arr,i) pa=(arr+i+3)
  89. #define arrMap(p,arr)        {    Int len = from[arr+1]-1;           \
  90.                 ArrEltPtr pa = arr+3;               \
  91.                 while (0<len--) { p(pa); nextElt(pa); }       \
  92.                 }
  93. #endif
  94. #endif
  95.  
  96. /*- Tags for fst() element in particular kinds of Pair ------------------- */
  97.  
  98. #define INDIRECT    0            /* Indirection           */
  99. #define INDIRECT1    1            /* Second form used in gc  */
  100. #define FORWARD        2            /* Forwarding pointer       */
  101. #define INTCELL         3            /* (Big) Integer       */
  102. #define STRCELL        4            /* Character String       */
  103. #define SUPERCOMB    5            /* Supercombinator       */
  104. #define FILECELL    6            /* File value           */
  105. #define FLOATCELL    7            /* Floating point       */
  106. #define ARRAY        8            /* Array           */
  107. #define MUTVAR        9            /* Mutable variable       */
  108. #if BREAK_FLOATS
  109. #define MAXBOXTAG       FILECELL        /* Last boxed cell tag       */
  110. extern  Cell        safeMkFloat    Args((FloatPro));
  111. #else
  112. #define MAXBOXTAG    FLOATCELL        /* Last boxed cell tag       */
  113. #define safeMkFloat(n)    mkFloat((FloatPro)n)
  114. #endif
  115. #define MAXTAG        MUTVAR            /* Last tag value       */
  116.  
  117. #define mkBig(n)    pair(INTCELL,n)
  118. #define bigOf(c)    ((Int)(snd(c)))
  119.  
  120. typedef FloatImpType    Float;
  121. extern  Cell        mkFloat        Args((FloatPro));
  122. extern    FloatPro    floatOf        Args((Cell));
  123. extern    String        floatToString    Args((FloatPro));
  124. extern  FloatPro    stringToFloat    Args((String));
  125.  
  126. #define mkString(s)    pair(STRCELL,(Int)(s))
  127. #define stringOf(c)    ((String)(snd(c)))
  128.  
  129. #define mkSuper(sc)    pair(SUPERCOMB,(Int)(sc))
  130. #define superOf(c)      ((Super *)(snd(c)))
  131.  
  132. /*- Cells>MAXTAG represent small integers, characters, dictionaries and -- */
  133. /*- constructor functions -- we don't have to worry which since these ---- */
  134. /*- routines will only be used with well-typed source programs ----------- */
  135.  
  136. #define SMALLMIN    (MAXTAG+2)
  137. #define SMALLMAX        MAXPOSINT
  138. #define SMALLZERO       (SMALLMIN/2 + SMALLMAX/2)
  139. #define isSmall(c)      (SMALLMIN<=(c))
  140. #define mkSmall(n)      (SMALLZERO+(n))
  141. #define smallOf(c)      ((Int)(c-SMALLZERO))
  142.  
  143. #define mkInt(n)    (isSmall(mkSmall(n)) ? mkSmall(n) : mkBig(n))
  144. #define intOf(c)    (isSmall(c) ? smallOf(c) : bigOf(c))
  145.  
  146. #define mkChar(c)    ((Cell)(SMALLMIN+((unsigned)((c)%NUM_CHARS))))
  147. #define charOf(c)       ((Char)((c)-SMALLMIN))
  148.  
  149. #define mkDict(n)    ((Cell)(SMALLMIN+(n)))
  150. #define dictOf(c)       ((Int)((c)-SMALLMIN))
  151.  
  152. #define mkCfun(n)    ((Cell)(SMALLMIN+(n)))
  153. #define cfunOf(c)    ((Int)((c)-SMALLMIN))
  154. #define FAIL        mkCfun(-1)        /* Every type has a Fail   */
  155.  
  156. /*- Control stack implementation ------------------------------------------*/
  157.  
  158. typedef Cell        *StackPtr;         /* stack pointer       */
  159. extern    Cell        cellStack[];
  160. #ifdef  GLOBALsp
  161. register StackPtr    sp GLOBALsp;
  162. #else
  163. extern    StackPtr    sp;
  164. #endif
  165. #define clearStack()    sp=cellStack+NUM_STACK
  166. #define stackLoop(i)    for (i=cellStack+NUM_STACK-1; i>=sp; i--)
  167. #define push(c)          if (sp>cellStack) *--sp=(c); else overflow()
  168. #define    onto(c)        *--sp=(c)        /* fast form of push()       */
  169. #define pop()        *sp++
  170. #define drop()        sp++
  171. #define top()        *sp
  172. #define pushed(n)    sp[n]
  173. #define pushedSince(p)    ((Int)((p)-sp))
  174. #define offset(n)    root[-(n)]
  175.  
  176. /*- references to body of compiled code -----------------------------------*/
  177.  
  178. #define ARGCHECK 0        /* set to 1 for no. of argument checking   */
  179. extern  int argcheck;        /* check for consistency between main       */
  180.                 /* program and runtime library           */
  181.  
  182. extern  int        num_scs;        /* supercombinators       */
  183. extern  Cell        sc[];
  184. #if    ARGCHECK
  185. typedef Void        Super Args((StackPtr));
  186. #else
  187. typedef Void        Super Args((Void));
  188. #endif
  189. extern  Super        *scNames[];
  190.  
  191. extern  int        num_dicts;        /* dictionaries           */
  192. extern  Cell        dict[];
  193. extern  int        dictImps[];
  194. #define dsel(n,d)    dict[dictOf(d)+n]
  195.  
  196. /*-Super combinator skeleton definition -------------------------------------
  197.  * the following macros are used to construct the heading for a super-
  198.  * combinator definition.  The combn() family of macros is used for the
  199.  * benefit of compilers which do not automatically unroll small loops.
  200.  * combinators with >9 args are headed using the comb macro, and a loop is
  201.  * always used ... at least in the C code.  Adjust according to taste!
  202.  * ------------------------------------------------------------------------*/
  203.  
  204. #if     ARGCHECK
  205. #define defSc(nm,args)    Void nm(root)                       \
  206.             register StackPtr root; {               \
  207.                 if (root-sp<=args)                   \
  208.                 insufficientArgs();               \
  209.                 root=sp;
  210. #else
  211. #define defSc(nm,args)    Void nm() {                       \
  212.                 register StackPtr root=sp;
  213. #endif
  214. #define Arg        *root = snd(*(root+1)); root++;
  215. #define needStack(n)    if (sp-cellStack<n) overflow()
  216. #define End        }
  217.  
  218. #define comb(nm,n)    defSc(nm,n) {int i=n; do {Arg} while (--i>0);}
  219. #define comb0(nm)    defSc(nm,0)
  220. #define comb1(nm)    defSc(nm,1) Arg
  221. #define comb2(nm)    defSc(nm,2) Arg Arg
  222. #define comb3(nm)    defSc(nm,3) Arg Arg Arg
  223. #define comb4(nm)    defSc(nm,4) Arg Arg Arg Arg
  224. #define comb5(nm)    defSc(nm,5) Arg Arg Arg Arg Arg
  225. #define comb6(nm)    comb(nm,6)
  226. #define comb7(nm)    comb(nm,7)
  227. #define comb8(nm)    comb(nm,8)
  228. #define comb9(nm)    comb(nm,9)
  229.  
  230. /*- macros for simple steps in compiled code -------------------------------*/
  231.  
  232. extern  Cell whnf;        /* head of term in weak head normal form    */
  233. extern  Int  whnfInt;        /* integer value for term in whnf        */
  234.  
  235. #define pushInt(n)        onto(mkInt(n))
  236. #define pushFloat(f)        onto(safeMkFloat(f))
  237. #define pushStr(s)        onto(mkString(s))
  238. #define mkap()            sp[1]=pair(*sp,sp[1]); sp++
  239. #define toparg(e)        *sp=pair(*sp,e)
  240. #define topfun(e)        *sp=pair(e,*sp)
  241. #define pushpair(l,r)        onto(pair(l,r))
  242. #define updap(o,l,r)        snd(root[-o])=r; fst(root[-o])=l
  243. #define update(o,c)        updap(o,INDIRECT,c)
  244. #define updap2(o)        updap(o,*sp,sp[1]); sp+=2
  245. #define alloc()            pushpair(0,0)
  246. #define slide(n,e)        pushed(n)=e; sp+=n
  247. #define setstk(n)        sp=root-n
  248. #define test(c)            if (whnf!=c)
  249. #define inteq(n)        if (whnfInt!=n)
  250. #define intge(h,n)        if (whnfInt>=n) {               \
  251.                     heap(h);                   \
  252.                     onto(mkInt(whnfInt-n));           \
  253.                 } else
  254. #define intdv(h,n)        if (whnfInt>=0 && (whnfInt%n==0)) {       \
  255.                     heap(h);                   \
  256.                     onto(mkInt(whnfInt/n));           \
  257.                 } else
  258. #define ret()            sp=root; return
  259.  
  260. /* N.B.  values in heap() calls are possibly overestimates of storage use
  261.  * if INTCELL or FLOATCELL (with BREAK_FLOATS) values are ever allocated.
  262.  * If you change the basic allocators used here so that the exact figure
  263.  * is required, it will probably be best to make sure that an INTCELL is
  264.  * _always_ heap allocated (including the two INTCELLs that make up a
  265.  * BREAK_FLOATS FLOATCELL).  The alternative is to arrange that any unfilled
  266.  * cells are filled in with blanks of an appropriate form.
  267.  */
  268. #if GC_MARKSCAN
  269. #define heap(n)            /*do nothing*/
  270. #endif
  271. #if GC_TWOSPACE
  272. #define heap(n)            if (hp+(2*n)>=0) garbageCollect()
  273. #endif
  274.  
  275. /*- builtin primitive functions -------------------------------------------*/
  276.  
  277. extern Cell primFatbar,     primFail;    /* System (internal) primitives       */
  278. extern Cell primUndefMem,   primBlackHole;
  279. extern Cell primSel,        primIf;
  280. extern Cell primStrict;
  281.  
  282. extern Cell primPlusInt,    primMinusInt;/* User (general) primitives       */
  283. extern Cell primMulInt,     primDivInt;
  284. extern Cell primModInt,     primRemInt;
  285. extern Cell primNegInt,        primQuotInt;
  286. extern Cell primCharToInt,  primIntToChar;
  287. extern Cell primIntToFloat;
  288. extern Cell primPlusFloat,  primMinusFloat;
  289. extern Cell primMulFloat,   primDivFloat;
  290. extern Cell primNegFloat;
  291. extern Cell primEqInt,        primLeInt;
  292. extern Cell primEqChar,     primLeChar;
  293. extern Cell primEqFloat,    primLeFloat;
  294. extern Cell primGenericEq,  primGenericNe;
  295. extern Cell primGenericGt,  primGenericGe;
  296. extern Cell primGenericLt,  primGenericLe;
  297. extern Cell primShowsInt,   primShowsFloat;
  298. extern Cell primError;
  299. extern Cell primFopen;
  300.  
  301. #if  IO_MONAD
  302. extern Cell primSTRun,        primSTReturn;/* IO and ST monad primitives       */
  303. extern Cell primIOBind,     primSTBind;
  304. extern Cell primSTNew,        primSTAssign;
  305. extern Cell primSTDeref,    primSTMutVarEq;
  306. extern Cell primIOGetch,    primIOPutchar;
  307. #endif
  308.  
  309. #if  HAS_FLOATS
  310. extern Cell primSinFloat,   primAsinFloat;
  311. extern Cell primCosFloat,   primAcosFloat;
  312. extern Cell primTanFloat,   primAtanFloat;
  313. extern Cell primAtan2Float, primExpFloat;
  314. extern Cell primLogFloat,   primLog10Float;
  315. extern Cell primSqrtFloat,  primFloatToInt;
  316. #endif
  317.  
  318. /*- runtime support functions and variables -------------------------------*/
  319.  
  320. typedef Void (*TopLevel)        Args((Cell));
  321. extern  TopLevel topLevel;
  322. #if IO_DIALOGUE
  323. extern  Void dialogue        Args((Cell));
  324. #endif
  325. #if IO_MONAD
  326. extern  Void iomonad        Args((Cell));
  327. #endif
  328.  
  329. extern Void eval        Args((Cell));
  330. extern Void overflow        Args((Void));
  331. extern Void insufficientArgs    Args((Void));
  332. extern Void fail        Args((Void));
  333. extern Cell rootFst        Args((Cell));
  334. extern Int  readTerminalChar    Args((Void));
  335. extern Void noechoTerminal    Args((Void));
  336. extern Void normalTerminal    Args((Void));
  337.  
  338. /* ----------------------------------------------------------------------- */
  339.