home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / hugs101.zip / hugs101sc.zip / hugsdist / src / machine.c < prev    next >
C/C++ Source or Header  |  1995-03-02  |  36KB  |  1,338 lines
  1. /* --------------------------------------------------------------------------
  2.  * machine.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.  * Graph reduction engine, code generation and execution
  7.  * ------------------------------------------------------------------------*/
  8.  
  9. #include "prelude.h"
  10. #include "storage.h"
  11. #include "connect.h"
  12. #include "errors.h"
  13. #include <setjmp.h>
  14.  
  15. /*#define DEBUG_CODE*/
  16. Bool   andorOptimise = TRUE;        /* TRUE => optimise uses of &&, || */
  17. Bool   failOnError   = TRUE;        /* TRUE => abort as soon as error  */
  18.                     /*       occurs           */
  19.  
  20. /* --------------------------------------------------------------------------
  21.  * Data structures for machine memory (program storage):
  22.  * ------------------------------------------------------------------------*/
  23.  
  24. /* This list defines the sequence of all instructions that can be used in
  25.  * the abstract machine code for Hugs.  The Ins() macro is used to
  26.  * ensure that the correct mapping of instructions to labels is used when
  27.  * compiling the GCC_THREADED version.
  28.  */
  29.  
  30. #define INSTRLIST    Ins(iLOAD),  Ins(iCELL),   Ins(iCHAR),      \
  31.             Ins(iINT),   Ins(iFLOAT),  Ins(iSTRING),  \
  32.             Ins(iMKAP),  Ins(iUPDATE), Ins(iUPDAP),      \
  33.             Ins(iEVAL),  Ins(iRETURN), Ins(iTEST),      \
  34.             Ins(iGOTO),  Ins(iSETSTK), Ins(iROOT),      \
  35.             Ins(iDICT),  Ins(iFAIL),   Ins(iALLOC),      \
  36.             Ins(iSLIDE), Ins(iTABLE)
  37.   
  38. #define Ins(x) x
  39. typedef enum { INSTRLIST } Instr;
  40. #undef  Ins
  41.  
  42. typedef Int Label;
  43.  
  44. typedef union {
  45.     Int   mint;
  46. #if !BREAK_FLOATS
  47.     Float mfloat;
  48. #endif
  49.     Cell  cell;
  50.     Text  text;
  51.     Addr  addr;
  52.     Instr instr;
  53.     Label lab;
  54. } MemCell;
  55.  
  56. typedef MemCell far *Memory;
  57. static    Memory        memory;
  58. #define intAt(m)    memory[m].mint
  59. #if !BREAK_FLOATS
  60. #define floatAt(m)  memory[m].mfloat
  61. #endif
  62. #define cellAt(m)   memory[m].cell
  63. #define textAt(m)   memory[m].text
  64. #define addrAt(m)   memory[m].addr
  65. #define instrAt(m)  memory[m].instr
  66. #define labAt(m)    memory[m].lab
  67.  
  68. /* --------------------------------------------------------------------------
  69.  * Local function prototypes:
  70.  * ------------------------------------------------------------------------*/
  71.  
  72. static Void  local instrNone    Args((Instr));
  73. static Void  local instrInt    Args((Instr,Int));
  74. static Void  local instrFloat   Args((Instr,FloatPro));
  75. static Void  local instrCell    Args((Instr,Cell));
  76. static Void  local instrText    Args((Instr,Text));
  77. static Void  local instrLab    Args((Instr,Label));
  78. static Void  local instrCellLab Args((Instr,Cell,Label));
  79.  
  80. static Void  local asSTART    Args((Void));
  81. static Label local newLabel    Args((Label));
  82. static Void  local asEND    Args((Void));
  83. static Void  local asDICT    Args((Int));
  84. static Void  local asSLIDE    Args((Int));
  85. static Void  local asMKAP    Args((Int));
  86. static Void  local asUPDATE    Args((Int));
  87. static Void  local asGOTO    Args((Label));
  88.  
  89. #ifdef DEBUG_CODE
  90. static Void  local dissassemble Args((Addr,Addr));
  91. static Void  local printCell    Args((Cell));
  92. static Addr  local dissNone    Args((Addr,String));
  93. static Addr  local dissInt    Args((Addr,String));
  94. static Addr  local dissFloat    Args((Addr,String));
  95. static Addr  local dissCell    Args((Addr,String));
  96. static Addr  local dissText    Args((Addr,String));
  97. static Addr  local dissAddr    Args((Addr,String));
  98. static Addr  local dissIntAddr    Args((Addr,String));
  99. static Addr  local dissCellAddr Args((Addr,String));
  100. #endif
  101.  
  102. static Void  local build    Args((Cell,Int));
  103. static Void  local buildGuards    Args((List,Int));
  104. static Int   local buildLoc    Args((List,Int));
  105. static Void  local buildBignum  Args((Bignum));
  106.  
  107. static Void  local make     Args((Cell,Int,Label,Label));
  108. static Void  local makeCond    Args((Cell,Cell,Cell,Int,Label,Label));
  109. static Void  local makeNumcase  Args((Triple,Int,Label,Label));
  110. static Void  local testGuard    Args((Pair,Int,Label,Label,Label));
  111. static Void  local testCase    Args((Pair,Int,Label,Label,Label));
  112.  
  113. static Void  local analyseAp    Args((Cell));
  114. static Void  local buildAp    Args((Cell,Int,Label,Bool));
  115.  
  116. static Void  local evalString   Args((Cell));
  117. static Void  local run        Args((Addr,StackPtr));
  118.  
  119. /* --------------------------------------------------------------------------
  120.  * Assembler: (Low level, instruction code storage)
  121.  * ------------------------------------------------------------------------*/
  122.  
  123. static Addr  startInstr;        /* first instruction after START   */
  124. static Addr  lastInstr;            /* last instr written (for peephole*/
  125.                     /* optimisations etc.)           */
  126. static Addr  noMatch;            /* address of a single FAIL instr  */
  127. static Int   srsp;            /* simulated runtime stack pointer */
  128. static Int   offsPosn[NUM_OFFSETS];    /* mapping from logical to physical*/
  129.                     /* offset positions           */
  130.  
  131. static Void local instrNone(opc)    /* Opcode with no operands       */
  132. Instr opc; {
  133.     lastInstr           = getMem(1);
  134.     instrAt(lastInstr) = opc;
  135. }
  136.  
  137. static Void local instrInt(opc,n)    /* Opcode with integer operand       */
  138. Instr opc;
  139. Int   n; {
  140.     lastInstr           = getMem(2);
  141.     instrAt(lastInstr) = opc;
  142.     intAt(lastInstr+1) = n;
  143. }
  144.  
  145. static Void local instrFloat(opc,fl)    /* Opcode with Float operand       */
  146. Instr    opc;
  147. FloatPro fl; {
  148. #if BREAK_FLOATS
  149.     lastInstr         = getMem(3);
  150.     instrAt(lastInstr)     = opc;
  151.     cellAt(lastInstr+1)     = part1Float(fl);
  152.     cellAt(lastInstr+2)  = part2Float(fl);
  153. #else
  154.     lastInstr            = getMem(2);
  155.     instrAt(lastInstr)   = opc;
  156.     floatAt(lastInstr+1) = fl;
  157. #endif
  158. }
  159.  
  160. static Void local instrCell(opc,c)    /* Opcode with Cell operand       */
  161. Instr opc;
  162. Cell  c; {
  163.     lastInstr        = getMem(2);
  164.     instrAt(lastInstr)    = opc;
  165.     cellAt(lastInstr+1) = c;
  166. }
  167.  
  168. static Void local instrText(opc,t)    /* Opcode with Text operand       */
  169. Instr opc;
  170. Text  t; {
  171.     lastInstr        = getMem(2);
  172.     instrAt(lastInstr)    = opc;
  173.     textAt(lastInstr+1) = t;
  174. }
  175.  
  176. static Void local instrLab(opc,l)    /* Opcode with label operand       */
  177. Instr opc;
  178. Label l; {
  179.     lastInstr           = getMem(2);
  180.     instrAt(lastInstr) = opc;
  181.     labAt(lastInstr+1) = l;
  182.     if (l<0)
  183.     internal("bad Label");
  184. }
  185.  
  186. static Void local instrCellLab(opc,c,l)    /* Opcode with cell, label operands*/
  187. Instr opc;
  188. Cell  c;
  189. Label l; {
  190.     lastInstr        = getMem(3);
  191.     instrAt(lastInstr)    = opc;
  192.     cellAt(lastInstr+1) = c;
  193.     labAt(lastInstr+2)    = l;
  194.     if (l<0)
  195.     internal("bad Label");
  196. }
  197.  
  198. /* --------------------------------------------------------------------------
  199.  * Main low level assembler control: (includes label assignment and fixup)
  200.  *
  201.  * Labels are used as a simple form of continuation during the code gen:
  202.  *  RUNON    => produce code which does not make jump at end of construction
  203.  *  UPDRET   => produce code which performs UPDATE 0, RETURN at end
  204.  *  VALRET   => produce code which performs RETURN at end
  205.  *  other(d) => produce code which branches to label d at end
  206.  * ------------------------------------------------------------------------*/
  207.  
  208. static    Label          nextLab;           /* next label number to allocate    */
  209. #define SHOULDNTFAIL  (-1)
  210. #define RUNON          (-2)
  211. #define UPDRET          (-3)
  212. #define VALRET          (-4)
  213. static    Addr          fixups[NUM_FIXUPS]; /* fixup table maps Label -> Addr*/
  214. #define atLabel(n)    fixups[n] = getMem(0)
  215. #define endLabel(d,l) if (d==RUNON) atLabel(l)
  216. #define fix(a)          addrAt(a) = fixups[labAt(a)]
  217.  
  218. static Void local asSTART() {           /* initialise assembler           */
  219.     fixups[0]    = noMatch;
  220.     nextLab    = 1;
  221.     startInstr    = getMem(0);
  222.     lastInstr    = startInstr-1;
  223.     srsp    = 0;
  224.     offsPosn[0] = 0;
  225. }
  226.  
  227. static Label local newLabel(d)           /* allocate new label           */
  228. Label d; {
  229.     if (d==RUNON) {
  230.     if (nextLab>=NUM_FIXUPS) {
  231.         ERROR(0) "Compiled code too complex"
  232.         EEND;
  233.     }
  234.     return nextLab++;
  235.     }
  236.     return d;
  237. }
  238.  
  239. static Void local asEND() {           /* Fix addresses in assembled code  */
  240.     Addr pc = startInstr;
  241.  
  242.     while (pc<=lastInstr)
  243.     switch (instrAt(pc)) {
  244.         case iEVAL     :           /* opcodes taking no arguments       */
  245.         case iFAIL     :
  246.         case iRETURN : pc++;
  247.                break;
  248.  
  249.         case iGOTO     : fix(pc+1);  /* opcodes taking one argument       */
  250.         case iSETSTK :
  251.         case iALLOC  :
  252.         case iSLIDE  :
  253.         case iROOT     :
  254.             case iDICT   :
  255.         case iLOAD     :
  256.         case iCELL     :
  257.         case iCHAR     :
  258.         case iINT     :
  259. #if !BREAK_FLOATS
  260.         case iFLOAT  :
  261. #endif
  262.         case iSTRING :
  263.         case iMKAP     :
  264.         case iUPDATE :
  265.         case iUPDAP  : pc+=2;
  266.                break;
  267. #if BREAK_FLOATS
  268.         case iFLOAT  : pc+=3;
  269.                break;
  270. #endif
  271.  
  272.         case iTEST     : fix(pc+2);
  273.                pc+=3;
  274.                break;
  275.  
  276.         default     : internal("fixAddrs");
  277.     }
  278. }
  279.  
  280. /* --------------------------------------------------------------------------
  281.  * Assembler Opcodes: (includes simple peephole optimisations)
  282.  * ------------------------------------------------------------------------*/
  283.  
  284. #define asINTEGER(n) instrInt(iINT,n);        srsp++
  285. #define asFLOAT(fl)  instrFloat(iFLOAT,fl);    srsp++
  286. #define asSTRING(t)  instrText(iSTRING,t);    srsp++
  287. #define asCHAR(n)    instrInt(iCHAR,n);        srsp++
  288. #define asLOAD(n)    instrInt(iLOAD,n);        srsp++
  289. #define asALLOC(n)   instrInt(iALLOC,n);    srsp+=n
  290. #define asROOT(n)    instrInt(iROOT,n);        srsp++
  291. #define asSETSTK(n)  instrInt(iSETSTK,n);    srsp=n
  292. #define asEVAL()     instrNone(iEVAL);        srsp--    /* inaccurate srsp */
  293. #define asRETURN()   instrNone(iRETURN)
  294. #define asCELL(c)    instrCell(iCELL,c);    srsp++
  295. #define asTEST(c,l)  instrCellLab(iTEST,c,l)        /* inaccurate srsp */
  296. #define asFAIL()     instrNone(iFAIL)
  297.  
  298. static Void local asDICT(n)        /* pick element of dictionary       */
  299. Int n; {
  300. /* Sadly, the following optimisation cannot be used unless CELL references
  301.  * in compiled code are garbage collected (and possibly modified when cell  
  302.  * indirections are found).
  303.  *
  304.  *    if (instrAt(lastInstr)==iCELL)
  305.  *    -- Peephole optimisation: CELL {dict m};DICT n ==> CELL dict(m+n)
  306.  *    if (whatIs(cellAt(lastInstr+1))==DICTCELL)
  307.  *        cellAt(lastInstr+1) = dict(dictOf(cellAt(lastInstr+1))+n);
  308.  *    else
  309.  *        internal("asDICT");
  310.  *    else  ...
  311.  */
  312.     if (n!=0)                /* optimisation:DICT 0 has no use  */
  313.     instrInt(iDICT,n);        /* for std dictionary construction */
  314. }
  315.  
  316. static Void local asSLIDE(n)        /* Slide results down stack       */
  317. Int n; {
  318.     if (instrAt(lastInstr)==iSLIDE)    /* Peephole optimisation:       */
  319.     intAt(lastInstr+1)+=n;        /* SLIDE n;SLIDE m ===> SLIDE (n+m)*/
  320.     else
  321.     instrInt(iSLIDE,n);
  322.     srsp -= n;
  323. }
  324.  
  325. static Void local asMKAP(n)        /* Make application nodes ...       */
  326. Int n; {
  327.     if (instrAt(lastInstr)==iMKAP)    /* Peephole optimisation:       */
  328.     intAt(lastInstr+1)+=n;        /* MKAP n; MKAP m  ===> MKAP (n+m) */
  329.     else
  330.     instrInt(iMKAP,n);
  331.     srsp -= n;
  332. }
  333.  
  334. static Void local asUPDATE(n)        /* Update node ...           */
  335. Int n; {
  336.     if (instrAt(lastInstr)==iMKAP) {    /* Peephole optimisations:       */
  337.     if (intAt(lastInstr+1)>1) {    /* MKAP (n+1); UPDATE p           */
  338.         intAt(lastInstr+1)--;    /*          ===> MKAP n; UPDAP p */
  339.         instrInt(iUPDAP,n);
  340.     }
  341.     else {
  342.         instrAt(lastInstr) = iUPDAP;
  343.         intAt(lastInstr+1) = n;    /* MKAP 1; UPDATE p ===> UPDAP p   */
  344.     }
  345.     }
  346.     else
  347.     instrInt(iUPDATE,n);
  348.     srsp--;
  349. }
  350.  
  351. static Void local asGOTO(l)        /* End evaluation of expr in manner*/
  352. Label l; {                /* indicated by label l           */
  353.     switch (l) {                    /* inaccurate srsp */
  354.     case UPDRET : asUPDATE(0);
  355.     case VALRET : asRETURN();
  356.     case RUNON  : break;
  357.     default     : instrLab(iGOTO,l);
  358.               break;
  359.     }
  360. }
  361.  
  362. /* --------------------------------------------------------------------------
  363.  * Constructor function tables:
  364.  *
  365.  * Tables of constructor functions for enumerated types are needed to
  366.  * produce derived instances.
  367.  * ------------------------------------------------------------------------*/
  368.  
  369. Void addCfunTable(tc)            /* Add a constructor fun table to  */
  370. Tycon tc; {                /* constructors for tycon tc       */
  371.     if (isTycon(tc) && tycon(tc).what==DATATYPE) {
  372.     List cs = tycon(tc).defn;
  373.     if (name(hd(cs)).code<=0) {
  374.         Int  l     = length(cs);
  375.         Addr a     = getMem(2+l);
  376.         instrAt(a) = iTABLE;
  377.         intAt(a+1) = l;
  378.         for (l=0; nonNull(cs); l++, cs=tl(cs)) {
  379.         cellAt(a+l+2)     = hd(cs);
  380.         name(hd(cs)).code = a;
  381.         }
  382.     }
  383.     }
  384. }
  385.  
  386. Name succCfun(n)            /* get next constructor    in sequence*/
  387. Name n; {                /* or NIL, if none           */
  388.     Int  d = name(n).number+1;
  389.     Addr a = name(n).code;
  390.     return (d>=intAt(a+1)) ? NIL : cellAt(a+d+2);
  391. }
  392.  
  393. Name nextCfun(n1,n2)            /* get next constructor    in series  */
  394. Name n1, n2; {                /* or NIL, if none           */
  395.     Int  d = 2*name(n2).number - name(n1).number;
  396.     Addr a = name(n1).code;
  397.     return (d<0 || d>=intAt(a+1)) ? NIL : cellAt(a+d+2);
  398. }
  399.  
  400. /* --------------------------------------------------------------------------
  401.  * Dissassembler:
  402.  * ------------------------------------------------------------------------*/
  403.  
  404. #ifdef DEBUG_CODE
  405. #define printAddr(a) printf("0x%04X",a)/* printable representation of Addr */
  406.  
  407. static Void local dissassemble(pc,end) /* print dissassembly of code       */
  408. Addr pc;
  409. Addr end; {
  410.     while (pc<=end) {
  411.     printAddr(pc);
  412.     printf("\t");
  413.     switch (instrAt(pc)) {
  414.         case iLOAD     : pc = dissInt(pc,"LOAD");     break;
  415.         case iCELL     : pc = dissCell(pc,"CELL");     break;
  416.         case iCHAR     : pc = dissInt(pc,"CHAR");     break;
  417.         case iINT     : pc = dissInt(pc,"INT");     break;
  418.         case iFLOAT  : pc = dissFloat(pc,"FLOAT");   break;
  419.         case iSTRING : pc = dissText(pc,"STRING");     break;
  420.         case iMKAP     : pc = dissInt(pc,"MKAP");     break;
  421.         case iUPDATE : pc = dissInt(pc,"UPDATE");     break;
  422.         case iUPDAP  : pc = dissInt(pc,"UPDAP");     break;
  423.         case iEVAL     : pc = dissNone(pc,"EVAL");     break;
  424.         case iRETURN : pc = dissNone(pc,"RETURN");     break;
  425.         case iTEST     : pc = dissCellAddr(pc,"TEST"); break;
  426.         case iGOTO     : pc = dissAddr(pc,"GOTO");     break;
  427.         case iSETSTK : pc = dissInt(pc,"SETSTK");     break;
  428.         case iALLOC  : pc = dissInt(pc,"ALLOC");     break;
  429.         case iSLIDE  : pc = dissInt(pc,"SLIDE");     break;
  430.         case iROOT     : pc = dissInt(pc,"ROOT");     break;
  431.             case iDICT   : pc = dissInt(pc,"DICT");      break;
  432.         case iFAIL     : pc = dissNone(pc,"FAIL");     break;
  433.         case iTABLE  : pc = dissNone(pc,"TABLE");
  434.                pc+= intAt(pc)+1;
  435.                break;
  436.         default     : internal("unknown instruction");
  437.     }
  438.     }
  439. }
  440.  
  441. static Void local printCell(c)           /* printable representation of Cell */
  442. Cell c; {
  443.     if (isName(c))
  444.     printf("%s",textToStr(name(c).text));
  445.     else
  446.     printf("$%d",c);
  447. }
  448.  
  449. static Addr local dissNone(pc,s)       /* dissassemble instr no args       */
  450. Addr   pc;
  451. String s; {
  452.     printf("%s\n",s);
  453.     return pc+1;
  454. }
  455.  
  456. static Addr local dissInt(pc,s)        /* dissassemble instr with Int arg  */
  457. Addr   pc;
  458. String s; {
  459.     printf("%s\t%d\n",s,intAt(pc+1));
  460.     return pc+2;
  461. }
  462.  
  463. static Addr local dissFloat(pc,s)      /* dissassemble instr with Float arg*/
  464. Addr   pc;
  465. String s; {
  466. #if BREAK_FLOATS
  467.     printf("%s\t%s\n",s,
  468.     floatToString(floatFromParts(cellAt(pc+1),cellAt(pc+2))));
  469.     return pc+3;
  470. #else
  471.     printf("%s\t%s\n",s,floatToString((FloatPro)floatAt(pc+1)));
  472.     return pc+2;
  473. #endif
  474. }
  475.  
  476. static Addr local dissCell(pc,s)       /* dissassemble instr with Cell arg */
  477. Addr   pc;
  478. String s; {
  479.     printf("%s\t",s);
  480.     printCell(cellAt(pc+1));
  481.     printf("\n");
  482.     return pc+2;
  483. }
  484.  
  485. static Addr local dissText(pc,s)       /* dissassemble instr with Text arg */
  486. Addr   pc;
  487. String s; {
  488.     printf("%s\t%s\n",s,textToStr(textAt(pc+1)));
  489.     return pc+2;
  490. }
  491.  
  492. static Addr local dissAddr(pc,s)       /* dissassemble instr with Addr arg */
  493. Addr   pc;
  494. String s; {
  495.     printf("%s\t",s);
  496.     printAddr(addrAt(pc+1));
  497.     printf("\n");
  498.     return pc+2;
  499. }
  500.  
  501. static Addr local dissIntAddr(pc,s)    /* dissassemble instr with Int/Addr */
  502. Addr   pc;
  503. String s; {
  504.     printf("%s\t%d\t",s,intAt(pc+1));
  505.     printAddr(addrAt(pc+2));
  506.     printf("\n");
  507.     return pc+3;
  508. }
  509.  
  510. static Addr local dissCellAddr(pc,s)   /* dissassemble instr with Cell/Addr*/
  511. Addr   pc;
  512. String s; {
  513.     printf("%s\t",s);
  514.     printCell(cellAt(pc+1));
  515.     printf("\t");
  516.     printAddr(addrAt(pc+2));
  517.     printf("\n");
  518.     return pc+3;
  519. }
  520. #endif
  521.  
  522. /* --------------------------------------------------------------------------
  523.  * Compile expression to code which will build expression without any
  524.  * evaluation.
  525.  * ------------------------------------------------------------------------*/
  526.  
  527. static Void local build(e,co)        /* Generate code which will build  */
  528. Cell e;                    /* instance of given expression but*/
  529. Int  co; {                /* perform no evaluation        */
  530.     Int n;
  531.  
  532.     switch (whatIs(e)) {
  533.  
  534.     case LETREC    : n = buildLoc(fst(snd(e)),co);
  535.                  build(snd(snd(e)),co+n);
  536.                  asSLIDE(n);
  537.                  break;
  538.  
  539.     case FATBAR    : build(snd(snd(e)),co);
  540.                  build(fst(snd(e)),co);
  541.                  asCELL(nameFatbar);
  542.                  asMKAP(2);
  543.                  break;
  544.  
  545.     case COND      : build(thd3(snd(e)),co);
  546.                  build(snd3(snd(e)),co);
  547.                  build(fst3(snd(e)),co);
  548.                  asCELL(nameIf);
  549.                    asMKAP(3);
  550.                    break;
  551.  
  552.     case GUARDED   : buildGuards(snd(e),co);
  553.                  break;
  554.  
  555.     case AP        : buildAp(e,co,SHOULDNTFAIL,FALSE);
  556.                  break;
  557.  
  558.     case UNIT      :
  559.     case TUPLE     :
  560.     case NAME      : asCELL(e);
  561.              break;
  562.  
  563.     case ZERONUM   :
  564.     case POSNUM    :
  565.     case NEGNUM    : buildBignum(e);
  566.              break;
  567.  
  568.     case DICTCELL  : asCELL(dict(dictOf(e)));    /* see comments for*/
  569.              break;                /* DICTCELL in make*/
  570.                             /* function below  */
  571.     case INTCELL   : asINTEGER(intOf(e));
  572.              break;
  573.  
  574.         case FLOATCELL : asFLOAT(floatOf(e));
  575.              break;
  576.  
  577.     case STRCELL   : asSTRING(textOf(e));
  578.              break;
  579.  
  580.     case CHARCELL  : asCHAR(charOf(e));
  581.              break;
  582.  
  583.     case OFFSET    : asLOAD(offsPosn[offsetOf(e)]);
  584.                  break;
  585.  
  586.     default        : internal("build");
  587.     }
  588. }
  589.  
  590. static Void local buildGuards(gs,co)    /* Generate code to compile list   */
  591. List gs;                /* of guards to a conditional expr */
  592. Int  co; {                /* without evaluation           */
  593.     if (isNull(gs)) {
  594.     asCELL(nameFail);
  595.     }
  596.     else {
  597.     buildGuards(tl(gs),co);
  598.     build(snd(hd(gs)),co);
  599.     build(fst(hd(gs)),co);
  600.     asCELL(nameIf);
  601.     asMKAP(3);
  602.     }
  603. }
  604.  
  605. static Int local buildLoc(vs,co)    /* Generate code to build local var*/
  606. List vs;                /* bindings on stack,  with no eval*/
  607. Int  co; {
  608.     Int n = length(vs);
  609.     Int i;
  610.  
  611.     for (i=1; i<=n; i++)
  612.     offsPosn[co+i] = srsp+i;
  613.     asALLOC(n);
  614.     for (i=1; i<=n; i++) {
  615.     build(hd(vs),co+n);
  616.     asUPDATE(offsPosn[co+i]);
  617.     vs = tl(vs);
  618.     }
  619.     return n;
  620. }
  621.  
  622. static Void local buildBignum(b)    /* Generate code to build bignum   */
  623. Bignum b; {
  624.     if (b==ZERONUM) {
  625.     asCELL(ZERONUM);
  626.     }
  627.     else {
  628.     List rs = snd(b) = rev(snd(b));
  629.     asCELL(NIL);
  630.     for (; nonNull(rs); rs=tl(rs)) {
  631.         asCELL(hd(rs));
  632.         asMKAP(1);
  633.     }
  634.     snd(b) = rev(snd(b));        /* put digits back in order       */
  635.     asCELL(fst(b));
  636.     asMKAP(1);
  637.     }
  638. }
  639.  
  640. /* --------------------------------------------------------------------------
  641.  * Compile expression to code which will build expression evaluating guards
  642.  * and testing cases to avoid building complete graph.
  643.  * ------------------------------------------------------------------------*/
  644.  
  645. #define makeTests(ct,tests,co,f,d)     {   Label l1 = newLabel(d);        \
  646.                        List  xs = tests;            \
  647.                        while (nonNull(tl(xs))) {        \
  648.                            Label l2   = newLabel(RUNON);\
  649.                            Int savesp = srsp;        \
  650.                            ct(hd(xs),co,f,l2,l1);        \
  651.                            atLabel(l2);            \
  652.                            srsp = savesp;            \
  653.                            xs   = tl(xs);            \
  654.                        }                    \
  655.                        ct(hd(xs),co,f,f,d);            \
  656.                        endLabel(d,l1);            \
  657.                        }
  658.  
  659. static Void local make(e,co,f,d)       /* Construct code to build e, given */
  660. Cell  e;                   /* current offset co, and branch       */
  661. Int   co;                   /* to f on failure, d on completion */
  662. Label f;
  663. Label d; {
  664.     switch (whatIs(e)) {
  665.  
  666.     case LETREC    : {   Int n = buildLoc(fst(snd(e)),co);
  667.                  make(snd(snd(e)),co+n,f,RUNON);
  668.                  asSLIDE(n);
  669.                  asGOTO(d);
  670.                  }
  671.                  break;
  672.  
  673.     case FATBAR    : {   Label l1     = newLabel(RUNON);
  674.                  Label l2     = newLabel(d);
  675.                  Int   savesp = srsp;
  676.  
  677.                  make(fst(snd(e)),co,l1,l2);
  678.  
  679.                  atLabel(l1);
  680.                  srsp = savesp;
  681.                  asSETSTK(srsp);
  682.                  make(snd(snd(e)),co,f,l2);
  683.  
  684.                  endLabel(d,l2);
  685.                  }
  686.                  break;
  687.  
  688.     case COND      : makeCond(fst3(snd(e)),
  689.                   snd3(snd(e)),
  690.                   thd3(snd(e)),co,f,d);
  691.                  break;
  692.  
  693.     case NUMCASE   : makeNumcase(snd(e),co,f,d);
  694.                  break;
  695.  
  696.     case CASE      : make(fst(snd(e)),co,SHOULDNTFAIL,RUNON);
  697.                  asEVAL();
  698.                  makeTests(testCase,snd(snd(e)),co,f,d);
  699.                  break;
  700.  
  701.     case GUARDED   : makeTests(testGuard,snd(e),co,f,d);
  702.                  break;
  703.  
  704.     case AP        : if (andorOptimise) {
  705.                  Cell h = getHead(e);
  706.                  if (h==nameAnd && argCount==2) {
  707.                  /* x && y ==> if x then y else False       */
  708.                  makeCond(arg(fun(e)),arg(e),nameFalse,co,f,d);
  709.                  break;
  710.                  }
  711.                  else if (h==nameOr && argCount==2) {
  712.                  /* x || y ==> if x then True else y       */
  713.                  makeCond(arg(fun(e)),nameTrue,arg(e),co,f,d);
  714.                  break;
  715.                  }
  716.              }
  717.                          buildAp(e,co,f,TRUE);
  718.                          asGOTO(d);
  719.                          break;
  720.  
  721.     case UNIT      :
  722.     case TUPLE     :
  723.     case NAME      : asCELL(e);
  724.                  asGOTO(d);
  725.                  break;
  726.  
  727.     /* for dict cells, ensure that CELL referred to in the code is the */
  728.     /* dictionary cell at the head of the dictionary; not just a copy  */
  729.  
  730.     case DICTCELL  : asCELL(dict(dictOf(e)));
  731.                  asGOTO(d);
  732.                  break;
  733.  
  734.     case ZERONUM   :
  735.     case POSNUM    :
  736.     case NEGNUM    : buildBignum(e);
  737.                  asGOTO(d);
  738.              break;
  739.  
  740.     case INTCELL   : asINTEGER(intOf(e));
  741.                  asGOTO(d);
  742.                  break;
  743.  
  744.         case FLOATCELL : asFLOAT(floatOf(e));
  745.                  asGOTO(d);
  746.              break;
  747.  
  748.     case STRCELL   : asSTRING(textOf(e));
  749.                  asGOTO(d);
  750.                  break;
  751.  
  752.     case CHARCELL  : asCHAR(charOf(e));
  753.                  asGOTO(d);
  754.                  break;
  755.  
  756.     case OFFSET    : asLOAD(offsPosn[offsetOf(e)]);
  757.                  asGOTO(d);
  758.                  break;
  759.  
  760.     default        : internal("make");
  761.     }
  762. }
  763.  
  764. static Void local makeCond(i,t,e,co,f,d)/* Build code for conditional       */
  765. Cell  i,t,e;
  766. Int   co;
  767. Label f;
  768. Label d; {
  769.     Label l1 = newLabel(RUNON);
  770.     Label l2 = newLabel(d);
  771.     Int   savesp;
  772.  
  773.     make(i,co,f,RUNON);
  774.     asEVAL();
  775.  
  776.     savesp = srsp;
  777.     asTEST(nameTrue,l1);
  778.     make(t,co,f,l2);
  779.  
  780.     srsp = savesp;
  781.     atLabel(l1);
  782.     make(e,co,f,l2);
  783.  
  784.     endLabel(d,l2);
  785. }
  786.  
  787. static Void local makeNumcase(nc,co,f,d)/* Build code for numcase       */
  788. Triple nc;
  789. Int    co;
  790. Label  f, d; {
  791.     Cell discr = snd3(nc);
  792.     Cell h     = getHead(discr);
  793.     make(fst3(nc),co,SHOULDNTFAIL,RUNON);
  794.     switch (whatIs(h)) {
  795.     case NAME   : if (h==nameFromInt) {
  796.               asINTEGER(intOf(arg(discr)));
  797.               make(arg(fun(discr)),co,SHOULDNTFAIL,RUNON);
  798.               asCELL(namePmInt);
  799.               }
  800.               else if (h==nameFromInteger) {
  801.               buildBignum(arg(discr));
  802.               make(arg(fun(discr)),co,SHOULDNTFAIL,RUNON);
  803.               asCELL(namePmInteger);
  804.               }
  805.               else if (h==nameFromDouble) {
  806.               asFLOAT(floatOf(arg(discr)));
  807.               make(arg(fun(discr)),co,SHOULDNTFAIL,RUNON);
  808.               asCELL(namePmFlt);
  809.               }
  810.               asMKAP(3);
  811.               asEVAL();
  812.               asTEST(nameTrue,f);
  813.               make(thd3(nc),co,f,d);
  814.               break;
  815. #if NPLUSK
  816.     case ADDPAT : asINTEGER(snd(h));
  817.               make(arg(discr),co,SHOULDNTFAIL,RUNON);
  818.               asCELL(namePmNpk);
  819.               asMKAP(3);
  820.               asEVAL();
  821.               asTEST(nameJust,f);
  822.               offsPosn[co+1] = ++srsp;
  823.               make(thd3(nc),co+1,f,d);
  824.               --srsp;
  825.               break;
  826. #endif
  827.     }
  828. }
  829.  
  830. static Void local testGuard(g,co,f,cf,d)/* Produce code for guard       */
  831. Pair  g;
  832. Int   co;
  833. Label f;
  834. Label cf;
  835. Label d; {
  836.     make(fst(g),co,SHOULDNTFAIL,RUNON);
  837.     asEVAL();
  838.     asTEST(nameTrue,cf);
  839.     make(snd(g),co,f,d);
  840. }
  841.  
  842. static Void local testCase(c,co,f,cf,d) /* Produce code for guard       */
  843. Pair  c;
  844. Int   co;                /* labels determine where to go if:*/
  845. Label f;                /* match succeeds, but rest fails  */
  846. Label cf;                /* this match fails           */
  847. Label d; {
  848.     Int n = discrArity(fst(c));
  849.     Int i;
  850.     switch (whatIs(fst(c))) {
  851.     case UNIT    :            /* typing guarantees that tags will*/
  852.     case TUPLE   : break;        /* match without further tests       */
  853.     default      : asTEST(fst(c),cf);
  854.                break;
  855.     }
  856.     for (i=1; i<=n; i++)
  857.     offsPosn[co+i] = ++srsp;
  858.     make(snd(c),co+n,f,d);
  859. }
  860.  
  861. /* --------------------------------------------------------------------------
  862.  * We frequently encounter functions which call themselves recursively with
  863.  * a number of initial arguments preserved:
  864.  * e.g.  (map f) []    = []
  865.  *     (map f) (x:xs) = f x : (map f) xs
  866.  * Lambda lifting, in particular, is likely to introduce such functions.
  867.  * Rather than reconstructing a new instance of the recursive function and
  868.  * its arguments, we can extract the relevant portion of the root of the
  869.  * current redex.
  870.  *
  871.  * The following functions implement this optimisation.
  872.  * ------------------------------------------------------------------------*/
  873.  
  874. static Int  nonRoots;               /* #args which can't get from root  */
  875. static Int  rootPortion;           /* portion of root used ...       */
  876. static Name definingName;           /* name of func being defined,if any*/
  877. static Int  definingArity;           /* arity of definingName        */
  878.  
  879. static Void local analyseAp(e)           /* Determine if any portion of an   */
  880. Cell e; {                   /* application can be built using a */
  881.     if (isAp(e)) {               /* portion of the root           */
  882.     analyseAp(fun(e));
  883.     if (nonRoots==0 && rootPortion>1
  884.             && isOffset(arg(e))
  885.             && offsetOf(arg(e))==rootPortion-1)
  886.         rootPortion--;
  887.     else
  888.         nonRoots++;
  889.     }
  890.     else if (e==definingName)
  891.     rootPortion = definingArity+1;
  892.     else
  893.     rootPortion = 0;
  894. }
  895.  
  896. static Void local buildAp(e,co,f,str)    /* Build application, making use of*/
  897. Cell  e;                /* root optimisation if poss.       */
  898. Int   co;
  899. Label f;
  900. Bool  str; {
  901.     Int nr, rp, i;
  902.  
  903.     nonRoots = 0;
  904.     analyseAp(e);
  905.     nr = nonRoots;
  906.     rp = rootPortion;
  907.  
  908.     for (i=0; i<nr; ++i) {
  909.     build(arg(e),co);
  910.     e = fun(e);
  911.     }
  912.  
  913.     if (isSelect(e)) {
  914.         if (selectOf(e)>0) {
  915.         asDICT(selectOf(e));
  916.     }
  917.     }
  918.     else {
  919.     if (isName(e) && name(e).defn==MFUN) {
  920.         asDICT(name(e).number);
  921.         nr--;    /* AP node for member function need never be built */
  922.     }
  923.     else {
  924.         if (0<rp && rp<=definingArity) {
  925.         asROOT(rp-1);
  926.             }
  927.         else
  928.         if (str)
  929.             make(e,co,f,RUNON);
  930.         else
  931.             build(e,co);
  932.     }
  933.  
  934.     if (nr>0) {
  935.         asMKAP(nr);
  936.         }
  937.     }
  938. }
  939.  
  940. /* --------------------------------------------------------------------------
  941.  * Code generator entry point:
  942.  * ------------------------------------------------------------------------*/
  943.  
  944. Addr codeGen(n,arity,e)            /* Generate code for expression e,  */
  945. Name n;                    /* treating return value of CAFs    */
  946. Int  arity;                   /* differently to functs with args  */
  947. Cell e; {
  948.     definingName  = n;
  949.     definingArity = arity;
  950.     asSTART();
  951.     if (nonNull(n)) {
  952.         Int i;
  953.         for (i=1; i<=arity; i++)
  954.         offsPosn[i] = ++srsp;
  955.         make(e,arity,noMatch,(arity>0 ? UPDRET : VALRET));
  956.     }
  957.     else {
  958.         build(e,0);
  959.         asRETURN();
  960.     }
  961.     asEND();
  962. #ifdef DEBUG_CODE
  963.     if (nonNull(n))
  964.     printf("name=%s\n",textToStr(name(n).text));
  965.     dissassemble(startInstr,lastInstr);
  966.     printf("------------------\n");
  967. #endif
  968.     if (nonNull(n))
  969.     name(n).defn  = NIL;
  970.     return startInstr;
  971. }
  972.  
  973. Void externalPrim(n,s)        /* Add name n as an external primitive;       */
  974. Name   n;            /* This is not currently implemented in       */
  975. String s; {            /* the current version of the interpreter  */
  976.     ERROR(name(n).line) "Unknown primitive reference \"%s\"", s
  977.     EEND;
  978. }
  979.  
  980. /* --------------------------------------------------------------------------
  981.  * Evaluator:
  982.  * ------------------------------------------------------------------------*/
  983.  
  984. Int   whnfArgs;                   /* number of arguments of whnf term */
  985. Cell  whnfHead;                   /* head cell of term in whnf       */
  986. Int   whnfInt;                   /* value of INTCELL (in whnf)       */
  987. Float whnfFloat;               /* value of FLOATCELL (in whnf)     */
  988. Long  numReductions;               /* number of reductions counted       */
  989.  
  990. static Cell    errorRedex;           /* irreducible error expression       */
  991. static jmp_buf *evalError = 0;           /* jump buffer for eval errors       */
  992.  
  993. Void eval(n)                   /* Graph reduction evaluator    */
  994. Cell n; {
  995.     StackPtr base = sp;
  996.     Int      ar;
  997.  
  998. unw:switch (whatIs(n)) {           /* unwind spine of application  */
  999.  
  1000.     case AP        : push(n);
  1001.              n = fun(n);
  1002.              goto unw;
  1003.  
  1004.     case INDIRECT  : n = arg(n);
  1005.              allowBreak();
  1006.              goto unw;
  1007.  
  1008.     case NAME      : ar = name(n).arity;
  1009.              if (name(n).defn!=CFUN && sp-base>=ar) {
  1010.                  allowBreak();
  1011.                  if (ar>0) {             /* fn with args*/
  1012.                  StackPtr root;
  1013.  
  1014.                  push(NIL);            /* rearrange   */
  1015.                  root = sp;
  1016.                  do {
  1017.                      stack(root) = arg(stack(root-1));
  1018.                      --root;
  1019.                  } while (--ar>0);
  1020.  
  1021.                  if (name(n).primDef)        /* reduce       */
  1022.                      (*name(n).primDef)(root);
  1023.                  else
  1024.                      run(name(n).code,root);
  1025.  
  1026.                  numReductions++;
  1027.  
  1028.                  sp = root;            /* continue... */
  1029.                  n  = pop();
  1030.                  }
  1031.                  else {                /* CAF       */
  1032.                  if (isNull(name(n).defn)) {/* build CAF   */
  1033.                      push(n);            /* save CAF    */
  1034.  
  1035.                      if (name(n).primDef)
  1036.                      (*name(n).primDef)(sp);
  1037.                      else
  1038.                      run(name(n).code,sp);
  1039.  
  1040.                      numReductions++;
  1041.  
  1042.                      name(n).defn = pop();
  1043.                      drop();            /* drop CAF    */
  1044.                  }
  1045.                  n = name(n).defn;        /*already built*/
  1046.                  if (sp>base)
  1047.                      fun(top()) = n;
  1048.                  }
  1049.                  goto unw;
  1050.              }
  1051.              break;
  1052.  
  1053.     case INTCELL   : whnfInt = intOf(n);
  1054.              break;
  1055.  
  1056.         case FLOATCELL : whnfFloat = floatOf(n);
  1057.              break;
  1058.  
  1059.     case STRCELL   : evalString(n);
  1060.              goto unw;
  1061.  
  1062.     case FILECELL  : evalFile(n);
  1063.              goto unw;
  1064.     }
  1065.  
  1066.     whnfHead = n;               /* rearrange components of term on  */
  1067.     whnfArgs = sp - base;           /* stack, now in whnf ...       */
  1068.     for (ar=whnfArgs; ar>0; ar--) {
  1069.     fun(stack(base+ar)) = n;
  1070.     n            = stack(base+ar);
  1071.     stack(base+ar)        = arg(n);
  1072.     }
  1073. }
  1074.  
  1075. Void unwind(n)                   /* unwind spine of application;       */
  1076. Cell n; {                   /* like eval except that we always  */
  1077.     whnfArgs = 0;               /* treat the expression n as if it  */
  1078.                        /* were already in whnf.        */
  1079. unw:switch (whatIs(n)) {
  1080.     case AP        : push(arg(n));
  1081.              whnfArgs++;
  1082.              n = fun(n);
  1083.              goto unw;
  1084.  
  1085.     case INDIRECT  : n = arg(n);
  1086.              allowBreak();
  1087.              goto unw;
  1088.  
  1089.     case INTCELL   : whnfInt = intOf(n);
  1090.              break;
  1091.  
  1092.         case FLOATCELL : whnfFloat = floatOf(n);
  1093.              break;
  1094.  
  1095.     case STRCELL   : evalString(n);
  1096.              goto unw;
  1097.     }
  1098.     whnfHead = n;
  1099. }
  1100.  
  1101. static Void local evalString(n)        /* expand STRCELL at node n       */
  1102. Cell n; {
  1103.     Text t = textOf(n);
  1104.     Int  c = textToStr(t)[0];
  1105.     if (c==0) {
  1106.     fst(n) = INDIRECT;
  1107.     snd(n) = nameNil;
  1108.     return;
  1109.     }
  1110.     else if (c=='\\') {
  1111.     c = textToStr(++t)[0];
  1112.         if (c!='\\')
  1113.         c = 0;
  1114.     }
  1115.     fst(n) = consChar(c);
  1116.     snd(n) = mkStr(++t);
  1117. }
  1118.  
  1119. static Void local run(start,root)      /* execute code beginning at given  */
  1120. Addr     start;                   /* address with local stack starting*/
  1121. StackPtr root; {               /* at given root offset           */
  1122.     register Memory pc = memory+start;
  1123.  
  1124. #if     GCC_THREADED
  1125. #define Ins(x)        &&l##x
  1126. static  void *labs[] = { INSTRLIST };
  1127. #undef  Ins
  1128. #define Case(x)        l##x
  1129. #define    Continue    goto *labs[(pc++)->instr]
  1130. #define    Dispatch    Continue;
  1131. #define EndDispatch
  1132. #else
  1133. #define Dispatch    for (;;) switch((pc++)->instr) {
  1134. #define    Case(x)        case x
  1135. #define    Continue    continue
  1136. #define EndDispatch    default : internal("illegal instruction"); \
  1137.                   break;               \
  1138.             }
  1139. #endif
  1140.  
  1141.     Dispatch
  1142.  
  1143.     Case(iLOAD)   : push(stack(root+pc->mint));     /* load from stack*/
  1144.             pc++;
  1145.             Continue;
  1146.  
  1147.     Case(iCELL)   : push(pc->cell);             /* load const Cell*/
  1148.             pc++;
  1149.             Continue;
  1150.  
  1151.     Case(iCHAR)   : push(mkChar(pc->mint));         /* load char const*/
  1152.             pc++;
  1153.             Continue;
  1154.  
  1155.     Case(iINT)    : push(mkInt(pc->mint));         /* load int const */
  1156.             pc++;
  1157.             Continue;
  1158.  
  1159. #if BREAK_FLOATS
  1160.     Case(iFLOAT)  : push(mkFloat(floatFromParts     /* load dbl const */
  1161.                 (pc->cell,(pc+1)->cell)));
  1162.             pc+=2;
  1163.             Continue;
  1164. #else
  1165.     Case(iFLOAT)  : push(mkFloat(pc->mfloat));     /* load float cnst*/
  1166.             pc++;
  1167.             Continue;
  1168. #endif
  1169.  
  1170.     Case(iSTRING) : push(mkStr(pc->text));         /* load str const */
  1171.             pc++;
  1172.             Continue;
  1173.  
  1174.     Case(iMKAP)   : {   Cell t = pushed(0);         /* make AP nodes  */
  1175.                 Int  i = pc->text;
  1176.                 while (0<i--) {
  1177.                 drop();
  1178.                 t=ap(t,pushed(0));
  1179.                 }
  1180.                 pushed(0)=t;
  1181.             }
  1182.             pc++;
  1183.             Continue;
  1184.  
  1185.     Case(iUPDATE) : {   Cell t = stack(root        /* update cell ...*/
  1186.                          + pc->mint);
  1187.                 fst(t) = INDIRECT;
  1188.                 snd(t) = pop();
  1189.             }
  1190.             pc++;
  1191.             Continue;
  1192.  
  1193.     Case(iUPDAP)  : {   Cell t = stack(root         /* update AP node */
  1194.                          + pc->mint);
  1195.                 fst(t) = pop();
  1196.                 snd(t) = pop();
  1197.             }
  1198.             pc++;
  1199.             Continue;
  1200.  
  1201.     Case(iEVAL)   : eval(pop());             /* evaluate top() */
  1202.             Continue;
  1203.  
  1204.     Case(iRETURN) : return;                 /* terminate       */
  1205.  
  1206.     Case(iTEST)   : if (whnfHead==pc->cell)         /* test for cell  */
  1207.                 pc += 2;
  1208.             else
  1209.                 pc = memory + (pc+1)->addr;
  1210.             Continue;
  1211.  
  1212.     Case(iGOTO)   : pc = memory + pc->addr;         /* goto label       */
  1213.             Continue;
  1214.  
  1215.     Case(iSETSTK) : sp=root + pc->mint;          /* set stack ptr  */
  1216.             pc++;
  1217.             Continue;
  1218.  
  1219.     Case(iALLOC)  : {   Int i = pc->mint;         /* alloc loc vars */
  1220.                 chkStack(i);
  1221.                 while (0<i--)
  1222.                 onto(ap(NIL,NIL));
  1223.             }
  1224.             pc++;
  1225.             Continue;
  1226.  
  1227.     Case(iDICT)   : top() = dict(dictOf(top()) + pc->mint);
  1228.             pc++;                 /* dict lookup    */
  1229.             Continue;
  1230.  
  1231.     Case(iROOT)   : {   Cell t = stack(root);     /* partial root   */
  1232.                 Int  i = pc->mint;
  1233.                 while (fst(t)==INDIRECT) {
  1234.                 allowBreak();
  1235.                 t = arg(t);
  1236.                 }
  1237.                 while (0<i--) {
  1238.                 t = fun(t);
  1239.                 while (fst(t)==INDIRECT) {
  1240.                     allowBreak();
  1241.                     t = arg(t);
  1242.                 }
  1243.                 }
  1244.                 push(t);
  1245.             }
  1246.             pc++;
  1247.             Continue;
  1248.  
  1249.     Case(iSLIDE)  : pushed(pc->mint) = top();     /* remove loc vars*/
  1250.             sp -= pc->mint;
  1251.             pc++;
  1252.             Continue;
  1253.  
  1254.     Case(iTABLE)  :
  1255.     Case(iFAIL)   : evalFails(root);         /* cannot reduce  */
  1256.             return;/*NOT REACHED*/
  1257.  
  1258.     EndDispatch
  1259.  
  1260. #undef Dispatch
  1261. #undef Case
  1262. #undef Continue
  1263. #undef EndDispatch
  1264. }
  1265.  
  1266. Cell evalWithNoError(e)            /* Evaluate expression, returning   */
  1267. Cell e; {                   /* NIL if successful, irreducible   */
  1268.     Cell badRedex;               /* expression if not...           */
  1269.     jmp_buf *oldCatch = evalError;
  1270.  
  1271. #if JMPBUF_ARRAY
  1272.     jmp_buf catch[1];
  1273.     evalError = catch;
  1274.     if (setjmp(catch[0])==0) {
  1275.     eval(e);
  1276.     badRedex = NIL;
  1277.     }
  1278.     else
  1279.     badRedex = errorRedex;
  1280. #else
  1281.     jmp_buf catch;
  1282.     evalError = &catch;
  1283.     if (setjmp(catch)==0) {
  1284.         eval(e); 
  1285.     badRedex = NIL;
  1286.     }
  1287.     else
  1288.         badRedex = errorRedex;
  1289. #endif
  1290.  
  1291.     evalError = oldCatch;
  1292.     return badRedex;
  1293. }
  1294.  
  1295. Void evalFails(root)            /* Eval of current redex fails       */
  1296. StackPtr root; {
  1297.     errorRedex = stack(root);        /* get error & bypass indirections */
  1298.     while (isPair(errorRedex) && fst(errorRedex)==INDIRECT)
  1299.     errorRedex = snd(errorRedex);
  1300.  
  1301.     if (failOnError)
  1302.     abandon("Program",errorRedex);
  1303.     else if (evalError)
  1304.     longjmp(*evalError,1);
  1305.     else
  1306.     internal("uncaught eval error");
  1307. }
  1308.  
  1309. Cell graphForExp() {            /* Build graph for expression to be*/
  1310.     clearStack();            /* reduced...               */
  1311.     run(inputCode,sp);
  1312. #ifdef DEBUG_CODE
  1313. printf("graphForExp() returns: ");
  1314. printExp(stdout,top());
  1315. putchar('\n');
  1316. #endif
  1317.     return pop();
  1318. }
  1319.  
  1320. /* --------------------------------------------------------------------------
  1321.  * Machine control:
  1322.  * ------------------------------------------------------------------------*/
  1323.  
  1324. Void machine(what)
  1325. Int what; {
  1326.     switch (what) {
  1327.     case INSTALL : machine(RESET);
  1328.                memory  = (Memory)farCalloc(NUM_ADDRS,sizeof(MemCell));
  1329.                if (memory==0)
  1330.                fatal("Cannot allocate program memory");
  1331.                instrNone(iFAIL);
  1332.                noMatch = lastInstr;
  1333.                break;
  1334.     }
  1335. }
  1336.  
  1337. /* ------------------------------------------------------------------------*/
  1338.