home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / hugs101.zip / hugs101sc.zip / hugsdist / src / output.c < prev    next >
C/C++ Source or Header  |  1995-03-02  |  19KB  |  779 lines
  1. /* --------------------------------------------------------------------------
  2.  * output.c:    Copyright (c) Mark P Jones 1991-1994.   All rights reserved.
  3.  *              See NOTICE for details and conditions of use etc...
  4.  *              Hugs version 1.0 August 1994, derived from Gofer 2.30a
  5.  *
  6.  * Unparse expressions and types - for use in error messages, type checker
  7.  * and for debugging.
  8.  * ------------------------------------------------------------------------*/
  9.  
  10. #include "prelude.h"
  11. #include "storage.h"
  12. #include "connect.h"
  13. #include "errors.h"
  14. #include <ctype.h>
  15.  
  16. /* --------------------------------------------------------------------------
  17.  * Local function prototypes:
  18.  * ------------------------------------------------------------------------*/
  19.  
  20. static Void local putChr     Args((Int));
  21. static Void local putStr     Args((String));
  22. static Void local putInt     Args((Int));
  23.  
  24. static Void local put             Args((Int,Cell));
  25. static Void local putComp     Args((Cell,List));
  26. static Void local putQual        Args((Cell));
  27. static Bool local isDictVal     Args((Cell));
  28. static Cell local maySkipDict     Args((Cell));
  29. static Void local putAp         Args((Int,Cell));
  30. static Void local putOverInfix   Args((Int,Text,Syntax,Cell));
  31. static Void local putInfix     Args((Int,Text,Syntax,Cell,Cell));
  32. static Void local putSimpleAp     Args((Cell));
  33. static Void local putTuple     Args((Int,Cell));
  34. static Int  local unusedTups     Args((Int,Cell));
  35. static Void local unlexVar     Args((Text));
  36. static Void local unlexOp     Args((Text));
  37. static Void local unlexCharConst Args((Cell));
  38. static Void local unlexStrConst     Args((Text));
  39.  
  40. static Void local putSigType     Args((Cell));
  41. static Void local putContext     Args((List));
  42. static Void local putPred     Args((Cell));
  43. static Void local putType     Args((Cell,Int));
  44. static Void local putTyVar     Args((Int));
  45. static Bool local putTupleType   Args((Cell));
  46. static Void local putApType     Args((Type));
  47.  
  48. static Void local putKind     Args((Kind));
  49.  
  50. /* --------------------------------------------------------------------------
  51.  * Basic output routines:
  52.  * ------------------------------------------------------------------------*/
  53.  
  54. static FILE *outputStream;        /* current output stream       */
  55. static Int  outColumn = 0;        /* current output column number       */
  56.  
  57. #define OPEN(b)    if (b) putChr('(');
  58. #define CLOSE(b)   if (b) putChr(')');
  59.  
  60. static Void local putChr(c)             /* print single character          */
  61. Int c; {
  62.     putc(c,outputStream);
  63.     outColumn++;
  64. }
  65.  
  66. static Void local putStr(s)             /* print string                    */
  67. String s; {
  68.     for (; *s; s++) {
  69.         putc(*s,outputStream);
  70.         outColumn++;
  71.     }
  72. }
  73.  
  74. static Void local putInt(n)             /* print integer                   */
  75. Int n; {
  76.     static char intBuf[16];
  77.     sprintf(intBuf,"%d",n);
  78.     putStr(intBuf);
  79. }
  80.  
  81. /* --------------------------------------------------------------------------
  82.  * Precedence values (See Haskell report p.10):
  83.  * ------------------------------------------------------------------------*/
  84.  
  85. #define ALWAYS        FUN_PREC           /* Always use parens (unless atomic)*/
  86.                        /* User defined operators have prec */
  87.                        /* in the range MIN_PREC..MAX_PREC  */
  88. #define ARROW_PREC  MAX_PREC           /* for printing -> in type exprs    */
  89. #define COCO_PREC   (MIN_PREC-1)       /* :: is left assoc, low precedence */
  90. #define COND_PREC   (MIN_PREC-2)       /* conditional expressions       */
  91. #define WHERE_PREC  (MIN_PREC-3)       /* where expressions           */
  92. #define LAM_PREC    (MIN_PREC-4)       /* lambda abstraction           */
  93. #define NEVER        LAM_PREC           /* Never use parentheses        */
  94.  
  95.  
  96. /* --------------------------------------------------------------------------
  97.  * Print an expression (used to display context of type errors):
  98.  * ------------------------------------------------------------------------*/
  99.  
  100. static Int putDepth = 0;           /* limits depth of printing DBG       */
  101.  
  102. static Void local put(d,e)           /* print expression e in context of */
  103. Int  d;                    /* operator of precedence d       */
  104. Cell e; {
  105.     List xs;
  106.  
  107.     if (putDepth>10) {
  108.     putStr("...");
  109.     return;
  110.     }
  111.     else
  112.     putDepth++;
  113.  
  114.     switch (whatIs(e)) {
  115.     case FINLIST    : putChr('[');
  116.               xs = snd(e);
  117.               if (nonNull(xs)) {
  118.                   put(NEVER,hd(xs));
  119.                   while (nonNull(xs=tl(xs))) {
  120.                   putChr(',');
  121.                   put(NEVER,hd(xs));
  122.                   }
  123.               }
  124.               putChr(']');
  125.               break;
  126.  
  127.     case AP     : putAp(d,e);
  128.               break;
  129.  
  130.     case NAME    : unlexVar(name(e).text);
  131.               break;
  132.  
  133.     case INSTANCE   : putStr(textToStr(class(inst(e).c).text));
  134.               putChr('_');
  135.               putType(inst(e).t,NEVER);
  136.               break;
  137.  
  138.     case VARIDCELL    :
  139.     case VAROPCELL    :
  140.     case DICTVAR    :
  141.     case CONIDCELL    :
  142.     case CONOPCELL    : unlexVar(textOf(e));
  143.               break;
  144.  
  145.     case DICTCELL   : putStr("{dict");
  146.               putInt(dictOf(e));
  147.               putChr('}');
  148.               break;
  149.  
  150.     case SELECT    : putStr("#");
  151.               putInt(selectOf(e));
  152.               break;
  153.  
  154.     case UNIT    : putStr("()");
  155.               break;
  156.  
  157.     case TUPLE    : putTuple(tupleOf(e),e);
  158.               break;
  159.  
  160.     case WILDCARD    : putChr('_');
  161.               break;
  162.  
  163.     case ASPAT    : put(NEVER,fst(snd(e)));
  164.               putChr('@');
  165.               put(ALWAYS,snd(snd(e)));
  166.               break;
  167.  
  168.     case LAZYPAT    : putChr('~');
  169.               put(ALWAYS,snd(e));
  170.               break;
  171.  
  172.     case COMP    : putComp(fst(snd(e)),snd(snd(e)));
  173.               break;
  174.  
  175.     case CHARCELL    : unlexCharConst(charOf(e));
  176.               break;
  177.  
  178.     case INTCELL    : putInt(intOf(e));
  179.               break;
  180.  
  181. #if BIGNUMS
  182.     case NEGNUM    :
  183.     case ZERONUM    :
  184.     case POSNUM    : xs = bigOut(e,NIL,d>=FUN_PREC);
  185.               for (; nonNull(xs); xs=tl(xs))
  186.                   putChr(charOf(arg(hd(xs))));
  187.               break;
  188. #endif
  189.  
  190.         case FLOATCELL  : putStr(floatToString(floatOf(e)));
  191.               break;
  192.  
  193.     case STRCELL    : unlexStrConst(textOf(e));
  194.               break;
  195.  
  196.     case LETREC    : OPEN(d>WHERE_PREC);
  197. #ifdef DEBUG_CODE
  198.               putStr("let {");
  199.               put(NEVER,fst(snd(e)));
  200.               putStr("} in ");
  201. #else
  202.               putStr("let {...} in ");
  203. #endif
  204.                           put(WHERE_PREC+1,snd(snd(e)));
  205.               CLOSE(d>WHERE_PREC);
  206.               break;
  207.  
  208.     case COND    : OPEN(d>COND_PREC);
  209.               putStr("if ");
  210.               put(COND_PREC+1,fst3(snd(e)));
  211.               putStr(" then ");
  212.               put(COND_PREC+1,snd3(snd(e)));
  213.               putStr(" else ");
  214.               put(COND_PREC+1,thd3(snd(e)));
  215.               CLOSE(d>COND_PREC);
  216.               break;
  217.  
  218. #if IO_MONAD
  219.     case RUNST    : OPEN(d>=FUN_PREC);
  220.               putStr("runST ");
  221.               put(ALWAYS,snd(e));
  222.               CLOSE(d>=FUN_PREC);
  223.               break;
  224. #endif
  225.  
  226.     case LAMBDA    : xs = fst(snd(e));
  227.               while (nonNull(xs) && isDictVal(hd(xs)))
  228.                   xs = tl(xs);
  229.               if (isNull(xs)) {
  230.                   put(d,snd(snd(snd(e))));
  231.                   break;
  232.               }
  233.               OPEN(d>LAM_PREC);
  234.               putChr('\\');
  235.               if (nonNull(xs)) {
  236.                   put(ALWAYS,hd(xs));
  237.                   while (nonNull(xs=tl(xs))) {
  238.                   putChr(' ');
  239.                   put(ALWAYS,hd(xs));
  240.                   }
  241.               }
  242.               putStr(" -> ");
  243.               put(LAM_PREC,snd(snd(snd(e))));
  244.               CLOSE(d>LAM_PREC);
  245.               break;
  246.  
  247.     case ESIGN    : OPEN(d>COCO_PREC);
  248.               put(COCO_PREC,fst(snd(e)));
  249.               putStr(" :: ");
  250.               putSigType(snd(snd(e)));
  251.               CLOSE(d>COCO_PREC);
  252.               break;
  253.  
  254.     case CASE    : putStr("case ");
  255.               put(NEVER,fst(snd(e)));
  256. #ifdef DEBUG_CODE
  257.               putStr(" of {");
  258.               put(NEVER,snd(snd(e)));
  259.               putChr('}');
  260. #else
  261.               putStr(" of {...}");
  262. #endif
  263.               break;
  264.  
  265.     case INDIRECT    : putChr('^');
  266.               put(ALWAYS,snd(e));
  267.               break;
  268.  
  269.     default     : /*internal("put");*/
  270.               putChr('$');
  271.               putInt(e);
  272.               break;
  273.     }
  274.     putDepth--;
  275. }
  276.  
  277. static Void local putComp(e,qs)        /* print comprehension           */
  278. Cell e;
  279. List qs; {
  280.     putStr("[ ");
  281.     put(NEVER,e);
  282.     if (nonNull(qs)) {
  283.     putStr(" | ");
  284.     putQual(hd(qs));
  285.     while (nonNull(qs=tl(qs))) {
  286.         putStr(", ");
  287.         putQual(hd(qs));
  288.     }
  289.     }
  290.     putStr(" ]");
  291. }
  292.  
  293. static Void local putQual(q)        /* print list comp qualifier       */
  294. Cell q; {
  295.     switch (whatIs(q)) {
  296.     case BOOLQUAL : put(NEVER,snd(q));
  297.             return;
  298.  
  299.     case QWHERE   : putStr("let {...}");
  300.             return;
  301.  
  302.     case FROMQUAL : put(ALWAYS,fst(snd(q)));
  303.             putStr("<-");
  304.             put(NEVER,snd(snd(q)));
  305.             return;
  306.     }
  307. }
  308.  
  309. static Bool local isDictVal(e)        /* Look for dictionary value       */
  310. Cell e; {
  311.     switch (whatIs(e)) {
  312.     case AP          : return isSelect(fun(e));
  313.     case DICTCELL :
  314.     case DICTVAR  : return TRUE;
  315.     }
  316.     return FALSE;
  317. }
  318.  
  319. static Cell local maySkipDict(e)    /* descend function application,   */
  320. Cell e; {                /* ignoring dict aps           */
  321.     while (isAp(e) && isDictVal(arg(e)))
  322.     e = fun(e);
  323.     return e;
  324. }
  325.  
  326. static Void local putAp(d,e)        /* print application (args>=1)       */
  327. Int  d;
  328. Cell e; {
  329.     Cell   h;
  330.     Text   t;
  331.     Syntax sy;
  332.     Int    args = 0;
  333.  
  334.     for (h=e; isAp(h); h=fun(h))    /* find head of expression, looking*/
  335.     if (!isDictVal(arg(h)))        /* for dictionary arguments       */
  336.         args++;
  337.  
  338.     if (args==0) {            /* Special case when *all* args       */
  339.     put(d,h);            /* are dictionary values       */
  340.     return;
  341.     }
  342.  
  343.     switch (whatIs(h)) {
  344. #if NPLUSK
  345.     case ADDPAT    : if (args==1)
  346.                   putInfix(d,textPlus,syntaxOf(textPlus),
  347.                      arg(e),mkInt(intValOf(fun(e))));
  348.               else
  349.                   putStr("ADDPAT");
  350.               return;
  351. #endif
  352.  
  353.     case TUPLE    : OPEN(args>tupleOf(h) && d>=FUN_PREC);
  354.               putTuple(tupleOf(h),e);
  355.               CLOSE(args>tupleOf(h) && d>=FUN_PREC);
  356.               return;
  357.  
  358.     case NAME    : if (args==1 &&
  359.                   ((h==nameFromInt     && isInt(arg(e)))    ||
  360.                    (h==nameFromInteger && isBignum(arg(e))) ||
  361.                    (h==nameFromDouble  && isFloat(arg(e))))) {
  362.                   put(d,arg(e));
  363.                   return;
  364.               }
  365.               sy = syntaxOf(t = name(h).text);
  366.               break;
  367.  
  368.     case VARIDCELL    :
  369.     case VAROPCELL    :
  370.     case DICTVAR    :
  371.     case CONIDCELL    :
  372.     case CONOPCELL    : sy = syntaxOf(t = textOf(h));
  373.               break;
  374.  
  375.     default     : sy = APPLIC;
  376.               break;
  377.     }
  378.  
  379.     e = maySkipDict(e);
  380.  
  381.     if (sy==APPLIC) {                   /* print simple application       */
  382.     OPEN(d>=FUN_PREC);
  383.     putSimpleAp(e);
  384.     CLOSE(d>=FUN_PREC);
  385.     return;
  386.     }
  387.     else if (args==1) {                /* print section of the form (e+)  */
  388.     putChr('(');
  389.     put(FUN_PREC-1,arg(e));
  390.     putChr(' ');
  391.     unlexOp(t);
  392.     putChr(')');
  393.     }
  394.     else if (args==2)               /* infix expr of the form e1 + e2   */
  395.     putInfix(d,t,sy,arg(maySkipDict(fun(e))),arg(e));
  396.     else {                   /* o/w (e1 + e2) e3 ... en   (n>=3) */
  397.     OPEN(d>=FUN_PREC);
  398.     putOverInfix(args,t,sy,e);
  399.     CLOSE(d>=FUN_PREC);
  400.     }
  401. }
  402.  
  403. static Void local putOverInfix(args,t,sy,e)
  404. Int    args;                   /* infix applied to >= 3 arguments  */
  405. Text   t;
  406. Syntax sy;
  407. Cell   e; {
  408.     if (args>2) {
  409.     putOverInfix(args-1,t,sy,maySkipDict(fun(e)));
  410.     putChr(' ');
  411.     put(FUN_PREC,arg(e));
  412.     }
  413.     else
  414.     putInfix(ALWAYS,t,sy,arg(maySkipDict(fun(e))),arg(e));
  415. }
  416.  
  417. static Void local putInfix(d,t,sy,e,f)  /* print infix expression       */
  418. Int    d;
  419. Text   t;                /* Infix operator symbol         */
  420. Syntax sy;                /* with name t, syntax s        */
  421. Cell   e, f; {                /* Left and right operands       */
  422.     Syntax a = assocOf(sy);
  423.     Int    p = precOf(sy);
  424.  
  425.     OPEN(d>p);
  426.     put((a==LEFT_ASS ? p : 1+p), e);
  427.     putChr(' ');
  428.     unlexOp(t);
  429.     putChr(' ');
  430.     put((a==RIGHT_ASS ? p : 1+p), f);
  431.     CLOSE(d>p);
  432. }
  433.  
  434. static Void local putSimpleAp(e)       /* print application e0 e1 ... en   */
  435. Cell e; {
  436.     if (isAp(e)) {
  437.     putSimpleAp(maySkipDict(fun(e)));
  438.     putChr(' ');
  439.     put(FUN_PREC,arg(e));
  440.     }
  441.     else
  442.     put(FUN_PREC,e);
  443. }
  444.  
  445. static Void local putTuple(ts,e)    /* Print tuple expression, allowing*/
  446. Int  ts;                /* for possibility of either too   */
  447. Cell e; {                /* few or too many args to constr  */
  448.     Int i;
  449.     putChr('(');
  450.     if ((i=unusedTups(ts,e))>0) {
  451.     while (--i>0)
  452.         putChr(',');
  453.         putChr(')');
  454.     }
  455. }
  456.  
  457. static Int local unusedTups(ts,e)    /* print first part of tuple expr  */
  458. Int  ts;                /* returning number of constructor */
  459. Cell e; {                /* args not yet printed ...       */
  460.     if (isAp(e)) {
  461.     if ((ts=unusedTups(ts,fun(e))-1)>=0) {
  462.         put(NEVER,arg(e));
  463.         putChr(ts>0?',':')');
  464.     }
  465.     else {
  466.         putChr(' ');
  467.         put(FUN_PREC,arg(e));
  468.     }
  469.     }
  470.     return ts;
  471. }
  472.  
  473. static Void local unlexVar(t)           /* print text as a variable name    */
  474. Text t; {                   /* operator symbols must be enclosed*/
  475.     String s = textToStr(t);           /* in parentheses... except [] ...  */
  476.  
  477.     if ((isascii(s[0]) && isalpha(s[0])) || s[0]=='_' || strcmp(s,"[]")==0)
  478.     putStr(s);
  479.     else {
  480.     putChr('(');
  481.     putStr(s);
  482.     putChr(')');
  483.     }
  484. }
  485.  
  486. static Void local unlexOp(t)           /* print text as operator name       */
  487. Text t; {                   /* alpha numeric symbols must be    */
  488.     String s = textToStr(t);           /* enclosed by backquotes       */
  489.  
  490.     if (isascii(s[0]) && isalpha(s[0])) {
  491.     putChr('`');
  492.     putStr(s);
  493.     putChr('`');
  494.     }
  495.     else
  496.     putStr(s);
  497. }
  498.  
  499. static Void local unlexCharConst(c)
  500. Cell c; {
  501.     putChr('\'');
  502.     putStr(unlexChar(c,'\''));
  503.     putChr('\'');
  504. }
  505.  
  506. static Void local unlexStrConst(t)
  507. Text t; {
  508.     String s            = textToStr(t);
  509.     static Char SO      = 14;        /* ASCII code for '\SO'           */
  510.     Bool   lastWasSO    = FALSE;
  511.     Bool   lastWasDigit = FALSE;
  512.     Bool   lastWasEsc   = FALSE;
  513.  
  514.     putChr('\"');
  515.     for (; *s; s++) {
  516.     String ch = unlexChar(*s,'\"');
  517.     Char   c  = ' ';
  518.  
  519.     if ((lastWasSO && *ch=='H') ||
  520.         (lastWasEsc && lastWasDigit && isascii(*ch) && isdigit(*ch)))
  521.         putStr("\\&");
  522.  
  523.     lastWasEsc   = (*ch=='\\');
  524.     lastWasSO    = (*s==SO);
  525.         for (; *ch; c = *ch++)
  526.         putChr(*ch);
  527.         lastWasDigit = (isascii(c) && isdigit(c));
  528.     }
  529.     putChr('\"');
  530. }
  531.  
  532. /* --------------------------------------------------------------------------
  533.  * Print type expression:
  534.  * ------------------------------------------------------------------------*/
  535.  
  536. static Void local putSigType(t)        /* print (possibly) generic type   */
  537. Cell t; {
  538.     if (isPolyType(t))            /* skip (forall _) part (if any)   */
  539.         t = monoTypeOf(t);
  540.  
  541.     if (whatIs(t)==QUAL) {        /* Handle qualified types          */
  542.         putContext(fst(snd(t)));
  543.         putStr(" => ");
  544.         t = snd(snd(t));
  545.     }
  546.  
  547.     putType(t,NEVER);            /* Finally, print rest of type ... */
  548. }
  549.  
  550. static Void local putContext(qs)    /* print context list           */
  551. List qs; {
  552.     if (isNull(qs))
  553.     putStr("()");
  554.     else {
  555.     Int nq = length(qs);
  556.  
  557.     if (nq!=1) putChr('(');
  558.     putPred(hd(qs));
  559.     while (nonNull(qs=tl(qs))) {
  560.         putStr(", ");
  561.         putPred(hd(qs));
  562.     }
  563.     if (nq!=1) putChr(')');
  564.     }
  565. }
  566.  
  567. static Void local putPred(pi)        /* Output predicate           */
  568. Cell pi; {
  569.     if (isAp(pi)) {
  570.     putPred(fun(pi));
  571.     putChr(' ');
  572.     putType(arg(pi),ALWAYS);
  573.     }
  574.     else if (isClass(pi))
  575.     putStr(textToStr(class(pi).text));
  576.     else if (isCon(pi))
  577.     putStr(textToStr(textOf(pi)));
  578.     else
  579.     putStr("<unknownPredicate>");
  580. }
  581.  
  582. static Void local putType(t,prec)    /* print nongeneric type expression*/
  583. Cell t;
  584. Int  prec; {
  585.     switch(whatIs(t)) {
  586.     case UNIT    : putStr("()");
  587.                break;
  588.  
  589.     case LIST    : putStr("[]");
  590.                break;
  591.  
  592.     case ARROW   : putStr("(->)");
  593.                break;
  594.  
  595.     case TYCON   : putStr(textToStr(tycon(t).text));
  596.                break;
  597.  
  598.     case TUPLE   : {   Int n = tupleOf(t);
  599.                putChr('(');
  600.                while (--n > 0)
  601.                    putChr(',');
  602.                putChr(')');
  603.                }
  604.                break;
  605.  
  606.     case OFFSET  : putTyVar(offsetOf(t));
  607.                break;
  608.  
  609.     case INTCELL : putChr('_');
  610.                putInt(intOf(t));
  611.                break;
  612.  
  613.     case AP         : {   Cell typeHead = getHead(t);
  614.                Bool brackets = (argCount!=0 && prec>=ALWAYS);
  615.  
  616.                switch (whatIs(typeHead)) {
  617.                    case LIST  : if (argCount==1) {
  618.                         putChr('[');
  619.                         putType(arg(t),NEVER);
  620.                         putChr(']');
  621.                         return;
  622.                         }
  623.                         break;
  624.  
  625.                    case ARROW : if (argCount==2) {
  626.                         OPEN(prec>=ARROW_PREC);
  627.                         putType(arg(fun(t)),ARROW_PREC);
  628.                         putStr(" -> ");
  629.                         putType(arg(t),NEVER);
  630.                         CLOSE(prec>=ARROW_PREC);
  631.                         return;
  632.                         }
  633.                         else if (argCount==1) {
  634.                         putChr('(');
  635.                         putType(arg(t),ARROW_PREC);
  636.                         putStr("->)");
  637.                         return;
  638.                         }
  639.                         break;
  640.  
  641.                    case TUPLE : if (argCount==tupleOf(typeHead)) {
  642.                         putChr('(');
  643.                         putTupleType(t);
  644.                         putChr(')');
  645.                         return;
  646.                         }
  647.                         break;
  648.  
  649.                    case TYCON :
  650. #if IO_MONAD
  651.                         if (typeHead==typeST &&
  652.                             argCount==1      &&
  653.                         snd(t)==typeWorld)
  654.                         brackets = FALSE;
  655. #endif
  656.                         break;
  657.                }
  658.                OPEN(brackets);
  659.                putApType(t);
  660.                CLOSE(brackets);
  661.                }
  662.                break;
  663.  
  664.     default      : putStr("(bad type)");
  665.     }
  666. }
  667.  
  668. static Void local putTyVar(n)        /* print type variable           */
  669. Int n; {
  670.     static String alphabet        /* for the benefit of EBCDIC :-)   */
  671.         ="abcdefghijklmnopqrstuvwxyz";
  672.     putChr(alphabet[n%26]);
  673.     if (n /= 26)            /* just in case there are > 26 vars*/
  674.     putInt(n);
  675. }
  676.  
  677. static Bool local putTupleType(e)    /* print tuple of types, returning */
  678. Cell e; {                /* TRUE if something was printed,  */
  679.     if (isAp(e)) {            /* FALSE otherwise; used to control*/
  680.     if (putTupleType(fun(e)))    /* printing of intermed. commas       */
  681.         putChr(',');
  682.     putType(arg(e),NEVER);
  683.     return TRUE;
  684.     }
  685.     return FALSE;
  686. }
  687.  
  688. static Void local putApType(t)        /* print type application       */
  689. Cell t; {
  690.     if (isAp(t)) {
  691. #if IO_MONAD
  692.     if (fun(t)==typeST && arg(t)==typeWorld)
  693.         putType(typeIO,ALWAYS);
  694.     else
  695. #endif
  696.     {
  697.         putApType(fun(t));
  698.         putChr(' ');
  699.         putType(arg(t),ALWAYS);
  700.     }
  701.     }
  702.     else
  703.     putType(t,ALWAYS);
  704. }
  705.  
  706. /* --------------------------------------------------------------------------
  707.  * Print kind expression:
  708.  * ------------------------------------------------------------------------*/
  709.  
  710. static Void local putKind(k)        /* print kind expression       */
  711. Kind k; {
  712.     switch (whatIs(k)) {
  713.     case AP         : if (isAp(fst(k))) {
  714.                putChr('(');
  715.                putKind(fst(k));
  716.                putChr(')');
  717.                }
  718.                else
  719.                putKind(fst(k));
  720.                putStr(" -> ");
  721.                putKind(snd(k));
  722.                break;
  723.  
  724.     case STAR    : putChr('*');
  725.                break;
  726.  
  727.     case OFFSET  : putTyVar(offsetOf(k));
  728.                break;
  729.  
  730.     case INTCELL : putChr('_');
  731.                putInt(intOf(k));
  732.                break;
  733.  
  734.     default      : putStr("(bad kind)");
  735.     }
  736. }
  737.  
  738. /* --------------------------------------------------------------------------
  739.  * Main drivers:
  740.  * ------------------------------------------------------------------------*/
  741.  
  742. Void printExp(fp,e)            /* print expr on specified stream  */
  743. FILE *fp;
  744. Cell e; {
  745.     outputStream = fp;
  746.     putDepth     = 0;
  747.     put(NEVER,e);
  748. }
  749.  
  750. Void printType(fp,t)            /* print type on specified stream  */
  751. FILE *fp;
  752. Cell t; {
  753.     outputStream = fp;
  754.     putSigType(t);
  755. }
  756.  
  757. Void printContext(fp,qs)        /* print context on spec. stream   */
  758. FILE *fp;
  759. List qs; {
  760.     outputStream = fp;
  761.     putContext(qs);
  762. }
  763.  
  764. Void printPred(fp,pi)            /* print predicate pi on stream    */
  765. FILE *fp;
  766. Cell pi; {
  767.     outputStream = fp;
  768.     putPred(pi);
  769. }
  770.  
  771. Void printKind(fp,k)            /* print kind k on stream       */
  772. FILE *fp;
  773. Kind k; {
  774.     outputStream = fp;
  775.     putKind(k);
  776. }
  777.  
  778. /*-------------------------------------------------------------------------*/
  779.