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