Commit 3317c1cc authored by sewardj's avatar sewardj

[project @ 1999-03-04 10:18:02 by sewardj]

Amalgamated pp.c into stg.c.
parent 997919c2
/* -*- 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
/*-------------------------------------------------------------------------*/
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment