home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / gofer / Sources / c / output < prev    next >
Encoding:
Text File  |  1993-02-12  |  25.9 KB  |  1,132 lines
  1. /* --------------------------------------------------------------------------
  2.  * output.c:    Copyright (c) Mark P Jones 1991-1993.   All rights reserved.
  3.  *              See goferite.h for details and conditions of use etc...
  4.  *              Gofer version 2.28 January 1993
  5.  *
  6.  * Unparse expressions and types - for use in error messages, type checker
  7.  * and for debugging.
  8.  * ------------------------------------------------------------------------*/
  9.  
  10. #ifndef  GOFC_OUTPUT
  11. #include "prelude.h"
  12. #include "storage.h"
  13. #include "connect.h"
  14. #include "errors.h"
  15. #include <ctype.h>
  16. #endif
  17.  
  18. /* --------------------------------------------------------------------------
  19.  * Local function prototypes:
  20.  * ------------------------------------------------------------------------*/
  21.  
  22. static Void local putChr     Args((Int));
  23. static Void local putStr     Args((String));
  24. static Void local putInt     Args((Int));
  25. static Void local indent     Args((Int));
  26.  
  27. static Void local put             Args((Int,Cell));
  28. static Void local putComp     Args((Cell,List));
  29. static Void local putQual        Args((Cell));
  30. static Bool local isDictVal     Args((Cell));
  31. static Cell local maySkipDict     Args((Cell));
  32. static Void local putAp         Args((Int,Cell));
  33. static Void local putOverInfix   Args((Int,Text,Syntax,Cell));
  34. static Void local putInfix     Args((Int,Text,Syntax,Cell,Cell));
  35. static Void local putSimpleAp     Args((Cell));
  36. static Void local putTuple     Args((Int,Cell));
  37. static Int  local unusedTups     Args((Int,Cell));
  38. static Void local unlexVar     Args((Text));
  39. static Void local unlexOp     Args((Text));
  40. static Void local unlexCharConst Args((Cell));
  41. static Void local unlexStrConst     Args((Text));
  42.  
  43. #ifdef GOFC_OUTPUT
  44. static Void local pPut         Args((Int,Cell,Int));
  45. static Void local pPutAp     Args((Int,Cell,Int));
  46. static Void local pPutSimpleAp     Args((Cell,Int));
  47. static Void local pPutTuple     Args((Int,Cell,Int));
  48. static Int  local punusedTups     Args((Int,Cell,Int));
  49. static Void local pPutOffset     Args((Int));
  50. static Int  local pPutLocals     Args((List,Int));
  51. static Void local pLiftedStart     Args((Cell,Int,String));
  52. static Void local pLifted     Args((Cell,Int,String));
  53. static Int  local pDiscr     Args((Cell,Int));
  54. #endif
  55.  
  56. static Void local putSigType     Args((Cell));
  57. static Void local putContext     Args((List));
  58. static Void local putPred     Args((Cell));
  59. static Void local putType     Args((Cell,Int));
  60. static Void local putTyVar     Args((Int));
  61. static Bool local putTupleType   Args((Cell));
  62. static Void local putApType     Args((Type));
  63.  
  64. static Void local putKind     Args((Kind));
  65. static Void local putSig     Args((Cell));
  66.  
  67. /* --------------------------------------------------------------------------
  68.  * Basic output routines:
  69.  * ------------------------------------------------------------------------*/
  70.  
  71. static FILE *outputStream;        /* current output stream       */
  72. static Int  outColumn = 0;        /* current output column number       */
  73. Bool   showDicts = FALSE;        /* TRUE => include dictionary vars */
  74.                     /*       in output expressions   */
  75.  
  76. #define OPEN(b)    if (b) putChr('(');
  77. #define CLOSE(b)   if (b) putChr(')');
  78.  
  79. static Void local putChr(c)             /* print single character          */
  80. Int c; {
  81.     putc(c,outputStream);
  82.     outColumn++;
  83. }
  84.  
  85. static Void local putStr(s)             /* print string                    */
  86. String s; {
  87.     for (; *s; s++) {
  88.         putc(*s,outputStream);
  89.         outColumn++;
  90.     }
  91. }
  92.  
  93. static Void local putInt(n)             /* print integer                   */
  94. Int n; {
  95.     static char intBuf[16];
  96.     sprintf(intBuf,"%d",n);
  97.     putStr(intBuf);
  98. }
  99.  
  100. static Void local indent(n)             /* indent to particular position   */
  101. Int n; {
  102.     outColumn = n;
  103.     while (0<n--) {
  104.         putc(' ',outputStream);
  105.     }
  106. }
  107.  
  108. /* --------------------------------------------------------------------------
  109.  * Precedence values (See Haskell report p.10):
  110.  * ------------------------------------------------------------------------*/
  111.  
  112. #define ALWAYS        FUN_PREC           /* Always use parens (unless atomic)*/
  113.                        /* User defined operators have prec */
  114.                        /* in the range MIN_PREC..MAX_PREC  */
  115. #define ARROW_PREC  MAX_PREC           /* for printing -> in type exprs    */
  116. #define COCO_PREC   (MIN_PREC-1)       /* :: is left assoc, low precedence */
  117. #define COND_PREC   (MIN_PREC-2)       /* conditional expressions       */
  118. #define WHERE_PREC  (MIN_PREC-3)       /* where expressions           */
  119. #define LAM_PREC    (MIN_PREC-4)       /* lambda abstraction           */
  120. #define NEVER        LAM_PREC           /* Never use parentheses        */
  121.  
  122.  
  123. /* --------------------------------------------------------------------------
  124.  * Print an expression (used to display context of type errors):
  125.  * ------------------------------------------------------------------------*/
  126.  
  127. static Int putDepth = 0;           /* limits depth of printing DBG       */
  128.  
  129. static Void local put(d,e)           /* print expression e in context of */
  130. Int  d;                    /* operator of precedence d       */
  131. Cell e; {
  132.     List xs;
  133.  
  134.     if (putDepth>10) {
  135.     putStr("...");
  136.     return;
  137.     }
  138.     else
  139.     putDepth++;
  140.  
  141.     switch (whatIs(e)) {
  142.     case FINLIST    : putChr('[');
  143.               xs = snd(e);
  144.               if (nonNull(xs)) {
  145.                   put(NEVER,hd(xs));
  146.                   while (nonNull(xs=tl(xs))) {
  147.                   putChr(',');
  148.                   put(NEVER,hd(xs));
  149.                   }
  150.               }
  151.               putChr(']');
  152.               break;
  153.  
  154.     case AP     : putAp(d,e);
  155.               break;
  156.  
  157.     case NAME    : unlexVar(name(e).text);
  158.               break;
  159.  
  160.     case VARIDCELL    :
  161.     case VAROPCELL    :
  162.     case DICTVAR    :
  163.     case CONIDCELL    :
  164.     case CONOPCELL    : unlexVar(textOf(e));
  165.               break;
  166.  
  167.     case DICTCELL   : putStr("{dict}");
  168.               break;
  169.  
  170.     case SELECT    : putStr("#");
  171.               putInt(selectOf(e));
  172.               break;
  173.  
  174.     case UNIT    : putStr("()");
  175.               break;
  176.  
  177.     case TUPLE    : putTuple(tupleOf(e),e);
  178.               break;
  179.  
  180.     case WILDCARD    : putChr('_');
  181.               break;
  182.  
  183.     case ASPAT    : put(NEVER,fst(snd(e)));
  184.               putChr('@');
  185.               put(ALWAYS,snd(snd(e)));
  186.               break;
  187.  
  188.     case LAZYPAT    : putChr('~');
  189.               put(ALWAYS,snd(e));
  190.               break;
  191.  
  192.     case MONADCOMP    : putComp(fst(snd(snd(e))),snd(snd(snd(e))));
  193.               break;
  194.  
  195.     case COMP    :
  196.     case LISTCOMP   : putComp(fst(snd(e)),snd(snd(e)));
  197.               break;
  198.  
  199.     case CHARCELL    : unlexCharConst(charOf(e));
  200.               break;
  201.  
  202.     case INTCELL    : putInt(intOf(e));
  203.               break;
  204.  
  205.         case FLOATCELL  : putStr(floatToString(floatOf(e)));
  206.               break;
  207.  
  208.     case STRCELL    : unlexStrConst(textOf(e));
  209.               break;
  210.  
  211.     case LETREC    : OPEN(d>WHERE_PREC);
  212. #ifdef DEBUG_CODE
  213.               putStr("let {");
  214.               put(NEVER,fst(snd(e)));
  215.               putStr("} in ");
  216. #else
  217.                           putStr("let {...} in ");
  218. #endif
  219.                           put(WHERE_PREC+1,snd(snd(e)));
  220.               CLOSE(d>WHERE_PREC);
  221.               break;
  222.  
  223.     case COND    : OPEN(d>COND_PREC);
  224.               putStr("if ");
  225.               put(COND_PREC+1,fst3(snd(e)));
  226.               putStr(" then ");
  227.               put(COND_PREC+1,snd3(snd(e)));
  228.               putStr(" else ");
  229.               put(COND_PREC+1,thd3(snd(e)));
  230.               CLOSE(d>COND_PREC);
  231.               break;
  232.  
  233.     case LAMBDA    : xs = fst(snd(e));
  234.               if (!showDicts) {
  235.                   while (nonNull(xs) && isDictVal(hd(xs)))
  236.                   xs = tl(xs);
  237.                   if (isNull(xs)) {
  238.                   put(d,snd(snd(snd(e))));
  239.                   break;
  240.                   }
  241.               }
  242.               OPEN(d>LAM_PREC);
  243.               putChr('\\');
  244.               if (nonNull(xs)) {
  245.                   put(ALWAYS,hd(xs));
  246.                   while (nonNull(xs=tl(xs))) {
  247.                   putChr(' ');
  248.                   put(ALWAYS,hd(xs));
  249.                   }
  250.               }
  251.               putStr(" -> ");
  252.               put(LAM_PREC,snd(snd(snd(e))));
  253.               CLOSE(d>LAM_PREC);
  254.               break;
  255.  
  256.     case ESIGN    : OPEN(d>COCO_PREC);
  257.               put(COCO_PREC,fst(snd(e)));
  258.               putStr(" :: ");
  259.               putSigType(snd(snd(e)));
  260.               CLOSE(d>COCO_PREC);
  261.               break;
  262.  
  263.     case CASE    : putStr("case ");
  264.               put(NEVER,fst(snd(e)));
  265. #ifdef DEBUG_CODE
  266.               putStr(" of {");
  267.               put(NEVER,snd(snd(e)));
  268.               putChr('}');
  269. #else
  270.               putStr(" of {...}");
  271. #endif
  272.               break;
  273.  
  274.     case INDIRECT    : putChr('^');
  275.               put(ALWAYS,snd(e));
  276.               break;
  277.  
  278.     default     : /*internal("put");*/
  279.               putChr('$');
  280.               putInt(e);
  281.               break;
  282.     }
  283.     putDepth--;
  284. }
  285.  
  286. static Void local putComp(e,qs)        /* print comprehension           */
  287. Cell e;
  288. List qs; {
  289.     putStr("[ ");
  290.     put(NEVER,e);
  291.     if (nonNull(qs)) {
  292.     putStr(" | ");
  293.     putQual(hd(qs));
  294.     while (nonNull(qs=tl(qs))) {
  295.         putStr(", ");
  296.         putQual(hd(qs));
  297.     }
  298.     }
  299.     putStr(" ]");
  300. }
  301.  
  302. static Void local putQual(q)        /* print list comp qualifier       */
  303. Cell q; {
  304.     switch (whatIs(q)) {
  305.     case BOOLQUAL : put(NEVER,snd(q));
  306.             return;
  307.  
  308.     case QWHERE   : putStr("let {...}");
  309.             return;
  310.  
  311.     case FROMQUAL : put(ALWAYS,fst(snd(q)));
  312.             putStr("<-");
  313.             put(NEVER,snd(snd(q)));
  314.             return;
  315.     }
  316. }
  317.  
  318. static Bool local isDictVal(e)        /* Look for dictionary value       */
  319. Cell e; {
  320.     switch (whatIs(e)) {
  321.     case AP          : return isSelect(fun(e));
  322.     case DICTCELL :
  323.     case DICTVAR  : return TRUE;
  324.     }
  325.     return FALSE;
  326. }
  327.  
  328. static Cell local maySkipDict(e)    /* descend function application       */
  329. Cell e; {                /* possibly ignoring dict aps       */
  330.     if (!showDicts)
  331.     while (isAp(e) && isDictVal(arg(e)))
  332.         e = fun(e);
  333.     return e;
  334. }
  335.  
  336. static Void local putAp(d,e)        /* print application (args>=1)       */
  337. Int  d;
  338. Cell e; {
  339.     Bool   anyDictArgs = FALSE;
  340.     Cell   h;
  341.     Text   t;
  342.     Syntax sy;
  343.     Int    args = 0;
  344.  
  345.     for (h=e; isAp(h); h=fun(h))    /* find head of expression, looking*/
  346.     if (isDictVal(arg(h))) {    /* for dictionary arguments       */
  347.         anyDictArgs = TRUE;
  348.         if (showDicts)
  349.         args++;
  350.     }
  351.     else
  352.         args++;
  353.  
  354.     if (args==0) {            /* Special case when *all* args       */
  355.     put(d,h);            /* are dictionary values       */
  356.     return;
  357.     }
  358.  
  359.     switch (whatIs(h)) {
  360.     case ADDPAT    : if (args==1)
  361.                   putInfix(d,textPlus,syntaxOf(textPlus),
  362.                      arg(e),mkInt(intValOf(fun(e))));
  363.               else
  364.                   putStr("ADDPAT");
  365.               return;
  366.  
  367.     case MULPAT    : if (args==1)
  368.                   putInfix(d,textMult,syntaxOf(textMult),
  369.                      mkInt(intValOf(fun(e))),arg(e));
  370.               else
  371.                   putStr("MULPAT");
  372.               return;
  373.  
  374.     case TUPLE    : OPEN(args>tupleOf(h) && d>=FUN_PREC);
  375.               putTuple(tupleOf(h),e);
  376.               CLOSE(args>tupleOf(h) && d>=FUN_PREC);
  377.               return;
  378.  
  379.     case NAME    : sy = syntaxOf(t = name(h).text);
  380.               break;
  381.     case VARIDCELL    :
  382.     case VAROPCELL    :
  383.     case DICTVAR    :
  384.     case CONIDCELL    :
  385.     case CONOPCELL    : sy = syntaxOf(t = textOf(h));
  386.               break;
  387.  
  388.     default     : sy = APPLIC;
  389.               break;
  390.     }
  391.  
  392.     e = maySkipDict(e);
  393.     if (showDicts && anyDictArgs)    /* expressions involving dicts       */
  394.     sy = APPLIC;            /* are printed applicatively       */
  395.  
  396.     if (sy==APPLIC) {                   /* print simple application       */
  397.     OPEN(d>=FUN_PREC);
  398.     putSimpleAp(e);
  399.     CLOSE(d>=FUN_PREC);
  400.     return;
  401.     }
  402.     else if (args==1) {                /* print section of the form (e+)  */
  403.     putChr('(');
  404.     put(FUN_PREC-1,arg(e));
  405.     putChr(' ');
  406.     unlexOp(t);
  407.     putChr(')');
  408.     }
  409.     else if (args==2)               /* infix expr of the form e1 + e2   */
  410.     putInfix(d,t,sy,arg(maySkipDict(fun(e))),arg(e));
  411.     else {                   /* o/w (e1 + e2) e3 ... en   (n>=3) */
  412.     OPEN(d>=FUN_PREC);
  413.     putOverInfix(args,t,sy,e);
  414.     CLOSE(d>=FUN_PREC);
  415.     }
  416. }
  417.  
  418. static Void local putOverInfix(args,t,sy,e)
  419. Int    args;                   /* infix applied to >= 3 arguments  */
  420. Text   t;
  421. Syntax sy;
  422. Cell   e; {
  423.     if (args>2) {
  424.     putOverInfix(args-1,t,sy,maySkipDict(fun(e)));
  425.     putChr(' ');
  426.     put(FUN_PREC,arg(e));
  427.     }
  428.     else
  429.     putInfix(ALWAYS,t,sy,arg(maySkipDict(fun(e))),arg(e));
  430. }
  431.  
  432. static Void local putInfix(d,t,sy,e,f)  /* print infix expression       */
  433. Int    d;
  434. Text   t;                /* Infix operator symbol         */
  435. Syntax sy;                /* with name t, syntax s        */
  436. Cell   e, f; {                /* Left and right operands       */
  437.     Syntax a = assocOf(sy);
  438.     Int    p = precOf(sy);
  439.  
  440.     OPEN(d>p);
  441.     put((a==LEFT_ASS ? p : 1+p), e);
  442.     putChr(' ');
  443.     unlexOp(t);
  444.     putChr(' ');
  445.     put((a==RIGHT_ASS ? p : 1+p), f);
  446.     CLOSE(d>p);
  447. }
  448.  
  449. static Void local putSimpleAp(e)       /* print application e0 e1 ... en   */
  450. Cell e; {
  451.     if (isAp(e)) {
  452.     putSimpleAp(maySkipDict(fun(e)));
  453.     putChr(' ');
  454.     put(FUN_PREC,arg(e));
  455.     }
  456.     else
  457.     put(FUN_PREC,e);
  458. }
  459.  
  460. static Void local putTuple(ts,e)    /* Print tuple expression, allowing*/
  461. Int  ts;                /* for possibility of either too   */
  462. Cell e; {                /* few or too many args to constr  */
  463.     Int i;
  464.     putChr('(');
  465.     if ((i=unusedTups(ts,e))>0) {
  466.     while (--i>0)
  467.         putChr(',');
  468.         putChr(')');
  469.     }
  470. }
  471.  
  472. static Int local unusedTups(ts,e)    /* print first part of tuple expr  */
  473. Int  ts;                /* returning number of constructor */
  474. Cell e; {                /* args not yet printed ...       */
  475.     if (isAp(e)) {
  476.     if ((ts=unusedTups(ts,fun(e))-1)>=0) {
  477.         put(NEVER,arg(e));
  478.         putChr(ts>0?',':')');
  479.     }
  480.     else {
  481.         putChr(' ');
  482.         put(FUN_PREC,arg(e));
  483.     }
  484.     }
  485.     return ts;
  486. }
  487.  
  488. static Void local unlexVar(t)           /* print text as a variable name    */
  489. Text t; {                   /* operator symbols must be enclosed*/
  490.     String s = textToStr(t);           /* in parentheses... except [] ...  */
  491.  
  492.     if ((isascii(s[0]) && isalpha(s[0])) || s[0]=='_' || strcmp(s,"[]")==0)
  493.     putStr(s);
  494.     else {
  495.     putChr('(');
  496.     putStr(s);
  497.     putChr(')');
  498.     }
  499. }
  500.  
  501. static Void local unlexOp(t)           /* print text as operator name       */
  502. Text t; {                   /* alpha numeric symbols must be    */
  503.     String s = textToStr(t);           /* enclosed by backquotes       */
  504.  
  505.     if (isascii(s[0]) && isalpha(s[0])) {
  506.     putChr('`');
  507.     putStr(s);
  508.     putChr('`');
  509.     }
  510.     else
  511.     putStr(s);
  512. }
  513.  
  514. static Void local unlexCharConst(c)
  515. Cell c; {
  516.     putChr('\'');
  517.     putStr(unlexChar(c,'\''));
  518.     putChr('\'');
  519. }
  520.  
  521. static Void local unlexStrConst(t)
  522. Text t; {
  523.     String s            = textToStr(t);
  524.     static Char SO      = 14;        /* ASCII code for '\SO'           */
  525.     Bool   lastWasSO    = FALSE;
  526.     Bool   lastWasDigit = FALSE;
  527.     Bool   lastWasEsc   = FALSE;
  528.  
  529.     putChr('\"');
  530.     for (; *s; s++) {
  531.         String ch = unlexChar(*s,'\"');
  532.     Char   c  = ' ';
  533.  
  534.     if ((lastWasSO && *ch=='H') ||
  535.         (lastWasEsc && lastWasDigit && isascii(*ch) && isdigit(*ch)))
  536.         putStr("\\&");
  537.  
  538.         lastWasEsc   = (*ch=='\\');
  539.         lastWasSO    = (*s==SO);
  540.         for (; *ch; c = *ch++)
  541.         putChr(*ch);
  542.         lastWasDigit = (isascii(c) && isdigit(c));
  543.     }
  544.     putChr('\"');
  545. }
  546.  
  547. /* --------------------------------------------------------------------------
  548.  * Pretty printer for supercombinator definitions:
  549.  * i.e. for lambda-lifter output, immediately prior to code generation.
  550.  * ------------------------------------------------------------------------*/
  551.  
  552. #ifdef GOFC_OUTPUT
  553. static Void local pPut(d,e,co)           /* pretty print expr in context of  */
  554. Int  d;                    /* operator of precedence d       */
  555. Cell e;                       /* with current offset co       */
  556. Int  co; {
  557.     switch (whatIs(e)) {
  558.     case AP     : if (fun(e)==mkSelect(0))
  559.                   pPut(d,arg(e),co);
  560.               else
  561.                   pPutAp(d,e,co);
  562.               break;
  563.  
  564.     case OFFSET    : pPutOffset(offsetOf(e));
  565.               break;
  566.  
  567.     case NAME    : unlexVar(name(e).text);
  568.               break;
  569.  
  570.     case DICTCELL   : putStr("{dict}");
  571.               break;
  572.  
  573.     case SELECT    : putStr("#");
  574.               putInt(selectOf(e));
  575.               break;
  576.  
  577.     case UNIT    : putStr("()");
  578.               break;
  579.  
  580.     case TUPLE    : pPutTuple(tupleOf(e),e,co);
  581.               break;
  582.  
  583.     case CHARCELL    : unlexCharConst(charOf(e));
  584.               break;
  585.  
  586.     case INTCELL    : putInt(intOf(e));
  587.               break;
  588.  
  589.         case FLOATCELL  : putStr(floatToString(floatOf(e)));
  590.               break;
  591.  
  592.     case STRCELL    : unlexStrConst(textOf(e));
  593.               break;
  594.  
  595.     case LETREC    : OPEN(d>WHERE_PREC);
  596.               co += pPutLocals(fst(snd(e)),co);
  597.               pPut(WHERE_PREC+1, snd(snd(e)), co);
  598.               CLOSE(d>WHERE_PREC);
  599.               break;
  600.  
  601.     case COND    : OPEN(d>COND_PREC);
  602.               putStr("if ");
  603.               pPut(COND_PREC+1,fst3(snd(e)),co);
  604.               putStr(" then ");
  605.               pPut(COND_PREC+1,snd3(snd(e)),co);
  606.               putStr(" else ");
  607.               pPut(COND_PREC+1,thd3(snd(e)),co);
  608.               CLOSE(d>COND_PREC);
  609.               break;
  610.  
  611.     default     : internal("pPut");
  612.     }
  613. }
  614.  
  615. static Void local pPutAp(d,e,co)    /* print application (args>=1)       */
  616. Int  d;
  617. Cell e;
  618. Int  co; {
  619.     Bool   anyDictArgs = FALSE;
  620.     Cell   h;
  621.     Text   t;
  622.     Syntax sy;
  623.     Int    args = 0;
  624.  
  625.     for (h=e; isAp(h); h=fun(h)) {    /* find head of expression, looking*/
  626.     if (isDictVal(arg(h)))        /* for dictionary arguments       */
  627.         anyDictArgs = TRUE;
  628.     args++;
  629.     }
  630.  
  631.     switch (whatIs(h)) {
  632.     case TUPLE    : OPEN(args>tupleOf(h) && d>=FUN_PREC);
  633.               pPutTuple(tupleOf(h),e,co);
  634.               CLOSE(args>tupleOf(h) && d>=FUN_PREC);
  635.               return;
  636.  
  637.     case NAME    : sy = syntaxOf(t = name(h).text);
  638.               break;
  639.  
  640.     default     : sy = APPLIC;
  641.               break;
  642.     }
  643.  
  644.     if (anyDictArgs || args>2)        /* print some exprs applicatively  */
  645.     sy = APPLIC;
  646.  
  647.     if (sy==APPLIC) {                   /* print simple application       */
  648.     OPEN(d>=FUN_PREC);
  649.     pPutSimpleAp(e,co);
  650.     CLOSE(d>=FUN_PREC);
  651.     return;
  652.     }
  653.     else if (args==1) {                /* print section of the form (e+)  */
  654.     putChr('(');
  655.     pPut(FUN_PREC-1,arg(e),co);
  656.     putChr(' ');
  657.     unlexOp(t);
  658.     putChr(')');
  659.     }
  660.     else {                /* infix expr of the form e1 + e2  */
  661.     Syntax a = assocOf(sy);
  662.     Int    p = precOf(sy);
  663.     OPEN(d>p);
  664.     pPut((a==LEFT_ASS ? p : 1+p), arg(fun(e)), co);
  665.     putChr(' ');
  666.     unlexOp(t);
  667.     putChr(' ');
  668.     pPut((a==RIGHT_ASS ? p : 1+p), arg(e), co);
  669.     CLOSE(d>p);
  670.     }
  671.  
  672. }
  673.  
  674. static Void local pPutSimpleAp(e,co)    /* print application e0 e1 ... en  */
  675. Cell e;
  676. Int  co; {
  677.     if (isAp(e)) {
  678.     pPutSimpleAp(fun(e),co);
  679.     putChr(' ');
  680.     pPut(FUN_PREC,arg(e),co);
  681.     }
  682.     else
  683.     pPut(FUN_PREC,e,co);
  684. }
  685.  
  686. static Void local pPutTuple(ts,e,co)    /* Print tuple expression, allowing*/
  687. Int  ts;                /* for possibility of either too   */
  688. Cell e;                    /* few or too many args to constr  */
  689. Int  co; {
  690.     Int i;
  691.     putChr('(');
  692.     if ((i=punusedTups(ts,e,co))>0) {
  693.     while (--i>0)
  694.         putChr(',');
  695.         putChr(')');
  696.     }
  697. }
  698.  
  699. static Int local punusedTups(ts,e,co)    /* print first part of tuple expr  */
  700. Int  ts;                /* returning number of constructor */
  701. Cell e;                    /* args not yet printed ...       */
  702. Int  co; {
  703.     if (isAp(e)) {
  704.     if ((ts=punusedTups(ts,fun(e),co)-1)>=0) {
  705.         pPut(NEVER,arg(e),co);
  706.         putChr(ts>0?',':')');
  707.     }
  708.     else {
  709.         putChr(' ');
  710.         pPut(FUN_PREC,arg(e),co);
  711.     }
  712.     }
  713.     return ts;
  714. }
  715.  
  716. static Void local pPutOffset(n)        /* pretty print offset number       */
  717. Int n; {
  718.     putChr('o');
  719.     putInt(n);
  720. }
  721.  
  722. static Int local pPutLocals(vs,co)    /* pretty print locals           */
  723. List vs;
  724. Int  co; {
  725.     Int left = outColumn;
  726.     Int n    = length(vs);
  727.     Int i;
  728.  
  729.     putStr("let { ");
  730.     for (i=0; i<n; i++) {
  731.     pPutOffset(co+i+1);
  732.     putChr(' ');
  733.     pLiftedStart(hd(vs),co+n,"=");
  734.     vs = tl(vs);
  735.     if (nonNull(vs))
  736.         indent(left+6);
  737.     }
  738.     indent(left);
  739.     putStr("} in  ");
  740.     return n;
  741. }
  742.  
  743. static Void local pLiftedStart(e,co,eq)    /* print start of definition       */
  744. Cell   e;
  745. Int    co;
  746. String eq; {
  747.     if (whatIs(e)!=GUARDED) {
  748.     putStr(eq);
  749.     putChr(' ');
  750.     }
  751.     pLifted(e,co,eq);
  752. }
  753.  
  754. static Void local pLifted(e,co,eq)    /* print lifted definition       */
  755. Cell   e;
  756. Int    co;
  757. String eq; {
  758.     switch (whatIs(e)) {
  759.     case GUARDED : {   Int  left = outColumn;
  760.                List gs   = snd(e);
  761.                if (isNull(gs))
  762.                    internal("pLifted");
  763.                for (;;) {
  764.                    putStr("| ");
  765.                    pPut(NEVER,fst(hd(gs)),co);
  766.                    putChr(' ');
  767.                    putStr(eq);
  768.                    putChr(' ');
  769.                    pPut(NEVER,snd(hd(gs)),co);
  770.                    putStr(";\n");
  771.                    gs = tl(gs);
  772.                    if (nonNull(gs))
  773.                    indent(left);
  774.                    else
  775.                    break;
  776.                }
  777.                }
  778.                break;
  779.  
  780.     case LETREC  : co += pPutLocals(fst(snd(e)),co);
  781.                pLifted(snd(snd(e)), co, eq);
  782.                break;
  783.  
  784.         case FATBAR  : {   Int left = outColumn;
  785.                pLifted(fst(snd(e)),co,eq);
  786.                indent(left);
  787.                putStr("FATBAR\n");
  788.                indent(left);
  789.                pLifted(snd(snd(e)),co,eq);
  790.                }
  791.                break;
  792.  
  793.     case CASE    : {   Int  left = outColumn;
  794.                List cs   = snd(snd(e));
  795.                putStr("case ");
  796.                pPut(NEVER,fst(snd(e)),co);
  797.                putStr(" of {\n");
  798.                for (; nonNull(cs); cs=tl(cs)) {
  799.                    Int arity;
  800.                    indent(left+2);
  801.                    arity = pDiscr(fst(hd(cs)),co);
  802.                    putChr(' ');
  803.                    pLiftedStart(snd(hd(cs)),co+arity,"->");
  804.                }
  805.                indent(left);
  806.                putStr("}\n");
  807.                }
  808.                break;
  809.  
  810.     default         : pPut(NEVER,e,co);
  811.                putStr(";\n");
  812.                break;
  813.     }
  814. }
  815.  
  816. static Int local pDiscr(d,co)        /* pretty print discriminator       */
  817. Cell d;
  818. Int  co; {
  819.     Int arity = 0;
  820.  
  821.     switch (whatIs(d)) {
  822.     case INTCELL  : putInt(intOf(d));
  823.             break;
  824.  
  825.     case CHARCELL : unlexCharConst(charOf(d));
  826.             break;
  827.  
  828.     case UNIT     : putStr("()");
  829.             break;
  830.  
  831.     case ADDPAT   : pPutOffset(co+1);
  832.             putChr('+');
  833.             putInt(intValOf(d));
  834.             arity = 1;
  835.             break;
  836.  
  837.     case MULPAT   : putInt(intValOf(d));
  838.             putChr('*');
  839.             pPutOffset(co+1);
  840.             arity = 1;
  841.             break;
  842.  
  843.     case NAME     : {   Int i = 0;
  844.                 arity = name(d).arity;
  845.                 unlexVar(name(d).text);
  846.                 for (; i<arity; ++i) {
  847.                 putChr(' ');
  848.                 pPutOffset(co+arity-i);
  849.                 }
  850.             }
  851.             break;
  852.  
  853.     case TUPLE    : {   Int i = 0;
  854.                 arity = tupleOf(d);
  855.                 putChr('(');
  856.                 pPutOffset(co+arity);
  857.                 while (++i<arity) {
  858.                 putChr(',');
  859.                 pPutOffset(co+arity-i);
  860.                 }
  861.                 putChr(')');
  862.             }
  863.             break;
  864.  
  865.     default          : internal("pDiscr");
  866.     }
  867.  
  868.     return arity;
  869. }
  870.  
  871. Void pScDef(t,arity,e)            /* pretty print sc defn on gofcFp  */
  872. Text t;
  873. Int  arity;
  874. Cell e; {
  875.     Int i;
  876.     outputStream = gofcFp;
  877.     putChr('\n');
  878.     outColumn = 0;
  879.     unlexVar(t);
  880.     for (i=0; i<arity; i++) {
  881.     putChr(' ');
  882.     pPutOffset(arity-i);
  883.     }
  884.     putChr(' ');
  885.     pLiftedStart(e,arity,"=");
  886. }
  887. #endif
  888.  
  889. /* --------------------------------------------------------------------------
  890.  * Print type expression:
  891.  * ------------------------------------------------------------------------*/
  892.  
  893. static Void local putSigType(t)        /* print (possibly) generic type   */
  894. Cell t; {
  895.     if (isPolyType(t))            /* skip (forall _) part (if any)   */
  896.         t = monoTypeOf(t);
  897.  
  898.     if (whatIs(t)==QUAL) {        /* Handle qualified types          */
  899.         putContext(fst(snd(t)));
  900.         putStr(" => ");
  901.         t = snd(snd(t));
  902.     }
  903.  
  904.     putType(t,NEVER);            /* Finally, print rest of type ... */
  905. }
  906.  
  907. static Void local putContext(qs)    /* print context list           */
  908. List qs; {
  909.     if (isNull(qs))
  910.     putStr("()");
  911.     else {
  912.     Int nq = length(qs);
  913.  
  914.     if (nq!=1) putChr('(');
  915.     putPred(hd(qs));
  916.     while (nonNull(qs=tl(qs))) {
  917.         putStr(", ");
  918.         putPred(hd(qs));
  919.     }
  920.     if (nq!=1) putChr(')');
  921.     }
  922. }
  923.  
  924. static Void local putPred(pi)        /* Output predicate           */
  925. Cell pi; {
  926.     if (isAp(pi)) {
  927.     putPred(fun(pi));
  928.     putChr(' ');
  929.     putType(arg(pi),ALWAYS);
  930.     }
  931.     else if (isClass(pi))
  932.     putStr(textToStr(class(pi).text));
  933.     else if (isCon(pi))
  934.     putStr(textToStr(textOf(pi)));
  935.     else
  936.     putStr("<unknownPredicate>");
  937. }
  938.  
  939. static Void local putType(t,prec)    /* print nongeneric type expression*/
  940. Cell t;
  941. Int  prec; {
  942.     switch(whatIs(t)) {
  943.     case UNIT    : putStr("()");
  944.                break;
  945.  
  946.     case LIST    : putStr("[]");
  947.                break;
  948.  
  949.     case ARROW   : putStr("(->)");
  950.                break;
  951.  
  952.     case TYCON   : putStr(textToStr(tycon(t).text));
  953.                break;
  954.  
  955.     case TUPLE   : {   Int n = tupleOf(t);
  956.                putChr('(');
  957.                while (--n > 0)
  958.                    putChr(',');
  959.                putChr(')');
  960.                }
  961.                break;
  962.  
  963.     case OFFSET  : putTyVar(offsetOf(t));
  964.                break;
  965.  
  966.     case INTCELL : putChr('_');
  967.                putInt(intOf(t));
  968.                break;
  969.  
  970.     case AP         : {   Cell typeHead = getHead(t);
  971.                Bool brackets = (argCount!=0 && prec>=ALWAYS);
  972.  
  973.                switch (whatIs(typeHead)) {
  974.                    case LIST  : if (argCount==1) {
  975.                         putChr('[');
  976.                         putType(arg(t),NEVER);
  977.                         putChr(']');
  978.                         return;
  979.                         }
  980.                         break;
  981.  
  982.                    case ARROW : if (argCount==2) {
  983.                         OPEN(prec>=ARROW_PREC);
  984.                         putType(arg(fun(t)),ARROW_PREC);
  985.                         putStr(" -> ");
  986.                         putType(arg(t),NEVER);
  987.                         CLOSE(prec>=ARROW_PREC);
  988.                         return;
  989.                         }
  990.                         break;
  991.  
  992.                    case TUPLE : if (argCount==tupleOf(typeHead)) {
  993.                         putChr('(');
  994.                         putTupleType(t);
  995.                         putChr(')');
  996.                         return;
  997.                         }
  998.                         break;
  999.                }
  1000.                OPEN(brackets);
  1001.                putApType(t);
  1002.                CLOSE(brackets);
  1003.                }
  1004.                break;
  1005.  
  1006.     default      : putStr("(bad type)");
  1007.     }
  1008. }
  1009.  
  1010. static Void local putTyVar(n)        /* print type variable           */
  1011. Int n; {
  1012.     static String alphabet        /* for the benefit of EBCDIC :-)   */
  1013.         ="abcdefghijklmnopqrstuvwxyz";
  1014.     putChr(alphabet[n%26]);
  1015.     if (n /= 26)            /* just in case there are > 26 vars*/
  1016.     putInt(n);
  1017. }
  1018.  
  1019. static Bool local putTupleType(e)    /* print tuple of types, returning */
  1020. Cell e; {                /* TRUE if something was printed,  */
  1021.     if (isAp(e)) {            /* FALSE otherwise; used to control*/
  1022.     if (putTupleType(fun(e)))    /* printing of intermed. commas       */
  1023.         putChr(',');
  1024.     putType(arg(e),NEVER);
  1025.     return TRUE;
  1026.     }
  1027.     return FALSE;
  1028. }
  1029.  
  1030. static Void local putApType(t)        /* print type application       */
  1031. Cell t; {
  1032.     if (isAp(t)) {
  1033.     putApType(fun(t));
  1034.     putChr(' ');
  1035.     putType(arg(t),ALWAYS);
  1036.     }
  1037.     else
  1038.     putType(t,ALWAYS);
  1039. }
  1040.  
  1041. /* --------------------------------------------------------------------------
  1042.  * Print kind expression:
  1043.  * ------------------------------------------------------------------------*/
  1044.  
  1045. static Void local putKind(k)        /* print kind expression       */
  1046. Kind k; {
  1047.     switch (whatIs(k)) {
  1048.     case AP         : if (isAp(fst(k))) {
  1049.                putChr('(');
  1050.                putKind(fst(k));
  1051.                putChr(')');
  1052.                }
  1053.                else
  1054.                putKind(fst(k));
  1055.                putStr(" -> ");
  1056.                putKind(snd(k));
  1057.                break;
  1058.  
  1059.     case STAR    : putChr('*');
  1060.                break;
  1061.  
  1062.     case OFFSET  : putTyVar(offsetOf(k));
  1063.                break;
  1064.  
  1065.     case INTCELL : putChr('_');
  1066.                putInt(intOf(k));
  1067.                break;
  1068.  
  1069.     default      : putStr("(bad kind)");
  1070.     }
  1071. }
  1072.  
  1073. static Void local putSig(sig)        /* print class kind signature       */
  1074. Cell sig; {
  1075.     putChr('(');
  1076.     putKind(hd(sig));
  1077.     for (sig=tl(sig); nonNull(sig); sig=tl(sig)) {
  1078.     putStr(", ");
  1079.     putKind(hd(sig));
  1080.     }
  1081.     putChr(')');
  1082. }
  1083.  
  1084. /* --------------------------------------------------------------------------
  1085.  * Main drivers:
  1086.  * ------------------------------------------------------------------------*/
  1087.  
  1088. Void printExp(fp,e)            /* print expr on specified stream  */
  1089. FILE *fp;
  1090. Cell e; {
  1091.     outputStream = fp;
  1092.     putDepth     = 0;
  1093.     put(NEVER,e);
  1094. }
  1095.  
  1096. Void printType(fp,t)            /* print type on specified stream  */
  1097. FILE *fp;
  1098. Cell t; {
  1099.     outputStream = fp;
  1100.     putSigType(t);
  1101. }
  1102.  
  1103. Void printContext(fp,qs)        /* print context on spec. stream   */
  1104. FILE *fp;
  1105. List qs; {
  1106.     outputStream = fp;
  1107.     putContext(qs);
  1108. }
  1109.  
  1110. Void printPred(fp,pi)            /* print predicate pi on stream    */
  1111. FILE *fp;
  1112. Cell pi; {
  1113.     outputStream = fp;
  1114.     putPred(pi);
  1115. }
  1116.  
  1117. Void printKind(fp,k)            /* print kind k on stream       */
  1118. FILE *fp;
  1119. Kind k; {
  1120.     outputStream = fp;
  1121.     putKind(k);
  1122. }
  1123.  
  1124. Void printSig(fp,sig)            /* print class kind signature       */
  1125. FILE *fp;
  1126. Cell sig; {
  1127.     outputStream = fp;
  1128.     putSig(sig);
  1129. }
  1130.  
  1131. /*-------------------------------------------------------------------------*/
  1132.