+++ /dev/null
-/**********************************************************************
-* *
-* *
-* Syntax Tree Printing Routines *
-* *
-* *
-**********************************************************************/
-
-
-#define COMPACT TRUE /* No spaces in output -- #undef this for debugging */
-
-
-#include <stdio.h>
-
-#include "hspincl.h"
-#include "constants.h"
-#include "utils.h"
-
-/* fwd decls, necessary and otherwise */
-static void pbool PROTO( (BOOLEAN) );
-static void pconstr PROTO( (constr) );
-/* static void pcoresyn PROTO((coresyn)); */
-static void pentid PROTO( (entidt) );
-static void pgrhses PROTO( (list) );
-static void pid PROTO( (id) );
-static void plist PROTO( (void (*)(/*NOT WORTH IT: void * */), list) );
-static void pmaybe PROTO( (void (*)(), maybe) );
-static void pmaybe_list PROTO( (void (*)(), maybe) );
-/* static void ppragma PROTO( (hpragma) ); */
-static void pqid PROTO( (qid) );
-static void prbind PROTO( (binding) );
-static void pstr PROTO( (char *) );
-static void ptree PROTO( (tree) );
-static void ppgdexp PROTO( (gdexp) );
-static void pgrhsb PROTO( (grhsb) );
-static void ppmatch PROTO( (match) );
-static void pttype PROTO( (ttype) );
-static void plineno PROTO( (long) );
-
-extern char *input_filename;
-extern BOOLEAN hashIds;
-
-/* How to print tags */
-
-#if COMPACT
-#define PUTTAG(c) putchar(c);
-#define PUTTAGSTR(s) printf("%s",(s));
-#else
-#define PUTTAG(c) putchar(c); \
- putchar(' ');
-#define PUTTAGSTR(s) printf("%s",(s)); \
- putchar(' ');
-#endif
-
-
-/* Performs a post order walk of the tree
- to print it.
-*/
-
-void
-pprogram(t)
- tree t;
-{
- print_hash_table();
- ptree(t);
-}
-
-/* print_string: we must escape \t and \\, as described in
- char/string lexer comments. (WDP 94/11)
-*/
-static void
-print_string(hstring str)
-{
- char *gs;
- char c;
- int i, str_length;
-
- putchar('#');
- str_length = str->len;
- gs = str->bytes;
-
- for (i = 0; i < str_length; i++) {
- c = gs[i];
- if ( c == '\t' ) {
- putchar('\\');
- putchar('t');
- } else if ( c == '\\' ) {
- putchar('\\');
- putchar('\\');
- } else {
- putchar(gs[i]);
- }
- }
- putchar('\t');
-}
-
-static void
-plineno (l)
-long l;
-{
- printf("#%lu\t",l);
- return;
-}
-
-
-static int
-get_character(hstring str)
-{
- int c = (int)((str->bytes)[0]);
-
- if (str->len != 1) { /* ToDo: assert */
- fprintf(stderr, "get_character: length != 1? (%ld: %s)\n", str->len, str->bytes);
- }
-
- if (c < 0) {
- c += 256; /* "This is not a hack" -- KH */
- }
-
- return(c);
-}
-
-static void
-pliteral(literal t)
-{
- switch(tliteral(t)) {
- case integer:
- PUTTAG('4');
- pstr(ginteger(t));
- break;
- case intprim:
- PUTTAG('H');
- pstr(gintprim(t));
- break;
- case floatr:
- PUTTAG('F');
- pstr(gfloatr(t));
- break;
- case doubleprim:
- PUTTAG('J');
- pstr(gdoubleprim(t));
- break;
- case floatprim:
- PUTTAG('K');
- pstr(gfloatprim(t));
- break;
- case charr:
- PUTTAG('C');
- /* Changed %d to %u, since negative chars
- make little sense -- KH @ 16/4/91
- */
- printf("#%u\t", get_character(gchar(t)));
- break;
- case charprim:
- PUTTAG('P');
- printf("#%u\t", get_character(gcharprim(t)));
- break;
- case string:
- PUTTAG('S');
- print_string(gstring(t));
- break;
- case stringprim:
- PUTTAG('V');
- print_string(gstringprim(t));
- break;
- case clitlit:
- PUTTAG('Y');
- pstr(gclitlit(t));
- /* pstr(gclitlit_kind(t)); */
- break;
- default:
- error("Bad pliteral");
- }
-}
-
-static void
-ptree(t)
- tree t;
-{
-again:
- switch(ttree(t)) {
- case hmodule:
- PUTTAG('M');
- plineno(ghmodline(t));
- pid(ghname(t));
- printf("#%lu\t",ghversion(t));
- pstr(input_filename);
- prbind(ghmodlist(t));
- /* pfixes(); */
- plist(prbind, ghimplist(t));
- pmaybe_list(pentid, ghexplist(t));
- break;
- case ident:
- PUTTAG('i');
- pqid(gident(t));
- break;
- case lit:
- PUTTAG('C');
- pliteral(glit(t));
- break;
-
- case ap:
- PUTTAG('a');
- ptree(gfun(t));
- ptree(garg(t));
- break;
- case infixap:
- PUTTAG('@');
- pqid(ginffun(t));
- ptree(ginfarg1(t));
- ptree(ginfarg2(t));
- break;
- case negate:
- PUTTAG('-');
- ptree(gnexp(t));
- break;
- case lambda:
- PUTTAG('l');
- ppmatch(glammatch(t));
- break;
-
- case let:
- PUTTAG('E');
- prbind(gletvdefs(t));
- ptree(gletvexpr(t));
- break;
- case casee:
- PUTTAG('c');
- plineno(gcaseline(t));
- ptree(gcaseexpr(t));
- plist(ppmatch, gcasebody(t));
- break;
- case ife:
- PUTTAG('b');
- ptree(gifpred(t));
- ptree(gifthen(t));
- ptree(gifelse(t));
- break;
- case doe:
- PUTTAG('O');
- plineno(gdoline(t));
- plist(ptree, gdo(t));
- break;
- case dobind:
- PUTTAG('Q');
- plineno(gdobindline(t));
- ptree(gdobindpat(t));
- ptree(gdobindexp(t));
- break;
- case doexp:
- PUTTAG('R');
- plineno(gdoexpline(t));
- ptree(gdoexp(t));
- break;
- case seqlet:
- PUTTAG('U');
- prbind(gseqlet(t));
- break;
- case record:
- PUTTAG('d');
- pqid(grcon(t));
- plist(prbind,grbinds(t));
- break;
-
- case rupdate:
- PUTTAG('h');
- ptree(gupdexp(t));
- plist(prbind,gupdbinds(t));
- break;
-
- case rbind:
- PUTTAG('o');
- pqid(grbindvar(t));
- pmaybe(ptree,grbindexp(t));
- break;
-
- case par: t = gpare(t); goto again;
-
- case as:
- PUTTAG('s');
- pqid(gasid(t));
- ptree(gase(t));
- break;
- case lazyp:
- PUTTAG('~');
- ptree(glazyp(t));
- break;
- case wildp:
- PUTTAG('_');
- break;
-
- case restr:
- PUTTAG('R');
- ptree(grestre(t));
- pttype(grestrt(t));
- break;
- case tuple:
- PUTTAG(',');
- plist(ptree,gtuplelist(t));
- break;
- case llist:
- PUTTAG(':');
- plist(ptree,gllist(t));
- break;
- case eenum:
- PUTTAG('.');
- ptree(gefrom(t));
- pmaybe(ptree,gestep(t));
- pmaybe(ptree,geto(t));
- break;
- case comprh:
- PUTTAG('Z');
- ptree(gcexp(t));
- plist(ptree,gcquals(t));
- break;
- case qual:
- PUTTAG('G');
- ptree(gqpat(t));
- ptree(gqexp(t));
- break;
- case guard:
- PUTTAG('g');
- ptree(ggexp(t));
- break;
- case lsection:
- PUTTAG('(');
- ptree(glsexp(t));
- pqid(glsop(t));
- break;
- case rsection:
- PUTTAG(')');
- pqid(grsop(t));
- ptree(grsexp(t));
- break;
- case ccall:
- PUTTAG('j');
- pstr(gccid(t));
- pstr(gccinfo(t));
- plist(ptree,gccargs(t));
- break;
- case scc:
- PUTTAG('k');
- print_string(gsccid(t));
- ptree(gsccexp(t));
- break;
- default:
- error("Bad ptree");
- }
-}
-
-static void
-plist(fun, l)
- void (*fun)(/* NOT WORTH IT: void * */);
- list l;
-{
- if (tlist(l) == lnil) {
- PUTTAG('N');
- } else {
- PUTTAG('L');
- (*fun)(lhd(l));
- plist(fun, ltl(l));
- }
-}
-
-static void
-pmaybe(fun, m)
- void (*fun)(/* NOT WORTH IT: void * */);
- maybe m;
-{
- if (tmaybe(m) == nothing) {
- PUTTAG('N');
- } else {
- PUTTAG('J');
- (*fun)(gthing(m));
- }
-}
-
-static void
-pmaybe_list(fun, m)
- void (*fun)(/* NOT WORTH IT: void * */);
- maybe m;
-{
- if (tmaybe(m) == nothing) {
- PUTTAG('N');
- } else {
- PUTTAG('J');
- plist(fun, gthing(m));
- }
-}
-
-static void
-pid(i)
- id i;
-{
- if(hashIds)
- printf("!%lu\t", hash_index(i));
- else
- printf("#%s\t", id_to_string(i));
-}
-
-static void
-pqid(i)
- qid i;
-{
- if(hashIds)
- printf("!%lu\t", hash_index(qid_to_id(i)));
- else
- printf("#%s\t", qid_to_string(i));
-}
-
-static void
-pstr(i)
- char *i;
-{
- printf("#%s\t", i);
-}
-
-static void
-prbind(b)
- binding b;
-{
- switch(tbinding(b)) {
- case tbind:
- PUTTAG('t');
- plineno(gtline(b));
- plist(pttype, gtbindc(b));
- pmaybe_list(pid, gtbindd(b));
- pttype(gtbindid(b));
- plist(pconstr, gtbindl(b));
- break;
- case ntbind:
- PUTTAG('q');
- plineno(gntline(b));
- plist(pttype,gntbindcty(b));
- pmaybe_list(pid, gntbindd(b));
- pttype(gntbindid(b));
- plist(pconstr, gntbindcty(b));
- break;
- case nbind :
- PUTTAG('n');
- plineno(gnline(b));
- pttype(gnbindid(b));
- pttype(gnbindas(b));
- break;
- case pbind :
- PUTTAG('p');
- ptree( gpbindl(b) );
- pgrhsb( gpbindr(b) );
- plineno(gpline(b));
- break;
- case fbind :
- PUTTAG('f');
- plist(ppmatch, gfbindm(b));
- plineno(gfline(b));
- break;
- case abind :
- PUTTAG('A');
- prbind(gabindfst(b));
- prbind(gabindsnd(b));
- break;
- case ibind :
- PUTTAG('%');
- plineno(giline(b));
- pttype(gibindi(b));
- prbind(gibindw(b));
- /* ppragma(gipragma(b)); */
- break;
- case dbind :
- PUTTAG('D');
- plineno(gdline(b));
- plist(pttype,gdbindts(b));
- break;
-
- case cbind :
- PUTTAG('$');
- plineno(gcline(b));
- plist(pttype,gcbindc(b));
- pttype(gcbindid(b));
- prbind(gcbindw(b));
- break;
-
- /* signature(-like) things, including user pragmas */
- case sbind :
- PUTTAG('r');
- plineno(gsline(b));
- plist(pqid,gsbindids(b));
- pttype(gsbindid(b));
- break;
-
- case nullbind :
- PUTTAG('B');
- break;
-
- case fixd:
- PUTTAG('I');
- pqid(gfixop(b));
- printf("%lu\t%lu",gfixinfx(b),gfixprec(b));
- break;
-
- case import:
- PUTTAG('e');
- plineno(gibindline(b));
- /* pid(gibindfile(b)); */
- pid(gibindimod(b));
- printf("#%lu\t",gibindqual(b)); /* 1 -- qualified */
- printf("#%lu\t",gibindsource(b)); /* 1 -- from source */
- pmaybe(pid, gibindas(b));
- pmaybe(pconstr, gibindspec(b));
- /* plist(pentid,giebindexp(b)); ??? */
- /* prbind(giebinddef(b)); ???? */
- break;
-
- /* User pragmas till the end */
-
- case vspec_uprag:
- PUTTAGSTR("Ss");
- plineno(gvspec_line(b));
- pqid(gvspec_id(b));
- plist(pttype,gvspec_tys(b));
- break;
- case vspec_ty_and_id:
- PUTTAGSTR("St");
- pttype(gvspec_ty(b));
- pmaybe(pttype,gvspec_tyid(b));
- break;
-
- case ispec_uprag:
- PUTTAGSTR("SS");
- plineno(gispec_line(b));
- pttype(gispec_ty(b));
- break;
- case inline_uprag:
- PUTTAGSTR("Si");
- plineno(ginline_line(b));
- pqid(ginline_id(b));
- break;
- case magicuf_uprag:
- PUTTAGSTR("Su");
- plineno(gmagicuf_line(b));
- pqid(gmagicuf_id(b));
- pid(gmagicuf_str(b));
- break;
- case dspec_uprag:
- PUTTAGSTR("Sd");
- plineno(gdspec_line(b));
- pqid(gdspec_id(b));
- plist(pttype,gdspec_tys(b));
- break;
-
- /* end of signature(-like) things */
-/* not used:
- case mbind:
- PUTTAG('7');
- plineno(gmline(b));
- pid(gmbindmodn(b));
- plist(pentid,gmbindimp(b));
- break;
-*/
- default : error("Bad prbind");
- break;
- }
-}
-
-static void
-pttype(t)
- ttype t;
-{
- switch (tttype(t)) {
- case tname : PUTTAG('T');
- pqid(gtypeid(t));
- break;
- case namedtvar : PUTTAG('y');
- pstr(gnamedtvar(t));
- break;
- case tllist : PUTTAG(':');
- pttype(gtlist(t));
- break;
- case ttuple : PUTTAG(',');
- plist(pttype,gttuple(t));
- break;
- case tfun : PUTTAG('>');
- pttype(gtin(t));
- pttype(gtout(t));
- break;
- case tapp : PUTTAG('@');
- pttype(gtapp(t));
- pttype(gtarg(t));
- break;
- case tbang : PUTTAG('!');
- pttype(gtbang(t));
- break;
- case forall : PUTTAG('3');
- plist(pstr, gtforalltv(t));
- plist(pttype,gtforallctxt(t));
- pttype(gtforallt(t));
- break;
- default : error("bad pttype");
- }
-}
-
-static void
-pconstr(a)
- constr a;
-{
- switch (tconstr(a)) {
- case constrpre :
- PUTTAG('1');
- plineno(gconcline(a));
- pqid(gconcid(a));
- plist(pttype, gconctypel(a));
- break;
- case constrinf :
- PUTTAG('2');
- plineno(gconiline(a));
- pqid(gconiop(a));
- pttype(gconity1(a));
- pttype(gconity2(a));
- break;
-
- case constrrec :
- PUTTAG('u');
- plineno(gconrline(a));
- pqid(gconrid(a));
- plist(pqid,gconrfieldl(a));
- break;
- case constrnew :
- PUTTAG('v');
- plineno(gconnline(a));
- pqid(gconnid(a));
- pttype(gconnty(a));
- break;
- case field :
- PUTTAG('5');
- plist(pqid,gfieldn(a));
- pttype(gfieldt(a));
- break;
- default : fprintf(stderr, "Bad tag in abstree %d\n", tconstr(a));
- exit(1);
- }
-}
-
-
-static void
-pentid(i)
- entidt i;
-{
- switch (tentidt(i)) {
- case entid : PUTTAG('x');
- pqid(gentid(i));
- break;
- case enttype : PUTTAG('X');
- pqid(gtentid(i));
- break;
- case enttypeall : PUTTAG('z');
- pqid(gaentid(i));
- break;
- case enttypenamed:PUTTAG('8');
- pqid(gnentid(i));
- plist(pqid,gnentnames(i));
- break;
- case entmod : PUTTAG('m');
- pid(gmentid(i));
- break;
- default :
- error("Bad pentid");
- }
-}
-
-
-static void ppmatch(l) match l; { fprintf( stderr, "printtree.c: ppmatch" ); }
-static void ppgdexp(l) gdexp l; { fprintf( stderr, "printtree.c: ppgdexp" ); }
-static void pgrhsb(l) grhsb l; { fprintf( stderr, "printtree.c: pgrhsb" ); }
-
-static void
-pgrhses(l)
- list l;
-{
- ptree(lhd(l)); /* Guard */
- ptree(lhd(ltl(l))); /* Expression */
-}
-/*
-static void
-ppragma(p)
- hpragma p;
-{
- switch(thpragma(p)) {
- case no_pragma: PUTTAGSTR("PN");
- break;
- case idata_pragma: PUTTAGSTR("Pd");
- plist(pconstr, gprag_data_constrs(p));
- plist(ppragma, gprag_data_specs(p));
- break;
- case itype_pragma: PUTTAGSTR("Pt");
- break;
- case iclas_pragma: PUTTAGSTR("Pc");
- plist(ppragma, gprag_clas(p));
- break;
- case iclasop_pragma: PUTTAGSTR("Po");
- ppragma(gprag_dsel(p));
- ppragma(gprag_defm(p));
- break;
-
- case iinst_simpl_pragma: PUTTAGSTR("Pis");
-/ * pid(gprag_imod_simpl(p));
-* / ppragma(gprag_dfun_simpl(p));
- break;
- case iinst_const_pragma: PUTTAGSTR("Pic");
-/ * pid(gprag_imod_const(p));
-* / ppragma(gprag_dfun_const(p));
- plist(ppragma, gprag_constms(p));
- break;
-
- case igen_pragma: PUTTAGSTR("Pg");
- ppragma(gprag_arity(p));
- ppragma(gprag_update(p));
- ppragma(gprag_strictness(p));
- ppragma(gprag_unfolding(p));
- plist(ppragma, gprag_specs(p));
- break;
- case iarity_pragma: PUTTAGSTR("PA");
- pid(gprag_arity_val(p));
- break;
- case iupdate_pragma: PUTTAGSTR("Pu");
- pid(gprag_update_val(p));
- break;
- case istrictness_pragma: PUTTAGSTR("PS");
- print_string(gprag_strict_spec(p));
- ppragma(gprag_strict_wrkr(p));
- break;
- case imagic_unfolding_pragma: PUTTAGSTR("PM");
- pid(gprag_magic_str(p));
- break;
-
- case iunfolding_pragma: PUTTAGSTR("PU");
- ppragma(gprag_unfold_guide(p));
- pcoresyn(gprag_unfold_core(p));
- break;
-
- case iunfold_always: PUTTAGSTR("Px");
- break;
- case iunfold_if_args: PUTTAGSTR("Py");
- pid(gprag_unfold_if_t_args(p));
- pid(gprag_unfold_if_v_args(p));
- pid(gprag_unfold_if_con_args(p));
- pid(gprag_unfold_if_size(p));
- break;
-
- case iname_pragma_pr: PUTTAGSTR("P1");
- pid(gprag_name_pr1(p));
- ppragma(gprag_name_pr2(p));
- break;
- case itype_pragma_pr: PUTTAGSTR("P2");
- plist(pttype, gprag_type_pr1(p));
- pid(gprag_type_pr2(p));
- ppragma(gprag_type_pr3(p));
- break;
-
- case idata_pragma_4s: PUTTAGSTR("P4");
- plist(pttype, gprag_data_spec(p));
- break;
-
- default: error("Bad Pragma");
- }
-}
-*/
-
-static void
-pbool(b)
- BOOLEAN b;
-{
- if (b) {
- putchar('T');
- } else {
- putchar('F');
- }
-}
-
projects / ghc-hetmet.git / blobdiff