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