1 /* -*- mode: hugs-c; -*- */
2 /* --------------------------------------------------------------------------
5 * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
6 * All rights reserved. See NOTICE for details and conditions of use etc...
7 * Hugs version 1.4, December 1997
11 * $Date: 1998/12/02 13:22:31 $
12 * ------------------------------------------------------------------------*/
20 #include "hugs.h" /* for debugCode */
21 #include "input.h" /* for unlexChar */
23 /* --------------------------------------------------------------------------
25 * ------------------------------------------------------------------------*/
27 static Void local pIndent Args((Int));
28 static Void local unlexVar Args((Text));
29 static Void local unlexCharConst Args((Cell));
30 static Void local unlexStrConst Args((Text));
32 static Void local putStgVar Args((StgVar));
33 static Void local putStgVars Args((List));
34 static Void local putStgAtom Args((StgAtom a));
35 static Void local putStgAtoms Args((List as));
36 static Void local putStgBinds Args((List));
37 static Void local putStgExpr Args((StgExpr));
38 static Void local putStgRhs Args((StgRhs));
39 static Void local putStgPat Args((StgPat));
40 static Void local putStgPrimPat Args((StgPrimPat));
42 /* --------------------------------------------------------------------------
43 * Basic output routines:
44 * ------------------------------------------------------------------------*/
46 static FILE *outputStream; /* current output stream */
47 static Int outColumn = 0; /* current output column number */
49 static Void local putChr( Int c );
50 static Void local putStr( String s );
51 static Void local putInt( Int n );
52 static Void local putPtr( Ptr p );
54 static Void local putChr(c) /* print single character */
60 static Void local putStr(s) /* print string */
63 Putc(*s,outputStream);
68 static Void local putInt(n) /* print integer */
70 static char intBuf[16];
71 sprintf(intBuf,"%d",n);
75 static Void local putPtr(p) /* print pointer */
77 static char intBuf[16];
78 sprintf(intBuf,"%p",p);
82 /* --------------------------------------------------------------------------
83 * Indentation and showing names/constants
84 * ------------------------------------------------------------------------*/
86 static Void local pIndent(n) /* indent to particular position */
90 Putc(' ',outputStream);
94 static Void local unlexVar(t) /* print text as a variable name */
95 Text t; { /* operator symbols must be enclosed*/
96 String s = textToStr(t); /* in parentheses... except [] ... */
98 if ((isascii(s[0]) && isalpha(s[0])) || s[0]=='_' || s[0]=='[' || s[0]=='(')
107 static Void local unlexCharConst(c)
110 putStr(unlexChar(c,'\''));
114 static Void local unlexStrConst(t)
116 String s = textToStr(t);
117 static Char SO = 14; /* ASCII code for '\SO' */
118 Bool lastWasSO = FALSE;
119 Bool lastWasDigit = FALSE;
120 Bool lastWasEsc = FALSE;
124 String ch = unlexChar(*s,'\"');
127 if ((lastWasSO && *ch=='H') ||
128 (lastWasEsc && lastWasDigit && isascii(*ch) && isdigit(*ch)))
131 lastWasEsc = (*ch=='\\');
132 lastWasSO = (*s==SO);
133 for (; *ch; c = *ch++)
135 lastWasDigit = (isascii(c) && isdigit(c));
140 /* --------------------------------------------------------------------------
141 * Pretty printer for stg code:
142 * ------------------------------------------------------------------------*/
144 static Void putStgAlts ( Int left, List alts );
145 static Void putStgPrimAlt ( Int left, List vs, StgExpr body );
147 static Void local putStgVar(StgVar v)
150 unlexVar(name(v).text);
157 static Void local putStgVars( List vs )
159 for(; nonNull(vs); vs=tl(vs)) {
165 static Void local putStgAtom( StgAtom a )
173 unlexCharConst(charOf(a));
181 putStr(bignumToString(a));
185 putStr(floatToString(a));
189 unlexStrConst(textOf(a));
196 fprintf(stderr,"\nYoiks: "); printExp(stderr,a);
197 internal("putStgAtom");
201 Void putStgAtoms( List as )
204 while (nonNull(as)) {
214 Void putStgPat( StgPat pat )
217 if (nonNull(stgVarBody(pat))) {
218 StgDiscr d = stgConCon(stgVarBody(pat));
219 List vs = stgConArgs(stgVarBody(pat));
224 unlexVar(name(d).text);
225 for (; nonNull(vs); vs=tl(vs)) {
236 while (nonNull(vs)) {
245 fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
246 internal("putStgPat");
251 Void putStgPrimPat( StgPrimPat pat )
254 if (nonNull(stgVarBody(pat))) {
255 StgExpr d = stgVarBody(pat);
265 fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
266 internal("putStgPrimPat");
272 Void putStgBinds(binds) /* pretty print locals */
274 Int left = outColumn;
277 while (nonNull(binds)) {
278 Cell bind = hd(binds);
281 putStgRhs(stgVarBody(bind));
291 static Void putStgAlts( Int left, List alts )
293 if (length(alts) == 1) {
294 StgCaseAlt alt = hd(alts);
296 putStgPat(stgCaseAltPat(alt));
299 putStgExpr(stgCaseAltBody(alt));
303 for (; nonNull(alts); alts=tl(alts)) {
304 StgCaseAlt alt = hd(alts);
306 putStgPat(stgCaseAltPat(alt));
308 putStgExpr(stgCaseAltBody(alt));
316 static Void putStgPrimAlts( Int left, List alts )
318 if (length(alts) == 1) {
319 StgPrimAlt alt = hd(alts);
321 mapProc(putStgPrimPat,stgPrimAltPats(alt));
324 putStgExpr(stgPrimAltBody(alt));
328 for (; nonNull(alts); alts=tl(alts)) {
329 StgPrimAlt alt = hd(alts);
331 mapProc(putStgPrimPat,stgPrimAltPats(alt));
333 putStgExpr(stgPrimAltBody(alt));
341 Void putStgExpr( StgExpr e ) /* pretty print expr */
345 putStgBinds(stgLetBinds(e));
346 putStgExpr(stgLetBody(e));
350 Int left = outColumn;
352 putStgVars(stgLambdaArgs(e));
355 putStgExpr(stgLambdaBody(e));
360 Int left = outColumn;
362 putStgExpr(stgCaseScrut(e));
364 putStgAlts(left,stgCaseAlts(e));
369 Int left = outColumn;
371 putStgExpr(stgPrimCaseScrut(e));
373 putStgPrimAlts(left,stgPrimCaseAlts(e));
378 Cell op = stgPrimOp(e);
379 unlexVar(name(op).text);
380 putStgAtoms(stgPrimArgs(e));
384 putStgVar(stgAppFun(e));
385 putStgAtoms(stgAppArgs(e));
392 fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
393 internal("putStgExpr");
397 Void putStgRhs( StgRhs e ) /* print lifted definition */
402 Name con = stgConCon(e);
405 putInt(tupleOf(con));
407 unlexVar(name(con).text);
409 putStgAtoms(stgConArgs(e));
418 static void beginStgPP( FILE* fp );
419 static void endStgPP( FILE* fp );
421 static void beginStgPP( FILE* fp )
428 static void endStgPP( FILE* fp )
433 Void printStg(fp,b) /* Pretty print sc defn on fp */
440 putStgRhs(stgVarBody(b));
446 Void ppStg( StgVar v )
453 Void ppStgExpr( StgExpr e )
462 Void ppStgRhs( StgRhs rhs )
471 Void ppStgAlts( List alts )
480 extern Void ppStgPrimAlts( List alts )
484 putStgPrimAlts(0,alts);
489 extern Void ppStgVars( List vs )
501 /*-------------------------------------------------------------------------*/