gcc/fortran/dump-parse-tree.cc

   1 /* Parse tree dumper
   2    Copyright (C) 2003-2023 Free Software Foundation, Inc.
   3    Contributed by Steven Bosscher
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 3, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING3.  If not see
  19 <http://www.gnu.org/licenses/>.  */
  20
  21
  22 /* Actually this is just a collection of routines that used to be
  23    scattered around the sources.  Now that they are all in a single
  24    file, almost all of them can be static, and the other files don't
  25    have this mess in them.
  26
  27    As a nice side-effect, this file can act as documentation of the
  28    gfc_code and gfc_expr structures and all their friends and
  29    relatives.
  30
  31    TODO: Dump DATA.  */
  32
  33 #include "config.h"
  34 #include "system.h"
  35 #include "coretypes.h"
  36 #include "gfortran.h"
  37 #include "constructor.h"
  38 #include "version.h"
  39 #include "parse.h"  /* For gfc_ascii_statement.  */
  40
  41 /* Keep track of indentation for symbol tree dumps.  */
  42 static int show_level = 0;
  43
  44 /* The file handle we're dumping to is kept in a static variable.  This
  45    is not too cool, but it avoids a lot of passing it around.  */
  46 static FILE *dumpfile;
  47
  48 /* Forward declaration of some of the functions.  */
  49 static void show_expr (gfc_expr *p);
  50 static void show_code_node (int, gfc_code *);
  51 static void show_namespace (gfc_namespace *ns);
  52 static void show_code (int, gfc_code *);
  53 static void show_symbol (gfc_symbol *);
  54 static void show_typespec (gfc_typespec *);
  55 static void show_ref (gfc_ref *);
  56 static void show_attr (symbol_attribute *, const char *);
  57
  58 /* Allow dumping of an expression in the debugger.  */
  59 void gfc_debug_expr (gfc_expr *);
  60
  61 void debug (symbol_attribute *attr)
  62 {
  63   FILE *tmp = dumpfile;
  64   dumpfile = stderr;
  65   show_attr (attr, NULL);
  66   fputc ('\n', dumpfile);
  67   dumpfile = tmp;
  68 }
  69
  70 void debug (gfc_formal_arglist *formal)
  71 {
  72   FILE *tmp = dumpfile;
  73   dumpfile = stderr;
  74   for (; formal; formal = formal->next)
  75     {
  76       fputc ('\n', dumpfile);
  77       show_symbol (formal->sym);
  78     }
  79   fputc ('\n', dumpfile);
  80   dumpfile = tmp;
  81 }
  82
  83 void debug (symbol_attribute attr)
  84 {
  85   debug (&attr);
  86 }
  87
  88 void debug (gfc_expr *e)
  89 {
  90   FILE *tmp = dumpfile;
  91   dumpfile = stderr;
  92   if (e != NULL)
  93     {
  94       show_expr (e);
  95       fputc (' ', dumpfile);
  96       show_typespec (&e->ts);
  97     }
  98   else
  99     fputs ("() ", dumpfile);
 100
 101   fputc ('\n', dumpfile);
 102   dumpfile = tmp;
 103 }
 104
 105 void debug (gfc_typespec *ts)
 106 {
 107   FILE *tmp = dumpfile;
 108   dumpfile = stderr;
 109   show_typespec (ts);
 110   fputc ('\n', dumpfile);
 111   dumpfile = tmp;
 112 }
 113
 114 void debug (gfc_typespec ts)
 115 {
 116   debug (&ts);
 117 }
 118
 119 void debug (gfc_ref *p)
 120 {
 121   FILE *tmp = dumpfile;
 122   dumpfile = stderr;
 123   show_ref (p);
 124   fputc ('\n', dumpfile);
 125   dumpfile = tmp;
 126 }
 127
 128 void
 129 gfc_debug_expr (gfc_expr *e)
 130 {
 131   FILE *tmp = dumpfile;
 132   dumpfile = stderr;
 133   show_expr (e);
 134   fputc ('\n', dumpfile);
 135   dumpfile = tmp;
 136 }
 137
 138 /* Allow for dumping of a piece of code in the debugger.  */
 139 void gfc_debug_code (gfc_code *c);
 140
 141 void
 142 gfc_debug_code (gfc_code *c)
 143 {
 144   FILE *tmp = dumpfile;
 145   dumpfile = stderr;
 146   show_code (1, c);
 147   fputc ('\n', dumpfile);
 148   dumpfile = tmp;
 149 }
 150
 151 void debug (gfc_symbol *sym)
 152 {
 153   FILE *tmp = dumpfile;
 154   dumpfile = stderr;
 155   show_symbol (sym);
 156   fputc ('\n', dumpfile);
 157   dumpfile = tmp;
 158 }
 159
 160 /* Do indentation for a specific level.  */
 161
 162 static inline void
 163 code_indent (int level, gfc_st_label *label)
 164 {
 165   int i;
 166
 167   if (label != NULL)
 168     fprintf (dumpfile, "%-5d ", label->value);
 169
 170   for (i = 0; i < (2 * level - (label ? 6 : 0)); i++)
 171     fputc (' ', dumpfile);
 172 }
 173
 174
 175 /* Simple indentation at the current level.  This one
 176    is used to show symbols.  */
 177
 178 static inline void
 179 show_indent (void)
 180 {
 181   fputc ('\n', dumpfile);
 182   code_indent (show_level, NULL);
 183 }
 184
 185
 186 /* Show type-specific information.  */
 187
 188 static void
 189 show_typespec (gfc_typespec *ts)
 190 {
 191   if (ts->type == BT_ASSUMED)
 192     {
 193       fputs ("(TYPE(*))", dumpfile);
 194       return;
 195     }
 196
 197   fprintf (dumpfile, "(%s ", gfc_basic_typename (ts->type));
 198
 199   switch (ts->type)
 200     {
 201     case BT_DERIVED:
 202     case BT_CLASS:
 203     case BT_UNION:
 204       fprintf (dumpfile, "%s", ts->u.derived->name);
 205       break;
 206
 207     case BT_CHARACTER:
 208       if (ts->u.cl)
 209         show_expr (ts->u.cl->length);
 210       fprintf(dumpfile, " %d", ts->kind);
 211       break;
 212
 213     default:
 214       fprintf (dumpfile, "%d", ts->kind);
 215       break;
 216     }
 217   if (ts->is_c_interop)
 218     fputs (" C_INTEROP", dumpfile);
 219
 220   if (ts->is_iso_c)
 221     fputs (" ISO_C", dumpfile);
 222
 223   if (ts->deferred)
 224     fputs (" DEFERRED", dumpfile);
 225
 226   fputc (')', dumpfile);
 227 }
 228
 229
 230 /* Show an actual argument list.  */
 231
 232 static void
 233 show_actual_arglist (gfc_actual_arglist *a)
 234 {
 235   fputc ('(', dumpfile);
 236
 237   for (; a; a = a->next)
 238     {
 239       fputc ('(', dumpfile);
 240       if (a->name != NULL)
 241         fprintf (dumpfile, "%s = ", a->name);
 242       if (a->expr != NULL)
 243         show_expr (a->expr);
 244       else
 245         fputs ("(arg not-present)", dumpfile);
 246
 247       fputc (')', dumpfile);
 248       if (a->next != NULL)
 249         fputc (' ', dumpfile);
 250     }
 251
 252   fputc (')', dumpfile);
 253 }
 254
 255
 256 /* Show a gfc_array_spec array specification structure.  */
 257
 258 static void
 259 show_array_spec (gfc_array_spec *as)
 260 {
 261   const char *c;
 262   int i;
 263
 264   if (as == NULL)
 265     {
 266       fputs ("()", dumpfile);
 267       return;
 268     }
 269
 270   fprintf (dumpfile, "(%d [%d]", as->rank, as->corank);
 271
 272   if (as->rank + as->corank > 0 || as->rank == -1)
 273     {
 274       switch (as->type)
 275       {
 276         case AS_EXPLICIT:      c = "AS_EXPLICIT";      break;
 277         case AS_DEFERRED:      c = "AS_DEFERRED";      break;
 278         case AS_ASSUMED_SIZE:  c = "AS_ASSUMED_SIZE";  break;
 279         case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
 280         case AS_ASSUMED_RANK:  c = "AS_ASSUMED_RANK";  break;
 281         default:
 282           gfc_internal_error ("show_array_spec(): Unhandled array shape "
 283                               "type.");
 284       }
 285       fprintf (dumpfile, " %s ", c);
 286
 287       for (i = 0; i < as->rank + as->corank; i++)
 288         {
 289           show_expr (as->lower[i]);
 290           fputc (' ', dumpfile);
 291           show_expr (as->upper[i]);
 292           fputc (' ', dumpfile);
 293         }
 294     }
 295
 296   fputc (')', dumpfile);
 297 }
 298
 299
 300 /* Show a gfc_array_ref array reference structure.  */
 301
 302 static void
 303 show_array_ref (gfc_array_ref * ar)
 304 {
 305   int i;
 306
 307   fputc ('(', dumpfile);
 308
 309   switch (ar->type)
 310     {
 311     case AR_FULL:
 312       fputs ("FULL", dumpfile);
 313       break;
 314
 315     case AR_SECTION:
 316       for (i = 0; i < ar->dimen; i++)
 317         {
 318           /* There are two types of array sections: either the
 319              elements are identified by an integer array ('vector'),
 320              or by an index range. In the former case we only have to
 321              print the start expression which contains the vector, in
 322              the latter case we have to print any of lower and upper
 323              bound and the stride, if they're present.  */
 324
 325           if (ar->start[i] != NULL)
 326             show_expr (ar->start[i]);
 327
 328           if (ar->dimen_type[i] == DIMEN_RANGE)
 329             {
 330               fputc (':', dumpfile);
 331
 332               if (ar->end[i] != NULL)
 333                 show_expr (ar->end[i]);
 334
 335               if (ar->stride[i] != NULL)
 336                 {
 337                   fputc (':', dumpfile);
 338                   show_expr (ar->stride[i]);
 339                 }
 340             }
 341
 342           if (i != ar->dimen - 1)
 343             fputs (" , ", dumpfile);
 344         }
 345       break;
 346
 347     case AR_ELEMENT:
 348       for (i = 0; i < ar->dimen; i++)
 349         {
 350           show_expr (ar->start[i]);
 351           if (i != ar->dimen - 1)
 352             fputs (" , ", dumpfile);
 353         }
 354       break;
 355
 356     case AR_UNKNOWN:
 357       fputs ("UNKNOWN", dumpfile);
 358       break;
 359
 360     default:
 361       gfc_internal_error ("show_array_ref(): Unknown array reference");
 362     }
 363
 364   fputc (')', dumpfile);
 365   if (ar->codimen == 0)
 366     return;
 367
 368   /* Show coarray part of the reference, if any.  */
 369   fputc ('[',dumpfile);
 370   for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
 371     {
 372       if (ar->dimen_type[i] == DIMEN_STAR)
 373         fputc('*',dumpfile);
 374       else if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
 375         fputs("THIS_IMAGE", dumpfile);
 376       else
 377         {
 378           show_expr (ar->start[i]);
 379           if (ar->end[i])
 380             {
 381               fputc(':', dumpfile);
 382               show_expr (ar->end[i]);
 383             }
 384         }
 385       if (i != ar->dimen + ar->codimen - 1)
 386         fputs (" , ", dumpfile);
 387
 388     }
 389   fputc (']',dumpfile);
 390 }
 391
 392
 393 /* Show a list of gfc_ref structures.  */
 394
 395 static void
 396 show_ref (gfc_ref *p)
 397 {
 398   for (; p; p = p->next)
 399     switch (p->type)
 400       {
 401       case REF_ARRAY:
 402         show_array_ref (&p->u.ar);
 403         break;
 404
 405       case REF_COMPONENT:
 406         fprintf (dumpfile, " %% %s", p->u.c.component->name);
 407         break;
 408
 409       case REF_SUBSTRING:
 410         fputc ('(', dumpfile);
 411         show_expr (p->u.ss.start);
 412         fputc (':', dumpfile);
 413         show_expr (p->u.ss.end);
 414         fputc (')', dumpfile);
 415         break;
 416
 417       case REF_INQUIRY:
 418         switch (p->u.i)
 419         {
 420           case INQUIRY_KIND:
 421             fprintf (dumpfile, " INQUIRY_KIND ");
 422             break;
 423           case INQUIRY_LEN:
 424             fprintf (dumpfile, " INQUIRY_LEN ");
 425             break;
 426           case INQUIRY_RE:
 427             fprintf (dumpfile, " INQUIRY_RE ");
 428             break;
 429           case INQUIRY_IM:
 430             fprintf (dumpfile, " INQUIRY_IM ");
 431         }
 432         break;
 433
 434       default:
 435         gfc_internal_error ("show_ref(): Bad component code");
 436       }
 437 }
 438
 439
 440 /* Display a constructor.  Works recursively for array constructors.  */
 441
 442 static void
 443 show_constructor (gfc_constructor_base base)
 444 {
 445   gfc_constructor *c;
 446   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
 447     {
 448       if (c->iterator == NULL)
 449         show_expr (c->expr);
 450       else
 451         {
 452           fputc ('(', dumpfile);
 453           show_expr (c->expr);
 454
 455           fputc (' ', dumpfile);
 456           show_expr (c->iterator->var);
 457           fputc ('=', dumpfile);
 458           show_expr (c->iterator->start);
 459           fputc (',', dumpfile);
 460           show_expr (c->iterator->end);
 461           fputc (',', dumpfile);
 462           show_expr (c->iterator->step);
 463
 464           fputc (')', dumpfile);
 465         }
 466
 467       if (gfc_constructor_next (c) != NULL)
 468         fputs (" , ", dumpfile);
 469     }
 470 }
 471
 472
 473 static void
 474 show_char_const (const gfc_char_t *c, gfc_charlen_t length)
 475 {
 476   fputc ('\'', dumpfile);
 477   for (size_t i = 0; i < (size_t) length; i++)
 478     {
 479       if (c[i] == '\'')
 480         fputs ("''", dumpfile);
 481       else
 482         fputs (gfc_print_wide_char (c[i]), dumpfile);
 483     }
 484   fputc ('\'', dumpfile);
 485 }
 486
 487
 488 /* Show a component-call expression.  */
 489
 490 static void
 491 show_compcall (gfc_expr* p)
 492 {
 493   gcc_assert (p->expr_type == EXPR_COMPCALL);
 494
 495   fprintf (dumpfile, "%s", p->symtree->n.sym->name);
 496   show_ref (p->ref);
 497   fprintf (dumpfile, "%s", p->value.compcall.name);
 498
 499   show_actual_arglist (p->value.compcall.actual);
 500 }
 501
 502
 503 /* Show an expression.  */
 504
 505 static void
 506 show_expr (gfc_expr *p)
 507 {
 508   const char *c;
 509   int i;
 510
 511   if (p == NULL)
 512     {
 513       fputs ("()", dumpfile);
 514       return;
 515     }
 516
 517   switch (p->expr_type)
 518     {
 519     case EXPR_SUBSTRING:
 520       show_char_const (p->value.character.string, p->value.character.length);
 521       show_ref (p->ref);
 522       break;
 523
 524     case EXPR_STRUCTURE:
 525       fprintf (dumpfile, "%s(", p->ts.u.derived->name);
 526       show_constructor (p->value.constructor);
 527       fputc (')', dumpfile);
 528       break;
 529
 530     case EXPR_ARRAY:
 531       fputs ("(/ ", dumpfile);
 532       show_constructor (p->value.constructor);
 533       fputs (" /)", dumpfile);
 534
 535       show_ref (p->ref);
 536       break;
 537
 538     case EXPR_NULL:
 539       fputs ("NULL()", dumpfile);
 540       break;
 541
 542     case EXPR_CONSTANT:
 543       switch (p->ts.type)
 544         {
 545         case BT_INTEGER:
 546           mpz_out_str (dumpfile, 10, p->value.integer);
 547
 548           if (p->ts.kind != gfc_default_integer_kind)
 549             fprintf (dumpfile, "_%d", p->ts.kind);
 550           break;
 551
 552         case BT_LOGICAL:
 553           if (p->value.logical)
 554             fputs (".true.", dumpfile);
 555           else
 556             fputs (".false.", dumpfile);
 557           break;
 558
 559         case BT_REAL:
 560           mpfr_out_str (dumpfile, 10, 0, p->value.real, GFC_RND_MODE);
 561           if (p->ts.kind != gfc_default_real_kind)
 562             fprintf (dumpfile, "_%d", p->ts.kind);
 563           break;
 564
 565         case BT_CHARACTER:
 566           show_char_const (p->value.character.string,
 567                            p->value.character.length);
 568           break;
 569
 570         case BT_COMPLEX:
 571           fputs ("(complex ", dumpfile);
 572
 573           mpfr_out_str (dumpfile, 10, 0, mpc_realref (p->value.complex),
 574                         GFC_RND_MODE);
 575           if (p->ts.kind != gfc_default_complex_kind)
 576             fprintf (dumpfile, "_%d", p->ts.kind);
 577
 578           fputc (' ', dumpfile);
 579
 580           mpfr_out_str (dumpfile, 10, 0, mpc_imagref (p->value.complex),
 581                         GFC_RND_MODE);
 582           if (p->ts.kind != gfc_default_complex_kind)
 583             fprintf (dumpfile, "_%d", p->ts.kind);
 584
 585           fputc (')', dumpfile);
 586           break;
 587
 588         case BT_BOZ:
 589           if (p->boz.rdx == 2)
 590             fputs ("b'", dumpfile);
 591           else if (p->boz.rdx == 8)
 592             fputs ("o'", dumpfile);
 593           else
 594             fputs ("z'", dumpfile);
 595           fprintf (dumpfile, "%s'", p->boz.str);
 596           break;
 597
 598         case BT_HOLLERITH:
 599           fprintf (dumpfile, HOST_WIDE_INT_PRINT_DEC "H",
 600                    p->representation.length);
 601           c = p->representation.string;
 602           for (i = 0; i < p->representation.length; i++, c++)
 603             {
 604               fputc (*c, dumpfile);
 605             }
 606           break;
 607
 608         default:
 609           fputs ("???", dumpfile);
 610           break;
 611         }
 612
 613       if (p->representation.string)
 614         {
 615           fputs (" {", dumpfile);
 616           c = p->representation.string;
 617           for (i = 0; i < p->representation.length; i++, c++)
 618             {
 619               fprintf (dumpfile, "%.2x", (unsigned int) *c);
 620               if (i < p->representation.length - 1)
 621                 fputc (',', dumpfile);
 622             }
 623           fputc ('}', dumpfile);
 624         }
 625
 626       break;
 627
 628     case EXPR_VARIABLE:
 629       if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
 630         fprintf (dumpfile, "%s:", p->symtree->n.sym->ns->proc_name->name);
 631       fprintf (dumpfile, "%s", p->symtree->n.sym->name);
 632       show_ref (p->ref);
 633       break;
 634
 635     case EXPR_OP:
 636       fputc ('(', dumpfile);
 637       switch (p->value.op.op)
 638         {
 639         case INTRINSIC_UPLUS:
 640           fputs ("U+ ", dumpfile);
 641           break;
 642         case INTRINSIC_UMINUS:
 643           fputs ("U- ", dumpfile);
 644           break;
 645         case INTRINSIC_PLUS:
 646           fputs ("+ ", dumpfile);
 647           break;
 648         case INTRINSIC_MINUS:
 649           fputs ("- ", dumpfile);
 650           break;
 651         case INTRINSIC_TIMES:
 652           fputs ("* ", dumpfile);
 653           break;
 654         case INTRINSIC_DIVIDE:
 655           fputs ("/ ", dumpfile);
 656           break;
 657         case INTRINSIC_POWER:
 658           fputs ("** ", dumpfile);
 659           break;
 660         case INTRINSIC_CONCAT:
 661           fputs ("// ", dumpfile);
 662           break;
 663         case INTRINSIC_AND:
 664           fputs ("AND ", dumpfile);
 665           break;
 666         case INTRINSIC_OR:
 667           fputs ("OR ", dumpfile);
 668           break;
 669         case INTRINSIC_EQV:
 670           fputs ("EQV ", dumpfile);
 671           break;
 672         case INTRINSIC_NEQV:
 673           fputs ("NEQV ", dumpfile);
 674           break;
 675         case INTRINSIC_EQ:
 676         case INTRINSIC_EQ_OS:
 677           fputs ("== ", dumpfile);
 678           break;
 679         case INTRINSIC_NE:
 680         case INTRINSIC_NE_OS:
 681           fputs ("/= ", dumpfile);
 682           break;
 683         case INTRINSIC_GT:
 684         case INTRINSIC_GT_OS:
 685           fputs ("> ", dumpfile);
 686           break;
 687         case INTRINSIC_GE:
 688         case INTRINSIC_GE_OS:
 689           fputs (">= ", dumpfile);
 690           break;
 691         case INTRINSIC_LT:
 692         case INTRINSIC_LT_OS:
 693           fputs ("< ", dumpfile);
 694           break;
 695         case INTRINSIC_LE:
 696         case INTRINSIC_LE_OS:
 697           fputs ("<= ", dumpfile);
 698           break;
 699         case INTRINSIC_NOT:
 700           fputs ("NOT ", dumpfile);
 701           break;
 702         case INTRINSIC_PARENTHESES:
 703           fputs ("parens ", dumpfile);
 704           break;
 705
 706         default:
 707           gfc_internal_error
 708             ("show_expr(): Bad intrinsic in expression");
 709         }
 710
 711       show_expr (p->value.op.op1);
 712
 713       if (p->value.op.op2)
 714         {
 715           fputc (' ', dumpfile);
 716           show_expr (p->value.op.op2);
 717         }
 718
 719       fputc (')', dumpfile);
 720       break;
 721
 722     case EXPR_FUNCTION:
 723       if (p->value.function.name == NULL)
 724         {
 725           fprintf (dumpfile, "%s", p->symtree->n.sym->name);
 726           if (gfc_is_proc_ptr_comp (p))
 727             show_ref (p->ref);
 728           fputc ('[', dumpfile);
 729           show_actual_arglist (p->value.function.actual);
 730           fputc (']', dumpfile);
 731         }
 732       else
 733         {
 734           fprintf (dumpfile, "%s", p->value.function.name);
 735           if (gfc_is_proc_ptr_comp (p))
 736             show_ref (p->ref);
 737           fputc ('[', dumpfile);
 738           fputc ('[', dumpfile);
 739           show_actual_arglist (p->value.function.actual);
 740           fputc (']', dumpfile);
 741           fputc (']', dumpfile);
 742         }
 743
 744       break;
 745
 746     case EXPR_COMPCALL:
 747       show_compcall (p);
 748       break;
 749
 750     default:
 751       gfc_internal_error ("show_expr(): Don't know how to show expr");
 752     }
 753 }
 754
 755 /* Show symbol attributes.  The flavor and intent are followed by
 756    whatever single bit attributes are present.  */
 757
 758 static void
 759 show_attr (symbol_attribute *attr, const char * module)
 760 {
 761   if (attr->flavor != FL_UNKNOWN)
 762     {
 763       if (attr->flavor == FL_DERIVED && attr->pdt_template)
 764         fputs (" (PDT-TEMPLATE", dumpfile);
 765       else
 766     fprintf (dumpfile, "(%s ", gfc_code2string (flavors, attr->flavor));
 767     }
 768   if (attr->access != ACCESS_UNKNOWN)
 769     fprintf (dumpfile, "%s ", gfc_code2string (access_types, attr->access));
 770   if (attr->proc != PROC_UNKNOWN)
 771     fprintf (dumpfile, "%s ", gfc_code2string (procedures, attr->proc));
 772   if (attr->save != SAVE_NONE)
 773     fprintf (dumpfile, "%s", gfc_code2string (save_status, attr->save));
 774
 775   if (attr->artificial)
 776     fputs (" ARTIFICIAL", dumpfile);
 777   if (attr->allocatable)
 778     fputs (" ALLOCATABLE", dumpfile);
 779   if (attr->asynchronous)
 780     fputs (" ASYNCHRONOUS", dumpfile);
 781   if (attr->codimension)
 782     fputs (" CODIMENSION", dumpfile);
 783   if (attr->dimension)
 784     fputs (" DIMENSION", dumpfile);
 785   if (attr->contiguous)
 786     fputs (" CONTIGUOUS", dumpfile);
 787   if (attr->external)
 788     fputs (" EXTERNAL", dumpfile);
 789   if (attr->intrinsic)
 790     fputs (" INTRINSIC", dumpfile);
 791   if (attr->optional)
 792     fputs (" OPTIONAL", dumpfile);
 793   if (attr->pdt_kind)
 794     fputs (" KIND", dumpfile);
 795   if (attr->pdt_len)
 796     fputs (" LEN", dumpfile);
 797   if (attr->pointer)
 798     fputs (" POINTER", dumpfile);
 799   if (attr->subref_array_pointer)
 800     fputs (" SUBREF-ARRAY-POINTER", dumpfile);
 801   if (attr->cray_pointer)
 802     fputs (" CRAY-POINTER", dumpfile);
 803   if (attr->cray_pointee)
 804     fputs (" CRAY-POINTEE", dumpfile);
 805   if (attr->is_protected)
 806     fputs (" PROTECTED", dumpfile);
 807   if (attr->value)
 808     fputs (" VALUE", dumpfile);
 809   if (attr->volatile_)
 810     fputs (" VOLATILE", dumpfile);
 811   if (attr->threadprivate)
 812     fputs (" THREADPRIVATE", dumpfile);
 813   if (attr->target)
 814     fputs (" TARGET", dumpfile);
 815   if (attr->dummy)
 816     {
 817       fputs (" DUMMY", dumpfile);
 818       if (attr->intent != INTENT_UNKNOWN)
 819         fprintf (dumpfile, "(%s)", gfc_intent_string (attr->intent));
 820     }
 821
 822   if (attr->result)
 823     fputs (" RESULT", dumpfile);
 824   if (attr->entry)
 825     fputs (" ENTRY", dumpfile);
 826   if (attr->entry_master)
 827     fputs (" ENTRY-MASTER", dumpfile);
 828   if (attr->mixed_entry_master)
 829     fputs (" MIXED-ENTRY-MASTER", dumpfile);
 830   if (attr->is_bind_c)
 831     fputs (" BIND(C)", dumpfile);
 832
 833   if (attr->data)
 834     fputs (" DATA", dumpfile);
 835   if (attr->use_assoc)
 836     {
 837       fputs (" USE-ASSOC", dumpfile);
 838       if (module != NULL)
 839         fprintf (dumpfile, "(%s)", module);
 840     }
 841
 842   if (attr->in_namelist)
 843     fputs (" IN-NAMELIST", dumpfile);
 844   if (attr->in_common)
 845     fputs (" IN-COMMON", dumpfile);
 846
 847   if (attr->abstract)
 848     fputs (" ABSTRACT", dumpfile);
 849   if (attr->function)
 850     fputs (" FUNCTION", dumpfile);
 851   if (attr->subroutine)
 852     fputs (" SUBROUTINE", dumpfile);
 853   if (attr->implicit_type)
 854     fputs (" IMPLICIT-TYPE", dumpfile);
 855
 856   if (attr->sequence)
 857     fputs (" SEQUENCE", dumpfile);
 858   if (attr->alloc_comp)
 859     fputs (" ALLOC-COMP", dumpfile);
 860   if (attr->pointer_comp)
 861     fputs (" POINTER-COMP", dumpfile);
 862   if (attr->proc_pointer_comp)
 863     fputs (" PROC-POINTER-COMP", dumpfile);
 864   if (attr->private_comp)
 865     fputs (" PRIVATE-COMP", dumpfile);
 866   if (attr->zero_comp)
 867     fputs (" ZERO-COMP", dumpfile);
 868   if (attr->coarray_comp)
 869     fputs (" COARRAY-COMP", dumpfile);
 870   if (attr->lock_comp)
 871     fputs (" LOCK-COMP", dumpfile);
 872   if (attr->event_comp)
 873     fputs (" EVENT-COMP", dumpfile);
 874   if (attr->defined_assign_comp)
 875     fputs (" DEFINED-ASSIGNED-COMP", dumpfile);
 876   if (attr->unlimited_polymorphic)
 877     fputs (" UNLIMITED-POLYMORPHIC", dumpfile);
 878   if (attr->has_dtio_procs)
 879     fputs (" HAS-DTIO-PROCS", dumpfile);
 880   if (attr->caf_token)
 881     fputs (" CAF-TOKEN", dumpfile);
 882   if (attr->select_type_temporary)
 883     fputs (" SELECT-TYPE-TEMPORARY", dumpfile);
 884   if (attr->associate_var)
 885     fputs (" ASSOCIATE-VAR", dumpfile);
 886   if (attr->pdt_kind)
 887     fputs (" PDT-KIND", dumpfile);
 888   if (attr->pdt_len)
 889     fputs (" PDT-LEN", dumpfile);
 890   if (attr->pdt_type)
 891     fputs (" PDT-TYPE", dumpfile);
 892   if (attr->pdt_array)
 893     fputs (" PDT-ARRAY", dumpfile);
 894   if (attr->pdt_string)
 895     fputs (" PDT-STRING", dumpfile);
 896   if (attr->omp_udr_artificial_var)
 897     fputs (" OMP-UDR-ARTIFICIAL-VAR", dumpfile);
 898   if (attr->omp_declare_target)
 899     fputs (" OMP-DECLARE-TARGET", dumpfile);
 900   if (attr->omp_declare_target_link)
 901     fputs (" OMP-DECLARE-TARGET-LINK", dumpfile);
 902   if (attr->elemental)
 903     fputs (" ELEMENTAL", dumpfile);
 904   if (attr->pure)
 905     fputs (" PURE", dumpfile);
 906   if (attr->implicit_pure)
 907     fputs (" IMPLICIT-PURE", dumpfile);
 908   if (attr->recursive)
 909     fputs (" RECURSIVE", dumpfile);
 910   if (attr->unmaskable)
 911     fputs (" UNMASKABKE", dumpfile);
 912   if (attr->masked)
 913     fputs (" MASKED", dumpfile);
 914   if (attr->contained)
 915     fputs (" CONTAINED", dumpfile);
 916   if (attr->mod_proc)
 917     fputs (" MOD-PROC", dumpfile);
 918   if (attr->module_procedure)
 919     fputs (" MODULE-PROCEDURE", dumpfile);
 920   if (attr->public_used)
 921     fputs (" PUBLIC_USED", dumpfile);
 922   if (attr->array_outer_dependency)
 923     fputs (" ARRAY-OUTER-DEPENDENCY", dumpfile);
 924   if (attr->noreturn)
 925     fputs (" NORETURN", dumpfile);
 926   if (attr->always_explicit)
 927     fputs (" ALWAYS-EXPLICIT", dumpfile);
 928   if (attr->is_main_program)
 929     fputs (" IS-MAIN-PROGRAM", dumpfile);
 930   if (attr->oacc_routine_nohost)
 931     fputs (" OACC-ROUTINE-NOHOST", dumpfile);
 932
 933   /* FIXME: Still missing are oacc_routine_lop and ext_attr.  */
 934   fputc (')', dumpfile);
 935 }
 936
 937
 938 /* Show components of a derived type.  */
 939
 940 static void
 941 show_components (gfc_symbol *sym)
 942 {
 943   gfc_component *c;
 944
 945   for (c = sym->components; c; c = c->next)
 946     {
 947       show_indent ();
 948       fprintf (dumpfile, "(%s ", c->name);
 949       show_typespec (&c->ts);
 950       if (c->kind_expr)
 951         {
 952           fputs (" kind_expr: ", dumpfile);
 953           show_expr (c->kind_expr);
 954         }
 955       if (c->param_list)
 956         {
 957           fputs ("PDT parameters", dumpfile);
 958           show_actual_arglist (c->param_list);
 959         }
 960
 961       if (c->attr.allocatable)
 962         fputs (" ALLOCATABLE", dumpfile);
 963       if (c->attr.pdt_kind)
 964         fputs (" KIND", dumpfile);
 965       if (c->attr.pdt_len)
 966         fputs (" LEN", dumpfile);
 967       if (c->attr.pointer)
 968         fputs (" POINTER", dumpfile);
 969       if (c->attr.proc_pointer)
 970         fputs (" PPC", dumpfile);
 971       if (c->attr.dimension)
 972         fputs (" DIMENSION", dumpfile);
 973       fputc (' ', dumpfile);
 974       show_array_spec (c->as);
 975       if (c->attr.access)
 976         fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access));
 977       fputc (')', dumpfile);
 978       if (c->next != NULL)
 979         fputc (' ', dumpfile);
 980     }
 981 }
 982
 983
 984 /* Show the f2k_derived namespace with procedure bindings.  */
 985
 986 static void
 987 show_typebound_proc (gfc_typebound_proc* tb, const char* name)
 988 {
 989   show_indent ();
 990
 991   if (tb->is_generic)
 992     fputs ("GENERIC", dumpfile);
 993   else
 994     {
 995       fputs ("PROCEDURE, ", dumpfile);
 996       if (tb->nopass)
 997         fputs ("NOPASS", dumpfile);
 998       else
 999         {
1000           if (tb->pass_arg)
1001             fprintf (dumpfile, "PASS(%s)", tb->pass_arg);
1002           else
1003             fputs ("PASS", dumpfile);
1004         }
1005       if (tb->non_overridable)
1006         fputs (", NON_OVERRIDABLE", dumpfile);
1007     }
1008
1009   if (tb->access == ACCESS_PUBLIC)
1010     fputs (", PUBLIC", dumpfile);
1011   else
1012     fputs (", PRIVATE", dumpfile);
1013
1014   fprintf (dumpfile, " :: %s => ", name);
1015
1016   if (tb->is_generic)
1017     {
1018       gfc_tbp_generic* g;
1019       for (g = tb->u.generic; g; g = g->next)
1020         {
1021           fputs (g->specific_st->name, dumpfile);
1022           if (g->next)
1023             fputs (", ", dumpfile);
1024         }
1025     }
1026   else
1027     fputs (tb->u.specific->n.sym->name, dumpfile);
1028 }
1029
1030 static void
1031 show_typebound_symtree (gfc_symtree* st)
1032 {
1033   gcc_assert (st->n.tb);
1034   show_typebound_proc (st->n.tb, st->name);
1035 }
1036
1037 static void
1038 show_f2k_derived (gfc_namespace* f2k)
1039 {
1040   gfc_finalizer* f;
1041   int op;
1042
1043   show_indent ();
1044   fputs ("Procedure bindings:", dumpfile);
1045   ++show_level;
1046
1047   /* Finalizer bindings.  */
1048   for (f = f2k->finalizers; f; f = f->next)
1049     {
1050       show_indent ();
1051       fprintf (dumpfile, "FINAL %s", f->proc_tree->n.sym->name);
1052     }
1053
1054   /* Type-bound procedures.  */
1055   gfc_traverse_symtree (f2k->tb_sym_root, &show_typebound_symtree);
1056
1057   --show_level;
1058
1059   show_indent ();
1060   fputs ("Operator bindings:", dumpfile);
1061   ++show_level;
1062
1063   /* User-defined operators.  */
1064   gfc_traverse_symtree (f2k->tb_uop_root, &show_typebound_symtree);
1065
1066   /* Intrinsic operators.  */
1067   for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
1068     if (f2k->tb_op[op])
1069       show_typebound_proc (f2k->tb_op[op],
1070                            gfc_op2string ((gfc_intrinsic_op) op));
1071
1072   --show_level;
1073 }
1074
1075
1076 /* Show a symbol.  If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
1077    show the interface.  Information needed to reconstruct the list of
1078    specific interfaces associated with a generic symbol is done within
1079    that symbol.  */
1080
1081 static void
1082 show_symbol (gfc_symbol *sym)
1083 {
1084   gfc_formal_arglist *formal;
1085   gfc_interface *intr;
1086   int i,len;
1087
1088   if (sym == NULL)
1089     return;
1090
1091   fprintf (dumpfile, "|| symbol: '%s' ", sym->name);
1092   len = strlen (sym->name);
1093   for (i=len; i<12; i++)
1094     fputc(' ', dumpfile);
1095
1096   if (sym->binding_label)
1097       fprintf (dumpfile,"|| binding_label: '%s' ", sym->binding_label);
1098
1099   ++show_level;
1100
1101   show_indent ();
1102   fputs ("type spec : ", dumpfile);
1103   show_typespec (&sym->ts);
1104
1105   show_indent ();
1106   fputs ("attributes: ", dumpfile);
1107   show_attr (&sym->attr, sym->module);
1108
1109   if (sym->value)
1110     {
1111       show_indent ();
1112       fputs ("value: ", dumpfile);
1113       show_expr (sym->value);
1114     }
1115
1116   if (sym->ts.type != BT_CLASS && sym->as)
1117     {
1118       show_indent ();
1119       fputs ("Array spec:", dumpfile);
1120       show_array_spec (sym->as);
1121     }
1122   else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
1123     {
1124       show_indent ();
1125       fputs ("Array spec:", dumpfile);
1126       show_array_spec (CLASS_DATA (sym)->as);
1127     }
1128
1129   if (sym->generic)
1130     {
1131       show_indent ();
1132       fputs ("Generic interfaces:", dumpfile);
1133       for (intr = sym->generic; intr; intr = intr->next)
1134         fprintf (dumpfile, " %s", intr->sym->name);
1135     }
1136
1137   if (sym->result)
1138     {
1139       show_indent ();
1140       fprintf (dumpfile, "result: %s", sym->result->name);
1141     }
1142
1143   if (sym->components)
1144     {
1145       show_indent ();
1146       fputs ("components: ", dumpfile);
1147       show_components (sym);
1148     }
1149
1150   if (sym->f2k_derived)
1151     {
1152       show_indent ();
1153       if (sym->hash_value)
1154         fprintf (dumpfile, "hash: %d", sym->hash_value);
1155       show_f2k_derived (sym->f2k_derived);
1156     }
1157
1158   if (sym->formal)
1159     {
1160       show_indent ();
1161       fputs ("Formal arglist:", dumpfile);
1162
1163       for (formal = sym->formal; formal; formal = formal->next)
1164         {
1165           if (formal->sym != NULL)
1166             fprintf (dumpfile, " %s", formal->sym->name);
1167           else
1168             fputs (" [Alt Return]", dumpfile);
1169         }
1170     }
1171
1172   if (sym->formal_ns && (sym->formal_ns->proc_name != sym)
1173       && sym->attr.proc != PROC_ST_FUNCTION
1174       && !sym->attr.entry)
1175     {
1176       show_indent ();
1177       fputs ("Formal namespace", dumpfile);
1178       show_namespace (sym->formal_ns);
1179     }
1180
1181   if (sym->attr.flavor == FL_VARIABLE
1182       && sym->param_list)
1183     {
1184       show_indent ();
1185       fputs ("PDT parameters", dumpfile);
1186       show_actual_arglist (sym->param_list);
1187     }
1188
1189   if (sym->attr.flavor == FL_NAMELIST)
1190     {
1191       gfc_namelist *nl;
1192       show_indent ();
1193       fputs ("variables : ", dumpfile);
1194       for (nl = sym->namelist; nl; nl = nl->next)
1195         fprintf (dumpfile, " %s",nl->sym->name);
1196     }
1197
1198   --show_level;
1199 }
1200
1201
1202 /* Show a user-defined operator.  Just prints an operator
1203    and the name of the associated subroutine, really.  */
1204
1205 static void
1206 show_uop (gfc_user_op *uop)
1207 {
1208   gfc_interface *intr;
1209
1210   show_indent ();
1211   fprintf (dumpfile, "%s:", uop->name);
1212
1213   for (intr = uop->op; intr; intr = intr->next)
1214     fprintf (dumpfile, " %s", intr->sym->name);
1215 }
1216
1217
1218 /* Workhorse function for traversing the user operator symtree.  */
1219
1220 static void
1221 traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *))
1222 {
1223   if (st == NULL)
1224     return;
1225
1226   (*func) (st->n.uop);
1227
1228   traverse_uop (st->left, func);
1229   traverse_uop (st->right, func);
1230 }
1231
1232
1233 /* Traverse the tree of user operator nodes.  */
1234
1235 void
1236 gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *))
1237 {
1238   traverse_uop (ns->uop_root, func);
1239 }
1240
1241
1242 /* Function to display a common block.  */
1243
1244 static void
1245 show_common (gfc_symtree *st)
1246 {
1247   gfc_symbol *s;
1248
1249   show_indent ();
1250   fprintf (dumpfile, "common: /%s/ ", st->name);
1251
1252   s = st->n.common->head;
1253   while (s)
1254     {
1255       fprintf (dumpfile, "%s", s->name);
1256       s = s->common_next;
1257       if (s)
1258         fputs (", ", dumpfile);
1259     }
1260   fputc ('\n', dumpfile);
1261 }
1262
1263
1264 /* Worker function to display the symbol tree.  */
1265
1266 static void
1267 show_symtree (gfc_symtree *st)
1268 {
1269   int len, i;
1270
1271   show_indent ();
1272
1273   len = strlen(st->name);
1274   fprintf (dumpfile, "symtree: '%s'", st->name);
1275
1276   for (i=len; i<12; i++)
1277     fputc(' ', dumpfile);
1278
1279   if (st->ambiguous)
1280     fputs( " Ambiguous", dumpfile);
1281
1282   if (st->n.sym->ns != gfc_current_ns)
1283     fprintf (dumpfile, "|| symbol: '%s' from namespace '%s'", st->n.sym->name,
1284              st->n.sym->ns->proc_name->name);
1285   else
1286     show_symbol (st->n.sym);
1287 }
1288
1289
1290 /******************* Show gfc_code structures **************/
1291
1292
1293 /* Show a list of code structures.  Mutually recursive with
1294    show_code_node().  */
1295
1296 static void
1297 show_code (int level, gfc_code *c)
1298 {
1299   for (; c; c = c->next)
1300     show_code_node (level, c);
1301 }
1302
1303 static void
1304 show_iterator (gfc_namespace *ns)
1305 {
1306   for (gfc_symbol *sym = ns->omp_affinity_iterators; sym; sym = sym->tlink)
1307     {
1308       gfc_constructor *c;
1309       if (sym != ns->omp_affinity_iterators)
1310         fputc (',', dumpfile);
1311       fputs (sym->name, dumpfile);
1312       fputc ('=', dumpfile);
1313       c = gfc_constructor_first (sym->value->value.constructor);
1314       show_expr (c->expr);
1315       fputc (':', dumpfile);
1316       c = gfc_constructor_next (c);
1317       show_expr (c->expr);
1318       c = gfc_constructor_next (c);
1319       if (c)
1320         {
1321           fputc (':', dumpfile);
1322           show_expr (c->expr);
1323         }
1324     }
1325 }
1326
1327 static void
1328 show_omp_namelist (int list_type, gfc_omp_namelist *n)
1329 {
1330   gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
1331   gfc_omp_namelist *n2 = n;
1332   for (; n; n = n->next)
1333     {
1334       gfc_current_ns = ns_curr;
1335       if (list_type == OMP_LIST_AFFINITY || list_type == OMP_LIST_DEPEND)
1336         {
1337           gfc_current_ns = n->u2.ns ? n->u2.ns : ns_curr;
1338           if (n->u2.ns != ns_iter)
1339             {
1340               if (n != n2)
1341                 {
1342                   fputs (") ", dumpfile);
1343                   if (list_type == OMP_LIST_AFFINITY)
1344                     fputs ("AFFINITY (", dumpfile);
1345                   else if (n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST)
1346                     fputs ("DOACROSS (", dumpfile);
1347                   else
1348                     fputs ("DEPEND (", dumpfile);
1349                 }
1350               if (n->u2.ns)
1351                 {
1352                   fputs ("ITERATOR(", dumpfile);
1353                   show_iterator (n->u2.ns);
1354                   fputc (')', dumpfile);
1355                   fputc (list_type == OMP_LIST_AFFINITY ? ':' : ',', dumpfile);
1356                 }
1357             }
1358           ns_iter = n->u2.ns;
1359         }
1360       if (list_type == OMP_LIST_ALLOCATE)
1361         {
1362           if (n->expr)
1363             {
1364               fputs ("allocator(", dumpfile);
1365               show_expr (n->expr);
1366               fputc (')', dumpfile);
1367             }
1368           if (n->expr && n->u.align)
1369             fputc (',', dumpfile);
1370           if (n->u.align)
1371             {
1372               fputs ("allocator(", dumpfile);
1373               show_expr (n->u.align);
1374               fputc (')', dumpfile);
1375             }
1376           if (n->expr || n->u.align)
1377             fputc (':', dumpfile);
1378           fputs (n->sym->name, dumpfile);
1379           if (n->next)
1380             fputs (") ALLOCATE(", dumpfile);
1381           continue;
1382         }
1383       if (list_type == OMP_LIST_REDUCTION)
1384         switch (n->u.reduction_op)
1385           {
1386           case OMP_REDUCTION_PLUS:
1387           case OMP_REDUCTION_TIMES:
1388           case OMP_REDUCTION_MINUS:
1389           case OMP_REDUCTION_AND:
1390           case OMP_REDUCTION_OR:
1391           case OMP_REDUCTION_EQV:
1392           case OMP_REDUCTION_NEQV:
1393             fprintf (dumpfile, "%s:",
1394                      gfc_op2string ((gfc_intrinsic_op) n->u.reduction_op));
1395             break;
1396           case OMP_REDUCTION_MAX: fputs ("max:", dumpfile); break;
1397           case OMP_REDUCTION_MIN: fputs ("min:", dumpfile); break;
1398           case OMP_REDUCTION_IAND: fputs ("iand:", dumpfile); break;
1399           case OMP_REDUCTION_IOR: fputs ("ior:", dumpfile); break;
1400           case OMP_REDUCTION_IEOR: fputs ("ieor:", dumpfile); break;
1401           case OMP_REDUCTION_USER:
1402             if (n->u2.udr)
1403               fprintf (dumpfile, "%s:", n->u2.udr->udr->name);
1404             break;
1405           default: break;
1406           }
1407       else if (list_type == OMP_LIST_DEPEND)
1408         switch (n->u.depend_doacross_op)
1409           {
1410           case OMP_DEPEND_IN: fputs ("in:", dumpfile); break;
1411           case OMP_DEPEND_OUT: fputs ("out:", dumpfile); break;
1412           case OMP_DEPEND_INOUT: fputs ("inout:", dumpfile); break;
1413           case OMP_DEPEND_INOUTSET: fputs ("inoutset:", dumpfile); break;
1414           case OMP_DEPEND_DEPOBJ: fputs ("depobj:", dumpfile); break;
1415           case OMP_DEPEND_MUTEXINOUTSET:
1416             fputs ("mutexinoutset:", dumpfile);
1417             break;
1418           case OMP_DEPEND_SINK_FIRST:
1419           case OMP_DOACROSS_SINK_FIRST:
1420             fputs ("sink:", dumpfile);
1421             while (1)
1422               {
1423                 if (!n->sym)
1424                   fputs ("omp_cur_iteration", dumpfile);
1425                 else
1426                   fprintf (dumpfile, "%s", n->sym->name);
1427                 if (n->expr)
1428                   {
1429                     fputc ('+', dumpfile);
1430                     show_expr (n->expr);
1431                   }
1432                 if (n->next == NULL)
1433                   break;
1434                 else if (n->next->u.depend_doacross_op != OMP_DOACROSS_SINK)
1435                   {
1436                     if (n->next->u.depend_doacross_op
1437                         == OMP_DOACROSS_SINK_FIRST)
1438                       fputs (") DOACROSS(", dumpfile);
1439                     else
1440                       fputs (") DEPEND(", dumpfile);
1441                     break;
1442                   }
1443                 fputc (',', dumpfile);
1444                 n = n->next;
1445               }
1446             continue;
1447           default: break;
1448           }
1449       else if (list_type == OMP_LIST_MAP)
1450         switch (n->u.map_op)
1451           {
1452           case OMP_MAP_ALLOC: fputs ("alloc:", dumpfile); break;
1453           case OMP_MAP_TO: fputs ("to:", dumpfile); break;
1454           case OMP_MAP_FROM: fputs ("from:", dumpfile); break;
1455           case OMP_MAP_TOFROM: fputs ("tofrom:", dumpfile); break;
1456           case OMP_MAP_ALWAYS_TO: fputs ("always,to:", dumpfile); break;
1457           case OMP_MAP_ALWAYS_FROM: fputs ("always,from:", dumpfile); break;
1458           case OMP_MAP_ALWAYS_TOFROM: fputs ("always,tofrom:", dumpfile); break;
1459           case OMP_MAP_DELETE: fputs ("delete:", dumpfile); break;
1460           case OMP_MAP_RELEASE: fputs ("release:", dumpfile); break;
1461           default: break;
1462           }
1463       else if (list_type == OMP_LIST_LINEAR && n->u.linear.old_modifier)
1464         switch (n->u.linear.op)
1465           {
1466           case OMP_LINEAR_REF: fputs ("ref(", dumpfile); break;
1467           case OMP_LINEAR_VAL: fputs ("val(", dumpfile); break;
1468           case OMP_LINEAR_UVAL: fputs ("uval(", dumpfile); break;
1469           default: break;
1470           }
1471       fprintf (dumpfile, "%s", n->sym ? n->sym->name : "omp_all_memory");
1472       if (list_type == OMP_LIST_LINEAR && n->u.linear.op != OMP_LINEAR_DEFAULT)
1473         fputc (')', dumpfile);
1474       if (n->expr)
1475         {
1476           fputc (':', dumpfile);
1477           show_expr (n->expr);
1478         }
1479       if (n->next)
1480         fputc (',', dumpfile);
1481     }
1482   gfc_current_ns = ns_curr;
1483 }
1484
1485 static void
1486 show_omp_assumes (gfc_omp_assumptions *assume)
1487 {
1488   for (int i = 0; i < assume->n_absent; i++)
1489     {
1490       fputs (" ABSENT (", dumpfile);
1491       fputs (gfc_ascii_statement (assume->absent[i], true), dumpfile);
1492       fputc (')', dumpfile);
1493     }
1494   for (int i = 0; i < assume->n_contains; i++)
1495     {
1496       fputs (" CONTAINS (", dumpfile);
1497       fputs (gfc_ascii_statement (assume->contains[i], true), dumpfile);
1498       fputc (')', dumpfile);
1499     }
1500   for (gfc_expr_list *el = assume->holds; el; el = el->next)
1501     {
1502       fputs (" HOLDS (", dumpfile);
1503       show_expr (el->expr);
1504       fputc (')', dumpfile);
1505     }
1506   if (assume->no_openmp)
1507     fputs (" NO_OPENMP", dumpfile);
1508   if (assume->no_openmp_routines)
1509     fputs (" NO_OPENMP_ROUTINES", dumpfile);
1510   if (assume->no_parallelism)
1511     fputs (" NO_PARALLELISM", dumpfile);
1512 }
1513
1514 /* Show OpenMP or OpenACC clauses.  */
1515
1516 static void
1517 show_omp_clauses (gfc_omp_clauses *omp_clauses)
1518 {
1519   int list_type, i;
1520
1521   switch (omp_clauses->cancel)
1522     {
1523     case OMP_CANCEL_UNKNOWN:
1524       break;
1525     case OMP_CANCEL_PARALLEL:
1526       fputs (" PARALLEL", dumpfile);
1527       break;
1528     case OMP_CANCEL_SECTIONS:
1529       fputs (" SECTIONS", dumpfile);
1530       break;
1531     case OMP_CANCEL_DO:
1532       fputs (" DO", dumpfile);
1533       break;
1534     case OMP_CANCEL_TASKGROUP:
1535       fputs (" TASKGROUP", dumpfile);
1536       break;
1537     }
1538   if (omp_clauses->if_expr)
1539     {
1540       fputs (" IF(", dumpfile);
1541       show_expr (omp_clauses->if_expr);
1542       fputc (')', dumpfile);
1543     }
1544   if (omp_clauses->final_expr)
1545     {
1546       fputs (" FINAL(", dumpfile);
1547       show_expr (omp_clauses->final_expr);
1548       fputc (')', dumpfile);
1549     }
1550   if (omp_clauses->num_threads)
1551     {
1552       fputs (" NUM_THREADS(", dumpfile);
1553       show_expr (omp_clauses->num_threads);
1554       fputc (')', dumpfile);
1555     }
1556   if (omp_clauses->async)
1557     {
1558       fputs (" ASYNC", dumpfile);
1559       if (omp_clauses->async_expr)
1560         {
1561           fputc ('(', dumpfile);
1562           show_expr (omp_clauses->async_expr);
1563           fputc (')', dumpfile);
1564         }
1565     }
1566   if (omp_clauses->num_gangs_expr)
1567     {
1568       fputs (" NUM_GANGS(", dumpfile);
1569       show_expr (omp_clauses->num_gangs_expr);
1570       fputc (')', dumpfile);
1571     }
1572   if (omp_clauses->num_workers_expr)
1573     {
1574       fputs (" NUM_WORKERS(", dumpfile);
1575       show_expr (omp_clauses->num_workers_expr);
1576       fputc (')', dumpfile);
1577     }
1578   if (omp_clauses->vector_length_expr)
1579     {
1580       fputs (" VECTOR_LENGTH(", dumpfile);
1581       show_expr (omp_clauses->vector_length_expr);
1582       fputc (')', dumpfile);
1583     }
1584   if (omp_clauses->gang)
1585     {
1586       fputs (" GANG", dumpfile);
1587       if (omp_clauses->gang_num_expr || omp_clauses->gang_static_expr)
1588         {
1589           fputc ('(', dumpfile);
1590           if (omp_clauses->gang_num_expr)
1591             {
1592               fprintf (dumpfile, "num:");
1593               show_expr (omp_clauses->gang_num_expr);
1594             }
1595           if (omp_clauses->gang_num_expr && omp_clauses->gang_static)
1596             fputc (',', dumpfile);
1597           if (omp_clauses->gang_static)
1598             {
1599               fprintf (dumpfile, "static:");
1600               if (omp_clauses->gang_static_expr)
1601                 show_expr (omp_clauses->gang_static_expr);
1602               else
1603                 fputc ('*', dumpfile);
1604             }
1605           fputc (')', dumpfile);
1606         }
1607     }
1608   if (omp_clauses->worker)
1609     {
1610       fputs (" WORKER", dumpfile);
1611       if (omp_clauses->worker_expr)
1612         {
1613           fputc ('(', dumpfile);
1614           show_expr (omp_clauses->worker_expr);
1615           fputc (')', dumpfile);
1616         }
1617     }
1618   if (omp_clauses->vector)
1619     {
1620       fputs (" VECTOR", dumpfile);
1621       if (omp_clauses->vector_expr)
1622         {
1623           fputc ('(', dumpfile);
1624           show_expr (omp_clauses->vector_expr);
1625           fputc (')', dumpfile);
1626         }
1627     }
1628   if (omp_clauses->sched_kind != OMP_SCHED_NONE)
1629     {
1630       const char *type;
1631       switch (omp_clauses->sched_kind)
1632         {
1633         case OMP_SCHED_STATIC: type = "STATIC"; break;
1634         case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
1635         case OMP_SCHED_GUIDED: type = "GUIDED"; break;
1636         case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
1637         case OMP_SCHED_AUTO: type = "AUTO"; break;
1638         default:
1639           gcc_unreachable ();
1640         }
1641       fputs (" SCHEDULE (", dumpfile);
1642       if (omp_clauses->sched_simd)
1643         {
1644           if (omp_clauses->sched_monotonic
1645               || omp_clauses->sched_nonmonotonic)
1646             fputs ("SIMD, ", dumpfile);
1647           else
1648             fputs ("SIMD: ", dumpfile);
1649         }
1650       if (omp_clauses->sched_monotonic)
1651         fputs ("MONOTONIC: ", dumpfile);
1652       else if (omp_clauses->sched_nonmonotonic)
1653         fputs ("NONMONOTONIC: ", dumpfile);
1654       fputs (type, dumpfile);
1655       if (omp_clauses->chunk_size)
1656         {
1657           fputc (',', dumpfile);
1658           show_expr (omp_clauses->chunk_size);
1659         }
1660       fputc (')', dumpfile);
1661     }
1662   if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
1663     {
1664       const char *type;
1665       switch (omp_clauses->default_sharing)
1666         {
1667         case OMP_DEFAULT_NONE: type = "NONE"; break;
1668         case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
1669         case OMP_DEFAULT_SHARED: type = "SHARED"; break;
1670         case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1671         case OMP_DEFAULT_PRESENT: type = "PRESENT"; break;
1672         default:
1673           gcc_unreachable ();
1674         }
1675       fprintf (dumpfile, " DEFAULT(%s)", type);
1676     }
1677   if (omp_clauses->tile_list)
1678     {
1679       gfc_expr_list *list;
1680       fputs (" TILE(", dumpfile);
1681       for (list = omp_clauses->tile_list; list; list = list->next)
1682         {
1683           show_expr (list->expr);
1684           if (list->next)
1685             fputs (", ", dumpfile);
1686         }
1687       fputc (')', dumpfile);
1688     }
1689   if (omp_clauses->wait_list)
1690     {
1691       gfc_expr_list *list;
1692       fputs (" WAIT(", dumpfile);
1693       for (list = omp_clauses->wait_list; list; list = list->next)
1694         {
1695           show_expr (list->expr);
1696           if (list->next)
1697             fputs (", ", dumpfile);
1698         }
1699       fputc (')', dumpfile);
1700     }
1701   if (omp_clauses->seq)
1702     fputs (" SEQ", dumpfile);
1703   if (omp_clauses->independent)
1704     fputs (" INDEPENDENT", dumpfile);
1705   if (omp_clauses->order_concurrent)
1706     {
1707       fputs (" ORDER(", dumpfile);
1708       if (omp_clauses->order_unconstrained)
1709         fputs ("UNCONSTRAINED:", dumpfile);
1710       else if (omp_clauses->order_reproducible)
1711         fputs ("REPRODUCIBLE:", dumpfile);
1712       fputs ("CONCURRENT)", dumpfile);
1713     }
1714   if (omp_clauses->ordered)
1715     {
1716       if (omp_clauses->orderedc)
1717         fprintf (dumpfile, " ORDERED(%d)", omp_clauses->orderedc);
1718       else
1719         fputs (" ORDERED", dumpfile);
1720     }
1721   if (omp_clauses->untied)
1722     fputs (" UNTIED", dumpfile);
1723   if (omp_clauses->mergeable)
1724     fputs (" MERGEABLE", dumpfile);
1725   if (omp_clauses->collapse)
1726     fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
1727   for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
1728     if (omp_clauses->lists[list_type] != NULL
1729         && list_type != OMP_LIST_COPYPRIVATE)
1730       {
1731         const char *type = NULL;
1732         switch (list_type)
1733           {
1734           case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
1735           case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1736           case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
1737           case OMP_LIST_COPYPRIVATE: type = "COPYPRIVATE"; break;
1738           case OMP_LIST_SHARED: type = "SHARED"; break;
1739           case OMP_LIST_COPYIN: type = "COPYIN"; break;
1740           case OMP_LIST_UNIFORM: type = "UNIFORM"; break;
1741           case OMP_LIST_AFFINITY: type = "AFFINITY"; break;
1742           case OMP_LIST_ALIGNED: type = "ALIGNED"; break;
1743           case OMP_LIST_LINEAR: type = "LINEAR"; break;
1744           case OMP_LIST_DEPEND:
1745             if (omp_clauses->lists[list_type]
1746                 && (omp_clauses->lists[list_type]->u.depend_doacross_op
1747                     == OMP_DOACROSS_SINK_FIRST))
1748               type = "DOACROSS";
1749             else
1750               type = "DEPEND";
1751             break;
1752           case OMP_LIST_MAP: type = "MAP"; break;
1753           case OMP_LIST_TO: type = "TO"; break;
1754           case OMP_LIST_FROM: type = "FROM"; break;
1755           case OMP_LIST_REDUCTION:
1756           case OMP_LIST_REDUCTION_INSCAN:
1757           case OMP_LIST_REDUCTION_TASK: type = "REDUCTION"; break;
1758           case OMP_LIST_IN_REDUCTION: type = "IN_REDUCTION"; break;
1759           case OMP_LIST_TASK_REDUCTION: type = "TASK_REDUCTION"; break;
1760           case OMP_LIST_DEVICE_RESIDENT: type = "DEVICE_RESIDENT"; break;
1761           case OMP_LIST_ENTER: type = "ENTER"; break;
1762           case OMP_LIST_LINK: type = "LINK"; break;
1763           case OMP_LIST_USE_DEVICE: type = "USE_DEVICE"; break;
1764           case OMP_LIST_CACHE: type = "CACHE"; break;
1765           case OMP_LIST_IS_DEVICE_PTR: type = "IS_DEVICE_PTR"; break;
1766           case OMP_LIST_USE_DEVICE_PTR: type = "USE_DEVICE_PTR"; break;
1767           case OMP_LIST_HAS_DEVICE_ADDR: type = "HAS_DEVICE_ADDR"; break;
1768           case OMP_LIST_USE_DEVICE_ADDR: type = "USE_DEVICE_ADDR"; break;
1769           case OMP_LIST_NONTEMPORAL: type = "NONTEMPORAL"; break;
1770           case OMP_LIST_ALLOCATE: type = "ALLOCATE"; break;
1771           case OMP_LIST_SCAN_IN: type = "INCLUSIVE"; break;
1772           case OMP_LIST_SCAN_EX: type = "EXCLUSIVE"; break;
1773           default:
1774             gcc_unreachable ();
1775           }
1776         fprintf (dumpfile, " %s(", type);
1777         if (list_type == OMP_LIST_REDUCTION_INSCAN)
1778           fputs ("inscan, ", dumpfile);
1779         if (list_type == OMP_LIST_REDUCTION_TASK)
1780           fputs ("task, ", dumpfile);
1781         show_omp_namelist (list_type, omp_clauses->lists[list_type]);
1782         fputc (')', dumpfile);
1783       }
1784   if (omp_clauses->safelen_expr)
1785     {
1786       fputs (" SAFELEN(", dumpfile);
1787       show_expr (omp_clauses->safelen_expr);
1788       fputc (')', dumpfile);
1789     }
1790   if (omp_clauses->simdlen_expr)
1791     {
1792       fputs (" SIMDLEN(", dumpfile);
1793       show_expr (omp_clauses->simdlen_expr);
1794       fputc (')', dumpfile);
1795     }
1796   if (omp_clauses->inbranch)
1797     fputs (" INBRANCH", dumpfile);
1798   if (omp_clauses->notinbranch)
1799     fputs (" NOTINBRANCH", dumpfile);
1800   if (omp_clauses->proc_bind != OMP_PROC_BIND_UNKNOWN)
1801     {
1802       const char *type;
1803       switch (omp_clauses->proc_bind)
1804         {
1805         case OMP_PROC_BIND_PRIMARY: type = "PRIMARY"; break;
1806         case OMP_PROC_BIND_MASTER: type = "MASTER"; break;
1807         case OMP_PROC_BIND_SPREAD: type = "SPREAD"; break;
1808         case OMP_PROC_BIND_CLOSE: type = "CLOSE"; break;
1809         default:
1810           gcc_unreachable ();
1811         }
1812       fprintf (dumpfile, " PROC_BIND(%s)", type);
1813     }
1814   if (omp_clauses->bind != OMP_BIND_UNSET)
1815     {
1816       const char *type;
1817       switch (omp_clauses->bind)
1818         {
1819         case OMP_BIND_TEAMS: type = "TEAMS"; break;
1820         case OMP_BIND_PARALLEL: type = "PARALLEL"; break;
1821         case OMP_BIND_THREAD: type = "THREAD"; break;
1822         default:
1823           gcc_unreachable ();
1824         }
1825       fprintf (dumpfile, " BIND(%s)", type);
1826     }
1827   if (omp_clauses->num_teams_upper)
1828     {
1829       fputs (" NUM_TEAMS(", dumpfile);
1830       if (omp_clauses->num_teams_lower)
1831         {
1832           show_expr (omp_clauses->num_teams_lower);
1833           fputc (':', dumpfile);
1834         }
1835       show_expr (omp_clauses->num_teams_upper);
1836       fputc (')', dumpfile);
1837     }
1838   if (omp_clauses->device)
1839     {
1840       fputs (" DEVICE(", dumpfile);
1841       if (omp_clauses->ancestor)
1842         fputs ("ANCESTOR:", dumpfile);
1843       show_expr (omp_clauses->device);
1844       fputc (')', dumpfile);
1845     }
1846   if (omp_clauses->thread_limit)
1847     {
1848       fputs (" THREAD_LIMIT(", dumpfile);
1849       show_expr (omp_clauses->thread_limit);
1850       fputc (')', dumpfile);
1851     }
1852   if (omp_clauses->dist_sched_kind != OMP_SCHED_NONE)
1853     {
1854       fputs (" DIST_SCHEDULE (STATIC", dumpfile);
1855       if (omp_clauses->dist_chunk_size)
1856         {
1857           fputc (',', dumpfile);
1858           show_expr (omp_clauses->dist_chunk_size);
1859         }
1860       fputc (')', dumpfile);
1861     }
1862   for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++)
1863     {
1864       const char *dfltmap;
1865       if (omp_clauses->defaultmap[i] == OMP_DEFAULTMAP_UNSET)
1866         continue;
1867       fputs (" DEFAULTMAP (", dumpfile);
1868       switch (omp_clauses->defaultmap[i])
1869         {
1870         case OMP_DEFAULTMAP_ALLOC: dfltmap = "ALLOC"; break;
1871         case OMP_DEFAULTMAP_TO: dfltmap = "TO"; break;
1872         case OMP_DEFAULTMAP_FROM: dfltmap = "FROM"; break;
1873         case OMP_DEFAULTMAP_TOFROM: dfltmap = "TOFROM"; break;
1874         case OMP_DEFAULTMAP_FIRSTPRIVATE: dfltmap = "FIRSTPRIVATE"; break;
1875         case OMP_DEFAULTMAP_NONE: dfltmap = "NONE"; break;
1876         case OMP_DEFAULTMAP_DEFAULT: dfltmap = "DEFAULT"; break;
1877         case OMP_DEFAULTMAP_PRESENT: dfltmap = "PRESENT"; break;
1878         default: gcc_unreachable ();
1879         }
1880       fputs (dfltmap, dumpfile);
1881       if (i != OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
1882         {
1883           fputc (':', dumpfile);
1884           switch ((enum gfc_omp_defaultmap_category) i)
1885             {
1886             case OMP_DEFAULTMAP_CAT_SCALAR: dfltmap = "SCALAR"; break;
1887             case OMP_DEFAULTMAP_CAT_AGGREGATE: dfltmap = "AGGREGATE"; break;
1888             case OMP_DEFAULTMAP_CAT_ALLOCATABLE: dfltmap = "ALLOCATABLE"; break;
1889             case OMP_DEFAULTMAP_CAT_POINTER: dfltmap = "POINTER"; break;
1890             default: gcc_unreachable ();
1891             }
1892           fputs (dfltmap, dumpfile);
1893         }
1894       fputc (')', dumpfile);
1895     }
1896   if (omp_clauses->weak)
1897     fputs (" WEAK", dumpfile);
1898   if (omp_clauses->compare)
1899     fputs (" COMPARE", dumpfile);
1900   if (omp_clauses->nogroup)
1901     fputs (" NOGROUP", dumpfile);
1902   if (omp_clauses->simd)
1903     fputs (" SIMD", dumpfile);
1904   if (omp_clauses->threads)
1905     fputs (" THREADS", dumpfile);
1906   if (omp_clauses->grainsize)
1907     {
1908       fputs (" GRAINSIZE(", dumpfile);
1909       if (omp_clauses->grainsize_strict)
1910         fputs ("strict: ", dumpfile);
1911       show_expr (omp_clauses->grainsize);
1912       fputc (')', dumpfile);
1913     }
1914   if (omp_clauses->filter)
1915     {
1916       fputs (" FILTER(", dumpfile);
1917       show_expr (omp_clauses->filter);
1918       fputc (')', dumpfile);
1919     }
1920   if (omp_clauses->hint)
1921     {
1922       fputs (" HINT(", dumpfile);
1923       show_expr (omp_clauses->hint);
1924       fputc (')', dumpfile);
1925     }
1926   if (omp_clauses->num_tasks)
1927     {
1928       fputs (" NUM_TASKS(", dumpfile);
1929       if (omp_clauses->num_tasks_strict)
1930         fputs ("strict: ", dumpfile);
1931       show_expr (omp_clauses->num_tasks);
1932       fputc (')', dumpfile);
1933     }
1934   if (omp_clauses->priority)
1935     {
1936       fputs (" PRIORITY(", dumpfile);
1937       show_expr (omp_clauses->priority);
1938       fputc (')', dumpfile);
1939     }
1940   if (omp_clauses->detach)
1941     {
1942       fputs (" DETACH(", dumpfile);
1943       show_expr (omp_clauses->detach);
1944       fputc (')', dumpfile);
1945     }
1946   for (i = 0; i < OMP_IF_LAST; i++)
1947     if (omp_clauses->if_exprs[i])
1948       {
1949         static const char *ifs[] = {
1950           "CANCEL",
1951           "PARALLEL",
1952           "SIMD",
1953           "TASK",
1954           "TASKLOOP",
1955           "TARGET",
1956           "TARGET DATA",
1957           "TARGET UPDATE",
1958           "TARGET ENTER DATA",
1959           "TARGET EXIT DATA"
1960         };
1961       fputs (" IF(", dumpfile);
1962       fputs (ifs[i], dumpfile);
1963       fputs (": ", dumpfile);
1964       show_expr (omp_clauses->if_exprs[i]);
1965       fputc (')', dumpfile);
1966     }
1967   if (omp_clauses->destroy)
1968     fputs (" DESTROY", dumpfile);
1969   if (omp_clauses->depend_source)
1970     fputs (" DEPEND(source)", dumpfile);
1971   if (omp_clauses->doacross_source)
1972     fputs (" DOACROSS(source:)", dumpfile);
1973   if (omp_clauses->capture)
1974     fputs (" CAPTURE", dumpfile);
1975   if (omp_clauses->depobj_update != OMP_DEPEND_UNSET)
1976     {
1977       const char *deptype;
1978       fputs (" UPDATE(", dumpfile);
1979       switch (omp_clauses->depobj_update)
1980         {
1981         case OMP_DEPEND_IN: deptype = "IN"; break;
1982         case OMP_DEPEND_OUT: deptype = "OUT"; break;
1983         case OMP_DEPEND_INOUT: deptype = "INOUT"; break;
1984         case OMP_DEPEND_INOUTSET: deptype = "INOUTSET"; break;
1985         case OMP_DEPEND_MUTEXINOUTSET: deptype = "MUTEXINOUTSET"; break;
1986         default: gcc_unreachable ();
1987         }
1988       fputs (deptype, dumpfile);
1989       fputc (')', dumpfile);
1990     }
1991   if (omp_clauses->atomic_op != GFC_OMP_ATOMIC_UNSET)
1992     {
1993       const char *atomic_op;
1994       switch (omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
1995         {
1996         case GFC_OMP_ATOMIC_READ: atomic_op = "READ"; break;
1997         case GFC_OMP_ATOMIC_WRITE: atomic_op = "WRITE"; break;
1998         case GFC_OMP_ATOMIC_UPDATE: atomic_op = "UPDATE"; break;
1999         default: gcc_unreachable ();
2000         }
2001       fputc (' ', dumpfile);
2002       fputs (atomic_op, dumpfile);
2003     }
2004   if (omp_clauses->memorder != OMP_MEMORDER_UNSET)
2005     {
2006       const char *memorder;
2007       switch (omp_clauses->memorder)
2008         {
2009         case OMP_MEMORDER_ACQ_REL: memorder = "ACQ_REL"; break;
2010         case OMP_MEMORDER_ACQUIRE: memorder = "AQUIRE"; break;
2011         case OMP_MEMORDER_RELAXED: memorder = "RELAXED"; break;
2012         case OMP_MEMORDER_RELEASE: memorder = "RELEASE"; break;
2013         case OMP_MEMORDER_SEQ_CST: memorder = "SEQ_CST"; break;
2014         default: gcc_unreachable ();
2015         }
2016       fputc (' ', dumpfile);
2017       fputs (memorder, dumpfile);
2018     }
2019   if (omp_clauses->fail != OMP_MEMORDER_UNSET)
2020     {
2021       const char *memorder;
2022       switch (omp_clauses->fail)
2023         {
2024         case OMP_MEMORDER_ACQUIRE: memorder = "AQUIRE"; break;
2025         case OMP_MEMORDER_RELAXED: memorder = "RELAXED"; break;
2026         case OMP_MEMORDER_SEQ_CST: memorder = "SEQ_CST"; break;
2027         default: gcc_unreachable ();
2028         }
2029       fputs (" FAIL(", dumpfile);
2030       fputs (memorder, dumpfile);
2031       putc (')', dumpfile);
2032     }
2033   if (omp_clauses->at != OMP_AT_UNSET)
2034     {
2035       if (omp_clauses->at != OMP_AT_COMPILATION)
2036         fputs (" AT (COMPILATION)", dumpfile);
2037       else
2038         fputs (" AT (EXECUTION)", dumpfile);
2039     }
2040   if (omp_clauses->severity != OMP_SEVERITY_UNSET)
2041     {
2042       if (omp_clauses->severity != OMP_SEVERITY_FATAL)
2043         fputs (" SEVERITY (FATAL)", dumpfile);
2044       else
2045         fputs (" SEVERITY (WARNING)", dumpfile);
2046     }
2047   if (omp_clauses->message)
2048     {
2049       fputs (" ERROR (", dumpfile);
2050       show_expr (omp_clauses->message);
2051       fputc (')', dumpfile);
2052     }
2053   if (omp_clauses->assume)
2054     show_omp_assumes (omp_clauses->assume);
2055 }
2056
2057 /* Show a single OpenMP or OpenACC directive node and everything underneath it
2058    if necessary.  */
2059
2060 static void
2061 show_omp_node (int level, gfc_code *c)
2062 {
2063   gfc_omp_clauses *omp_clauses = NULL;
2064   const char *name = NULL;
2065   bool is_oacc = false;
2066
2067   switch (c->op)
2068     {
2069     case EXEC_OACC_PARALLEL_LOOP:
2070       name = "PARALLEL LOOP"; is_oacc = true; break;
2071     case EXEC_OACC_PARALLEL: name = "PARALLEL"; is_oacc = true; break;
2072     case EXEC_OACC_KERNELS_LOOP: name = "KERNELS LOOP"; is_oacc = true; break;
2073     case EXEC_OACC_KERNELS: name = "KERNELS"; is_oacc = true; break;
2074     case EXEC_OACC_SERIAL_LOOP: name = "SERIAL LOOP"; is_oacc = true; break;
2075     case EXEC_OACC_SERIAL: name = "SERIAL"; is_oacc = true; break;
2076     case EXEC_OACC_DATA: name = "DATA"; is_oacc = true; break;
2077     case EXEC_OACC_HOST_DATA: name = "HOST_DATA"; is_oacc = true; break;
2078     case EXEC_OACC_LOOP: name = "LOOP"; is_oacc = true; break;
2079     case EXEC_OACC_UPDATE: name = "UPDATE"; is_oacc = true; break;
2080     case EXEC_OACC_WAIT: name = "WAIT"; is_oacc = true; break;
2081     case EXEC_OACC_CACHE: name = "CACHE"; is_oacc = true; break;
2082     case EXEC_OACC_ENTER_DATA: name = "ENTER DATA"; is_oacc = true; break;
2083     case EXEC_OACC_EXIT_DATA: name = "EXIT DATA"; is_oacc = true; break;
2084     case EXEC_OMP_ASSUME: name = "ASSUME"; break;
2085     case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
2086     case EXEC_OMP_BARRIER: name = "BARRIER"; break;
2087     case EXEC_OMP_CANCEL: name = "CANCEL"; break;
2088     case EXEC_OMP_CANCELLATION_POINT: name = "CANCELLATION POINT"; break;
2089     case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
2090     case EXEC_OMP_DISTRIBUTE: name = "DISTRIBUTE"; break;
2091     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
2092       name = "DISTRIBUTE PARALLEL DO"; break;
2093     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
2094       name = "DISTRIBUTE PARALLEL DO SIMD"; break;
2095     case EXEC_OMP_DISTRIBUTE_SIMD: name = "DISTRIBUTE SIMD"; break;
2096     case EXEC_OMP_DO: name = "DO"; break;
2097     case EXEC_OMP_DO_SIMD: name = "DO SIMD"; break;
2098     case EXEC_OMP_ERROR: name = "ERROR"; break;
2099     case EXEC_OMP_FLUSH: name = "FLUSH"; break;
2100     case EXEC_OMP_LOOP: name = "LOOP"; break;
2101     case EXEC_OMP_MASKED: name = "MASKED"; break;
2102     case EXEC_OMP_MASKED_TASKLOOP: name = "MASKED TASKLOOP"; break;
2103     case EXEC_OMP_MASKED_TASKLOOP_SIMD: name = "MASKED TASKLOOP SIMD"; break;
2104     case EXEC_OMP_MASTER: name = "MASTER"; break;
2105     case EXEC_OMP_MASTER_TASKLOOP: name = "MASTER TASKLOOP"; break;
2106     case EXEC_OMP_MASTER_TASKLOOP_SIMD: name = "MASTER TASKLOOP SIMD"; break;
2107     case EXEC_OMP_ORDERED: name = "ORDERED"; break;
2108     case EXEC_OMP_DEPOBJ: name = "DEPOBJ"; break;
2109     case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
2110     case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
2111     case EXEC_OMP_PARALLEL_DO_SIMD: name = "PARALLEL DO SIMD"; break;
2112     case EXEC_OMP_PARALLEL_LOOP: name = "PARALLEL LOOP"; break;
2113     case EXEC_OMP_PARALLEL_MASTER: name = "PARALLEL MASTER"; break;
2114     case EXEC_OMP_PARALLEL_MASKED: name = "PARALLEL MASK"; break;
2115     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
2116       name = "PARALLEL MASK TASKLOOP"; break;
2117     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
2118       name = "PARALLEL MASK TASKLOOP SIMD"; break;
2119     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
2120       name = "PARALLEL MASTER TASKLOOP"; break;
2121     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
2122       name = "PARALLEL MASTER TASKLOOP SIMD"; break;
2123     case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
2124     case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
2125     case EXEC_OMP_SCAN: name = "SCAN"; break;
2126     case EXEC_OMP_SCOPE: name = "SCOPE"; break;
2127     case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
2128     case EXEC_OMP_SIMD: name = "SIMD"; break;
2129     case EXEC_OMP_SINGLE: name = "SINGLE"; break;
2130     case EXEC_OMP_TARGET: name = "TARGET"; break;
2131     case EXEC_OMP_TARGET_DATA: name = "TARGET DATA"; break;
2132     case EXEC_OMP_TARGET_ENTER_DATA: name = "TARGET ENTER DATA"; break;
2133     case EXEC_OMP_TARGET_EXIT_DATA: name = "TARGET EXIT DATA"; break;
2134     case EXEC_OMP_TARGET_PARALLEL: name = "TARGET PARALLEL"; break;
2135     case EXEC_OMP_TARGET_PARALLEL_DO: name = "TARGET PARALLEL DO"; break;
2136     case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
2137       name = "TARGET_PARALLEL_DO_SIMD"; break;
2138     case EXEC_OMP_TARGET_PARALLEL_LOOP: name = "TARGET PARALLEL LOOP"; break;
2139     case EXEC_OMP_TARGET_SIMD: name = "TARGET SIMD"; break;
2140     case EXEC_OMP_TARGET_TEAMS: name = "TARGET TEAMS"; break;
2141     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
2142       name = "TARGET TEAMS DISTRIBUTE"; break;
2143     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
2144       name = "TARGET TEAMS DISTRIBUTE PARALLEL DO"; break;
2145     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2146       name = "TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; break;
2147     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
2148       name = "TARGET TEAMS DISTRIBUTE SIMD"; break;
2149     case EXEC_OMP_TARGET_TEAMS_LOOP: name = "TARGET TEAMS LOOP"; break;
2150     case EXEC_OMP_TARGET_UPDATE: name = "TARGET UPDATE"; break;
2151     case EXEC_OMP_TASK: name = "TASK"; break;
2152     case EXEC_OMP_TASKGROUP: name = "TASKGROUP"; break;
2153     case EXEC_OMP_TASKLOOP: name = "TASKLOOP"; break;
2154     case EXEC_OMP_TASKLOOP_SIMD: name = "TASKLOOP SIMD"; break;
2155     case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
2156     case EXEC_OMP_TASKYIELD: name = "TASKYIELD"; break;
2157     case EXEC_OMP_TEAMS: name = "TEAMS"; break;
2158     case EXEC_OMP_TEAMS_DISTRIBUTE: name = "TEAMS DISTRIBUTE"; break;
2159     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
2160       name = "TEAMS DISTRIBUTE PARALLEL DO"; break;
2161     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2162       name = "TEAMS DISTRIBUTE PARALLEL DO SIMD"; break;
2163     case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: name = "TEAMS DISTRIBUTE SIMD"; break;
2164     case EXEC_OMP_TEAMS_LOOP: name = "TEAMS LOOP"; break;
2165     case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
2166     default:
2167       gcc_unreachable ();
2168     }
2169   fprintf (dumpfile, "!$%s %s", is_oacc ? "ACC" : "OMP", name);
2170   switch (c->op)
2171     {
2172     case EXEC_OACC_PARALLEL_LOOP:
2173     case EXEC_OACC_PARALLEL:
2174     case EXEC_OACC_KERNELS_LOOP:
2175     case EXEC_OACC_KERNELS:
2176     case EXEC_OACC_SERIAL_LOOP:
2177     case EXEC_OACC_SERIAL:
2178     case EXEC_OACC_DATA:
2179     case EXEC_OACC_HOST_DATA:
2180     case EXEC_OACC_LOOP:
2181     case EXEC_OACC_UPDATE:
2182     case EXEC_OACC_WAIT:
2183     case EXEC_OACC_CACHE:
2184     case EXEC_OACC_ENTER_DATA:
2185     case EXEC_OACC_EXIT_DATA:
2186     case EXEC_OMP_ASSUME:
2187     case EXEC_OMP_CANCEL:
2188     case EXEC_OMP_CANCELLATION_POINT:
2189     case EXEC_OMP_DISTRIBUTE:
2190     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
2191     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
2192     case EXEC_OMP_DISTRIBUTE_SIMD:
2193     case EXEC_OMP_DO:
2194     case EXEC_OMP_DO_SIMD:
2195     case EXEC_OMP_ERROR:
2196     case EXEC_OMP_LOOP:
2197     case EXEC_OMP_ORDERED:
2198     case EXEC_OMP_MASKED:
2199     case EXEC_OMP_PARALLEL:
2200     case EXEC_OMP_PARALLEL_DO:
2201     case EXEC_OMP_PARALLEL_DO_SIMD:
2202     case EXEC_OMP_PARALLEL_LOOP:
2203     case EXEC_OMP_PARALLEL_MASKED:
2204     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
2205     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
2206     case EXEC_OMP_PARALLEL_MASTER:
2207     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
2208     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
2209     case EXEC_OMP_PARALLEL_SECTIONS:
2210     case EXEC_OMP_PARALLEL_WORKSHARE:
2211     case EXEC_OMP_SCAN:
2212     case EXEC_OMP_SCOPE:
2213     case EXEC_OMP_SECTIONS:
2214     case EXEC_OMP_SIMD:
2215     case EXEC_OMP_SINGLE:
2216     case EXEC_OMP_TARGET:
2217     case EXEC_OMP_TARGET_DATA:
2218     case EXEC_OMP_TARGET_ENTER_DATA:
2219     case EXEC_OMP_TARGET_EXIT_DATA:
2220     case EXEC_OMP_TARGET_PARALLEL:
2221     case EXEC_OMP_TARGET_PARALLEL_DO:
2222     case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
2223     case EXEC_OMP_TARGET_PARALLEL_LOOP:
2224     case EXEC_OMP_TARGET_SIMD:
2225     case EXEC_OMP_TARGET_TEAMS:
2226     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
2227     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
2228     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2229     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
2230     case EXEC_OMP_TARGET_TEAMS_LOOP:
2231     case EXEC_OMP_TARGET_UPDATE:
2232     case EXEC_OMP_TASK:
2233     case EXEC_OMP_TASKLOOP:
2234     case EXEC_OMP_TASKLOOP_SIMD:
2235     case EXEC_OMP_TEAMS:
2236     case EXEC_OMP_TEAMS_DISTRIBUTE:
2237     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
2238     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2239     case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
2240     case EXEC_OMP_TEAMS_LOOP:
2241     case EXEC_OMP_WORKSHARE:
2242       omp_clauses = c->ext.omp_clauses;
2243       break;
2244     case EXEC_OMP_CRITICAL:
2245       omp_clauses = c->ext.omp_clauses;
2246       if (omp_clauses)
2247         fprintf (dumpfile, " (%s)", c->ext.omp_clauses->critical_name);
2248       break;
2249     case EXEC_OMP_DEPOBJ:
2250       omp_clauses = c->ext.omp_clauses;
2251       if (omp_clauses)
2252         {
2253           fputc ('(', dumpfile);
2254           show_expr (c->ext.omp_clauses->depobj);
2255           fputc (')', dumpfile);
2256         }
2257       break;
2258     case EXEC_OMP_FLUSH:
2259       if (c->ext.omp_namelist)
2260         {
2261           fputs (" (", dumpfile);
2262           show_omp_namelist (OMP_LIST_NUM, c->ext.omp_namelist);
2263           fputc (')', dumpfile);
2264         }
2265       return;
2266     case EXEC_OMP_BARRIER:
2267     case EXEC_OMP_TASKWAIT:
2268     case EXEC_OMP_TASKYIELD:
2269       return;
2270     case EXEC_OACC_ATOMIC:
2271     case EXEC_OMP_ATOMIC:
2272       omp_clauses = c->block ? c->block->ext.omp_clauses : NULL;
2273       break;
2274     default:
2275       break;
2276     }
2277   if (omp_clauses)
2278     show_omp_clauses (omp_clauses);
2279   fputc ('\n', dumpfile);
2280
2281   /* OpenMP and OpenACC executable directives don't have associated blocks.  */
2282   if (c->op == EXEC_OACC_CACHE || c->op == EXEC_OACC_UPDATE
2283       || c->op == EXEC_OACC_ENTER_DATA || c->op == EXEC_OACC_EXIT_DATA
2284       || c->op == EXEC_OMP_TARGET_UPDATE || c->op == EXEC_OMP_TARGET_ENTER_DATA
2285       || c->op == EXEC_OMP_TARGET_EXIT_DATA || c->op == EXEC_OMP_SCAN
2286       || c->op == EXEC_OMP_DEPOBJ || c->op == EXEC_OMP_ERROR
2287       || (c->op == EXEC_OMP_ORDERED && c->block == NULL))
2288     return;
2289   if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
2290     {
2291       gfc_code *d = c->block;
2292       while (d != NULL)
2293         {
2294           show_code (level + 1, d->next);
2295           if (d->block == NULL)
2296             break;
2297           code_indent (level, 0);
2298           fputs ("!$OMP SECTION\n", dumpfile);
2299           d = d->block;
2300         }
2301     }
2302   else
2303     show_code (level + 1, c->block->next);
2304   if (c->op == EXEC_OMP_ATOMIC)
2305     return;
2306   fputc ('\n', dumpfile);
2307   code_indent (level, 0);
2308   fprintf (dumpfile, "!$%s END %s", is_oacc ? "ACC" : "OMP", name);
2309   if (omp_clauses != NULL)
2310     {
2311       if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
2312         {
2313           fputs (" COPYPRIVATE(", dumpfile);
2314           show_omp_namelist (OMP_LIST_COPYPRIVATE,
2315                              omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
2316           fputc (')', dumpfile);
2317         }
2318       else if (omp_clauses->nowait)
2319         fputs (" NOWAIT", dumpfile);
2320     }
2321   else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_clauses)
2322     fprintf (dumpfile, " (%s)", c->ext.omp_clauses->critical_name);
2323 }
2324
2325
2326 /* Show a single code node and everything underneath it if necessary.  */
2327
2328 static void
2329 show_code_node (int level, gfc_code *c)
2330 {
2331   gfc_forall_iterator *fa;
2332   gfc_open *open;
2333   gfc_case *cp;
2334   gfc_alloc *a;
2335   gfc_code *d;
2336   gfc_close *close;
2337   gfc_filepos *fp;
2338   gfc_inquire *i;
2339   gfc_dt *dt;
2340   gfc_namespace *ns;
2341
2342   if (c->here)
2343     {
2344       fputc ('\n', dumpfile);
2345       code_indent (level, c->here);
2346     }
2347   else
2348     show_indent ();
2349
2350   switch (c->op)
2351     {
2352     case EXEC_END_PROCEDURE:
2353       break;
2354
2355     case EXEC_NOP:
2356       fputs ("NOP", dumpfile);
2357       break;
2358
2359     case EXEC_CONTINUE:
2360       fputs ("CONTINUE", dumpfile);
2361       break;
2362
2363     case EXEC_ENTRY:
2364       fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
2365       break;
2366
2367     case EXEC_INIT_ASSIGN:
2368     case EXEC_ASSIGN:
2369       fputs ("ASSIGN ", dumpfile);
2370       show_expr (c->expr1);
2371       fputc (' ', dumpfile);
2372       show_expr (c->expr2);
2373       break;
2374
2375     case EXEC_LABEL_ASSIGN:
2376       fputs ("LABEL ASSIGN ", dumpfile);
2377       show_expr (c->expr1);
2378       fprintf (dumpfile, " %d", c->label1->value);
2379       break;
2380
2381     case EXEC_POINTER_ASSIGN:
2382       fputs ("POINTER ASSIGN ", dumpfile);
2383       show_expr (c->expr1);
2384       fputc (' ', dumpfile);
2385       show_expr (c->expr2);
2386       break;
2387
2388     case EXEC_GOTO:
2389       fputs ("GOTO ", dumpfile);
2390       if (c->label1)
2391         fprintf (dumpfile, "%d", c->label1->value);
2392       else
2393         {
2394           show_expr (c->expr1);
2395           d = c->block;
2396           if (d != NULL)
2397             {
2398               fputs (", (", dumpfile);
2399               for (; d; d = d ->block)
2400                 {
2401                   code_indent (level, d->label1);
2402                   if (d->block != NULL)
2403                     fputc (',', dumpfile);
2404                   else
2405                     fputc (')', dumpfile);
2406                 }
2407             }
2408         }
2409       break;
2410
2411     case EXEC_CALL:
2412     case EXEC_ASSIGN_CALL:
2413       if (c->resolved_sym)
2414         fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
2415       else if (c->symtree)
2416         fprintf (dumpfile, "CALL %s ", c->symtree->name);
2417       else
2418         fputs ("CALL ?? ", dumpfile);
2419
2420       show_actual_arglist (c->ext.actual);
2421       break;
2422
2423     case EXEC_COMPCALL:
2424       fputs ("CALL ", dumpfile);
2425       show_compcall (c->expr1);
2426       break;
2427
2428     case EXEC_CALL_PPC:
2429       fputs ("CALL ", dumpfile);
2430       show_expr (c->expr1);
2431       show_actual_arglist (c->ext.actual);
2432       break;
2433
2434     case EXEC_RETURN:
2435       fputs ("RETURN ", dumpfile);
2436       if (c->expr1)
2437         show_expr (c->expr1);
2438       break;
2439
2440     case EXEC_PAUSE:
2441       fputs ("PAUSE ", dumpfile);
2442
2443       if (c->expr1 != NULL)
2444         show_expr (c->expr1);
2445       else
2446         fprintf (dumpfile, "%d", c->ext.stop_code);
2447
2448       break;
2449
2450     case EXEC_ERROR_STOP:
2451       fputs ("ERROR ", dumpfile);
2452       /* Fall through.  */
2453
2454     case EXEC_STOP:
2455       fputs ("STOP ", dumpfile);
2456
2457       if (c->expr1 != NULL)
2458         show_expr (c->expr1);
2459       else
2460         fprintf (dumpfile, "%d", c->ext.stop_code);
2461       if (c->expr2 != NULL)
2462         {
2463           fputs (" QUIET=", dumpfile);
2464           show_expr (c->expr2);
2465         }
2466
2467       break;
2468
2469     case EXEC_FAIL_IMAGE:
2470       fputs ("FAIL IMAGE ", dumpfile);
2471       break;
2472
2473     case EXEC_CHANGE_TEAM:
2474       fputs ("CHANGE TEAM", dumpfile);
2475       break;
2476
2477     case EXEC_END_TEAM:
2478       fputs ("END TEAM", dumpfile);
2479       break;
2480
2481     case EXEC_FORM_TEAM:
2482       fputs ("FORM TEAM", dumpfile);
2483       break;
2484
2485     case EXEC_SYNC_TEAM:
2486       fputs ("SYNC TEAM", dumpfile);
2487       break;
2488
2489     case EXEC_SYNC_ALL:
2490       fputs ("SYNC ALL ", dumpfile);
2491       if (c->expr2 != NULL)
2492         {
2493           fputs (" stat=", dumpfile);
2494           show_expr (c->expr2);
2495         }
2496       if (c->expr3 != NULL)
2497         {
2498           fputs (" errmsg=", dumpfile);
2499           show_expr (c->expr3);
2500         }
2501       break;
2502
2503     case EXEC_SYNC_MEMORY:
2504       fputs ("SYNC MEMORY ", dumpfile);
2505       if (c->expr2 != NULL)
2506         {
2507           fputs (" stat=", dumpfile);
2508           show_expr (c->expr2);
2509         }
2510       if (c->expr3 != NULL)
2511         {
2512           fputs (" errmsg=", dumpfile);
2513           show_expr (c->expr3);
2514         }
2515       break;
2516
2517     case EXEC_SYNC_IMAGES:
2518       fputs ("SYNC IMAGES  image-set=", dumpfile);
2519       if (c->expr1 != NULL)
2520         show_expr (c->expr1);
2521       else
2522         fputs ("* ", dumpfile);
2523       if (c->expr2 != NULL)
2524         {
2525           fputs (" stat=", dumpfile);
2526           show_expr (c->expr2);
2527         }
2528       if (c->expr3 != NULL)
2529         {
2530           fputs (" errmsg=", dumpfile);
2531           show_expr (c->expr3);
2532         }
2533       break;
2534
2535     case EXEC_EVENT_POST:
2536     case EXEC_EVENT_WAIT:
2537       if (c->op == EXEC_EVENT_POST)
2538         fputs ("EVENT POST ", dumpfile);
2539       else
2540         fputs ("EVENT WAIT ", dumpfile);
2541
2542       fputs ("event-variable=", dumpfile);
2543       if (c->expr1 != NULL)
2544         show_expr (c->expr1);
2545       if (c->expr4 != NULL)
2546         {
2547           fputs (" until_count=", dumpfile);
2548           show_expr (c->expr4);
2549         }
2550       if (c->expr2 != NULL)
2551         {
2552           fputs (" stat=", dumpfile);
2553           show_expr (c->expr2);
2554         }
2555       if (c->expr3 != NULL)
2556         {
2557           fputs (" errmsg=", dumpfile);
2558           show_expr (c->expr3);
2559         }
2560       break;
2561
2562     case EXEC_LOCK:
2563     case EXEC_UNLOCK:
2564       if (c->op == EXEC_LOCK)
2565         fputs ("LOCK ", dumpfile);
2566       else
2567         fputs ("UNLOCK ", dumpfile);
2568
2569       fputs ("lock-variable=", dumpfile);
2570       if (c->expr1 != NULL)
2571         show_expr (c->expr1);
2572       if (c->expr4 != NULL)
2573         {
2574           fputs (" acquired_lock=", dumpfile);
2575           show_expr (c->expr4);
2576         }
2577       if (c->expr2 != NULL)
2578         {
2579           fputs (" stat=", dumpfile);
2580           show_expr (c->expr2);
2581         }
2582       if (c->expr3 != NULL)
2583         {
2584           fputs (" errmsg=", dumpfile);
2585           show_expr (c->expr3);
2586         }
2587       break;
2588
2589     case EXEC_ARITHMETIC_IF:
2590       fputs ("IF ", dumpfile);
2591       show_expr (c->expr1);
2592       fprintf (dumpfile, " %d, %d, %d",
2593                   c->label1->value, c->label2->value, c->label3->value);
2594       break;
2595
2596     case EXEC_IF:
2597       d = c->block;
2598       fputs ("IF ", dumpfile);
2599       show_expr (d->expr1);
2600
2601       ++show_level;
2602       show_code (level + 1, d->next);
2603       --show_level;
2604
2605       d = d->block;
2606       for (; d; d = d->block)
2607         {
2608           fputs("\n", dumpfile);
2609           code_indent (level, 0);
2610           if (d->expr1 == NULL)
2611             fputs ("ELSE", dumpfile);
2612           else
2613             {
2614               fputs ("ELSE IF ", dumpfile);
2615               show_expr (d->expr1);
2616             }
2617
2618           ++show_level;
2619           show_code (level + 1, d->next);
2620           --show_level;
2621         }
2622
2623       if (c->label1)
2624         code_indent (level, c->label1);
2625       else
2626         show_indent ();
2627
2628       fputs ("ENDIF", dumpfile);
2629       break;
2630
2631     case EXEC_BLOCK:
2632       {
2633         const char* blocktype;
2634         gfc_namespace *saved_ns;
2635         gfc_association_list *alist;
2636
2637         if (c->ext.block.assoc)
2638           blocktype = "ASSOCIATE";
2639         else
2640           blocktype = "BLOCK";
2641         show_indent ();
2642         fprintf (dumpfile, "%s ", blocktype);
2643         for (alist = c->ext.block.assoc; alist; alist = alist->next)
2644           {
2645             fprintf (dumpfile, " %s = ", alist->name);
2646             show_expr (alist->target);
2647           }
2648
2649         ++show_level;
2650         ns = c->ext.block.ns;
2651         saved_ns = gfc_current_ns;
2652         gfc_current_ns = ns;
2653         gfc_traverse_symtree (ns->sym_root, show_symtree);
2654         gfc_current_ns = saved_ns;
2655         show_code (show_level, ns->code);
2656         --show_level;
2657         show_indent ();
2658         fprintf (dumpfile, "END %s ", blocktype);
2659         break;
2660       }
2661
2662     case EXEC_END_BLOCK:
2663       /* Only come here when there is a label on an
2664          END ASSOCIATE construct.  */
2665       break;
2666
2667     case EXEC_SELECT:
2668     case EXEC_SELECT_TYPE:
2669     case EXEC_SELECT_RANK:
2670       d = c->block;
2671       fputc ('\n', dumpfile);
2672       code_indent (level, 0);
2673       if (c->op == EXEC_SELECT_RANK)
2674         fputs ("SELECT RANK ", dumpfile);
2675       else if (c->op == EXEC_SELECT_TYPE)
2676         fputs ("SELECT TYPE ", dumpfile);
2677       else
2678         fputs ("SELECT CASE ", dumpfile);
2679       show_expr (c->expr1);
2680
2681       for (; d; d = d->block)
2682         {
2683           fputc ('\n', dumpfile);
2684           code_indent (level, 0);
2685           fputs ("CASE ", dumpfile);
2686           for (cp = d->ext.block.case_list; cp; cp = cp->next)
2687             {
2688               fputc ('(', dumpfile);
2689               show_expr (cp->low);
2690               fputc (' ', dumpfile);
2691               show_expr (cp->high);
2692               fputc (')', dumpfile);
2693               fputc (' ', dumpfile);
2694             }
2695
2696           show_code (level + 1, d->next);
2697           fputc ('\n', dumpfile);
2698         }
2699
2700       code_indent (level, c->label1);
2701       fputs ("END SELECT", dumpfile);
2702       break;
2703
2704     case EXEC_WHERE:
2705       fputs ("WHERE ", dumpfile);
2706
2707       d = c->block;
2708       show_expr (d->expr1);
2709       fputc ('\n', dumpfile);
2710
2711       show_code (level + 1, d->next);
2712
2713       for (d = d->block; d; d = d->block)
2714         {
2715           code_indent (level, 0);
2716           fputs ("ELSE WHERE ", dumpfile);
2717           show_expr (d->expr1);
2718           fputc ('\n', dumpfile);
2719           show_code (level + 1, d->next);
2720         }
2721
2722       code_indent (level, 0);
2723       fputs ("END WHERE", dumpfile);
2724       break;
2725
2726
2727     case EXEC_FORALL:
2728       fputs ("FORALL ", dumpfile);
2729       for (fa = c->ext.forall_iterator; fa; fa = fa->next)
2730         {
2731           show_expr (fa->var);
2732           fputc (' ', dumpfile);
2733           show_expr (fa->start);
2734           fputc (':', dumpfile);
2735           show_expr (fa->end);
2736           fputc (':', dumpfile);
2737           show_expr (fa->stride);
2738
2739           if (fa->next != NULL)
2740             fputc (',', dumpfile);
2741         }
2742
2743       if (c->expr1 != NULL)
2744         {
2745           fputc (',', dumpfile);
2746           show_expr (c->expr1);
2747         }
2748       fputc ('\n', dumpfile);
2749
2750       show_code (level + 1, c->block->next);
2751
2752       code_indent (level, 0);
2753       fputs ("END FORALL", dumpfile);
2754       break;
2755
2756     case EXEC_CRITICAL:
2757       fputs ("CRITICAL\n", dumpfile);
2758       show_code (level + 1, c->block->next);
2759       code_indent (level, 0);
2760       fputs ("END CRITICAL", dumpfile);
2761       break;
2762
2763     case EXEC_DO:
2764       fputs ("DO ", dumpfile);
2765       if (c->label1)
2766         fprintf (dumpfile, " %-5d ", c->label1->value);
2767
2768       show_expr (c->ext.iterator->var);
2769       fputc ('=', dumpfile);
2770       show_expr (c->ext.iterator->start);
2771       fputc (' ', dumpfile);
2772       show_expr (c->ext.iterator->end);
2773       fputc (' ', dumpfile);
2774       show_expr (c->ext.iterator->step);
2775
2776       ++show_level;
2777       show_code (level + 1, c->block->next);
2778       --show_level;
2779
2780       if (c->label1)
2781         break;
2782
2783       show_indent ();
2784       fputs ("END DO", dumpfile);
2785       break;
2786
2787     case EXEC_DO_CONCURRENT:
2788       fputs ("DO CONCURRENT ", dumpfile);
2789       for (fa = c->ext.forall_iterator; fa; fa = fa->next)
2790         {
2791           show_expr (fa->var);
2792           fputc (' ', dumpfile);
2793           show_expr (fa->start);
2794           fputc (':', dumpfile);
2795           show_expr (fa->end);
2796           fputc (':', dumpfile);
2797           show_expr (fa->stride);
2798
2799           if (fa->next != NULL)
2800             fputc (',', dumpfile);
2801         }
2802       show_expr (c->expr1);
2803       ++show_level;
2804
2805       show_code (level + 1, c->block->next);
2806       --show_level;
2807       code_indent (level, c->label1);
2808       show_indent ();
2809       fputs ("END DO", dumpfile);
2810       break;
2811
2812     case EXEC_DO_WHILE:
2813       fputs ("DO WHILE ", dumpfile);
2814       show_expr (c->expr1);
2815       fputc ('\n', dumpfile);
2816
2817       show_code (level + 1, c->block->next);
2818
2819       code_indent (level, c->label1);
2820       fputs ("END DO", dumpfile);
2821       break;
2822
2823     case EXEC_CYCLE:
2824       fputs ("CYCLE", dumpfile);
2825       if (c->symtree)
2826         fprintf (dumpfile, " %s", c->symtree->n.sym->name);
2827       break;
2828
2829     case EXEC_EXIT:
2830       fputs ("EXIT", dumpfile);
2831       if (c->symtree)
2832         fprintf (dumpfile, " %s", c->symtree->n.sym->name);
2833       break;
2834
2835     case EXEC_ALLOCATE:
2836       fputs ("ALLOCATE ", dumpfile);
2837       if (c->expr1)
2838         {
2839           fputs (" STAT=", dumpfile);
2840           show_expr (c->expr1);
2841         }
2842
2843       if (c->expr2)
2844         {
2845           fputs (" ERRMSG=", dumpfile);
2846           show_expr (c->expr2);
2847         }
2848
2849       if (c->expr3)
2850         {
2851           if (c->expr3->mold)
2852             fputs (" MOLD=", dumpfile);
2853           else
2854             fputs (" SOURCE=", dumpfile);
2855           show_expr (c->expr3);
2856         }
2857
2858       for (a = c->ext.alloc.list; a; a = a->next)
2859         {
2860           fputc (' ', dumpfile);
2861           show_expr (a->expr);
2862         }
2863
2864       break;
2865
2866     case EXEC_DEALLOCATE:
2867       fputs ("DEALLOCATE ", dumpfile);
2868       if (c->expr1)
2869         {
2870           fputs (" STAT=", dumpfile);
2871           show_expr (c->expr1);
2872         }
2873
2874       if (c->expr2)
2875         {
2876           fputs (" ERRMSG=", dumpfile);
2877           show_expr (c->expr2);
2878         }
2879
2880       for (a = c->ext.alloc.list; a; a = a->next)
2881         {
2882           fputc (' ', dumpfile);
2883           show_expr (a->expr);
2884         }
2885
2886       break;
2887
2888     case EXEC_OPEN:
2889       fputs ("OPEN", dumpfile);
2890       open = c->ext.open;
2891
2892       if (open->unit)
2893         {
2894           fputs (" UNIT=", dumpfile);
2895           show_expr (open->unit);
2896         }
2897       if (open->iomsg)
2898         {
2899           fputs (" IOMSG=", dumpfile);
2900           show_expr (open->iomsg);
2901         }
2902       if (open->iostat)
2903         {
2904           fputs (" IOSTAT=", dumpfile);
2905           show_expr (open->iostat);
2906         }
2907       if (open->file)
2908         {
2909           fputs (" FILE=", dumpfile);
2910           show_expr (open->file);
2911         }
2912       if (open->status)
2913         {
2914           fputs (" STATUS=", dumpfile);
2915           show_expr (open->status);
2916         }
2917       if (open->access)
2918         {
2919           fputs (" ACCESS=", dumpfile);
2920           show_expr (open->access);
2921         }
2922       if (open->form)
2923         {
2924           fputs (" FORM=", dumpfile);
2925           show_expr (open->form);
2926         }
2927       if (open->recl)
2928         {
2929           fputs (" RECL=", dumpfile);
2930           show_expr (open->recl);
2931         }
2932       if (open->blank)
2933         {
2934           fputs (" BLANK=", dumpfile);
2935           show_expr (open->blank);
2936         }
2937       if (open->position)
2938         {
2939           fputs (" POSITION=", dumpfile);
2940           show_expr (open->position);
2941         }
2942       if (open->action)
2943         {
2944           fputs (" ACTION=", dumpfile);
2945           show_expr (open->action);
2946         }
2947       if (open->delim)
2948         {
2949           fputs (" DELIM=", dumpfile);
2950           show_expr (open->delim);
2951         }
2952       if (open->pad)
2953         {
2954           fputs (" PAD=", dumpfile);
2955           show_expr (open->pad);
2956         }
2957       if (open->decimal)
2958         {
2959           fputs (" DECIMAL=", dumpfile);
2960           show_expr (open->decimal);
2961         }
2962       if (open->encoding)
2963         {
2964           fputs (" ENCODING=", dumpfile);
2965           show_expr (open->encoding);
2966         }
2967       if (open->round)
2968         {
2969           fputs (" ROUND=", dumpfile);
2970           show_expr (open->round);
2971         }
2972       if (open->sign)
2973         {
2974           fputs (" SIGN=", dumpfile);
2975           show_expr (open->sign);
2976         }
2977       if (open->convert)
2978         {
2979           fputs (" CONVERT=", dumpfile);
2980           show_expr (open->convert);
2981         }
2982       if (open->asynchronous)
2983         {
2984           fputs (" ASYNCHRONOUS=", dumpfile);
2985           show_expr (open->asynchronous);
2986         }
2987       if (open->err != NULL)
2988         fprintf (dumpfile, " ERR=%d", open->err->value);
2989
2990       break;
2991
2992     case EXEC_CLOSE:
2993       fputs ("CLOSE", dumpfile);
2994       close = c->ext.close;
2995
2996       if (close->unit)
2997         {
2998           fputs (" UNIT=", dumpfile);
2999           show_expr (close->unit);
3000         }
3001       if (close->iomsg)
3002         {
3003           fputs (" IOMSG=", dumpfile);
3004           show_expr (close->iomsg);
3005         }
3006       if (close->iostat)
3007         {
3008           fputs (" IOSTAT=", dumpfile);
3009           show_expr (close->iostat);
3010         }
3011       if (close->status)
3012         {
3013           fputs (" STATUS=", dumpfile);
3014           show_expr (close->status);
3015         }
3016       if (close->err != NULL)
3017         fprintf (dumpfile, " ERR=%d", close->err->value);
3018       break;
3019
3020     case EXEC_BACKSPACE:
3021       fputs ("BACKSPACE", dumpfile);
3022       goto show_filepos;
3023
3024     case EXEC_ENDFILE:
3025       fputs ("ENDFILE", dumpfile);
3026       goto show_filepos;
3027
3028     case EXEC_REWIND:
3029       fputs ("REWIND", dumpfile);
3030       goto show_filepos;
3031
3032     case EXEC_FLUSH:
3033       fputs ("FLUSH", dumpfile);
3034
3035     show_filepos:
3036       fp = c->ext.filepos;
3037
3038       if (fp->unit)
3039         {
3040           fputs (" UNIT=", dumpfile);
3041           show_expr (fp->unit);
3042         }
3043       if (fp->iomsg)
3044         {
3045           fputs (" IOMSG=", dumpfile);
3046           show_expr (fp->iomsg);
3047         }
3048       if (fp->iostat)
3049         {
3050           fputs (" IOSTAT=", dumpfile);
3051           show_expr (fp->iostat);
3052         }
3053       if (fp->err != NULL)
3054         fprintf (dumpfile, " ERR=%d", fp->err->value);
3055       break;
3056
3057     case EXEC_INQUIRE:
3058       fputs ("INQUIRE", dumpfile);
3059       i = c->ext.inquire;
3060
3061       if (i->unit)
3062         {
3063           fputs (" UNIT=", dumpfile);
3064           show_expr (i->unit);
3065         }
3066       if (i->file)
3067         {
3068           fputs (" FILE=", dumpfile);
3069           show_expr (i->file);
3070         }
3071
3072       if (i->iomsg)
3073         {
3074           fputs (" IOMSG=", dumpfile);
3075           show_expr (i->iomsg);
3076         }
3077       if (i->iostat)
3078         {
3079           fputs (" IOSTAT=", dumpfile);
3080           show_expr (i->iostat);
3081         }
3082       if (i->exist)
3083         {
3084           fputs (" EXIST=", dumpfile);
3085           show_expr (i->exist);
3086         }
3087       if (i->opened)
3088         {
3089           fputs (" OPENED=", dumpfile);
3090           show_expr (i->opened);
3091         }
3092       if (i->number)
3093         {
3094           fputs (" NUMBER=", dumpfile);
3095           show_expr (i->number);
3096         }
3097       if (i->named)
3098         {
3099           fputs (" NAMED=", dumpfile);
3100           show_expr (i->named);
3101         }
3102       if (i->name)
3103         {
3104           fputs (" NAME=", dumpfile);
3105           show_expr (i->name);
3106         }
3107       if (i->access)
3108         {
3109           fputs (" ACCESS=", dumpfile);
3110           show_expr (i->access);
3111         }
3112       if (i->sequential)
3113         {
3114           fputs (" SEQUENTIAL=", dumpfile);
3115           show_expr (i->sequential);
3116         }
3117
3118       if (i->direct)
3119         {
3120           fputs (" DIRECT=", dumpfile);
3121           show_expr (i->direct);
3122         }
3123       if (i->form)
3124         {
3125           fputs (" FORM=", dumpfile);
3126           show_expr (i->form);
3127         }
3128       if (i->formatted)
3129         {
3130           fputs (" FORMATTED", dumpfile);
3131           show_expr (i->formatted);
3132         }
3133       if (i->unformatted)
3134         {
3135           fputs (" UNFORMATTED=", dumpfile);
3136           show_expr (i->unformatted);
3137         }
3138       if (i->recl)
3139         {
3140           fputs (" RECL=", dumpfile);
3141           show_expr (i->recl);
3142         }
3143       if (i->nextrec)
3144         {
3145           fputs (" NEXTREC=", dumpfile);
3146           show_expr (i->nextrec);
3147         }
3148       if (i->blank)
3149         {
3150           fputs (" BLANK=", dumpfile);
3151           show_expr (i->blank);
3152         }
3153       if (i->position)
3154         {
3155           fputs (" POSITION=", dumpfile);
3156           show_expr (i->position);
3157         }
3158       if (i->action)
3159         {
3160           fputs (" ACTION=", dumpfile);
3161           show_expr (i->action);
3162         }
3163       if (i->read)
3164         {
3165           fputs (" READ=", dumpfile);
3166           show_expr (i->read);
3167         }
3168       if (i->write)
3169         {
3170           fputs (" WRITE=", dumpfile);
3171           show_expr (i->write);
3172         }
3173       if (i->readwrite)
3174         {
3175           fputs (" READWRITE=", dumpfile);
3176           show_expr (i->readwrite);
3177         }
3178       if (i->delim)
3179         {
3180           fputs (" DELIM=", dumpfile);
3181           show_expr (i->delim);
3182         }
3183       if (i->pad)
3184         {
3185           fputs (" PAD=", dumpfile);
3186           show_expr (i->pad);
3187         }
3188       if (i->convert)
3189         {
3190           fputs (" CONVERT=", dumpfile);
3191           show_expr (i->convert);
3192         }
3193       if (i->asynchronous)
3194         {
3195           fputs (" ASYNCHRONOUS=", dumpfile);
3196           show_expr (i->asynchronous);
3197         }
3198       if (i->decimal)
3199         {
3200           fputs (" DECIMAL=", dumpfile);
3201           show_expr (i->decimal);
3202         }
3203       if (i->encoding)
3204         {
3205           fputs (" ENCODING=", dumpfile);
3206           show_expr (i->encoding);
3207         }
3208       if (i->pending)
3209         {
3210           fputs (" PENDING=", dumpfile);
3211           show_expr (i->pending);
3212         }
3213       if (i->round)
3214         {
3215           fputs (" ROUND=", dumpfile);
3216           show_expr (i->round);
3217         }
3218       if (i->sign)
3219         {
3220           fputs (" SIGN=", dumpfile);
3221           show_expr (i->sign);
3222         }
3223       if (i->size)
3224         {
3225           fputs (" SIZE=", dumpfile);
3226           show_expr (i->size);
3227         }
3228       if (i->id)
3229         {
3230           fputs (" ID=", dumpfile);
3231           show_expr (i->id);
3232         }
3233
3234       if (i->err != NULL)
3235         fprintf (dumpfile, " ERR=%d", i->err->value);
3236       break;
3237
3238     case EXEC_IOLENGTH:
3239       fputs ("IOLENGTH ", dumpfile);
3240       show_expr (c->expr1);
3241       goto show_dt_code;
3242       break;
3243
3244     case EXEC_READ:
3245       fputs ("READ", dumpfile);
3246       goto show_dt;
3247
3248     case EXEC_WRITE:
3249       fputs ("WRITE", dumpfile);
3250
3251     show_dt:
3252       dt = c->ext.dt;
3253       if (dt->io_unit)
3254         {
3255           fputs (" UNIT=", dumpfile);
3256           show_expr (dt->io_unit);
3257         }
3258
3259       if (dt->format_expr)
3260         {
3261           fputs (" FMT=", dumpfile);
3262           show_expr (dt->format_expr);
3263         }
3264
3265       if (dt->format_label != NULL)
3266         fprintf (dumpfile, " FMT=%d", dt->format_label->value);
3267       if (dt->namelist)
3268         fprintf (dumpfile, " NML=%s", dt->namelist->name);
3269
3270       if (dt->iomsg)
3271         {
3272           fputs (" IOMSG=", dumpfile);
3273           show_expr (dt->iomsg);
3274         }
3275       if (dt->iostat)
3276         {
3277           fputs (" IOSTAT=", dumpfile);
3278           show_expr (dt->iostat);
3279         }
3280       if (dt->size)
3281         {
3282           fputs (" SIZE=", dumpfile);
3283           show_expr (dt->size);
3284         }
3285       if (dt->rec)
3286         {
3287           fputs (" REC=", dumpfile);
3288           show_expr (dt->rec);
3289         }
3290       if (dt->advance)
3291         {
3292           fputs (" ADVANCE=", dumpfile);
3293           show_expr (dt->advance);
3294         }
3295       if (dt->id)
3296         {
3297           fputs (" ID=", dumpfile);
3298           show_expr (dt->id);
3299         }
3300       if (dt->pos)
3301         {
3302           fputs (" POS=", dumpfile);
3303           show_expr (dt->pos);
3304         }
3305       if (dt->asynchronous)
3306         {
3307           fputs (" ASYNCHRONOUS=", dumpfile);
3308           show_expr (dt->asynchronous);
3309         }
3310       if (dt->blank)
3311         {
3312           fputs (" BLANK=", dumpfile);
3313           show_expr (dt->blank);
3314         }
3315       if (dt->decimal)
3316         {
3317           fputs (" DECIMAL=", dumpfile);
3318           show_expr (dt->decimal);
3319         }
3320       if (dt->delim)
3321         {
3322           fputs (" DELIM=", dumpfile);
3323           show_expr (dt->delim);
3324         }
3325       if (dt->pad)
3326         {
3327           fputs (" PAD=", dumpfile);
3328           show_expr (dt->pad);
3329         }
3330       if (dt->round)
3331         {
3332           fputs (" ROUND=", dumpfile);
3333           show_expr (dt->round);
3334         }
3335       if (dt->sign)
3336         {
3337           fputs (" SIGN=", dumpfile);
3338           show_expr (dt->sign);
3339         }
3340
3341     show_dt_code:
3342       for (c = c->block->next; c; c = c->next)
3343         show_code_node (level + (c->next != NULL), c);
3344       return;
3345
3346     case EXEC_TRANSFER:
3347       fputs ("TRANSFER ", dumpfile);
3348       show_expr (c->expr1);
3349       break;
3350
3351     case EXEC_DT_END:
3352       fputs ("DT_END", dumpfile);
3353       dt = c->ext.dt;
3354
3355       if (dt->err != NULL)
3356         fprintf (dumpfile, " ERR=%d", dt->err->value);
3357       if (dt->end != NULL)
3358         fprintf (dumpfile, " END=%d", dt->end->value);
3359       if (dt->eor != NULL)
3360         fprintf (dumpfile, " EOR=%d", dt->eor->value);
3361       break;
3362
3363     case EXEC_WAIT:
3364       fputs ("WAIT", dumpfile);
3365
3366       if (c->ext.wait != NULL)
3367         {
3368           gfc_wait *wait = c->ext.wait;
3369           if (wait->unit)
3370             {
3371               fputs (" UNIT=", dumpfile);
3372               show_expr (wait->unit);
3373             }
3374           if (wait->iostat)
3375             {
3376               fputs (" IOSTAT=", dumpfile);
3377               show_expr (wait->iostat);
3378             }
3379           if (wait->iomsg)
3380             {
3381               fputs (" IOMSG=", dumpfile);
3382               show_expr (wait->iomsg);
3383             }
3384           if (wait->id)
3385             {
3386               fputs (" ID=", dumpfile);
3387               show_expr (wait->id);
3388             }
3389           if (wait->err)
3390             fprintf (dumpfile, " ERR=%d", wait->err->value);
3391           if (wait->end)
3392             fprintf (dumpfile, " END=%d", wait->end->value);
3393           if (wait->eor)
3394             fprintf (dumpfile, " EOR=%d", wait->eor->value);
3395         }
3396       break;
3397
3398     case EXEC_OACC_PARALLEL_LOOP:
3399     case EXEC_OACC_PARALLEL:
3400     case EXEC_OACC_KERNELS_LOOP:
3401     case EXEC_OACC_KERNELS:
3402     case EXEC_OACC_SERIAL_LOOP:
3403     case EXEC_OACC_SERIAL:
3404     case EXEC_OACC_DATA:
3405     case EXEC_OACC_HOST_DATA:
3406     case EXEC_OACC_LOOP:
3407     case EXEC_OACC_UPDATE:
3408     case EXEC_OACC_WAIT:
3409     case EXEC_OACC_CACHE:
3410     case EXEC_OACC_ENTER_DATA:
3411     case EXEC_OACC_EXIT_DATA:
3412     case EXEC_OMP_ASSUME:
3413     case EXEC_OMP_ATOMIC:
3414     case EXEC_OMP_CANCEL:
3415     case EXEC_OMP_CANCELLATION_POINT:
3416     case EXEC_OMP_BARRIER:
3417     case EXEC_OMP_CRITICAL:
3418     case EXEC_OMP_DEPOBJ:
3419     case EXEC_OMP_DISTRIBUTE:
3420     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
3421     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
3422     case EXEC_OMP_DISTRIBUTE_SIMD:
3423     case EXEC_OMP_DO:
3424     case EXEC_OMP_DO_SIMD:
3425     case EXEC_OMP_ERROR:
3426     case EXEC_OMP_FLUSH:
3427     case EXEC_OMP_LOOP:
3428     case EXEC_OMP_MASKED:
3429     case EXEC_OMP_MASKED_TASKLOOP:
3430     case EXEC_OMP_MASKED_TASKLOOP_SIMD:
3431     case EXEC_OMP_MASTER:
3432     case EXEC_OMP_MASTER_TASKLOOP:
3433     case EXEC_OMP_MASTER_TASKLOOP_SIMD:
3434     case EXEC_OMP_ORDERED:
3435     case EXEC_OMP_PARALLEL:
3436     case EXEC_OMP_PARALLEL_DO:
3437     case EXEC_OMP_PARALLEL_DO_SIMD:
3438     case EXEC_OMP_PARALLEL_LOOP:
3439     case EXEC_OMP_PARALLEL_MASKED:
3440     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
3441     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
3442     case EXEC_OMP_PARALLEL_MASTER:
3443     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
3444     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
3445     case EXEC_OMP_PARALLEL_SECTIONS:
3446     case EXEC_OMP_PARALLEL_WORKSHARE:
3447     case EXEC_OMP_SCAN:
3448     case EXEC_OMP_SCOPE:
3449     case EXEC_OMP_SECTIONS:
3450     case EXEC_OMP_SIMD:
3451     case EXEC_OMP_SINGLE:
3452     case EXEC_OMP_TARGET:
3453     case EXEC_OMP_TARGET_DATA:
3454     case EXEC_OMP_TARGET_ENTER_DATA:
3455     case EXEC_OMP_TARGET_EXIT_DATA:
3456     case EXEC_OMP_TARGET_PARALLEL:
3457     case EXEC_OMP_TARGET_PARALLEL_DO:
3458     case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
3459     case EXEC_OMP_TARGET_PARALLEL_LOOP:
3460     case EXEC_OMP_TARGET_SIMD:
3461     case EXEC_OMP_TARGET_TEAMS:
3462     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
3463     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
3464     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3465     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
3466     case EXEC_OMP_TARGET_TEAMS_LOOP:
3467     case EXEC_OMP_TARGET_UPDATE:
3468     case EXEC_OMP_TASK:
3469     case EXEC_OMP_TASKGROUP:
3470     case EXEC_OMP_TASKLOOP:
3471     case EXEC_OMP_TASKLOOP_SIMD:
3472     case EXEC_OMP_TASKWAIT:
3473     case EXEC_OMP_TASKYIELD:
3474     case EXEC_OMP_TEAMS:
3475     case EXEC_OMP_TEAMS_DISTRIBUTE:
3476     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
3477     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3478     case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
3479     case EXEC_OMP_TEAMS_LOOP:
3480     case EXEC_OMP_WORKSHARE:
3481       show_omp_node (level, c);
3482       break;
3483
3484     default:
3485       gfc_internal_error ("show_code_node(): Bad statement code");
3486     }
3487 }
3488
3489
3490 /* Show an equivalence chain.  */
3491
3492 static void
3493 show_equiv (gfc_equiv *eq)
3494 {
3495   show_indent ();
3496   fputs ("Equivalence: ", dumpfile);
3497   while (eq)
3498     {
3499       show_expr (eq->expr);
3500       eq = eq->eq;
3501       if (eq)
3502         fputs (", ", dumpfile);
3503     }
3504 }
3505
3506
3507 /* Show a freakin' whole namespace.  */
3508
3509 static void
3510 show_namespace (gfc_namespace *ns)
3511 {
3512   gfc_interface *intr;
3513   gfc_namespace *save;
3514   int op;
3515   gfc_equiv *eq;
3516   int i;
3517
3518   gcc_assert (ns);
3519   save = gfc_current_ns;
3520
3521   show_indent ();
3522   fputs ("Namespace:", dumpfile);
3523
3524   i = 0;
3525   do
3526     {
3527       int l = i;
3528       while (i < GFC_LETTERS - 1
3529              && gfc_compare_types (&ns->default_type[i+1],
3530                                    &ns->default_type[l]))
3531         i++;
3532
3533       if (i > l)
3534         fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
3535       else
3536         fprintf (dumpfile, " %c: ", l+'A');
3537
3538       show_typespec(&ns->default_type[l]);
3539       i++;
3540     } while (i < GFC_LETTERS);
3541
3542   if (ns->proc_name != NULL)
3543     {
3544       show_indent ();
3545       fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
3546     }
3547
3548   ++show_level;
3549   gfc_current_ns = ns;
3550   gfc_traverse_symtree (ns->common_root, show_common);
3551
3552   gfc_traverse_symtree (ns->sym_root, show_symtree);
3553
3554   for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
3555     {
3556       /* User operator interfaces */
3557       intr = ns->op[op];
3558       if (intr == NULL)
3559         continue;
3560
3561       show_indent ();
3562       fprintf (dumpfile, "Operator interfaces for %s:",
3563                gfc_op2string ((gfc_intrinsic_op) op));
3564
3565       for (; intr; intr = intr->next)
3566         fprintf (dumpfile, " %s", intr->sym->name);
3567     }
3568
3569   if (ns->uop_root != NULL)
3570     {
3571       show_indent ();
3572       fputs ("User operators:\n", dumpfile);
3573       gfc_traverse_user_op (ns, show_uop);
3574     }
3575
3576   for (eq = ns->equiv; eq; eq = eq->next)
3577     show_equiv (eq);
3578
3579   if (ns->oacc_declare)
3580     {
3581       struct gfc_oacc_declare *decl;
3582       /* Dump !$ACC DECLARE clauses.  */
3583       for (decl = ns->oacc_declare; decl; decl = decl->next)
3584         {
3585           show_indent ();
3586           fprintf (dumpfile, "!$ACC DECLARE");
3587           show_omp_clauses (decl->clauses);
3588         }
3589     }
3590
3591   if (ns->omp_assumes)
3592     {
3593       show_indent ();
3594       fprintf (dumpfile, "!$OMP ASSUMES");
3595       show_omp_assumes (ns->omp_assumes);
3596     }
3597
3598   fputc ('\n', dumpfile);
3599   show_indent ();
3600   fputs ("code:", dumpfile);
3601   show_code (show_level, ns->code);
3602   --show_level;
3603
3604   for (ns = ns->contained; ns; ns = ns->sibling)
3605     {
3606       fputs ("\nCONTAINS\n", dumpfile);
3607       ++show_level;
3608       show_namespace (ns);
3609       --show_level;
3610     }
3611
3612   fputc ('\n', dumpfile);
3613   gfc_current_ns = save;
3614 }
3615
3616
3617 /* Main function for dumping a parse tree.  */
3618
3619 void
3620 gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
3621 {
3622   dumpfile = file;
3623   show_namespace (ns);
3624 }
3625
3626 /* This part writes BIND(C) definition for use in external C programs.  */
3627
3628 static void write_interop_decl (gfc_symbol *);
3629 static void write_proc (gfc_symbol *, bool);
3630
3631 void
3632 gfc_dump_c_prototypes (gfc_namespace *ns, FILE *file)
3633 {
3634   int error_count;
3635   gfc_get_errors (NULL, &error_count);
3636   if (error_count != 0)
3637     return;
3638   dumpfile = file;
3639   gfc_traverse_ns (ns, write_interop_decl);
3640 }
3641
3642 /* Loop over all global symbols, writing out their declarations.  */
3643
3644 void
3645 gfc_dump_external_c_prototypes (FILE * file)
3646 {
3647   dumpfile = file;
3648   fprintf (dumpfile,
3649            _("/* Prototypes for external procedures generated from %s\n"
3650              "   by GNU Fortran %s%s.\n\n"
3651              "   Use of this interface is discouraged, consider using the\n"
3652              "   BIND(C) feature of standard Fortran instead.  */\n\n"),
3653            gfc_source_file, pkgversion_string, version_string);
3654
3655   for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
3656        gfc_current_ns = gfc_current_ns->sibling)
3657     {
3658       gfc_symbol *sym = gfc_current_ns->proc_name;
3659
3660       if (sym == NULL || sym->attr.flavor != FL_PROCEDURE
3661           || sym->attr.is_bind_c)
3662         continue;
3663
3664       write_proc (sym, false);
3665     }
3666   return;
3667 }
3668
3669 enum type_return { T_OK=0, T_WARN, T_ERROR };
3670
3671 /* Return the name of the type for later output.  Both function pointers and
3672    void pointers will be mapped to void *.  */
3673
3674 static enum type_return
3675 get_c_type_name (gfc_typespec *ts, gfc_array_spec *as, const char **pre,
3676                  const char **type_name, bool *asterisk, const char **post,
3677                  bool func_ret)
3678 {
3679   static char post_buffer[40];
3680   enum type_return ret;
3681   ret = T_ERROR;
3682
3683   *pre = " ";
3684   *asterisk = false;
3685   *post = "";
3686   *type_name = "<error>";
3687   if (ts->type == BT_REAL || ts->type == BT_INTEGER || ts->type == BT_COMPLEX)
3688     {
3689       if (ts->is_c_interop && ts->interop_kind)
3690         ret = T_OK;
3691       else
3692         ret = T_WARN;
3693
3694       for (int i = 0; i < ISOCBINDING_NUMBER; i++)
3695         {
3696           if (c_interop_kinds_table[i].f90_type == ts->type
3697               && c_interop_kinds_table[i].value == ts->kind)
3698             {
3699               *type_name = c_interop_kinds_table[i].name + 2;
3700               if (strcmp (*type_name, "signed_char") == 0)
3701                 *type_name = "signed char";
3702               else if (strcmp (*type_name, "size_t") == 0)
3703                 *type_name = "ssize_t";
3704               else if (strcmp (*type_name, "float_complex") == 0)
3705                 *type_name = "__GFORTRAN_FLOAT_COMPLEX";
3706               else if (strcmp (*type_name, "double_complex") == 0)
3707                 *type_name = "__GFORTRAN_DOUBLE_COMPLEX";
3708               else if (strcmp (*type_name, "long_double_complex") == 0)
3709                 *type_name = "__GFORTRAN_LONG_DOUBLE_COMPLEX";
3710
3711               break;
3712             }
3713         }
3714     }
3715   else if (ts->type == BT_LOGICAL)
3716     {
3717       if (ts->is_c_interop && ts->interop_kind)
3718         {
3719           *type_name = "_Bool";
3720           ret = T_OK;
3721         }
3722       else
3723         {
3724           /* Let's select an appropriate int, with a warning. */
3725           for (int i = 0; i < ISOCBINDING_NUMBER; i++)
3726             {
3727               if (c_interop_kinds_table[i].f90_type == BT_INTEGER
3728                   && c_interop_kinds_table[i].value == ts->kind)
3729                 {
3730                   *type_name = c_interop_kinds_table[i].name + 2;
3731                   ret = T_WARN;
3732                 }
3733             }
3734         }
3735     }
3736   else if (ts->type == BT_CHARACTER)
3737     {
3738       if (ts->is_c_interop)
3739         {
3740           *type_name = "char";
3741           ret = T_OK;
3742         }
3743       else
3744         {
3745           if (ts->kind == gfc_default_character_kind)
3746             *type_name = "char";
3747           else
3748             /* Let's select an appropriate int. */
3749             for (int i = 0; i < ISOCBINDING_NUMBER; i++)
3750               {
3751                 if (c_interop_kinds_table[i].f90_type == BT_INTEGER
3752                     && c_interop_kinds_table[i].value == ts->kind)
3753                   {
3754                     *type_name = c_interop_kinds_table[i].name + 2;
3755                     break;
3756                   }
3757             }
3758           ret = T_WARN;
3759
3760         }
3761     }
3762   else if (ts->type == BT_DERIVED)
3763     {
3764       if (ts->u.derived->from_intmod == INTMOD_ISO_C_BINDING)
3765         {
3766           if (strcmp (ts->u.derived->name, "c_ptr") == 0)
3767             *type_name = "void";
3768           else if (strcmp (ts->u.derived->name, "c_funptr") == 0)
3769             {
3770               *type_name = "int ";
3771               if (func_ret)
3772                 {
3773                   *pre = "(";
3774                   *post = "())";
3775                 }
3776               else
3777                 {
3778                   *pre = "(";
3779                   *post = ")()";
3780                 }
3781             }
3782           *asterisk = true;
3783           ret = T_OK;
3784         }
3785       else
3786         *type_name = ts->u.derived->name;
3787
3788       ret = T_OK;
3789     }
3790
3791   if (ret != T_ERROR && as)
3792     {
3793       mpz_t sz;
3794       bool size_ok;
3795       size_ok = spec_size (as, &sz);
3796       gcc_assert (size_ok == true);
3797       gmp_snprintf (post_buffer, sizeof(post_buffer), "[%Zd]", sz);
3798       *post = post_buffer;
3799       mpz_clear (sz);
3800     }
3801   return ret;
3802 }
3803
3804 /* Write out a declaration.  */
3805 static void
3806 write_decl (gfc_typespec *ts, gfc_array_spec *as, const char *sym_name,
3807             bool func_ret, locus *where, bool bind_c)
3808 {
3809   const char *pre, *type_name, *post;
3810   bool asterisk;
3811   enum type_return rok;
3812
3813   rok = get_c_type_name (ts, as, &pre, &type_name, &asterisk, &post, func_ret);
3814   if (rok == T_ERROR)
3815     {
3816       gfc_error_now ("Cannot convert %qs to interoperable type at %L",
3817                      gfc_typename (ts), where);
3818       fprintf (dumpfile, "/* Cannot convert '%s' to interoperable type */",
3819                gfc_typename (ts));
3820       return;
3821     }
3822   fputs (type_name, dumpfile);
3823   fputs (pre, dumpfile);
3824   if (asterisk)
3825     fputs ("*", dumpfile);
3826
3827   fputs (sym_name, dumpfile);
3828   fputs (post, dumpfile);
3829
3830   if (rok == T_WARN && bind_c)
3831     fprintf (dumpfile," /* WARNING: Converting '%s' to interoperable type */",
3832              gfc_typename (ts));
3833 }
3834
3835 /* Write out an interoperable type.  It will be written as a typedef
3836    for a struct.  */
3837
3838 static void
3839 write_type (gfc_symbol *sym)
3840 {
3841   gfc_component *c;
3842
3843   fprintf (dumpfile, "typedef struct %s {\n", sym->name);
3844   for (c = sym->components; c; c = c->next)
3845     {
3846       fputs ("    ", dumpfile);
3847       write_decl (&(c->ts), c->as, c->name, false, &sym->declared_at, true);
3848       fputs (";\n", dumpfile);
3849     }
3850
3851   fprintf (dumpfile, "} %s;\n", sym->name);
3852 }
3853
3854 /* Write out a variable.  */
3855
3856 static void
3857 write_variable (gfc_symbol *sym)
3858 {
3859   const char *sym_name;
3860
3861   gcc_assert (sym->attr.flavor == FL_VARIABLE);
3862
3863   if (sym->binding_label)
3864     sym_name = sym->binding_label;
3865   else
3866     sym_name = sym->name;
3867
3868   fputs ("extern ", dumpfile);
3869   write_decl (&(sym->ts), sym->as, sym_name, false, &sym->declared_at, true);
3870   fputs (";\n", dumpfile);
3871 }
3872
3873
3874 /* Write out a procedure, including its arguments.  */
3875 static void
3876 write_proc (gfc_symbol *sym, bool bind_c)
3877 {
3878   const char *pre, *type_name, *post;
3879   bool asterisk;
3880   enum type_return rok;
3881   gfc_formal_arglist *f;
3882   const char *sym_name;
3883   const char *intent_in;
3884   bool external_character;
3885
3886   external_character =  sym->ts.type == BT_CHARACTER && !bind_c;
3887
3888   if (sym->binding_label)
3889     sym_name = sym->binding_label;
3890   else
3891     sym_name = sym->name;
3892
3893   if (sym->ts.type == BT_UNKNOWN || external_character)
3894     {
3895       fprintf (dumpfile, "void ");
3896       fputs (sym_name, dumpfile);
3897     }
3898   else
3899     write_decl (&(sym->ts), sym->as, sym_name, true, &sym->declared_at, bind_c);
3900
3901   if (!bind_c)
3902     fputs ("_", dumpfile);
3903
3904   fputs (" (", dumpfile);
3905   if (external_character)
3906     {
3907       fprintf (dumpfile, "char *result_%s, size_t result_%s_len",
3908                sym_name, sym_name);
3909       if (sym->formal)
3910         fputs (", ", dumpfile);
3911     }
3912
3913   for (f = sym->formal; f; f = f->next)
3914     {
3915       gfc_symbol *s;
3916       s = f->sym;
3917       rok = get_c_type_name (&(s->ts), NULL, &pre, &type_name, &asterisk,
3918                              &post, false);
3919       if (rok == T_ERROR)
3920         {
3921           gfc_error_now ("Cannot convert %qs to interoperable type at %L",
3922                          gfc_typename (&s->ts), &s->declared_at);
3923           fprintf (dumpfile, "/* Cannot convert '%s' to interoperable type */",
3924                    gfc_typename (&s->ts));
3925           return;
3926         }
3927
3928       if (!s->attr.value)
3929         asterisk = true;
3930
3931       if (s->attr.intent == INTENT_IN && !s->attr.value)
3932         intent_in = "const ";
3933       else
3934         intent_in = "";
3935
3936       fputs (intent_in, dumpfile);
3937       fputs (type_name, dumpfile);
3938       fputs (pre, dumpfile);
3939       if (asterisk)
3940         fputs ("*", dumpfile);
3941
3942       fputs (s->name, dumpfile);
3943       fputs (post, dumpfile);
3944       if (bind_c && rok == T_WARN)
3945         fputs(" /* WARNING: non-interoperable KIND */ ", dumpfile);
3946
3947       if (f->next)
3948         fputs(", ", dumpfile);
3949     }
3950   if (!bind_c)
3951     for (f = sym->formal; f; f = f->next)
3952       if (f->sym->ts.type == BT_CHARACTER)
3953         fprintf (dumpfile, ", size_t %s_len", f->sym->name);
3954
3955   fputs (");\n", dumpfile);
3956 }
3957
3958
3959 /* Write a C-interoperable declaration as a C prototype or extern
3960    declaration.  */
3961
3962 static void
3963 write_interop_decl (gfc_symbol *sym)
3964 {
3965   /* Only dump bind(c) entities.  */
3966   if (!sym->attr.is_bind_c)
3967     return;
3968
3969   /* Don't dump our iso c module.  */
3970   if (sym->from_intmod == INTMOD_ISO_C_BINDING)
3971     return;
3972
3973   if (sym->attr.flavor == FL_VARIABLE)
3974     write_variable (sym);
3975   else if (sym->attr.flavor == FL_DERIVED)
3976     write_type (sym);
3977   else if (sym->attr.flavor == FL_PROCEDURE)
3978     write_proc (sym, true);
3979 }
3980
3981 /* This section deals with dumping the global symbol tree.  */
3982
3983 /* Callback function for printing out the contents of the tree.  */
3984
3985 static void
3986 show_global_symbol (gfc_gsymbol *gsym, void *f_data)
3987 {
3988   FILE *out;
3989   out = (FILE *) f_data;
3990
3991   if (gsym->name)
3992     fprintf (out, "name=%s", gsym->name);
3993
3994   if (gsym->sym_name)
3995     fprintf (out, ", sym_name=%s", gsym->sym_name);
3996
3997   if (gsym->mod_name)
3998     fprintf (out, ", mod_name=%s", gsym->mod_name);
3999
4000   if (gsym->binding_label)
4001     fprintf (out, ", binding_label=%s", gsym->binding_label);
4002
4003   fputc ('\n', out);
4004 }
4005
4006 /* Show all global symbols.  */
4007
4008 void
4009 gfc_dump_global_symbols (FILE *f)
4010 {
4011   if (gfc_gsym_root == NULL)
4012     fprintf (f, "empty\n");
4013   else
4014     gfc_traverse_gsymbol (gfc_gsym_root, show_global_symbol, (void *) f);
4015 }
4016
4017 /* Show an array ref.  */
4018
4019 void debug (gfc_array_ref *ar)
4020 {
4021   FILE *tmp = dumpfile;
4022   dumpfile = stderr;
4023   show_array_ref (ar);
4024   fputc ('\n', dumpfile);
4025   dumpfile = tmp;
4026 }