text: /* --------------------------------------------------------------------------
   * Builtin printer, used as an alternative to overloaded "show", and also
   * used for certain primitive types.
   *
   * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
   * Yale Haskell Group, and the OGI School of Science & Engineering at OHSU,
   * 1994-2003, All rights reserved.  It is distributed as free software under
   * the license in the file "License", which is included in the distribution.
   *
   * ------------------------------------------------------------------------*/
  
  static Void   local printer		Args((Name,Int));
  static Void   local outName   		Args((Name));
  static Void   local outVar		Args((Name));
  static Void   local outOp		Args((Name));
  static Void   local outStr		Args((String));
  static Void   local outPr		Args((Name,Int,Cell));
  static Void   local outLPr		Args((Name,Cell));
  static Void   local outException	Args((Cell));
  static Void   local outBadRedex		Args((Cell));
  static Cell   local printDException	Args((Cell));
  static Cell   local printException	Args((Cell,Cell));
  
  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;
  
  /* --------------------------------------------------------------------------
   * Printer control:
   * ------------------------------------------------------------------------*/
  
  static Void printerControl Args((Int));
  static Void printerControl(what)
  Int what; {
      switch (what) {
  	case MARK    : mark(out);
  		       break;
  	case INSTALL : 
  		       setCurrModule(modulePrelude);
  #define pFun(n,s,t)    addPrim(0,n=newName(findText(s),NIL),t,modulePrelude,NIL)
  		       pFun(namePrint,	   "_print",   "print");
  		       pFun(nameNPrint,	   "_nprint",  "nprint");
  		       pFun(nameLPrint,	   "_lprint",  "lprint");
  		       pFun(nameNLPrint,   "_nlprint", "nlprint");
  		       pFun(nameSPrint,	   "_sprint",  "sprint");
  		       pFun(nameNSPrint,   "_nsprint", "nsprint");
  #undef pFun
  		       /* deliberate fall through */
  	case RESET   : out = NIL;
  		       break;
      }
  }
  
  PROTO_PRIM(primPrint);
  PROTO_PRIM(primBPrint);
  PROTO_PRIM(primNPrint);
  PROTO_PRIM(primLPrint);
  PROTO_PRIM(primNLPrint);
  PROTO_PRIM(primSPrint);
  PROTO_PRIM(primNSPrint);
  
  static struct primitive printerPrimTable[] = {
    {"print",		3, primPrint},
    {"nprint",		3, primNPrint},
    {"lprint",		2, primLPrint},
    {"nlprint",		2, primNLPrint},
    {"sprint",		2, primSPrint},
    {"nsprint",		2, primNSPrint},
    {"primShowsInt",	3, primBPrint},
    {"primShowsPtr",	3, primBPrint},
    {"primShowsInteger",	3, primBPrint},
    {"primShowsFloat",	3, primBPrint},
    {"primShowsDouble",	3, primBPrint},
    {0,			0, 0}
  };
  
  static struct primInfo printerPrims = { printerControl, printerPrimTable, 0 };
  
  /*-------------------------------------------------------------------------*/
  
  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);
  	outException(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"	   */
  
      allowBreak();
  
      switch(whatIs(whnfHead)) {
  
  	case NAME     : {   Syntax sy = syntaxOf(whnfHead);
  
  			    if (!isCfun(whnfHead) ||
  				    name(whnfHead).arity>whnfArgs)
  				pr = nameNPrint;
  
  #ifndef VERBOSE_PRINT
  			    /* don't print dictionary arguments */
  			    while (used<whnfArgs) {
  				Cell h;
  				Int w;
  				h=pushed(used);
  				for (;;) {
  				    w = whatIs(h);
  				    if (w==AP)
  					h = fun(h);
  				    else if (w==INDIRECT)
  					h = arg(h);
  				    else
  					break;
  				}
  				if (w==NAME && isNull(name(h).type) &&
  				    (whatIs(name(h).parent)==INSTANCE ||
  				     isDfun(h) ||
  				     strncmp(textToStr(name(h).text),"Make.",5) == 0))
  				    used++;
  				else
  				    break;
  			    }
  #endif
  
  			    if (whnfHead==nameCons && whnfArgs==2) {/*list */
  				StackPtr ksp = sp;
  				used 	     = 2;
  				if (pr==namePrint) {
  				    Cell temp = evalWithNoError(top());
  				    if (nonNull(temp)) {
  					push(temp);
  					outCh('[');
  					outException(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));
  				    }
  				}
  				return;
  			    }
  #ifndef VERBOSE_PRINT
  			    /* hide fromInt/fromDouble */
  			    else if (whnfArgs==2 &&
  				     ((whnfHead==nameFromInt && whatIs(pushed(1))==INTCELL) ||
  				      (whnfHead==nameFromDouble && (whatIs(pushed(1))==FLOATCELL || whatIs(pushed(1))==DOUBLECELL)))) {
  				unwind(pushed(1));
  				printer(pr,d);
  				return;
  			    }
  #endif
  			    else if (whnfArgs-used==1 && sy!=APPLIC) { /* (e1+) */
  				outCh('(');
  				outPr(pr,FUN_PREC-1,pushed(used));
  				outCh(' ');
  				outOp(whnfHead);
  				outCh(')');
  				used++;
  			    }
  			    else if (whnfArgs-used>=2 && sy!=APPLIC) { /* e1+e2 */
  				Syntax a = assocOf(sy);
  				Int    p = precOf(sy);
  				if (whnfArgs-used>2 || d>p)
  				     outCh('(');
  				outPr(pr,(a==LEFT_ASS? p:1+p),pushed(used));
  				used++;
  				outCh(' ');
  				outOp(whnfHead);
  				outCh(' ');
  				outPr(pr,(a==RIGHT_ASS?p:1+p),pushed(used));
  				used++;
  				if (whnfArgs-used>2 || d>p)
  				    outCh(')');
  			    }
  			    else				  /* f ... */
  				outVar(whnfHead);
  			}
  			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 PTRCELL  : {   Pointer p = ptrOf(whnfHead);
  			    char buffer[32];
  			    char spec[16];
  			    /* Fall into line with how GHC shows Addrs  */
  			    sprintf(spec,"0x%%.%dlx", (SIZEOF_INTP)*2);
  			    sprintf(buffer,spec,(long)p);
  #if 0
  			    /* Old skool */
  			    sprintf(buffer,"%p",p);
  #endif
  			    outStr(buffer);
  			    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;
  
  	case DOUBLECELL:if (whnfDouble<0.0 && d>=UMINUS_PREC)
  			    outCh('(');
  			outStr(doubleToString(whnfDouble));
  			if (whnfDouble<0.0 && d>=UMINUS_PREC)
  			    outCh(')');
  			pr = nameNPrint;
  			break;
  
  #if HASKELL_ARRAYS
  	case ARRAY    : outStr("{array}");
  			pr = nameNPrint;
  			break;
  #endif
  
  #if IO_REFS
  	case MUTVAR   : outStr("{mutable variable}");
  			pr = nameNPrint;
  			break;
  #endif
  
  	case HUGSOBJECT: 
  			outStr("{Cell ...}");
  			pr = nameNPrint;
  			break;
  
  #if TREX
  	case RECORD   : outStr("{record}");
  			pr = nameNPrint;
  			break;
  #endif
   
  #if IO_HANDLES
  	case HANDCELL : outStr("{handle}");
  			pr = nameNPrint;
  			break;
  #endif
  
  #if OBSERVATIONS
          case OBSERVE  : outStr("printer.c: printer(): OBSERVE");
                          break;
  #endif
  
  	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("] ++ ");
  	outException(top());
      }
      else if (whnfHead==nameCons && whnfArgs==2) {
  	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(',');
  	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("\" ++ ");
  	outException(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("\" ++ [");
  	    outException(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 outName(nm)  /* output nm using parent field if possible */
  Name nm; {
      Cell p = name(nm).parent;
      switch (whatIs(p)) {
  #ifdef VERBOSE_PRINT
  	case INSTANCE : outStr("inst");
  			outStr(textToStr(cclass(inst(p).c).text));
  			outCh('_');
  			break;
  
  	case CLASS    : outStr(textToStr(cclass(p).text));
  			outCh('_');
  			break;
  
  	case TYCON    : outStr(textToStr(tycon(p).text));
  			outCh('_');
  			break;
  #endif
  
  	case NAME     : outName(p);
  			outCh('_');
  			break;
      }
      outStr(textToStr(name(nm).text));
  }
  
  static Void local outVar(nm)		/* output nm as function symbol	   */
  Name nm; {
      String s = textToStr(name(nm).text);
      if ((isascii(*s) && isalpha(*s)) || *s=='_' || *s=='[' || *s=='(')
  	outName(nm);
      else {
  	outCh('(');
  	outName(nm);
  	outCh(')');
      }
  }
  
  static Void local outOp(nm)		/* output nm as operator symbol	   */
  Name nm; {
      String s = textToStr(name(nm).text);
      if (isascii(s[0]) && isalpha(s[0])) {
  	outCh('`');
  	outName(nm);
  	outCh('`');
      }
      else
  	outName(nm);
  }
  
  static Void local outStr(s)		/* output string s		   */
  String s; {
      while (*s)
  	outCh(ExtractChar(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 outException(ex)	/* Produce expr to print exception */
  Cell ex; {
      outCh('{');
      if (isAp(ex) && fun(ex)==nameErrorCall) {
  	outStr("error ");
  	outPr(nameNPrint,FUN_PREC,arg(ex));
      } else {
  	outStr("throw ");
  	outPr(nameNPrint,FUN_PREC,ex);
      }
      outCh('}');
  }
  
  static Void local outBadRedex(rx)	/* Produce expr to print bad redex */
  Cell rx; {
      outCh('{');
      outPr(nameNPrint,MIN_PREC,rx);
      outCh('}');
  }
  
  static Cell local printDException(ex)	/* Produce expression for exception*/
  Cell ex; {				/* with special handling	   */
      if (isAp(ex) && fun(ex)==nameErrorCall)/* of {error str} exceptions    */
  	return arg(ex);
      else
  	return printException(ex,nameNil);
  }
  
  static Cell local printException(ex,rs)	/* produce expression for exception*/
  Cell ex, rs; {
     out = NIL;
     outException(ex);
     return revOnto(out,rs);
  }
  
  Void abandon(what,ex)			/* abandon computation		   */
  String what;
  Cell   ex; {
      push(printDException(ex));
      out   = NIL;
      outCh('\n');
      outStr(what);
      outStr(" error: ");
      top() = revOnto(out,top());
      out   = NIL;
      outputString(errorStream);
      errAbort();
  }
  
  /*-------------------------------------------------------------------------*/
  