+++ /dev/null
-/* -*- mode: hugs-c; -*- */
-/* --------------------------------------------------------------------------
- * STG pretty printer
- *
- * 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
- *
- * $RCSfile: pp.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:31 $
- * ------------------------------------------------------------------------*/
-
-#include "prelude.h"
-#include "storage.h"
-#include "connect.h"
-#include "errors.h"
-#include "stg.h"
-#include "pp.h"
-#include "hugs.h" /* for debugCode */
-#include "input.h" /* for unlexChar */
-
-/* --------------------------------------------------------------------------
- * Local functions
- * ------------------------------------------------------------------------*/
-
-static Void local pIndent Args((Int));
-static Void local unlexVar Args((Text));
-static Void local unlexCharConst Args((Cell));
-static Void local unlexStrConst Args((Text));
-
-static Void local putStgVar Args((StgVar));
-static Void local putStgVars Args((List));
-static Void local putStgAtom Args((StgAtom a));
-static Void local putStgAtoms Args((List as));
-static Void local putStgBinds Args((List));
-static Void local putStgExpr Args((StgExpr));
-static Void local putStgRhs Args((StgRhs));
-static Void local putStgPat Args((StgPat));
-static Void local putStgPrimPat Args((StgPrimPat));
-
-/* --------------------------------------------------------------------------
- * Basic output routines:
- * ------------------------------------------------------------------------*/
-
-static FILE *outputStream; /* current output stream */
-static Int outColumn = 0; /* current output column number */
-
-static Void local putChr( Int c );
-static Void local putStr( String s );
-static Void local putInt( Int n );
-static Void local putPtr( Ptr p );
-
-static Void local putChr(c) /* print single character */
-Int c; {
- Putc(c,outputStream);
- outColumn++;
-}
-
-static Void local putStr(s) /* print string */
-String s; {
- for (; *s; s++) {
- Putc(*s,outputStream);
- outColumn++;
- }
-}
-
-static Void local putInt(n) /* print integer */
-Int n; {
- static char intBuf[16];
- sprintf(intBuf,"%d",n);
- putStr(intBuf);
-}
-
-static Void local putPtr(p) /* print pointer */
-Ptr p; {
- static char intBuf[16];
- sprintf(intBuf,"%p",p);
- putStr(intBuf);
-}
-
-/* --------------------------------------------------------------------------
- * Indentation and showing names/constants
- * ------------------------------------------------------------------------*/
-
-static Void local pIndent(n) /* indent to particular position */
-Int n; {
- outColumn = n;
- while (0<n--) {
- Putc(' ',outputStream);
- }
-}
-
-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]=='(')
- putStr(s);
- else {
- putChr('(');
- putStr(s);
- putChr(')');
- }
-}
-
-static Void local unlexCharConst(c)
-Cell c; {
- putChr('\'');
- putStr(unlexChar(c,'\''));
- putChr('\'');
-}
-
-static Void local unlexStrConst(t)
-Text t; {
- String s = textToStr(t);
- static Char SO = 14; /* ASCII code for '\SO' */
- Bool lastWasSO = FALSE;
- Bool lastWasDigit = FALSE;
- Bool lastWasEsc = FALSE;
-
- putChr('\"');
- for (; *s; s++) {
- String ch = unlexChar(*s,'\"');
- Char c = ' ';
-
- if ((lastWasSO && *ch=='H') ||
- (lastWasEsc && lastWasDigit && isascii(*ch) && isdigit(*ch)))
- putStr("\\&");
-
- lastWasEsc = (*ch=='\\');
- lastWasSO = (*s==SO);
- for (; *ch; c = *ch++)
- putChr(*ch);
- lastWasDigit = (isascii(c) && isdigit(c));
- }
- putChr('\"');
-}
-
-/* --------------------------------------------------------------------------
- * Pretty printer for stg code:
- * ------------------------------------------------------------------------*/
-
-static Void putStgAlts ( Int left, List alts );
-static Void putStgPrimAlt ( Int left, List vs, StgExpr body );
-
-static Void local putStgVar(StgVar v)
-{
- if (isName(v)) {
- unlexVar(name(v).text);
- } else {
- putStr("id");
- putInt(-v);
- }
-}
-
-static Void local putStgVars( List vs )
-{
- for(; nonNull(vs); vs=tl(vs)) {
- putStgVar(hd(vs));
- putChr(' ');
- }
-}
-
-static Void local putStgAtom( StgAtom a )
-{
- switch (whatIs(a)) {
- case STGVAR:
- case NAME:
- putStgVar(a);
- break;
- case CHARCELL:
- unlexCharConst(charOf(a));
- putChr('#');
- break;
- case INTCELL:
- putInt(intOf(a));
- putChr('#');
- break;
- case BIGCELL:
- putStr(bignumToString(a));
- putChr('#');
- break;
- case FLOATCELL:
- putStr(floatToString(a));
- putChr('#');
- break;
- case STRCELL:
- unlexStrConst(textOf(a));
- break;
- case PTRCELL:
- putPtr(ptrOf(a));
- putChr('#');
- break;
- default:
- fprintf(stderr,"\nYoiks: "); printExp(stderr,a);
- internal("putStgAtom");
- }
-}
-
-Void putStgAtoms( List as )
-{
- putChr('{');
- while (nonNull(as)) {
- putStgAtom(hd(as));
- as=tl(as);
- if (nonNull(as)) {
- putChr(',');
- }
- }
- putChr('}');
-}
-
-Void putStgPat( StgPat pat )
-{
- putStgVar(pat);
- if (nonNull(stgVarBody(pat))) {
- StgDiscr d = stgConCon(stgVarBody(pat));
- List vs = stgConArgs(stgVarBody(pat));
- putChr('@');
- switch (whatIs(d)) {
- case NAME:
- {
- unlexVar(name(d).text);
- for (; nonNull(vs); vs=tl(vs)) {
- putChr(' ');
- putStgVar(hd(vs));
- }
- break;
- }
- case TUPLE:
- {
- putChr('(');
- putStgVar(hd(vs));
- vs=tl(vs);
- while (nonNull(vs)) {
- putChr(',');
- putStgVar(hd(vs));
- vs=tl(vs);
- }
- putChr(')');
- break;
- }
- default:
- fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
- internal("putStgPat");
- }
- }
-}
-
-Void putStgPrimPat( StgPrimPat pat )
-{
- putStgVar(pat);
- if (nonNull(stgVarBody(pat))) {
- StgExpr d = stgVarBody(pat);
- putChr('@');
- switch (whatIs(d)) {
- case INTCELL:
- {
- putInt(intOf(d));
- putChr('#');
- break;
- }
- default:
- fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
- internal("putStgPrimPat");
- }
- }
- putChr(' ');
-}
-
-Void putStgBinds(binds) /* pretty print locals */
-List binds; {
- Int left = outColumn;
-
- putStr("let { ");
- while (nonNull(binds)) {
- Cell bind = hd(binds);
- putStgVar(bind);
- putStr(" = ");
- putStgRhs(stgVarBody(bind));
- putStr("\n");
- binds = tl(binds);
- if (nonNull(binds))
- pIndent(left+6);
- }
- pIndent(left);
- putStr("} in ");
-}
-
-static Void putStgAlts( Int left, List alts )
-{
- if (length(alts) == 1) {
- StgCaseAlt alt = hd(alts);
- putStr("{ ");
- putStgPat(stgCaseAltPat(alt));
- putStr(" ->\n");
- pIndent(left);
- putStgExpr(stgCaseAltBody(alt));
- putStr("}");
- } else {
- putStr("{\n");
- for (; nonNull(alts); alts=tl(alts)) {
- StgCaseAlt alt = hd(alts);
- pIndent(left+2);
- putStgPat(stgCaseAltPat(alt));
- putStr(" -> ");
- putStgExpr(stgCaseAltBody(alt));
- putStr("\n");
- }
- pIndent(left);
- putStr("}\n");
- }
-}
-
-static Void putStgPrimAlts( Int left, List alts )
-{
- if (length(alts) == 1) {
- StgPrimAlt alt = hd(alts);
- putStr("{ ");
- mapProc(putStgPrimPat,stgPrimAltPats(alt));
- putStr(" ->\n");
- pIndent(left);
- putStgExpr(stgPrimAltBody(alt));
- putStr("}");
- } else {
- putStr("{\n");
- for (; nonNull(alts); alts=tl(alts)) {
- StgPrimAlt alt = hd(alts);
- pIndent(left+2);
- mapProc(putStgPrimPat,stgPrimAltPats(alt));
- putStr(" -> ");
- putStgExpr(stgPrimAltBody(alt));
- putStr("\n");
- }
- pIndent(left);
- putStr("}\n");
- }
-}
-
-Void putStgExpr( StgExpr e ) /* pretty print expr */
-{
- switch (whatIs(e)) {
- case LETREC:
- putStgBinds(stgLetBinds(e));
- putStgExpr(stgLetBody(e));
- break;
- case LAMBDA:
- {
- Int left = outColumn;
- putStr("\\ ");
- putStgVars(stgLambdaArgs(e));
- putStr("->\n");
- pIndent(left+2);
- putStgExpr(stgLambdaBody(e));
- break;
- }
- case CASE:
- {
- Int left = outColumn;
- putStr("case ");
- putStgExpr(stgCaseScrut(e));
- putStr(" of ");
- putStgAlts(left,stgCaseAlts(e));
- break;
- }
- case PRIMCASE:
- {
- Int left = outColumn;
- putStr("case# ");
- putStgExpr(stgPrimCaseScrut(e));
- putStr(" of ");
- putStgPrimAlts(left,stgPrimCaseAlts(e));
- break;
- }
- case STGPRIM:
- {
- Cell op = stgPrimOp(e);
- unlexVar(name(op).text);
- putStgAtoms(stgPrimArgs(e));
- break;
- }
- case STGAPP:
- putStgVar(stgAppFun(e));
- putStgAtoms(stgAppArgs(e));
- break;
- case STGVAR:
- case NAME:
- putStgVar(e);
- break;
- default:
- fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
- internal("putStgExpr");
- }
-}
-
-Void putStgRhs( StgRhs e ) /* print lifted definition */
-{
- switch (whatIs(e)) {
- case STGCON:
- {
- Name con = stgConCon(e);
- if (isTuple(con)) {
- putStr("Tuple");
- putInt(tupleOf(con));
- } else {
- unlexVar(name(con).text);
- }
- putStgAtoms(stgConArgs(e));
- break;
- }
- default:
- putStgExpr(e);
- break;
- }
-}
-
-static void beginStgPP( FILE* fp );
-static void endStgPP( FILE* fp );
-
-static void beginStgPP( FILE* fp )
-{
- outputStream = fp;
- putChr('\n');
- outColumn = 0;
-}
-
-static void endStgPP( FILE* fp )
-{
- fflush(fp);
-}
-
-Void printStg(fp,b) /* Pretty print sc defn on fp */
-FILE *fp;
-StgVar b;
-{
- beginStgPP(fp);
- putStgVar(b);
- putStr(" = ");
- putStgRhs(stgVarBody(b));
- putStr("\n");
- endStgPP(fp);
-}
-
-#if DEBUG_PRINTER
-Void ppStg( StgVar v )
-{
- if (debugCode) {
- printStg(stdout,v);
- }
-}
-
-Void ppStgExpr( StgExpr e )
-{
- if (debugCode) {
- beginStgPP(stdout);
- putStgExpr(e);
- endStgPP(stdout);
- }
-}
-
-Void ppStgRhs( StgRhs rhs )
-{
- if (debugCode) {
- beginStgPP(stdout);
- putStgRhs(rhs);
- endStgPP(stdout);
- }
-}
-
-Void ppStgAlts( List alts )
-{
- if (debugCode) {
- beginStgPP(stdout);
- putStgAlts(0,alts);
- endStgPP(stdout);
- }
-}
-
-extern Void ppStgPrimAlts( List alts )
-{
- if (debugCode) {
- beginStgPP(stdout);
- putStgPrimAlts(0,alts);
- endStgPP(stdout);
- }
-}
-
-extern Void ppStgVars( List vs )
-{
- if (debugCode) {
- beginStgPP(stdout);
- printf("Vars: ");
- putStgVars(vs);
- printf("\n");
- endStgPP(stdout);
- }
-}
-#endif
-
-/*-------------------------------------------------------------------------*/
projects / ghc-hetmet.git / commitdiff