home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / hugs101.zip / hugs101sc.zip / hugsdist / src / builtin.c < prev    next >
C/C++ Source or Header  |  1995-03-02  |  74KB  |  2,474 lines
  1. /* --------------------------------------------------------------------------
  2.  * builtin.c:   Copyright (c) Mark P Jones 1991-1994.   All rights reserved.
  3.  *              See NOTICE for details and conditions of use etc...
  4.  *              Hugs version 1.0 August 1994, derived from Gofer 2.30a
  5.  *
  6.  * Primitive functions, input output etc...
  7.  * ------------------------------------------------------------------------*/
  8.  
  9. #include "prelude.h"
  10. #include "storage.h"
  11. #include "connect.h"
  12. #include "errors.h"
  13. #include <ctype.h>
  14. #include <math.h>
  15. #include <float.h>
  16. #if (BCC | BCC32)
  17. #include <io.h>
  18. #endif
  19.  
  20. Name nameFatbar,  nameFail;        /* primitives reqd for translation */
  21. Name nameIf,      nameSel;
  22. Name namePmInt,   namePmFlt;        /* primitives for pattern matching */
  23. Name namePmInteger;
  24. #if NPLUSK
  25. Name namePmNpk,   namePmSub;        /* primitives for (n+k) patterns   */
  26. #endif
  27. Name nameConCmp,  nameEnRange;        /* primitives used for deriv inst  */
  28. Name nameEnIndex, nameEnInRng;
  29. Name nameEnFrom,  nameEnFrTh;
  30. Name nameEnFrTo;
  31.  
  32. Name nameUndefMem;            /* undefined member primitive       */
  33. Name nameMakeMem;            /* makeMember primitive           */
  34. Name nameBlackHole;            /* for GC-detected black hole       */
  35. Name nameAnd,     nameOr;        /* built-in logical connectives       */
  36. Name nameOtherwise;            /* another name for True       */
  37. Name nameError;                /* error primitive function       */
  38. Name nameComp;                /* function composition           */
  39. Name nameApp;                /* list append               */
  40. Name nameShowParen;            /* wrap with parens           */
  41. Name nameRangeSize;            /* calculate size of index range   */
  42.  
  43. Name namePrint,  nameNPrint;        /* primitives for printing       */
  44.  
  45. #if    HASKELL_ARRAYS
  46. static Name nameEltUndef;        /* undefined element in array       */
  47. static Name nameOutBounds;        /* value of of bounds           */
  48. #endif
  49. #if    IO_MONAD
  50. Name   nameSTRun;            /* encapsulation operator for IO   */
  51. static Name nameFst;            /* fst primitive           */
  52. static Name nameSnd;            /* snd primitive           */
  53. #endif
  54.  
  55. /* --------------------------------------------------------------------------
  56.  * Local function prototypes:
  57.  * ------------------------------------------------------------------------*/
  58.  
  59. #define PROTO_PRIM(name)    static Void name Args((StackPtr))
  60. #define primFun(name)        static Void name(root) StackPtr root;
  61. #define primArg(n)        stack(root+n)
  62.  
  63. /* IMPORTANT: the second element of an update must be written first.
  64.  * this is to deal with the case where an INDIRECT tag is written into
  65.  * a Cell before the second value has been set.  If a garbage collection
  66.  * occurs before the second element was set then the INDIRECTion will be
  67.  * (wrongly) elided and result in chaos.  I know.  It happened to me.
  68.  */
  69.  
  70. #define update(l,r)        ((snd(stack(root))=r),(fst(stack(root))=l))
  71. #define updateRoot(c)        update(INDIRECT,c)
  72. #define updapRoot(l,r)        update(l,r)
  73. #define cantReduce()        evalFails(root)
  74.  
  75. PROTO_PRIM(primFatbar);
  76. PROTO_PRIM(primFail);
  77. PROTO_PRIM(primSel);
  78. PROTO_PRIM(primIf);
  79. PROTO_PRIM(primStrict);
  80. PROTO_PRIM(primTrace);
  81. PROTO_PRIM(primMakeMem);
  82. PROTO_PRIM(primConCmp);
  83. PROTO_PRIM(primEnRange);
  84. PROTO_PRIM(primEnIndex);
  85. PROTO_PRIM(primEnInRng);
  86. PROTO_PRIM(primEnFrom);
  87. PROTO_PRIM(primEnFrTh);
  88. PROTO_PRIM(primEnFrTo);
  89.  
  90.  
  91. #if    HASKELL_ARRAYS
  92. static Int  local getSize    Args((Cell, Cell));
  93. static List local addAssocs    Args((Cell, Int, Cell, List));
  94. static List local foldAssocs    Args((Cell, Int, Cell, Cell, List));
  95.  
  96. PROTO_PRIM(primArray);
  97. PROTO_PRIM(primUpdate);
  98. PROTO_PRIM(primAccum);
  99. PROTO_PRIM(primAccumArray);
  100. PROTO_PRIM(primAmap);
  101. PROTO_PRIM(primSubscript);
  102. PROTO_PRIM(primBounds);
  103. PROTO_PRIM(primElems);
  104. #endif
  105.  
  106. PROTO_PRIM(primMinInt);
  107. PROTO_PRIM(primMaxInt);
  108. PROTO_PRIM(primPlusInt);
  109. PROTO_PRIM(primMinusInt);
  110. PROTO_PRIM(primMulInt);
  111. PROTO_PRIM(primDivInt);
  112. PROTO_PRIM(primQuotInt);
  113. PROTO_PRIM(primModInt);
  114. PROTO_PRIM(primRemInt);
  115. PROTO_PRIM(primQrmInt);
  116. PROTO_PRIM(primNegInt);
  117. PROTO_PRIM(primEvenInt);
  118.  
  119. #if BIGNUMS
  120. PROTO_PRIM(primPlusInteger);
  121. PROTO_PRIM(primMinusInteger);
  122. PROTO_PRIM(primMulInteger);
  123. PROTO_PRIM(primQrmInteger);
  124. PROTO_PRIM(primNegInteger);
  125. PROTO_PRIM(primEvenInteger);
  126. PROTO_PRIM(primIntToInteger);
  127. PROTO_PRIM(primIntegerToInt);
  128. PROTO_PRIM(primIntegerToFloat);
  129. PROTO_PRIM(primEqInteger);
  130. PROTO_PRIM(primCmpInteger);
  131. #endif
  132.  
  133. PROTO_PRIM(primCharToInt);
  134. PROTO_PRIM(primIntToChar);
  135. PROTO_PRIM(primIntToFloat);
  136. PROTO_PRIM(primDummyCvt);
  137.  
  138. PROTO_PRIM(primPlusFloat);
  139. PROTO_PRIM(primMinusFloat);
  140. PROTO_PRIM(primMulFloat);
  141. PROTO_PRIM(primDivFloat);
  142. PROTO_PRIM(primNegFloat);
  143.  
  144. #if HAS_FLOATS
  145. PROTO_PRIM(primPiFloat);
  146. PROTO_PRIM(primSinFloat);
  147. PROTO_PRIM(primCosFloat);
  148. PROTO_PRIM(primTanFloat);
  149. PROTO_PRIM(primAsinFloat);
  150. PROTO_PRIM(primAcosFloat);
  151. PROTO_PRIM(primAtanFloat);
  152. PROTO_PRIM(primAtan2Float);
  153. PROTO_PRIM(primExpFloat);
  154. PROTO_PRIM(primLogFloat);
  155. PROTO_PRIM(primLog10Float);
  156. PROTO_PRIM(primSqrtFloat);
  157. PROTO_PRIM(primFloatToInt);
  158. PROTO_PRIM(primFloatRadix);
  159. PROTO_PRIM(primFloatDigits);
  160. PROTO_PRIM(primFloatRange);
  161. PROTO_PRIM(primFloatDecode);
  162. PROTO_PRIM(primFloatEncode);
  163. #endif
  164.  
  165. PROTO_PRIM(primEqInt);
  166. PROTO_PRIM(primCmpInt);
  167.  
  168. PROTO_PRIM(primEqChar);
  169. PROTO_PRIM(primLeChar);
  170.  
  171. PROTO_PRIM(primEqFloat);
  172. PROTO_PRIM(primLeFloat);
  173.  
  174. #if GENERIC_CMP
  175. PROTO_PRIM(primCmp);
  176. PROTO_PRIM(primGenericEq);
  177. PROTO_PRIM(primGenericLe);
  178. PROTO_PRIM(primGenericLt);
  179. PROTO_PRIM(primGenericGe);
  180. PROTO_PRIM(primGenericGt);
  181. PROTO_PRIM(primGenericNe);
  182. #endif
  183.  
  184. PROTO_PRIM(primPrint);
  185. PROTO_PRIM(primNPrint);
  186.  
  187. static Void   local printer        Args((StackPtr,Name,Int,Cell));
  188. static Void   local startList        Args((StackPtr,Cell));
  189. static Void   local startNList        Args((StackPtr,Cell));
  190.  
  191. PROTO_PRIM(primLPrint);
  192. PROTO_PRIM(primNLPrint);
  193. PROTO_PRIM(primSPrint);
  194. PROTO_PRIM(primNSPrint);
  195.  
  196. static Cell   local textAsVar        Args((Text,Cell));
  197. static Cell   local textAsOp        Args((Text,Cell));
  198. static Cell   local stringOutput    Args((String,Cell));
  199. static Cell   local printBadRedex    Args((Cell,Cell));
  200. static Cell   local printDBadRedex    Args((Cell,Cell));
  201. static Cell   local outputInst        Args((Inst,List));
  202.  
  203. #if IO_DIALOGUE
  204. static String local evalName        Args((Cell));
  205. #endif
  206. #if IO_DIALOGUE
  207. static Void   local abandonDialogue    Args((Cell));
  208. static Cell   local readFile        Args((Void));
  209. static Cell   local writeFile        Args((Void));
  210. static Cell   local appendFile        Args((Void));
  211. static Cell   local readChan        Args((Void));
  212. static Cell   local appendChan        Args((Void));
  213. static FILE  *local validOutChannel    Args((String));
  214. static Cell   local echo        Args((Void));
  215. static Cell   local getCLArgs        Args((Void));
  216. static Cell   local getProgName        Args((Void));
  217. static Cell   local getEnv        Args((Void));
  218. static Cell   local outputDString    Args((FILE *));
  219.  
  220. PROTO_PRIM(primInput);
  221. PROTO_PRIM(primFopen);
  222. #endif
  223.  
  224. #if IO_MONAD
  225. PROTO_PRIM(primSTRun);
  226. PROTO_PRIM(primFst);
  227. PROTO_PRIM(primSnd);
  228. PROTO_PRIM(primSTReturn);
  229. PROTO_PRIM(primIOBind);
  230. PROTO_PRIM(primSTBind);
  231. PROTO_PRIM(primSTInter);
  232. PROTO_PRIM(primSTNew);
  233. PROTO_PRIM(primSTAssign);
  234. PROTO_PRIM(primSTDeref);
  235. PROTO_PRIM(primSTMutVarEq);
  236. PROTO_PRIM(primIOGetch);
  237. PROTO_PRIM(primIOPutchar);
  238. #if HASKELL_ARRAYS
  239. PROTO_PRIM(primSTNewArr);
  240. PROTO_PRIM(primSTReadArr);
  241. PROTO_PRIM(primSTWriteArr);
  242. PROTO_PRIM(primSTFreeze);
  243. #endif
  244. #endif
  245.  
  246. /* --------------------------------------------------------------------------
  247.  * Table of primitive/built-in values:
  248.  * ------------------------------------------------------------------------*/
  249.  
  250. struct primitive primitives[] = {
  251.   {"primFatbar",    2, primFatbar},
  252.   {"primFail",        0, primFail},
  253.   {"primUndefMem",    1, primFail},
  254.   {"primGCBhole",    0, primFail},
  255.   {"primError",        1, primFail},
  256.   {"primSel",        3, primSel},
  257.   {"primIf",        3, primIf},
  258.   {"primTrace",        2, primTrace},
  259.   {"primMakeMem",    2, primMakeMem},
  260.   {"primConCmp",    3, primConCmp},
  261.   {"primEnRange",    1, primEnRange},
  262.   {"primEnIndex",    2, primEnIndex},
  263.   {"primEnInRng",    2, primEnInRng},
  264.   {"primEnFrom",    1, primEnFrom},
  265.   {"primEnFrTh",    2, primEnFrTh},
  266.   {"primEnFrTo",    2, primEnFrTo},
  267.  
  268. #if    HASKELL_ARRAYS
  269.   {"primArray",        3, primArray},
  270.   {"primUpdate",    3, primUpdate},
  271.   {"primAccum",        4, primAccum},
  272.   {"primAccumArray",    5, primAccumArray},
  273.   {"primAmap",        2, primAmap},
  274.   {"primSubscript",    3, primSubscript},
  275.   {"primBounds",    1, primBounds},
  276.   {"primElems",        1, primElems},
  277.   {"primEltUndef",    0, primFail},
  278.   {"primOutBounds",    2, primFail},
  279. #endif
  280.  
  281.   {"primPrint",        3, primPrint},
  282.   {"primNprint",    3, primNPrint},
  283.   {"primLprint",    2, primLPrint},
  284.   {"primNlprint",    2, primNLPrint},
  285.   {"primSprint",    2, primSPrint},
  286.   {"primNsprint",    2, primNSPrint},
  287.  
  288.   {"primMinInt",    0, primMinInt},
  289.   {"primMaxInt",    0, primMaxInt},
  290.   {"primPlusInt",    2, primPlusInt},
  291.   {"primMinusInt",    2, primMinusInt},
  292.   {"primMulInt",    2, primMulInt},
  293.   {"primDivInt",    2, primDivInt},
  294.   {"primQuotInt",    2, primQuotInt},
  295.   {"primModInt",    2, primModInt},
  296.   {"primRemInt",    2, primRemInt},
  297.   {"primNegInt",    1, primNegInt},
  298.   {"primEvenInt",    1, primEvenInt},
  299.   {"primQrmInt",    2, primQrmInt},
  300.  
  301. #if BIGNUMS                /* Bignum primitive functions       */
  302.   {"primPlusInteger",    2, primPlusInteger},
  303.   {"primMinusInteger",    2, primMinusInteger},
  304.   {"primMulInteger",    2, primMulInteger},
  305.   {"primQrmInteger",    2, primQrmInteger},
  306.   {"primNegInteger",    1, primNegInteger},
  307.   {"primEvenInteger",    1, primEvenInteger},
  308.   {"primIntToInteger",  1, primIntToInteger},
  309.   {"primIntegerToInt",  1, primIntegerToInt},
  310.   {"primIntegerToFloat",1, primIntegerToFloat},
  311.   {"primIntegerToDouble",1,primIntegerToFloat},
  312.   {"primEqInteger",    2, primEqInteger},
  313.   {"primCmpInteger",    3, primCmpInteger},
  314. #else                    /* Implement Integer as Int       */
  315.   {"primPlusInteger",    2, primPlusInt},
  316.   {"primMinusInteger",    2, primMinusInt},
  317.   {"primMulInteger",    2, primMulInt},
  318.   {"primQrmInteger",    2, primQrmInt},
  319.   {"primNegInteger",    1, primNegInt},
  320.   {"primIntToInteger",  1, primDummyCvt},
  321.   {"primIntegerToInt",  1, primDummyCvt},
  322.   {"primIntegerToFloat",1, primIntToFloat},
  323.   {"primIntegerToDouble",1,primIntToFloat},
  324.   {"primEqInteger",    2, primEqInt},
  325.   {"primCmpInteger",    3, primCmpInt},
  326. #endif
  327.  
  328.   {"primPlusFloat",    2, primPlusFloat},
  329.   {"primMinusFloat",    2, primMinusFloat},
  330.   {"primMulFloat",    2, primMulFloat},
  331.   {"primDivFloat",    2, primDivFloat},
  332.   {"primNegFloat",    1, primNegFloat},
  333.  
  334.   {"primPlusDouble",    2, primPlusFloat},    /* Currently Float */
  335.   {"primMinusDouble",    2, primMinusFloat},    /* Currently Float */
  336.   {"primMulDouble",    2, primMulFloat},    /* Currently Float */
  337.   {"primDivDouble",    2, primDivFloat},    /* Currently Float */
  338.   {"primNegDouble",    1, primNegFloat},    /* Currently Float */
  339.  
  340. #if HAS_FLOATS
  341.   {"primPiFloat",    0, primPiFloat},
  342.   {"primSinFloat",    1, primSinFloat},
  343.   {"primCosFloat",    1, primCosFloat},
  344.   {"primTanFloat",    1, primTanFloat},
  345.   {"primAsinFloat",    1, primAsinFloat},
  346.   {"primAcosFloat",    1, primAcosFloat},
  347.   {"primAtanFloat",    1, primAtanFloat},
  348.   {"primAtan2Float",    2, primAtan2Float},
  349.   {"primExpFloat",    1, primExpFloat},
  350.   {"primLogFloat",    1, primLogFloat},
  351.   {"primLog10Float",    1, primLog10Float},
  352.   {"primSqrtFloat",    1, primSqrtFloat},
  353.   {"primFloatToInt",    1, primFloatToInt},
  354.   {"primFloatRadix",    1, primFloatRadix},
  355.   {"primFloatDigits",    1, primFloatDigits},
  356.   {"primFloatRange",    1, primFloatRange},
  357.   {"primFloatDecode",    1, primFloatDecode},
  358.   {"primFloatEncode",    2, primFloatEncode},
  359.  
  360.   {"primPiDouble",    0, primPiFloat},    /* Currently Float */
  361.   {"primSinDouble",    1, primSinFloat},    /* Currently Float */
  362.   {"primCosDouble",    1, primCosFloat},    /* Currently Float */
  363.   {"primTanDouble",    1, primTanFloat},    /* Currently Float */
  364.   {"primAsinDouble",    1, primAsinFloat},    /* Currently Float */
  365.   {"primAcosDouble",    1, primAcosFloat},    /* Currently Float */
  366.   {"primAtanDouble",    1, primAtanFloat},    /* Currently Float */
  367.   {"primAtan2Double",    2, primAtan2Float},    /* Currently Float */
  368.   {"primExpDouble",    1, primExpFloat},    /* Currently Float */
  369.   {"primLogDouble",    1, primLogFloat},    /* Currently Float */
  370.   {"primLog10Double",    1, primLog10Float},    /* Currently Float */
  371.   {"primSqrtDouble",    1, primSqrtFloat},    /* Currently Float */
  372.   {"primDoubleToInt",    1, primFloatToInt},    /* Currently Float */
  373.   {"primDoubleRadix",    1, primFloatRadix},    /* Currently Float */
  374.   {"primDoubleDigits",    1, primFloatDigits},    /* Currently Float */
  375.   {"primDoubleRange",    1, primFloatRange},    /* Currently Float */
  376.   {"primDoubleDecode",    1, primFloatDecode},    /* Currently Float */
  377.   {"primDoubleEncode",    2, primFloatEncode},    /* Currently Float */
  378. #endif
  379.  
  380.   {"primIntToChar",    1, primIntToChar},
  381.   {"primCharToInt",    1, primCharToInt},
  382.   {"primIntToFloat",    1, primIntToFloat},
  383.   {"primIntToDouble",    1, primIntToFloat},    /* Currently Float */
  384.   {"primDoubleToFloat", 1, primDummyCvt},    /* dummy       */
  385.  
  386.   {"primEqInt",        2, primEqInt},
  387.   {"primCmpInt",    3, primCmpInt},
  388.   {"primEqChar",    2, primEqChar},
  389.   {"primLeChar",    2, primLeChar},
  390.   {"primEqFloat",    2, primEqFloat},
  391.   {"primLeFloat",    2, primLeFloat},
  392.   {"primEqDouble",    2, primEqFloat},    /* Currently Float */
  393.   {"primLeDouble",    2, primLeFloat},    /* Currently Float */
  394.  
  395. #if GENERIC_CMP
  396.   {"primCompare",    1, primCmp},
  397.   {"primGenericEq",    2, primGenericEq},
  398.   {"primGenericNe",    2, primGenericNe},
  399.   {"primGenericGt",    2, primGenericGt},
  400.   {"primGenericLe",    2, primGenericLe},
  401.   {"primGenericGe",    2, primGenericGe},
  402.   {"primGenericLt",    2, primGenericLt},
  403. #endif
  404.  
  405.   {"primShowsInt",    3, primPrint},
  406.   {"primShowsInteger",    3, primPrint},
  407.   {"primShowsFloat",    3, primPrint},
  408.   {"primShowsDouble",    3, primPrint},
  409.  
  410.   {"primStrict",    2, primStrict},
  411.  
  412. #if IO_DIALOGUE
  413.   {"primInput",        1, primInput},
  414.   {"primFopen",        3, primFopen},
  415. #endif
  416.  
  417. #if IO_MONAD
  418.   {"primSTRun",        1, primSTRun},
  419.   {"primFst",        1, primFst},
  420.   {"primSnd",        1, primSnd},
  421.   {"primSTReturn",    1, primSTReturn},
  422.   {"primIOBind",    3, primIOBind},
  423.   {"primSTBind",    3, primSTBind},
  424.   {"primSTInter",    2, primSTInter},
  425.   {"primSTNew",        2, primSTNew},
  426.   {"primSTAssign",    3, primSTAssign},
  427.   {"primSTDeref",    2, primSTDeref},
  428.   {"primSTMutVarEq",    2, primSTMutVarEq},
  429.   {"primIOGetch",    1, primIOGetch},
  430.   {"primIOPutchar",    2, primIOPutchar},
  431. #if HASKELL_ARRAYS
  432.   {"primSTNewArr",    4, primSTNewArr},
  433.   {"primSTReadArr",    4, primSTReadArr},
  434.   {"primSTWriteArr",    5, primSTWriteArr},
  435.   {"primSTFreeze",    2, primSTFreeze},
  436. #endif
  437. #endif
  438.  
  439.   {0,            0, 0}
  440. };
  441.  
  442. /* --------------------------------------------------------------------------
  443.  * Primitive functions:
  444.  * ------------------------------------------------------------------------*/
  445.  
  446. primFun(primFatbar) {            /* Fatbar primitive           */
  447.     Cell l    = primArg(2);        /* _FAIL [] r = r           */
  448.     Cell r    = primArg(1);        /* l     [] r = l  -- otherwise       */
  449.     Cell temp = evalWithNoError(l);
  450.     if (nonNull(temp))
  451.     if (temp==nameFail)
  452.         updateRoot(r);
  453.     else {
  454.         updateRoot(temp);
  455.         cantReduce();
  456.     }
  457.     else
  458.     updateRoot(l);
  459. }
  460.  
  461. primFun(primFail) {               /* Failure primitive           */
  462.     cantReduce();
  463. }
  464.  
  465. primFun(primSel) {               /* Component selection           */
  466.     Cell c = primArg(3);           /* _sel c e n   return nth component*/
  467.     Cell e = primArg(2);           /*           in expression e       */
  468.     Cell n = intOf(primArg(1));        /*           built using cfun c  */
  469.  
  470.     eval(e);
  471.     if (whnfHead==c &&    ((isName(whnfHead) && name(whnfHead).arity==whnfArgs)
  472.               || (isTuple(whnfHead) && tupleOf(whnfHead)==whnfArgs)))
  473.     updateRoot(pushed(n-1));
  474.     else
  475.     cantReduce();
  476. }
  477.  
  478. primFun(primIf) {               /* Conditional primitive        */
  479.     eval(primArg(3));
  480.     if (whnfHead==nameTrue)
  481.     updateRoot(primArg(2));
  482.     else
  483.     updateRoot(primArg(1));
  484. }
  485.  
  486. primFun(primStrict) {               /* Strict application primitive       */
  487.     eval(primArg(1));               /* evaluate 2nd argument        */
  488.     updapRoot(primArg(2),primArg(1));  /* and apply 1st argument to result */
  489. }
  490.  
  491. primFun(primTrace) {            /* an unsound trace primitive for  */
  492.     fflush(stdout);            /* debugging purposes           */
  493.     eval(pop());            /*  :: String -> a -> a           */
  494.     while (whnfHead==nameCons) {
  495.     eval(pop());
  496.     putchar(charOf(whnfHead));
  497.     eval(pop());
  498.     }
  499.     updateRoot(pop());
  500. }
  501.  
  502. primFun(primMakeMem) {            /* construct member function       */
  503.     Int  di = intOf(primArg(2));    /* Assume that makeMember redexes  */
  504.     Cell i  = primArg(1);        /* appear only in dictionary blocks*/
  505.     List ds = name(i).type;        /* and need no further evaluation  */
  506.  
  507.     while (nonNull(tl(ds))) {        /* makeMember is only used when       */
  508.     i  = ap(i,makeDictFor(hd(ds),di));/* list of evidence is nonNull   */
  509.     ds = tl(ds);
  510.     }
  511.     updapRoot(i,makeDictFor(hd(ds),di));
  512. }
  513.  
  514. primFun(primConCmp) {            /* compare constructors           */
  515.     eval(primArg(3));            /*  :: a -> a -> Bool -> Bool       */
  516.     if (isName(whnfHead) && name(whnfHead).defn==CFUN) {
  517.     Int l = name(whnfHead).number;
  518.     eval(primArg(2));
  519.     if (isName(whnfHead) && name(whnfHead).defn==CFUN) {
  520.         Int r = name(whnfHead).number;
  521.         updateRoot(l<r ? nameFalse : (l>r ? nameTrue : primArg(1)));
  522.         return;
  523.     }
  524.     }
  525.     cantReduce();
  526. }
  527.  
  528. primFun(primEnRange) {            /* derived range for enum type       */
  529.     eval(primArg(1));            /* :: (a,a) -> [a]           */
  530.     updapRoot(ap(nameEnFrTo,primArg(3)),primArg(2));
  531. }
  532.  
  533. primFun(primEnIndex) {            /* derived indec for enum type       */
  534.     eval(primArg(2));            /*  :: (a,a) -> a -> Int       */
  535.     eval(primArg(4));            /* evaluate lower bound           */
  536.     if (isName(whnfHead) && name(whnfHead).defn==CFUN) {
  537.     Int l = name(whnfHead).number;
  538.     eval(primArg(3));        /* evaluate upper bound           */
  539.     if (isName(whnfHead) && name(whnfHead).defn==CFUN) {
  540.         Int h = name(whnfHead).number;
  541.         eval(primArg(1));        /* evaluate index           */
  542.         if (l<=name(whnfHead).number && name(whnfHead).number<=h) {
  543.         updateRoot(mkInt(name(whnfHead).number-l));
  544.         return;
  545.         }
  546.     }
  547.     }
  548.     cantReduce();
  549. }
  550.  
  551. primFun(primEnInRng) {            /* derived inRange for enum type   */
  552.     eval(primArg(2));            /*  :: (a,a) -> a -> Bool       */
  553.     eval(primArg(4));            /* evaluate lower bound           */
  554.     if (isName(whnfHead) && name(whnfHead).defn==CFUN) {
  555.     Int l = name(whnfHead).number;
  556.     eval(primArg(3));        /* evaluate upper bound           */
  557.     if (isName(whnfHead) && name(whnfHead).defn==CFUN) {
  558.         Int h = name(whnfHead).number;
  559.         eval(primArg(1));        /* evaluate index           */
  560.         if (l<=name(whnfHead).number && name(whnfHead).number<=h)
  561.         updateRoot(nameTrue);
  562.         else
  563.         updateRoot(nameFalse);
  564.         return;
  565.     }
  566.     }
  567.     cantReduce();
  568. }
  569.  
  570. primFun(primEnFrom) {            /* derived enumFrom for enum type  */
  571.     eval(primArg(1));            /* :: a -> [a]                */
  572.     if (isName(whnfHead) && name(whnfHead).defn==CFUN) {
  573.     Name cfs  = succCfun(whnfHead);
  574.     Cell cont = isNull(cfs) ? nameNil : ap(nameEnFrom,cfs);
  575.     updapRoot(ap(nameCons,whnfHead),cont);
  576.     }
  577.     else
  578.     cantReduce();
  579. }
  580.  
  581. primFun(primEnFrTo) {            /* derived enumFromTo for enum type*/
  582.     eval(primArg(2));            /* :: a -> a -> [a]           */
  583.     if (isName(whnfHead) && name(whnfHead).defn==CFUN) {
  584.     Name l = whnfHead;
  585.     eval(primArg(1));
  586.     if (isName(whnfHead) && name(whnfHead).defn==CFUN) {
  587.         if (name(l).number < name(whnfHead).number)
  588.         updapRoot(ap(nameCons,l),
  589.               ap(ap(nameEnFrTo,succCfun(l)),whnfHead));
  590.         else if (l==whnfHead)
  591.         updapRoot(ap(nameCons,l),nameNil);
  592.         else
  593.         updateRoot(nameNil);
  594.         return;
  595.     }
  596.     }
  597.     cantReduce();
  598. }
  599.  
  600. primFun(primEnFrTh) {            /* derived enumFromThen for enum ty*/
  601.    eval(primArg(2));            /* :: a -> a -> [a]           */
  602.    if (isName(whnfHead) && name(whnfHead).defn==CFUN) {
  603.     Name f = whnfHead;
  604.     eval(primArg(1));
  605.     if (isName(whnfHead) && name(whnfHead).defn==CFUN) {
  606.         Name n    = nextCfun(f,whnfHead);
  607.         Cell cont = isNull(n) ? ap(ap(nameCons,whnfHead),nameNil)
  608.                   : ap(ap(nameEnFrTh,whnfHead),n);
  609.         updapRoot(ap(nameCons,f),cont);
  610.         return;
  611.     }
  612.     }
  613.     cantReduce();
  614. }
  615.  
  616. /* --------------------------------------------------------------------------
  617.  * Array primitives:
  618.  * ------------------------------------------------------------------------*/
  619.  
  620. #if    HASKELL_ARRAYS
  621. static Int local getSize(bounds,range)
  622. Cell bounds, range; {
  623.     Int lo;
  624.     eval(bounds);            /* get components of bounds pair   */
  625.     eval(ap(range,pop()));        /* get lower bound as an integer   */
  626.     lo = whnfInt;
  627.     eval(ap(range,pop()));        /* get upper bound as an integer   */
  628.     whnfInt -= lo;
  629.     return (whnfInt<0 ? 0 : whnfInt+1);
  630. }
  631.  
  632. static List local addAssocs(r,s,as,vs)    /* add assocs in as to array       */
  633. Cell r;                    /* list vs, using r for the range  */
  634. Int  s;                    /* and s for array size           */
  635. Cell as;
  636. List vs; {
  637.     for (;;) {                /* loop through assocs           */
  638.     eval(as);
  639.     if (whnfHead==nameNil && whnfArgs==0)
  640.         break;
  641.     else if (whnfHead==nameCons && whnfArgs==2) {
  642.         eval(pop());
  643.         /* at this point, the top of the stack looks like:
  644.          *
  645.          *      pushed(0) == index  (first component in assoc)
  646.          *      pushed(1) == value for assoc
  647.          *        pushed(2) == rest of assocs
  648.          */
  649.         eval(ap(r,top()));
  650.         if (whnfInt<0 || whnfInt>=s)
  651.         return UNIT;
  652.         else {
  653.         List us = NIL;
  654.         drop();
  655.         for (us=vs; whnfInt>0; --whnfInt)
  656.             us = tl(us);
  657.         hd(us) = (isNull(hd(us)) ? top() : nameEltUndef);
  658.         drop();
  659.         as = pop();
  660.         }
  661.     }
  662.     else
  663.         internal("runtime type error");
  664.     }
  665.     return vs;
  666. }
  667.  
  668. static List local foldAssocs(r,s,f,as,vs)
  669. Cell r;                    /* fold assocs as into array list  */
  670. Int  s;                    /* vs using function f, with r for */
  671. Cell f;                    /* range and s for size           */
  672. Cell as;                /* bounds.               */
  673. List vs; {
  674.     for (;;) {                /* loop through assocs           */
  675.     eval(as);
  676.     if (whnfHead==nameNil && whnfArgs==0)
  677.         break;
  678.     else if (whnfHead==nameCons && whnfArgs==2) {
  679.         eval(pop());
  680.         /* at this point, the top of the stack looks like:
  681.          *
  682.          *      pushed(0) == index  (first component in assoc)
  683.          *      pushed(1) == value for assoc
  684.          *        pushed(2) == rest of assocs
  685.          */
  686.         eval(ap(r,top()));
  687.         if (whnfInt<0 || whnfInt>s)
  688.         return UNIT;
  689.         else {
  690.         List us = NIL;
  691.         drop();
  692.         for (us=vs; whnfInt>0; --whnfInt)
  693.             us = tl(us);
  694.         hd(us) = ap(ap(f,hd(us)),pop());
  695.         as = pop();
  696.         }
  697.     }
  698.     else
  699.         internal("runtime type error");
  700.     }
  701.     return vs;
  702. }
  703.  
  704. primFun(primArray) {            /* Array creation           */
  705.     Cell range  = primArg(3);        /*  :: (a -> Int) ->            */
  706.     Cell bounds = primArg(2);        /*    (a,a) ->           */
  707.     Cell assocs = primArg(1);        /*     [Assoc a b] -> Array a b  */
  708.     List vs     = NIL;
  709.     List us    = NIL;
  710.     Int  size;
  711.  
  712.     size = getSize(bounds,range);            /* check bounds       */
  713.     vs   = copy(size,NIL);                /* initialize elems*/
  714.     vs   = addAssocs(range,size,assocs,vs);        /* process assocs  */
  715.     if (vs==UNIT) {
  716.     updapRoot(ap(nameOutBounds,bounds),top());
  717.     cantReduce();
  718.     }
  719.     for (us=vs; nonNull(us); us=tl(us))            /* set undef elts  */
  720.     if (isNull(hd(us)))
  721.         hd(us) = nameEltUndef;
  722.  
  723.     updapRoot(ARRAY,ap(bounds,vs));
  724. }
  725.  
  726. primFun(primUpdate) {            /* Array update               */
  727.     Cell range  = primArg(3);        /*  :: (a -> Int) ->           */
  728.     Cell oldArr = primArg(2);        /*    Array a b ->           */
  729.     Cell assocs = primArg(1);        /*     [Assoc a b] -> Array a b  */
  730.     Cell bounds = NIL;
  731.     Cell elems  = NIL;
  732.     List vs     = NIL;
  733.     List us    = NIL;
  734.     Int  size;
  735.  
  736.     eval(oldArr);                    /* find bounds       */
  737.     bounds = fst(snd(whnfHead));
  738.     elems  = snd(snd(whnfHead));
  739.     size   = getSize(bounds,range);
  740.     vs     = copy(size,NIL);                /* initialize elems*/
  741.     vs     = addAssocs(range,size,assocs,vs);        /* process assocs  */
  742.     if (vs==UNIT) {
  743.         updapRoot(ap(nameOutBounds,bounds),top());
  744.         cantReduce();
  745.     }
  746.     for (us=vs; nonNull(us) && nonNull(elems); us=tl(us), elems=tl(elems))
  747.     if (isNull(hd(us)))                /* undef values    */
  748.         hd(us) = hd(elems);                /* replaced by the */
  749.                             /* old array vals  */
  750.     updapRoot(ARRAY,ap(bounds,vs));
  751. }
  752.  
  753. primFun(primAccum) {            /* Array accum               */
  754.     Cell range  = primArg(4);        /*  :: (a -> Int) ->           */
  755.     Cell f      = primArg(3);        /*    (b -> c -> b) ->       */
  756.     Cell orig   = primArg(2);        /*     Array a b ->           */
  757.     Cell assocs = primArg(1);        /*      [Assoc a c] -> Array a b */
  758.     Cell bounds = NIL;
  759.     List vs     = NIL;
  760.     Int  size;
  761.  
  762.     eval(orig);                        /* find bounds       */
  763.     bounds = fst(snd(whnfHead));
  764.     vs     = dupList(snd(snd(whnfHead)));        /* elements of orig*/
  765.     size   = getSize(bounds,range);
  766.     vs     = foldAssocs(range,size,f,assocs,vs);    /* process assocs  */
  767.     if (vs==UNIT) {
  768.         updapRoot(ap(nameOutBounds,bounds),top());
  769.         cantReduce();
  770.     }
  771.     updapRoot(ARRAY,ap(bounds,vs));
  772. }
  773.  
  774. primFun(primAccumArray) {        /* Array accumArray           */
  775.     Cell range  = primArg(5);        /*  :: (a -> Int) ->           */
  776.     Cell f      = primArg(4);        /*    (b -> c -> b) ->       */
  777.     Cell z      = primArg(3);        /*     b ->               */
  778.     Cell bounds = primArg(2);        /*      (a,a) ->           */
  779.     Cell assocs = primArg(1);        /*       [Assoc a c] -> Array a b*/
  780.     List vs     = NIL;
  781.     Int  size;
  782.  
  783.     size = getSize(bounds,range);            /* check size       */
  784.     vs   = copy(size,z);                /* initialize elems*/
  785.     vs   = foldAssocs(range,size,f,assocs,vs);        /* process assocs  */
  786.     if (vs==UNIT) {
  787.         updapRoot(ap(nameOutBounds,bounds),top());
  788.         cantReduce();
  789.     }
  790.     updapRoot(ARRAY,ap(bounds,vs));
  791. }
  792.  
  793. primFun(primAmap) {            /* map function over array       */
  794.     Cell f  = primArg(2);        /*  :: (b -> c) ->           */
  795.     Cell a  = primArg(1);        /*    Array a b -> Array a c       */
  796.     List us = NIL;
  797.     List vs = NIL;
  798.  
  799.     eval(a);        
  800.     a = whnfHead;
  801.     for (us=snd(snd(a)); nonNull(us); us=tl(us))
  802.     vs = cons(ap(f,hd(us)),vs);
  803.     updapRoot(ARRAY,ap(fst(snd(a)),rev(vs)));
  804. }
  805.  
  806. primFun(primSubscript) {        /* Subscript primitive           */
  807.     Int  index = 0;            /*  :: (a -> Int) ->           */
  808.     List vs = NIL;            /*    Array a b ->           */
  809.                     /*     a -> b               */
  810.  
  811.     eval(ap(primArg(3),primArg(1)));    /* find required position       */
  812.     if ((index=whnfInt) < 0)
  813.     cantReduce();
  814.     eval(primArg(2));            /* evaluate array           */
  815.     if (whatIs(whnfHead)!=ARRAY)
  816.     internal("primBounds");
  817.     for (vs=snd(snd(whnfHead)); nonNull(vs) && index>0; vs=tl(vs))
  818.     --index;
  819.     if (isNull(vs))
  820.     cantReduce();
  821.     updateRoot(hd(vs));
  822. }
  823.  
  824. primFun(primBounds) {            /* Bounds primitive           */
  825.     eval(primArg(1));            /*  :: Array a b -> (a,a)       */
  826.     if (whatIs(whnfHead)!=ARRAY)
  827.     internal("primBounds");
  828.     updateRoot(fst(snd(whnfHead)));
  829. }
  830.  
  831. primFun(primElems) {            /* elems primitive           */
  832.     Cell vs = NIL;
  833.     Cell us = NIL;
  834.     eval(primArg(1));            /* evaluate array to whnf       */
  835.     if (whatIs(whnfHead)!=ARRAY)
  836.     internal("primElems");
  837.     for (us=snd(snd(whnfHead)); nonNull(us); us=tl(us))
  838.     vs = ap(ap(nameCons,hd(us)),vs);
  839.     updateRoot(revOnto(vs,nameNil));
  840. }
  841. #endif
  842.  
  843. /* --------------------------------------------------------------------------
  844.  * Integer arithmetic primitives:
  845.  * ------------------------------------------------------------------------*/
  846.  
  847. primFun(primMinInt) {            /* minimum integer CAF           */
  848.     push(mkInt((-MAXPOSINT)-1));
  849. }
  850.  
  851. primFun(primMaxInt) {            /* maximum integer CAF           */
  852.     push(mkInt(MAXPOSINT));
  853. }
  854.  
  855. primFun(primPlusInt) {               /* Integer addition primitive       */
  856.     Int x;
  857.     eval(primArg(2));
  858.     x = whnfInt;
  859.     eval(primArg(1));
  860.     updateRoot(mkInt(x+whnfInt));
  861. }
  862.  
  863. primFun(primMinusInt) {            /* Integer subtraction primitive    */
  864.     Int x;
  865.     eval(primArg(2));
  866.     x = whnfInt;
  867.     eval(primArg(1));
  868.     updateRoot(mkInt(x-whnfInt));
  869. }
  870.  
  871. primFun(primMulInt) {               /* Integer multiplication primitive */
  872.     Int x;
  873.     eval(primArg(2));
  874.     x = whnfInt;
  875.     eval(primArg(1));
  876.     updateRoot(mkInt(x*whnfInt));
  877. }
  878.  
  879. primFun(primQrmInt) {            /* Integer quotient and remainder  */
  880.     Int x;                /* truncated towards zero       */
  881.     eval(primArg(2));
  882.     x = whnfInt;
  883.     eval(primArg(1));
  884.     if (whnfInt==0)
  885.     cantReduce();
  886.     updapRoot(ap(nameCons,mkInt(x/whnfInt)),mkInt(x%whnfInt));
  887. }
  888.  
  889. primFun(primQuotInt) {            /* Integer division primitive       */
  890.     Int x;                /* truncated towards zero       */
  891.     eval(primArg(2));
  892.     x = whnfInt;
  893.     eval(primArg(1));
  894.     if (whnfInt==0)
  895.     cantReduce();
  896.     updateRoot(mkInt(x/whnfInt));
  897. }
  898.  
  899. primFun(primDivInt) {            /* Integer division primitive       */
  900.     Int x,r;                /* truncated towards -ve infinity  */
  901.     eval(primArg(2));
  902.     x = whnfInt;
  903.     eval(primArg(1));
  904.     if (whnfInt==0)
  905.     cantReduce();
  906.     r = x%whnfInt;
  907.     x = x/whnfInt;
  908.     if ((whnfInt<0 && r>0) || (whnfInt>0 && r<0))
  909.     x--;
  910.     updateRoot(mkInt(x));
  911. }
  912.  
  913. primFun(primModInt) {               /* Integer modulo primitive       */
  914.     Int x,y;
  915.     eval(primArg(2));
  916.     x = whnfInt;
  917.     eval(primArg(1));
  918.     if (whnfInt==0)
  919.     cantReduce();
  920.     y = x%whnfInt;               /* "... the modulo having the sign  */
  921.     if ((y<0 && whnfInt>0) ||           /*           of the divisor ..." */
  922.     (y>0 && whnfInt<0))           /* See definition on p.91 of Haskell*/
  923.     updateRoot(mkInt(y+whnfInt));  /* report...               */
  924.     else
  925.     updateRoot(mkInt(y));
  926. }
  927.  
  928. primFun(primRemInt) {               /* Integer remainder primitive       */
  929.     Int x;
  930.     eval(primArg(2));               /* quot and rem satisfy:           */
  931.     x = whnfInt;               /* (x `quot` y)*y + (x `rem` y) == x*/
  932.     eval(primArg(1));               /* which is exactly the property    */
  933.     if (whnfInt==0)               /* described in K&R 2:           */
  934.     cantReduce();               /*      (a/b)*b + a%b == a       */
  935.     updateRoot(mkInt(x%whnfInt));
  936. }
  937.  
  938. primFun(primNegInt) {               /* Integer negation primitive       */
  939.     eval(primArg(1));
  940.     updateRoot(mkInt(-whnfInt));
  941. }
  942.  
  943. primFun(primEvenInt) {               /* Integer even predicate       */
  944.     eval(primArg(1));
  945.     updateRoot((whnfInt&1) ? nameFalse : nameTrue);
  946. }
  947.  
  948. /* --------------------------------------------------------------------------
  949.  * Haskell Integer (bignum) primitives:
  950.  * ------------------------------------------------------------------------*/
  951.  
  952. #if BIGNUMS
  953. #include "bignums.c"
  954.  
  955. primFun(primPlusInteger) {
  956.     Bignum x;
  957.     eval(primArg(2));
  958.     x = whnfHead;
  959.     eval(primArg(1));
  960.     updateRoot(bigAdd(x,whnfHead));
  961. }
  962.  
  963. primFun(primMinusInteger) {
  964.     Bignum x;
  965.     eval(primArg(2));
  966.     x = whnfHead;
  967.     eval(primArg(1));
  968.     updateRoot(bigSub(x,whnfHead));
  969. }
  970.  
  971. primFun(primMulInteger) {
  972.     Bignum x;
  973.     eval(primArg(2));
  974.     x = whnfHead;
  975.     eval(primArg(1));
  976.     updateRoot(bigMul(x,whnfHead));
  977. }
  978.  
  979. primFun(primQrmInteger) {
  980.     Bignum x;
  981.     eval(primArg(2));
  982.     x = whnfHead;
  983.     eval(primArg(1));
  984.     x = bigQrm(x,whnfHead);
  985.     if (isNull(x))
  986.     cantReduce();
  987.     else
  988.     updateRoot(x);
  989. }
  990.  
  991. primFun(primNegInteger) {
  992.     eval(primArg(1));
  993.     updateRoot(bigNeg(whnfHead));
  994. }
  995.  
  996. primFun(primEvenInteger) {
  997.     eval(primArg(1));
  998.     updateRoot(bigEven(whnfHead) ? nameTrue : nameFalse);
  999. }
  1000.  
  1001. primFun(primIntToInteger) {
  1002.     eval(primArg(1));
  1003.     updateRoot(bigInt(whnfInt));
  1004. }
  1005.  
  1006. primFun(primIntegerToInt) {
  1007.     eval(primArg(1));
  1008.     whnfHead = bigToInt(whnfHead);
  1009.     if (nonNull(whnfHead))
  1010.     updateRoot(whnfHead);
  1011.     else
  1012.     cantReduce();
  1013. }
  1014.  
  1015. primFun(primIntegerToFloat) {
  1016.     eval(primArg(1));
  1017.     updateRoot(bigToFloat(whnfHead));
  1018. }
  1019.  
  1020. primFun(primEqInteger) {
  1021.     Bignum x;
  1022.     eval(primArg(2));
  1023.     x = whnfHead;
  1024.     eval(primArg(1));
  1025.     updateRoot(bigCmp(x,whnfHead)==0 ? nameTrue : nameFalse);
  1026. }
  1027.  
  1028. primFun(primCmpInteger) {
  1029.     Bignum x;
  1030.     eval(primArg(3));
  1031.     x = whnfHead;
  1032.     eval(primArg(2));
  1033.     switch (bigCmp(x,whnfHead)) {
  1034.     case (-1) : x = nameFalse;  break;
  1035.     case   0  : x = primArg(1); break;
  1036.     case   1  : x = nameTrue;   break;
  1037.     }
  1038.     updateRoot(x);
  1039. }
  1040. #endif
  1041.  
  1042. /* --------------------------------------------------------------------------
  1043.  * Coercion primitives:
  1044.  * ------------------------------------------------------------------------*/
  1045.  
  1046. primFun(primCharToInt) {           /* Character to integer primitive   */
  1047.     eval(primArg(1));
  1048.     updateRoot(mkInt(charOf(whnfHead)));
  1049. }
  1050.  
  1051. primFun(primIntToChar) {           /* Integer to character primitive   */
  1052.     eval(primArg(1));
  1053.     if (whnfInt<0  || whnfInt>MAXCHARVAL)
  1054.     cantReduce();
  1055.     updateRoot(mkChar(whnfInt));
  1056. }
  1057.  
  1058. primFun(primIntToFloat) {        /* Integer to Float primitive       */
  1059.     eval(primArg(1));
  1060.     updateRoot(mkFloat((Float)(whnfInt)));
  1061. }
  1062.  
  1063. primFun(primDummyCvt) {            /* dummy (identity) conversion       */
  1064.     updateRoot(primArg(1));
  1065. }
  1066.  
  1067. /* --------------------------------------------------------------------------
  1068.  * Float arithmetic primitives:
  1069.  * ------------------------------------------------------------------------*/
  1070.  
  1071. primFun(primPlusFloat) {           /* Float addition primitive       */
  1072.     Float x;
  1073.     eval(primArg(2));
  1074.     x = whnfFloat;
  1075.     eval(primArg(1));
  1076.     updateRoot(mkFloat(x+whnfFloat));
  1077. }
  1078.  
  1079. primFun(primMinusFloat) {            /* Float subtraction primitive       */
  1080.     Float x;
  1081.     eval(primArg(2));
  1082.     x = whnfFloat;
  1083.     eval(primArg(1));
  1084.     updateRoot(mkFloat(x-whnfFloat));
  1085. }
  1086.  
  1087. primFun(primMulFloat) {               /* Float multiplication primitive   */
  1088.     Float x;
  1089.     eval(primArg(2));
  1090.     x = whnfFloat;
  1091.     eval(primArg(1));
  1092.     updateRoot(mkFloat(x*whnfFloat));
  1093. }
  1094.  
  1095. primFun(primDivFloat) {               /* Float division primitive       */
  1096.     Float x;
  1097.     eval(primArg(2));
  1098.     x = whnfFloat;
  1099.     eval(primArg(1));
  1100.     if (whnfFloat==0)
  1101.     cantReduce();
  1102.     updateRoot(mkFloat(x/whnfFloat));
  1103. }
  1104.  
  1105. primFun(primNegFloat) {               /* Float negation primitive       */
  1106.     eval(primArg(1));
  1107.     updateRoot(mkFloat(-whnfFloat));
  1108. }
  1109.  
  1110. #if HAS_FLOATS
  1111. primFun(primPiFloat) {            /* Float pi primitive           */
  1112.     push(mkFloat(3.1415926535));
  1113. }
  1114.  
  1115. primFun(primSinFloat) {            /* Float sin (trig) primitive       */
  1116.     eval(primArg(1));
  1117.     updateRoot(mkFloat(sin(whnfFloat)));
  1118. }
  1119.  
  1120. primFun(primCosFloat) {            /* Float cos (trig) primitive       */
  1121.     eval(primArg(1));
  1122.     updateRoot(mkFloat(cos(whnfFloat)));
  1123. }
  1124.  
  1125. primFun(primTanFloat) {            /* Float tan (trig) primitive       */
  1126.     eval(primArg(1));
  1127.     updateRoot(mkFloat(tan(whnfFloat)));
  1128. }
  1129.  
  1130. primFun(primAsinFloat) {        /* Float arc sin (trig) primitive  */
  1131.     eval(primArg(1));
  1132.     updateRoot(mkFloat(asin(whnfFloat)));
  1133. }
  1134.  
  1135. primFun(primAcosFloat) {        /* Float arc cos (trig) primitive  */
  1136.     eval(primArg(1));
  1137.     updateRoot(mkFloat(acos(whnfFloat)));
  1138. }
  1139.  
  1140. primFun(primAtanFloat) {        /* Float arc tan (trig) primitive  */
  1141.     eval(primArg(1));
  1142.     updateRoot(mkFloat(atan(whnfFloat)));
  1143. }
  1144.  
  1145. primFun(primAtan2Float) {        /* Float arc tan with quadrant info*/
  1146.     Float t;                /*          (trig) primitive  */
  1147.     eval(primArg(2));
  1148.     t = whnfFloat;
  1149.     eval(primArg(1));
  1150.     updateRoot(mkFloat(atan2(t,whnfFloat)));
  1151. }
  1152.  
  1153. primFun(primExpFloat) {            /* Float exponential primitive       */
  1154.     eval(primArg(1));
  1155.     updateRoot(mkFloat(exp(whnfFloat)));
  1156. }
  1157.  
  1158. primFun(primLogFloat) {            /* Float logarithm primitive       */
  1159.     eval(primArg(1));
  1160.     if (whnfFloat<=0)
  1161.     cantReduce();
  1162.     updateRoot(mkFloat(log(whnfFloat)));
  1163. }
  1164.  
  1165. primFun(primLog10Float) {        /* Float logarithm (base 10) prim  */
  1166.     eval(primArg(1));
  1167.     if (whnfFloat<=0)
  1168.     cantReduce();
  1169.     updateRoot(mkFloat(log10(whnfFloat)));
  1170. }
  1171.  
  1172. primFun(primSqrtFloat) {        /* Float square root primitive       */
  1173.     eval(primArg(1));
  1174.     if (whnfFloat<0)
  1175.     cantReduce();
  1176.     updateRoot(mkFloat(sqrt(whnfFloat)));
  1177. }
  1178.  
  1179. primFun(primFloatToInt) {        /* Adhoc Float --> Int conversion  */
  1180.     eval(primArg(1));
  1181.     updateRoot(mkInt((Int)(whnfFloat)));
  1182. }
  1183.  
  1184. primFun(primFloatRadix) {        /* Float radix primitive       */
  1185. #if BIGNUMS                /*  :: a -> Integer           */
  1186.     updateRoot(bigInt(FLT_RADIX));    /* from K&R2, I hope it's portable */
  1187. #else
  1188.     updateRoot(mkInt(FLT_RADIX));
  1189. #endif
  1190. }
  1191.  
  1192. primFun(primFloatDigits) {        /* Float sig. digits primitive       */
  1193.     updateRoot(mkInt(FLT_MANT_DIG));    /*  :: a -> Int               */
  1194. }                    /* again, courtesy K&R2           */
  1195.  
  1196. primFun(primFloatRange) {        /* Float exponent range primitive  */
  1197.     updapRoot(ap(mkTuple(2),mkInt(FLT_MIN_EXP)),mkInt(FLT_MAX_EXP));
  1198. }
  1199.  
  1200. primFun(primFloatDecode) {        /* Float decode primitive       */
  1201.     double f;                /*  :: Float -> (Integer,Int)       */
  1202.     Int    n;                /* another gruesome hack       */
  1203.     eval(primArg(1));
  1204.     f  = frexp((double)(whnfFloat),&n);    /* 0.5   <= f < 1           */
  1205.     f  = ldexp(f,FLT_MANT_DIG);        /* 2^m-1 <= f < 2^m, m=FLT_MANT_DIG*/
  1206.     n -= FLT_MANT_DIG;
  1207. #if BIGNUMS
  1208.     updapRoot(ap(mkTuple(2),bigDouble(f)),mkInt(n));
  1209. #else
  1210.     updapRoot(ap(mkTuple(2),mkInt(((Int)f))),mkInt(n));
  1211. #endif
  1212. }
  1213.  
  1214. primFun(primFloatEncode) {        /* Float encode primitive       */
  1215.     Int n;                /*  :: Integer -> Int -> a       */
  1216.     Cell f;                /* Ugly hack, don't use Hugs for   */
  1217.     eval(primArg(1));            /* numerical work           */
  1218.     n = whnfInt;
  1219.     eval(primArg(2));            /* get integer               */
  1220.     f = bigToFloat(whnfHead);        /* and turn it into a float       */
  1221.     updateRoot(mkFloat(ldexp(floatOf(f),n)));
  1222. }
  1223. #endif
  1224.  
  1225. /* --------------------------------------------------------------------------
  1226.  * Comparison primitives:
  1227.  * ------------------------------------------------------------------------*/
  1228.  
  1229. primFun(primEqInt) {               /* Integer equality primitive       */
  1230.     Int x;
  1231.     eval(primArg(2));
  1232.     x = whnfInt;
  1233.     eval(primArg(1));
  1234.     updateRoot(x==whnfInt ? nameTrue : nameFalse);
  1235. }
  1236.  
  1237. primFun(primCmpInt) {               /* Integer compare primitive       */
  1238.     Int x;
  1239.     eval(primArg(3));
  1240.     x = whnfInt;
  1241.     eval(primArg(2));
  1242.     updateRoot(x>whnfInt ? nameTrue  :
  1243.                           (x<whnfInt ? nameFalse : primArg(1)));
  1244. }
  1245.  
  1246. primFun(primEqChar) {               /* Character equality primitive       */
  1247.     Cell x;
  1248.     eval(primArg(2));
  1249.     x = whnfHead;
  1250.     eval(primArg(1));
  1251.     updateRoot(x==whnfHead ? nameTrue : nameFalse);
  1252. }
  1253.  
  1254. primFun(primLeChar) {               /* Character <= primitive       */
  1255.     Cell x;
  1256.     eval(primArg(2));
  1257.     x = whnfHead;
  1258.     eval(primArg(1));
  1259.     updateRoot(x<=whnfHead ? nameTrue : nameFalse);
  1260. }
  1261.  
  1262. primFun(primEqFloat) {               /* Float equality primitive       */
  1263.     Float x;
  1264.     eval(primArg(2));
  1265.     x = whnfFloat;
  1266.     eval(primArg(1));
  1267.     updateRoot(x==whnfFloat ? nameTrue : nameFalse);
  1268. }
  1269.  
  1270. primFun(primLeFloat) {               /* Float <= primitive           */
  1271.     Float x;
  1272.     eval(primArg(2));
  1273.     x = whnfFloat;
  1274.     eval(primArg(1));
  1275.     updateRoot(x<=whnfFloat ? nameTrue : nameFalse);
  1276. }
  1277.  
  1278. #if GENERIC_CMP
  1279. /* Generic comparisons implemented using the internal primitive function:
  1280.  *
  1281.  * primCmp []            = EQ
  1282.  *         ((C xs, D ys):rs)
  1283.  *       | C < D        = LT
  1284.  *       | C == D        = primCmp (zip xs ys ++ rs)
  1285.  *       | C > D        = GT
  1286.  *       ((Int n, Int m):rs)
  1287.  *       | n < m        = LT
  1288.  *       | n == m        = primCmp rs
  1289.  *       | n > m        = GT
  1290.  *       etc ... similar for comparison of characters:
  1291.  *
  1292.  * The list argument to primCmp is represented as an `internal list';
  1293.  * i.e. no (:)/[] constructors - use internal cons and NIL instead!
  1294.  *
  1295.  * To compare two values x and y, evaluate primCmp [(x,y)] and use result.
  1296.  */
  1297.  
  1298. #define LT            1
  1299. #define EQ            2
  1300. #define GT            3
  1301. #define compResult(x) updateRoot(mkInt(x))
  1302.  
  1303. static Name namePrimCmp;
  1304.  
  1305. primFun(primCmp) {            /* generic comparison function       */
  1306.     Cell rs = primArg(1);
  1307.  
  1308.     if (isNull(rs)) {
  1309.     compResult(EQ);
  1310.     return;
  1311.     }
  1312.     else {
  1313.     Cell x = fst(hd(rs));
  1314.     Cell y = snd(hd(rs));
  1315.     Int  whnfArgs1;
  1316.     Cell whnfHead1;
  1317.  
  1318.     rs = tl(rs);
  1319.     eval(x);
  1320.     whnfArgs1 = whnfArgs;
  1321.     whnfHead1 = whnfHead;
  1322.  
  1323.     switch (whatIs(whnfHead1)) {
  1324.         case INTCELL  : if (whnfArgs==0) {        /* compare ints    */
  1325.                 eval(y);
  1326.                 if (!isInt(whnfHead) || whnfArgs!=0)
  1327.                     break;
  1328.                 if (intOf(whnfHead1) > whnfInt)
  1329.                     compResult(GT);
  1330.                 else if (intOf(whnfHead1) < whnfInt)
  1331.                     compResult(LT);
  1332.                 else
  1333.                     updapRoot(namePrimCmp,rs);
  1334.                 return;
  1335.                 }
  1336.                 break;
  1337.  
  1338.         case FLOATCELL: if (whnfArgs==0) {        /* compare floats  */
  1339.                 eval(y);
  1340.                 if (!isFloat(whnfHead) || whnfArgs!=0)
  1341.                     break;
  1342.                 if (floatOf(whnfHead1) > whnfFloat)
  1343.                     compResult(GT);
  1344.                 else if (floatOf(whnfHead1) < whnfFloat)
  1345.                     compResult(LT);
  1346.                 else
  1347.                     updapRoot(namePrimCmp,rs);
  1348.                 return;
  1349.                 }
  1350.                 break;
  1351.  
  1352.         case CHARCELL : if (whnfArgs==0) {        /* compare chars   */
  1353.                 eval(y);
  1354.                 if (!isChar(whnfHead) || whnfArgs!=0)
  1355.                     break;
  1356.                 if (charOf(whnfHead1) > charOf(whnfHead))
  1357.                     compResult(GT);
  1358.                 else if (charOf(whnfHead1) < charOf(whnfHead))
  1359.                     compResult(LT);
  1360.                 else
  1361.                     updapRoot(namePrimCmp,rs);
  1362.                 return;
  1363.                 }
  1364.                 break;
  1365.  
  1366. #if HASKELL_ARRAYS
  1367.         case ARRAY    : break;
  1368. #endif
  1369. #if IO_MONAD
  1370.         case MUTVAR   : break;
  1371. #endif
  1372.  
  1373.         default      : eval(y);            /* compare structs */
  1374.                 if (whnfHead1==whnfHead &&
  1375.                 whnfArgs1==whnfArgs &&
  1376.                 (whnfHead==UNIT    ||
  1377.                  isTuple(whnfHead) ||
  1378.                  (isName(whnfHead) &&
  1379.                   name(whnfHead).defn==CFUN))) {
  1380.                 while (whnfArgs1-- >0)
  1381.                     rs = cons(pair(pushed(whnfArgs+whnfArgs1),
  1382.                            pushed(whnfArgs1)),rs);
  1383.                 updapRoot(namePrimCmp,rs);
  1384.                 return;
  1385.                 }
  1386.                 if (isName(whnfHead1)        &&
  1387.                  name(whnfHead1).defn==CFUN &&
  1388.                  isName(whnfHead)        &&
  1389.                  name(whnfHead).defn==CFUN) {
  1390.                 if (name(whnfHead1).number
  1391.                         > name(whnfHead).number)
  1392.                     compResult(GT);
  1393.                 else if (name(whnfHead1).number
  1394.                         < name(whnfHead).number)
  1395.                     compResult(LT);
  1396.                 else
  1397.                     break;
  1398.                 return;
  1399.                 }
  1400.                             break;
  1401.     }
  1402.         /* we're going to fail because we can't compare x and y; modify    */
  1403.     /* the root expression so that it looks reasonable before failing  */
  1404.     /* i.e. output produced will be:  {_compare x y}           */
  1405.     updapRoot(ap(namePrimCmp,x),y);
  1406.     }
  1407.     cantReduce();
  1408. }
  1409.  
  1410. primFun(primGenericEq) {        /* Generic equality test       */
  1411.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  1412.     eval(c);
  1413.     updateRoot(whnfInt==EQ ? nameTrue : nameFalse);
  1414. }
  1415.  
  1416. primFun(primGenericLe) {        /* Generic <= test           */
  1417.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  1418.     eval(c);
  1419.     updateRoot(whnfInt<=EQ ? nameTrue : nameFalse);
  1420. }
  1421.  
  1422. primFun(primGenericLt) {        /* Generic < test           */
  1423.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  1424.     eval(c);
  1425.     updateRoot(whnfInt<EQ ? nameTrue : nameFalse);
  1426. }
  1427.  
  1428. primFun(primGenericGe) {        /* Generic >= test           */
  1429.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  1430.     eval(c);
  1431.     updateRoot(whnfInt>=EQ ? nameTrue : nameFalse);
  1432. }
  1433.  
  1434. primFun(primGenericGt) {        /* Generic > test           */
  1435.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  1436.     eval(c);
  1437.     updateRoot(whnfInt>EQ ? nameTrue : nameFalse);
  1438. }
  1439.  
  1440. primFun(primGenericNe) {        /* Generic /= test           */
  1441.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  1442.     eval(c);
  1443.     updateRoot(whnfInt!=EQ ? nameTrue : nameFalse);
  1444. }
  1445. #endif
  1446.  
  1447. /* --------------------------------------------------------------------------
  1448.  * Print primitives:
  1449.  * ------------------------------------------------------------------------*/
  1450.  
  1451. static Cell consOpen,    consSpace,  consComma,    consClose;
  1452. static Cell consObrace, consCbrace, consOsq,    consCsq;
  1453. static Cell consBack,    consMinus,  consQuote,  consDQuote;
  1454.  
  1455. static Name nameLPrint, nameNLPrint;    /* list printing primitives       */
  1456. static Name nameSPrint, nameNSPrint;    /* string printing primitives       */
  1457.  
  1458. #define print(pr,d,e,ss)    ap(ap(ap(pr,mkInt(d)),e),ss)
  1459. #define lprint(pr,xs,ss)    ap(ap(pr,xs),ss)
  1460. #define printString(s,ss)   revOnto(stringOutput(s,NIL),ss)
  1461. #define printSChar(c,ss)    printString(unlexChar(c,'\"'),ss)
  1462.  
  1463. primFun(primPrint) {            /* evaluate and print term       */
  1464.     Int  d    = intOf(primArg(3));    /*    :: Int->Expr->[Char]->[Char] */
  1465.     Cell e    = primArg(2);
  1466.     Cell ss   = primArg(1);
  1467.     Cell temp = evalWithNoError(e);
  1468.     if (nonNull(temp))
  1469.     updateRoot(printBadRedex(temp,ss));
  1470.     else
  1471.     printer(root,namePrint,d,ss);
  1472. }
  1473.  
  1474. primFun(primNPrint) {            /* print term without evaluation   */
  1475.     Int    d      = intOf(primArg(3)); /*     :: Int->Expr->[Char]->[Char] */
  1476.     Cell   e      = primArg(2);
  1477.     Cell   ss      = primArg(1);
  1478.     unwind(e);
  1479.     printer(root,nameNPrint,d,ss);
  1480. }
  1481.  
  1482. static Void local printer(root,pr,d,ss)    /* Main part: primPrint/primNPrint */
  1483. StackPtr root;                /* root or print redex           */
  1484. Name     pr;                /* printer to use on components       */
  1485. Int     d;                /* precedence level           */
  1486. Cell     ss; {                /* rest of output           */
  1487.     Int  used    = 0;
  1488.     Cell output = NIL;
  1489.  
  1490.     switch(whatIs(whnfHead)) {
  1491.  
  1492.     case NAME     : {   Syntax sy = syntaxOf(name(whnfHead).text);
  1493.  
  1494.                 if (name(whnfHead).defn!=CFUN ||
  1495.                     name(whnfHead).arity>whnfArgs)
  1496.                 pr = nameNPrint;
  1497.  
  1498.                 if (whnfHead==nameCons && whnfArgs==2) {/*list */
  1499.                 if (pr==namePrint)
  1500.                     startList(root,ss);
  1501.                 else
  1502.                     startNList(root,ss);
  1503.                 return;
  1504.                 }
  1505.                 if (whnfArgs==1 && sy!=APPLIC) {      /* (e1+) */
  1506.                 used   = 1;
  1507.                 output = ap(consClose,
  1508.                       textAsOp(name(whnfHead).text,
  1509.                        ap(consSpace,
  1510.                         print(pr,FUN_PREC-1,pushed(0),
  1511.                          ap(consOpen,NIL)))));
  1512.                 }
  1513.                 else if (whnfArgs>=2 && sy!=APPLIC) { /* e1+e2 */
  1514.                 Syntax a = assocOf(sy);
  1515.                 Int    p = precOf(sy);
  1516.                 used     = 2;
  1517.                 if (whnfArgs>2 || d>p)
  1518.                      output = ap(consOpen,output);
  1519.                 output = print(pr,(a==RIGHT_ASS?p:1+p),
  1520.                           pushed(1),
  1521.                       ap(consSpace,
  1522.                        textAsOp(name(whnfHead).text,
  1523.                         ap(consSpace,
  1524.                          print(pr,(a==LEFT_ASS? p:1+p),
  1525.                           pushed(0),
  1526.                           output)))));
  1527.                 if (whnfArgs>2 || d>p)
  1528.                     output = ap(consClose,output);
  1529.                 }
  1530.                 else                  /* f ... */
  1531.                 output = textAsVar(name(whnfHead).text,NIL);
  1532.             }
  1533.             break;
  1534.  
  1535. #if BIGNUMS
  1536.     case NEGNUM   :
  1537.     case ZERONUM  :
  1538.     case POSNUM   : output = rev(bigOut(whnfHead,output,d>=FUN_PREC));
  1539.             pr     = nameNPrint;
  1540.             break;
  1541. #endif
  1542.  
  1543.     case INTCELL  : {   Int digit;
  1544.  
  1545.                 if (intOf(whnfHead)<0 && d>=FUN_PREC)
  1546.                 output = ap(consClose,output);
  1547.  
  1548.                 do {
  1549.                 digit = whnfInt%10;
  1550.                 if (digit<0)
  1551.                     digit= (-digit);
  1552.                 output = ap(consChar('0'+digit),output);
  1553.                 } while ((whnfInt/=10)!=0);
  1554.  
  1555.                 if (intOf(whnfHead)<0) {
  1556.                 output = ap(consMinus,output);
  1557.                 if (d>=FUN_PREC)
  1558.                     output = ap(consOpen,output);
  1559.                 }
  1560.  
  1561.                 output = rev(output);
  1562.                 pr       = nameNPrint;
  1563.             }
  1564.             break;
  1565.  
  1566.     case UNIT     : output = ap(consClose,ap(consOpen,NIL));
  1567.             pr     = nameNPrint;
  1568.             break;
  1569.  
  1570.     case TUPLE    : {   Int  tn   = tupleOf(whnfHead);
  1571.                             Cell punc = consOpen;
  1572.                 Int  i;
  1573.  
  1574.                 used      = tn<whnfArgs ? tn : whnfArgs;
  1575.                 output    = NIL;
  1576.                 for (i=0; i<used; ++i) {
  1577.                 output = print(pr,MIN_PREC,pushed(i),
  1578.                       ap(punc,
  1579.                        output));
  1580.                 punc   = consComma;
  1581.                 }
  1582.                 for (; i<tn; ++i) {
  1583.                 output = ap(punc,output);
  1584.                 punc   = consComma;
  1585.                 }
  1586.                 output = ap(consClose,output);
  1587.             }
  1588.             pr = nameNPrint;
  1589.             break;
  1590.  
  1591.     case CHARCELL : output = ap(consQuote,
  1592.                                   stringOutput(unlexChar(charOf(whnfHead),
  1593.                                                          '\''),
  1594.                    ap(consQuote,
  1595.                     output)));
  1596.             pr     = nameNPrint;
  1597.             break;
  1598.  
  1599.     case FLOATCELL: if (whnfFloat<0.0 && d>=FUN_PREC)
  1600.                 output = ap(consOpen,output);
  1601.             output = stringOutput(floatToString(whnfFloat),output);
  1602.             if (whnfFloat<0.0 && d>=FUN_PREC)
  1603.                 output = ap(consClose,output);
  1604.             pr = nameNPrint;
  1605.             break;
  1606.  
  1607. #if HASKELL_ARRAYS
  1608.     case ARRAY    : output = stringOutput("{array}",output);
  1609.             pr     = nameNPrint;
  1610.             break;
  1611. #endif
  1612.  
  1613. #if IO_MONAD
  1614.     case MUTVAR   : output = stringOutput("{mutable variable}",output);
  1615.             pr     = nameNPrint;
  1616.             break;
  1617. #endif
  1618.  
  1619.         case DICTCELL : output = stringOutput("{dict}",output);
  1620.             pr     = nameNPrint;
  1621.             break;
  1622.  
  1623.     case FILECELL : output = stringOutput("{file}",output);
  1624.             pr     = nameNPrint;
  1625.             break;
  1626.  
  1627.     case INSTANCE : output = outputInst(whnfHead,output);
  1628.             pr     = nameNPrint;
  1629.             break;
  1630.  
  1631.     default       : internal("Error in graph");
  1632.             break;
  1633.     }
  1634.  
  1635.     if (used<whnfArgs) {        /* Add remaining args to output       */
  1636.     do
  1637.         output = print(pr,FUN_PREC,pushed(used),ap(consSpace,output));
  1638.     while (++used<whnfArgs);
  1639.  
  1640.     if (d>=FUN_PREC) {        /* Determine if parens are needed  */
  1641.         updapRoot(consOpen,revOnto(output,ap(consClose,ss)));
  1642.         return;
  1643.     }
  1644.     }
  1645.  
  1646.     updateRoot(revOnto(output,ss));
  1647. }
  1648.  
  1649. /* --------------------------------------------------------------------------
  1650.  * List printing primitives:
  1651.  * ------------------------------------------------------------------------*/
  1652.  
  1653. static Void local startList(root,ss)    /* start printing evaluated list   */
  1654. StackPtr root;
  1655. Cell     ss; {
  1656.     Cell x    = pushed(0);
  1657.     Cell xs   = pushed(1);
  1658.     Cell temp = evalWithNoError(x);
  1659.     if (nonNull(temp))
  1660.     updapRoot(consOsq,
  1661.            printBadRedex(temp,
  1662.             lprint(nameLPrint,xs,ss)));
  1663.     else if (isChar(whnfHead) && whnfArgs==0)
  1664.     updapRoot(consDQuote,
  1665.            printSChar(charOf(whnfHead),
  1666.             lprint(nameSPrint,xs,ss)));
  1667.     else
  1668.     updapRoot(consOsq,
  1669.            print(namePrint,MIN_PREC,x,
  1670.             lprint(nameLPrint,xs,ss)));
  1671. }
  1672.  
  1673. static Void local startNList(root,ss)    /* start printing unevaluated list */
  1674. StackPtr root;
  1675. Cell     ss; {
  1676.     Cell x    = pushed(0);
  1677.     Cell xs   = pushed(1);
  1678.     unwind(x);
  1679.     if (isChar(whnfHead) && whnfArgs==0)
  1680.     updapRoot(consDQuote,
  1681.            printSChar(charOf(whnfHead),
  1682.             lprint(nameNSPrint,xs,ss)));
  1683.     else
  1684.     updapRoot(consOsq,
  1685.            print(nameNPrint,MIN_PREC,x,
  1686.             lprint(nameNLPrint,xs,ss)));
  1687. }
  1688.  
  1689. primFun(primLPrint) {            /* evaluate and print list       */
  1690.     Cell e    = primArg(2);
  1691.     Cell ss   = primArg(1);
  1692.     Cell temp = evalWithNoError(e);
  1693.  
  1694.     if (nonNull(temp))
  1695.     updateRoot(printString("] ++ ",printBadRedex(temp,ss)));
  1696.     else if (whnfHead==nameCons && whnfArgs==2)
  1697.     updapRoot(consComma,
  1698.            ap(consSpace,
  1699.             print(namePrint,MIN_PREC,pushed(0),
  1700.              lprint(nameLPrint,pushed(1),ss))));
  1701.     else if (whnfHead==nameNil && whnfArgs==0)
  1702.     updapRoot(consCsq,ss);
  1703.     else
  1704.     updateRoot(printString("] ++ ",printBadRedex(e,ss)));
  1705. }
  1706.  
  1707. primFun(primNLPrint) {            /* print list without evaluation   */
  1708.     Cell e  = primArg(2);
  1709.     Cell ss = primArg(1);
  1710.     unwind(e);
  1711.     if (whnfHead==nameCons && whnfArgs==2)
  1712.     updapRoot(consComma,
  1713.            ap(consSpace,
  1714.             print(nameNPrint,MIN_PREC,pushed(0),
  1715.              lprint(nameNLPrint,pushed(1),ss))));
  1716.     else if (whnfHead==nameNil && whnfArgs==0)
  1717.     updapRoot(consCsq,ss);
  1718.     else
  1719.     updateRoot(printString("] ++ ",print(nameNPrint,FUN_PREC-1,e,ss)));
  1720. }
  1721.  
  1722. primFun(primSPrint) {            /* evaluate and print string       */
  1723.     Cell e    = primArg(2);
  1724.     Cell ss   = primArg(1);
  1725.     Cell temp = evalWithNoError(e);
  1726.  
  1727.     if (nonNull(temp))
  1728.     updateRoot(printString("\" ++ ",printBadRedex(temp,ss)));
  1729.     else if (whnfHead==nameCons && whnfArgs==2) {
  1730.     Cell x  = pushed(0);
  1731.     Cell xs = pushed(1);
  1732.     temp    = evalWithNoError(x);
  1733.     if (nonNull(temp))
  1734.         updateRoot(printString("\" ++ [",
  1735.             printBadRedex(temp,
  1736.              lprint(nameLPrint,xs,ss))));
  1737.     else if (isChar(whnfHead) && whnfArgs==0)
  1738.         updateRoot(printSChar(charOf(whnfHead),
  1739.                 lprint(nameSPrint,xs,ss)));
  1740.     else
  1741.         updateRoot(printString("\" ++ [",
  1742.             printBadRedex(x,
  1743.              lprint(nameLPrint,xs,ss))));
  1744.     }
  1745.     else if (whnfHead==nameNil && whnfArgs==0)
  1746.     updapRoot(consDQuote,ss);
  1747.     else
  1748.     updateRoot(printString("\" ++ ",printBadRedex(e,ss)));
  1749. }
  1750.  
  1751. primFun(primNSPrint) {            /* print string without eval       */
  1752.     Cell e  = primArg(2);
  1753.     Cell ss = primArg(1);
  1754.     unwind(e);
  1755.     if (whnfHead==nameCons && whnfArgs==2) {
  1756.     Cell x  = pushed(0);
  1757.     Cell xs = pushed(1);
  1758.     unwind(x);
  1759.     if (isChar(whnfHead) && whnfArgs==0)
  1760.         updateRoot(printSChar(charOf(whnfHead),
  1761.                 lprint(nameNSPrint,xs,ss)));
  1762.     else
  1763.         updateRoot(printString("\" ++ [",
  1764.             print(nameNPrint,MIN_PREC,x,
  1765.              lprint(nameNLPrint,xs,ss))));
  1766.     }
  1767.     else if (whnfHead==nameNil && whnfArgs==0)
  1768.     updapRoot(consDQuote,ss);
  1769.     else
  1770.     updateRoot(printString("\" ++ ",print(nameNPrint,FUN_PREC-1,e,ss)));
  1771. }
  1772.  
  1773. /* --------------------------------------------------------------------------
  1774.  * Auxiliary functions for printer(s):
  1775.  * ------------------------------------------------------------------------*/
  1776.  
  1777. static Cell local textAsVar(t,ss)    /* reverse t as function symbol       */
  1778. Text t;                    /* onto output ss           */
  1779. Cell ss; {
  1780.     String s = textToStr(t);
  1781.     if ((isascii(s[0]) && isalpha(s[0])) || s[0]=='_' || strcmp(s,"[]")==0)
  1782.     return stringOutput(s,ss);
  1783.     else
  1784.     return ap(consClose,stringOutput(s,ap(consOpen,ss)));
  1785. }
  1786.  
  1787. static Cell local textAsOp(t,ss)    /* reverse t as op. symbol onto ss */
  1788. Text t;
  1789. Cell ss; {
  1790.     String s = textToStr(t);
  1791.     if (isascii(s[0]) && isalpha(s[0]))
  1792.     return ap(consBack,stringOutput(s,ap(consBack,ss)));
  1793.     else
  1794.     return stringOutput(s,ss);
  1795. }
  1796.  
  1797. static Cell local stringOutput(s,ss)    /* reverse string s onto output ss */
  1798. String s;
  1799. Cell   ss; {
  1800.     while (*s)
  1801.     ss = ap(consChar(*s++),ss);
  1802.     return ss;
  1803. }
  1804.  
  1805. static Cell local printBadRedex(rx,rs)    /* Produce expression to print bad */
  1806. Cell rx, rs; {                /* redex and then print rest ...   */
  1807.     return ap(consObrace,
  1808.         print(nameNPrint,MIN_PREC,rx,
  1809.          ap(consCbrace,
  1810.           rs)));
  1811. }
  1812.  
  1813. static Cell local printDBadRedex(rx,rs) /* Produce expression for bad redex*/
  1814. Cell rx, rs; {                /* within a Dialogue, with special */
  1815.     if (isAp(rx) && fun(rx)==nameError) /* handling of {error str} redexes */
  1816.     return arg(rx);
  1817.     else
  1818.     return printBadRedex(rx,rs);
  1819. }
  1820.  
  1821. Void abandon(what,rx)            /* abandon computation           */
  1822. String what;
  1823. Cell   rx; {
  1824.     outputString(errorStream,
  1825.          revOnto(stringOutput("\n",NIL),
  1826.          revOnto(stringOutput(what,NIL),
  1827.          revOnto(stringOutput(" error: ",NIL),
  1828.              printDBadRedex(rx,nameNil)))));
  1829.     errAbort();
  1830. }
  1831.  
  1832. static Cell local outputInst(in,out)    /* produce string representation   */
  1833. Inst in;                /* of instance               */
  1834. List out; {
  1835.     out = ap(consMinus,stringOutput(textToStr(class(inst(in).c).text),out));
  1836.     switch (whatIs(inst(in).t)) {
  1837.     case LIST  : return stringOutput("[]",out);
  1838.     case UNIT  : return stringOutput("()",out);
  1839.     case TUPLE : {   Int n = tupleOf(inst(in).t);
  1840.              for (out=ap(consOpen,out); n>0; --n)
  1841.                  out = ap(consComma,out);
  1842.              return ap(consClose,out);
  1843.              }
  1844.     case ARROW : return stringOutput("(->)",out);
  1845.     case TYCON : return stringOutput(textToStr(tycon(inst(in).t).text),
  1846.                      out);
  1847.     }
  1848.     return stringOutput("???",out);
  1849. }
  1850.  
  1851. /* --------------------------------------------------------------------------
  1852.  * Evaluate name, obtaining a C string from a Hugs string:
  1853.  * ------------------------------------------------------------------------*/
  1854.  
  1855. #if IO_DIALOGUE
  1856. static String local evalName(es)    /* evaluate es :: [Char] and save  */
  1857. Cell es; {                /* in char array... return ptr to  */
  1858.     static char buffer[FILENAME_MAX+1];    /* string or 0, if error occurs       */
  1859.     Int         pos    = 0;
  1860.     StackPtr    saveSp = sp;
  1861.  
  1862.     while (isNull(evalWithNoError(es)))
  1863.     if (whnfHead==nameCons && whnfArgs==2) {
  1864.         Cell e = pop();        /* avoid leaving anything on stack */
  1865.         es       = pop();
  1866.         if (isNull(evalWithNoError(e))
  1867.             && isChar(whnfHead) && whnfArgs==0
  1868.             && pos<FILENAME_MAX)
  1869.         buffer[pos++] = charOf(whnfHead);
  1870.         else
  1871.         break;
  1872.     }
  1873.     else if (whnfHead==nameNil && whnfArgs==0) {
  1874.         buffer[pos] = '\0';
  1875.         return buffer;
  1876.     }
  1877.     else
  1878.         break;
  1879.  
  1880.     sp = saveSp;            /* stack pointer must be the same  */
  1881.     return 0;                /* as it was on entry           */
  1882. }
  1883. #endif
  1884.  
  1885. /* --------------------------------------------------------------------------
  1886.  * Dialogue based input/output:
  1887.  *
  1888.  * N.B. take care when modifying this code - it is rather delicate and even
  1889.  * the simplest of changes might create a nasty space leak... you have been
  1890.  * warned (please let me know if you think there already is a space leak!).
  1891.  * ------------------------------------------------------------------------*/
  1892.  
  1893. #if IO_DIALOGUE
  1894. static Name nameInput;            /* For reading from stdin       */
  1895. static Bool echoChanged;        /* TRUE => echo changed in dialogue*/
  1896. static Bool stdinUsed;            /* TRUE => ReadChan stdin has been */
  1897.                     /*       seen in dialogue       */
  1898. static FILE *writingFile = 0;        /* points to file open for writing */
  1899.  
  1900. Void dialogue(prog)            /* carry out dialogue ...       */
  1901. Cell prog; {                /* :: Dialog=[Response]->[Request] */
  1902.     static String ioerr = "Attempt to read response before request complete";
  1903.     Cell tooStrict      = mkStr(findText(ioerr));
  1904.     Cell resps        = prog = ap(prog,NIL);
  1905.     Cell temp;
  1906.  
  1907.     echoChanged = FALSE;
  1908.     stdinUsed   = FALSE;
  1909.     for (;;) {                /* Keep Responding to Requests       */
  1910.     resps = snd(resps) = ap(nameError,tooStrict);
  1911.         clearStack();
  1912.     if (nonNull(temp=evalWithNoError(prog)))
  1913.         abandonDialogue(temp);
  1914.     else if (whnfHead==nameCons && whnfArgs==2) {
  1915.         if (nonNull(temp=evalWithNoError(pushed(0))))
  1916.         abandonDialogue(temp);
  1917.  
  1918.         prog = pushed(1+whnfArgs);
  1919.  
  1920.         if (whnfHead==nameReadFile && whnfArgs==1)
  1921.         fst(resps) = ap(nameCons,readFile());
  1922.         else if (whnfHead==nameWriteFile && whnfArgs==2)
  1923.         fst(resps) = ap(nameCons,writeFile());
  1924.         else if (whnfHead==nameAppendFile && whnfArgs==2)
  1925.         fst(resps) = ap(nameCons,appendFile());
  1926.         else if (whnfHead==nameReadChan && whnfArgs==1)
  1927.         fst(resps) = ap(nameCons,readChan());
  1928.         else if (whnfHead==nameAppendChan && whnfArgs==2)
  1929.         fst(resps) = ap(nameCons,appendChan());
  1930.         else if (whnfHead==nameEcho && whnfArgs==1)
  1931.         fst(resps) = ap(nameCons,echo());
  1932.         else if (whnfHead==nameGetArgs && whnfArgs==0)
  1933.         fst(resps) = ap(nameCons,getCLArgs());
  1934.         else if (whnfHead==nameGetProgName && whnfArgs==0)
  1935.         fst(resps) = ap(nameCons,getProgName());
  1936.         else if (whnfHead==nameGetEnv && whnfArgs==1)
  1937.         fst(resps) = ap(nameCons,getEnv());
  1938.         else
  1939.         abandonDialogue(pushed(whnfArgs));
  1940.     }
  1941.     else if (whnfHead==nameNil && whnfArgs==0) {
  1942.         normalTerminal();
  1943.         return;
  1944.     }
  1945.     else
  1946.         internal("Type error during Dialogue");
  1947.     }
  1948. }
  1949.  
  1950. static Void local abandonDialogue(rx)    /* abandon dialogue after failure  */
  1951. Cell rx; {                /* to reduce redex rx           */
  1952.     abandon("Dialogue",rx);
  1953. }
  1954.  
  1955. static Cell local readFile() {        /* repond to ReadFile request       */
  1956.     String s    = evalName(pushed(0));    /* pushed(0) = file name string       */
  1957.     Cell   temp = NIL;            /* pushed(1) = ReadFile request       */
  1958.                     /* pushed(2) = rest of program       */
  1959.  
  1960.     if (!s)                /* problem with filename?       */
  1961.     abandonDialogue(pushed(1));
  1962.     if (access(s,0)!=0)            /* can't find file           */ 
  1963.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  1964.     if (isNull(temp = openFile(s)))    /* can't open file           */
  1965.     return ap(nameFailure,ap(nameReadError,pushed(0)));
  1966.     return ap(nameStr,temp);        /* otherwise we got a file!       */
  1967. }
  1968.  
  1969. static Cell local writeFile() {        /* respond to WriteFile req.       */
  1970.     String s    = evalName(pushed(0));    /* pushed(0) = file name string       */
  1971.     FILE   *fp;                /* pushed(1) = output string       */
  1972.     Cell   temp;            /* pushed(2) = output request       */
  1973.                     /* pushed(3) = rest of program       */
  1974.  
  1975.     if (!s)                /* problem with filename?          */
  1976.         abandonDialogue(pushed(2));
  1977.     pushed(2) = NIL;            /* eliminate space leak!       */
  1978.     if ((fp=fopen(s,FOPEN_WRITE))==0)    /* problem with output file?       */
  1979.     return ap(nameFailure,ap(nameWriteError,pushed(0)));
  1980.     drop();
  1981.     temp = outputDString(writingFile = fp);
  1982.     fclose(fp);
  1983.     writingFile = 0;
  1984.     if (nonNull(temp))
  1985.     return ap(nameFailure,ap(nameWriteError,temp));
  1986.     else
  1987.     return nameSuccess;
  1988. }
  1989.  
  1990. static Cell local appendFile() {    /* respond to AppendFile req.       */
  1991.     String s    = evalName(pushed(0));    /* pushed(0) = file name string       */
  1992.     FILE   *fp;                /* pushed(1) = output string       */
  1993.     Cell   temp;            /* pushed(2) = output request       */
  1994.                     /* pushed(3) = rest of program       */
  1995.  
  1996.     if (!s)                /* problem with filename?          */
  1997.         abandonDialogue(pushed(2));
  1998.     pushed(2) = NIL;            /* eliminate space leak!       */
  1999.     if (access(s,0)!=0)            /* can't find file?           */
  2000.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  2001.     if ((fp=fopen(s,FOPEN_APPEND))==0)    /* problem with output file?       */
  2002.     return ap(nameFailure,ap(nameWriteError,pushed(0)));
  2003.     drop();
  2004.     temp = outputDString(writingFile = fp);
  2005.     fclose(fp);
  2006.     writingFile = 0;
  2007.     if (nonNull(temp))
  2008.     return ap(nameFailure,ap(nameWriteError,temp));
  2009.     else
  2010.     return nameSuccess;
  2011. }
  2012.  
  2013. static Cell local readChan() {        /* respond to readChan req.       */
  2014.     String s    = evalName(pushed(0));    /* pushed(0) = channel name string */
  2015.                     /* pushed(1) = output request       */
  2016.                     /* pushed(2) = rest of program       */
  2017.  
  2018.     if (!s)                /* problem with filename?       */
  2019.     abandonDialogue(pushed(1));
  2020.     if (strcmp(s,"stdin")!=0)        /* only valid channel == stdin       */
  2021.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  2022.     if (stdinUsed)            /* can't reuse stdin channel!      */
  2023.     return ap(nameFailure,ap(nameReadError,pushed(0)));
  2024.     stdinUsed = TRUE;
  2025.     return ap(nameStr,ap(nameInput,UNIT));
  2026. }
  2027.  
  2028. static Cell local appendChan() {    /* respond to AppendChannel req.   */
  2029.     String s = evalName(pushed(0));    /* pushed(0) = channel name string */
  2030.     FILE   *fp;                /* pushed(1) = output string       */
  2031.     Cell   temp;            /* pushed(2) = output request       */
  2032.                     /* pushed(3) = rest of program       */
  2033.     if (!s)                /* problem with filename?          */
  2034.         abandonDialogue(pushed(2));
  2035.     pushed(2) = NIL;            /* eliminate space leak!       */
  2036.     if ((fp = validOutChannel(s))==0)    /* problem with output channel?       */
  2037.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  2038.     drop();
  2039.     if (nonNull(temp=outputDString(fp)))
  2040.     return ap(nameFailure,ap(nameWriteError,temp));
  2041.     else
  2042.     return nameSuccess;
  2043. }
  2044.  
  2045. static FILE *local validOutChannel(s)    /* return FILE * for valid output  */
  2046. String s; {                /* channel name or 0 otherwise...  */
  2047.     if (strcmp(s,"stdout")==0)
  2048.     return stdout;
  2049.     if (strcmp(s,"stderr")==0)
  2050.     return stderr;
  2051.     if (strcmp(s,"stdecho")==0)        /* in Hugs, stdecho==stdout       */
  2052.     return stdout;
  2053.     return 0;
  2054. }
  2055.  
  2056. static Cell local echo() {        /* respond to Echo request       */
  2057.                         /* pushed(0) = boolean echo status */
  2058.                     /* pushed(1) = echo request       */
  2059.                     /* pushed(2) = rest of program       */
  2060.     static String inUse  = "stdin already in use";
  2061.     static String repeat = "repeated Echo request";
  2062.  
  2063.     if (isNull(evalWithNoError(pushed(0)))) {
  2064.     if (stdinUsed)
  2065.         return ap(nameFailure,ap(nameOtherError,mkStr(findText(inUse))));
  2066.     if (echoChanged)
  2067.         return ap(nameFailure,ap(nameOtherError,mkStr(findText(repeat))));
  2068.     if (whnfHead==nameFalse && whnfArgs==0) {
  2069.         echoChanged = TRUE;
  2070.         noechoTerminal();
  2071.         return nameSuccess;
  2072.     }
  2073.     if (whnfHead==nameTrue && whnfArgs==0) {
  2074.         echoChanged = TRUE;
  2075.         return nameSuccess;
  2076.     }
  2077.     }
  2078.     abandonDialogue(pushed(1));
  2079.     return NIL;/*NOTREACHED*/
  2080. }
  2081.  
  2082. static Cell local getCLArgs() {        /* get command args -- always []   */
  2083.     return ap(nameStrList,nameNil);
  2084. }
  2085.  
  2086. static Cell local getProgName() {    /* get program name -- an error!   */
  2087.     return ap(nameFailure,ap(nameOtherError,nameNil));
  2088. }
  2089.  
  2090. static Cell local getEnv() {        /* get environment variable       */
  2091.     String s = evalName(pushed(0));    /* pushed(0) = variable name string*/
  2092.     String r = 0;            /* pushed(1) = output request       */
  2093.                     /* pushed(2) = rest of program       */
  2094.     if (!s)
  2095.         abandonDialogue(pushed(1));
  2096.     if (r=getenv(s))
  2097.     return ap(nameStr,revOnto(stringOutput(r,NIL),nameNil));
  2098.     else
  2099.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  2100. }
  2101.  
  2102. primFun(primInput) {            /* read single character from stdin*/
  2103.     Int c = readTerminalChar();
  2104.  
  2105.     if (c==EOF || c<0 || c>=NUM_CHARS) {
  2106.     clearerr(stdin);
  2107.     updateRoot(nameNil);
  2108.     }
  2109.     else
  2110.     updapRoot(consChar(c),ap(nameInput,UNIT));
  2111. }
  2112.  
  2113. primFun(primFopen) {            /* open file for reading as str       */
  2114.     Cell   succ = primArg(1);        /*  :: String->a->(String->a)->a   */
  2115.     Cell   fail = primArg(2);
  2116.     String s    = evalName(primArg(3));
  2117.  
  2118.     if (s){
  2119.     Cell file = openFile(s);
  2120.     if (nonNull(file)) {
  2121.         updapRoot(succ,file);
  2122.         return;
  2123.     }
  2124.     }
  2125.     updateRoot(fail);
  2126. }
  2127.  
  2128. static Cell local outputDString(fp)    /* Evaluate string cs and print       */
  2129. FILE *fp; {                /* on specified output stream fp   */
  2130.     Cell temp = NIL;
  2131.     for (;;) {                /* keep reducing and printing head */
  2132.     temp = evalWithNoError(pop());    /* character               */
  2133.     if (nonNull(temp))
  2134.         return printDBadRedex(temp,nameNil);
  2135.     else if (whnfHead==nameCons && whnfArgs==2) {
  2136.         if (nonNull(temp=evalWithNoError(pop())))
  2137.         return printDBadRedex(temp,top());
  2138.         else if (isChar(whnfHead) && whnfArgs==0) {
  2139.         fputc(charOf(whnfHead),fp);
  2140.         if (!writingFile)
  2141.             fflush(fp);
  2142.         }
  2143.         else
  2144.         break;
  2145.     }
  2146.     else if (whnfHead==nameNil && whnfArgs==0) {
  2147.         if (writingFile)
  2148.         fflush(fp);
  2149.         return NIL;
  2150.     }
  2151.     else
  2152.         break;
  2153.     }
  2154.     internal("runtime type error");
  2155.     return nameNil;/*NOTREACHED*/
  2156. }
  2157. #endif
  2158.  
  2159. /* --------------------------------------------------------------------------
  2160.  * Top-level printing mechanism:
  2161.  * ------------------------------------------------------------------------*/
  2162.  
  2163. Cell outputString(fp,cs)        /* Evaluate string cs and print       */
  2164. FILE *fp;                /* on specified output stream fp   */
  2165. Cell cs; {
  2166.     Cell temp;
  2167.  
  2168.     for (;;) {                /* keep reducing and printing head */
  2169.     clearStack();            /* character               */
  2170.     temp = evalWithNoError(cs);
  2171.     if (nonNull(temp))
  2172.         cs = printBadRedex(temp,nameNil);
  2173.     else if (whnfHead==nameCons && whnfArgs==2) {
  2174.         Cell c = pushed(0);
  2175.         cs     = pushed(1);
  2176.  
  2177.         if (nonNull(temp=evalWithNoError(c)))
  2178.         cs = printBadRedex(temp,cs);
  2179.         else if (isChar(whnfHead) && whnfArgs==0) {
  2180.         fputc(charOf(whnfHead),fp);
  2181.             fflush(fp);
  2182.         }
  2183.         else
  2184.         break;
  2185.     }
  2186.     else if (whnfHead==nameNil && whnfArgs==0)
  2187.         return NIL;
  2188.     else
  2189.         break;
  2190.     }
  2191.     internal("runtime type error");
  2192.     return nameNil;/*NOTREACHED*/
  2193. }
  2194.  
  2195. /* --------------------------------------------------------------------------
  2196.  * IO monad implementation,  based on `Lazy State Threads' by Launchbury and
  2197.  * Peyton Jones, PLDI 94.
  2198.  *
  2199.  * type ST s a = State s -> (a, State s)
  2200.  * ------------------------------------------------------------------------*/
  2201.  
  2202. #if IO_MONAD
  2203. Void ioExecute(prog)            /* execute IO monad program of type*/
  2204. Cell prog; {                /* IO ()               */
  2205.     Cell temp;
  2206.     noechoTerminal();
  2207.     if (nonNull(temp=evalWithNoError(ap(prog,UNIT))) ||
  2208.         nonNull(temp=evalWithNoError(pushed(1))))
  2209.     abandon("Program execution",temp);
  2210. }
  2211.  
  2212. primFun(primSTRun) {            /* ST monad encapsulate           */
  2213.     updapRoot(nameFst,            /*  :: all s.(ST s a) -> a       */
  2214.           ap(primArg(1),UNIT));
  2215. }
  2216.  
  2217. primFun(primFst) {            /* fst primitive           */
  2218.     eval(primArg(1));            /*  :: (a,s) -> a           */
  2219.     updateRoot(top());
  2220. }
  2221.  
  2222. primFun(primSnd) {            /* snd primitive           */
  2223.     eval(primArg(1));            /*  :: (a,s) -> s           */
  2224.     updateRoot(pushed(1));
  2225. }
  2226.  
  2227. primFun(primSTReturn) {            /* ST monad return           */
  2228.     updapRoot(mkTuple(2),primArg(1));    /* return    :: a -> ST s a       */
  2229. }                    /* return a   = \s -> (a,s)       */
  2230.  
  2231. primFun(primIOBind) {            /* IO monad bind           */
  2232.     Cell m = primArg(3);        /* :: ST s a ->               */
  2233.     Cell f = primArg(2);        /*     (a -> ST s b) ->           */
  2234.     Cell s = primArg(1);        /*    ST s b               */
  2235.     eval(ap(m,s));
  2236.     updapRoot(ap(f,top()),pushed(1));    /* A strict bind operation on ST   */
  2237. }
  2238.  
  2239. primFun(primSTBind) {            /* ST monad bind           */
  2240.     Cell m = primArg(3);        /* :: ST s a ->               */
  2241.     Cell f = primArg(2);        /*     (a -> ST s b) ->           */
  2242.     Cell s = primArg(1);        /*    ST s b               */
  2243.     Cell r = ap(m,s);            /* lazy version of bind on ST       */
  2244.     updapRoot(ap(f,ap(nameFst,r)),ap(nameSnd,r));
  2245. }
  2246.  
  2247. primFun(primSTInter) {            /* ST monad interleave           */
  2248.     Cell m = primArg(2);        /*  :: ST s a ->           */
  2249.     Cell s = primArg(1);        /*      ST s a               */
  2250.     updapRoot(ap(mkTuple(2),ap(nameFst,ap(m,s))),s);
  2251. }
  2252.  
  2253. primFun(primSTNew) {            /* ST monad variable allocator       */
  2254.     Cell i = primArg(2);        /*  :: a ->               */
  2255.     Cell s = primArg(1);        /*     ST s (MutVar s a)       */
  2256.     eval(s);                /* force evaluation of state       */
  2257.     updapRoot(ap(mkTuple(2),ap(MUTVAR,i)),s);
  2258. }
  2259.  
  2260. primFun(primSTAssign) {            /* ST monad assignment           */
  2261.     Cell v = primArg(3);        /*  :: MutVar s a ->           */
  2262.     Cell e = primArg(2);        /*    a ->               */
  2263.     Cell s = primArg(1);        /*     ST s ()           */
  2264.     eval(s);                /* force evaluation of state       */
  2265.     eval(v);
  2266.     if (!isPair(whnfHead) || fst(whnfHead)!=MUTVAR)
  2267.     internal("type error in assign");
  2268.     snd(whnfHead) = e;            /* Arrgh! impurity! :-)           */
  2269.     updapRoot(ap(mkTuple(2),UNIT),s);
  2270. }
  2271.  
  2272. primFun(primSTDeref) {            /* ST monad dereference           */
  2273.     Cell v = primArg(2);        /*  :: MutVar s a ->           */
  2274.     Cell s = primArg(1);        /*    ST s a               */
  2275.     eval(s);                /* force evaluation of state       */
  2276.     eval(v);
  2277.     if (!isPair(whnfHead) || fst(whnfHead)!=MUTVAR)
  2278.     internal("type error in deref");
  2279.     updapRoot(ap(mkTuple(2),snd(whnfHead)),s);
  2280. }
  2281.  
  2282. primFun(primSTMutVarEq) {        /* ST monad variable equality       */
  2283.     Cell x = primArg(2);        /*  :: MutVar s a ->            */
  2284.     Cell y = primArg(1);        /*      MutVar s a -> Bool       */
  2285.     eval(x);
  2286.     x = whnfHead;
  2287.     eval(y);
  2288.     updateRoot(x==whnfHead ? nameTrue : nameFalse);
  2289. }
  2290.  
  2291. primFun(primIOGetch) {            /* get character from stdin       */
  2292.     Cell s = primArg(1);        /*  :: IO Char               */
  2293.     eval(s);
  2294.     updapRoot(ap(mkTuple(2),mkChar(readTerminalChar())),s);
  2295. }
  2296.  
  2297. primFun(primIOPutchar) {        /* print character on stdout       */
  2298.     Cell c = primArg(2);        /*  :: Char ->               */
  2299.     Cell s = primArg(1);        /*    IO ()               */
  2300.     eval(s);
  2301.     eval(c);
  2302.     putchar(charOf(whnfHead));
  2303.     fflush(stdout);
  2304.     updapRoot(ap(mkTuple(2),UNIT),s);
  2305. }
  2306.  
  2307. #if HASKELL_ARRAYS
  2308. primFun(primSTNewArr) {            /* allocate mutable array       */
  2309.     Cell range  = primArg(4);        /*  :: (a -> Int) ->           */
  2310.     Cell bounds = primArg(3);        /*      (a,a) ->           */
  2311.     Cell z    = primArg(2);        /*     b ->               */
  2312.     Cell s    = primArg(1);        /*      ST s (MutArr s a b)       */
  2313.     Int  size;
  2314.     eval(s);
  2315.     size = getSize(bounds,range);
  2316.     updapRoot(ap(mkTuple(2), ap(ARRAY, ap(bounds,copy(size,z)))), s);
  2317. }
  2318.  
  2319. primFun(primSTReadArr) {        /* read element in mutable array   */
  2320.     Cell index = primArg(4);        /*  :: ((a,a) -> a -> Int) ->       */
  2321.     Cell a     = primArg(3);        /*    MutArr s a b ->           */
  2322.     Cell i     = primArg(2);        /*       a ->               */
  2323.     Cell s     = primArg(1);        /*      ST s b           */
  2324.     Cell vs    = NIL;
  2325.     eval(s);
  2326.     eval(a);
  2327.     vs = snd(whnfHead);
  2328.     eval(ap(ap(index,fst(vs)),i));
  2329.     while (whnfInt-- > 0)
  2330.     vs = snd(vs);
  2331.     updapRoot(ap(mkTuple(2),fst(snd(vs))),s);
  2332. }
  2333.  
  2334. primFun(primSTWriteArr) {        /* write element in mutable array  */
  2335.     Cell index = primArg(5);        /*  :: ((a,a) -> a -> Int) ->       */
  2336.     Cell a     = primArg(4);        /*    MutArr s a b ->           */
  2337.     Cell i     = primArg(3);        /*       a ->               */
  2338.     Cell v     = primArg(2);        /*      b ->               */
  2339.     Cell s     = primArg(1);        /*       ST s ()           */
  2340.     Cell vs    = NIL;
  2341.     eval(s);
  2342.     eval(a);
  2343.     vs = snd(whnfHead);
  2344.     eval(ap(ap(index,fst(vs)),i));
  2345.     while (whnfInt-- > 0)
  2346.     vs = snd(vs);
  2347.     fst(snd(vs)) = v;
  2348.     updapRoot(ap(mkTuple(2),UNIT),s);
  2349. }
  2350.  
  2351. primFun(primSTFreeze) {            /* freeze mutable array           */
  2352.     Cell arr = primArg(2);        /*  :: MutArr s a b ->           */
  2353.     Cell s   = primArg(1);        /*    ST s (Array a b)       */
  2354.     eval(s);
  2355.     eval(arr);
  2356.     updapRoot(ap(mkTuple(2),ap(ARRAY,dupList(snd(whnfHead)))),s);
  2357. }
  2358. #endif
  2359. #endif
  2360.  
  2361. /* --------------------------------------------------------------------------
  2362.  * Build array of character conses:
  2363.  * ------------------------------------------------------------------------*/
  2364.  
  2365. static Cell consCharArray[NUM_CHARS];
  2366.  
  2367. Cell consChar(c)            /* return application (:) c       */
  2368. Char c; {
  2369.     if (c<0)
  2370.     c += NUM_CHARS;
  2371.     return consCharArray[c];
  2372. }
  2373.  
  2374. /* --------------------------------------------------------------------------
  2375.  * Built-in control:
  2376.  * ------------------------------------------------------------------------*/
  2377.  
  2378. Void builtIn(what)
  2379. Int what; {
  2380.     Int i;
  2381.  
  2382.     switch (what) {
  2383. #if IO_DIALOGUE
  2384.     case RESET   : if (writingFile) {
  2385.                fclose(writingFile);
  2386.                writingFile = 0;
  2387.                }
  2388.                break;
  2389. #endif
  2390.  
  2391.     case MARK    : for (i=0; i<NUM_CHARS; ++i)
  2392.                mark(consCharArray[i]);
  2393.                break;
  2394.  
  2395.     case INSTALL : for (i=0; i<NUM_CHARS; ++i)
  2396.                consCharArray[i] = ap(nameCons,mkChar(i));
  2397.  
  2398.                consOpen       = consCharArray['('];
  2399.                consSpace      = consCharArray[' '];
  2400.                consComma      = consCharArray[','];
  2401.                consClose      = consCharArray[')'];
  2402.                consObrace     = consCharArray['{'];
  2403.                consCbrace     = consCharArray['}'];
  2404.                consOsq          = consCharArray['['];
  2405.                consCsq          = consCharArray[']'];
  2406.                consBack       = consCharArray['`'];
  2407.                consMinus      = consCharArray['-'];
  2408.                consQuote      = consCharArray['\''];
  2409.                consDQuote     = consCharArray['\"'];
  2410.  
  2411. #define pFun(n,s,t)    addPrim(0,n=newName(findText(s)),t,NIL)
  2412.                pFun(nameFatbar,       "_FATBAR", "primFatbar");
  2413.                pFun(nameFail,       "_FAIL",   "primFail");
  2414.                pFun(nameIf,       "_IF",     "primIf");
  2415.                pFun(nameSel,       "_SEL",    "primSel");
  2416.  
  2417. #if GENERIC_CMP
  2418.                pFun(namePrimCmp,   "_compare", "primCompare");
  2419. #endif
  2420.                pFun(namePrint,       "_print",   "primPrint");
  2421.                pFun(nameNPrint,       "_nprint",  "primNprint");
  2422.                pFun(nameLPrint,       "_lprint",  "primLprint");
  2423.                pFun(nameNLPrint,   "_nlprint", "primNlprint");
  2424.                pFun(nameSPrint,       "_sprint",  "primSprint");
  2425.                pFun(nameNSPrint,   "_nsprint", "primNsprint");
  2426.  
  2427.                pFun(nameConCmp,       "_concmp",  "primConCmp");
  2428.                pFun(nameEnRange,   "_range",   "primEnRange");
  2429.                pFun(nameEnIndex,   "_index",   "primEnIndex");
  2430.                pFun(nameEnInRng,   "_inRange", "primEnInRng");
  2431.                pFun(nameEnFrom,    "_From",    "primEnFrom");
  2432.                pFun(nameEnFrTo,       "_FromTo",  "primEnFrTo");
  2433.                pFun(nameEnFrTh,       "_FromThen","primEnFrTh");
  2434.  
  2435. #if IO_DIALOGUE
  2436.                pFun(nameInput,       "_input",   "primInput");
  2437. #endif
  2438.                pFun(nameUndefMem,  "_undefined_member", "primUndefMem");
  2439.                pFun(nameMakeMem,   "_makeMember",   "primMakeMem");
  2440.                pFun(nameBlackHole, "Gc Black Hole", "primGCBhole");
  2441. #if    HASKELL_ARRAYS
  2442.                pFun(nameEltUndef,  "_undefined_array_element",
  2443.                             "primEltUndef");
  2444.                pFun(nameOutBounds, "_out_of_bounds","primOutBounds");
  2445. #endif
  2446. #if    IO_MONAD
  2447.                pFun(nameSTRun,       "runST",    "primSTRun");
  2448.                pFun(nameFst,       "_fst",    "primFst");
  2449.                pFun(nameSnd,       "_snd",    "primSnd");
  2450. #endif
  2451. #undef pFun
  2452. #define predef(nm,str) nm=newName(findText(str)); name(nm).defn=PREDEFINED
  2453.                predef(nameAnd,        "&&");
  2454.                predef(nameOr,        "||");
  2455.                predef(nameOtherwise,    "otherwise");
  2456.                predef(nameError,    "error");
  2457.                predef(nameComp,        ".");
  2458.                predef(nameApp,        "++");
  2459.                predef(nameShowParen,    "showParen");
  2460.                predef(nameRangeSize,    "rangeSize");
  2461.                predef(namePmInt,    "primPmInt");
  2462.                predef(namePmInteger,    "primPmInteger");
  2463.                predef(namePmFlt,    "primPmFlt");
  2464. #if NPLUSK
  2465.                predef(namePmNpk,    "primPmNpk");
  2466.                predef(namePmSub,    "primPmSub");
  2467. #endif
  2468. #undef  predef
  2469.                break;
  2470.     }
  2471. }
  2472.  
  2473. /*-------------------------------------------------------------------------*/
  2474.