/* --------------------------------------------------------------------------
* printer.c: Copyright (c) Mark P Jones 1991-1998. All rights reserved.
* See NOTICE for details and conditions of use etc...
* Hugs version 1.3b, January 1998
*
* Builtin printer, used as an alternative to overloaded "show", and also
* used for certain primitive types.
* ------------------------------------------------------------------------*/
static Void local printer Args((Name,Int));
static Void local outVar Args((Text));
static Void local outOp Args((Text));
static Void local outStr Args((String));
static Void local outPr Args((Name,Int,Cell));
static Void local outLPr Args((Name,Cell));
static Void local outBadRedex Args((Cell));
static Cell local printDBadRedex Args((Cell,Cell));
static Cell local printBadRedex Args((Cell,Cell));
static Void local outInst Args((Inst));
static Name nameLPrint, nameNLPrint; /* list printing primitives */
static Name nameSPrint, nameNSPrint; /* string printing primitives */
static Cell out; /* GC'd var used by printer code */
#define outCh(c) out = ap(consChar(c),out)
#define outSCh(c) outStr(unlexChar(c,'\"'))
#define updOutRoot(ss) out = revOnto(out,ss); \
updapRoot(fst(out),snd(out)); \
out = NIL;
primFun(primPrint) { /* Evaluate and print term */
Cell temp; /* :: Int->Expr->[Char]->[Char] */
Int d;
eval(primArg(3));
d = whnfInt;
temp = evalWithNoError(primArg(2));
out = NIL;
if (nonNull(temp)) {
push(temp);
outBadRedex(top());
}
else
printer(namePrint,d);
updOutRoot(primArg(1));
}
primFun(primBPrint) { /* Eval and print value of basic */
Int d; /* type -- Int, Integer, Float, or */
eval(primArg(3)); /* Double -- as a string. */
d = whnfInt;
eval(primArg(2)); /* Differs from primPrint only in */
out = NIL; /* its use of weaker error handling*/
printer(namePrint,d); /* to make showsPrec strict. */
updOutRoot(primArg(1));
}
primFun(primNPrint) { /* print term without evaluation */
Int d; /* :: Int->Expr->[Char]->[Char] */
eval(primArg(3));
d = whnfInt;
unwind(primArg(2));
out = NIL;
printer(nameNPrint,d);
updOutRoot(primArg(1));
}
static Void local printer(pr,d) /* Main part: primPrint/primNPrint */
Name pr; /* printer to use on components */
Int d; { /* precedence level */
Int used = 0; /* Output, in reverse, to "out" */
switch(whatIs(whnfHead)) {
case NAME : { Syntax sy = syntaxOf(name(whnfHead).text);
if (!isCfun(whnfHead) ||
name(whnfHead).arity>whnfArgs)
pr = nameNPrint;
if (whnfHead==nameCons && whnfArgs==2) {/*list */
StackPtr ksp = sp;
used = 2;
if (pr==namePrint) {
Cell temp = evalWithNoError(top());
if (nonNull(temp)) {
push(temp);
outCh('[');
outBadRedex(top());
sp = ksp;
outLPr(nameLPrint,pushed(1));
}
else if (isChar(whnfHead) && whnfArgs==0) {
outCh('"');
outSCh(charOf(whnfHead));
outLPr(nameSPrint,pushed(1));
}
else {
sp = ksp;
outCh('[');
outPr(namePrint,MIN_PREC,top());
outLPr(nameLPrint,pushed(1));
}
}
else {
unwind(top());
if (isChar(whnfHead) && whnfArgs==0) {
outCh('"');
outSCh(charOf(whnfHead));
outLPr(nameNSPrint,pushed(1));
}
else {
sp = ksp;
outCh('[');
outPr(nameNPrint,MIN_PREC,top());
outLPr(nameNLPrint,pushed(1));
}
}
break;
}
if (whnfArgs==1 && sy!=APPLIC) { /* (e1+) */
used = 1;
outCh('(');
outPr(pr,FUN_PREC-1,pushed(0));
outCh(' ');
outOp(name(whnfHead).text);
outCh(')');
}
else if (whnfArgs>=2 && sy!=APPLIC) { /* e1+e2 */
Syntax a = assocOf(sy);
Int p = precOf(sy);
used = 2;
if (whnfArgs>2 || d>p)
outCh('(');
outPr(pr,(a==LEFT_ASS? p:1+p),pushed(0));
outCh(' ');
outOp(name(whnfHead).text);
outCh(' ');
outPr(pr,(a==RIGHT_ASS?p:1+p),pushed(1));
if (whnfArgs>2 || d>p)
outCh(')');
}
else /* f ... */
outVar(name(whnfHead).text);
}
break;
#if BIGNUMS
case NEGNUM :
case ZERONUM :
case POSNUM : out = rev(bigOut(whnfHead,NIL,d>=UMINUS_PREC));
pr = nameNPrint;
break;
#endif
case INTCELL : { Int digit;
if (intOf(whnfHead)<0 && d>=UMINUS_PREC)
outCh(')');
do {
digit = whnfInt%10;
if (digit<0)
digit= (-digit);
outCh('0'+digit);
} while ((whnfInt/=10)!=0);
if (intOf(whnfHead)<0) {
outCh('-');
if (d>=UMINUS_PREC)
outCh('(');
}
out = rev(out);
pr = nameNPrint;
}
break;
case TUPLE : { Int tn = tupleOf(whnfHead);
Int punc = '(';
Int i;
used = tn<whnfArgs ? tn : whnfArgs;
for (i=0; i<used; ++i) {
outCh(punc);
outPr(pr,MIN_PREC,pushed(i));
punc = ',';
}
for (; i<tn; ++i) {
outCh(punc);
punc = ',';
}
outCh(')');
}
pr = nameNPrint;
break;
case CHARCELL : outCh('\'');
outStr(unlexChar(charOf(whnfHead), '\''));
outCh('\'');
pr = nameNPrint;
break;
case FLOATCELL: if (whnfFloat<0.0 && d>=UMINUS_PREC)
outCh('(');
outStr(floatToString(whnfFloat));
if (whnfFloat<0.0 && d>=UMINUS_PREC)
outCh(')');
pr = nameNPrint;
break;
#if HASKELL_ARRAYS
case ARRAY : outStr("{array}");
pr = nameNPrint;
break;
#endif
#if LAZY_ST
case MUTVAR : outStr("{mutable variable}");
pr = nameNPrint;
break;
#endif
#if OBJ
case OBJREF : outStr("{object reference}");
pr = nameNPrint;
break;
#endif
case DICTCELL : outStr("{dict}");
pr = nameNPrint;
break;
#if IO_MONAD
case HANDCELL : outStr("{handle}");
pr = nameNPrint;
break;
#endif
case INSTANCE : outInst(whnfHead);
pr = nameNPrint;
break;
default : internal("Error in graph");
break;
}
if (used<whnfArgs) { /* Add remaining args to output */
do {
outCh(' ');
outPr(pr,FUN_PREC,pushed(used));
} while (++used<whnfArgs);
if (d>=FUN_PREC) { /* Determine if parens are needed */
out = appendOnto(out,singleton(consChar('(')));
outCh(')');
}
}
}
/* --------------------------------------------------------------------------
* List printing primitives:
* ------------------------------------------------------------------------*/
primFun(primLPrint) { /* evaluate and print list */
Cell temp = evalWithNoError(primArg(2));
out = NIL;
if (nonNull(temp)) {
push(temp);
outStr("] ++ ");
outBadRedex(top());
}
else if (whnfHead==nameCons && whnfArgs==2) {
outCh(',');
outCh(' ');
outPr(namePrint,MIN_PREC,pushed(0));
outLPr(nameLPrint,pushed(1));
}
else if (whnfHead==nameNil && whnfArgs==0)
outCh(']');
else {
outStr("] ++ ");
outBadRedex(primArg(2));
}
updOutRoot(primArg(1));
}
primFun(primNLPrint) { /* print list without evaluation */
unwind(primArg(2));
out = NIL;
if (whnfHead==nameCons && whnfArgs==2) {
outCh(',');
outCh(' ');
outPr(nameNPrint,MIN_PREC,pushed(0));
outLPr(nameNLPrint,pushed(1));
}
else if (whnfHead==nameNil && whnfArgs==0)
outCh(']');
else {
outStr("] ++ ");
outPr(nameNPrint,FUN_PREC-1,primArg(2));
}
updOutRoot(primArg(1));
}
primFun(primSPrint) { /* evaluate and print string */
Cell temp = evalWithNoError(primArg(2));
out = NIL;
if (nonNull(temp)) {
push(temp);
outStr("\" ++ ");
outBadRedex(top());
}
else if (whnfHead==nameCons && whnfArgs==2) {
temp = evalWithNoError(top()); /* primArg(4), primArg(3) contain */
out = NIL; /* the head and tail of list, resp*/
if (nonNull(temp)) {
push(temp);
outStr("\" ++ [");
outBadRedex(top());
outLPr(nameLPrint,primArg(3));
}
else if (isChar(whnfHead) && whnfArgs==0) {
outSCh(charOf(whnfHead));
outLPr(nameSPrint,primArg(3));
}
else {
outStr("\" ++ [");
outBadRedex(primArg(4));
outLPr(nameLPrint,primArg(3));
}
}
else if (whnfHead==nameNil && whnfArgs==0)
outCh('"');
else {
outStr("\" ++ ");
outBadRedex(primArg(2));
}
updOutRoot(primArg(1));
}
primFun(primNSPrint) { /* print string without eval */
unwind(primArg(2));
out = NIL;
if (whnfHead==nameCons && whnfArgs==2) {
unwind(pushed(0));
if (isChar(whnfHead) && whnfArgs==0) {
outSCh(charOf(whnfHead));
outLPr(nameNSPrint,primArg(3));
}
else {
outStr("\" ++ [");
outPr(nameNPrint,MIN_PREC,primArg(4));
outLPr(nameNLPrint,primArg(3));
}
}
else if (whnfHead==nameNil && whnfArgs==0)
outCh('"');
else {
outStr("\" ++ ");
outPr(nameNPrint,FUN_PREC-1,primArg(2));
}
updOutRoot(primArg(1));
}
/* --------------------------------------------------------------------------
* Auxiliary functions for printer(s):
* ------------------------------------------------------------------------*/
static Void local outVar(t) /* output t as function symbol */
Text t; {
String s = textToStr(t);
if ((isascii(*s) && isalpha(*s)) || *s=='_' || *s=='[' || *s=='(')
outStr(s);
else {
outCh('(');
outStr(s);
outCh(')');
}
}
static Void local outOp(t) /* output t as operator symbol */
Text t; {
String s = textToStr(t);
if (isascii(s[0]) && isalpha(s[0])) {
outCh('`');
outStr(s);
outCh('`');
}
else
outStr(s);
}
static Void local outStr(s) /* output string s */
String s; {
while (*s)
outCh(*s++);
}
static Void local outPr(pr,d,e) /* output expr e with printer pr, */
Name pr; /* precedence d */
Int d;
Cell e; {
out = ap(NIL,out);
fst(out) = ap(NIL,e);
fst(fst(out)) = ap(pr,mkInt(d));
}
static Void local outLPr(pr,xs) /* output list xs with printer pr */
Name pr;
Cell xs; {
out = ap(NIL,out);
fst(out) = ap(pr,xs);
}
static Void local outBadRedex(rx) /* Produce expr to print bad redex */
Cell rx; {
outCh('{');
outPr(nameNPrint,MIN_PREC,rx);
outCh('}');
}
static Cell local printDBadRedex(rx,rs) /* Produce expression for bad */
Cell rx, rs; { /* redex with special handling */
if (isAp(rx) && fun(rx)==nameError) /* of {error str} redexes */
return arg(rx);
else
return printBadRedex(rx,rs);
}
static Cell local printBadRedex(rx,rs) /* produce expression for bad */
Cell rx, rs; { /* redex */
out = NIL;
outBadRedex(rx);
return revOnto(out,rs);
}
Void abandon(what,rx) /* abandon computation */
String what;
Cell rx; {
push(printDBadRedex(rx,nameNil));
out = NIL;
outCh('\n');
outStr(what);
outStr(" error: ");
top() = revOnto(out,top());
out = NIL;
outputString(errorStream);
errAbort();
}
static Void local outInst(in) /* produce string representation */
Inst in; { /* of instance */
outStr(textToStr(cclass(inst(in).c).text));
outCh('-');
switch (whatIs(inst(in).t)) {
case TUPLE : { Int n = tupleOf(inst(in).t);
outCh('(');
for (; n>0; --n)
outCh(',');
outCh(')');
}
return;
case TYCON : outStr(textToStr(tycon(inst(in).t).text));
return;
default : outStr("???");
return;
}
}
/*-------------------------------------------------------------------------*/
syntax highlighted by Code2HTML, v. 0.9.1