ghc/compiler/yaccParser/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 ptree   PROTO( (tree) );
  21 static void plist   PROTO( (void (*)(/*NOT WORTH IT: void * */), list) );
  22 static void pid     PROTO( (id) );
  23 static void pstr    PROTO( (char *) );
  24 static void pbool   PROTO( (BOOLEAN) );
  25 static void prbind  PROTO( (binding) );
  26 static void pttype  PROTO( (ttype) );
  27 static void patype  PROTO( (atype) );
  28 static void pentid  PROTO( (entidt) );
  29 static void prename PROTO( (list) );
  30 static void pfixes  PROTO( (void) );
  31 static void ppbinding PROTO((pbinding));
  32 static void pgrhses PROTO( (list) );
  33 static void ppragma PROTO( (hpragma) );
  34 static void pcoresyn PROTO((coresyn));
  35
  36 extern char *fixop   PROTO((int));
  37 extern char *fixtype PROTO((int));
  38
  39 extern char *input_filename;
  40 extern BOOLEAN hashIds;
  41
  42 /*      How to print tags       */
  43
  44 #if COMPACT
  45 #define PUTTAG(c)       putchar(c);
  46 #define PUTTAGSTR(s)    printf("%s",(s));
  47 #else
  48 #define PUTTAG(c)       putchar(c); \
  49                         putchar(' ');
  50 #define PUTTAGSTR(s)    printf("%s",(s)); \
  51                         putchar(' ');
  52 #endif
  53
  54
  55 /*      Performs a post order walk of the tree
  56         to print it.
  57 */
  58
  59 void
  60 pprogram(t)
  61 tree t;
  62 {
  63   print_hash_table();
  64   ptree(t);
  65 }
  66
  67 /* print_string: we must escape \t and \\, as described in
  68    char/string lexer comments.  (WDP 94/11)
  69 */
  70 static void
  71 print_string(hstring str)
  72 {
  73     char *gs;
  74     char c;
  75     int i, str_length;
  76
  77     putchar('#');
  78     str_length = str->len;
  79     gs = str->bytes;
  80
  81     for (i = 0; i < str_length; i++) {
  82         c = gs[i];
  83         if ( c == '\t' ) {
  84             putchar('\\');
  85             putchar('t');
  86         } else if ( c == '\\' ) {
  87             putchar('\\');
  88             putchar('\\');
  89         } else {
  90             putchar(gs[i]);
  91         }
  92     }
  93     putchar('\t');
  94 }
  95
  96 static int
  97 get_character(hstring str)
  98 {
  99     int c = (int)((str->bytes)[0]);
 100
 101     if (str->len != 1) { /* ToDo: assert */
 102         fprintf(stderr, "get_character: length != 1? (%ld: %s)\n", str->len, str->bytes);
 103     }
 104
 105     if (c < 0) {
 106         c += 256;       /* "This is not a hack" -- KH */
 107     }
 108
 109     return(c);
 110 }
 111
 112 static void
 113 pliteral(literal t)
 114 {
 115     switch(tliteral(t)) {
 116       case integer:
 117                       PUTTAG('4');
 118                       pstr(ginteger(t));
 119                       break;
 120       case intprim:
 121                       PUTTAG('H');
 122                       pstr(gintprim(t));
 123                       break;
 124       case floatr:
 125                       PUTTAG('F');
 126                       pstr(gfloatr(t));
 127                       break;
 128       case doubleprim:
 129                       PUTTAG('J');
 130                       pstr(gdoubleprim(t));
 131                       break;
 132       case floatprim:
 133                       PUTTAG('K');
 134                       pstr(gfloatprim(t));
 135                       break;
 136       case charr:
 137                       PUTTAG('C');
 138                       /* Changed %d to %u, since negative chars
 139                          make little sense -- KH @ 16/4/91
 140                       */
 141                       printf("#%u\t", get_character(gchar(t)));
 142                       break;
 143       case charprim:
 144                       PUTTAG('P');
 145                       printf("#%u\t", get_character(gcharprim(t)));
 146                       break;
 147       case string:
 148                       PUTTAG('S');
 149                       print_string(gstring(t));
 150                       break;
 151       case stringprim:
 152                       PUTTAG('V');
 153                       print_string(gstringprim(t));
 154                       break;
 155       case clitlit:
 156                       PUTTAG('Y');
 157                       pstr(gclitlit(t));
 158                       pstr(gclitlit_kind(t));
 159                       break;
 160
 161       case norepi:
 162                       PUTTAG('I');
 163                       pstr(gnorepi(t));
 164                       break;
 165       case norepr:
 166                       PUTTAG('R');
 167                       pstr(gnorepr_n(t));
 168                       pstr(gnorepr_d(t));
 169                       break;
 170       case noreps:
 171                       PUTTAG('s');
 172                       print_string(gnoreps(t));
 173                       break;
 174       default:
 175                       error("Bad pliteral");
 176     }
 177 }
 178
 179 static void
 180 ptree(t)
 181    tree t;
 182 {
 183 again:
 184     switch(ttree(t)) {
 185       case par:         t = gpare(t); goto again;
 186       case hmodule:
 187                       PUTTAG('M');
 188                       printf("#%lu\t",ghmodline(t));
 189                       pid(ghname(t));
 190                       pstr(input_filename);
 191                       prbind(ghmodlist(t));
 192                       pfixes();
 193                       plist(prbind, ghimplist(t));
 194                       plist(pentid, ghexplist(t));
 195                       break;
 196       case ident:
 197                       PUTTAG('i');
 198                       pid(gident(t));
 199                       break;
 200       case lit:
 201                       PUTTAG('C');
 202                       pliteral(glit(t));
 203                       break;
 204
 205       case ap:
 206                       PUTTAG('a');
 207                       ptree(gfun(t));
 208                       ptree(garg(t));
 209                       break;
 210       case lsection:
 211                       PUTTAG('(');
 212                       ptree(glsexp(t));
 213                       pid(glsop(t));
 214                       break;
 215       case rsection:
 216                       PUTTAG(')');
 217                       pid(grsop(t));
 218                       ptree(grsexp(t));
 219                       break;
 220       case tinfixop:
 221                       PUTTAG('@');
 222                       ptree(ginarg1((struct Sap *)t));
 223                       pid(gident(ginfun((struct Sap *)t)));
 224                       ptree(ginarg2((struct Sap *)t));
 225                       break;
 226
 227       case lambda:
 228                       PUTTAG('l');
 229                       printf("#%lu\t",glamline(t));
 230                       plist(ptree,glampats(t));
 231                       ptree(glamexpr(t));
 232                       break;
 233
 234       case let:
 235                       PUTTAG('E');
 236                       prbind(gletvdeflist(t));
 237                       ptree(gletvexpr(t));
 238                       break;
 239       case casee:
 240                       PUTTAG('c');
 241                       ptree(gcaseexpr(t));
 242                       plist(ppbinding, gcasebody(t));
 243                       break;
 244       case ife:
 245                       PUTTAG('b');
 246                       ptree(gifpred(t));
 247                       ptree(gifthen(t));
 248                       ptree(gifelse(t));
 249                       break;
 250       case tuple:
 251                       PUTTAG(',');
 252                       plist(ptree,gtuplelist(t));
 253                       break;
 254       case eenum:
 255                       PUTTAG('.');
 256                       ptree(gefrom(t));
 257                       plist(ptree,gestep(t));
 258                       plist(ptree,geto(t));
 259                       break;
 260       case llist:
 261                       PUTTAG(':');
 262                       plist(ptree,gllist(t));
 263                       break;
 264       case negate:
 265                       PUTTAG('-');
 266                       ptree(gnexp(t));
 267                       break;
 268       case comprh:
 269                       PUTTAG('Z');
 270                       ptree(gcexp(t));
 271                       plist(ptree,gcquals(t));
 272                       break;
 273       case qual:
 274                       PUTTAG('G');
 275                       ptree(gqpat(t));
 276                       ptree(gqexp(t));
 277                       break;
 278       case guard:
 279                       PUTTAG('g');
 280                       ptree(ggexp(t));
 281                       break;
 282       case def:
 283                       PUTTAG('=');
 284                       ptree(ggdef(t)); /* was: prbind (WDP 94/10) */
 285                       break;
 286       case as:
 287                       PUTTAG('s');
 288                       pid(gasid(t));
 289                       ptree(gase(t));
 290                       break;
 291       case lazyp:
 292                       PUTTAG('~');
 293                       ptree(glazyp(t));
 294                       break;
 295       case plusp:
 296                       PUTTAG('+');
 297                       ptree(gplusp(t));
 298                       pliteral(gplusi(t));
 299                       break;
 300       case wildp:
 301                       PUTTAG('_');
 302                       break;
 303       case restr:
 304                       PUTTAG('R');
 305                       ptree(grestre(t));
 306                       pttype(grestrt(t));
 307                       break;
 308       case ccall:
 309                       PUTTAG('j');
 310                       pstr(gccid(t));
 311                       pstr(gccinfo(t));
 312                       plist(ptree,gccargs(t));
 313                       break;
 314       case scc:
 315                       PUTTAG('k');
 316                       print_string(gsccid(t));
 317                       ptree(gsccexp(t));
 318                       break;
 319 #ifdef DPH
 320       case parzf:
 321                       PUTTAG('5');
 322                       ptree(gpzfexp(t));
 323                       plist(ptree,gpzfqual(t));
 324                       break;
 325       case pod:
 326                       PUTTAG('6');
 327                       plist(ptree,gpod(t));
 328                       break;
 329       case proc:
 330                       PUTTAG('O');
 331                       plist(ptree,gprocid(t));
 332                       ptree(gprocdata(t));
 333                       break;
 334       case pardgen:
 335                       PUTTAG('0');
 336                       ptree(gdproc(t));
 337                       ptree(gdexp(t));
 338                       break;
 339       case parigen:
 340                       PUTTAG('w');
 341                       ptree(giproc(t));
 342                       ptree(giexp(t));
 343                       break;
 344       case parfilt:
 345                       PUTTAG('I');
 346                       ptree(gpfilt(t));
 347                       break;
 348 #endif /* DPH */
 349
 350       default:
 351                       error("Bad ptree");
 352     }
 353 }
 354
 355 static void
 356 plist(fun, l)
 357   void (*fun)(/* NOT WORTH IT: void * */);
 358   list l;
 359 {
 360         if (tlist(l) == lcons) {
 361                 PUTTAG('L');
 362                 (*fun)(lhd(l));
 363                 plist(fun, ltl(l));
 364         } else  {
 365                 PUTTAG('N');
 366         }
 367 }
 368
 369 static void
 370 pid(i)
 371   id i;
 372 {
 373   if(hashIds)
 374         printf("!%lu\t", hash_index(i));
 375   else
 376         printf("#%s\t", id_to_string(i));
 377 }
 378
 379 static void
 380 pstr(i)
 381   char *i;
 382 {
 383         printf("#%s\t", i);
 384 }
 385
 386 static void
 387 prbind(b)
 388   binding b;
 389 {
 390         switch(tbinding(b)) {
 391         case tbind:
 392                           PUTTAG('t');
 393                           printf("#%lu\t",gtline(b));
 394                           plist(pttype, gtbindc(b));
 395                           plist(pid, gtbindd(b));
 396                           pttype(gtbindid(b));
 397                           plist(patype, gtbindl(b));
 398                           ppragma(gtpragma(b));
 399                           break;
 400         case nbind      :
 401                           PUTTAG('n');
 402                           printf("#%lu\t",gnline(b));
 403                           pttype(gnbindid(b));
 404                           pttype(gnbindas(b));
 405                           ppragma(gnpragma(b));
 406                           break;
 407         case pbind      :
 408                           PUTTAG('p');
 409                           printf("#%lu\t",gpline(b));
 410                           plist(ppbinding, gpbindl(b));
 411                           break;
 412         case fbind      :
 413                           PUTTAG('f');
 414                           printf("#%lu\t",gfline(b));
 415                           plist(ppbinding, gfbindl(b));
 416                           break;
 417         case abind      :
 418                           PUTTAG('A');
 419                           prbind(gabindfst(b));
 420                           prbind(gabindsnd(b));
 421                           break;
 422         case cbind      :
 423                           PUTTAG('$');
 424                           printf("#%lu\t",gcline(b));
 425                           plist(pttype,gcbindc(b));
 426                           pttype(gcbindid(b));
 427                           prbind(gcbindw(b));
 428                           ppragma(gcpragma(b));
 429                           break;
 430         case ibind      :
 431                           PUTTAG('%');
 432                           printf("#%lu\t",giline(b));
 433                           plist(pttype,gibindc(b));
 434                           pid(gibindid(b));
 435                           pttype(gibindi(b));
 436                           prbind(gibindw(b));
 437                           ppragma(gipragma(b));
 438                           break;
 439         case dbind      :
 440                           PUTTAG('D');
 441                           printf("#%lu\t",gdline(b));
 442                           plist(pttype,gdbindts(b));
 443                           break;
 444
 445         /* signature(-like) things, including user pragmas */
 446         case sbind      :
 447                           PUTTAGSTR("St");
 448                           printf("#%lu\t",gsline(b));
 449                           plist(pid,gsbindids(b));
 450                           pttype(gsbindid(b));
 451                           ppragma(gspragma(b));
 452                           break;
 453
 454         case vspec_uprag:
 455                           PUTTAGSTR("Ss");
 456                           printf("#%lu\t",gvspec_line(b));
 457                           pid(gvspec_id(b));
 458                           plist(pttype,gvspec_tys(b));
 459                           break;
 460         case ispec_uprag:
 461                           PUTTAGSTR("SS");
 462                           printf("#%lu\t",gispec_line(b));
 463                           pid(gispec_clas(b));
 464                           pttype(gispec_ty(b));
 465                           break;
 466         case inline_uprag:
 467                           PUTTAGSTR("Si");
 468                           printf("#%lu\t",ginline_line(b));
 469                           pid(ginline_id(b));
 470                           plist(pid,ginline_howto(b));
 471                           break;
 472         case deforest_uprag:
 473                           PUTTAGSTR("Sd");
 474                           printf("#%lu\t",gdeforest_line(b));
 475                           pid(gdeforest_id(b));
 476                           break;
 477         case magicuf_uprag:
 478                           PUTTAGSTR("Su");
 479                           printf("#%lu\t",gmagicuf_line(b));
 480                           pid(gmagicuf_id(b));
 481                           pid(gmagicuf_str(b));
 482                           break;
 483         case abstract_uprag:
 484                           PUTTAGSTR("Sa");
 485                           printf("#%lu\t",gabstract_line(b));
 486                           pid(gabstract_id(b));
 487                           break;
 488         case dspec_uprag:
 489                           PUTTAGSTR("Sd");
 490                           printf("#%lu\t",gdspec_line(b));
 491                           pid(gdspec_id(b));
 492                           plist(pttype,gdspec_tys(b));
 493                           break;
 494
 495         /* end of signature(-like) things */
 496
 497         case mbind:
 498                           PUTTAG('7');
 499                           printf("#%lu\t",gmline(b));
 500                           pid(gmbindmodn(b));
 501                           plist(pentid,gmbindimp(b));
 502                           plist(prename,gmbindren(b));
 503                           break;
 504         case import:
 505                           PUTTAG('e');
 506                           printf("#%lu\t",giebindline(b));
 507                           pstr(giebindfile(b));
 508                           pid(giebindmod(b));
 509                           plist(pentid,giebindexp(b));
 510                           plist(prename,giebindren(b));
 511                           prbind(giebinddef(b));
 512                           break;
 513         case hiding:
 514                           PUTTAG('h');
 515                           printf("#%lu\t",gihbindline(b));
 516                           pstr(gihbindfile(b));
 517                           pid(gihbindmod(b));
 518                           plist(pentid,gihbindexp(b));
 519                           plist(prename,gihbindren(b));
 520                           prbind(gihbinddef(b));
 521                           break;
 522         case nullbind   :
 523                           PUTTAG('B');
 524                           break;
 525         default         : error("Bad prbind");
 526                           break;
 527         }
 528 }
 529
 530 static void
 531 pttype(t)
 532   ttype t;
 533 {
 534         switch (tttype(t)) {
 535         case tname      : PUTTAG('T');
 536                           pid(gtypeid(t));
 537                           plist(pttype, gtypel(t));
 538                           break;
 539         case namedtvar  : PUTTAG('y');
 540                           pid(gnamedtvar(t));
 541                           break;
 542         case tllist     : PUTTAG(':');
 543                           pttype(gtlist(t));
 544                           break;
 545         case ttuple     : PUTTAG(',');
 546                           plist(pttype,gttuple(t));
 547                           break;
 548         case tfun       : PUTTAG('>');
 549                           pttype(gtfun(t));
 550                           pttype(gtarg(t));
 551                           break;
 552         case context    : PUTTAG('3');
 553                           plist(pttype,gtcontextl(t));
 554                           pttype(gtcontextt(t));
 555                           break;
 556
 557         case unidict    : PUTTAGSTR("2A");
 558                           pid(gunidict_clas(t));
 559                           pttype(gunidict_ty(t));
 560                           break;
 561         case unityvartemplate : PUTTAGSTR("2B");
 562                           pid(gunityvartemplate(t));
 563                           break;
 564         case uniforall  : PUTTAGSTR("2C");
 565                           plist(pid,guniforall_tv(t));
 566                           pttype(guniforall_ty(t));
 567                           break;
 568
 569         case ty_maybe_nothing : PUTTAGSTR("2D");
 570                           break;
 571         case ty_maybe_just: PUTTAGSTR("2E");
 572                           pttype(gty_maybe(t));
 573                           break;
 574
 575 #ifdef DPH
 576         case tproc      :
 577                           PUTTAG('u');
 578                           plist(pttype,gtpid(t));
 579                           pttype(gtdata(t));
 580                           break;
 581         case tpod       :
 582                           PUTTAG('v');
 583                           pttype(gtpod(t));
 584                           break;
 585 #endif
 586         default         : error("bad pttype");
 587         }
 588 }
 589
 590 static void
 591 patype(a)
 592   atype a;
 593 {
 594         switch (tatype(a)) {
 595         case atc        :
 596                           PUTTAG('1');
 597                           printf("#%lu\t",gatcline(a));
 598                           pid(gatcid(a));
 599                           plist(pttype, gatctypel(a));
 600                           break;
 601         default         : fprintf(stderr, "Bad tag in abstree %d\n", tatype(a));
 602                           exit(1);
 603         }
 604 }
 605
 606
 607 static void
 608 pentid(i)
 609   entidt i;
 610 {
 611         switch (tentidt(i)) {
 612         case entid      : PUTTAG('x');
 613                           pid(gentid(i));
 614                           break;
 615         case enttype    : PUTTAG('X');
 616                           pid(gitentid(i));
 617                           break;
 618         case enttypeall : PUTTAG('z');
 619                           pid(gatentid(i));
 620                           break;
 621         case entmod     : PUTTAG('m');
 622                           pid(gmentid(i));
 623                           break;
 624         case enttypecons: PUTTAG('8');
 625                           pid(gctentid(i));
 626                           plist(pid,gctentcons(i));
 627                           break;
 628         case entclass   : PUTTAG('9');
 629                           pid(gcentid(i));
 630                           plist(pid,gcentops(i));
 631                           break;
 632         default         :
 633                           error("Bad pentid");
 634         }
 635 }
 636
 637
 638 static void
 639 prename(l)
 640   list l;
 641 {
 642   pid(lhd(l));
 643   pid(lhd(ltl(l)));
 644 }
 645
 646
 647 static void
 648 pfixes()
 649 {
 650         int m = nfixes(), i;
 651         char *s;
 652
 653         for(i = 0; i < m; i++) {
 654                 s = fixtype(i);
 655                 if (s) {
 656                         PUTTAG('L');
 657                         pstr(fixop(i));
 658                         pstr(fixtype(i));
 659                         printf("#%lu\t",precedence(i));
 660                 }
 661         }
 662         PUTTAG('N');
 663 }
 664
 665
 666 static void
 667 ppbinding(p)
 668   pbinding p;
 669 {
 670         switch(tpbinding(p)) {
 671         case pgrhs      : PUTTAG('W');
 672                           printf("#%lu\t",ggline(p));
 673                           pid(ggfuncname(p));
 674                           ptree(ggpat(p));
 675                           plist(pgrhses,ggdexprs(p));
 676                           prbind(ggbind(p));
 677                           break;
 678         default         :
 679                           error("Bad pbinding");
 680         }
 681 }
 682
 683
 684 static void
 685 pgrhses(l)
 686   list l;
 687 {
 688   ptree(lhd(l));                /* Guard */
 689   ptree(lhd(ltl(l)));           /* Expression */
 690 }
 691
 692 static void
 693 ppragma(p)
 694   hpragma p;
 695 {
 696     switch(thpragma(p)) {
 697       case no_pragma:           PUTTAGSTR("PN");
 698                                 break;
 699       case idata_pragma:        PUTTAGSTR("Pd");
 700                                 plist(patype, gprag_data_constrs(p));
 701                                 plist(ppragma, gprag_data_specs(p));
 702                                 break;
 703       case itype_pragma:        PUTTAGSTR("Pt");
 704                                 break;
 705       case iclas_pragma:        PUTTAGSTR("Pc");
 706                                 plist(ppragma, gprag_clas(p));
 707                                 break;
 708       case iclasop_pragma:      PUTTAGSTR("Po");
 709                                 ppragma(gprag_dsel(p));
 710                                 ppragma(gprag_defm(p));
 711                                 break;
 712
 713       case iinst_simpl_pragma:  PUTTAGSTR("Pis");
 714                                 pid(gprag_imod_simpl(p));
 715                                 ppragma(gprag_dfun_simpl(p));
 716                                 break;
 717       case iinst_const_pragma:  PUTTAGSTR("Pic");
 718                                 pid(gprag_imod_const(p));
 719                                 ppragma(gprag_dfun_const(p));
 720                                 plist(ppragma, gprag_constms(p));
 721                                 break;
 722       case iinst_spec_pragma:   PUTTAGSTR("PiS");
 723                                 pid(gprag_imod_spec(p));
 724                                 ppragma(gprag_dfun_spec(p));
 725                                 plist(ppragma, gprag_inst_specs(p));
 726                                 break;
 727
 728       case igen_pragma:         PUTTAGSTR("Pg");
 729                                 ppragma(gprag_arity(p));
 730                                 ppragma(gprag_update(p));
 731                                 ppragma(gprag_deforest(p));
 732                                 ppragma(gprag_strictness(p));
 733                                 ppragma(gprag_unfolding(p));
 734                                 plist(ppragma, gprag_specs(p));
 735                                 break;
 736       case iarity_pragma:       PUTTAGSTR("PA");
 737                                 pid(gprag_arity_val(p));
 738                                 break;
 739       case iupdate_pragma:      PUTTAGSTR("Pu");
 740                                 pid(gprag_update_val(p));
 741                                 break;
 742       case ideforest_pragma:    PUTTAGSTR("PD");
 743                                 break;
 744       case istrictness_pragma:  PUTTAGSTR("PS");
 745                                 print_string(gprag_strict_spec(p));
 746                                 ppragma(gprag_strict_wrkr(p));
 747                                 break;
 748       case imagic_unfolding_pragma: PUTTAGSTR("PM");
 749                                 pid(gprag_magic_str(p));
 750                                 break;
 751
 752       case iunfolding_pragma:   PUTTAGSTR("PU");
 753                                 ppragma(gprag_unfold_guide(p));
 754                                 pcoresyn(gprag_unfold_core(p));
 755                                 break;
 756
 757       case iunfold_always:      PUTTAGSTR("Px");
 758                                 break;
 759       case iunfold_if_args:     PUTTAGSTR("Py");
 760                                 pid(gprag_unfold_if_t_args(p));
 761                                 pid(gprag_unfold_if_v_args(p));
 762                                 pid(gprag_unfold_if_con_args(p));
 763                                 pid(gprag_unfold_if_size(p));
 764                                 break;
 765
 766       case iname_pragma_pr:     PUTTAGSTR("P1");
 767                                 pid(gprag_name_pr1(p));
 768                                 ppragma(gprag_name_pr2(p));
 769                                 break;
 770       case itype_pragma_pr:     PUTTAGSTR("P2");
 771                                 plist(pttype, gprag_type_pr1(p));
 772                                 pid(gprag_type_pr2(p));
 773                                 ppragma(gprag_type_pr3(p));
 774                                 break;
 775       case iinst_pragma_3s:     PUTTAGSTR("P3");
 776                                 plist(pttype, gprag_inst_pt1(p));
 777                                 pid(gprag_inst_pt2(p));
 778                                 ppragma(gprag_inst_pt3(p));
 779                                 plist(ppragma,gprag_inst_pt4(p));
 780                                 break;
 781
 782       case idata_pragma_4s:     PUTTAGSTR("P4");
 783                                 plist(pttype, gprag_data_spec(p));
 784                                 break;
 785
 786       default:                  error("Bad Pragma");
 787       }
 788 }
 789
 790 static void
 791 pbool(b)
 792   BOOLEAN b;
 793 {
 794     if (b) {
 795       putchar('T');
 796     } else {
 797       putchar('F');
 798     }
 799 }
 800
 801 static void
 802 pcoresyn(p)
 803   coresyn p;
 804 {
 805     switch(tcoresyn(p)) {
 806       case cobinder:            PUTTAGSTR("Fa");
 807                                 pid(gcobinder_v(p));
 808                                 pttype(gcobinder_ty(p));
 809                                 break;
 810
 811       case colit:               PUTTAGSTR("Fb");
 812                                 pliteral(gcolit(p));
 813                                 break;
 814       case colocal:             PUTTAGSTR("Fc");
 815                                 pcoresyn(gcolocal_v(p));
 816                                 break;
 817
 818       case cononrec:            PUTTAGSTR("Fd");
 819                                 pcoresyn(gcononrec_b(p));
 820                                 pcoresyn(gcononrec_rhs(p));
 821                                 break;
 822       case corec:               PUTTAGSTR("Fe");
 823                                 plist(pcoresyn,gcorec(p));
 824                                 break;
 825       case corec_pair:          PUTTAGSTR("Ff");
 826                                 pcoresyn(gcorec_b(p));
 827                                 pcoresyn(gcorec_rhs(p));
 828                                 break;
 829
 830       case covar:               PUTTAGSTR("Fg");
 831                                 pcoresyn(gcovar(p));
 832                                 break;
 833       case coliteral:           PUTTAGSTR("Fh");
 834                                 pliteral(gcoliteral(p));
 835                                 break;
 836       case cocon:               PUTTAGSTR("Fi");
 837                                 pcoresyn(gcocon_con(p));
 838                                 plist(pttype, gcocon_tys(p));
 839                                 plist(pcoresyn, gcocon_args(p));
 840                                 break;
 841       case coprim:              PUTTAGSTR("Fj");
 842                                 pcoresyn(gcoprim_op(p));
 843                                 plist(pttype, gcoprim_tys(p));
 844                                 plist(pcoresyn, gcoprim_args(p));
 845                                 break;
 846       case colam:               PUTTAGSTR("Fk");
 847                                 plist(pcoresyn, gcolam_vars(p));
 848                                 pcoresyn(gcolam_body(p));
 849                                 break;
 850       case cotylam:             PUTTAGSTR("Fl");
 851                                 plist(pid, gcotylam_tvs(p));
 852                                 pcoresyn(gcotylam_body(p));
 853                                 break;
 854       case coapp:               PUTTAGSTR("Fm");
 855                                 pcoresyn(gcoapp_fun(p));
 856                                 plist(pcoresyn, gcoapp_args(p));
 857                                 break;
 858       case cotyapp:             PUTTAGSTR("Fn");
 859                                 pcoresyn(gcotyapp_e(p));
 860                                 pttype(gcotyapp_t(p));
 861                                 break;
 862       case cocase:              PUTTAGSTR("Fo");
 863                                 pcoresyn(gcocase_s(p));
 864                                 pcoresyn(gcocase_alts(p));
 865                                 break;
 866       case colet:               PUTTAGSTR("Fp");
 867                                 pcoresyn(gcolet_bind(p));
 868                                 pcoresyn(gcolet_body(p));
 869                                 break;
 870       case coscc:               PUTTAGSTR("Fz");        /* out of order! */
 871                                 pcoresyn(gcoscc_scc(p));
 872                                 pcoresyn(gcoscc_body(p));
 873                                 break;
 874
 875       case coalg_alts:          PUTTAGSTR("Fq");
 876                                 plist(pcoresyn, gcoalg_alts(p));
 877                                 pcoresyn(gcoalg_deflt(p));
 878                                 break;
 879       case coalg_alt:           PUTTAGSTR("Fr");
 880                                 pcoresyn(gcoalg_con(p));
 881                                 plist(pcoresyn, gcoalg_bs(p));
 882                                 pcoresyn(gcoalg_rhs(p));
 883                                 break;
 884       case coprim_alts:         PUTTAGSTR("Fs");
 885                                 plist(pcoresyn, gcoprim_alts(p));
 886                                 pcoresyn(gcoprim_deflt(p));
 887                                 break;
 888       case coprim_alt:          PUTTAGSTR("Ft");
 889                                 pliteral(gcoprim_lit(p));
 890                                 pcoresyn(gcoprim_rhs(p));
 891                                 break;
 892       case conodeflt:           PUTTAGSTR("Fu");
 893                                 break;
 894       case cobinddeflt:         PUTTAGSTR("Fv");
 895                                 pcoresyn(gcobinddeflt_v(p));
 896                                 pcoresyn(gcobinddeflt_rhs(p));
 897                                 break;
 898
 899       case co_primop:           PUTTAGSTR("Fw");
 900                                 pid(gco_primop(p));
 901                                 break;
 902       case co_ccall:            PUTTAGSTR("Fx");
 903                                 pbool(gco_ccall_may_gc(p));
 904                                 pid(gco_ccall(p));
 905                                 plist(pttype, gco_ccall_arg_tys(p));
 906                                 pttype(gco_ccall_res_ty(p));
 907                                 break;
 908       case co_casm:             PUTTAGSTR("Fy");
 909                                 pbool(gco_casm_may_gc(p));
 910                                 pliteral(gco_casm(p));
 911                                 plist(pttype, gco_casm_arg_tys(p));
 912                                 pttype(gco_casm_res_ty(p));
 913                                 break;
 914
 915         /* Cost-centre stuff */
 916       case co_preludedictscc:   PUTTAGSTR("F?a");
 917                                 pcoresyn(gco_preludedictscc_dupd(p));
 918                                 break;
 919       case co_alldictscc:       PUTTAGSTR("F?b");
 920                                 print_string(gco_alldictscc_m(p));
 921                                 print_string(gco_alldictscc_g(p));
 922                                 pcoresyn(gco_alldictscc_dupd(p));
 923                                 break;
 924       case co_usercc:           PUTTAGSTR("F?c");
 925                                 print_string(gco_usercc_n(p));
 926                                 print_string(gco_usercc_m(p));
 927                                 print_string(gco_usercc_g(p));
 928                                 pcoresyn(gco_usercc_dupd(p));
 929                                 pcoresyn(gco_usercc_cafd(p));
 930                                 break;
 931       case co_autocc:           PUTTAGSTR("F?d");
 932                                 pcoresyn(gco_autocc_i(p));
 933                                 print_string(gco_autocc_m(p));
 934                                 print_string(gco_autocc_g(p));
 935                                 pcoresyn(gco_autocc_dupd(p));
 936                                 pcoresyn(gco_autocc_cafd(p));
 937                                 break;
 938       case co_dictcc:           PUTTAGSTR("F?e");
 939                                 pcoresyn(gco_dictcc_i(p));
 940                                 print_string(gco_dictcc_m(p));
 941                                 print_string(gco_dictcc_g(p));
 942                                 pcoresyn(gco_dictcc_dupd(p));
 943                                 pcoresyn(gco_dictcc_cafd(p));
 944                                 break;
 945
 946       case co_scc_noncaf:       PUTTAGSTR("F?f");
 947                                 break;
 948       case co_scc_caf:          PUTTAGSTR("F?g");
 949                                 break;
 950       case co_scc_nondupd:      PUTTAGSTR("F?h");
 951                                 break;
 952       case co_scc_dupd:         PUTTAGSTR("F?i");
 953                                 break;
 954
 955         /* Id stuff */
 956       case co_id:               PUTTAGSTR("F1");
 957                                 pid(gco_id(p));
 958                                 break;
 959       case co_orig_id:          PUTTAGSTR("F9");
 960                                 pid(gco_orig_id_m(p));
 961                                 pid(gco_orig_id_n(p));
 962                                 break;
 963       case co_sdselid:          PUTTAGSTR("F2");
 964                                 pid(gco_sdselid_c(p));
 965                                 pid(gco_sdselid_sc(p));
 966                                 break;
 967       case co_classopid:        PUTTAGSTR("F3");
 968                                 pid(gco_classopid_c(p));
 969                                 pid(gco_classopid_o(p));
 970                                 break;
 971       case co_defmid:           PUTTAGSTR("F4");
 972                                 pid(gco_defmid_c(p));
 973                                 pid(gco_defmid_op(p));
 974                                 break;
 975       case co_dfunid:           PUTTAGSTR("F5");
 976                                 pid(gco_dfunid_c(p));
 977                                 pttype(gco_dfunid_ty(p));
 978                                 break;
 979       case co_constmid:         PUTTAGSTR("F6");
 980                                 pid(gco_constmid_c(p));
 981                                 pid(gco_constmid_op(p));
 982                                 pttype(gco_constmid_ty(p));
 983                                 break;
 984       case co_specid:           PUTTAGSTR("F7");
 985                                 pcoresyn(gco_specid_un(p));
 986                                 plist(pttype,gco_specid_tys(p));
 987                                 break;
 988       case co_wrkrid:           PUTTAGSTR("F8");
 989                                 pcoresyn(gco_wrkrid_un(p));
 990                                 break;
 991       /* more to come?? */
 992
 993       default :                 error("Bad Core syntax");
 994     }
 995 }