-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Unparse expressions and types - for use in error messages, type checker
* and for debugging.
*
- * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
- * All rights reserved. See NOTICE for details and conditions of use etc...
- * Hugs version 1.4, December 1997
+ * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
+ * Yale Haskell Group, and the Oregon Graduate Institute of Science and
+ * Technology, 1994-1999, All rights reserved. It is distributed as
+ * free software under the license in the file "License", which is
+ * included in the distribution.
*
* $RCSfile: output.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:24 $
+ * $Revision: 1.17 $
+ * $Date: 2000/03/23 14:54:21 $
* ------------------------------------------------------------------------*/
-#include "prelude.h"
+#include "hugsbasictypes.h"
#include "storage.h"
#include "connect.h"
-#include "input.h" /* for textPlus */
#include "errors.h"
-#include "link.h"
#include <ctype.h>
#define DEPTH_LIMIT 15
* Local function prototypes:
* ------------------------------------------------------------------------*/
-static Void local putChr Args((Int));
-static Void local putStr Args((String));
-static Void local putInt Args((Int));
-
-static Void local put Args((Int,Cell));
-static Void local putFlds Args((Cell,List));
-static Void local putComp Args((Cell,List));
-static Void local putQual Args((Cell));
-static Bool local isDictVal Args((Cell));
-static Cell local maySkipDict Args((Cell));
-static Void local putAp Args((Int,Cell));
-static Void local putOverInfix Args((Int,Text,Syntax,Cell));
-static Void local putInfix Args((Int,Text,Syntax,Cell,Cell));
-static Void local putSimpleAp Args((Cell,Int));
-static Void local putTuple Args((Int,Cell));
-static Int local unusedTups Args((Int,Cell));
-static Void local unlexVar Args((Text));
-static Void local unlexOp Args((Text));
-static Void local unlexCharConst Args((Cell));
-static Void local unlexStrConst Args((Text));
-
-static Void local putSigType Args((Cell));
-static Void local putContext Args((List,Int));
-static Void local putPred Args((Cell,Int));
-static Void local putType Args((Cell,Int,Int));
-static Void local putTyVar Args((Int));
-static Bool local putTupleType Args((Cell,Int));
-static Void local putApType Args((Type,Int,Int));
-
-static Void local putKind Args((Kind));
-static Void local putKinds Args((Kinds));
+static Void local put ( Int,Cell );
+static Void local putFlds ( Cell,List );
+static Void local putComp ( Cell,List );
+static Void local putQual ( Cell );
+static Bool local isDictVal ( Cell );
+static Cell local maySkipDict ( Cell );
+static Void local putAp ( Int,Cell );
+static Void local putOverInfix ( Int,Text,Syntax,Cell );
+static Void local putInfix ( Int,Text,Syntax,Cell,Cell );
+static Void local putSimpleAp ( Cell,Int );
+static Void local putTuple ( Int,Cell );
+static Int local unusedTups ( Int,Cell );
+static Void local unlexOp ( Text );
+
+static Void local putSigType ( Cell );
+static Void local putContext ( List,List,Int );
+static Void local putPred ( Cell,Int );
+static Void local putType ( Cell,Int,Int );
+static Void local putTyVar ( Int );
+static Bool local putTupleType ( Cell,Int );
+static Void local putApType ( Type,Int,Int );
+
+static Void local putKind ( Kind );
+static Void local putKinds ( Kinds );
+
/* --------------------------------------------------------------------------
* Basic output routines:
* ------------------------------------------------------------------------*/
-static FILE *outputStream; /* current output stream */
+FILE *outputStream; /* current output stream */
+Int outColumn = 0; /* current output column number */
#define OPEN(b) if (b) putChr('(');
#define CLOSE(b) if (b) putChr(')');
-static Void local putChr(c) /* print single character */
+Void putChr(c) /* print single character */
Int c; {
Putc(c,outputStream);
+ outColumn++;
}
-static Void local putStr(s) /* print string */
+Void putStr(s) /* print string */
String s; {
for (; *s; s++) {
Putc(*s,outputStream);
+ outColumn++;
}
}
-static Void local putInt(n) /* print integer */
+Void putInt(n) /* print integer */
Int n; {
static char intBuf[16];
sprintf(intBuf,"%d",n);
putStr(intBuf);
}
+Void putPtr(p) /* print pointer */
+Ptr p; {
+ static char intBuf[16];
+ sprintf(intBuf,"%p",p);
+ putStr(intBuf);
+}
+
/* --------------------------------------------------------------------------
* Precedence values (See Haskell 1.3 report, p.12):
* ------------------------------------------------------------------------*/
case CONOPCELL : unlexVar(textOf(e));
break;
+#if IPARAM
+ case IPVAR : putChr('?');
+ unlexVar(textOf(e));
+ break;
+
+ case WITHEXP : OPEN(d>WHERE_PREC);
+ putStr("dlet {...} in ");
+ put(WHERE_PREC+1,fst(snd(e)));
+ CLOSE(d>WHERE_PREC);
+ break;
+#endif
+
#if TREX
case RECSEL : putChr('#');
unlexVar(extText(snd(e)));
case COMP : putComp(fst(snd(e)),snd(snd(e)));
break;
- case CHARCELL : unlexCharConst(charOf(e));
+ case MONADCOMP : putComp(fst(snd(snd(e))),snd(snd(snd(e))));
break;
- case INTCELL : putInt(intOf(e));
+ case CHARCELL : unlexCharConst(charOf(e));
break;
- case BIGCELL : putStr(bignumToString(e));
+ case INTCELL : { Int i = intOf(e);
+ if (i<0 && d>=UMINUS_PREC) putChr('(');
+ putInt(i);
+ if (i<0 && d>=UMINUS_PREC) putChr(')');
+ }
break;
- case FLOATCELL : putStr(floatToString(e));
+ case FLOATCELL : { Float f = floatOf(e);
+ if (f<0 && d>=UMINUS_PREC) putChr('(');
+ putStr(floatToString(e));
+ if (f<0 && d>=UMINUS_PREC) putChr(')');
+ }
break;
case STRCELL : unlexStrConst(textOf(e));
break;
case LETREC : OPEN(d>WHERE_PREC);
-#if DEBUG_CODE
+#if 0
putStr("let {");
put(NEVER,fst(snd(e)));
putStr("} in ");
case LAMBDA : xs = fst(snd(e));
if (whatIs(xs)==BIGLAM)
- xs = snd(snd(e));
+ xs = snd(snd(xs));
while (nonNull(xs) && isDictVal(hd(xs)))
xs = tl(xs);
if (isNull(xs)) {
case CASE : putStr("case ");
put(NEVER,fst(snd(e)));
-#if DEBUG_CODE
+#if 0
putStr(" of {");
put(NEVER,snd(snd(e)));
putChr('}');
putDepth--;
}
-static Void local putFlds(exp,fs) /* Output exp using labelled fields*/
+static Void local putFlds(exp,fs) /* Output exp using labelled fields*/
Cell exp;
List fs; {
put(ALWAYS,exp);
isVar(e) ? textOf(e) : inventText();
put(NEVER,f);
- if (s!=t) {
+ if (haskell98 || s!=t) {
putStr(" = ");
put(NEVER,e);
}
static Bool local isDictVal(e) /* Look for dictionary value */
Cell e; {
-#if !DEBUG_CODE
+#if 0 /* was !DEBUG_CODE -- is it necessary? */
Cell h = getHead(e);
switch (whatIs(h)) {
- case DICTVAR : return TRUE;
- case NAME : return isDfun(h);
+ case DICTVAR : return TRUE;
+ case NAME : return isDfun(h);
}
#endif
return FALSE;
Int d;
Cell e; {
Cell h;
- Text t;
+ Text t = 0; /* bogus init to keep gcc -O happy */
Syntax sy;
Int args = 0;
}
switch (whatIs(h)) {
-#if NPLUSK
case ADDPAT : if (args==1)
- putInfix(d,textPlus,syntaxOf(textPlus),
- arg(e),snd(h));
+ putInfix(d,textPlus,syntaxOf(namePlus),
+ arg(e),mkInt(intValOf(fun(e))));
else
putStr("ADDPAT");
return;
-#endif
case TUPLE : OPEN(args>tupleOf(h) && d>=FUN_PREC);
putTuple(tupleOf(h),e);
case NAME : if (args==1 &&
((h==nameFromInt && isInt(arg(e))) ||
- (h==nameFromInteger && isBignum(arg(e))) ||
(h==nameFromDouble && isFloat(arg(e))))) {
put(d,arg(e));
return;
}
- sy = syntaxOf(t = name(h).text);
+ t = name(h).text;
+ sy = syntaxOf(h);
break;
case VARIDCELL :
case VAROPCELL :
case DICTVAR :
case CONIDCELL :
- case CONOPCELL : sy = syntaxOf(t = textOf(h));
+ case CONOPCELL : sy = defaultSyntax(t = textOf(h));
break;
#if TREX
return ts;
}
-static Void local unlexVar(t) /* print text as a variable name */
-Text t; { /* operator symbols must be enclosed*/
- String s = textToStr(t); /* in parentheses... except [] ... */
-
- if ((isascii(s[0]) && isalpha(s[0])) || s[0]=='_' || s[0]=='[' || s[0]=='(')
+Void unlexVarStr(s)
+String s; {
+ if ((isascii((int)(s[0])) && isalpha((int)(s[0])))
+ || s[0]=='_' || s[0]=='[' || s[0]=='('
+ || s[0]=='$'
+ || (s[0]==':' && s[1]=='D')
+ )
putStr(s);
else {
putChr('(');
}
}
+Void unlexVar(t) /* print text as a variable name */
+Text t; { /* operator symbols must be enclosed*/
+ unlexVarStr(textToStr(t)); /* in parentheses... except [] ... */
+}
+
static Void local unlexOp(t) /* print text as operator name */
Text t; { /* alpha numeric symbols must be */
String s = textToStr(t); /* enclosed by backquotes */
- if (isascii(s[0]) && isalpha(s[0])) {
+ if (isascii((int)(s[0])) && isalpha((int)(s[0]))) {
putChr('`');
putStr(s);
putChr('`');
putStr(s);
}
-static Void local unlexCharConst(c)
+Void unlexCharConst(c)
Cell c; {
putChr('\'');
putStr(unlexChar(c,'\''));
putChr('\'');
}
-static Void local unlexStrConst(t)
+Void unlexStrConst(t)
Text t; {
String s = textToStr(t);
static Char SO = 14; /* ASCII code for '\SO' */
Char c = ' ';
if ((lastWasSO && *ch=='H') ||
- (lastWasEsc && lastWasDigit && isascii(*ch) && isdigit(*ch)))
+ (lastWasEsc && lastWasDigit
+ && isascii((int)(*ch)) && isdigit((int)(*ch))))
putStr("\\&");
lastWasEsc = (*ch=='\\');
putType(t,NEVER,fr); /* Finally, print rest of type ... */
}
-static Void local putContext(qs,fr) /* print context list */
+static Void local putContext(ps,qs,fr) /* print context list */
+List ps;
List qs;
Int fr; {
- if (isNull(qs))
- putStr("()");
- else {
- Int nq = length(qs);
- if (nq!=1) putChr('(');
+ Int len = length(ps) + length(qs);
+ Int c = len;
+#if IPARAM
+ Bool useParens = len!=1 || isIP(fun(hd(ps)));
+#else
+ Bool useParens = len!=1;
+#endif
+ if (useParens)
+ putChr('(');
+ for (; nonNull(ps); ps=tl(ps)) {
+ putPred(hd(ps),fr);
+ if (--c > 0) {
+ putStr(", ");
+ }
+ }
+ for (; nonNull(qs); qs=tl(qs)) {
putPred(hd(qs),fr);
- while (nonNull(qs=tl(qs))) {
+ if (--c > 0) {
putStr(", ");
- putPred(hd(qs),fr);
}
- if (nq!=1) putChr(')');
}
+ if (useParens)
+ putChr(')');
}
static Void local putPred(pi,fr) /* Output predicate */
return;
}
#endif
+#if IPARAM
+ if (whatIs(fun(pi)) == IPCELL) {
+ putChr('?');
+ putPred(fun(pi),fr);
+ putStr(" :: ");
+ putType(arg(pi),NEVER,fr);
+ return;
+ }
+#endif
putPred(fun(pi),fr);
putChr(' ');
putType(arg(pi),ALWAYS,fr);
putStr(textToStr(cclass(pi).text));
else if (isCon(pi))
putStr(textToStr(textOf(pi)));
+#if IPARAM
+ else if (whatIs(pi) == IPCELL)
+ unlexVar(textOf(pi));
+#endif
else
putStr("<unknownPredicate>");
}
Int prec;
Int fr; {
switch(whatIs(t)) {
- case TYCON : putStr(textToStr(tycon(t).text));
- break;
+ case TYCON : putStr(textToStr(tycon(t).text));
+ break;
- case TUPLE : { Int n = tupleOf(t);
- putChr('(');
- while (--n > 0)
- putChr(',');
- putChr(')');
- }
- break;
+ case TUPLE : { Int n = tupleOf(t);
+ putChr('(');
+ while (--n > 0)
+ putChr(',');
+ putChr(')');
+ }
+ break;
case POLYTYPE : { Kinds ks = polySigOf(t);
OPEN(prec>=ARROW_PREC);
for (; isAp(ks); ks=tl(ks)) {
putTyVar(fr++);
if (isAp(tl(ks)))
- putChr(',');
+ putChr(' ');
}
putStr(". ");
putType(monotypeOf(t),NEVER,fr);
}
break;
+ case CDICTS :
case QUAL : OPEN(prec>=ARROW_PREC);
- putContext(fst(snd(t)),fr);
- putStr(" => ");
- putType(snd(snd(t)),NEVER,fr);
+ if (whatIs(snd(snd(t)))==CDICTS) {
+ putContext(fst(snd(t)),fst(snd(snd(snd(t)))),fr);
+ putStr(" => ");
+ putType(snd(snd(snd(snd(t)))),NEVER,fr);
+ } else {
+ putContext(fst(snd(t)),NIL,fr);
+ putStr(" => ");
+ putType(snd(snd(t)),NEVER,fr);
+ }
CLOSE(prec>=ARROW_PREC);
break;
case RANK2 : putType(snd(snd(t)),prec,fr);
break;
- case OFFSET : putTyVar(offsetOf(t));
- break;
+ case OFFSET : putTyVar(offsetOf(t));
+ break;
case VARIDCELL :
case VAROPCELL : putChr('_');
unlexVar(textOf(t));
break;
- case INTCELL : putChr('_');
- putInt(intOf(t));
- break;
+ case INTCELL : putChr('_');
+ putInt(intOf(t));
+ break;
-/* #ifdef DEBUG_TYPES */
- case STAR : putChr('*');
- break;
-/* #endif */
-
- case AP : { Cell typeHead = getHead(t);
- Bool brackets = (argCount!=0 && prec>=ALWAYS);
- Int args = argCount;
-
- if (typeHead==typeList) {
- if (argCount==1) {
- putChr('[');
- putType(arg(t),NEVER,fr);
- putChr(']');
- return;
- }
- }
- else if (typeHead==typeArrow) {
- if (argCount==2) {
- OPEN(prec>=ARROW_PREC);
- putType(arg(fun(t)),ARROW_PREC,fr);
- putStr(" -> ");
- putType(arg(t),NEVER,fr);
- CLOSE(prec>=ARROW_PREC);
- return;
- }
- else if (argCount==1) {
- putChr('(');
- putType(arg(t),ARROW_PREC,fr);
- putStr("->)");
- return;
- }
- }
- else if (isTuple(typeHead)) {
- if (argCount==tupleOf(typeHead)) {
- putChr('(');
- putTupleType(t,fr);
- putChr(')');
- return;
- }
- }
+ case AP : { Cell typeHead = getHead(t);
+ Bool brackets = (argCount!=0 && prec>=ALWAYS);
+ Int args = argCount;
+
+ if (typeHead==typeList) {
+ if (argCount==1) {
+ putChr('[');
+ putType(arg(t),NEVER,fr);
+ putChr(']');
+ return;
+ }
+ }
+ else if (typeHead==typeArrow) {
+ if (argCount==2) {
+ OPEN(prec>=ARROW_PREC);
+ putType(arg(fun(t)),ARROW_PREC,fr);
+ putStr(" -> ");
+ putType(arg(t),NEVER,fr);
+ CLOSE(prec>=ARROW_PREC);
+ return;
+ }
+#if 0
+ else if (argCount==1) {
+ putChr('(');
+ putType(arg(t),ARROW_PREC,fr);
+ putStr("->)");
+ return;
+ }
+#endif
+ }
+ else if (isTuple(typeHead)) {
+ if (argCount==tupleOf(typeHead)) {
+ putChr('(');
+ putTupleType(t,fr);
+ putChr(')');
+ return;
+ }
+ }
#if TREX
- else if (isExt(typeHead)) {
+ else if (isExt(typeHead)) {
if (args==2) {
String punc = "(";
do {
putStr(punc);
punc = ", ";
putStr(textToStr(extText(typeHead)));
- putStr("::");
+ putStr(" :: ");
putType(extField(t),NEVER,fr);
t = extRow(t);
typeHead = getHead(t);
args-=2;
}
#endif
- OPEN(brackets);
- putApType(t,args,fr);
- CLOSE(brackets);
- }
- break;
+ OPEN(brackets);
+ putApType(t,args,fr);
+ CLOSE(brackets);
+ }
+ break;
- default : putStr("(bad type)");
+ default : putStr("(bad type)");
}
}
* Main drivers:
* ------------------------------------------------------------------------*/
+FILE *mystdout ( Void ) {
+ /* We use this from the gdb command line when debugging */
+ return stdout;
+}
+
Void printExp(fp,e) /* print expr on specified stream */
FILE *fp;
Cell e; {
FILE *fp;
List qs; {
outputStream = fp;
- putContext(qs,0);
+ putContext(qs,NIL,0);
}
Void printPred(fp,pi) /* print predicate pi on stream */
}
Void printKinds(fp,ks) /* print list of kinds on stream */
-FILE *fp;
+FILE *fp;
Kinds ks; {
outputStream = fp;
putKinds(ks);
}
+Void printFD(fp,fd) /* print functional dependency */
+FILE* fp;
+Pair fd; {
+ List us;
+ outputStream = fp;
+ for (us=fst(fd); nonNull(us); us=tl(us)) {
+ putTyVar(offsetOf(hd(us)));
+ if (nonNull(tl(us))) {
+ putChr(' ');
+ }
+ }
+ putStr(" -> ");
+ for (us=snd(fd); nonNull(us); us=tl(us)) {
+ putTyVar(offsetOf(hd(us)));
+ if (nonNull(tl(us))) {
+ putChr(' ');
+ }
+ }
+}
+
/*-------------------------------------------------------------------------*/
projects / ghc-hetmet.git / blobdiff