home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / gofer / Sources / c / prims < prev    next >
Encoding:
Text File  |  1993-02-12  |  48.0 KB  |  1,636 lines
  1. /* --------------------------------------------------------------------------
  2.  * prims.c:     Copyright (c) Mark P Jones 1991-1993.   All rights reserved.
  3.  *              See goferite.h for details and conditions of use etc...
  4.  *              Gofer version 2.28 January 1993
  5.  *
  6.  * Primitive functions, input output etc...
  7.  * if PRIMITIVES_CODE == 0 then the code for PRIMITIVES is excluded: only
  8.  * the primitives table and consChar() parts are retained.
  9.  * ------------------------------------------------------------------------*/
  10.  
  11. #if PRIMITIVES_CODE
  12. #include <ctype.h>
  13. #if (TURBOC | BCC)
  14. #include <io.h>
  15. #endif
  16. #endif
  17.  
  18. /* --------------------------------------------------------------------------
  19.  * Local function prototypes:
  20.  * ------------------------------------------------------------------------*/
  21.  
  22. #if PRIMITIVES_CODE
  23. #define PROTO_PRIM(name)    static Void name Args((StackPtr))
  24. #define primFun(name)        static Void name(root) StackPtr root;
  25. #define primArg(n)        stack(root+n)
  26.  
  27. /* IMPORTANT: the second element of an update must be written first.
  28.  * this is to deal with the case where an INDIRECT tag is written into
  29.  * a Cell before the second value has been set.  If a garbage collection
  30.  * occurs before the second element was set then the INDIRECTion will be
  31.  * (wrongly) elided and result in chaos.  I know.  It happened to me.
  32.  */
  33.  
  34. #define update(l,r)        ((snd(stack(root))=r),(fst(stack(root))=l))
  35. #define updateRoot(c)        update(INDIRECT,c)
  36. #define updapRoot(l,r)        update(l,r)
  37. #define cantReduce()        evalFails(root)
  38.  
  39. PROTO_PRIM(primFatbar);
  40. PROTO_PRIM(primFail);
  41. PROTO_PRIM(primSel);
  42. PROTO_PRIM(primIf);
  43. PROTO_PRIM(primStrict);
  44.  
  45. PROTO_PRIM(primPlusInt);
  46. PROTO_PRIM(primMinusInt);
  47. PROTO_PRIM(primMulInt);
  48. PROTO_PRIM(primDivInt);
  49. PROTO_PRIM(primQuotInt);
  50. PROTO_PRIM(primModInt);
  51. PROTO_PRIM(primRemInt);
  52. PROTO_PRIM(primNegInt);
  53.  
  54. PROTO_PRIM(primCharToInt);
  55. PROTO_PRIM(primIntToChar);
  56. PROTO_PRIM(primIntToFloat);
  57.  
  58. PROTO_PRIM(primPlusFloat);
  59. PROTO_PRIM(primMinusFloat);
  60. PROTO_PRIM(primMulFloat);
  61. PROTO_PRIM(primDivFloat);
  62. PROTO_PRIM(primNegFloat);
  63.  
  64. #if HAS_FLOATS
  65. PROTO_PRIM(primSinFloat);
  66. PROTO_PRIM(primCosFloat);
  67. PROTO_PRIM(primTanFloat);
  68. PROTO_PRIM(primAsinFloat);
  69. PROTO_PRIM(primAcosFloat);
  70. PROTO_PRIM(primAtanFloat);
  71. PROTO_PRIM(primAtan2Float);
  72. PROTO_PRIM(primExpFloat);
  73. PROTO_PRIM(primLogFloat);
  74. PROTO_PRIM(primLog10Float);
  75. PROTO_PRIM(primSqrtFloat);
  76. PROTO_PRIM(primFloatToInt);
  77. #endif
  78.  
  79. PROTO_PRIM(primEqInt);
  80. PROTO_PRIM(primLeInt);
  81.  
  82. PROTO_PRIM(primEqChar);
  83. PROTO_PRIM(primLeChar);
  84.  
  85. PROTO_PRIM(primEqFloat);
  86. PROTO_PRIM(primLeFloat);
  87.  
  88. PROTO_PRIM(primCmp);
  89. PROTO_PRIM(primGenericEq);
  90. PROTO_PRIM(primGenericLe);
  91. PROTO_PRIM(primGenericLt);
  92. PROTO_PRIM(primGenericGe);
  93. PROTO_PRIM(primGenericGt);
  94. PROTO_PRIM(primGenericNe);
  95.  
  96. PROTO_PRIM(primPrint);
  97. PROTO_PRIM(primNPrint);
  98.  
  99. static Void   local printer        Args((StackPtr,Name,Int,Cell));
  100. static Void   local startList        Args((StackPtr,Cell));
  101. static Void   local startNList        Args((StackPtr,Cell));
  102.  
  103. PROTO_PRIM(primLPrint);
  104. PROTO_PRIM(primNLPrint);
  105. PROTO_PRIM(primSPrint);
  106. PROTO_PRIM(primNSPrint);
  107.  
  108. static Cell   local textAsVar        Args((Text,Cell));
  109. static Cell   local textAsOp        Args((Text,Cell));
  110. static Cell   local stringOutput    Args((String,Cell));
  111. static Cell   local printBadRedex    Args((Cell,Cell));
  112.  
  113. static String local evalName        Args((Cell));
  114. static Void   local abandonDialogue    Args((Cell));
  115. static Cell   local printDBadRedex    Args((Cell,Cell));
  116. static Cell   local readFile        Args((Void));
  117. static Cell   local writeFile        Args((Void));
  118. static Cell   local appendFile        Args((Void));
  119. static Cell   local readChan        Args((Void));
  120. static Cell   local appendChan        Args((Void));
  121. static FILE  *local validOutChannel    Args((String));
  122. static Cell   local echo        Args((Void));
  123. static Cell   local getCLArgs        Args((Void));
  124. static Cell   local getProgName        Args((Void));
  125. static Cell   local getEnv        Args((Void));
  126.  
  127. PROTO_PRIM(primInput);
  128. PROTO_PRIM(primFopen);
  129.  
  130. #ifdef LAMBDAVAR
  131. PROTO_PRIM(primLvReturn);
  132. PROTO_PRIM(primLvPure);
  133. PROTO_PRIM(primLvRead);
  134. PROTO_PRIM(primLvBind);
  135. PROTO_PRIM(primLvVar);
  136. PROTO_PRIM(primLvNewvar);
  137. PROTO_PRIM(primLvAssign);
  138. PROTO_PRIM(primLvVarEq);
  139. PROTO_PRIM(primLvGetch);
  140. PROTO_PRIM(primLvPutchar);
  141. PROTO_PRIM(primLvSystem);
  142. #endif
  143.  
  144. #ifdef LAMBDANU
  145. PROTO_PRIM(primLnReturn);
  146. PROTO_PRIM(primLnBind);
  147. PROTO_PRIM(primLnFlip);
  148. PROTO_PRIM(primLnNew);
  149. PROTO_PRIM(primLnAssign);
  150. PROTO_PRIM(primLnRead);
  151. PROTO_PRIM(primLnIo);
  152. PROTO_PRIM(primLnBegin);
  153. PROTO_PRIM(primLnTagEq);
  154. PROTO_PRIM(primLnGetch);
  155. PROTO_PRIM(primLnPutchar);
  156. PROTO_PRIM(primLnSystem);
  157. PROTO_PRIM(primLnDone);
  158. #endif
  159.  
  160. #endif
  161.  
  162. /* --------------------------------------------------------------------------
  163.  * Table of primitive/built-in values:
  164.  * ------------------------------------------------------------------------*/
  165.  
  166. #if PRIMITIVES_CODE
  167. #define GofcPrim(imp)    imp
  168. #define NoGofcPrim(imp)    imp
  169. #else
  170. #define GofcPrim(imp)    PRIM_GOFC
  171. #define NoGofcPrim(imp)    PRIM_NOGOFC
  172. #endif
  173.  
  174. struct primitive primitives[] = {
  175.   {"primFatbar",    2, GofcPrim(primFatbar)},
  176.   {"primFail",        0, GofcPrim(primFail)},
  177.   {"primUndefMem",    1, GofcPrim(primFail)},
  178.   {"primGCBhole",    0, NoGofcPrim(primFail)},
  179.   {"primError",        1, GofcPrim(primFail)},
  180.   {"primSel",        3, GofcPrim(primSel)},
  181.   {"primIf",        3, GofcPrim(primIf)},
  182.  
  183.   {"primCompare",    1, NoGofcPrim(primCmp)},
  184.   {"primInput",        1, NoGofcPrim(primInput)},
  185.   {"primPrint",        3, NoGofcPrim(primPrint)},
  186.   {"primNprint",    3, NoGofcPrim(primNPrint)},
  187.   {"primLprint",    2, NoGofcPrim(primLPrint)},
  188.   {"primNlprint",    2, NoGofcPrim(primNLPrint)},
  189.   {"primSprint",    2, NoGofcPrim(primSPrint)},
  190.   {"primNsprint",    2, NoGofcPrim(primNSPrint)},
  191.  
  192.   {"primPlusInt",    2, GofcPrim(primPlusInt)},
  193.   {"primMinusInt",    2, GofcPrim(primMinusInt)},
  194.   {"primMulInt",    2, GofcPrim(primMulInt)},
  195.   {"primDivInt",    2, GofcPrim(primDivInt)},
  196.   {"primQuotInt",    2, GofcPrim(primQuotInt)},
  197.   {"primModInt",    2, GofcPrim(primModInt)},
  198.   {"primRemInt",    2, GofcPrim(primRemInt)},
  199.   {"primNegInt",    1, GofcPrim(primNegInt)},
  200.  
  201.   {"primPlusFloat",    2, GofcPrim(primPlusFloat)},
  202.   {"primMinusFloat",    2, GofcPrim(primMinusFloat)},
  203.   {"primMulFloat",    2, GofcPrim(primMulFloat)},
  204.   {"primDivFloat",    2, GofcPrim(primDivFloat)},
  205.   {"primNegFloat",    1, GofcPrim(primNegFloat)},
  206.  
  207. #if HAS_FLOATS
  208.   {"primSinFloat",    1, GofcPrim(primSinFloat)},
  209.   {"primCosFloat",    1, GofcPrim(primCosFloat)},
  210.   {"primTanFloat",    1, GofcPrim(primTanFloat)},
  211.   {"primAsinFloat",    1, GofcPrim(primAsinFloat)},
  212.   {"primAcosFloat",    1, GofcPrim(primAcosFloat)},
  213.   {"primAtanFloat",    1, GofcPrim(primAtanFloat)},
  214.   {"primAtan2Float",    2, GofcPrim(primAtan2Float)},
  215.   {"primExpFloat",    1, GofcPrim(primExpFloat)},
  216.   {"primLogFloat",    1, GofcPrim(primLogFloat)},
  217.   {"primLog10Float",    1, GofcPrim(primLog10Float)},
  218.   {"primSqrtFloat",    1, GofcPrim(primSqrtFloat)},
  219.   {"primFloatToInt",    1, GofcPrim(primFloatToInt)},
  220. #endif
  221.  
  222.   {"primIntToChar",    1, GofcPrim(primIntToChar)},
  223.   {"primCharToInt",    1, GofcPrim(primCharToInt)},
  224.   {"primIntToFloat",    1, GofcPrim(primIntToFloat)},
  225.  
  226.   {"primEqInt",        2, GofcPrim(primEqInt)},
  227.   {"primLeInt",        2, GofcPrim(primLeInt)},
  228.   {"primEqChar",    2, GofcPrim(primEqChar)},
  229.   {"primLeChar",    2, GofcPrim(primLeChar)},
  230.   {"primEqFloat",    2, GofcPrim(primEqFloat)},
  231.   {"primLeFloat",    2, GofcPrim(primLeFloat)},
  232.  
  233.   {"primGenericEq",    2, GofcPrim(primGenericEq)},
  234.   {"primGenericNe",    2, GofcPrim(primGenericNe)},
  235.   {"primGenericGt",    2, GofcPrim(primGenericGt)},
  236.   {"primGenericLe",    2, GofcPrim(primGenericLe)},
  237.   {"primGenericGe",    2, GofcPrim(primGenericGe)},
  238.   {"primGenericLt",    2, GofcPrim(primGenericLt)},
  239.  
  240.   {"primPrint",        3, NoGofcPrim(primPrint)},
  241.   {"primShowsInt",    3, GofcPrim(primPrint)},
  242.   {"primShowsFloat",    3, GofcPrim(primPrint)},
  243.  
  244.   {"primStrict",    2, GofcPrim(primStrict)},
  245.  
  246.   {"primFopen",        3, GofcPrim(primFopen)},
  247.  
  248. #ifdef LAMBDAVAR
  249.   {"primLvReturn",    2, NoGofcPrim(primLvReturn)},
  250.   {"primLvPure",    1, NoGofcPrim(primLvPure)},
  251.   {"primLvRead",    3, NoGofcPrim(primLvRead)},
  252.   {"primLvBind",    3, NoGofcPrim(primLvBind)},
  253.   {"primLvVar",        2, NoGofcPrim(primLvVar)},
  254.   {"primLvNewvar",    1, NoGofcPrim(primLvNewvar)},
  255.   {"primLvAssign",    3, NoGofcPrim(primLvAssign)},
  256.   {"primLvVarEq",    2, NoGofcPrim(primLvVarEq)},
  257.   {"primLvUnbound",    0, NoGofcPrim(primFail)},
  258.   {"primLvGetch",    1, NoGofcPrim(primLvGetch)},
  259.   {"primLvPutchar",    2, NoGofcPrim(primLvPutchar)},
  260.   {"primLvSystem",    2, NoGofcPrim(primLvSystem)},
  261. #endif
  262.  
  263. #ifdef LAMBDANU
  264.   {"primLnReturn",    2, NoGofcPrim(primLnReturn)},
  265.   {"primLnBind",    3, NoGofcPrim(primLnBind)},
  266.   {"primLnFlip",    3, NoGofcPrim(primLnFlip)},
  267.   {"primLnNew",        1, NoGofcPrim(primLnNew)},
  268.   {"primLnAssign",    3, NoGofcPrim(primLnAssign)},
  269.   {"primLnRead",    3, NoGofcPrim(primLnRead)},
  270.   {"primLnIo",        2, NoGofcPrim(primLnIo)},
  271.   {"primLnBegin",    1, NoGofcPrim(primLnBegin)},
  272.   {"primLnTagEq",    2, NoGofcPrim(primLnTagEq)},
  273.   {"primLnGetch",    1, NoGofcPrim(primLnGetch)},
  274.   {"primLnPutchar",    2, NoGofcPrim(primLnPutchar)},
  275.   {"primLnSystem",    2, NoGofcPrim(primLnSystem)},
  276.   {"primLnUnbound",    0, NoGofcPrim(primFail)},
  277.   {"primLnNocont",    0, NoGofcPrim(primFail)},
  278.   {"primLnDone",    1, NoGofcPrim(primLnDone)},
  279. #endif
  280.  
  281.   {0,            0, 0}
  282. };
  283.  
  284. /* --------------------------------------------------------------------------
  285.  * Primitive functions:
  286.  * ------------------------------------------------------------------------*/
  287.  
  288. #if PRIMITIVES_CODE
  289. primFun(primFatbar) {            /* Fatbar primitive           */
  290.     Cell l    = primArg(2);        /* _FAIL [] r = r           */
  291.     Cell r    = primArg(1);        /* l     [] r = l  -- otherwise       */
  292.     Cell temp = evalWithNoError(l);
  293.     if (nonNull(temp))
  294.     if (temp==nameFail)
  295.         updateRoot(r);
  296.     else {
  297.         updateRoot(temp);
  298.         cantReduce();
  299.     }
  300.     else
  301.     updateRoot(l);
  302. }
  303.  
  304. primFun(primFail) {               /* Failure primitive           */
  305.     cantReduce();
  306. }
  307.  
  308. primFun(primSel) {               /* Component selection           */
  309.     Cell c = primArg(3);           /* _sel c e n   return nth component*/
  310.     Cell e = primArg(2);           /*           in expression e       */
  311.     Cell n = intOf(primArg(1));        /*           built using cfun c  */
  312.  
  313.     eval(e);
  314.     if (whnfHead==c &&    ((isName(whnfHead) && name(whnfHead).arity==whnfArgs)
  315.               || (isTuple(whnfHead) && tupleOf(whnfHead)==whnfArgs)))
  316.     updateRoot(pushed(n-1));
  317.     else
  318.     cantReduce();
  319. }
  320.  
  321. primFun(primIf) {               /* Conditional primitive        */
  322.     eval(primArg(3));
  323.     if (whnfHead==nameTrue)
  324.     updateRoot(primArg(2));
  325.     else
  326.     updateRoot(primArg(1));
  327. }
  328.  
  329. primFun(primStrict) {               /* Strict application primitive       */
  330.     eval(primArg(1));               /* evaluate 2nd argument        */
  331.     updapRoot(primArg(2),primArg(1));  /* and apply 1st argument to result */
  332. }
  333.  
  334. /* --------------------------------------------------------------------------
  335.  * Integer arithmetic primitives:
  336.  * ------------------------------------------------------------------------*/
  337.  
  338. primFun(primPlusInt) {               /* Integer addition primitive       */
  339.     Int x;
  340.     eval(primArg(2));
  341.     x = whnfInt;
  342.     eval(primArg(1));
  343.     updateRoot(mkInt(x+whnfInt));
  344. }
  345.  
  346. primFun(primMinusInt) {            /* Integer subtraction primitive    */
  347.     Int x;
  348.     eval(primArg(2));
  349.     x = whnfInt;
  350.     eval(primArg(1));
  351.     updateRoot(mkInt(x-whnfInt));
  352. }
  353.  
  354. primFun(primMulInt) {               /* Integer multiplication primitive */
  355.     Int x;
  356.     eval(primArg(2));
  357.     x = whnfInt;
  358.     eval(primArg(1));
  359.     updateRoot(mkInt(x*whnfInt));
  360. }
  361.  
  362. primFun(primQuotInt) {            /* Integer division primitive       */
  363.     Int x;                /* truncated towards zero       */
  364.     eval(primArg(2));
  365.     x = whnfInt;
  366.     eval(primArg(1));
  367.  
  368.     if (whnfInt==0)
  369.     cantReduce();
  370.  
  371.     updateRoot(mkInt(x/whnfInt));
  372. }
  373.  
  374. primFun(primDivInt) {            /* Integer division primitive       */
  375.     Int x,r;                /* truncated towards -ve infinity  */
  376.     eval(primArg(2));
  377.     x = whnfInt;
  378.     eval(primArg(1));
  379.  
  380.     if (whnfInt==0)
  381.     cantReduce();
  382.     r = x%whnfInt;
  383.     x = x/whnfInt;
  384.     if ((whnfInt<0 && r>0) || (whnfInt>0 && r<0))
  385.     x--;
  386.     updateRoot(mkInt(x));
  387. }
  388.  
  389. primFun(primModInt) {               /* Integer modulo primitive       */
  390.     Int x,y;
  391.     eval(primArg(2));
  392.     x = whnfInt;
  393.     eval(primArg(1));
  394.     if (whnfInt==0)
  395.     cantReduce();
  396.     y = x%whnfInt;               /* "... the modulo having the sign  */
  397.     if ((y<0 && whnfInt>0) ||           /*           of the divisor ..." */
  398.     (y>0 && whnfInt<0))           /* See definition on p.91 of Haskell*/
  399.     updateRoot(mkInt(y+whnfInt));  /* report...               */
  400.     else
  401.     updateRoot(mkInt(y));
  402. }
  403.  
  404. primFun(primRemInt) {               /* Integer remainder primitive       */
  405.     Int x;
  406.     eval(primArg(2));               /* div and rem satisfy:           */
  407.     x = whnfInt;               /* (x `div` y)*y + (x `rem` y) == x */
  408.     eval(primArg(1));               /* which is exactly the property    */
  409.     if (whnfInt==0)               /* described in K&R 2:           */
  410.     cantReduce();               /*      (a/b)*b + a%b == a       */
  411.     updateRoot(mkInt(x%whnfInt));
  412. }
  413.  
  414. primFun(primNegInt) {               /* Integer negation primitive       */
  415.     eval(primArg(1));
  416.     updateRoot(mkInt(-whnfInt));
  417. }
  418.  
  419. /* --------------------------------------------------------------------------
  420.  * Coercion primitives:
  421.  * ------------------------------------------------------------------------*/
  422.  
  423. primFun(primCharToInt) {           /* Character to integer primitive   */
  424.     eval(primArg(1));
  425.     updateRoot(mkInt(charOf(whnfHead)));
  426. }
  427.  
  428. primFun(primIntToChar) {           /* Integer to character primitive   */
  429.     eval(primArg(1));
  430.     if (whnfInt<0  || whnfInt>MAXCHARVAL)
  431.     cantReduce();
  432.     updateRoot(mkChar(whnfInt));
  433. }
  434.  
  435. primFun(primIntToFloat) {        /* Integer to Float primitive       */
  436.     eval(primArg(1));
  437.     updateRoot(mkFloat((Float)(whnfInt)));
  438. }
  439.  
  440. /* --------------------------------------------------------------------------
  441.  * Float arithmetic primitives:
  442.  * ------------------------------------------------------------------------*/
  443.  
  444. primFun(primPlusFloat) {           /* Float addition primitive       */
  445.     Float x;
  446.     eval(primArg(2));
  447.     x = whnfFloat;
  448.     eval(primArg(1));
  449.     updateRoot(mkFloat(x+whnfFloat));
  450. }
  451.  
  452. primFun(primMinusFloat) {            /* Float subtraction primitive       */
  453.     Float x;
  454.     eval(primArg(2));
  455.     x = whnfFloat;
  456.     eval(primArg(1));
  457.     updateRoot(mkFloat(x-whnfFloat));
  458. }
  459.  
  460. primFun(primMulFloat) {               /* Float multiplication primitive   */
  461.     Float x;
  462.     eval(primArg(2));
  463.     x = whnfFloat;
  464.     eval(primArg(1));
  465.     updateRoot(mkFloat(x*whnfFloat));
  466. }
  467.  
  468. primFun(primDivFloat) {               /* Float division primitive       */
  469.     Float x;
  470.     eval(primArg(2));
  471.     x = whnfFloat;
  472.     eval(primArg(1));
  473.     if (whnfFloat==0)
  474.     cantReduce();
  475.     updateRoot(mkFloat(x/whnfFloat));
  476. }
  477.  
  478. primFun(primNegFloat) {               /* Float negation primitive       */
  479.     eval(primArg(1));
  480.     updateRoot(mkFloat(-whnfFloat));
  481. }
  482.  
  483. #if HAS_FLOATS
  484. primFun(primSinFloat) {            /* Float sin (trig) primitive       */
  485.     eval(primArg(1));
  486.     updateRoot(mkFloat(sin(whnfFloat)));
  487. }
  488.  
  489. primFun(primCosFloat) {            /* Float cos (trig) primitive       */
  490.     eval(primArg(1));
  491.     updateRoot(mkFloat(cos(whnfFloat)));
  492. }
  493.  
  494. primFun(primTanFloat) {            /* Float tan (trig) primitive       */
  495.     eval(primArg(1));
  496.     updateRoot(mkFloat(tan(whnfFloat)));
  497. }
  498.  
  499. primFun(primAsinFloat) {        /* Float arc sin (trig) primitive  */
  500.     eval(primArg(1));
  501.     updateRoot(mkFloat(asin(whnfFloat)));
  502. }
  503.  
  504. primFun(primAcosFloat) {        /* Float arc cos (trig) primitive  */
  505.     eval(primArg(1));
  506.     updateRoot(mkFloat(acos(whnfFloat)));
  507. }
  508.  
  509. primFun(primAtanFloat) {        /* Float arc tan (trig) primitive  */
  510.     eval(primArg(1));
  511.     updateRoot(mkFloat(atan(whnfFloat)));
  512. }
  513.  
  514. primFun(primAtan2Float) {        /* Float arc tan with quadrant info*/
  515.     Float t;                /*          (trig) primitive  */
  516.     eval(primArg(2));
  517.     t = whnfFloat;
  518.     eval(primArg(1));
  519.     updateRoot(mkFloat(atan2(t,whnfFloat)));
  520. }
  521.  
  522. primFun(primExpFloat) {            /* Float exponential primitive       */
  523.     eval(primArg(1));
  524.     updateRoot(mkFloat(exp(whnfFloat)));
  525. }
  526.  
  527. primFun(primLogFloat) {            /* Float logarithm primitive       */
  528.     eval(primArg(1));
  529.     if (whnfFloat<=0)
  530.     cantReduce();
  531.     updateRoot(mkFloat(log(whnfFloat)));
  532. }
  533.  
  534. primFun(primLog10Float) {        /* Float logarithm (base 10) prim  */
  535.     eval(primArg(1));
  536.     if (whnfFloat<=0)
  537.     cantReduce();
  538.     updateRoot(mkFloat(log10(whnfFloat)));
  539. }
  540.  
  541. primFun(primSqrtFloat) {        /* Float square root primitive       */
  542.     eval(primArg(1));
  543.     if (whnfFloat<0)
  544.     cantReduce();
  545.     updateRoot(mkFloat(sqrt(whnfFloat)));
  546. }
  547.  
  548. primFun(primFloatToInt) {        /* Adhoc Float --> Int conversion  */
  549.     eval(primArg(1));
  550.     updateRoot(mkInt((Int)(whnfFloat)));
  551. }
  552. #endif
  553.  
  554. /* --------------------------------------------------------------------------
  555.  * Comparison primitives:
  556.  * ------------------------------------------------------------------------*/
  557.  
  558. primFun(primEqInt) {               /* Integer equality primitive       */
  559.     Int x;
  560.     eval(primArg(2));
  561.     x = whnfInt;
  562.     eval(primArg(1));
  563.     updateRoot(x==whnfInt ? nameTrue : nameFalse);
  564. }
  565.  
  566. primFun(primLeInt) {               /* Integer <= primitive           */
  567.     Int x;
  568.     eval(primArg(2));
  569.     x = whnfInt;
  570.     eval(primArg(1));
  571.     updateRoot(x<=whnfInt ? nameTrue : nameFalse);
  572. }
  573.  
  574. primFun(primEqChar) {               /* Character equality primitive       */
  575.     Cell x;
  576.     eval(primArg(2));
  577.     x = whnfHead;
  578.     eval(primArg(1));
  579.     updateRoot(x==whnfHead ? nameTrue : nameFalse);
  580. }
  581.  
  582. primFun(primLeChar) {               /* Character <= primitive       */
  583.     Cell x;
  584.     eval(primArg(2));
  585.     x = whnfHead;
  586.     eval(primArg(1));
  587.     updateRoot(x<=whnfHead ? nameTrue : nameFalse);
  588. }
  589.  
  590. primFun(primEqFloat) {               /* Float equality primitive       */
  591.     Float x;
  592.     eval(primArg(2));
  593.     x = whnfFloat;
  594.     eval(primArg(1));
  595.     updateRoot(x==whnfFloat ? nameTrue : nameFalse);
  596. }
  597.  
  598. primFun(primLeFloat) {               /* Float <= primitive           */
  599.     Float x;
  600.     eval(primArg(2));
  601.     x = whnfFloat;
  602.     eval(primArg(1));
  603.     updateRoot(x<=whnfFloat ? nameTrue : nameFalse);
  604. }
  605.  
  606. /* Generic comparisons implemented using the internal primitive function:
  607.  *
  608.  * primCmp []            = EQ
  609.  *         ((C xs, D ys):rs)
  610.  *       | C < D        = LT
  611.  *       | C == D        = primCmp (zip xs ys ++ rs)
  612.  *       | C > D        = GT
  613.  *       ((Int n, Int m):rs)
  614.  *       | n < m        = LT
  615.  *       | n == m        = primCmp rs
  616.  *       | n > m        = GT
  617.  *       etc ... similar for comparison of characters:
  618.  *
  619.  * The list argument to primCmp is represented as an `internal list';
  620.  * i.e. no (:)/[] constructors - use internal cons and NIL instead!
  621.  *
  622.  * To compare two values x and y, evaluate primCmp [(x,y)] and use result.
  623.  */
  624.  
  625. #define LT            1
  626. #define EQ            2
  627. #define GT            3
  628. #define compResult(x) updateRoot(mkInt(x))
  629.  
  630. static Name namePrimCmp;
  631.  
  632. primFun(primCmp) {            /* generic comparison function       */
  633.     Cell rs = primArg(1);
  634.  
  635.     if (isNull(rs)) {
  636.     compResult(EQ);
  637.     return;
  638.     }
  639.     else {
  640.     Cell x = fst(hd(rs));
  641.     Cell y = snd(hd(rs));
  642.     Int  whnfArgs1;
  643.     Cell whnfHead1;
  644.  
  645.     rs = tl(rs);
  646.     eval(x);
  647.     whnfArgs1 = whnfArgs;
  648.     whnfHead1 = whnfHead;
  649.  
  650.     switch (whatIs(whnfHead1)) {
  651.         case INTCELL  : if (whnfArgs==0) {        /* compare ints    */
  652.                 eval(y);
  653.                 if (!isInt(whnfHead) || whnfArgs!=0)
  654.                     break;
  655.                 if (intOf(whnfHead1) > whnfInt)
  656.                     compResult(GT);
  657.                 else if (intOf(whnfHead1) < whnfInt)
  658.                     compResult(LT);
  659.                 else
  660.                     updapRoot(namePrimCmp,rs);
  661.                 return;
  662.                 }
  663.                 break;
  664.  
  665.         case FLOATCELL: if (whnfArgs==0) {        /* compare floats  */
  666.                 eval(y);
  667.                 if (!isFloat(whnfHead) || whnfArgs!=0)
  668.                     break;
  669.                 if (floatOf(whnfHead1) > whnfFloat)
  670.                     compResult(GT);
  671.                 else if (floatOf(whnfHead1) < whnfFloat)
  672.                     compResult(LT);
  673.                 else
  674.                     updapRoot(namePrimCmp,rs);
  675.                 return;
  676.                 }
  677.                 break;
  678.  
  679.         case CHARCELL : if (whnfArgs==0) {        /* compare chars   */
  680.                 eval(y);
  681.                 if (!isChar(whnfHead) || whnfArgs!=0)
  682.                     break;
  683.                 if (charOf(whnfHead1) > charOf(whnfHead))
  684.                     compResult(GT);
  685.                 else if (charOf(whnfHead1) < charOf(whnfHead))
  686.                     compResult(LT);
  687.                 else
  688.                     updapRoot(namePrimCmp,rs);
  689.                 return;
  690.                 }
  691.                 break;
  692.  
  693.         default      : eval(y);            /* compare structs */
  694.                 if (whnfHead1==whnfHead &&
  695.                 whnfArgs1==whnfArgs &&
  696.                 (whnfHead==UNIT    ||
  697.                  isTuple(whnfHead) ||
  698.                  (isName(whnfHead) &&
  699.                   name(whnfHead).defn==CFUN))) {
  700.                 while (whnfArgs1-- >0)
  701.                     rs = cons(pair(pushed(whnfArgs+whnfArgs1),
  702.                            pushed(whnfArgs1)),rs);
  703.                 updapRoot(namePrimCmp,rs);
  704.                 return;
  705.                 }
  706.                 if (isName(whnfHead1)        &&
  707.                  name(whnfHead1).defn==CFUN &&
  708.                  isName(whnfHead)        &&
  709.                  name(whnfHead).defn==CFUN) {
  710.                 if (name(whnfHead1).number
  711.                         > name(whnfHead).number)
  712.                     compResult(GT);
  713.                 else if (name(whnfHead1).number
  714.                         < name(whnfHead).number)
  715.                     compResult(LT);
  716.                 else
  717.                     break;
  718.                 return;
  719.                 }
  720.                             break;
  721.     }
  722.         /* we're going to fail because we can't compare x and y; modify    */
  723.     /* the root expression so that it looks reasonable before failing  */
  724.     /* i.e. output produced will be:  {_compare x y}           */
  725.     updapRoot(ap(namePrimCmp,x),y);
  726.     }
  727.     cantReduce();
  728. }
  729.  
  730. primFun(primGenericEq) {        /* Generic equality test       */
  731.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  732.     eval(c);
  733.     updateRoot(whnfInt==EQ ? nameTrue : nameFalse);
  734. }
  735.  
  736. primFun(primGenericLe) {        /* Generic <= test           */
  737.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  738.     eval(c);
  739.     updateRoot(whnfInt<=EQ ? nameTrue : nameFalse);
  740. }
  741.  
  742. primFun(primGenericLt) {        /* Generic < test           */
  743.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  744.     eval(c);
  745.     updateRoot(whnfInt<EQ ? nameTrue : nameFalse);
  746. }
  747.  
  748. primFun(primGenericGe) {        /* Generic >= test           */
  749.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  750.     eval(c);
  751.     updateRoot(whnfInt>=EQ ? nameTrue : nameFalse);
  752. }
  753.  
  754. primFun(primGenericGt) {        /* Generic > test           */
  755.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  756.     eval(c);
  757.     updateRoot(whnfInt>EQ ? nameTrue : nameFalse);
  758. }
  759.  
  760. primFun(primGenericNe) {        /* Generic /= test           */
  761.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  762.     eval(c);
  763.     updateRoot(whnfInt!=EQ ? nameTrue : nameFalse);
  764. }
  765.  
  766. /* --------------------------------------------------------------------------
  767.  * Print primitives:
  768.  * ------------------------------------------------------------------------*/
  769.  
  770. static Cell consOpen,    consSpace,  consComma,    consClose;
  771. static Cell consObrace, consCbrace, consOsq,    consCsq;
  772. static Cell consBack,    consMinus,  consQuote,  consDQuote;
  773.  
  774. static Name nameLPrint, nameNLPrint;    /* list printing primitives       */
  775. static Name nameSPrint, nameNSPrint;    /* string printing primitives       */
  776.  
  777. #define print(pr,d,e,ss)    ap(ap(ap(pr,mkInt(d)),e),ss)
  778. #define lprint(pr,xs,ss)    ap(ap(pr,xs),ss)
  779. #define printString(s,ss)   revOnto(stringOutput(s,NIL),ss)
  780. #define printSChar(c,ss)    printString(unlexChar(c,'\"'),ss)
  781.  
  782. primFun(primPrint) {            /* evaluate and print term       */
  783.     Int  d    = intOf(primArg(3));    /*    :: Int->Expr->[Char]->[Char] */
  784.     Cell e    = primArg(2);
  785.     Cell ss   = primArg(1);
  786.     Cell temp = evalWithNoError(e);
  787.     if (nonNull(temp))
  788.     updateRoot(printBadRedex(temp,ss));
  789.     else
  790.     printer(root,namePrint,d,ss);
  791. }
  792.  
  793. primFun(primNPrint) {            /* print term without evaluation   */
  794.     Int    d      = intOf(primArg(3)); /*     :: Int->Expr->[Char]->[Char] */
  795.     Cell   e      = primArg(2);
  796.     Cell   ss      = primArg(1);
  797.     unwind(e);
  798.     printer(root,nameNPrint,d,ss);
  799. }
  800.  
  801. static Void local printer(root,pr,d,ss)    /* Main part: primPrint/primNPrint */
  802. StackPtr root;                /* root or print redex           */
  803. Name     pr;                /* printer to use on components       */
  804. Int     d;                /* precedence level           */
  805. Cell     ss; {                /* rest of output           */
  806.     Int  used    = 0;
  807.     Cell output = NIL;
  808.  
  809.     switch(whatIs(whnfHead)) {
  810.  
  811.     case NAME     : {   Syntax sy = syntaxOf(name(whnfHead).text);
  812.  
  813.                 if (name(whnfHead).defn!=CFUN ||
  814.                     name(whnfHead).arity>whnfArgs)
  815.                 pr = nameNPrint;
  816.  
  817.                 if (whnfHead==nameCons && whnfArgs==2) {/*list */
  818.                 if (pr==namePrint)
  819.                     startList(root,ss);
  820.                 else
  821.                     startNList(root,ss);
  822.                 return;
  823.                 }
  824.                 if (whnfArgs==1 && sy!=APPLIC) {      /* (e1+) */
  825.                 used   = 1;
  826.                 output = ap(consClose,
  827.                       textAsOp(name(whnfHead).text,
  828.                        ap(consSpace,
  829.                         print(pr,FUN_PREC-1,pushed(0),
  830.                          ap(consOpen,NIL)))));
  831.                 }
  832.                 else if (whnfArgs>=2 && sy!=APPLIC) { /* e1+e2 */
  833.                 Syntax a = assocOf(sy);
  834.                 Int    p = precOf(sy);
  835.                 used     = 2;
  836.                 if (whnfArgs>2 || d>p)
  837.                      output = ap(consOpen,output);
  838.                 output = print(pr,(a==RIGHT_ASS?p:1+p),
  839.                           pushed(1),
  840.                       ap(consSpace,
  841.                        textAsOp(name(whnfHead).text,
  842.                         ap(consSpace,
  843.                          print(pr,(a==LEFT_ASS? p:1+p),
  844.                           pushed(0),
  845.                           output)))));
  846.                 if (whnfArgs>2 || d>p)
  847.                     output = ap(consClose,output);
  848.                 }
  849.                 else                  /* f ... */
  850.                 output = textAsVar(name(whnfHead).text,NIL);
  851.             }
  852.             break;
  853.  
  854.     case INTCELL  : {   Int digit;
  855.  
  856.                 if (intOf(whnfHead)<0 && d>=FUN_PREC)
  857.                 output = ap(consClose,output);
  858.  
  859.                 do {
  860.                 digit = whnfInt%10;
  861.                 if (digit<0)
  862.                     digit= (-digit);
  863.                 output = ap(consChar('0'+digit),output);
  864.                 } while ((whnfInt/=10)!=0);
  865.  
  866.                 if (intOf(whnfHead)<0) {
  867.                 output = ap(consMinus,output);
  868.                 if (d>=FUN_PREC)
  869.                     output = ap(consOpen,output);
  870.                 }
  871.  
  872.                 output = rev(output);
  873.                 pr       = nameNPrint;
  874.             }
  875.             break;
  876.  
  877.     case UNIT     : output = ap(consClose,ap(consOpen,NIL));
  878.             pr     = nameNPrint;
  879.             break;
  880.  
  881.     case TUPLE    : {   Int  tn   = tupleOf(whnfHead);
  882.                             Cell punc = consOpen;
  883.                 Int  i;
  884.  
  885.                 used      = tn<whnfArgs ? tn : whnfArgs;
  886.                 output    = NIL;
  887.                 for (i=0; i<used; ++i) {
  888.                 output = print(pr,MIN_PREC,pushed(i),
  889.                       ap(punc,
  890.                        output));
  891.                 punc   = consComma;
  892.                 }
  893.                 for (; i<tn; ++i) {
  894.                 output = ap(punc,output);
  895.                 punc   = consComma;
  896.                 }
  897.                 output = ap(consClose,output);
  898.             }
  899.             pr = nameNPrint;
  900.             break;
  901.  
  902.     case CHARCELL : output = ap(consQuote,
  903.                                   stringOutput(unlexChar(charOf(whnfHead),
  904.                                                          '\''),
  905.                    ap(consQuote,
  906.                     output)));
  907.             pr     = nameNPrint;
  908.             break;
  909.  
  910.     case FLOATCELL: output = stringOutput(floatToString(whnfFloat),
  911.                           output);
  912.             pr     = nameNPrint;
  913.             break;
  914.  
  915.         case DICTCELL : output = stringOutput("{dict}",output);
  916.             pr     = nameNPrint;
  917.             break;
  918.  
  919.     case FILECELL : output = stringOutput("{file}",output);
  920.             pr     = nameNPrint;
  921.             break;
  922.  
  923.     default       : internal("Error in graph");
  924.             break;
  925.     }
  926.  
  927.     if (used<whnfArgs) {        /* Add remaining args to output       */
  928.     do
  929.         output = print(pr,FUN_PREC,pushed(used),ap(consSpace,output));
  930.     while (++used<whnfArgs);
  931.  
  932.     if (d>=FUN_PREC) {        /* Determine if parens are needed  */
  933.         updapRoot(consOpen,revOnto(output,ap(consClose,ss)));
  934.         return;
  935.     }
  936.     }
  937.  
  938.     updateRoot(revOnto(output,ss));
  939. }
  940.  
  941. /* --------------------------------------------------------------------------
  942.  * List printing primitives:
  943.  * ------------------------------------------------------------------------*/
  944.  
  945. static Void local startList(root,ss)    /* start printing evaluated list   */
  946. StackPtr root;
  947. Cell     ss; {
  948.     Cell x    = pushed(0);
  949.     Cell xs   = pushed(1);
  950.     Cell temp = evalWithNoError(x);
  951.     if (nonNull(temp))
  952.     updapRoot(consOsq,
  953.            printBadRedex(temp,
  954.             lprint(nameLPrint,xs,ss)));
  955.     else if (isChar(whnfHead) && whnfArgs==0)
  956.     updapRoot(consDQuote,
  957.            printSChar(charOf(whnfHead),
  958.             lprint(nameSPrint,xs,ss)));
  959.     else
  960.     updapRoot(consOsq,
  961.            print(namePrint,MIN_PREC,x,
  962.             lprint(nameLPrint,xs,ss)));
  963. }
  964.  
  965. static Void local startNList(root,ss)    /* start printing unevaluated list */
  966. StackPtr root;
  967. Cell     ss; {
  968.     Cell x    = pushed(0);
  969.     Cell xs   = pushed(1);
  970.     unwind(x);
  971.     if (isChar(whnfHead) && whnfArgs==0)
  972.     updapRoot(consDQuote,
  973.            printSChar(charOf(whnfHead),
  974.             lprint(nameNSPrint,xs,ss)));
  975.     else
  976.     updapRoot(consOsq,
  977.            print(nameNPrint,MIN_PREC,x,
  978.             lprint(nameNLPrint,xs,ss)));
  979. }
  980.  
  981. primFun(primLPrint) {            /* evaluate and print list       */
  982.     Cell e    = primArg(2);
  983.     Cell ss   = primArg(1);
  984.     Cell temp = evalWithNoError(e);
  985.  
  986.     if (nonNull(temp))
  987.     updateRoot(printString("] ++ ",printBadRedex(temp,ss)));
  988.     else if (whnfHead==nameCons && whnfArgs==2)
  989.     updapRoot(consComma,
  990.            ap(consSpace,
  991.             print(namePrint,MIN_PREC,pushed(0),
  992.              lprint(nameLPrint,pushed(1),ss))));
  993.     else if (whnfHead==nameNil && whnfArgs==0)
  994.     updapRoot(consCsq,ss);
  995.     else
  996.     updateRoot(printString("] ++ ",printBadRedex(e,ss)));
  997. }
  998.  
  999. primFun(primNLPrint) {            /* print list without evaluation   */
  1000.     Cell e  = primArg(2);
  1001.     Cell ss = primArg(1);
  1002.     unwind(e);
  1003.     if (whnfHead==nameCons && whnfArgs==2)
  1004.     updapRoot(consComma,
  1005.            ap(consSpace,
  1006.             print(nameNPrint,MIN_PREC,pushed(0),
  1007.              lprint(nameNLPrint,pushed(1),ss))));
  1008.     else if (whnfHead==nameNil && whnfArgs==0)
  1009.     updapRoot(consCsq,ss);
  1010.     else
  1011.     updateRoot(printString("] ++ ",print(nameNPrint,FUN_PREC-1,e,ss)));
  1012. }
  1013.  
  1014. primFun(primSPrint) {            /* evaluate and print string       */
  1015.     Cell e    = primArg(2);
  1016.     Cell ss   = primArg(1);
  1017.     Cell temp = evalWithNoError(e);
  1018.  
  1019.     if (nonNull(temp))
  1020.     updateRoot(printString("\" ++ ",printBadRedex(temp,ss)));
  1021.     else if (whnfHead==nameCons && whnfArgs==2) {
  1022.     Cell x  = pushed(0);
  1023.     Cell xs = pushed(1);
  1024.     temp    = evalWithNoError(x);
  1025.     if (nonNull(temp))
  1026.         updateRoot(printString("\" ++ [",
  1027.             printBadRedex(temp,
  1028.              lprint(nameLPrint,xs,ss))));
  1029.     else if (isChar(whnfHead) && whnfArgs==0)
  1030.         updateRoot(printSChar(charOf(whnfHead),
  1031.                 lprint(nameSPrint,xs,ss)));
  1032.     else
  1033.         updateRoot(printString("\" ++ [",
  1034.             printBadRedex(x,
  1035.              lprint(nameLPrint,xs,ss))));
  1036.     }
  1037.     else if (whnfHead==nameNil && whnfArgs==0)
  1038.     updapRoot(consDQuote,ss);
  1039.     else
  1040.     updateRoot(printString("\" ++ ",printBadRedex(e,ss)));
  1041. }
  1042.  
  1043. primFun(primNSPrint) {            /* print string without eval       */
  1044.     Cell e  = primArg(2);
  1045.     Cell ss = primArg(1);
  1046.     unwind(e);
  1047.     if (whnfHead==nameCons && whnfArgs==2) {
  1048.     Cell x  = pushed(0);
  1049.     Cell xs = pushed(1);
  1050.     unwind(x);
  1051.     if (isChar(whnfHead) && whnfArgs==0)
  1052.         updateRoot(printSChar(charOf(whnfHead),
  1053.                 lprint(nameNSPrint,xs,ss)));
  1054.     else
  1055.         updateRoot(printString("\" ++ [",
  1056.             print(nameNPrint,MIN_PREC,x,
  1057.              lprint(nameNLPrint,xs,ss))));
  1058.     }
  1059.     else if (whnfHead==nameNil && whnfArgs==0)
  1060.     updapRoot(consDQuote,ss);
  1061.     else
  1062.     updateRoot(printString("\" ++ ",print(nameNPrint,FUN_PREC-1,e,ss)));
  1063. }
  1064.  
  1065. /* --------------------------------------------------------------------------
  1066.  * Auxiliary functions for printer(s):
  1067.  * ------------------------------------------------------------------------*/
  1068.  
  1069. static Cell local textAsVar(t,ss)    /* reverse t as function symbol       */
  1070. Text t;                    /* onto output ss           */
  1071. Cell ss; {
  1072.     String s = textToStr(t);
  1073.     if ((isascii(s[0]) && isalpha(s[0])) || s[0]=='_' || strcmp(s,"[]")==0)
  1074.     return stringOutput(s,ss);
  1075.     else
  1076.     return ap(consClose,stringOutput(s,ap(consOpen,ss)));
  1077. }
  1078.  
  1079. static Cell local textAsOp(t,ss)    /* reverse t as op. symbol onto ss */
  1080. Text t;
  1081. Cell ss; {
  1082.     String s = textToStr(t);
  1083.     if (isascii(s[0]) && isalpha(s[0]))
  1084.     return ap(consBack,stringOutput(s,ap(consBack,ss)));
  1085.     else
  1086.     return stringOutput(s,ss);
  1087. }
  1088.  
  1089. static Cell local stringOutput(s,ss)    /* reverse string s onto output ss */
  1090. String s;
  1091. Cell   ss; {
  1092.     while (*s)
  1093.     ss = ap(consChar(*s++),ss);
  1094.     return ss;
  1095. }
  1096.  
  1097. static Cell local printBadRedex(rx,rs)    /* Produce expression to print bad */
  1098. Cell rx, rs; {                /* redex and then print rest ...   */
  1099.     return ap(consObrace,
  1100.         print(nameNPrint,MIN_PREC,rx,
  1101.          ap(consCbrace,
  1102.           rs)));
  1103. }
  1104.  
  1105. Void abandon(what,rx)            /* abandon computation           */
  1106. String what;
  1107. Cell   rx; {
  1108.     outputString(errorStream,
  1109.          revOnto(stringOutput("\n",NIL),
  1110.          revOnto(stringOutput(what,NIL),
  1111.          revOnto(stringOutput(" error: ",NIL),
  1112.              printDBadRedex(rx,nameNil)))),TRUE);
  1113.     errAbort();
  1114. }
  1115.  
  1116. /* --------------------------------------------------------------------------
  1117.  * Evaluate name, obtaining a C string from a Gofer string:
  1118.  * ------------------------------------------------------------------------*/
  1119.  
  1120. static String local evalName(es)    /* evaluate es :: [Char] and save  */
  1121. Cell es; {                /* in char array... return ptr to  */
  1122.     static char buffer[FILENAME_MAX+1];    /* string or 0, if error occurs       */
  1123.     Int         pos    = 0;
  1124.     StackPtr    saveSp = sp;
  1125.  
  1126.     while (isNull(evalWithNoError(es)))
  1127.     if (whnfHead==nameCons && whnfArgs==2) {
  1128.         Cell e = pop();        /* avoid leaving anything on stack */
  1129.         es       = pop();
  1130.         if (isNull(evalWithNoError(e))
  1131.             && isChar(whnfHead) && whnfArgs==0
  1132.             && pos<FILENAME_MAX)
  1133.         buffer[pos++] = charOf(whnfHead);
  1134.         else
  1135.         break;
  1136.     }
  1137.     else if (whnfHead==nameNil && whnfArgs==0) {
  1138.         buffer[pos] = '\0';
  1139.         return buffer;
  1140.     }
  1141.     else
  1142.         break;
  1143.  
  1144.     sp = saveSp;            /* stack pointer must be the same  */
  1145.     return 0;                /* as it was on entry           */
  1146. }
  1147.  
  1148. /* --------------------------------------------------------------------------
  1149.  * Dialogue based input/output:
  1150.  *
  1151.  * N.B. take care when modifying this code - it is rather delicate and even
  1152.  * the simplest of changes might create a nasty space leak... you have been
  1153.  * warned (please let me know if you think there already is a space leak!).
  1154.  * ------------------------------------------------------------------------*/
  1155.  
  1156. static Name nameInput;            /* For reading from stdin       */
  1157. static Bool echoChanged;        /* TRUE => echo changed in dialogue*/
  1158. static Bool stdinUsed;            /* TRUE => ReadChan stdin has been */
  1159.                     /*       seen in dialogue       */
  1160. static FILE *writingFile = 0;        /* points to file open for writing */
  1161.  
  1162. Void dialogue(prog)            /* carry out dialogue ...       */
  1163. Cell prog; {                /* :: Dialog=[Response]->[Request] */
  1164.     static String ioerr = "Attempt to read response before request complete";
  1165.     Cell tooStrict      = mkStr(findText(ioerr));
  1166.     Cell resps        = prog = ap(prog,NIL);
  1167.     Cell temp;
  1168.  
  1169.     echoChanged = FALSE;
  1170.     stdinUsed   = FALSE;
  1171.     for (;;) {                /* Keep Responding to Requests       */
  1172.     resps = snd(resps) = ap(nameError,tooStrict);
  1173.         clearStack();
  1174.     if (nonNull(temp=evalWithNoError(prog)))
  1175.         abandonDialogue(temp);
  1176.     else if (whnfHead==nameCons && whnfArgs==2) {
  1177.         if (nonNull(temp=evalWithNoError(pushed(0))))
  1178.         abandonDialogue(temp);
  1179.  
  1180.         prog = pushed(1+whnfArgs);
  1181.  
  1182.         if (whnfHead==nameReadFile && whnfArgs==1)
  1183.         fst(resps) = ap(nameCons,readFile());
  1184.         else if (whnfHead==nameWriteFile && whnfArgs==2)
  1185.         fst(resps) = ap(nameCons,writeFile());
  1186.         else if (whnfHead==nameAppendFile && whnfArgs==2)
  1187.         fst(resps) = ap(nameCons,appendFile());
  1188.         else if (whnfHead==nameReadChan && whnfArgs==1)
  1189.         fst(resps) = ap(nameCons,readChan());
  1190.         else if (whnfHead==nameAppendChan && whnfArgs==2)
  1191.         fst(resps) = ap(nameCons,appendChan());
  1192.         else if (whnfHead==nameEcho && whnfArgs==1)
  1193.         fst(resps) = ap(nameCons,echo());
  1194.         else if (whnfHead==nameGetArgs && whnfArgs==0)
  1195.         fst(resps) = ap(nameCons,getCLArgs());
  1196.         else if (whnfHead==nameGetProgName && whnfArgs==0)
  1197.         fst(resps) = ap(nameCons,getProgName());
  1198.         else if (whnfHead==nameGetEnv && whnfArgs==1)
  1199.         fst(resps) = ap(nameCons,getEnv());
  1200.         else
  1201.         abandonDialogue(pushed(whnfArgs));
  1202.     }
  1203.     else if (whnfHead==nameNil && whnfArgs==0) {
  1204.         normalTerminal();
  1205.         return;
  1206.     }
  1207.     else
  1208.         internal("Type error during Dialogue");
  1209.     }
  1210. }
  1211.  
  1212. static Void local abandonDialogue(rx)    /* abandon dialogue after failure  */
  1213. Cell rx; {                /* to reduce redex rx           */
  1214.     abandon("Dialogue",rx);
  1215. }
  1216.  
  1217. static Cell local printDBadRedex(rx,rs) /* Produce expression for bad redex*/
  1218. Cell rx, rs; {                /* within a Dialogue, with special */
  1219.     if (isAp(rx) && fun(rx)==nameError) /* handling of {error str} redexes */
  1220.     return arg(rx);
  1221.     else
  1222.     return printBadRedex(rx,rs);
  1223. }
  1224.  
  1225. static Cell local readFile() {        /* repond to ReadFile request       */
  1226.     String s    = evalName(pushed(0));    /* pushed(0) = file name string       */
  1227.     Cell   temp = NIL;            /* pushed(1) = ReadFile request       */
  1228.                     /* pushed(2) = rest of program       */
  1229.  
  1230.     if (!s)                /* problem with filename?       */
  1231.     abandonDialogue(pushed(1));
  1232.     if (access(s,0)!=0)            /* can't find file           */ 
  1233.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  1234.     if (isNull(temp = openFile(s)))    /* can't open file           */
  1235.     return ap(nameFailure,ap(nameReadError,pushed(0)));
  1236.     return ap(nameStr,temp);        /* otherwise we got a file!       */
  1237. }
  1238.  
  1239. static Cell local writeFile() {        /* respond to WriteFile req.       */
  1240.     String s    = evalName(pushed(0));    /* pushed(0) = file name string       */
  1241.     FILE   *fp;                /* pushed(1) = output string       */
  1242.     Cell   temp;            /* pushed(2) = output request       */
  1243.                     /* pushed(3) = rest of program       */
  1244.  
  1245.     if (!s)                /* problem with filename?          */
  1246.         abandonDialogue(pushed(2));
  1247.     if ((fp=fopen(s,FOPEN_WRITE))==0)    /* problem with output file?       */
  1248.     return ap(nameFailure,ap(nameWriteError,pushed(0)));
  1249.     writingFile = fp;
  1250.     temp        = outputString(fp,pushed(1),FALSE);
  1251.     fclose(fp);
  1252.     writingFile = 0;
  1253.     if (nonNull(temp))
  1254.     return ap(nameFailure,ap(nameWriteError,temp));
  1255.     else
  1256.     return nameSuccess;
  1257. }
  1258.  
  1259. static Cell local appendFile() {    /* respond to AppendFile req.       */
  1260.     String s    = evalName(pushed(0));    /* pushed(0) = file name string       */
  1261.     FILE   *fp;                /* pushed(1) = output string       */
  1262.     Cell   temp;            /* pushed(2) = output request       */
  1263.                     /* pushed(3) = rest of program       */
  1264.  
  1265.     if (!s)                /* problem with filename?          */
  1266.         abandonDialogue(pushed(2));
  1267.     if (access(s,0)!=0)            /* can't find file?           */
  1268.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  1269.     if ((fp=fopen(s,FOPEN_APPEND))==0)    /* problem with output file?       */
  1270.     return ap(nameFailure,ap(nameWriteError,pushed(0)));
  1271.     writingFile = fp;
  1272.     temp        = outputString(fp,pushed(1),FALSE);
  1273.     fclose(fp);
  1274.     writingFile = 0;
  1275.     if (nonNull(temp))
  1276.     return ap(nameFailure,ap(nameWriteError,temp));
  1277.     else
  1278.     return nameSuccess;
  1279. }
  1280.  
  1281. static Cell local readChan() {        /* respond to readChan req.       */
  1282.     String s    = evalName(pushed(0));    /* pushed(0) = channel name string */
  1283.                     /* pushed(1) = output request       */
  1284.                     /* pushed(2) = rest of program       */
  1285.  
  1286.     if (!s)                /* problem with filename?       */
  1287.     abandonDialogue(pushed(1));
  1288.     if (strcmp(s,"stdin")!=0)        /* only valid channel == stdin       */
  1289.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  1290.     if (stdinUsed)            /* can't reuse stdin channel!      */
  1291.     return ap(nameFailure,ap(nameReadError,pushed(0)));
  1292.     stdinUsed = TRUE;
  1293.     return ap(nameStr,ap(nameInput,UNIT));
  1294. }
  1295.  
  1296. static Cell local appendChan() {    /* respond to AppendChannel req.   */
  1297.     String s    = evalName(pushed(0));    /* pushed(0) = channel name string */
  1298.     FILE   *fp;                /* pushed(1) = output string       */
  1299.     Cell   temp;            /* pushed(2) = output request       */
  1300.                     /* pushed(3) = rest of program       */
  1301.  
  1302.     if (!s)                /* problem with filename?          */
  1303.         abandonDialogue(pushed(2));
  1304.     if ((fp = validOutChannel(s))==0)    /* problem with output channel?       */
  1305.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  1306.     if (nonNull(temp=outputString(fp,pushed(1),FALSE)))
  1307.     return ap(nameFailure,ap(nameWriteError,temp));
  1308.     else
  1309.     return nameSuccess;
  1310. }
  1311.  
  1312. static FILE *local validOutChannel(s)    /* return FILE * for valid output  */
  1313. String s; {                /* channel name or 0 otherwise...  */
  1314.     if (strcmp(s,"stdout")==0)
  1315.     return stdout;
  1316.     if (strcmp(s,"stderr")==0)
  1317.     return stderr;
  1318.     if (strcmp(s,"stdecho")==0)        /* in Gofer, stdecho==stdout       */
  1319.     return stdout;
  1320.     return 0;
  1321. }
  1322.  
  1323. static Cell local echo() {        /* respond to Echo request       */
  1324.                         /* pushed(0) = boolean echo status */
  1325.                     /* pushed(1) = echo request       */
  1326.                     /* pushed(2) = rest of program       */
  1327.     static String inUse  = "stdin already in use";
  1328.     static String repeat = "repeated Echo request";
  1329.  
  1330.     if (isNull(evalWithNoError(pushed(0)))) {
  1331.     if (stdinUsed)
  1332.         return ap(nameFailure,ap(nameOtherError,mkStr(findText(inUse))));
  1333.     if (echoChanged)
  1334.         return ap(nameFailure,ap(nameOtherError,mkStr(findText(repeat))));
  1335.     if (whnfHead==nameFalse && whnfArgs==0) {
  1336.         echoChanged = TRUE;
  1337.         noechoTerminal();
  1338.         return nameSuccess;
  1339.     }
  1340.     if (whnfHead==nameTrue && whnfArgs==0) {
  1341.         echoChanged = TRUE;
  1342.         return nameSuccess;
  1343.     }
  1344.     }
  1345.     abandonDialogue(pushed(1));
  1346.     return NIL;/*NOTREACHED*/
  1347. }
  1348.  
  1349. static Cell local getCLArgs() {        /* get command args -- always []   */
  1350.     return ap(nameStrList,nameNil);
  1351. }
  1352.  
  1353. static Cell local getProgName() {    /* get program name -- an error!   */
  1354.     return ap(nameFailure,ap(nameOtherError,nameNil));
  1355. }
  1356.  
  1357. static Cell local getEnv() {        /* get environment variable       */
  1358.     String s = evalName(pushed(0));    /* pushed(0) = variable name string*/
  1359.     String r = 0;            /* pushed(1) = output request       */
  1360.                     /* pushed(2) = rest of program       */
  1361.     if (!s)
  1362.         abandonDialogue(pushed(1));
  1363.     if (r=getenv(s))
  1364.     return ap(nameStr,revOnto(stringOutput(r,NIL),nameNil));
  1365.     else
  1366.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  1367. }
  1368.  
  1369. primFun(primInput) {            /* read single character from stdin*/
  1370.     Int c = readTerminalChar();
  1371.  
  1372.     if (c==EOF || c<0 || c>=NUM_CHARS) {
  1373.     clearerr(stdin);
  1374.     updateRoot(nameNil);
  1375.     }
  1376.     else
  1377.     updapRoot(consChar(c),ap(nameInput,UNIT));
  1378. }
  1379.  
  1380. primFun(primFopen) {            /* open file for reading as str       */
  1381.     Cell   succ = primArg(1);        /*  :: String->a->(String->a)->a   */
  1382.     Cell   fail = primArg(2);
  1383.     String s    = evalName(primArg(3));
  1384.  
  1385.     if (s){
  1386.     Cell file = openFile(s);
  1387.     if (nonNull(file)) {
  1388.         updapRoot(succ,file);
  1389.         return;
  1390.     }
  1391.     }
  1392.     updateRoot(fail);
  1393. }
  1394.  
  1395. /* --------------------------------------------------------------------------
  1396.  * Top-level printing mechanism:
  1397.  * ------------------------------------------------------------------------*/
  1398.  
  1399. Cell outputString(fp,cs,noDialogue)    /* Evaluate string cs and print       */
  1400. FILE *fp;                /* on specified output stream fp   */
  1401. Cell cs;
  1402. Bool noDialogue; {            /* TRUE => not runnning Dialogue   */
  1403.     Cell temp;
  1404.  
  1405.     for (;;) {                /* keep reducing and printing head */
  1406.     clearStack();            /* character               */
  1407.     temp = evalWithNoError(cs);
  1408.     if (nonNull(temp))
  1409.         if (noDialogue)
  1410.         cs = printBadRedex(temp,nameNil);
  1411.         else
  1412.         return printDBadRedex(temp,nameNil);
  1413.     else if (whnfHead==nameCons && whnfArgs==2) {
  1414.         Cell c = pushed(0);
  1415.         cs     = pushed(1);
  1416.  
  1417.         if (nonNull(temp=evalWithNoError(c)))
  1418.         if (noDialogue)
  1419.             cs = printBadRedex(temp,cs);
  1420.         else
  1421.             return printDBadRedex(temp,cs);
  1422.         else if (isChar(whnfHead) && whnfArgs==0) {
  1423.         fputc(charOf(whnfHead),fp);
  1424.         fflush(fp);
  1425.         }
  1426.         else
  1427.         break;
  1428.     }
  1429.     else if (whnfHead==nameNil && whnfArgs==0)
  1430.         return NIL;
  1431.     else
  1432.         break;
  1433.     }
  1434.     internal("runtime type error");
  1435.     return nameNil;/*NOTREACHED*/
  1436. }
  1437.  
  1438. /* --------------------------------------------------------------------------
  1439.  * Lambda-var prototype implementation:
  1440.  * ------------------------------------------------------------------------*/
  1441.  
  1442. #ifdef LAMBDAVAR
  1443. Void lvExecute(prog)            /* execute lambda var prog of type */
  1444. Cell prog; {                /* Proc ()               */
  1445.     Cell temp;
  1446.     noechoTerminal();
  1447.     temp = evalWithNoError(ap(prog,UNIT));
  1448.     if (nonNull(temp))
  1449.     abandon("Program execution",temp);
  1450. }
  1451.  
  1452. primFun(primLvReturn) {            /* lambda var return           */
  1453.     updateRoot(primArg(2));        /* return    :: a -> Proc a       */
  1454.                     /* return e _ = e           */
  1455. }
  1456.  
  1457. primFun(primLvPure) {            /* lambda var pure           */
  1458.     updapRoot(primArg(1),UNIT);        /* pure  :: Proc a -> a           */
  1459.                     /* pure e = e ()           */
  1460. }
  1461.  
  1462. primFun(primLvRead) {            /* lambda var reader           */
  1463.     Cell v = primArg(3);        /* (?)::Var a->(a->Proc b)->Proc b */
  1464.     Cell f = primArg(2);        /* (Var v ? f) () ===> f v ()       */
  1465.     eval(v);
  1466.     if (whnfHead!=nameVar || whnfArgs!=1)
  1467.     internal("type error in reader");
  1468.     updapRoot(ap(f,pushed(0)),UNIT);
  1469. }
  1470.  
  1471. primFun(primLvBind) {            /* lambda var bind           */
  1472.     Cell m = primArg(3);        /*($=)::Proc a->(a->Proc b)->Proc b*/
  1473.     Cell f = primArg(2);        /* (m $= f) () ===> f (m ()) ()       */
  1474.     Cell a = ap(m,UNIT);        /* strict in first argument       */
  1475.     eval(a);
  1476.     updapRoot(ap(f,a),UNIT);
  1477. }
  1478.  
  1479. primFun(primLvVar) {            /* lambda var, new variable       */
  1480.     updapRoot(ap(primArg(2),        /* var :: (Var a -> Proc b)->Proc b*/
  1481.          ap(nameVar,        /* var f () = f {newvar} ()       */
  1482.             nameLvUnbound)),
  1483.           UNIT);
  1484. }
  1485.  
  1486. primFun(primLvNewvar) {            /* lambda var, improved new var       */
  1487.     updapRoot(nameVar,nameLvUnbound);    /* newvar   :: Proc (Var a)       */
  1488.                     /* newvar () = {newVar}           */
  1489. }
  1490.  
  1491. primFun(primLvAssign) {            /* lambda var assign           */
  1492.     Cell e = primArg(3);        /* assign :: a -> Var a -> Proc () */
  1493.     Cell v = primArg(2);            /* assign e (Var v) () = ()       */
  1494.     eval(v);
  1495.     if (whnfHead!=nameVar || whnfArgs!=1)
  1496.     internal("type error in assign");
  1497.     snd(v) = e;                /* Arrgh! impurity!           */
  1498.     updateRoot(UNIT);
  1499. }
  1500.  
  1501. primFun(primLvVarEq) {            /* lambda var equality for Vars       */
  1502.     Cell x = primArg(2);        /* :: Var a -> Var a -> Bool       */
  1503.     Cell y = primArg(1);
  1504.     eval(x);
  1505.     eval(y);                /* I'm not sure this is correct       */
  1506.     updateRoot(x==y ? nameTrue : nameFalse);
  1507. }
  1508.  
  1509. primFun(primLvGetch) {            /* get character from stdin       */
  1510.     updateRoot(mkChar(readTerminalChar()));
  1511. }
  1512.  
  1513. primFun(primLvPutchar) {        /* print character on stdout       */
  1514.     eval(primArg(2));            /* putchar c () ==> ()           */
  1515.     putchar(charOf(whnfHead));
  1516.     updateRoot(UNIT);
  1517. }
  1518.  
  1519. primFun(primLvSystem) {            /* do system call           */
  1520.     String s = evalName(primArg(2));    /* system s () ==> int result       */
  1521.     Int    n = s ? system(s) : 1;
  1522.     updateRoot(mkInt(n));
  1523. }
  1524. #endif
  1525.  
  1526. /* --------------------------------------------------------------------------
  1527.  * Lambda-nu prototype implementation:
  1528.  * ------------------------------------------------------------------------*/
  1529.  
  1530. #ifdef LAMBDANU
  1531. Void lnExecute(prog)            /* execute lambda nu prog of type  */
  1532. Cell prog; {                /* Cmd a ()               */
  1533.     Cell temp;
  1534.     noechoTerminal();
  1535.     temp = evalWithNoError(ap(prog,nameLnDone));
  1536.     if (nonNull(temp))
  1537.     abandon("Command execution",temp);
  1538. }
  1539.  
  1540. primFun(primLnDone) {            /* lambda nu done           */
  1541.     updateRoot(UNIT);            /* behaviour is ignored, so isn't  */
  1542. }                    /* really important           */
  1543.  
  1544. primFun(primLnReturn) {            /* lambda nu return           */
  1545.     updapRoot(primArg(1),primArg(2));    /* return    :: a -> Cmd d a       */
  1546. }                    /* return a c = c a           */
  1547.  
  1548. primFun(primLnBind) {            /* lambda nu bind           */
  1549.     Cell a = primArg(3);        /* (>>=)::Cmd c a -> (a -> Cmd c b)*/
  1550.     Cell b = primArg(2);        /*            -> Cmd c b */
  1551.     Cell c = primArg(1);        /* (a>>=b) c = a (flip b c)       */
  1552.     updapRoot(a,ap(ap(nameLnFlip,b),c));
  1553. }
  1554.  
  1555. primFun(primLnFlip) {            /* flip primitive, for use in bind */
  1556.     updapRoot(ap(primArg(3),primArg(1)),primArg(2));
  1557. }
  1558.  
  1559. primFun(primLnNew) {            /* lambda nu allocate variable       */
  1560.     Cell c = primArg(1);        /* new :: Cmd a (Tag b)           */
  1561.     updapRoot(c,ap(nameTag,nameLnUnbound));
  1562. }
  1563.  
  1564. primFun(primLnAssign) {            /* lambda nu assign           */
  1565.     Cell v = primArg(3);        /* assign:: Tag a -> a -> Cmd d () */
  1566.     Cell e = primArg(2);            /* assign (Tag v) e c = c ()       */
  1567.     Cell c = primArg(1);
  1568.     eval(v);
  1569.     if (whnfHead!=nameTag || whnfArgs!=1)
  1570.     internal("type error in assign");
  1571.     snd(v) = e;                /* Arrgh! impurity!           */
  1572.     updapRoot(c,UNIT);
  1573. }
  1574.  
  1575. primFun(primLnRead) {            /* lambda nu reader           */
  1576.     Cell vv = primArg(3);        /* (?) :: Tag a -> (a -> Cmd d b)  */
  1577.     Cell b  = primArg(2);        /*            -> Cmd d b */
  1578.     Cell c  = primArg(1);        /* (Tag v ? b) c = b v c       */
  1579.     eval(vv);
  1580.     if (whnfHead!=nameTag || whnfArgs!=1)
  1581.     internal("type error in reader");
  1582.     updapRoot(ap(b,pushed(0)),c);
  1583. }
  1584.  
  1585. primFun(primLnIo) {            /* lambda nu i/o           */
  1586.     updapRoot(primArg(2),primArg(1));    /* io :: ((a->d)->d) -> Cmd d a       */
  1587. }                    /* io a c = a c               */
  1588.  
  1589. primFun(primLnBegin) {            /* lambda nu begin           */
  1590.     updapRoot(primArg(1),nameLnNocont);    /* begin :: Cmd d a -> d       */
  1591. }
  1592.  
  1593. primFun(primLnTagEq) {            /* lambda nu equality for Tags       */
  1594.     Cell x = primArg(2);        /* :: Tag a -> Tag a -> Bool       */
  1595.     Cell y = primArg(1);
  1596.     eval(x);
  1597.     eval(y);                /* I'm not sure this is correct       */
  1598.     updateRoot(x==y ? nameTrue : nameFalse);
  1599. }
  1600.  
  1601. primFun(primLnGetch) {            /* get character from stdin       */
  1602.     updapRoot(primArg(1),mkChar(readTerminalChar()));
  1603. }
  1604.  
  1605. primFun(primLnPutchar) {        /* print character on stdout       */
  1606.     Cell c = primArg(1);        /* putchar    :: Char -> Cmd a ()  */
  1607.     eval(primArg(2));            /* putchar x c = c ()           */
  1608.     putchar(charOf(whnfHead));
  1609.     updapRoot(c,UNIT);
  1610. }
  1611.  
  1612. primFun(primLnSystem) {            /* do system call           */
  1613.     Cell   c = primArg(1);        /* system    :: String -> Cmd a Int*/
  1614.     String s = evalName(primArg(2));    /* system s c = c (int result)       */
  1615.     Int    n = s ? system(s) : 1;
  1616.     updateRoot(mkInt(n));
  1617. }
  1618. #endif
  1619.  
  1620. #endif
  1621.  
  1622. /* --------------------------------------------------------------------------
  1623.  * Build array of character conses:
  1624.  * ------------------------------------------------------------------------*/
  1625.  
  1626. static Cell consCharArray[NUM_CHARS];
  1627.  
  1628. Cell consChar(c)            /* return application (:) c       */
  1629. Char c; {
  1630.     if (c<0)
  1631.     c += NUM_CHARS;
  1632.     return consCharArray[c];
  1633. }
  1634.  
  1635. /*-------------------------------------------------------------------------*/
  1636.