home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / gofer / Sources / c / cmachine < prev    next >
Encoding:
Text File  |  1993-02-18  |  51.1 KB  |  1,922 lines
  1. /* --------------------------------------------------------------------------
  2.  * cmachine.c:  Copyright (c) Mark P Jones 1991-1993.   All rights reserved.
  3.  *              See goferite.h for details and conditions of use etc...
  4.  *        Gofer Compiler version 1.01 February 1992
  5.  *              Incorporated into mainstream Gofer 2.25, October 1992.
  6.  *              Gofer version 2.28 January 1993
  7.  *
  8.  * Compilation to simple G-code & (slightly) optimised translation to C code
  9.  * ------------------------------------------------------------------------*/
  10.  
  11. #include "prelude.h"
  12. #include "storage.h"
  13. #include "connect.h"
  14. #include "errors.h"
  15. #include <setjmp.h>
  16. #include <ctype.h>
  17.  
  18. #ifndef GOFC_INCLUDE
  19. #if     (TURBOC | BCC | DJGPP)
  20. #define GOFC_INCLUDE  "\"/gofer/gofc/gofc.h\""
  21. #else
  22. #if !RISCOS
  23. #define GOFC_INCLUDE  "\"/usr/local/lib/Gofer/gofc.h\""
  24. #else
  25. #define GOFC_INCLUDE "\"Lib:h.gofc\""
  26. #endif     
  27. #endif
  28. #endif
  29.  
  30. /*#define DEBUG_CODE*/
  31.  
  32. Bool   andorOptimise = TRUE;        /* TRUE => optimise uses of &&, || */
  33.  
  34. /* --------------------------------------------------------------------------
  35.  * Data structures for machine memory (program storage):
  36.  * ------------------------------------------------------------------------*/
  37.  
  38. typedef enum {
  39.     iLOAD,   iCELL,   iCHAR,   iINT,   iFLOAT,
  40.     iSTRING, iMKAP,   iUPDATE, iUPDAP, iEVAL,
  41.     iRETURN, iINTGE,  iINTEQ,  iINTDV, iTEST,
  42.     iGOTO,   iSETSTK, iALLOC,  iSLIDE, iROOT,
  43.     iDICT,   iFLUSH,  iLABEL,  iEND
  44. } Instr;
  45.  
  46. typedef Int Label;
  47.  
  48. typedef union {
  49.     Int   intVal;
  50. #if !BREAK_FLOATS
  51.     Float floatVal;
  52. #endif
  53.     Cell  cellVal;
  54.     Text  textVal;
  55.     Instr instrVal;
  56.     Label labVal;
  57. } MemCell;
  58.  
  59. typedef MemCell far *Memory;
  60. static    Memory        memory;
  61. #define intAt(m)    memory[m].intVal
  62. #if !BREAK_FLOATS
  63. #define floatAt(m)  memory[m].floatVal
  64. #endif
  65. #define cellAt(m)   memory[m].cellVal
  66. #define textAt(m)   memory[m].textVal
  67. #define instrAt(m)  memory[m].instrVal
  68. #define labAt(m)    memory[m].labVal
  69.  
  70. /* --------------------------------------------------------------------------
  71.  * Local function prototypes:
  72.  * ------------------------------------------------------------------------*/
  73.  
  74. static Void   local instrNone     Args((Instr));
  75. static Void   local instrInt     Args((Instr,Int));
  76. static Void   local instrFloat   Args((Instr,FloatPro));
  77. static Void   local instrCell     Args((Instr,Cell));
  78. static Void   local instrText     Args((Instr,Text));
  79. static Void   local instrLab     Args((Instr,Label));
  80. static Void   local instrIntLab     Args((Instr,Int,Label));
  81. static Void   local instrCellLab Args((Instr,Cell,Label));
  82.  
  83. static Void   local asSTART     Args((Void));
  84. static Label  local newLabel     Args((Void));
  85. static Void   local asLABEL     Args((Label));
  86. static Void   local asEND     Args((Void));
  87.  
  88. static Void   local asMKAP     Args((Int));
  89. static Void   local asUPDATE     Args((Int));
  90.  
  91. #ifdef DEBUG_CODE
  92. static Void   local dissassemble Args((Addr));
  93. static Void   local printCell     Args((Cell));
  94. static Addr   local dissNone     Args((Addr,String));
  95. static Addr   local dissInt     Args((Addr,String));
  96. static Addr   local dissFloat    Args((Addr,String));
  97. static Addr   local dissCell     Args((Addr,String));
  98. static Addr   local dissText     Args((Addr,String));
  99. static Addr   local dissLab     Args((Addr,String));
  100. static Addr   local dissIntLab     Args((Addr,String));
  101. static Addr   local dissCellLab     Args((Addr,String));
  102. #endif
  103.  
  104. static Void   local doCont     Args((Pair));
  105. static Pair   local flush     Args((Pair));
  106. static Void   local make     Args((Cell,Int,Label,Pair));
  107. static Void   local makeCond     Args((Cell,Cell,Cell,Int,Label,Pair));
  108. static Void   local makeCase     Args((Cell,Int,Label,Pair));
  109. static Void   local testCase     Args((Pair,Int,Label,Label,Pair));
  110. static Void   local makeGded     Args((List,Int,Label,Pair));
  111. static Bool   local testGuard     Args((Pair,Int,Label,Label,Pair));
  112.  
  113. static Void   local dependsOn     Args((Cell));
  114. static Void   local build     Args((Cell,Int));
  115. static Void   local buildGuards     Args((List,Int));
  116. static Int    local buildLoc     Args((List,Int));
  117.  
  118. static Void   local analyseAp     Args((Cell));
  119. static Void   local buildAp     Args((Cell,Int,Label,Bool));
  120.  
  121. static List   local identifyDeps Args((Name));
  122. static Void   local checkPrimDep Args((Name,Name));
  123. static Void   local outputCDecls Args((FILE *,List));
  124. static Void   local outputCDicts Args((FILE *));
  125.  
  126. static Void   local rspRecalc     Args((Void));
  127.  
  128. static Void   local outputCSc     Args((FILE *,Name));
  129. static List   local cCode     Args((Int,Addr));
  130. static List   local heapUse     Args((List));
  131. static List   local heapAnalyse     Args((List));
  132. static Void   local outputCinst     Args((FILE *,Cell));
  133.  
  134. static Void   local expr     Args((FILE *,Cell));
  135. static Void   local outputLabel  Args((FILE *,Int));
  136. static Void   local outputJump     Args((FILE *,Int));
  137. static Void   local outputCStr     Args((FILE *, String));
  138. static Bool   local validCstring Args((String));
  139. static String local scNameOf     Args((Name));
  140.  
  141. static Void   local startTable     Args((String,String,String));
  142. static Void   local tableItem     Args((FILE *,String));
  143. static Void   local finishTable     Args((FILE *));
  144.  
  145. /* --------------------------------------------------------------------------
  146.  * Assembler: (Low level, instruction code storage)
  147.  * ------------------------------------------------------------------------*/
  148.  
  149. static Addr  startInstr;        /* first instruction after START   */
  150. static Addr  lastInstr;            /* last instr written (for peephole*/
  151.                     /* optimisations etc.)           */
  152. static Int   srsp;            /* simulated runtime stack pointer */
  153. static Int   offsPosn[NUM_OFFSETS];    /* mapping from logical to physical*/
  154.                     /* offset positions           */
  155.  
  156. static Void local instrNone(opc)    /* Opcode with no operands       */
  157. Instr opc; {
  158.     lastInstr           = getMem(1);
  159.     instrAt(lastInstr) = opc;
  160. }
  161.  
  162. static Void local instrInt(opc,n)    /* Opcode with integer operand       */
  163. Instr opc;
  164. Int   n; {
  165.     lastInstr           = getMem(2);
  166.     instrAt(lastInstr) = opc;
  167.     intAt(lastInstr+1) = n;
  168. }
  169.  
  170. static Void local instrFloat(opc,fl)    /* Opcode with Float operand       */
  171. Instr opc;
  172. FloatPro fl; {
  173. #if BREAK_FLOATS
  174.     lastInstr         = getMem(3);
  175.     instrAt(lastInstr)     = opc;
  176.     cellAt(lastInstr+1)     = part1Float(fl);
  177.     cellAt(lastInstr+2)     = part2Float(fl);
  178. #else
  179.     lastInstr            = getMem(2);
  180.     instrAt(lastInstr)   = opc;
  181.     floatAt(lastInstr+1) = fl;
  182. #endif
  183. }
  184.  
  185. static Void local instrCell(opc,c)    /* Opcode with Cell operand       */
  186. Instr opc;
  187. Cell  c; {
  188.     lastInstr        = getMem(2);
  189.     instrAt(lastInstr)    = opc;
  190.     cellAt(lastInstr+1) = c;
  191. }
  192.  
  193. static Void local instrText(opc,t)    /* Opcode with Text operand       */
  194. Instr opc;
  195. Text  t; {
  196.     lastInstr        = getMem(2);
  197.     instrAt(lastInstr)    = opc;
  198.     textAt(lastInstr+1) = t;
  199. }
  200.  
  201. static Void local instrLab(opc,l)    /* Opcode with label operand       */
  202. Instr opc;
  203. Label l; {
  204.     lastInstr           = getMem(2);
  205.     instrAt(lastInstr) = opc;
  206.     labAt(lastInstr+1) = l;
  207.     if (l<0)
  208.     internal("bad Label");
  209. }
  210.  
  211. static Void local instrIntLab(opc,n,l)    /* Opcode with int, label operands */
  212. Instr opc;
  213. Int   n;
  214. Label l; {
  215.     lastInstr           = getMem(3);
  216.     instrAt(lastInstr) = opc;
  217.     intAt(lastInstr+1) = n;
  218.     labAt(lastInstr+2) = l;
  219.     if (l<0)
  220.     internal("bad Label");
  221. }
  222.  
  223. static Void local instrCellLab(opc,c,l)    /* Opcode with cell, label operands*/
  224. Instr opc;
  225. Cell  c;
  226. Label l; {
  227.     lastInstr        = getMem(3);
  228.     instrAt(lastInstr)    = opc;
  229.     cellAt(lastInstr+1) = c;
  230.     labAt(lastInstr+2)    = l;
  231.     if (l<0)
  232.     internal("bad Label");
  233. }
  234.  
  235. /* --------------------------------------------------------------------------
  236.  * Main low level assembler control: (includes label assignment and fixup)
  237.  * ------------------------------------------------------------------------*/
  238.  
  239. static    Label        nextLab;        /* next label number to allocate   */
  240. static  Label       fixups[NUM_FIXUPS]; /* fixups for label values       */
  241. #define FAIL        0            /* special label for fail()       */
  242.  
  243. #define fix(a)      labAt(a) = fixups[labAt(a)]
  244.  
  245. static Void local asSTART() {        /* initialise assembler           */
  246.     fixups[0]    = FAIL;            /* use label 0 for fail()       */
  247.     nextLab    = 1;
  248.     startInstr    = getMem(0);
  249.     lastInstr    = startInstr-1;
  250.     srsp    = 0;
  251.     offsPosn[0]    = 0;
  252. }
  253.  
  254. static Label local newLabel() {        /* allocate new label           */
  255.     if (nextLab>=NUM_FIXUPS) {
  256.     ERROR(0) "Compiled code too complex"
  257.     EEND;
  258.     }
  259.     return nextLab++;
  260. }
  261.  
  262. static Void local asLABEL(l)        /* indicate label reached       */
  263. Label l; {
  264.     if (instrAt(lastInstr)==iGOTO && labAt(lastInstr+1)==l) {
  265.     instrAt(lastInstr) = iLABEL;    /* GOTO l; LABEL l  ==>  LABEL l   */
  266.     fixups[l] = l;
  267.     }
  268.     else if (instrAt(lastInstr)==iLABEL)/* code already labelled at this pt*/
  269.     fixups[l] = labAt(lastInstr+1);    /* so use previous label       */
  270.     else {
  271.     instrLab(iLABEL,l);        /* otherwise insert new label       */
  272.     fixups[l] = l;
  273.     }
  274. }
  275.  
  276. static Void local asEND() {        /* Fix addresses in assembled code */
  277.     Addr pc = startInstr;
  278.  
  279.     instrNone(iEND);            /* insert END opcode           */
  280.     for (;;)
  281.     switch (instrAt(pc)) {
  282.         case iEND     : return;    /* end of code sequence           */
  283.  
  284.         case iEVAL     :        /* opcodes taking no arguments       */
  285.         case iFLUSH  :
  286.         case iRETURN : pc++;
  287.                break;
  288.  
  289.         case iGOTO     : fix(pc+1);    /* opcodes taking one argument       */
  290.         case iLABEL     : /* no need for a fix here !*/
  291.         case iSETSTK :
  292.         case iALLOC  :
  293.         case iSLIDE  :
  294.         case iROOT     :
  295.             case iDICT   :
  296.         case iLOAD     :
  297.         case iCELL     :
  298.         case iCHAR     :
  299.         case iINT     :
  300. #if !BREAK_FLOATS
  301.         case iFLOAT  :
  302. #endif
  303.         case iSTRING :
  304.         case iMKAP     :
  305.         case iUPDATE :
  306.         case iUPDAP  : pc+=2;
  307.                break;
  308. #if BREAK_FLOATS
  309.         case iFLOAT  : pc+=3;
  310.                break;
  311. #endif
  312.  
  313.         case iINTGE  :        /* opcodes taking two arguments       */
  314.         case iINTEQ  :
  315.         case iINTDV     :
  316.         case iTEST     : fix(pc+2);
  317.                pc+=3;
  318.                break;
  319.  
  320.         default     : internal("asEND");
  321.     }
  322. }
  323.  
  324. /* --------------------------------------------------------------------------
  325.  * Assembler Opcodes: (includes simple peephole optimisations)
  326.  * ------------------------------------------------------------------------*/
  327.  
  328. #define asINTEGER(n) instrInt(iINT,n);        srsp++
  329. #define asFLOAT(fl)  instrFloat(iFLOAT,fl);    srsp++
  330. #define asCHAR(n)    instrInt(iCHAR,n);        srsp++
  331. #define asLOAD(n)    instrInt(iLOAD,n);        srsp++
  332. #define asALLOC(n)   instrInt(iALLOC,n);    srsp+=n
  333. #define asROOT(n)    instrInt(iROOT,n);        srsp++
  334. #define asSETSTK(n)  instrInt(iSETSTK,n);    srsp=n
  335. #define asEVAL()     instrNone(iEVAL);        srsp--  /* inaccurate srsp */
  336. #define asFLUSH()    instrNone(iFLUSH)
  337. #define asRETURN()   instrNone(iRETURN)
  338. #define asCELL(c)    instrCell(iCELL,c);    srsp++
  339. #define asTEST(c,l)  instrCellLab(iTEST,c,l)        /* inaccurate srsp */
  340. #define asINTGE(n,l) instrIntLab(iINTGE,n,l)        /* inaccurate srsp */
  341. #define asINTEQ(n,l) instrIntLab(iINTEQ,n,l)
  342. #define asINTDV(n,l) instrIntLab(iINTDV,n,l)        /* inaccurate srsp */
  343. #define asGOTO(l)    instrLab(iGOTO,l)
  344. #define asSLIDE(n)   instrInt(iSLIDE,n);    srsp-=n
  345. #define asDICT(n)    if (n>0) instrInt(iDICT,n)
  346. #define asSTRING(t)  if (*textToStr(t))            \
  347.              instrText(iSTRING,t);        \
  348.              else                \
  349.              instrCell(iCELL,nameNil);    \
  350.              srsp++
  351.  
  352. static Void local asMKAP(n)        /* Make application nodes ...       */
  353. Int n; {
  354.     if (instrAt(lastInstr)==iMKAP)    /* Peephole optimisation:       */
  355.     intAt(lastInstr+1)+=n;        /* MKAP n; MKAP m  ===> MKAP (n+m) */
  356.     else
  357.     instrInt(iMKAP,n);
  358.     srsp -= n;
  359. }
  360.  
  361. static Void local asUPDATE(n)        /* Update node ...           */
  362. Int n; {
  363.     if (instrAt(lastInstr)==iMKAP) {    /* Peephole optimisations:       */
  364.     if (intAt(lastInstr+1)>1) {    /* MKAP (n+1); UPDATE p           */
  365.         intAt(lastInstr+1)--;    /*          ===> MKAP n; UPDAP p */
  366.         instrInt(iUPDAP,n);
  367.     }
  368.     else {
  369.         instrAt(lastInstr) = iUPDAP;
  370.         intAt(lastInstr+1) = n;    /* MKAP 1; UPDATE p ===> UPDAP p   */
  371.     }
  372.     }
  373.     else
  374.     instrInt(iUPDATE,n);
  375.     srsp--;
  376. }
  377.  
  378. /* --------------------------------------------------------------------------
  379.  * Dissassembler:
  380.  * ------------------------------------------------------------------------*/
  381.  
  382. #ifdef DEBUG_CODE
  383. static Void local dissassemble(pc)    /* print dissassembly of code       */
  384. Addr pc; {
  385.     for (;;)
  386.     switch (instrAt(pc)) {
  387.         case iEND     : return;
  388.         case iLOAD     : pc = dissInt(pc,"LOAD");     break;
  389.         case iCELL     : pc = dissCell(pc,"CELL");     break;
  390.         case iCHAR     : pc = dissInt(pc,"CHAR");     break;
  391.         case iINT     : pc = dissInt(pc,"INT");     break;
  392.         case iFLOAT  : pc = dissFloat(pc,"FLOAT");   break;
  393.         case iSTRING : pc = dissText(pc,"STRING");     break;
  394.         case iMKAP     : pc = dissInt(pc,"MKAP");     break;
  395.         case iUPDATE : pc = dissInt(pc,"UPDATE");     break;
  396.         case iUPDAP  : pc = dissInt(pc,"UPDAP");     break;
  397.         case iEVAL     : pc = dissNone(pc,"EVAL");     break;
  398.         case iFLUSH  : pc = dissNone(pc,"FLUSH");     break;
  399.         case iRETURN : pc = dissNone(pc,"RETURN");     break;
  400.         case iSETSTK : pc = dissInt(pc,"SETSTK");     break;
  401.         case iALLOC  : pc = dissInt(pc,"ALLOC");     break;
  402.         case iSLIDE  : pc = dissInt(pc,"SLIDE");     break;
  403.         case iROOT     : pc = dissInt(pc,"ROOT");     break;
  404.             case iDICT   : pc = dissInt(pc,"DICT");      break;
  405.         case iINTGE  : pc = dissIntLab(pc,"INTGE");     break;
  406.         case iINTEQ  : pc = dissIntLab(pc,"INTEQ");     break;
  407.         case iINTDV  : pc = dissIntLab(pc,"INTDV");     break;
  408.         case iTEST     : pc = dissCellLab(pc,"TEST");     break;
  409.         case iGOTO     : pc = dissLab(pc,"GOTO");     break;
  410.         case iLABEL  : pc = dissLab(pc,"LABEL");     break;
  411.         default     : internal("unknown instruction");
  412.     }
  413. }
  414.  
  415. static Void local printCell(c)           /* printable representation of Cell */
  416. Cell c; {
  417.     if (isName(c))
  418.     printf("%s",textToStr(name(c).text));
  419.     else
  420.     printf("$%d",c);
  421. }
  422.  
  423. static Addr local dissNone(pc,s)       /* dissassemble instr no args       */
  424. Addr   pc;
  425. String s; {
  426.     printf("%s\n",s);
  427.     return pc+1;
  428. }
  429.  
  430. static Addr local dissInt(pc,s)        /* dissassemble instr with Int arg  */
  431. Addr   pc;
  432. String s; {
  433.     printf("%s\t%d\n",s,intAt(pc+1));
  434.     return pc+2;
  435. }
  436.  
  437. static Addr local dissFloat(pc,s)      /* dissassemble instr with Float arg*/
  438. Addr   pc;
  439. String s; {
  440. #if BREAK_FLOATS
  441.     printf("%s\t%s\n",s,
  442.     floatToString(floatFromParts(cellAt(pc+1),cellAt(pc+2))));
  443.     return pc+3;
  444. #else
  445.     printf("%s\t%s\n",s,floatToString(floatAt(pc+1)));
  446.     return pc+2;
  447. #endif
  448. }
  449.  
  450. static Addr local dissCell(pc,s)       /* dissassemble instr with Cell arg */
  451. Addr   pc;
  452. String s; {
  453.     printf("%s\t",s);
  454.     printCell(cellAt(pc+1));
  455.     printf("\n");
  456.     return pc+2;
  457. }
  458.  
  459. static Addr local dissText(pc,s)       /* dissassemble instr with Text arg */
  460. Addr   pc;
  461. String s; {
  462.     printf("%s\t%s\n",s,textToStr(textAt(pc+1)));
  463.     return pc+2;
  464. }
  465.  
  466. static Addr local dissLab(pc,s)       /* dissassemble instr with Label arg */
  467. Addr   pc;
  468. String s; {
  469.     printf("%s\t%d\n",s,labAt(pc+1));
  470.     return pc+2;
  471. }
  472.  
  473. static Addr local dissIntLab(pc,s)    /* dissassemble instr with Int+Label */
  474. Addr   pc;
  475. String s; {
  476.     printf("%s\t%d\t%d\n",s,intAt(pc+1),labAt(pc+2));
  477.     return pc+3;
  478. }
  479.  
  480. static Addr local dissCellLab(pc,s)   /* dissassemble instr with Cell+Label*/
  481. Addr   pc;
  482. String s; {
  483.     printf("%s\t",s);
  484.     printCell(cellAt(pc+1));
  485.     printf("\t%d\n",labAt(pc+2));
  486.     return pc+3;
  487. }
  488. #endif
  489.  
  490. /* --------------------------------------------------------------------------
  491.  * Compile expression to code which will build expression evaluating guards
  492.  * and testing cases to avoid building complete graph.
  493.  *
  494.  * This section of code has been rewritten from the original form in
  495.  * version 2.21 of the interpreter to use a more sophisticated form of
  496.  * continuation rather than the simple UPDRET/SHOULDNTFAIL/label etc
  497.  * used in that program.  The aim of this rewrite is (of course) to try
  498.  * and produce better output code.  The basic type for continuations is:
  499.  *
  500.  *    type Continuation = (Int, ThenWhat)
  501.  *    data ThenWhat      = RUNONC         -- next instr
  502.  *              | FRUNONC        -- FLUSH then next instr
  503.  *              | BRANCH Label    -- branch to label
  504.  *              | FBRANCH Label    -- FLUSH then branch
  505.  *              | UPDRETC        -- UPDATE 0; RETURN
  506.  *
  507.  * As an example of the kind of optimisations we can get by this:
  508.  *
  509.  *  ...; MKAP 4; SLIDE m ; UPDATE 0 ; RETURN
  510.  *                     ====> ...; MKAP 3; UPDAP 0; RETURN
  511.  *
  512.  *  ...; MKAP 2; FLUSH ; UPDATE 0; RETURN
  513.  *                     ====> ...; MKAP 1; UPDAP 0; RETURN
  514.  *
  515.  *  ...; SLIDE m; SLIDE n; ...       ====> ...; SLIDE (m+n); ...
  516.  *  (this one was previously obtained by a peephole optimisation)
  517.  * ------------------------------------------------------------------------*/
  518.  
  519. static Pair shouldntFail;        /* error continuation           */
  520. static Pair functionReturn;        /* initial function continuation   */
  521. static Pair noAction;            /* skip continuation           */
  522.  
  523. static Void local doCont(c)        /* insert code for continuation    */
  524. Pair c; {
  525.     Int sl = intOf(fst(c));
  526.     switch (whatIs(snd(c))) {
  527.     case FRUNONC : asFLUSH();
  528.     case RUNONC  : if (sl>0) {
  529.                asSLIDE(sl);
  530.                }
  531.                break;
  532.  
  533.     case FBRANCH : asFLUSH();
  534.     case BRANCH  : if (sl>0) {
  535.                asSLIDE(sl);
  536.                }
  537.                asGOTO(intOf(snd(snd(c))));
  538.                break;
  539.  
  540.     case UPDRETC : asUPDATE(0);
  541.                asRETURN();
  542.                        break;
  543.  
  544.     case ERRCONT :
  545.     default         : internal("doCont");
  546.     }
  547. }
  548.  
  549. #define slide(n,d)   pair(mkInt(intOf(fst(d))+n),snd(d))
  550. #define isRunon(d)   (snd(d)==RUNONC || snd(d)==FRUNONC)
  551. #define fbranch(l,d) pair(fst(d),ap(FBRANCH,l))
  552. #define frunon(d)    pair(fst(d),FRUNONC)
  553.  
  554. static Pair local flush(d)        /* force flush on continuation       */
  555. Pair d; {
  556.     switch (whatIs(snd(d))) {
  557.     case RUNONC : return frunon(d);
  558.     case BRANCH : return fbranch(snd(snd(d)),d);
  559.     default        : return d;
  560.     }
  561. }
  562.  
  563. static Void local make(e,co,f,d)    /* Construct code to build e, given*/
  564. Cell  e;                /* current offset co, and branch   */
  565. Int   co;                /* to f on failure, d on completion*/
  566. Label f;
  567. Pair  d; {
  568.     switch (whatIs(e)) {
  569.  
  570.     case LETREC    : {   Int n = buildLoc(fst(snd(e)),co);
  571.                  make(snd(snd(e)),co+n,f,slide(n,d));
  572.                  }
  573.                  break;
  574.  
  575.     case FATBAR    : if (isRunon(d)) {
  576.                  Label l1     = newLabel();
  577.                  Label l2     = newLabel();
  578.                  Int   savesp = srsp;
  579.                  make(fst(snd(e)),co,l1,fbranch(mkInt(l2),d));
  580.                  asLABEL(l1);
  581.                  srsp = savesp;
  582.                  asSETSTK(srsp);
  583.                  make(snd(snd(e)),co,f,frunon(d));
  584.                  asLABEL(l2);
  585.              }
  586.              else {
  587.                  Label l  = newLabel();
  588.                  Cell  d1 = flush(d);
  589.                  Int   savesp = srsp;
  590.                  make(fst(snd(e)),co,l,d1);
  591.                  asLABEL(l);
  592.                  srsp = savesp;
  593.                  asSETSTK(srsp);
  594.                  make(snd(snd(e)),co,f,d1);
  595.              }
  596.                          break;
  597.  
  598.     case COND      : makeCond(fst3(snd(e)),
  599.                   snd3(snd(e)),
  600.                   thd3(snd(e)),co,f,d);
  601.                  break;
  602.  
  603.     case CASE      : makeCase(snd(e),co,f,d);
  604.              break;
  605.  
  606.     case GUARDED   : makeGded(snd(e),co,f,d);
  607.                  break;
  608.  
  609.     case AP        : if (andorOptimise) {
  610.                  Cell h = getHead(e);
  611.                  if (h==nameAnd && argCount==2) {
  612.                  /* x && y ==> if x then y else False       */
  613.                  makeCond(arg(fun(e)),arg(e),nameFalse,co,f,d);
  614.                  break;
  615.                  }
  616.                  else if (h==nameOr && argCount==2) {
  617.                  /* x || y ==> if x then True else y       */
  618.                  makeCond(arg(fun(e)),nameTrue,arg(e),co,f,d);
  619.                  break;
  620.                  }
  621.              }
  622.                          buildAp(e,co,f,TRUE);
  623.                          doCont(d);
  624.                          break;
  625.  
  626.     case NAME      : dependsOn(e);
  627.     case UNIT      :
  628.     case TUPLE     : asCELL(e);
  629.                  doCont(d);
  630.                  break;
  631.  
  632.     /* for dict cells, ensure that CELL referred to in the code is the */
  633.     /* dictionary cell at the head of the dictionary; not just a copy  */
  634.     /* In the interpreter, this was needed for the benefit of garbage  */
  635.     /* collection (and to avoid having multiple copies of a single       */
  636.     /* DICTCELL).  In the compiler, we need it to justify the use of   */
  637.     /* cellIsMember() in dependsOn() below.                   */
  638.  
  639.     case DICTCELL  : asCELL(dict(dictOf(e)));
  640.              dependsOn(dict(dictOf(e)));
  641.                  doCont(d);
  642.                  break;
  643.  
  644.     case INTCELL   : asINTEGER(intOf(e));
  645.                  doCont(d);
  646.                  break;
  647.  
  648.         case FLOATCELL : asFLOAT(floatOf(e));
  649.                  doCont(d);
  650.              break;
  651.  
  652.     case STRCELL   : asSTRING(textOf(e));
  653.                  doCont(d);
  654.                  break;
  655.  
  656.     case CHARCELL  : asCHAR(charOf(e));
  657.                  doCont(d);
  658.                  break;
  659.  
  660.     case OFFSET    : asLOAD(offsPosn[offsetOf(e)]);
  661.                  doCont(d);
  662.                  break;
  663.  
  664.     default        : internal("make");
  665.     }
  666. }
  667.  
  668. static Void local makeCond(i,t,e,co,f,d)/* Build code for conditional       */
  669. Cell  i,t,e;
  670. Int   co;
  671. Label f;
  672. Pair  d; {
  673.     if (andorOptimise && i==nameOtherwise)
  674.     make(t,co,f,d);
  675.     else {
  676.     Label l1 = newLabel();
  677.     Int   savesp;
  678.  
  679.     make(i,co,f,noAction);
  680.     asEVAL();
  681.     savesp = srsp;
  682.     asTEST(nameTrue,l1);
  683.     if (isRunon(d)) {
  684.         Label l2 = newLabel();
  685.  
  686.         make(t,co,f,fbranch(mkInt(l2),d));
  687.             asLABEL(l1);
  688.         srsp = savesp;
  689.         make(e,co,f,frunon(d));
  690.         asLABEL(l2);
  691.     }
  692.     else {
  693.         Cell d1 = flush(d);
  694.         make(t,co,f,d1);
  695.         asLABEL(l1);
  696.         srsp = savesp;
  697.         make(e,co,f,d1);
  698.     }
  699.     }
  700. }
  701.  
  702. static Void local makeCase(c,co,f,d)    /* construct code to implement case*/
  703. Cell  c;                /* makes the assumption that FLUSH */
  704. Int   co;                /* will never be required       */
  705. Label f;
  706. Pair  d; {
  707.     List  cs = snd(c);
  708.     Cell  d1 = d;
  709.     Label l0;
  710.  
  711.     make(fst(c),co,shouldntFail,noAction);
  712.     asEVAL();
  713.  
  714.     if (isRunon(d)) {
  715.     l0 = newLabel();
  716.     d1 = pair(mkInt(0),ap(BRANCH,mkInt(l0)));
  717.     }
  718.  
  719.     for(; nonNull(tl(cs)); cs=tl(cs)) {
  720.     Label l      = newLabel();
  721.         Int   savesp = srsp;
  722.     testCase(hd(cs),co,f,l,d1);
  723.     asLABEL(l);
  724.         srsp = savesp;
  725.     }
  726.  
  727.     if (isRunon(d)) {
  728.         Int savesp = srsp;
  729.     testCase(hd(cs),co,f,f,noAction);
  730.     asLABEL(l0);
  731.         srsp = savesp;
  732.     }
  733.     else
  734.     testCase(hd(cs),co,f,f,d1);
  735. }
  736.  
  737. static Void local testCase(c,co,f,cf,d)    /* Produce code for guard       */
  738. Pair  c;
  739. Int   co;                /* labels determine where to go if:*/
  740. Label f;                /* match succeeds, but rest fails  */
  741. Label cf;                /* this match fails           */
  742. Pair  d; {
  743.     Int n = discrArity(fst(c));
  744.     Int i;
  745.     switch (whatIs(fst(c))) {
  746.     case INTCELL : asINTEQ(intOf(fst(c)),cf);
  747.                break;
  748.     case ADDPAT  : asINTGE(intValOf(fst(c)),cf);
  749.                break;
  750.     case MULPAT  : asINTDV(intValOf(fst(c)),cf);
  751.                break;
  752.     default      : asTEST(fst(c),cf);
  753.                break;
  754.     }
  755.     for (i=1; i<=n; i++)
  756.     offsPosn[co+i] = ++srsp;
  757.     make(snd(c),co+n,f,d);
  758. }
  759.  
  760. static Void local makeGded(gs,co,f,d)    /* construct code to implement gded*/
  761. List  gs;                /* equations.  Makes the assumption*/
  762. Int   co;                /* that FLUSH will never be reqd.  */
  763. Label f;
  764. Pair  d; {
  765.     Cell  d1 = d;
  766.     Label l0;
  767.  
  768.     if (isRunon(d)) {
  769.     l0 = newLabel();
  770.     d1 = pair(mkInt(0),ap(BRANCH,mkInt(l0)));
  771.     }
  772.  
  773.     for(; nonNull(tl(gs)); gs=tl(gs)) {
  774.     Label l = newLabel();
  775.         Int   savesp = srsp;
  776.     if (testGuard(hd(gs),co,f,l,d1))
  777.         return;
  778.     asLABEL(l);
  779.         srsp = savesp;
  780.     }
  781.  
  782.     if (isRunon(d)) {
  783.         Int   savesp = srsp;
  784.     testGuard(hd(gs),co,f,f,noAction);
  785.     asLABEL(l0);
  786.         srsp = savesp;
  787.     }
  788.     else
  789.     testGuard(hd(gs),co,f,f,d1);
  790. }
  791.  
  792. static Bool local testGuard(g,co,f,cf,d) /* Produce code for guard       */
  793. Pair  g;                /* return TRUE if otherwise found  */
  794. Int   co;
  795. Label f;
  796. Label cf;
  797. Pair  d; {
  798.     if (andorOptimise && fst(g)==nameOtherwise) {
  799.     make(snd(g),co,f,d);
  800.     return TRUE;
  801.     }
  802.     else {
  803.     make(fst(g),co,shouldntFail,noAction);
  804.     asEVAL();
  805.     asTEST(nameTrue,cf);
  806.     make(snd(g),co,f,d);
  807.     return FALSE;
  808.     }
  809. }
  810.  
  811. /* --------------------------------------------------------------------------
  812.  * Compile expression to code which will build expression without any
  813.  * evaluation.
  814.  * ------------------------------------------------------------------------*/
  815.  
  816. static List scDeps;            /* records immediate dependent       */
  817.                     /* names and dictionaries       */
  818.  
  819. static Void local dependsOn(n)        /* update scDeps with new name       */
  820. Cell n; {
  821.  
  822.     if (isName(n))            /* ignore:               */
  823.     if (name(n).defn == CFUN ||    /* - constructor functions       */
  824.         name(n).defn == MFUN)    /* - member fns (shouldn't occur)  */
  825.         return;
  826.  
  827.     if (!cellIsMember(n,scDeps))    /* add to list of dependents       */
  828.     scDeps = cons(n,scDeps);
  829. }
  830.  
  831. static Void local build(e,co)        /* Generate code which will build  */
  832. Cell e;                 /* instance of given expression but*/
  833. Int  co; {                /* perform no evaluation        */
  834.     Int n;
  835.  
  836.     switch (whatIs(e)) {
  837.  
  838.     case LETREC    : n = buildLoc(fst(snd(e)),co);
  839.                  build(snd(snd(e)),co+n);
  840.                  asSLIDE(n);
  841.                  break;
  842.  
  843.     case FATBAR    : build(snd(snd(e)),co);
  844.                  build(fst(snd(e)),co);
  845.                  asCELL(nameFatbar);
  846.                  asMKAP(2);
  847.                  break;
  848.  
  849.     case COND      : build(thd3(snd(e)),co);
  850.                  build(snd3(snd(e)),co);
  851.                  build(fst3(snd(e)),co);
  852.                  asCELL(nameIf);
  853.                    asMKAP(3);
  854.                    break;
  855.  
  856.     case GUARDED   : buildGuards(snd(e),co);
  857.                  break;
  858.  
  859.     case AP        : buildAp(e,co,shouldntFail,FALSE);
  860.                  break;
  861.  
  862.     case NAME      : dependsOn(e);
  863.     case UNIT      :
  864.     case TUPLE     : asCELL(e);
  865.              break;
  866.  
  867.     case DICTCELL  : asCELL(dict(dictOf(e)));    /* see comments for*/
  868.              dependsOn(dict(dictOf(e)));    /* DICTCELL in make*/
  869.              break;                /* function above  */
  870.  
  871.     case INTCELL   : asINTEGER(intOf(e));
  872.              break;
  873.  
  874.         case FLOATCELL : asFLOAT(floatOf(e));
  875.              break;
  876.  
  877.     case STRCELL   : asSTRING(textOf(e));
  878.              break;
  879.  
  880.     case CHARCELL  : asCHAR(charOf(e));
  881.              break;
  882.  
  883.     case OFFSET    : asLOAD(offsPosn[offsetOf(e)]);
  884.                  break;
  885.  
  886.     default        : internal("build");
  887.     }
  888. }
  889.  
  890. static Void local buildGuards(gs,co)    /* Generate code to compile list   */
  891. List gs;                /* of guards to a conditional expr */
  892. Int  co; {                /* without evaluation           */
  893.     if (isNull(gs)) {
  894.     asCELL(nameFail);
  895.     }
  896.     else {
  897.     buildGuards(tl(gs),co);
  898.     build(snd(hd(gs)),co);
  899.     build(fst(hd(gs)),co);
  900.     asCELL(nameIf);
  901.     asMKAP(3);
  902.     }
  903. }
  904.  
  905. static Int local buildLoc(vs,co)    /* Generate code to build local var*/
  906. List vs;                /* bindings on stack,  with no eval*/
  907. Int  co; {
  908.     Int n = length(vs);
  909.     Int i;
  910.  
  911.     for (i=1; i<=n; i++)
  912.     offsPosn[co+i] = srsp+i;
  913.     asALLOC(n);
  914.     for (i=1; i<=n; i++) {
  915.     build(hd(vs),co+n);
  916.     asUPDATE(offsPosn[co+i]);
  917.     vs = tl(vs);
  918.     }
  919.     return n;
  920. }
  921.  
  922. /* --------------------------------------------------------------------------
  923.  * We frequently encounter functions which call themselves recursively with
  924.  * a number of initial arguments preserved:
  925.  * e.g.  (map f) []    = []
  926.  *     (map f) (x:xs) = f x : (map f) xs
  927.  * Lambda lifting, in particular, is likely to introduce such functions.
  928.  * Rather than reconstructing a new instance of the recursive function and
  929.  * it's arguments, we can extract the relevant portion of the root of the
  930.  * current redex.
  931.  *
  932.  * The following functions implement this optimisation.
  933.  * ------------------------------------------------------------------------*/
  934.  
  935. static Int  nonRoots;               /* #args which can't get from root  */
  936. static Int  rootPortion;           /* portion of root used ...       */
  937. static Name definingName;           /* name of func being defined,if any*/
  938. static Int  definingArity;           /* arity of definingName        */
  939.  
  940. static Void local analyseAp(e)           /* Determine if any portion of an   */
  941. Cell e; {                   /* application can be built using a */
  942.     if (isAp(e)) {               /* portion of the root           */
  943.     analyseAp(fun(e));
  944.     if (nonRoots==0 && rootPortion>1
  945.             && isOffset(arg(e))
  946.             && offsetOf(arg(e))==rootPortion-1)
  947.         rootPortion--;
  948.     else
  949.         nonRoots++;
  950.     }
  951.     else if (e==definingName)
  952.     rootPortion = definingArity+1;
  953.     else
  954.     rootPortion = 0;
  955. }
  956.  
  957. static Void local buildAp(e,co,f,str)    /* Build application, making use of*/
  958. Cell  e;                /* root optimisation if poss.       */
  959. Int   co;
  960. Label f;
  961. Bool  str; {
  962.     Int nr, rp, i;
  963.  
  964.     nonRoots = 0;
  965.     analyseAp(e);
  966.     nr = nonRoots;
  967.     rp = rootPortion;
  968.  
  969.     for (i=0; i<nr; ++i) {
  970.     build(arg(e),co);
  971.     e = fun(e);
  972.     }
  973.  
  974.     if (isSelect(e)) {
  975.         if (selectOf(e)>0) {
  976.         asDICT(selectOf(e));
  977.     }
  978.     }
  979.     else {
  980.     if (isName(e) && name(e).defn==MFUN) {
  981.         asDICT(name(e).number);
  982.         nr--;    /* AP node for member function need never be built */
  983.     }
  984.     else {
  985.         if (0<rp && rp<=definingArity) {
  986.         asROOT(rp-1);
  987.         }
  988.         else
  989.         if (str)
  990.             make(e,co,f,noAction);
  991.         else
  992.             build(e,co);
  993.     }
  994.  
  995.     if (nr>0) {
  996.         asMKAP(nr);
  997.     }
  998.     }
  999. }
  1000.  
  1001. /* --------------------------------------------------------------------------
  1002.  * Code generator entry point:
  1003.  * ------------------------------------------------------------------------*/
  1004.  
  1005. Addr codeGen(n,arity,e)            /* Generate code for expression e,  */
  1006. Name n;                    /* treating return value of CAFs    */
  1007. Int  arity;                   /* differently to functs with args  */
  1008. Cell e; {
  1009.     extern Void pScDef Args((Text,Int,Cell));
  1010.     extern Bool dumpScs;
  1011.  
  1012.     definingName  = n;
  1013.     definingArity = arity;
  1014.     scDeps      = NIL;
  1015. #ifdef DEBUG_CODE
  1016. printf("------------------\n");
  1017. if (nonNull(n)) printf("name=%s\n",textToStr(name(n).text));
  1018. printf("Arity   = %d\n",arity);
  1019. printf("codeGen = "); printExp(stdout,e); putchar('\n');
  1020. #endif
  1021.     if (dumpScs)
  1022.     pScDef(name(n).text,arity,e);
  1023.     else {
  1024.     Int i;
  1025.     asSTART();
  1026.     for (i=1; i<=arity; i++)
  1027.         offsPosn[i] = ++srsp;
  1028.     make(e,arity,FAIL,functionReturn);
  1029.     asEND();
  1030.     }
  1031.     name(n).defn = scDeps;
  1032.     scDeps     = NIL;
  1033. #ifdef DEBUG_CODE
  1034. dissassemble(startInstr);
  1035. printf("------------------\n");
  1036. #endif
  1037.     return startInstr;
  1038. }
  1039.  
  1040. /* --------------------------------------------------------------------------
  1041.  * C code generator: produces (portable, I hope) C output to implement a
  1042.  * specified main program.
  1043.  * ------------------------------------------------------------------------*/
  1044.  
  1045. Void outputCode(fp,mn)            /* print complete C program to       */
  1046. FILE *fp;                /* implement program mn :: Dialogue*/
  1047. Name mn; {
  1048.     List   scs = identifyDeps(mn);    /* determine which supercombinator */
  1049.     Target t   = length(scs);        /* definitions are needed in prog. */
  1050.     Target i   = 0;
  1051.  
  1052.     fprintf(fp,"#include %s\n\nint argcheck=ARGCHECK;\n\n",GOFC_INCLUDE);
  1053.     outputCDecls(fp,scs);
  1054.     outputCDicts(fp);
  1055.  
  1056.     setGoal("Compiling to C",t);
  1057.     for (; nonNull(scs); scs=tl(scs)) {
  1058.     outputCSc(fp,hd(scs));
  1059.     soFar(i++);
  1060.     }
  1061.     done();
  1062. }
  1063.  
  1064. static int *dictUse   = 0;        /* records dictionaries required   */
  1065. static int num_dicts  = 0;        /* dictionaries required       */
  1066. static int num_sdicts = 0;        /* all dictionaries known to system*/
  1067.  
  1068. static List local identifyDeps(mn)    /* list all dependents scs for mn  */
  1069. Name mn; {
  1070.     List needed     = singleton(mn);    /* Start with dependents of mn       */
  1071.     List scs        = NIL;
  1072.     List ns        = NIL;
  1073.     Int  i;
  1074.  
  1075.     num_sdicts = newDict(0);
  1076.     dictUse    = (int *)calloc(num_sdicts,sizeof(int));
  1077.     if (!dictUse) {
  1078.     ERROR(0) "Cannot allocate dictionary use table"
  1079.     EEND;
  1080.     }
  1081.     for (i=0; i<num_sdicts; i++)
  1082.     dictUse[i] = (-1);        /* (-1) => not required           */
  1083.  
  1084.     while (nonNull(needed)) {        /* Cycle through to find all       */
  1085.     Cell t = needed;        /* dependents ...           */
  1086.     Cell n = hd(t);
  1087.     needed = tl(needed);
  1088.     if (isName(n)) {        /* Dependent is a name           */
  1089.         if (!name(n).primDef && name(n).defn!=NEEDED) {
  1090.         tl(t)        = scs;
  1091.         scs         = t;
  1092.         map1Proc(checkPrimDep,n,name(n).defn);
  1093.         needed       = appendOnto(name(n).defn,needed);
  1094.         name(n).defn = NEEDED;
  1095.         }
  1096.     }
  1097.     else {                /* Dependent is a dictionary       */
  1098.         if (dictUse[dictOf(n)]<0)
  1099.         for (i=dictOf(n); (dictUse[i++]=0), i<num_sdicts; )
  1100.             if (isAp(dict(i))) {    /* member function       */
  1101.             if (isName(fun(dict(i))) &&
  1102.                 whatIs(arg(dict(i)))==DICTCELL)
  1103.                 needed = cons(fun(dict(i)),needed);
  1104.             else
  1105.                 if (fun(dict(i))!=nameUndefMem)
  1106.                 internal("bad dict ap");
  1107.             }
  1108.             else            /* DICTCELL           */
  1109.             if (dictOf(dict(i))==i)    /* past end of dictionary  */
  1110.                 break;
  1111.             else
  1112.                 needed = cons(dict(i),needed);
  1113.         }
  1114.     }
  1115.  
  1116.     ns = scs;                /* number supercombinators       */
  1117.     for (i=0; nonNull(ns); ns=tl(ns))
  1118.     name(hd(ns)).number = i++;
  1119.  
  1120.     num_dicts = 0;            /* number dictionaries           */
  1121.     for (i=0; i<num_sdicts; i++)
  1122.     if (dictUse[i]!=(-1))
  1123.         dictUse[i] = num_dicts++;
  1124.  
  1125.     return scs;
  1126. }
  1127.  
  1128. static Void local checkPrimDep(n,m)    /* Check that primitive dependent  */
  1129. Name n;                    /* m of n is supported by gofc       */
  1130. Cell m; {
  1131.     if (isName(m) && name(m).primDef == PRIM_NOGOFC) {
  1132.     ERROR(0)
  1133.      "Primitive function %s is not supported by the gofc runtime system\n",
  1134.          primitives[name(m).number].ref
  1135.     ETHEN
  1136.     ERRTEXT "(used in the definition of %s)", textToStr(name(n).text)
  1137.     EEND;
  1138.     }
  1139. }
  1140.  
  1141. static Void local outputCDecls(fp,scs)    /* print forward declarations for  */
  1142. FILE *fp;                /* supercombinators required       */
  1143. List scs; {
  1144.     int num_scs = length(scs);
  1145.  
  1146.     startTable("extern Super ", ";", ";\n");
  1147. #define declareSc(n) tableItem(fp,scNameOf(n))
  1148.     mapProc(declareSc,scs);
  1149. #undef  declareSc
  1150.     finishTable(fp);
  1151.  
  1152.     fprintf(fp,"\nint   num_scs = %d;\nCell  sc[%d];",num_scs,num_scs);
  1153.     fprintf(fp,"\nSuper *scNames[] = {\n");
  1154.     startTable("  ", ", ", "\n");
  1155. #define inArraySc(n) tableItem(fp,scNameOf(n))
  1156.     mapProc(inArraySc,scs);
  1157. #undef  inArraySc
  1158.     finishTable(fp);
  1159.     fprintf(fp,"};\n\n");
  1160. }
  1161.  
  1162. static Void local outputCDicts(fp)    /* print definitions for dictionary*/
  1163. FILE *fp; {                /* storage               */
  1164.     char buffer[100];
  1165.  
  1166.     fprintf(fp,"int  num_dicts = %d;\n",num_dicts);
  1167.  
  1168.     if (num_dicts==0) {
  1169.     fprintf(fp,"Cell dict[]     = {0}; /* dummy entries */\n");
  1170.     fprintf(fp,"int  dictImps[] = {0};\n\n");
  1171.     }
  1172.     else {
  1173.     Int dn;
  1174.     fprintf(fp,"Cell dict[] = {\n");
  1175.     startTable("  ", ",", "\n");
  1176.         for (dn=0; dn<num_sdicts; dn++) {
  1177.         if (dictUse[dn]>=0) {
  1178.                 if (isAp(dict(dn))) {
  1179.             if (fst(dict(dn))==nameUndefMem)
  1180.             tableItem(fp,"0");
  1181.             else {
  1182.             sprintf(buffer,"mkDict(%d)",
  1183.                     dictUse[dictOf(arg(dict(dn)))]);
  1184.             tableItem(fp,buffer);
  1185.             }
  1186.         }
  1187.         else {
  1188.             sprintf(buffer,"mkDict(%d)",dictUse[dictOf(dict(dn))]);
  1189.             tableItem(fp,buffer);
  1190.         }
  1191.         }
  1192.     }
  1193.     finishTable(fp);
  1194.     fprintf(fp,"};\nint dictImps[] = {\n");
  1195.     startTable("  ", ",", "\n");
  1196.     for (dn=0; dn<num_sdicts; dn++)
  1197.         if (dictUse[dn]>=0)
  1198.         if (isAp(dict(dn))) {
  1199.             sprintf(buffer,"%d",name(fun(dict(dn))).number);
  1200.             tableItem(fp,buffer);
  1201.         }
  1202.         else
  1203.             tableItem(fp,"-1");
  1204.     finishTable(fp);
  1205.     fprintf(fp,"};\n\n");
  1206.     }
  1207. }
  1208.  
  1209. /* --------------------------------------------------------------------------
  1210.  * Supercombinator C code generator:
  1211.  *
  1212.  * The C code generator re-interprets the sequence of machine instructions
  1213.  * produced by the G-code code generator given above, using a simulated
  1214.  * stack, in much the same way as described in Simon Peyton Jones's book,
  1215.  * section 19.3.2.  To be quite honest, I don't think I really understood
  1216.  * that section of the book until I started to work on this piece of code!
  1217.  * ------------------------------------------------------------------------*/
  1218.  
  1219. static  int    rsp;            /* Runtime stack pointer       */
  1220. static  int    rspMax;            /* Maximum value of stack pointer  */
  1221. static  int    pushes;            /* number of actual pushes in code */
  1222.  
  1223. #define rPush  if (++rsp>=rspMax) rspMax=rsp
  1224.  
  1225. static Void local rspRecalc() {        /* Recalculate rsp after change to */
  1226.     Int i = sp;                /* simulated stack pointer sp       */
  1227.     for (rsp=(-1); i>=0; --i)
  1228.     if (isNull(stack(i)) || stack(i)==mkOffset(i))
  1229.         rsp++;
  1230.     if (rsp>rspMax)            /* should never happen!           */
  1231.     rspMax = rsp;
  1232. }
  1233.  
  1234. /* --------------------------------------------------------------------------
  1235.  * Output code for a single supercombinator:
  1236.  * ------------------------------------------------------------------------*/
  1237.  
  1238. #define ppushed(n)  (isNull(pushed(n)) ? POP : pushed(n))
  1239. #define tpushed(n)  (isNull(pushed(n)) ? TOP : pushed(n))
  1240.  
  1241. static Void local outputCSc(fp,n)    /* Print C code for supercombinator*/
  1242. FILE *fp;
  1243. Name n; {
  1244.     List   instrs = heapUse(cCode(name(n).arity,name(n).code));
  1245.     String s      = 0;
  1246.  
  1247.     if (name(n).arity<10)        /* Print header               */
  1248.     fprintf(fp,"comb%d(%s)",name(n).arity,scNameOf(n));
  1249.     else
  1250.     fprintf(fp,"comb(%s,%d)",scNameOf(n),name(n).arity);
  1251.  
  1252.     fprintf(fp,"  /* ");        /* include supercombinator name       */
  1253.     for (s=textToStr(name(n).text); *s; s++) {
  1254.     fputc(*s,fp);
  1255.     if (*s=='*' && *(s+1)=='/')    /* avoid premature comment ending  */
  1256.         fputc(' ',fp);
  1257.     }
  1258.     fprintf(fp," */\n");
  1259.  
  1260.     if (pushes>0 && rspMax>name(n).arity)
  1261.     fprintf(fp,"  needStack(%d);\n",rspMax-name(n).arity);
  1262.  
  1263.     for (; nonNull(instrs); instrs=tl(instrs)) {
  1264.     Cell instr = hd(instrs);
  1265.  
  1266.     if (whatIs(instr)==C_LABEL) {    /* Handle printing of labels       */
  1267.         instrs = tl(instrs);    /* move on to next instruction       */
  1268.         if (isNull(instrs))
  1269.         internal("no instr for label");
  1270.         outputLabel(fp,intOf(snd(instr)));
  1271.         fputc(':',fp);
  1272.         instr   = hd(instrs);
  1273.     }
  1274.     else
  1275.         fprintf(fp,"  ");
  1276.  
  1277.         outputCinst(fp,instr);
  1278.     fprintf(fp,";\n");
  1279.     }
  1280.  
  1281.     fprintf(fp,"End\n\n");
  1282. }
  1283.  
  1284. static List local cCode(arity,pc)    /* simulate execution of G-code to */
  1285. Int  arity;                /* calculate corresponding C code  */
  1286. Addr pc; {
  1287.     Cell instrs = NIL;            /* holds sequence of C instrs       */
  1288.     Int  i;
  1289.     Cell t;
  1290.  
  1291.     clearStack();            /* initialise simulated stack       */
  1292.     for (i=0; i<=arity; i++) {
  1293.     push(mkOffset(i));
  1294.     }
  1295.     rsp    = arity;            /* and set Real stack ptr to match */
  1296.     rspMax = rsp;
  1297.     pushes = 0;
  1298.  
  1299. #define outC0(c)    instrs = cons(c,instrs)
  1300. #define outC1(c,o)    instrs = cons(ap(c,o),instrs)
  1301. #define outC2(c,o,p)    instrs = cons(ap(c,pair(o,p)),instrs)
  1302. #define outC3(c,o,p,q)    instrs = cons(ap(c,triple(o,p,q)),instrs)
  1303.  
  1304.     for (;;)
  1305.     switch (instrAt(pc)) {
  1306.  
  1307.         case iEND     : return rev(instrs);         /* end of code       */
  1308.  
  1309.         case iLABEL     : outC1(C_LABEL,         /* program label  */
  1310.                  mkInt(labAt(pc+1)));
  1311.                pc+=2;
  1312.                continue;
  1313.  
  1314.         case iLOAD     : push(mkOffset(intAt(pc+1)));     /* load from stack*/
  1315.                pc+=2;
  1316.                continue;
  1317.  
  1318.         case iCELL     : push(cellAt(pc+1));         /* load const Cell*/
  1319.                pc+=2;
  1320.                continue;
  1321.  
  1322.         case iCHAR     : push(mkChar(intAt(pc+1)));     /* load char const*/
  1323.                pc+=2;
  1324.                continue;
  1325.  
  1326.         /* the treatment of integers used here relies on the assumption*/
  1327.         /* that any number represented by a small int in the compiler  */
  1328.         /* can also be represented by a small int in the runtime system*/
  1329.  
  1330.         case iINT     : t = mkInt(intAt(pc+1));     /* load int const */
  1331.                if (!isSmall(t)) {         /* assume BIG int */
  1332.                    push(NIL);
  1333.                    rPush;
  1334.                    pushes++;
  1335.                    outC0(t);
  1336.                }
  1337.                else {                 /* assume SMALL   */
  1338.                    push(t);
  1339.                }
  1340.                pc+=2;
  1341.                continue;
  1342.  
  1343.         case iFLOAT  : push(NIL);             /* load float cnst*/
  1344.                rPush;
  1345.                pushes++;
  1346. #if BREAK_FLOATS
  1347.                outC0(mkFloat(floatFromParts
  1348.                         (cellAt(pc+1),cellAt(pc+2))));
  1349.                pc+=3;
  1350. #else
  1351.                outC0(mkFloat(floatAt(pc+1)));
  1352.                pc+=2;
  1353. #endif
  1354.                continue;
  1355.  
  1356.         case iFLUSH  : if (nonNull(top())) {     /* force top of   */
  1357.                    outC1(C_FLUSH,top());     /* simulated stack*/
  1358.                    top() = NIL;         /* onto real stack*/
  1359.                    rPush;
  1360.                    pushes++;
  1361.                }
  1362.                pc++;
  1363.                continue;
  1364.  
  1365.         case iSTRING : push(NIL);             /* load str const */
  1366.                rPush;
  1367.                pushes++;
  1368.                outC0(mkStr(textAt(pc+1)));
  1369.                pc+=2;
  1370.                continue;
  1371.  
  1372.         case iMKAP   : for (i=intAt(pc+1); i>0; --i){/* make AP nodes  */
  1373.                    if (isNull(pushed(0)))
  1374.                    if (isNull(pushed(1))) {
  1375.                        outC0(C_MKAP);
  1376.                        rsp--;
  1377.                    }
  1378.                    else
  1379.                        outC1(C_TOPARG,pushed(1));
  1380.                    else
  1381.                    if (isNull(pushed(1)))
  1382.                        outC1(C_TOPFUN,pushed(0));
  1383.                    else {
  1384.                        rPush;
  1385.                        pushes++;
  1386.                        outC2(C_PUSHPAIR,pushed(0),pushed(1));
  1387.                    }
  1388.                    drop();
  1389.                    top() = NIL;
  1390.                }
  1391.                pc+=2;
  1392.                continue;
  1393.  
  1394.         case iUPDATE : t = stack(intAt(pc+1));     /* update cell ...*/
  1395.                if (!isOffset(t))
  1396.                    internal("iUPDATE");
  1397.  
  1398.                if (isNull(pushed(0)))     /* update cell ...*/
  1399.                    rsp--;
  1400.  
  1401.                outC2(C_UPDATE,t,ppushed(0));
  1402.  
  1403.                drop();
  1404.                pc+=2;
  1405.                continue;
  1406.  
  1407.         case iUPDAP  : t = stack(intAt(pc+1));     /* update AP node */
  1408.                if (!isOffset(t))
  1409.                    internal("iUPDAP");
  1410.  
  1411.                if (isNull(pushed(0)))
  1412.                    if (isNull(pushed(1))) {
  1413.                    outC1(C_UPDAP2,t);
  1414.                    rsp-=2;
  1415.                    }
  1416.                    else {
  1417.                    outC3(C_UPDAP,t,POP,pushed(1));
  1418.                    rsp--;
  1419.                    }
  1420.                else
  1421.                    if (isNull(pushed(1))) {
  1422.                    outC3(C_UPDAP,t,pushed(0),POP);
  1423.                                    rsp--;
  1424.                    }
  1425.                    else
  1426.                    outC3(C_UPDAP,t,pushed(0),pushed(1));
  1427.  
  1428.                drop();
  1429.                drop();
  1430.                pc+=2;
  1431.                continue;
  1432.  
  1433.         case iALLOC  : for (i=intAt(pc+1); i>0; --i){/* alloc loc vars */
  1434.                    rPush;
  1435.                    pushes++;
  1436.                    outC0(C_ALLOC);
  1437.                    push(mkOffset(rsp));
  1438.                }
  1439.                pc+=2;
  1440.                continue;
  1441.  
  1442.         case iSLIDE  : i = intAt(pc+1);         /* remove loc vars*/
  1443.                if (nonNull(top()))
  1444.                    i--;
  1445.                outC2(C_SLIDE,mkInt(i),tpushed(0));
  1446.                rsp -= i;
  1447.                sp  -= intAt(pc+1);
  1448.                            pc  += 2;
  1449.                continue;
  1450.  
  1451.         case iDICT     : if (isNull(top()))         /* dict lookup    */
  1452.                    internal("iDICT");
  1453.  
  1454.                if (whatIs(top())==DICTCELL)
  1455.                    top() = mkDict(dictOf(top())+intAt(pc+1));
  1456.                else
  1457.                    top() = ap(mkSelect(intAt(pc+1)),top());
  1458.  
  1459.                            pc+=2;                        /* dict lookup    */
  1460.                            continue;
  1461.  
  1462.         case iROOT     : t = mkOffset(0);         /* partial root   */
  1463.                for (i=intAt(pc+1); i>0; --i)
  1464.                    t = ap(ROOTFST,t);
  1465.                push(t);
  1466.                pc+=2;
  1467.                continue;
  1468.  
  1469.         case iRETURN : outC0(C_RETURN);         /* terminate       */
  1470.                pc++;
  1471.                continue;
  1472.  
  1473.         case iGOTO     : outC1(C_GOTO,         /* goto label       */
  1474.                  mkInt(labAt(pc+1)));
  1475.                pc+=2;
  1476.                continue;
  1477.  
  1478.         case iSETSTK : sp = intAt(pc+1);         /* set stack ptr  */
  1479.                rspRecalc();
  1480.                outC1(C_SETSTK,mkInt(rsp));
  1481.                pc += 2;
  1482.                continue;
  1483.  
  1484.         case iINTEQ     :                  /* test integer ==*/
  1485.                outC2(C_INTEQ,mkInt(intAt(pc+1)),
  1486.                      mkInt(labAt(pc+2)));
  1487.                pc+=3;
  1488.                continue;
  1489.  
  1490.         case iINTGE     : push(NIL);             /* test integer >=*/
  1491.                rPush;
  1492.                pushes++;
  1493.                outC3(C_INTGE,mkInt(0),
  1494.                      mkInt(intAt(pc+1)),
  1495.                      mkInt(labAt(pc+2)));
  1496.                            pc+=3;
  1497.                continue;
  1498.  
  1499.         case iINTDV     : push(NIL);             /* test for mult  */
  1500.                rPush;
  1501.                pushes++;
  1502.                outC3(C_INTDV,mkInt(0),
  1503.                      mkInt(intAt(pc+1)),
  1504.                      mkInt(labAt(pc+2)));
  1505.                pc+=3;
  1506.                continue;
  1507.  
  1508.         case iTEST     : t = cellAt(pc+1);         /* test for cell  */
  1509.                switch (whatIs(t)) {
  1510.                    case UNIT     : i = 0;
  1511.                            break;
  1512.  
  1513.                    case TUPLE    : i = tupleOf(t);
  1514.                            break;
  1515.  
  1516.                    case NAME     : i = name(t).arity;
  1517.                            outC2(C_TEST,t,
  1518.                          mkInt(labAt(pc+2)));
  1519.                            break;
  1520.  
  1521.                    case CHARCELL : i = 0;
  1522.                            outC2(C_TEST,t,
  1523.                          mkInt(labAt(pc+2)));
  1524.                            break;
  1525.  
  1526.                    default         : internal("iTEST");
  1527.                }
  1528.  
  1529.                while (i-- > 0) {
  1530.                    rPush;
  1531.                    push(mkOffset(rsp));
  1532.                }
  1533.                pc+=3;
  1534.                continue;
  1535.  
  1536.         case iEVAL     : if (isNull(pushed(0)))     /* evaluate top() */
  1537.                    rsp--;
  1538.                outC1(C_EVAL,ppushed(0));
  1539.                drop();
  1540.                pc++;
  1541.                continue;
  1542.  
  1543.         default     : internal("illegal instruction");
  1544.                break;
  1545.     }
  1546.  
  1547. #undef outC0
  1548. #undef outC1
  1549. #undef outC2
  1550. #undef outC3
  1551. }
  1552.  
  1553. /* --------------------------------------------------------------------------
  1554.  * Insert heap use annotations:
  1555.  * ------------------------------------------------------------------------*/
  1556.  
  1557. static Int heapNeeded;            /* used to return # heap cells reqd*/
  1558.  
  1559. static List local heapUse(instrs)    /* add annotations for heap use       */
  1560. List instrs; {
  1561.     instrs = heapAnalyse(instrs);
  1562.     if (heapNeeded>0)
  1563.     instrs = cons(ap(C_HEAP,mkInt(heapNeeded)),instrs);
  1564.     return instrs;
  1565. }
  1566.  
  1567. static List local heapAnalyse(instrs)    /* analyse heap use in instruction */
  1568. List instrs; {
  1569.     Int  heap = 0;            /* number of heap cells needed     */
  1570.     List next;
  1571.  
  1572.     for (next=instrs; nonNull(next); next=tl(next))
  1573.     switch (whatIs(hd(next))) {
  1574.         case FLOATCELL  : heap+=4;        /*conservative overestimate*/
  1575.                   continue;        /*without BREAK_FLOATS this*/
  1576.                         /*will always use just one */
  1577.                         /*cell, with it may use 1-4*/
  1578.  
  1579.         case INTCELL    :            /*conservative overestimate*/
  1580.                         /*again. Small ints may not*/
  1581.                         /*require any heap storage */
  1582.         case STRCELL    :
  1583.         case C_MKAP        :
  1584.         case C_TOPFUN   :
  1585.         case C_TOPARG   :
  1586.         case C_PUSHPAIR :
  1587.         case C_ALLOC    : heap++;
  1588.         case C_UPDAP    :
  1589.         case C_UPDAP2   :
  1590.         case C_UPDATE   :
  1591.         case C_SLIDE    :
  1592.         case C_SETSTK   :
  1593.         case C_FLUSH    : continue;
  1594.  
  1595.         case C_INTGE    :
  1596.         case C_INTDV    : tl(next)          = heapAnalyse(tl(next));
  1597.                   fst3(snd(hd(next))) = mkInt(1+heapNeeded);
  1598.                   heapNeeded      = heap;
  1599.                   return instrs;
  1600.  
  1601.         case C_TEST        :
  1602.         case C_INTEQ    :
  1603.         case C_LABEL    :
  1604.         case C_GOTO     :
  1605.         case C_RETURN   :
  1606.         case C_EVAL        : tl(next)   = heapUse(tl(next));
  1607.                   heapNeeded = heap;
  1608.                               return instrs;
  1609.  
  1610.         default        : internal("heapAnalyse");
  1611.     }
  1612.  
  1613.     heapNeeded = heap;
  1614.     return instrs;
  1615. }
  1616.  
  1617. /* --------------------------------------------------------------------------
  1618.  * Output individual C code instructions:
  1619.  * ------------------------------------------------------------------------*/
  1620.  
  1621. static Void local outputCinst(fp,instr)    /* Output single C instruction       */
  1622. FILE *fp;
  1623. Cell instr; {
  1624.     switch (whatIs(instr)) {
  1625.     case INTCELL    : fprintf(fp,"pushInt(%d)",intOf(instr));
  1626.               break;
  1627.  
  1628.     case FLOATCELL  : fprintf(fp,"pushFloat(%g)",floatOf(instr));
  1629.               break;
  1630.  
  1631.     case STRCELL    : fprintf(fp,"pushStr(");
  1632.               outputCStr(fp,textToStr(textOf(instr)));
  1633.               fputc(')',fp);
  1634.               break;
  1635.  
  1636.     case C_MKAP    : fprintf(fp,"mkap()");
  1637.               break;
  1638.  
  1639.     case C_TOPARG   : fprintf(fp,"toparg(");
  1640.               expr(fp,snd(instr));
  1641.               fputc(')',fp);
  1642.               break;
  1643.  
  1644.     case C_TOPFUN   : fprintf(fp,"topfun(");
  1645.               expr(fp,snd(instr));
  1646.               fputc(')',fp);
  1647.               break;
  1648.  
  1649.     case C_PUSHPAIR : fprintf(fp,"pushpair(");
  1650.               expr(fp,fst(snd(instr)));
  1651.               fputc(',',fp);
  1652.               expr(fp,snd(snd(instr)));
  1653.               fputc(')',fp);
  1654.               break;
  1655.  
  1656.     case C_UPDATE   : fprintf(fp,"update(%d,",offsetOf(fst(snd(instr))));
  1657.               expr(fp,snd(snd(instr)));
  1658.               fputc(')',fp);
  1659.               break;
  1660.  
  1661.     case C_UPDAP    : fprintf(fp,"updap(%d,",offsetOf(fst3(snd(instr))));
  1662.               expr(fp,snd3(snd(instr)));
  1663.               fputc(',',fp);
  1664.               expr(fp,thd3(snd(instr)));
  1665.               fputc(')',fp);
  1666.               break;
  1667.  
  1668.     case C_UPDAP2    : fprintf(fp,"updap2(%d)",offsetOf(snd(instr)));
  1669.               break;
  1670.  
  1671.     case C_ALLOC    : fprintf(fp,"alloc()");
  1672.               break;
  1673.  
  1674.     case C_SLIDE    : fprintf(fp,"slide(%d,",intOf(fst(snd(instr))));
  1675.               expr(fp,snd(snd(instr)));
  1676.               fputc(')',fp);
  1677.               break;
  1678.  
  1679.     case C_RETURN   : fprintf(fp,"ret()");
  1680.               break;
  1681.  
  1682.     case C_GOTO    : outputJump(fp,intOf(snd(instr)));
  1683.               break;
  1684.  
  1685.     case C_FLUSH    : fprintf(fp,"onto(");
  1686.               expr(fp,snd(instr));
  1687.               fputc(')',fp);
  1688.               break;
  1689.  
  1690.     case C_SETSTK   : fprintf(fp,"setstk(%d)",intOf(snd(instr)));
  1691.               break;
  1692.  
  1693.     case C_HEAP    : fprintf(fp,"heap(%d)",intOf(snd(instr)));
  1694.               break;
  1695.  
  1696.     case C_INTEQ    : fprintf(fp,"inteq(%d) ",intOf(fst(snd(instr))));
  1697.               outputJump(fp,intOf(snd(snd(instr))));
  1698.               break;
  1699.  
  1700.     case C_INTGE    : fprintf(fp,"intge(%d,%d) ",intOf(fst3(snd(instr))),
  1701.                              intOf(snd3(snd(instr))));
  1702.               outputJump(fp,intOf(thd3(snd(instr))));
  1703.               break;
  1704.  
  1705.     case C_INTDV    : fprintf(fp,"intdv(%d,%d) ",intOf(fst3(snd(instr))),
  1706.                              intOf(snd3(snd(instr))));
  1707.               outputJump(fp,intOf(thd3(snd(instr))));
  1708.               break;
  1709.  
  1710.     case C_TEST    : fprintf(fp,"test(");
  1711.               expr(fp,fst(snd(instr)));
  1712.               fprintf(fp,") ");
  1713.               outputJump(fp,intOf(snd(snd(instr))));
  1714.               break;
  1715.  
  1716.     case C_EVAL    : fprintf(fp,"eval(");
  1717.               expr(fp,snd(instr));
  1718.               fputc(')',fp);
  1719.               break;
  1720.  
  1721.     default        : internal("bad C code");
  1722.     }
  1723. }
  1724.  
  1725. /* --------------------------------------------------------------------------
  1726.  * Output small parts of an expression:
  1727.  * ------------------------------------------------------------------------*/
  1728.  
  1729. static Void local expr(fp,n)        /* print C expression for value       */
  1730. FILE *fp;
  1731. Cell n; {
  1732.  
  1733.     switch (whatIs(n)) {
  1734.  
  1735.     case TOP      : fprintf(fp,"top()");
  1736.             break;
  1737.  
  1738.     case POP      : fprintf(fp,"pop()");
  1739.             break;
  1740.  
  1741.     case OFFSET   : fprintf(fp,"offset(%d)",offsetOf(n));
  1742.             break;
  1743.  
  1744.     case CHARCELL : fprintf(fp,"mkChar(%d)",charOf(n));
  1745.             break;
  1746.  
  1747.     case INTCELL  : fprintf(fp,"mkSmall(%d)",intOf(n));
  1748.             break;
  1749.  
  1750.     case AP          : if (fst(n)==ROOTFST) {
  1751.                 fprintf(fp,"rootFst(");
  1752.                 expr(fp,arg(n));
  1753.                 fputc(')',fp);
  1754.             }
  1755.             else if (isSelect(fst(n))) {
  1756.                 fprintf(fp,"dsel(%d,",selectOf(fst(n)));
  1757.                 expr(fp,arg(n));
  1758.                 fputc(')',fp);
  1759.             }
  1760.             else
  1761.                 internal("exprAP");
  1762.             break;
  1763.  
  1764.     case DICTCELL : fprintf(fp,"dict[%d]",dictUse[dictOf(n)]);
  1765.             break;
  1766.  
  1767.     case UNIT     : fprintf(fp,"mkCfun(0)");
  1768.             break;
  1769.  
  1770.     case TUPLE    : fprintf(fp,"mkCfun(%d)",tupleOf(n));
  1771.             break;
  1772.  
  1773.     case NAME     : if (name(n).defn==CFUN)
  1774.                 fprintf(fp,"mkCfun(%d)",name(n).number);
  1775.             else if (name(n).primDef)
  1776.                 fprintf(fp,"%s",primitives[name(n).number].ref);
  1777.             else
  1778.                 fprintf(fp,"sc[%d]",name(n).number);
  1779.             break;
  1780.  
  1781.     default          : internal("expr");
  1782.     }
  1783. }
  1784.  
  1785. static Void local outputLabel(fp,lab)    /* print C program label       */
  1786. FILE *fp;
  1787. Int  lab; {
  1788.     if (lab<=26)
  1789.     fputc('a'+lab-1, fp);
  1790.     else
  1791.     fprintf(fp,"a%d",lab-26);
  1792. }
  1793.  
  1794. static Void local outputJump(fp,lab)    /* print jump to label, taking       */
  1795. FILE *fp;                /* special account of FAIL label   */
  1796. Int  lab; {
  1797.     if (lab==FAIL)
  1798.     fprintf(fp,"fail()");
  1799.     else {
  1800.     fprintf(fp,"goto ");
  1801.     outputLabel(fp,lab);
  1802.     }
  1803. }
  1804.  
  1805. static Void local outputCStr(fp,s)    /* print out string, taking care   */
  1806. FILE   *fp;                /* to avoid problems with C escape */
  1807. String s; {                /* sequences               */
  1808.     fputc('"',fp);
  1809.     for (; *s; s++) {
  1810.         if (*s=='\\' || *s=='"')
  1811.         fprintf(fp,"\\%c",*s);
  1812.     else if (isprint(*s))
  1813.         fputc(*s,fp);
  1814.     else if (*s=='\n')
  1815.         fprintf(fp,"\\n");
  1816.     else
  1817.         fprintf(fp,"\\%03o",(*s<0 ? *s+NUM_CHARS : *s));
  1818.     }
  1819.     fputc('"',fp);
  1820. }
  1821.  
  1822. static Bool local validCstring(s)    /* check whether string s is valid */
  1823. String s; {                /* C identifier               */
  1824.     for (; *s && isascii(*s) && isalnum(*s); s++)
  1825.     ;
  1826.     return *s=='\0';
  1827. }
  1828.  
  1829. static String local scNameOf(n)        /* get name of C implementation of */
  1830. Name n; {                /* a particular supercombinator       */
  1831.     String s = textToStr(name(n).text);
  1832.     static char buffer[100];
  1833.  
  1834.     if (validCstring(s) && strlen(s)<96)
  1835.     sprintf(buffer,"sc_%s",s);
  1836.     else
  1837.     sprintf(buffer,"sc_%d",name(n).number);
  1838.  
  1839.     return buffer;
  1840. }
  1841.  
  1842. /* --------------------------------------------------------------------------
  1843.  * Pretty printing of tables:
  1844.  * ------------------------------------------------------------------------*/
  1845.  
  1846. #define TABLEWIDTH 72
  1847. static int    tableCol;
  1848. static int    tableItems;
  1849. static String tableStart;
  1850. static String tableEndLine;
  1851. static String tableEndTab;
  1852.  
  1853. static Void local startTable(start,endLine,endTab)
  1854. String start;
  1855. String endLine;
  1856. String endTab; {
  1857.     tableStart   = start;
  1858.     tableEndLine = endLine;
  1859.     tableEndTab  = endTab;
  1860.     tableCol     = 0;
  1861.     tableItems   = 0;
  1862. }
  1863.  
  1864. static Void local finishTable(fp)
  1865. FILE *fp; {
  1866.     if (tableCol>0)
  1867.     fprintf(fp,tableEndTab);
  1868. }
  1869.  
  1870. static Void local tableItem(fp,s)
  1871. FILE   *fp;
  1872. String s; {
  1873.     int n = strlen(s);
  1874.  
  1875.     if (tableItems++ == 0) {
  1876.     fprintf(fp,tableStart);
  1877.     tableCol = strlen(tableStart);
  1878.     }
  1879.     else {
  1880.     if (tableCol+n+2>TABLEWIDTH) {
  1881.         fprintf(fp,"%s\n%s",tableEndLine,tableStart);
  1882.         tableCol = strlen(tableStart);
  1883.     }
  1884.     else {
  1885.         fprintf(fp,", ");
  1886.         tableCol+=2;
  1887.     }
  1888.     }
  1889.     fprintf(fp,"%s",s);
  1890.     tableCol += n;
  1891. }
  1892.  
  1893. /* --------------------------------------------------------------------------
  1894.  * Machine control:
  1895.  * ------------------------------------------------------------------------*/
  1896.  
  1897. Void machine(what)
  1898. Int what; {
  1899.     switch (what) {
  1900.     case RESET   : scDeps  = NIL;
  1901.                break;
  1902.  
  1903.     case MARK    : mark(scDeps);
  1904.                mark(shouldntFail);
  1905.                mark(functionReturn);
  1906.                mark(noAction);
  1907.                break;
  1908.  
  1909.     case INSTALL : machine(RESET);
  1910.                memory = (Memory)farCalloc(NUM_ADDRS,sizeof(MemCell));
  1911.                if (memory==0)
  1912.                fatal("Cannot allocate program memory");
  1913.  
  1914.                shouldntFail   = pair(mkInt(0),ERRCONT);
  1915.                functionReturn = pair(mkInt(0),UPDRETC);
  1916.                noAction          = pair(mkInt(0),RUNONC);
  1917.                break;
  1918.     }
  1919. }
  1920.  
  1921. /* ------------------------------------------------------------------------*/
  1922.