ghc/compiler/parser/printtree.c

   1 /**********************************************************************
   2 *                                                                     *
   3 *                                                                     *
   4 *      Syntax Tree Printing Routines                                  *
   5 *                                                                     *
   6 *                                                                     *
   7 **********************************************************************/
   8
   9
  10 #define COMPACT TRUE    /* No spaces in output -- #undef this for debugging */
  11
  12
  13 #include <stdio.h>
  14
  15 #include "hspincl.h"
  16 #include "constants.h"
  17 #include "utils.h"
  18
  19 /* fwd decls, necessary and otherwise */
  20 static void pbool   PROTO( (BOOLEAN) );
  21 static void pconstr PROTO( (constr) );
  22 /* static void pcoresyn PROTO((coresyn)); */
  23 static void pentid  PROTO( (entidt) );
  24 static void pgrhses PROTO( (list) );
  25 static void pid     PROTO( (id) );
  26 static void plist   PROTO( (void (*)(/*NOT WORTH IT: void * */), list) );
  27 static void pmaybe  PROTO( (void (*)(), maybe) );
  28 static void pmaybe_list  PROTO( (void (*)(), maybe) );
  29 /* static void ppragma PROTO( (hpragma) ); */
  30 static void pqid    PROTO( (qid) );
  31 static void prbind  PROTO( (binding) );
  32 static void pstr    PROTO( (char *) );
  33 static void ptree   PROTO( (tree) );
  34 static void ppgdexp  PROTO( (gdexp) );
  35 static void pgrhsb  PROTO( (grhsb) );
  36 static void ppmatch  PROTO( (match) );
  37 static void pttype  PROTO( (ttype) );
  38 static void plineno PROTO( (long) );
  39
  40 extern char *input_filename;
  41 extern BOOLEAN hashIds;
  42
  43 /*      How to print tags       */
  44
  45 #if COMPACT
  46 #define PUTTAG(c)       putchar(c);
  47 #define PUTTAGSTR(s)    printf("%s",(s));
  48 #else
  49 #define PUTTAG(c)       putchar(c); \
  50                         putchar(' ');
  51 #define PUTTAGSTR(s)    printf("%s",(s)); \
  52                         putchar(' ');
  53 #endif
  54
  55
  56 /*      Performs a post order walk of the tree
  57         to print it.
  58 */
  59
  60 void
  61 pprogram(t)
  62   tree t;
  63 {
  64     print_hash_table();
  65     ptree(t);
  66 }
  67
  68 /* print_string: we must escape \t and \\, as described in
  69    char/string lexer comments.  (WDP 94/11)
  70 */
  71 static void
  72 print_string(hstring str)
  73 {
  74     char *gs;
  75     char c;
  76     int i, str_length;
  77
  78     putchar('#');
  79     str_length = str->len;
  80     gs = str->bytes;
  81
  82     for (i = 0; i < str_length; i++) {
  83         c = gs[i];
  84         if ( c == '\t' ) {
  85             putchar('\\');
  86             putchar('t');
  87         } else if ( c == '\\' ) {
  88             putchar('\\');
  89             putchar('\\');
  90         } else {
  91             putchar(gs[i]);
  92         }
  93     }
  94     putchar('\t');
  95 }
  96
  97 static void
  98 plineno (l)
  99 long l;
 100 {
 101  printf("#%lu\t",l);
 102  return;
 103 }
 104
 105
 106 static int
 107 get_character(hstring str)
 108 {
 109     int c = (int)((str->bytes)[0]);
 110
 111     if (str->len != 1) { /* ToDo: assert */
 112         fprintf(stderr, "get_character: length != 1? (%ld: %s)\n", str->len, str->bytes);
 113     }
 114
 115     if (c < 0) {
 116         c += 256;       /* "This is not a hack" -- KH */
 117     }
 118
 119     return(c);
 120 }
 121
 122 static void
 123 pliteral(literal t)
 124 {
 125     switch(tliteral(t)) {
 126       case integer:
 127                       PUTTAG('4');
 128                       pstr(ginteger(t));
 129                       break;
 130       case intprim:
 131                       PUTTAG('H');
 132                       pstr(gintprim(t));
 133                       break;
 134       case floatr:
 135                       PUTTAG('F');
 136                       pstr(gfloatr(t));
 137                       break;
 138       case doubleprim:
 139                       PUTTAG('J');
 140                       pstr(gdoubleprim(t));
 141                       break;
 142       case floatprim:
 143                       PUTTAG('K');
 144                       pstr(gfloatprim(t));
 145                       break;
 146       case charr:
 147                       PUTTAG('C');
 148                       /* Changed %d to %u, since negative chars
 149                          make little sense -- KH @ 16/4/91
 150                       */
 151                       printf("#%u\t", get_character(gchar(t)));
 152                       break;
 153       case charprim:
 154                       PUTTAG('P');
 155                       printf("#%u\t", get_character(gcharprim(t)));
 156                       break;
 157       case string:
 158                       PUTTAG('S');
 159                       print_string(gstring(t));
 160                       break;
 161       case stringprim:
 162                       PUTTAG('V');
 163                       print_string(gstringprim(t));
 164                       break;
 165       case clitlit:
 166                       PUTTAG('Y');
 167                       pstr(gclitlit(t));
 168                       /* pstr(gclitlit_kind(t)); */
 169                       break;
 170       default:
 171                       error("Bad pliteral");
 172     }
 173 }
 174
 175 static void
 176 ptree(t)
 177   tree t;
 178 {
 179 again:
 180     switch(ttree(t)) {
 181       case hmodule:
 182                       PUTTAG('M');
 183                       plineno(ghmodline(t));
 184                       pid(ghname(t));
 185                       printf("#%lu\t",ghversion(t));
 186                       pstr(input_filename);
 187                       prbind(ghmodlist(t));
 188                       /* pfixes(); */
 189                       plist(prbind, ghimplist(t));
 190                       pmaybe_list(pentid, ghexplist(t));
 191                       break;
 192       case ident:
 193                       PUTTAG('i');
 194                       pqid(gident(t));
 195                       break;
 196       case lit:
 197                       PUTTAG('C');
 198                       pliteral(glit(t));
 199                       break;
 200
 201       case ap:
 202                       PUTTAG('a');
 203                       ptree(gfun(t));
 204                       ptree(garg(t));
 205                       break;
 206       case infixap:
 207                       PUTTAG('@');
 208                       pqid(ginffun(t));
 209                       ptree(ginfarg1(t));
 210                       ptree(ginfarg2(t));
 211                       break;
 212       case negate:
 213                       PUTTAG('-');
 214                       ptree(gnexp(t));
 215                       break;
 216       case lambda:
 217                       PUTTAG('l');
 218                       ppmatch(glammatch(t));
 219                       break;
 220
 221       case let:
 222                       PUTTAG('E');
 223                       prbind(gletvdefs(t));
 224                       ptree(gletvexpr(t));
 225                       break;
 226       case casee:
 227                       PUTTAG('c');
 228                       plineno(gcaseline(t));
 229                       ptree(gcaseexpr(t));
 230                       plist(ppmatch, gcasebody(t));
 231                       break;
 232       case ife:
 233                       PUTTAG('b');
 234                       ptree(gifpred(t));
 235                       ptree(gifthen(t));
 236                       ptree(gifelse(t));
 237                       break;
 238       case doe:
 239                       PUTTAG('O');
 240                       plineno(gdoline(t));
 241                       plist(ptree, gdo(t));
 242                       break;
 243       case dobind:
 244                       PUTTAG('Q');
 245                       plineno(gdobindline(t));
 246                       ptree(gdobindpat(t));
 247                       ptree(gdobindexp(t));
 248                       break;
 249       case doexp:
 250                       PUTTAG('R');
 251                       plineno(gdoexpline(t));
 252                       ptree(gdoexp(t));
 253                       break;
 254       case seqlet:
 255                       PUTTAG('U');
 256                       prbind(gseqlet(t));
 257                       break;
 258       case record:
 259                       PUTTAG('d');
 260                       pqid(grcon(t));
 261                       plist(prbind,grbinds(t));
 262                       break;
 263
 264       case rupdate:
 265                       PUTTAG('h');
 266                       ptree(gupdexp(t));
 267                       plist(prbind,gupdbinds(t));
 268                       break;
 269
 270       case rbind:
 271                       PUTTAG('o');
 272                       pqid(grbindvar(t));
 273                       pmaybe(ptree,grbindexp(t));
 274                       break;
 275
 276       case par:       t = gpare(t); goto again;
 277
 278       case as:
 279                       PUTTAG('s');
 280                       pqid(gasid(t));
 281                       ptree(gase(t));
 282                       break;
 283       case lazyp:
 284                       PUTTAG('~');
 285                       ptree(glazyp(t));
 286                       break;
 287       case wildp:
 288                       PUTTAG('_');
 289                       break;
 290
 291       case restr:
 292                       PUTTAG('R');
 293                       ptree(grestre(t));
 294                       pttype(grestrt(t));
 295                       break;
 296       case tuple:
 297                       PUTTAG(',');
 298                       plist(ptree,gtuplelist(t));
 299                       break;
 300       case llist:
 301                       PUTTAG(':');
 302                       plist(ptree,gllist(t));
 303                       break;
 304       case eenum:
 305                       PUTTAG('.');
 306                       ptree(gefrom(t));
 307                       pmaybe(ptree,gestep(t));
 308                       pmaybe(ptree,geto(t));
 309                       break;
 310       case comprh:
 311                       PUTTAG('Z');
 312                       ptree(gcexp(t));
 313                       plist(ptree,gcquals(t));
 314                       break;
 315       case qual:
 316                       PUTTAG('G');
 317                       ptree(gqpat(t));
 318                       ptree(gqexp(t));
 319                       break;
 320       case guard:
 321                       PUTTAG('g');
 322                       ptree(ggexp(t));
 323                       break;
 324       case lsection:
 325                       PUTTAG('(');
 326                       ptree(glsexp(t));
 327                       pqid(glsop(t));
 328                       break;
 329       case rsection:
 330                       PUTTAG(')');
 331                       pqid(grsop(t));
 332                       ptree(grsexp(t));
 333                       break;
 334       case ccall:
 335                       PUTTAG('j');
 336                       pstr(gccid(t));
 337                       pstr(gccinfo(t));
 338                       plist(ptree,gccargs(t));
 339                       break;
 340       case scc:
 341                       PUTTAG('k');
 342                       print_string(gsccid(t));
 343                       ptree(gsccexp(t));
 344                       break;
 345       default:
 346                       error("Bad ptree");
 347     }
 348 }
 349
 350 static void
 351 plist(fun, l)
 352   void (*fun)(/* NOT WORTH IT: void * */);
 353   list l;
 354 {
 355     if (tlist(l) == lnil) {
 356         PUTTAG('N');
 357     } else  {
 358         PUTTAG('L');
 359         (*fun)(lhd(l));
 360         plist(fun, ltl(l));
 361     }
 362 }
 363
 364 static void
 365 pmaybe(fun, m)
 366   void (*fun)(/* NOT WORTH IT: void * */);
 367   maybe m;
 368 {
 369     if (tmaybe(m) == nothing) {
 370         PUTTAG('N');
 371     } else  {
 372         PUTTAG('J');
 373         (*fun)(gthing(m));
 374     }
 375 }
 376
 377 static void
 378 pmaybe_list(fun, m)
 379   void (*fun)(/* NOT WORTH IT: void * */);
 380   maybe m;
 381 {
 382     if (tmaybe(m) == nothing) {
 383         PUTTAG('N');
 384     } else  {
 385         PUTTAG('J');
 386         plist(fun, gthing(m));
 387     }
 388 }
 389
 390 static void
 391 pid(i)
 392   id i;
 393 {
 394   if(hashIds)
 395         printf("!%lu\t", hash_index(i));
 396   else
 397         printf("#%s\t", id_to_string(i));
 398 }
 399
 400 static void
 401 pqid(i)
 402   qid i;
 403 {
 404   if(hashIds)
 405         printf("!%lu\t", hash_index(qid_to_id(i)));
 406   else
 407         printf("#%s\t", qid_to_string(i));
 408 }
 409
 410 static void
 411 pstr(i)
 412   char *i;
 413 {
 414         printf("#%s\t", i);
 415 }
 416
 417 static void
 418 prbind(b)
 419   binding b;
 420 {
 421         switch(tbinding(b)) {
 422         case tbind:
 423                           PUTTAG('t');
 424                           plineno(gtline(b));
 425                           plist(pttype, gtbindc(b));
 426                           pmaybe_list(pid, gtbindd(b));
 427                           pttype(gtbindid(b));
 428                           plist(pconstr, gtbindl(b));
 429                           break;
 430         case ntbind:
 431                           PUTTAG('q');
 432                           plineno(gntline(b));
 433                           plist(pttype,gntbindcty(b));
 434                           pmaybe_list(pid, gntbindd(b));
 435                           pttype(gntbindid(b));
 436                           plist(pconstr, gntbindcty(b));
 437                           break;
 438         case nbind      :
 439                           PUTTAG('n');
 440                           plineno(gnline(b));
 441                           pttype(gnbindid(b));
 442                           pttype(gnbindas(b));
 443                           break;
 444         case pbind      :
 445                           PUTTAG('p');
 446                           ptree( gpbindl(b) );
 447                           pgrhsb( gpbindr(b) );
 448                           plineno(gpline(b));
 449                           break;
 450         case fbind      :
 451                           PUTTAG('f');
 452                           plist(ppmatch, gfbindm(b));
 453                           plineno(gfline(b));
 454                           break;
 455         case abind      :
 456                           PUTTAG('A');
 457                           prbind(gabindfst(b));
 458                           prbind(gabindsnd(b));
 459                           break;
 460         case ibind      :
 461                           PUTTAG('%');
 462                           plineno(giline(b));
 463                           pttype(gibindi(b));
 464                           prbind(gibindw(b));
 465                           /* ppragma(gipragma(b)); */
 466                           break;
 467         case dbind      :
 468                           PUTTAG('D');
 469                           plineno(gdline(b));
 470                           plist(pttype,gdbindts(b));
 471                           break;
 472
 473         case cbind      :
 474                           PUTTAG('$');
 475                           plineno(gcline(b));
 476                           plist(pttype,gcbindc(b));
 477                           pttype(gcbindid(b));
 478                           prbind(gcbindw(b));
 479                           break;
 480
 481         /* signature(-like) things, including user pragmas */
 482         case sbind      :
 483                           PUTTAG('r');
 484                           plineno(gsline(b));
 485                           plist(pqid,gsbindids(b));
 486                           pttype(gsbindid(b));
 487                           break;
 488
 489         case nullbind   :
 490                           PUTTAG('B');
 491                           break;
 492
 493         case fixd:
 494                       PUTTAG('I');
 495                       pqid(gfixop(b));
 496                       printf("%lu\t%lu",gfixinfx(b),gfixprec(b));
 497                       break;
 498
 499         case import:
 500                           PUTTAG('e');
 501                           plineno(gibindline(b));
 502                           /* pid(gibindfile(b)); */
 503                           pid(gibindimod(b));
 504                           printf("#%lu\t",gibindqual(b)); /* 1 -- qualified */
 505                           printf("#%lu\t",gibindsource(b)); /* 1 -- from source */
 506                           pmaybe(pid, gibindas(b));
 507                           pmaybe(pconstr, gibindspec(b));
 508                           /* plist(pentid,giebindexp(b)); ??? */
 509                           /* prbind(giebinddef(b)); ???? */
 510                           break;
 511
 512          /* User pragmas till the end */
 513
 514         case vspec_uprag:
 515                           PUTTAGSTR("Ss");
 516                           plineno(gvspec_line(b));
 517                           pqid(gvspec_id(b));
 518                           plist(pttype,gvspec_tys(b));
 519                           break;
 520         case vspec_ty_and_id:
 521                           PUTTAGSTR("St");
 522                           pttype(gvspec_ty(b));
 523                           pmaybe(pttype,gvspec_tyid(b));
 524                           break;
 525
 526         case ispec_uprag:
 527                           PUTTAGSTR("SS");
 528                           plineno(gispec_line(b));
 529                           pttype(gispec_ty(b));
 530                           break;
 531         case inline_uprag:
 532                           PUTTAGSTR("Si");
 533                           plineno(ginline_line(b));
 534                           pqid(ginline_id(b));
 535                           break;
 536         case magicuf_uprag:
 537                           PUTTAGSTR("Su");
 538                           plineno(gmagicuf_line(b));
 539                           pqid(gmagicuf_id(b));
 540                           pid(gmagicuf_str(b));
 541                           break;
 542         case dspec_uprag:
 543                           PUTTAGSTR("Sd");
 544                           plineno(gdspec_line(b));
 545                           pqid(gdspec_id(b));
 546                           plist(pttype,gdspec_tys(b));
 547                           break;
 548
 549         /* end of signature(-like) things */
 550 /* not used:
 551         case mbind:
 552                           PUTTAG('7');
 553                           plineno(gmline(b));
 554                           pid(gmbindmodn(b));
 555                           plist(pentid,gmbindimp(b));
 556                           break;
 557 */
 558         default         : error("Bad prbind");
 559                           break;
 560         }
 561 }
 562
 563 static void
 564 pttype(t)
 565   ttype t;
 566 {
 567         switch (tttype(t)) {
 568         case tname      : PUTTAG('T');
 569                           pqid(gtypeid(t));
 570                           break;
 571         case namedtvar  : PUTTAG('y');
 572                           pstr(gnamedtvar(t));
 573                           break;
 574         case tllist     : PUTTAG(':');
 575                           pttype(gtlist(t));
 576                           break;
 577         case ttuple     : PUTTAG(',');
 578                           plist(pttype,gttuple(t));
 579                           break;
 580         case tfun       : PUTTAG('>');
 581                           pttype(gtin(t));
 582                           pttype(gtout(t));
 583                           break;
 584         case tapp       : PUTTAG('@');
 585                           pttype(gtapp(t));
 586                           pttype(gtarg(t));
 587                           break;
 588         case tbang      : PUTTAG('!');
 589                           pttype(gtbang(t));
 590                           break;
 591         case forall     : PUTTAG('3');
 592                           plist(pstr, gtforalltv(t));
 593                           plist(pttype,gtforallctxt(t));
 594                           pttype(gtforallt(t));
 595                           break;
 596         default         : error("bad pttype");
 597         }
 598 }
 599
 600 static void
 601 pconstr(a)
 602   constr a;
 603 {
 604         switch (tconstr(a)) {
 605         case constrpre  :
 606                           PUTTAG('1');
 607                           plineno(gconcline(a));
 608                           pqid(gconcid(a));
 609                           plist(pttype, gconctypel(a));
 610                           break;
 611         case constrinf  :
 612                           PUTTAG('2');
 613                           plineno(gconiline(a));
 614                           pqid(gconiop(a));
 615                           pttype(gconity1(a));
 616                           pttype(gconity2(a));
 617                           break;
 618
 619         case constrrec  :
 620                           PUTTAG('u');
 621                           plineno(gconrline(a));
 622                           pqid(gconrid(a));
 623                           plist(pqid,gconrfieldl(a));
 624                           break;
 625         case constrnew  :
 626                           PUTTAG('v');
 627                           plineno(gconnline(a));
 628                           pqid(gconnid(a));
 629                           pttype(gconnty(a));
 630                           break;
 631         case field      :
 632                           PUTTAG('5');
 633                           plist(pqid,gfieldn(a));
 634                           pttype(gfieldt(a));
 635                           break;
 636         default         : fprintf(stderr, "Bad tag in abstree %d\n", tconstr(a));
 637                           exit(1);
 638         }
 639 }
 640
 641
 642 static void
 643 pentid(i)
 644   entidt i;
 645 {
 646         switch (tentidt(i)) {
 647         case entid      : PUTTAG('x');
 648                           pqid(gentid(i));
 649                           break;
 650         case enttype    : PUTTAG('X');
 651                           pqid(gtentid(i));
 652                           break;
 653         case enttypeall : PUTTAG('z');
 654                           pqid(gaentid(i));
 655                           break;
 656         case enttypenamed:PUTTAG('8');
 657                           pqid(gnentid(i));
 658                           plist(pqid,gnentnames(i));
 659                           break;
 660         case entmod     : PUTTAG('m');
 661                           pid(gmentid(i));
 662                           break;
 663         default         :
 664                           error("Bad pentid");
 665         }
 666 }
 667
 668
 669 static void ppmatch(l) match l; { fprintf( stderr, "printtree.c: ppmatch" ); }
 670 static void ppgdexp(l) gdexp l; { fprintf( stderr, "printtree.c: ppgdexp" ); }
 671 static void pgrhsb(l) grhsb l; { fprintf( stderr, "printtree.c: pgrhsb" ); }
 672
 673 static void
 674 pgrhses(l)
 675   list l;
 676 {
 677   ptree(lhd(l));                /* Guard */
 678   ptree(lhd(ltl(l)));           /* Expression */
 679 }
 680 /*
 681 static void
 682 ppragma(p)
 683   hpragma p;
 684 {
 685     switch(thpragma(p)) {
 686       case no_pragma:           PUTTAGSTR("PN");
 687                                 break;
 688       case idata_pragma:        PUTTAGSTR("Pd");
 689                                 plist(pconstr, gprag_data_constrs(p));
 690                                 plist(ppragma, gprag_data_specs(p));
 691                                 break;
 692       case itype_pragma:        PUTTAGSTR("Pt");
 693                                 break;
 694       case iclas_pragma:        PUTTAGSTR("Pc");
 695                                 plist(ppragma, gprag_clas(p));
 696                                 break;
 697       case iclasop_pragma:      PUTTAGSTR("Po");
 698                                 ppragma(gprag_dsel(p));
 699                                 ppragma(gprag_defm(p));
 700                                 break;
 701
 702       case iinst_simpl_pragma:  PUTTAGSTR("Pis");
 703 / *                             pid(gprag_imod_simpl(p));
 704 * /                             ppragma(gprag_dfun_simpl(p));
 705                                 break;
 706       case iinst_const_pragma:  PUTTAGSTR("Pic");
 707 / *                             pid(gprag_imod_const(p));
 708 * /                             ppragma(gprag_dfun_const(p));
 709                                 plist(ppragma, gprag_constms(p));
 710                                 break;
 711
 712       case igen_pragma:         PUTTAGSTR("Pg");
 713                                 ppragma(gprag_arity(p));
 714                                 ppragma(gprag_update(p));
 715                                 ppragma(gprag_strictness(p));
 716                                 ppragma(gprag_unfolding(p));
 717                                 plist(ppragma, gprag_specs(p));
 718                                 break;
 719       case iarity_pragma:       PUTTAGSTR("PA");
 720                                 pid(gprag_arity_val(p));
 721                                 break;
 722       case iupdate_pragma:      PUTTAGSTR("Pu");
 723                                 pid(gprag_update_val(p));
 724                                 break;
 725       case istrictness_pragma:  PUTTAGSTR("PS");
 726                                 print_string(gprag_strict_spec(p));
 727                                 ppragma(gprag_strict_wrkr(p));
 728                                 break;
 729       case imagic_unfolding_pragma: PUTTAGSTR("PM");
 730                                 pid(gprag_magic_str(p));
 731                                 break;
 732
 733       case iunfolding_pragma:   PUTTAGSTR("PU");
 734                                 ppragma(gprag_unfold_guide(p));
 735                                 pcoresyn(gprag_unfold_core(p));
 736                                 break;
 737
 738       case iunfold_always:      PUTTAGSTR("Px");
 739                                 break;
 740       case iunfold_if_args:     PUTTAGSTR("Py");
 741                                 pid(gprag_unfold_if_t_args(p));
 742                                 pid(gprag_unfold_if_v_args(p));
 743                                 pid(gprag_unfold_if_con_args(p));
 744                                 pid(gprag_unfold_if_size(p));
 745                                 break;
 746
 747       case iname_pragma_pr:     PUTTAGSTR("P1");
 748                                 pid(gprag_name_pr1(p));
 749                                 ppragma(gprag_name_pr2(p));
 750                                 break;
 751       case itype_pragma_pr:     PUTTAGSTR("P2");
 752                                 plist(pttype, gprag_type_pr1(p));
 753                                 pid(gprag_type_pr2(p));
 754                                 ppragma(gprag_type_pr3(p));
 755                                 break;
 756
 757       case idata_pragma_4s:     PUTTAGSTR("P4");
 758                                 plist(pttype, gprag_data_spec(p));
 759                                 break;
 760
 761       default:                  error("Bad Pragma");
 762       }
 763 }
 764 */
 765
 766 static void
 767 pbool(b)
 768   BOOLEAN b;
 769 {
 770     if (b) {
 771       putchar('T');
 772     } else {
 773       putchar('F');
 774     }
 775 }
 776