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