diff options
Diffstat (limited to 'gcc/fortran/dump-parse-tree.c')
| -rw-r--r-- | gcc/fortran/dump-parse-tree.c | 3924 |
1 files changed, 0 insertions, 3924 deletions
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c deleted file mode 100644 index a618ae2..0000000 --- a/gcc/fortran/dump-parse-tree.c +++ /dev/null @@ -1,3924 +0,0 @@ -/* Parse tree dumper - Copyright (C) 2003-2022 Free Software Foundation, Inc. - Contributed by Steven Bosscher - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -<http://www.gnu.org/licenses/>. */ - - -/* Actually this is just a collection of routines that used to be - scattered around the sources. Now that they are all in a single - file, almost all of them can be static, and the other files don't - have this mess in them. - - As a nice side-effect, this file can act as documentation of the - gfc_code and gfc_expr structures and all their friends and - relatives. - - TODO: Dump DATA. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "gfortran.h" -#include "constructor.h" -#include "version.h" - -/* Keep track of indentation for symbol tree dumps. */ -static int show_level = 0; - -/* The file handle we're dumping to is kept in a static variable. This - is not too cool, but it avoids a lot of passing it around. */ -static FILE *dumpfile; - -/* Forward declaration of some of the functions. */ -static void show_expr (gfc_expr *p); -static void show_code_node (int, gfc_code *); -static void show_namespace (gfc_namespace *ns); -static void show_code (int, gfc_code *); -static void show_symbol (gfc_symbol *); -static void show_typespec (gfc_typespec *); -static void show_ref (gfc_ref *); -static void show_attr (symbol_attribute *, const char *); - -/* Allow dumping of an expression in the debugger. */ -void gfc_debug_expr (gfc_expr *); - -void debug (symbol_attribute *attr) -{ - FILE *tmp = dumpfile; - dumpfile = stderr; - show_attr (attr, NULL); - fputc ('\n', dumpfile); - dumpfile = tmp; -} - -void debug (gfc_formal_arglist *formal) -{ - FILE *tmp = dumpfile; - dumpfile = stderr; - for (; formal; formal = formal->next) - { - fputc ('\n', dumpfile); - show_symbol (formal->sym); - } - fputc ('\n', dumpfile); - dumpfile = tmp; -} - -void debug (symbol_attribute attr) -{ - debug (&attr); -} - -void debug (gfc_expr *e) -{ - FILE *tmp = dumpfile; - dumpfile = stderr; - if (e != NULL) - { - show_expr (e); - fputc (' ', dumpfile); - show_typespec (&e->ts); - } - else - fputs ("() ", dumpfile); - - fputc ('\n', dumpfile); - dumpfile = tmp; -} - -void debug (gfc_typespec *ts) -{ - FILE *tmp = dumpfile; - dumpfile = stderr; - show_typespec (ts); - fputc ('\n', dumpfile); - dumpfile = tmp; -} - -void debug (gfc_typespec ts) -{ - debug (&ts); -} - -void debug (gfc_ref *p) -{ - FILE *tmp = dumpfile; - dumpfile = stderr; - show_ref (p); - fputc ('\n', dumpfile); - dumpfile = tmp; -} - -void -gfc_debug_expr (gfc_expr *e) -{ - FILE *tmp = dumpfile; - dumpfile = stderr; - show_expr (e); - fputc ('\n', dumpfile); - dumpfile = tmp; -} - -/* Allow for dumping of a piece of code in the debugger. */ -void gfc_debug_code (gfc_code *c); - -void -gfc_debug_code (gfc_code *c) -{ - FILE *tmp = dumpfile; - dumpfile = stderr; - show_code (1, c); - fputc ('\n', dumpfile); - dumpfile = tmp; -} - -void debug (gfc_symbol *sym) -{ - FILE *tmp = dumpfile; - dumpfile = stderr; - show_symbol (sym); - fputc ('\n', dumpfile); - dumpfile = tmp; -} - -/* Do indentation for a specific level. */ - -static inline void -code_indent (int level, gfc_st_label *label) -{ - int i; - - if (label != NULL) - fprintf (dumpfile, "%-5d ", label->value); - - for (i = 0; i < (2 * level - (label ? 6 : 0)); i++) - fputc (' ', dumpfile); -} - - -/* Simple indentation at the current level. This one - is used to show symbols. */ - -static inline void -show_indent (void) -{ - fputc ('\n', dumpfile); - code_indent (show_level, NULL); -} - - -/* Show type-specific information. */ - -static void -show_typespec (gfc_typespec *ts) -{ - if (ts->type == BT_ASSUMED) - { - fputs ("(TYPE(*))", dumpfile); - return; - } - - fprintf (dumpfile, "(%s ", gfc_basic_typename (ts->type)); - - switch (ts->type) - { - case BT_DERIVED: - case BT_CLASS: - case BT_UNION: - fprintf (dumpfile, "%s", ts->u.derived->name); - break; - - case BT_CHARACTER: - if (ts->u.cl) - show_expr (ts->u.cl->length); - fprintf(dumpfile, " %d", ts->kind); - break; - - default: - fprintf (dumpfile, "%d", ts->kind); - break; - } - if (ts->is_c_interop) - fputs (" C_INTEROP", dumpfile); - - if (ts->is_iso_c) - fputs (" ISO_C", dumpfile); - - if (ts->deferred) - fputs (" DEFERRED", dumpfile); - - fputc (')', dumpfile); -} - - -/* Show an actual argument list. */ - -static void -show_actual_arglist (gfc_actual_arglist *a) -{ - fputc ('(', dumpfile); - - for (; a; a = a->next) - { - fputc ('(', dumpfile); - if (a->name != NULL) - fprintf (dumpfile, "%s = ", a->name); - if (a->expr != NULL) - show_expr (a->expr); - else - fputs ("(arg not-present)", dumpfile); - - fputc (')', dumpfile); - if (a->next != NULL) - fputc (' ', dumpfile); - } - - fputc (')', dumpfile); -} - - -/* Show a gfc_array_spec array specification structure. */ - -static void -show_array_spec (gfc_array_spec *as) -{ - const char *c; - int i; - - if (as == NULL) - { - fputs ("()", dumpfile); - return; - } - - fprintf (dumpfile, "(%d [%d]", as->rank, as->corank); - - if (as->rank + as->corank > 0 || as->rank == -1) - { - switch (as->type) - { - case AS_EXPLICIT: c = "AS_EXPLICIT"; break; - case AS_DEFERRED: c = "AS_DEFERRED"; break; - case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break; - case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break; - case AS_ASSUMED_RANK: c = "AS_ASSUMED_RANK"; break; - default: - gfc_internal_error ("show_array_spec(): Unhandled array shape " - "type."); - } - fprintf (dumpfile, " %s ", c); - - for (i = 0; i < as->rank + as->corank; i++) - { - show_expr (as->lower[i]); - fputc (' ', dumpfile); - show_expr (as->upper[i]); - fputc (' ', dumpfile); - } - } - - fputc (')', dumpfile); -} - - -/* Show a gfc_array_ref array reference structure. */ - -static void -show_array_ref (gfc_array_ref * ar) -{ - int i; - - fputc ('(', dumpfile); - - switch (ar->type) - { - case AR_FULL: - fputs ("FULL", dumpfile); - break; - - case AR_SECTION: - for (i = 0; i < ar->dimen; i++) - { - /* There are two types of array sections: either the - elements are identified by an integer array ('vector'), - or by an index range. In the former case we only have to - print the start expression which contains the vector, in - the latter case we have to print any of lower and upper - bound and the stride, if they're present. */ - - if (ar->start[i] != NULL) - show_expr (ar->start[i]); - - if (ar->dimen_type[i] == DIMEN_RANGE) - { - fputc (':', dumpfile); - - if (ar->end[i] != NULL) - show_expr (ar->end[i]); - - if (ar->stride[i] != NULL) - { - fputc (':', dumpfile); - show_expr (ar->stride[i]); - } - } - - if (i != ar->dimen - 1) - fputs (" , ", dumpfile); - } - break; - - case AR_ELEMENT: - for (i = 0; i < ar->dimen; i++) - { - show_expr (ar->start[i]); - if (i != ar->dimen - 1) - fputs (" , ", dumpfile); - } - break; - - case AR_UNKNOWN: - fputs ("UNKNOWN", dumpfile); - break; - - default: - gfc_internal_error ("show_array_ref(): Unknown array reference"); - } - - fputc (')', dumpfile); - if (ar->codimen == 0) - return; - - /* Show coarray part of the reference, if any. */ - fputc ('[',dumpfile); - for (i = ar->dimen; i < ar->dimen + ar->codimen; i++) - { - if (ar->dimen_type[i] == DIMEN_STAR) - fputc('*',dumpfile); - else if (ar->dimen_type[i] == DIMEN_THIS_IMAGE) - fputs("THIS_IMAGE", dumpfile); - else - { - show_expr (ar->start[i]); - if (ar->end[i]) - { - fputc(':', dumpfile); - show_expr (ar->end[i]); - } - } - if (i != ar->dimen + ar->codimen - 1) - fputs (" , ", dumpfile); - - } - fputc (']',dumpfile); -} - - -/* Show a list of gfc_ref structures. */ - -static void -show_ref (gfc_ref *p) -{ - for (; p; p = p->next) - switch (p->type) - { - case REF_ARRAY: - show_array_ref (&p->u.ar); - break; - - case REF_COMPONENT: - fprintf (dumpfile, " %% %s", p->u.c.component->name); - break; - - case REF_SUBSTRING: - fputc ('(', dumpfile); - show_expr (p->u.ss.start); - fputc (':', dumpfile); - show_expr (p->u.ss.end); - fputc (')', dumpfile); - break; - - case REF_INQUIRY: - switch (p->u.i) - { - case INQUIRY_KIND: - fprintf (dumpfile, " INQUIRY_KIND "); - break; - case INQUIRY_LEN: - fprintf (dumpfile, " INQUIRY_LEN "); - break; - case INQUIRY_RE: - fprintf (dumpfile, " INQUIRY_RE "); - break; - case INQUIRY_IM: - fprintf (dumpfile, " INQUIRY_IM "); - } - break; - - default: - gfc_internal_error ("show_ref(): Bad component code"); - } -} - - -/* Display a constructor. Works recursively for array constructors. */ - -static void -show_constructor (gfc_constructor_base base) -{ - gfc_constructor *c; - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) - { - if (c->iterator == NULL) - show_expr (c->expr); - else - { - fputc ('(', dumpfile); - show_expr (c->expr); - - fputc (' ', dumpfile); - show_expr (c->iterator->var); - fputc ('=', dumpfile); - show_expr (c->iterator->start); - fputc (',', dumpfile); - show_expr (c->iterator->end); - fputc (',', dumpfile); - show_expr (c->iterator->step); - - fputc (')', dumpfile); - } - - if (gfc_constructor_next (c) != NULL) - fputs (" , ", dumpfile); - } -} - - -static void -show_char_const (const gfc_char_t *c, gfc_charlen_t length) -{ - fputc ('\'', dumpfile); - for (size_t i = 0; i < (size_t) length; i++) - { - if (c[i] == '\'') - fputs ("''", dumpfile); - else - fputs (gfc_print_wide_char (c[i]), dumpfile); - } - fputc ('\'', dumpfile); -} - - -/* Show a component-call expression. */ - -static void -show_compcall (gfc_expr* p) -{ - gcc_assert (p->expr_type == EXPR_COMPCALL); - - fprintf (dumpfile, "%s", p->symtree->n.sym->name); - show_ref (p->ref); - fprintf (dumpfile, "%s", p->value.compcall.name); - - show_actual_arglist (p->value.compcall.actual); -} - - -/* Show an expression. */ - -static void -show_expr (gfc_expr *p) -{ - const char *c; - int i; - - if (p == NULL) - { - fputs ("()", dumpfile); - return; - } - - switch (p->expr_type) - { - case EXPR_SUBSTRING: - show_char_const (p->value.character.string, p->value.character.length); - show_ref (p->ref); - break; - - case EXPR_STRUCTURE: - fprintf (dumpfile, "%s(", p->ts.u.derived->name); - show_constructor (p->value.constructor); - fputc (')', dumpfile); - break; - - case EXPR_ARRAY: - fputs ("(/ ", dumpfile); - show_constructor (p->value.constructor); - fputs (" /)", dumpfile); - - show_ref (p->ref); - break; - - case EXPR_NULL: - fputs ("NULL()", dumpfile); - break; - - case EXPR_CONSTANT: - switch (p->ts.type) - { - case BT_INTEGER: - mpz_out_str (dumpfile, 10, p->value.integer); - - if (p->ts.kind != gfc_default_integer_kind) - fprintf (dumpfile, "_%d", p->ts.kind); - break; - - case BT_LOGICAL: - if (p->value.logical) - fputs (".true.", dumpfile); - else - fputs (".false.", dumpfile); - break; - - case BT_REAL: - mpfr_out_str (dumpfile, 10, 0, p->value.real, GFC_RND_MODE); - if (p->ts.kind != gfc_default_real_kind) - fprintf (dumpfile, "_%d", p->ts.kind); - break; - - case BT_CHARACTER: - show_char_const (p->value.character.string, - p->value.character.length); - break; - - case BT_COMPLEX: - fputs ("(complex ", dumpfile); - - mpfr_out_str (dumpfile, 10, 0, mpc_realref (p->value.complex), - GFC_RND_MODE); - if (p->ts.kind != gfc_default_complex_kind) - fprintf (dumpfile, "_%d", p->ts.kind); - - fputc (' ', dumpfile); - - mpfr_out_str (dumpfile, 10, 0, mpc_imagref (p->value.complex), - GFC_RND_MODE); - if (p->ts.kind != gfc_default_complex_kind) - fprintf (dumpfile, "_%d", p->ts.kind); - - fputc (')', dumpfile); - break; - - case BT_BOZ: - if (p->boz.rdx == 2) - fputs ("b'", dumpfile); - else if (p->boz.rdx == 8) - fputs ("o'", dumpfile); - else - fputs ("z'", dumpfile); - fprintf (dumpfile, "%s'", p->boz.str); - break; - - case BT_HOLLERITH: - fprintf (dumpfile, HOST_WIDE_INT_PRINT_DEC "H", - p->representation.length); - c = p->representation.string; - for (i = 0; i < p->representation.length; i++, c++) - { - fputc (*c, dumpfile); - } - break; - - default: - fputs ("???", dumpfile); - break; - } - - if (p->representation.string) - { - fputs (" {", dumpfile); - c = p->representation.string; - for (i = 0; i < p->representation.length; i++, c++) - { - fprintf (dumpfile, "%.2x", (unsigned int) *c); - if (i < p->representation.length - 1) - fputc (',', dumpfile); - } - fputc ('}', dumpfile); - } - - break; - - case EXPR_VARIABLE: - if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name) - fprintf (dumpfile, "%s:", p->symtree->n.sym->ns->proc_name->name); - fprintf (dumpfile, "%s", p->symtree->n.sym->name); - show_ref (p->ref); - break; - - case EXPR_OP: - fputc ('(', dumpfile); - switch (p->value.op.op) - { - case INTRINSIC_UPLUS: - fputs ("U+ ", dumpfile); - break; - case INTRINSIC_UMINUS: - fputs ("U- ", dumpfile); - break; - case INTRINSIC_PLUS: - fputs ("+ ", dumpfile); - break; - case INTRINSIC_MINUS: - fputs ("- ", dumpfile); - break; - case INTRINSIC_TIMES: - fputs ("* ", dumpfile); - break; - case INTRINSIC_DIVIDE: - fputs ("/ ", dumpfile); - break; - case INTRINSIC_POWER: - fputs ("** ", dumpfile); - break; - case INTRINSIC_CONCAT: - fputs ("// ", dumpfile); - break; - case INTRINSIC_AND: - fputs ("AND ", dumpfile); - break; - case INTRINSIC_OR: - fputs ("OR ", dumpfile); - break; - case INTRINSIC_EQV: - fputs ("EQV ", dumpfile); - break; - case INTRINSIC_NEQV: - fputs ("NEQV ", dumpfile); - break; - case INTRINSIC_EQ: - case INTRINSIC_EQ_OS: - fputs ("== ", dumpfile); - break; - case INTRINSIC_NE: - case INTRINSIC_NE_OS: - fputs ("/= ", dumpfile); - break; - case INTRINSIC_GT: - case INTRINSIC_GT_OS: - fputs ("> ", dumpfile); - break; - case INTRINSIC_GE: - case INTRINSIC_GE_OS: - fputs (">= ", dumpfile); - break; - case INTRINSIC_LT: - case INTRINSIC_LT_OS: - fputs ("< ", dumpfile); - break; - case INTRINSIC_LE: - case INTRINSIC_LE_OS: - fputs ("<= ", dumpfile); - break; - case INTRINSIC_NOT: - fputs ("NOT ", dumpfile); - break; - case INTRINSIC_PARENTHESES: - fputs ("parens ", dumpfile); - break; - - default: - gfc_internal_error - ("show_expr(): Bad intrinsic in expression"); - } - - show_expr (p->value.op.op1); - - if (p->value.op.op2) - { - fputc (' ', dumpfile); - show_expr (p->value.op.op2); - } - - fputc (')', dumpfile); - break; - - case EXPR_FUNCTION: - if (p->value.function.name == NULL) - { - fprintf (dumpfile, "%s", p->symtree->n.sym->name); - if (gfc_is_proc_ptr_comp (p)) - show_ref (p->ref); - fputc ('[', dumpfile); - show_actual_arglist (p->value.function.actual); - fputc (']', dumpfile); - } - else - { - fprintf (dumpfile, "%s", p->value.function.name); - if (gfc_is_proc_ptr_comp (p)) - show_ref (p->ref); - fputc ('[', dumpfile); - fputc ('[', dumpfile); - show_actual_arglist (p->value.function.actual); - fputc (']', dumpfile); - fputc (']', dumpfile); - } - - break; - - case EXPR_COMPCALL: - show_compcall (p); - break; - - default: - gfc_internal_error ("show_expr(): Don't know how to show expr"); - } -} - -/* Show symbol attributes. The flavor and intent are followed by - whatever single bit attributes are present. */ - -static void -show_attr (symbol_attribute *attr, const char * module) -{ - if (attr->flavor != FL_UNKNOWN) - { - if (attr->flavor == FL_DERIVED && attr->pdt_template) - fputs (" (PDT-TEMPLATE", dumpfile); - else - fprintf (dumpfile, "(%s ", gfc_code2string (flavors, attr->flavor)); - } - if (attr->access != ACCESS_UNKNOWN) - fprintf (dumpfile, "%s ", gfc_code2string (access_types, attr->access)); - if (attr->proc != PROC_UNKNOWN) - fprintf (dumpfile, "%s ", gfc_code2string (procedures, attr->proc)); - if (attr->save != SAVE_NONE) - fprintf (dumpfile, "%s", gfc_code2string (save_status, attr->save)); - - if (attr->artificial) - fputs (" ARTIFICIAL", dumpfile); - if (attr->allocatable) - fputs (" ALLOCATABLE", dumpfile); - if (attr->asynchronous) - fputs (" ASYNCHRONOUS", dumpfile); - if (attr->codimension) - fputs (" CODIMENSION", dumpfile); - if (attr->dimension) - fputs (" DIMENSION", dumpfile); - if (attr->contiguous) - fputs (" CONTIGUOUS", dumpfile); - if (attr->external) - fputs (" EXTERNAL", dumpfile); - if (attr->intrinsic) - fputs (" INTRINSIC", dumpfile); - if (attr->optional) - fputs (" OPTIONAL", dumpfile); - if (attr->pdt_kind) - fputs (" KIND", dumpfile); - if (attr->pdt_len) - fputs (" LEN", dumpfile); - if (attr->pointer) - fputs (" POINTER", dumpfile); - if (attr->subref_array_pointer) - fputs (" SUBREF-ARRAY-POINTER", dumpfile); - if (attr->cray_pointer) - fputs (" CRAY-POINTER", dumpfile); - if (attr->cray_pointee) - fputs (" CRAY-POINTEE", dumpfile); - if (attr->is_protected) - fputs (" PROTECTED", dumpfile); - if (attr->value) - fputs (" VALUE", dumpfile); - if (attr->volatile_) - fputs (" VOLATILE", dumpfile); - if (attr->threadprivate) - fputs (" THREADPRIVATE", dumpfile); - if (attr->target) - fputs (" TARGET", dumpfile); - if (attr->dummy) - { - fputs (" DUMMY", dumpfile); - if (attr->intent != INTENT_UNKNOWN) - fprintf (dumpfile, "(%s)", gfc_intent_string (attr->intent)); - } - - if (attr->result) - fputs (" RESULT", dumpfile); - if (attr->entry) - fputs (" ENTRY", dumpfile); - if (attr->entry_master) - fputs (" ENTRY-MASTER", dumpfile); - if (attr->mixed_entry_master) - fputs (" MIXED-ENTRY-MASTER", dumpfile); - if (attr->is_bind_c) - fputs (" BIND(C)", dumpfile); - - if (attr->data) - fputs (" DATA", dumpfile); - if (attr->use_assoc) - { - fputs (" USE-ASSOC", dumpfile); - if (module != NULL) - fprintf (dumpfile, "(%s)", module); - } - - if (attr->in_namelist) - fputs (" IN-NAMELIST", dumpfile); - if (attr->in_common) - fputs (" IN-COMMON", dumpfile); - - if (attr->abstract) - fputs (" ABSTRACT", dumpfile); - if (attr->function) - fputs (" FUNCTION", dumpfile); - if (attr->subroutine) - fputs (" SUBROUTINE", dumpfile); - if (attr->implicit_type) - fputs (" IMPLICIT-TYPE", dumpfile); - - if (attr->sequence) - fputs (" SEQUENCE", dumpfile); - if (attr->alloc_comp) - fputs (" ALLOC-COMP", dumpfile); - if (attr->pointer_comp) - fputs (" POINTER-COMP", dumpfile); - if (attr->proc_pointer_comp) - fputs (" PROC-POINTER-COMP", dumpfile); - if (attr->private_comp) - fputs (" PRIVATE-COMP", dumpfile); - if (attr->zero_comp) - fputs (" ZERO-COMP", dumpfile); - if (attr->coarray_comp) - fputs (" COARRAY-COMP", dumpfile); - if (attr->lock_comp) - fputs (" LOCK-COMP", dumpfile); - if (attr->event_comp) - fputs (" EVENT-COMP", dumpfile); - if (attr->defined_assign_comp) - fputs (" DEFINED-ASSIGNED-COMP", dumpfile); - if (attr->unlimited_polymorphic) - fputs (" UNLIMITED-POLYMORPHIC", dumpfile); - if (attr->has_dtio_procs) - fputs (" HAS-DTIO-PROCS", dumpfile); - if (attr->caf_token) - fputs (" CAF-TOKEN", dumpfile); - if (attr->select_type_temporary) - fputs (" SELECT-TYPE-TEMPORARY", dumpfile); - if (attr->associate_var) - fputs (" ASSOCIATE-VAR", dumpfile); - if (attr->pdt_kind) - fputs (" PDT-KIND", dumpfile); - if (attr->pdt_len) - fputs (" PDT-LEN", dumpfile); - if (attr->pdt_type) - fputs (" PDT-TYPE", dumpfile); - if (attr->pdt_array) - fputs (" PDT-ARRAY", dumpfile); - if (attr->pdt_string) - fputs (" PDT-STRING", dumpfile); - if (attr->omp_udr_artificial_var) - fputs (" OMP-UDT-ARTIFICIAL-VAR", dumpfile); - if (attr->omp_declare_target) - fputs (" OMP-DECLARE-TARGET", dumpfile); - if (attr->omp_declare_target_link) - fputs (" OMP-DECLARE-TARGET-LINK", dumpfile); - if (attr->elemental) - fputs (" ELEMENTAL", dumpfile); - if (attr->pure) - fputs (" PURE", dumpfile); - if (attr->implicit_pure) - fputs (" IMPLICIT-PURE", dumpfile); - if (attr->recursive) - fputs (" RECURSIVE", dumpfile); - if (attr->unmaskable) - fputs (" UNMASKABKE", dumpfile); - if (attr->masked) - fputs (" MASKED", dumpfile); - if (attr->contained) - fputs (" CONTAINED", dumpfile); - if (attr->mod_proc) - fputs (" MOD-PROC", dumpfile); - if (attr->module_procedure) - fputs (" MODULE-PROCEDURE", dumpfile); - if (attr->public_used) - fputs (" PUBLIC_USED", dumpfile); - if (attr->array_outer_dependency) - fputs (" ARRAY-OUTER-DEPENDENCY", dumpfile); - if (attr->noreturn) - fputs (" NORETURN", dumpfile); - if (attr->always_explicit) - fputs (" ALWAYS-EXPLICIT", dumpfile); - if (attr->is_main_program) - fputs (" IS-MAIN-PROGRAM", dumpfile); - if (attr->oacc_routine_nohost) - fputs (" OACC-ROUTINE-NOHOST", dumpfile); - - /* FIXME: Still missing are oacc_routine_lop and ext_attr. */ - fputc (')', dumpfile); -} - - -/* Show components of a derived type. */ - -static void -show_components (gfc_symbol *sym) -{ - gfc_component *c; - - for (c = sym->components; c; c = c->next) - { - show_indent (); - fprintf (dumpfile, "(%s ", c->name); - show_typespec (&c->ts); - if (c->kind_expr) - { - fputs (" kind_expr: ", dumpfile); - show_expr (c->kind_expr); - } - if (c->param_list) - { - fputs ("PDT parameters", dumpfile); - show_actual_arglist (c->param_list); - } - - if (c->attr.allocatable) - fputs (" ALLOCATABLE", dumpfile); - if (c->attr.pdt_kind) - fputs (" KIND", dumpfile); - if (c->attr.pdt_len) - fputs (" LEN", dumpfile); - if (c->attr.pointer) - fputs (" POINTER", dumpfile); - if (c->attr.proc_pointer) - fputs (" PPC", dumpfile); - if (c->attr.dimension) - fputs (" DIMENSION", dumpfile); - fputc (' ', dumpfile); - show_array_spec (c->as); - if (c->attr.access) - fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access)); - fputc (')', dumpfile); - if (c->next != NULL) - fputc (' ', dumpfile); - } -} - - -/* Show the f2k_derived namespace with procedure bindings. */ - -static void -show_typebound_proc (gfc_typebound_proc* tb, const char* name) -{ - show_indent (); - - if (tb->is_generic) - fputs ("GENERIC", dumpfile); - else - { - fputs ("PROCEDURE, ", dumpfile); - if (tb->nopass) - fputs ("NOPASS", dumpfile); - else - { - if (tb->pass_arg) - fprintf (dumpfile, "PASS(%s)", tb->pass_arg); - else - fputs ("PASS", dumpfile); - } - if (tb->non_overridable) - fputs (", NON_OVERRIDABLE", dumpfile); - } - - if (tb->access == ACCESS_PUBLIC) - fputs (", PUBLIC", dumpfile); - else - fputs (", PRIVATE", dumpfile); - - fprintf (dumpfile, " :: %s => ", name); - - if (tb->is_generic) - { - gfc_tbp_generic* g; - for (g = tb->u.generic; g; g = g->next) - { - fputs (g->specific_st->name, dumpfile); - if (g->next) - fputs (", ", dumpfile); - } - } - else - fputs (tb->u.specific->n.sym->name, dumpfile); -} - -static void -show_typebound_symtree (gfc_symtree* st) -{ - gcc_assert (st->n.tb); - show_typebound_proc (st->n.tb, st->name); -} - -static void -show_f2k_derived (gfc_namespace* f2k) -{ - gfc_finalizer* f; - int op; - - show_indent (); - fputs ("Procedure bindings:", dumpfile); - ++show_level; - - /* Finalizer bindings. */ - for (f = f2k->finalizers; f; f = f->next) - { - show_indent (); - fprintf (dumpfile, "FINAL %s", f->proc_tree->n.sym->name); - } - - /* Type-bound procedures. */ - gfc_traverse_symtree (f2k->tb_sym_root, &show_typebound_symtree); - - --show_level; - - show_indent (); - fputs ("Operator bindings:", dumpfile); - ++show_level; - - /* User-defined operators. */ - gfc_traverse_symtree (f2k->tb_uop_root, &show_typebound_symtree); - - /* Intrinsic operators. */ - for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op) - if (f2k->tb_op[op]) - show_typebound_proc (f2k->tb_op[op], - gfc_op2string ((gfc_intrinsic_op) op)); - - --show_level; -} - - -/* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we - show the interface. Information needed to reconstruct the list of - specific interfaces associated with a generic symbol is done within - that symbol. */ - -static void -show_symbol (gfc_symbol *sym) -{ - gfc_formal_arglist *formal; - gfc_interface *intr; - int i,len; - - if (sym == NULL) - return; - - fprintf (dumpfile, "|| symbol: '%s' ", sym->name); - len = strlen (sym->name); - for (i=len; i<12; i++) - fputc(' ', dumpfile); - - if (sym->binding_label) - fprintf (dumpfile,"|| binding_label: '%s' ", sym->binding_label); - - ++show_level; - - show_indent (); - fputs ("type spec : ", dumpfile); - show_typespec (&sym->ts); - - show_indent (); - fputs ("attributes: ", dumpfile); - show_attr (&sym->attr, sym->module); - - if (sym->value) - { - show_indent (); - fputs ("value: ", dumpfile); - show_expr (sym->value); - } - - if (sym->ts.type != BT_CLASS && sym->as) - { - show_indent (); - fputs ("Array spec:", dumpfile); - show_array_spec (sym->as); - } - else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as) - { - show_indent (); - fputs ("Array spec:", dumpfile); - show_array_spec (CLASS_DATA (sym)->as); - } - - if (sym->generic) - { - show_indent (); - fputs ("Generic interfaces:", dumpfile); - for (intr = sym->generic; intr; intr = intr->next) - fprintf (dumpfile, " %s", intr->sym->name); - } - - if (sym->result) - { - show_indent (); - fprintf (dumpfile, "result: %s", sym->result->name); - } - - if (sym->components) - { - show_indent (); - fputs ("components: ", dumpfile); - show_components (sym); - } - - if (sym->f2k_derived) - { - show_indent (); - if (sym->hash_value) - fprintf (dumpfile, "hash: %d", sym->hash_value); - show_f2k_derived (sym->f2k_derived); - } - - if (sym->formal) - { - show_indent (); - fputs ("Formal arglist:", dumpfile); - - for (formal = sym->formal; formal; formal = formal->next) - { - if (formal->sym != NULL) - fprintf (dumpfile, " %s", formal->sym->name); - else - fputs (" [Alt Return]", dumpfile); - } - } - - if (sym->formal_ns && (sym->formal_ns->proc_name != sym) - && sym->attr.proc != PROC_ST_FUNCTION - && !sym->attr.entry) - { - show_indent (); - fputs ("Formal namespace", dumpfile); - show_namespace (sym->formal_ns); - } - - if (sym->attr.flavor == FL_VARIABLE - && sym->param_list) - { - show_indent (); - fputs ("PDT parameters", dumpfile); - show_actual_arglist (sym->param_list); - } - - if (sym->attr.flavor == FL_NAMELIST) - { - gfc_namelist *nl; - show_indent (); - fputs ("variables : ", dumpfile); - for (nl = sym->namelist; nl; nl = nl->next) - fprintf (dumpfile, " %s",nl->sym->name); - } - - --show_level; -} - - -/* Show a user-defined operator. Just prints an operator - and the name of the associated subroutine, really. */ - -static void -show_uop (gfc_user_op *uop) -{ - gfc_interface *intr; - - show_indent (); - fprintf (dumpfile, "%s:", uop->name); - - for (intr = uop->op; intr; intr = intr->next) - fprintf (dumpfile, " %s", intr->sym->name); -} - - -/* Workhorse function for traversing the user operator symtree. */ - -static void -traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *)) -{ - if (st == NULL) - return; - - (*func) (st->n.uop); - - traverse_uop (st->left, func); - traverse_uop (st->right, func); -} - - -/* Traverse the tree of user operator nodes. */ - -void -gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *)) -{ - traverse_uop (ns->uop_root, func); -} - - -/* Function to display a common block. */ - -static void -show_common (gfc_symtree *st) -{ - gfc_symbol *s; - - show_indent (); - fprintf (dumpfile, "common: /%s/ ", st->name); - - s = st->n.common->head; - while (s) - { - fprintf (dumpfile, "%s", s->name); - s = s->common_next; - if (s) - fputs (", ", dumpfile); - } - fputc ('\n', dumpfile); -} - - -/* Worker function to display the symbol tree. */ - -static void -show_symtree (gfc_symtree *st) -{ - int len, i; - - show_indent (); - - len = strlen(st->name); - fprintf (dumpfile, "symtree: '%s'", st->name); - - for (i=len; i<12; i++) - fputc(' ', dumpfile); - - if (st->ambiguous) - fputs( " Ambiguous", dumpfile); - - if (st->n.sym->ns != gfc_current_ns) - fprintf (dumpfile, "|| symbol: '%s' from namespace '%s'", st->n.sym->name, - st->n.sym->ns->proc_name->name); - else - show_symbol (st->n.sym); -} - - -/******************* Show gfc_code structures **************/ - - -/* Show a list of code structures. Mutually recursive with - show_code_node(). */ - -static void -show_code (int level, gfc_code *c) -{ - for (; c; c = c->next) - show_code_node (level, c); -} - -static void -show_iterator (gfc_namespace *ns) -{ - for (gfc_symbol *sym = ns->proc_name; sym; sym = sym->tlink) - { - gfc_constructor *c; - if (sym != ns->proc_name) - fputc (',', dumpfile); - fputs (sym->name, dumpfile); - fputc ('=', dumpfile); - c = gfc_constructor_first (sym->value->value.constructor); - show_expr (c->expr); - fputc (':', dumpfile); - c = gfc_constructor_next (c); - show_expr (c->expr); - c = gfc_constructor_next (c); - if (c) - { - fputc (':', dumpfile); - show_expr (c->expr); - } - } -} - -static void -show_omp_namelist (int list_type, gfc_omp_namelist *n) -{ - gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns; - gfc_omp_namelist *n2 = n; - for (; n; n = n->next) - { - gfc_current_ns = ns_curr; - if (list_type == OMP_LIST_AFFINITY || list_type == OMP_LIST_DEPEND) - { - gfc_current_ns = n->u2.ns ? n->u2.ns : ns_curr; - if (n->u2.ns != ns_iter) - { - if (n != n2) - fputs (list_type == OMP_LIST_AFFINITY - ? ") AFFINITY(" : ") DEPEND(", dumpfile); - if (n->u2.ns) - { - fputs ("ITERATOR(", dumpfile); - show_iterator (n->u2.ns); - fputc (')', dumpfile); - fputc (list_type == OMP_LIST_AFFINITY ? ':' : ',', dumpfile); - } - } - ns_iter = n->u2.ns; - } - if (list_type == OMP_LIST_REDUCTION) - switch (n->u.reduction_op) - { - case OMP_REDUCTION_PLUS: - case OMP_REDUCTION_TIMES: - case OMP_REDUCTION_MINUS: - case OMP_REDUCTION_AND: - case OMP_REDUCTION_OR: - case OMP_REDUCTION_EQV: - case OMP_REDUCTION_NEQV: - fprintf (dumpfile, "%s:", - gfc_op2string ((gfc_intrinsic_op) n->u.reduction_op)); - break; - case OMP_REDUCTION_MAX: fputs ("max:", dumpfile); break; - case OMP_REDUCTION_MIN: fputs ("min:", dumpfile); break; - case OMP_REDUCTION_IAND: fputs ("iand:", dumpfile); break; - case OMP_REDUCTION_IOR: fputs ("ior:", dumpfile); break; - case OMP_REDUCTION_IEOR: fputs ("ieor:", dumpfile); break; - case OMP_REDUCTION_USER: - if (n->u2.udr) - fprintf (dumpfile, "%s:", n->u2.udr->udr->name); - break; - default: break; - } - else if (list_type == OMP_LIST_DEPEND) - switch (n->u.depend_op) - { - case OMP_DEPEND_IN: fputs ("in:", dumpfile); break; - case OMP_DEPEND_OUT: fputs ("out:", dumpfile); break; - case OMP_DEPEND_INOUT: fputs ("inout:", dumpfile); break; - case OMP_DEPEND_DEPOBJ: fputs ("depobj:", dumpfile); break; - case OMP_DEPEND_MUTEXINOUTSET: - fputs ("mutexinoutset:", dumpfile); - break; - case OMP_DEPEND_SINK_FIRST: - fputs ("sink:", dumpfile); - while (1) - { - fprintf (dumpfile, "%s", n->sym->name); - if (n->expr) - { - fputc ('+', dumpfile); - show_expr (n->expr); - } - if (n->next == NULL) - break; - else if (n->next->u.depend_op != OMP_DEPEND_SINK) - { - fputs (") DEPEND(", dumpfile); - break; - } - fputc (',', dumpfile); - n = n->next; - } - continue; - default: break; - } - else if (list_type == OMP_LIST_MAP) - switch (n->u.map_op) - { - case OMP_MAP_ALLOC: fputs ("alloc:", dumpfile); break; - case OMP_MAP_TO: fputs ("to:", dumpfile); break; - case OMP_MAP_FROM: fputs ("from:", dumpfile); break; - case OMP_MAP_TOFROM: fputs ("tofrom:", dumpfile); break; - default: break; - } - else if (list_type == OMP_LIST_LINEAR) - switch (n->u.linear_op) - { - case OMP_LINEAR_REF: fputs ("ref(", dumpfile); break; - case OMP_LINEAR_VAL: fputs ("val(", dumpfile); break; - case OMP_LINEAR_UVAL: fputs ("uval(", dumpfile); break; - default: break; - } - fprintf (dumpfile, "%s", n->sym->name); - if (list_type == OMP_LIST_LINEAR && n->u.linear_op != OMP_LINEAR_DEFAULT) - fputc (')', dumpfile); - if (n->expr) - { - fputc (':', dumpfile); - show_expr (n->expr); - } - if (n->next) - fputc (',', dumpfile); - } - gfc_current_ns = ns_curr; -} - - -/* Show OpenMP or OpenACC clauses. */ - -static void -show_omp_clauses (gfc_omp_clauses *omp_clauses) -{ - int list_type, i; - - switch (omp_clauses->cancel) - { - case OMP_CANCEL_UNKNOWN: - break; - case OMP_CANCEL_PARALLEL: - fputs (" PARALLEL", dumpfile); - break; - case OMP_CANCEL_SECTIONS: - fputs (" SECTIONS", dumpfile); - break; - case OMP_CANCEL_DO: - fputs (" DO", dumpfile); - break; - case OMP_CANCEL_TASKGROUP: - fputs (" TASKGROUP", dumpfile); - break; - } - if (omp_clauses->if_expr) - { - fputs (" IF(", dumpfile); - show_expr (omp_clauses->if_expr); - fputc (')', dumpfile); - } - if (omp_clauses->final_expr) - { - fputs (" FINAL(", dumpfile); - show_expr (omp_clauses->final_expr); - fputc (')', dumpfile); - } - if (omp_clauses->num_threads) - { - fputs (" NUM_THREADS(", dumpfile); - show_expr (omp_clauses->num_threads); - fputc (')', dumpfile); - } - if (omp_clauses->async) - { - fputs (" ASYNC", dumpfile); - if (omp_clauses->async_expr) - { - fputc ('(', dumpfile); - show_expr (omp_clauses->async_expr); - fputc (')', dumpfile); - } - } - if (omp_clauses->num_gangs_expr) - { - fputs (" NUM_GANGS(", dumpfile); - show_expr (omp_clauses->num_gangs_expr); - fputc (')', dumpfile); - } - if (omp_clauses->num_workers_expr) - { - fputs (" NUM_WORKERS(", dumpfile); - show_expr (omp_clauses->num_workers_expr); - fputc (')', dumpfile); - } - if (omp_clauses->vector_length_expr) - { - fputs (" VECTOR_LENGTH(", dumpfile); - show_expr (omp_clauses->vector_length_expr); - fputc (')', dumpfile); - } - if (omp_clauses->gang) - { - fputs (" GANG", dumpfile); - if (omp_clauses->gang_num_expr || omp_clauses->gang_static_expr) - { - fputc ('(', dumpfile); - if (omp_clauses->gang_num_expr) - { - fprintf (dumpfile, "num:"); - show_expr (omp_clauses->gang_num_expr); - } - if (omp_clauses->gang_num_expr && omp_clauses->gang_static) - fputc (',', dumpfile); - if (omp_clauses->gang_static) - { - fprintf (dumpfile, "static:"); - if (omp_clauses->gang_static_expr) - show_expr (omp_clauses->gang_static_expr); - else - fputc ('*', dumpfile); - } - fputc (')', dumpfile); - } - } - if (omp_clauses->worker) - { - fputs (" WORKER", dumpfile); - if (omp_clauses->worker_expr) - { - fputc ('(', dumpfile); - show_expr (omp_clauses->worker_expr); - fputc (')', dumpfile); - } - } - if (omp_clauses->vector) - { - fputs (" VECTOR", dumpfile); - if (omp_clauses->vector_expr) - { - fputc ('(', dumpfile); - show_expr (omp_clauses->vector_expr); - fputc (')', dumpfile); - } - } - if (omp_clauses->sched_kind != OMP_SCHED_NONE) - { - const char *type; - switch (omp_clauses->sched_kind) - { - case OMP_SCHED_STATIC: type = "STATIC"; break; - case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break; - case OMP_SCHED_GUIDED: type = "GUIDED"; break; - case OMP_SCHED_RUNTIME: type = "RUNTIME"; break; - case OMP_SCHED_AUTO: type = "AUTO"; break; - default: - gcc_unreachable (); - } - fputs (" SCHEDULE (", dumpfile); - if (omp_clauses->sched_simd) - { - if (omp_clauses->sched_monotonic - || omp_clauses->sched_nonmonotonic) - fputs ("SIMD, ", dumpfile); - else - fputs ("SIMD: ", dumpfile); - } - if (omp_clauses->sched_monotonic) - fputs ("MONOTONIC: ", dumpfile); - else if (omp_clauses->sched_nonmonotonic) - fputs ("NONMONOTONIC: ", dumpfile); - fputs (type, dumpfile); - if (omp_clauses->chunk_size) - { - fputc (',', dumpfile); - show_expr (omp_clauses->chunk_size); - } - fputc (')', dumpfile); - } - if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN) - { - const char *type; - switch (omp_clauses->default_sharing) - { - case OMP_DEFAULT_NONE: type = "NONE"; break; - case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break; - case OMP_DEFAULT_SHARED: type = "SHARED"; break; - case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break; - case OMP_DEFAULT_PRESENT: type = "PRESENT"; break; - default: - gcc_unreachable (); - } - fprintf (dumpfile, " DEFAULT(%s)", type); - } - if (omp_clauses->tile_list) - { - gfc_expr_list *list; - fputs (" TILE(", dumpfile); - for (list = omp_clauses->tile_list; list; list = list->next) - { - show_expr (list->expr); - if (list->next) - fputs (", ", dumpfile); - } - fputc (')', dumpfile); - } - if (omp_clauses->wait_list) - { - gfc_expr_list *list; - fputs (" WAIT(", dumpfile); - for (list = omp_clauses->wait_list; list; list = list->next) - { - show_expr (list->expr); - if (list->next) - fputs (", ", dumpfile); - } - fputc (')', dumpfile); - } - if (omp_clauses->seq) - fputs (" SEQ", dumpfile); - if (omp_clauses->independent) - fputs (" INDEPENDENT", dumpfile); - if (omp_clauses->order_concurrent) - { - fputs (" ORDER(", dumpfile); - if (omp_clauses->order_unconstrained) - fputs ("UNCONSTRAINED:", dumpfile); - else if (omp_clauses->order_reproducible) - fputs ("REPRODUCIBLE:", dumpfile); - fputs ("CONCURRENT)", dumpfile); - } - if (omp_clauses->ordered) - { - if (omp_clauses->orderedc) - fprintf (dumpfile, " ORDERED(%d)", omp_clauses->orderedc); - else - fputs (" ORDERED", dumpfile); - } - if (omp_clauses->untied) - fputs (" UNTIED", dumpfile); - if (omp_clauses->mergeable) - fputs (" MERGEABLE", dumpfile); - if (omp_clauses->collapse) - fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse); - for (list_type = 0; list_type < OMP_LIST_NUM; list_type++) - if (omp_clauses->lists[list_type] != NULL - && list_type != OMP_LIST_COPYPRIVATE) - { - const char *type = NULL; - switch (list_type) - { - case OMP_LIST_PRIVATE: type = "PRIVATE"; break; - case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break; - case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break; - case OMP_LIST_COPYPRIVATE: type = "COPYPRIVATE"; break; - case OMP_LIST_SHARED: type = "SHARED"; break; - case OMP_LIST_COPYIN: type = "COPYIN"; break; - case OMP_LIST_UNIFORM: type = "UNIFORM"; break; - case OMP_LIST_AFFINITY: type = "AFFINITY"; break; - case OMP_LIST_ALIGNED: type = "ALIGNED"; break; - case OMP_LIST_LINEAR: type = "LINEAR"; break; - case OMP_LIST_DEPEND: type = "DEPEND"; break; - case OMP_LIST_MAP: type = "MAP"; break; - case OMP_LIST_TO: type = "TO"; break; - case OMP_LIST_FROM: type = "FROM"; break; - case OMP_LIST_REDUCTION: - case OMP_LIST_REDUCTION_INSCAN: - case OMP_LIST_REDUCTION_TASK: type = "REDUCTION"; break; - case OMP_LIST_IN_REDUCTION: type = "IN_REDUCTION"; break; - case OMP_LIST_TASK_REDUCTION: type = "TASK_REDUCTION"; break; - case OMP_LIST_DEVICE_RESIDENT: type = "DEVICE_RESIDENT"; break; - case OMP_LIST_LINK: type = "LINK"; break; - case OMP_LIST_USE_DEVICE: type = "USE_DEVICE"; break; - case OMP_LIST_CACHE: type = "CACHE"; break; - case OMP_LIST_IS_DEVICE_PTR: type = "IS_DEVICE_PTR"; break; - case OMP_LIST_USE_DEVICE_PTR: type = "USE_DEVICE_PTR"; break; - case OMP_LIST_USE_DEVICE_ADDR: type = "USE_DEVICE_ADDR"; break; - case OMP_LIST_NONTEMPORAL: type = "NONTEMPORAL"; break; - case OMP_LIST_ALLOCATE: type = "ALLOCATE"; break; - case OMP_LIST_SCAN_IN: type = "INCLUSIVE"; break; - case OMP_LIST_SCAN_EX: type = "EXCLUSIVE"; break; - default: - gcc_unreachable (); - } - fprintf (dumpfile, " %s(", type); - if (list_type == OMP_LIST_REDUCTION_INSCAN) - fputs ("inscan, ", dumpfile); - if (list_type == OMP_LIST_REDUCTION_TASK) - fputs ("task, ", dumpfile); - show_omp_namelist (list_type, omp_clauses->lists[list_type]); - fputc (')', dumpfile); - } - if (omp_clauses->safelen_expr) - { - fputs (" SAFELEN(", dumpfile); - show_expr (omp_clauses->safelen_expr); - fputc (')', dumpfile); - } - if (omp_clauses->simdlen_expr) - { - fputs (" SIMDLEN(", dumpfile); - show_expr (omp_clauses->simdlen_expr); - fputc (')', dumpfile); - } - if (omp_clauses->inbranch) - fputs (" INBRANCH", dumpfile); - if (omp_clauses->notinbranch) - fputs (" NOTINBRANCH", dumpfile); - if (omp_clauses->proc_bind != OMP_PROC_BIND_UNKNOWN) - { - const char *type; - switch (omp_clauses->proc_bind) - { - case OMP_PROC_BIND_PRIMARY: type = "PRIMARY"; break; - case OMP_PROC_BIND_MASTER: type = "MASTER"; break; - case OMP_PROC_BIND_SPREAD: type = "SPREAD"; break; - case OMP_PROC_BIND_CLOSE: type = "CLOSE"; break; - default: - gcc_unreachable (); - } - fprintf (dumpfile, " PROC_BIND(%s)", type); - } - if (omp_clauses->bind != OMP_BIND_UNSET) - { - const char *type; - switch (omp_clauses->bind) - { - case OMP_BIND_TEAMS: type = "TEAMS"; break; - case OMP_BIND_PARALLEL: type = "PARALLEL"; break; - case OMP_BIND_THREAD: type = "THREAD"; break; - default: - gcc_unreachable (); - } - fprintf (dumpfile, " BIND(%s)", type); - } - if (omp_clauses->num_teams_upper) - { - fputs (" NUM_TEAMS(", dumpfile); - if (omp_clauses->num_teams_lower) - { - show_expr (omp_clauses->num_teams_lower); - fputc (':', dumpfile); - } - show_expr (omp_clauses->num_teams_upper); - fputc (')', dumpfile); - } - if (omp_clauses->device) - { - fputs (" DEVICE(", dumpfile); - if (omp_clauses->ancestor) - fputs ("ANCESTOR:", dumpfile); - show_expr (omp_clauses->device); - fputc (')', dumpfile); - } - if (omp_clauses->thread_limit) - { - fputs (" THREAD_LIMIT(", dumpfile); - show_expr (omp_clauses->thread_limit); - fputc (')', dumpfile); - } - if (omp_clauses->dist_sched_kind != OMP_SCHED_NONE) - { - fputs (" DIST_SCHEDULE (STATIC", dumpfile); - if (omp_clauses->dist_chunk_size) - { - fputc (',', dumpfile); - show_expr (omp_clauses->dist_chunk_size); - } - fputc (')', dumpfile); - } - for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++) - { - const char *dfltmap; - if (omp_clauses->defaultmap[i] == OMP_DEFAULTMAP_UNSET) - continue; - fputs (" DEFAULTMAP (", dumpfile); - switch (omp_clauses->defaultmap[i]) - { - case OMP_DEFAULTMAP_ALLOC: dfltmap = "ALLOC"; break; - case OMP_DEFAULTMAP_TO: dfltmap = "TO"; break; - case OMP_DEFAULTMAP_FROM: dfltmap = "FROM"; break; - case OMP_DEFAULTMAP_TOFROM: dfltmap = "TOFROM"; break; - case OMP_DEFAULTMAP_FIRSTPRIVATE: dfltmap = "FIRSTPRIVATE"; break; - case OMP_DEFAULTMAP_NONE: dfltmap = "NONE"; break; - case OMP_DEFAULTMAP_DEFAULT: dfltmap = "DEFAULT"; break; - case OMP_DEFAULTMAP_PRESENT: dfltmap = "PRESENT"; break; - default: gcc_unreachable (); - } - fputs (dfltmap, dumpfile); - if (i != OMP_DEFAULTMAP_CAT_UNCATEGORIZED) - { - fputc (':', dumpfile); - switch ((enum gfc_omp_defaultmap_category) i) - { - case OMP_DEFAULTMAP_CAT_SCALAR: dfltmap = "SCALAR"; break; - case OMP_DEFAULTMAP_CAT_AGGREGATE: dfltmap = "AGGREGATE"; break; - case OMP_DEFAULTMAP_CAT_ALLOCATABLE: dfltmap = "ALLOCATABLE"; break; - case OMP_DEFAULTMAP_CAT_POINTER: dfltmap = "POINTER"; break; - default: gcc_unreachable (); - } - fputs (dfltmap, dumpfile); - } - fputc (')', dumpfile); - } - if (omp_clauses->weak) - fputs (" WEAK", dumpfile); - if (omp_clauses->compare) - fputs (" COMPARE", dumpfile); - if (omp_clauses->nogroup) - fputs (" NOGROUP", dumpfile); - if (omp_clauses->simd) - fputs (" SIMD", dumpfile); - if (omp_clauses->threads) - fputs (" THREADS", dumpfile); - if (omp_clauses->grainsize) - { - fputs (" GRAINSIZE(", dumpfile); - if (omp_clauses->grainsize_strict) - fputs ("strict: ", dumpfile); - show_expr (omp_clauses->grainsize); - fputc (')', dumpfile); - } - if (omp_clauses->filter) - { - fputs (" FILTER(", dumpfile); - show_expr (omp_clauses->filter); - fputc (')', dumpfile); - } - if (omp_clauses->hint) - { - fputs (" HINT(", dumpfile); - show_expr (omp_clauses->hint); - fputc (')', dumpfile); - } - if (omp_clauses->num_tasks) - { - fputs (" NUM_TASKS(", dumpfile); - if (omp_clauses->num_tasks_strict) - fputs ("strict: ", dumpfile); - show_expr (omp_clauses->num_tasks); - fputc (')', dumpfile); - } - if (omp_clauses->priority) - { - fputs (" PRIORITY(", dumpfile); - show_expr (omp_clauses->priority); - fputc (')', dumpfile); - } - if (omp_clauses->detach) - { - fputs (" DETACH(", dumpfile); - show_expr (omp_clauses->detach); - fputc (')', dumpfile); - } - for (i = 0; i < OMP_IF_LAST; i++) - if (omp_clauses->if_exprs[i]) - { - static const char *ifs[] = { - "CANCEL", - "PARALLEL", - "SIMD", - "TASK", - "TASKLOOP", - "TARGET", - "TARGET DATA", - "TARGET UPDATE", - "TARGET ENTER DATA", - "TARGET EXIT DATA" - }; - fputs (" IF(", dumpfile); - fputs (ifs[i], dumpfile); - fputs (": ", dumpfile); - show_expr (omp_clauses->if_exprs[i]); - fputc (')', dumpfile); - } - if (omp_clauses->destroy) - fputs (" DESTROY", dumpfile); - if (omp_clauses->depend_source) - fputs (" DEPEND(source)", dumpfile); - if (omp_clauses->capture) - fputs (" CAPTURE", dumpfile); - if (omp_clauses->depobj_update != OMP_DEPEND_UNSET) - { - const char *deptype; - fputs (" UPDATE(", dumpfile); - switch (omp_clauses->depobj_update) - { - case OMP_DEPEND_IN: deptype = "IN"; break; - case OMP_DEPEND_OUT: deptype = "OUT"; break; - case OMP_DEPEND_INOUT: deptype = "INOUT"; break; - case OMP_DEPEND_MUTEXINOUTSET: deptype = "MUTEXINOUTSET"; break; - default: gcc_unreachable (); - } - fputs (deptype, dumpfile); - fputc (')', dumpfile); - } - if (omp_clauses->atomic_op != GFC_OMP_ATOMIC_UNSET) - { - const char *atomic_op; - switch (omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK) - { - case GFC_OMP_ATOMIC_READ: atomic_op = "READ"; break; - case GFC_OMP_ATOMIC_WRITE: atomic_op = "WRITE"; break; - case GFC_OMP_ATOMIC_UPDATE: atomic_op = "UPDATE"; break; - default: gcc_unreachable (); - } - fputc (' ', dumpfile); - fputs (atomic_op, dumpfile); - } - if (omp_clauses->memorder != OMP_MEMORDER_UNSET) - { - const char *memorder; - switch (omp_clauses->memorder) - { - case OMP_MEMORDER_ACQ_REL: memorder = "ACQ_REL"; break; - case OMP_MEMORDER_ACQUIRE: memorder = "AQUIRE"; break; - case OMP_MEMORDER_RELAXED: memorder = "RELAXED"; break; - case OMP_MEMORDER_RELEASE: memorder = "RELEASE"; break; - case OMP_MEMORDER_SEQ_CST: memorder = "SEQ_CST"; break; - default: gcc_unreachable (); - } - fputc (' ', dumpfile); - fputs (memorder, dumpfile); - } - if (omp_clauses->fail != OMP_MEMORDER_UNSET) - { - const char *memorder; - switch (omp_clauses->fail) - { - case OMP_MEMORDER_ACQUIRE: memorder = "AQUIRE"; break; - case OMP_MEMORDER_RELAXED: memorder = "RELAXED"; break; - case OMP_MEMORDER_SEQ_CST: memorder = "SEQ_CST"; break; - default: gcc_unreachable (); - } - fputs (" FAIL(", dumpfile); - fputs (memorder, dumpfile); - putc (')', dumpfile); - } - if (omp_clauses->at != OMP_AT_UNSET) - { - if (omp_clauses->at != OMP_AT_COMPILATION) - fputs (" AT (COMPILATION)", dumpfile); - else - fputs (" AT (EXECUTION)", dumpfile); - } - if (omp_clauses->severity != OMP_SEVERITY_UNSET) - { - if (omp_clauses->severity != OMP_SEVERITY_FATAL) - fputs (" SEVERITY (FATAL)", dumpfile); - else - fputs (" SEVERITY (WARNING)", dumpfile); - } - if (omp_clauses->message) - { - fputs (" ERROR (", dumpfile); - show_expr (omp_clauses->message); - fputc (')', dumpfile); - } -} - -/* Show a single OpenMP or OpenACC directive node and everything underneath it - if necessary. */ - -static void -show_omp_node (int level, gfc_code *c) -{ - gfc_omp_clauses *omp_clauses = NULL; - const char *name = NULL; - bool is_oacc = false; - - switch (c->op) - { - case EXEC_OACC_PARALLEL_LOOP: - name = "PARALLEL LOOP"; is_oacc = true; break; - case EXEC_OACC_PARALLEL: name = "PARALLEL"; is_oacc = true; break; - case EXEC_OACC_KERNELS_LOOP: name = "KERNELS LOOP"; is_oacc = true; break; - case EXEC_OACC_KERNELS: name = "KERNELS"; is_oacc = true; break; - case EXEC_OACC_SERIAL_LOOP: name = "SERIAL LOOP"; is_oacc = true; break; - case EXEC_OACC_SERIAL: name = "SERIAL"; is_oacc = true; break; - case EXEC_OACC_DATA: name = "DATA"; is_oacc = true; break; - case EXEC_OACC_HOST_DATA: name = "HOST_DATA"; is_oacc = true; break; - case EXEC_OACC_LOOP: name = "LOOP"; is_oacc = true; break; - case EXEC_OACC_UPDATE: name = "UPDATE"; is_oacc = true; break; - case EXEC_OACC_WAIT: name = "WAIT"; is_oacc = true; break; - case EXEC_OACC_CACHE: name = "CACHE"; is_oacc = true; break; - case EXEC_OACC_ENTER_DATA: name = "ENTER DATA"; is_oacc = true; break; - case EXEC_OACC_EXIT_DATA: name = "EXIT DATA"; is_oacc = true; break; - case EXEC_OMP_ATOMIC: name = "ATOMIC"; break; - case EXEC_OMP_BARRIER: name = "BARRIER"; break; - case EXEC_OMP_CANCEL: name = "CANCEL"; break; - case EXEC_OMP_CANCELLATION_POINT: name = "CANCELLATION POINT"; break; - case EXEC_OMP_CRITICAL: name = "CRITICAL"; break; - case EXEC_OMP_DISTRIBUTE: name = "DISTRIBUTE"; break; - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - name = "DISTRIBUTE PARALLEL DO"; break; - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - name = "DISTRIBUTE PARALLEL DO SIMD"; break; - case EXEC_OMP_DISTRIBUTE_SIMD: name = "DISTRIBUTE SIMD"; break; - case EXEC_OMP_DO: name = "DO"; break; - case EXEC_OMP_DO_SIMD: name = "DO SIMD"; break; - case EXEC_OMP_ERROR: name = "ERROR"; break; - case EXEC_OMP_FLUSH: name = "FLUSH"; break; - case EXEC_OMP_LOOP: name = "LOOP"; break; - case EXEC_OMP_MASKED: name = "MASKED"; break; - case EXEC_OMP_MASKED_TASKLOOP: name = "MASKED TASKLOOP"; break; - case EXEC_OMP_MASKED_TASKLOOP_SIMD: name = "MASKED TASKLOOP SIMD"; break; - case EXEC_OMP_MASTER: name = "MASTER"; break; - case EXEC_OMP_MASTER_TASKLOOP: name = "MASTER TASKLOOP"; break; - case EXEC_OMP_MASTER_TASKLOOP_SIMD: name = "MASTER TASKLOOP SIMD"; break; - case EXEC_OMP_ORDERED: name = "ORDERED"; break; - case EXEC_OMP_DEPOBJ: name = "DEPOBJ"; break; - case EXEC_OMP_PARALLEL: name = "PARALLEL"; break; - case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break; - case EXEC_OMP_PARALLEL_DO_SIMD: name = "PARALLEL DO SIMD"; break; - case EXEC_OMP_PARALLEL_LOOP: name = "PARALLEL LOOP"; break; - case EXEC_OMP_PARALLEL_MASTER: name = "PARALLEL MASTER"; break; - case EXEC_OMP_PARALLEL_MASKED: name = "PARALLEL MASK"; break; - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - name = "PARALLEL MASK TASKLOOP"; break; - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - name = "PARALLEL MASK TASKLOOP SIMD"; break; - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - name = "PARALLEL MASTER TASKLOOP"; break; - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - name = "PARALLEL MASTER TASKLOOP SIMD"; break; - case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break; - case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break; - case EXEC_OMP_SCAN: name = "SCAN"; break; - case EXEC_OMP_SCOPE: name = "SCOPE"; break; - case EXEC_OMP_SECTIONS: name = "SECTIONS"; break; - case EXEC_OMP_SIMD: name = "SIMD"; break; - case EXEC_OMP_SINGLE: name = "SINGLE"; break; - case EXEC_OMP_TARGET: name = "TARGET"; break; - case EXEC_OMP_TARGET_DATA: name = "TARGET DATA"; break; - case EXEC_OMP_TARGET_ENTER_DATA: name = "TARGET ENTER DATA"; break; - case EXEC_OMP_TARGET_EXIT_DATA: name = "TARGET EXIT DATA"; break; - case EXEC_OMP_TARGET_PARALLEL: name = "TARGET PARALLEL"; break; - case EXEC_OMP_TARGET_PARALLEL_DO: name = "TARGET PARALLEL DO"; break; - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - name = "TARGET_PARALLEL_DO_SIMD"; break; - case EXEC_OMP_TARGET_PARALLEL_LOOP: name = "TARGET PARALLEL LOOP"; break; - case EXEC_OMP_TARGET_SIMD: name = "TARGET SIMD"; break; - case EXEC_OMP_TARGET_TEAMS: name = "TARGET TEAMS"; break; - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - name = "TARGET TEAMS DISTRIBUTE"; break; - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - name = "TARGET TEAMS DISTRIBUTE PARALLEL DO"; break; - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - name = "TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; break; - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - name = "TARGET TEAMS DISTRIBUTE SIMD"; break; - case EXEC_OMP_TARGET_TEAMS_LOOP: name = "TARGET TEAMS LOOP"; break; - case EXEC_OMP_TARGET_UPDATE: name = "TARGET UPDATE"; break; - case EXEC_OMP_TASK: name = "TASK"; break; - case EXEC_OMP_TASKGROUP: name = "TASKGROUP"; break; - case EXEC_OMP_TASKLOOP: name = "TASKLOOP"; break; - case EXEC_OMP_TASKLOOP_SIMD: name = "TASKLOOP SIMD"; break; - case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break; - case EXEC_OMP_TASKYIELD: name = "TASKYIELD"; break; - case EXEC_OMP_TEAMS: name = "TEAMS"; break; - case EXEC_OMP_TEAMS_DISTRIBUTE: name = "TEAMS DISTRIBUTE"; break; - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - name = "TEAMS DISTRIBUTE PARALLEL DO"; break; - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - name = "TEAMS DISTRIBUTE PARALLEL DO SIMD"; break; - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: name = "TEAMS DISTRIBUTE SIMD"; break; - case EXEC_OMP_TEAMS_LOOP: name = "TEAMS LOOP"; break; - case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break; - default: - gcc_unreachable (); - } - fprintf (dumpfile, "!$%s %s", is_oacc ? "ACC" : "OMP", name); - switch (c->op) - { - case EXEC_OACC_PARALLEL_LOOP: - case EXEC_OACC_PARALLEL: - case EXEC_OACC_KERNELS_LOOP: - case EXEC_OACC_KERNELS: - case EXEC_OACC_SERIAL_LOOP: - case EXEC_OACC_SERIAL: - case EXEC_OACC_DATA: - case EXEC_OACC_HOST_DATA: - case EXEC_OACC_LOOP: - case EXEC_OACC_UPDATE: - case EXEC_OACC_WAIT: - case EXEC_OACC_CACHE: - case EXEC_OACC_ENTER_DATA: - case EXEC_OACC_EXIT_DATA: - case EXEC_OMP_CANCEL: - case EXEC_OMP_CANCELLATION_POINT: - case EXEC_OMP_DISTRIBUTE: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_DISTRIBUTE_SIMD: - case EXEC_OMP_DO: - case EXEC_OMP_DO_SIMD: - case EXEC_OMP_ERROR: - case EXEC_OMP_LOOP: - case EXEC_OMP_ORDERED: - case EXEC_OMP_MASKED: - case EXEC_OMP_PARALLEL: - case EXEC_OMP_PARALLEL_DO: - case EXEC_OMP_PARALLEL_DO_SIMD: - case EXEC_OMP_PARALLEL_LOOP: - case EXEC_OMP_PARALLEL_MASKED: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_MASTER: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_SECTIONS: - case EXEC_OMP_PARALLEL_WORKSHARE: - case EXEC_OMP_SCAN: - case EXEC_OMP_SCOPE: - case EXEC_OMP_SECTIONS: - case EXEC_OMP_SIMD: - case EXEC_OMP_SINGLE: - case EXEC_OMP_TARGET: - case EXEC_OMP_TARGET_DATA: - case EXEC_OMP_TARGET_ENTER_DATA: - case EXEC_OMP_TARGET_EXIT_DATA: - case EXEC_OMP_TARGET_PARALLEL: - case EXEC_OMP_TARGET_PARALLEL_DO: - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_PARALLEL_LOOP: - case EXEC_OMP_TARGET_SIMD: - case EXEC_OMP_TARGET_TEAMS: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TARGET_TEAMS_LOOP: - case EXEC_OMP_TARGET_UPDATE: - case EXEC_OMP_TASK: - case EXEC_OMP_TASKLOOP: - case EXEC_OMP_TASKLOOP_SIMD: - case EXEC_OMP_TEAMS: - case EXEC_OMP_TEAMS_DISTRIBUTE: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TEAMS_LOOP: - case EXEC_OMP_WORKSHARE: - omp_clauses = c->ext.omp_clauses; - break; - case EXEC_OMP_CRITICAL: - omp_clauses = c->ext.omp_clauses; - if (omp_clauses) - fprintf (dumpfile, " (%s)", c->ext.omp_clauses->critical_name); - break; - case EXEC_OMP_DEPOBJ: - omp_clauses = c->ext.omp_clauses; - if (omp_clauses) - { - fputc ('(', dumpfile); - show_expr (c->ext.omp_clauses->depobj); - fputc (')', dumpfile); - } - break; - case EXEC_OMP_FLUSH: - if (c->ext.omp_namelist) - { - fputs (" (", dumpfile); - show_omp_namelist (OMP_LIST_NUM, c->ext.omp_namelist); - fputc (')', dumpfile); - } - return; - case EXEC_OMP_BARRIER: - case EXEC_OMP_TASKWAIT: - case EXEC_OMP_TASKYIELD: - return; - case EXEC_OACC_ATOMIC: - case EXEC_OMP_ATOMIC: - omp_clauses = c->block ? c->block->ext.omp_clauses : NULL; - break; - default: - break; - } - if (omp_clauses) - show_omp_clauses (omp_clauses); - fputc ('\n', dumpfile); - - /* OpenMP and OpenACC executable directives don't have associated blocks. */ - if (c->op == EXEC_OACC_CACHE || c->op == EXEC_OACC_UPDATE - || c->op == EXEC_OACC_ENTER_DATA || c->op == EXEC_OACC_EXIT_DATA - || c->op == EXEC_OMP_TARGET_UPDATE || c->op == EXEC_OMP_TARGET_ENTER_DATA - || c->op == EXEC_OMP_TARGET_EXIT_DATA || c->op == EXEC_OMP_SCAN - || c->op == EXEC_OMP_DEPOBJ || c->op == EXEC_OMP_ERROR - || (c->op == EXEC_OMP_ORDERED && c->block == NULL)) - return; - if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS) - { - gfc_code *d = c->block; - while (d != NULL) - { - show_code (level + 1, d->next); - if (d->block == NULL) - break; - code_indent (level, 0); - fputs ("!$OMP SECTION\n", dumpfile); - d = d->block; - } - } - else - show_code (level + 1, c->block->next); - if (c->op == EXEC_OMP_ATOMIC) - return; - fputc ('\n', dumpfile); - code_indent (level, 0); - fprintf (dumpfile, "!$%s END %s", is_oacc ? "ACC" : "OMP", name); - if (omp_clauses != NULL) - { - if (omp_clauses->lists[OMP_LIST_COPYPRIVATE]) - { - fputs (" COPYPRIVATE(", dumpfile); - show_omp_namelist (OMP_LIST_COPYPRIVATE, - omp_clauses->lists[OMP_LIST_COPYPRIVATE]); - fputc (')', dumpfile); - } - else if (omp_clauses->nowait) - fputs (" NOWAIT", dumpfile); - } - else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_clauses) - fprintf (dumpfile, " (%s)", c->ext.omp_clauses->critical_name); -} - - -/* Show a single code node and everything underneath it if necessary. */ - -static void -show_code_node (int level, gfc_code *c) -{ - gfc_forall_iterator *fa; - gfc_open *open; - gfc_case *cp; - gfc_alloc *a; - gfc_code *d; - gfc_close *close; - gfc_filepos *fp; - gfc_inquire *i; - gfc_dt *dt; - gfc_namespace *ns; - - if (c->here) - { - fputc ('\n', dumpfile); - code_indent (level, c->here); - } - else - show_indent (); - - switch (c->op) - { - case EXEC_END_PROCEDURE: - break; - - case EXEC_NOP: - fputs ("NOP", dumpfile); - break; - - case EXEC_CONTINUE: - fputs ("CONTINUE", dumpfile); - break; - - case EXEC_ENTRY: - fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name); - break; - - case EXEC_INIT_ASSIGN: - case EXEC_ASSIGN: - fputs ("ASSIGN ", dumpfile); - show_expr (c->expr1); - fputc (' ', dumpfile); - show_expr (c->expr2); - break; - - case EXEC_LABEL_ASSIGN: - fputs ("LABEL ASSIGN ", dumpfile); - show_expr (c->expr1); - fprintf (dumpfile, " %d", c->label1->value); - break; - - case EXEC_POINTER_ASSIGN: - fputs ("POINTER ASSIGN ", dumpfile); - show_expr (c->expr1); - fputc (' ', dumpfile); - show_expr (c->expr2); - break; - - case EXEC_GOTO: - fputs ("GOTO ", dumpfile); - if (c->label1) - fprintf (dumpfile, "%d", c->label1->value); - else - { - show_expr (c->expr1); - d = c->block; - if (d != NULL) - { - fputs (", (", dumpfile); - for (; d; d = d ->block) - { - code_indent (level, d->label1); - if (d->block != NULL) - fputc (',', dumpfile); - else - fputc (')', dumpfile); - } - } - } - break; - - case EXEC_CALL: - case EXEC_ASSIGN_CALL: - if (c->resolved_sym) - fprintf (dumpfile, "CALL %s ", c->resolved_sym->name); - else if (c->symtree) - fprintf (dumpfile, "CALL %s ", c->symtree->name); - else - fputs ("CALL ?? ", dumpfile); - - show_actual_arglist (c->ext.actual); - break; - - case EXEC_COMPCALL: - fputs ("CALL ", dumpfile); - show_compcall (c->expr1); - break; - - case EXEC_CALL_PPC: - fputs ("CALL ", dumpfile); - show_expr (c->expr1); - show_actual_arglist (c->ext.actual); - break; - - case EXEC_RETURN: - fputs ("RETURN ", dumpfile); - if (c->expr1) - show_expr (c->expr1); - break; - - case EXEC_PAUSE: - fputs ("PAUSE ", dumpfile); - - if (c->expr1 != NULL) - show_expr (c->expr1); - else - fprintf (dumpfile, "%d", c->ext.stop_code); - - break; - - case EXEC_ERROR_STOP: - fputs ("ERROR ", dumpfile); - /* Fall through. */ - - case EXEC_STOP: - fputs ("STOP ", dumpfile); - - if (c->expr1 != NULL) - show_expr (c->expr1); - else - fprintf (dumpfile, "%d", c->ext.stop_code); - - break; - - case EXEC_FAIL_IMAGE: - fputs ("FAIL IMAGE ", dumpfile); - break; - - case EXEC_CHANGE_TEAM: - fputs ("CHANGE TEAM", dumpfile); - break; - - case EXEC_END_TEAM: - fputs ("END TEAM", dumpfile); - break; - - case EXEC_FORM_TEAM: - fputs ("FORM TEAM", dumpfile); - break; - - case EXEC_SYNC_TEAM: - fputs ("SYNC TEAM", dumpfile); - break; - - case EXEC_SYNC_ALL: - fputs ("SYNC ALL ", dumpfile); - if (c->expr2 != NULL) - { - fputs (" stat=", dumpfile); - show_expr (c->expr2); - } - if (c->expr3 != NULL) - { - fputs (" errmsg=", dumpfile); - show_expr (c->expr3); - } - break; - - case EXEC_SYNC_MEMORY: - fputs ("SYNC MEMORY ", dumpfile); - if (c->expr2 != NULL) - { - fputs (" stat=", dumpfile); - show_expr (c->expr2); - } - if (c->expr3 != NULL) - { - fputs (" errmsg=", dumpfile); - show_expr (c->expr3); - } - break; - - case EXEC_SYNC_IMAGES: - fputs ("SYNC IMAGES image-set=", dumpfile); - if (c->expr1 != NULL) - show_expr (c->expr1); - else - fputs ("* ", dumpfile); - if (c->expr2 != NULL) - { - fputs (" stat=", dumpfile); - show_expr (c->expr2); - } - if (c->expr3 != NULL) - { - fputs (" errmsg=", dumpfile); - show_expr (c->expr3); - } - break; - - case EXEC_EVENT_POST: - case EXEC_EVENT_WAIT: - if (c->op == EXEC_EVENT_POST) - fputs ("EVENT POST ", dumpfile); - else - fputs ("EVENT WAIT ", dumpfile); - - fputs ("event-variable=", dumpfile); - if (c->expr1 != NULL) - show_expr (c->expr1); - if (c->expr4 != NULL) - { - fputs (" until_count=", dumpfile); - show_expr (c->expr4); - } - if (c->expr2 != NULL) - { - fputs (" stat=", dumpfile); - show_expr (c->expr2); - } - if (c->expr3 != NULL) - { - fputs (" errmsg=", dumpfile); - show_expr (c->expr3); - } - break; - - case EXEC_LOCK: - case EXEC_UNLOCK: - if (c->op == EXEC_LOCK) - fputs ("LOCK ", dumpfile); - else - fputs ("UNLOCK ", dumpfile); - - fputs ("lock-variable=", dumpfile); - if (c->expr1 != NULL) - show_expr (c->expr1); - if (c->expr4 != NULL) - { - fputs (" acquired_lock=", dumpfile); - show_expr (c->expr4); - } - if (c->expr2 != NULL) - { - fputs (" stat=", dumpfile); - show_expr (c->expr2); - } - if (c->expr3 != NULL) - { - fputs (" errmsg=", dumpfile); - show_expr (c->expr3); - } - break; - - case EXEC_ARITHMETIC_IF: - fputs ("IF ", dumpfile); - show_expr (c->expr1); - fprintf (dumpfile, " %d, %d, %d", - c->label1->value, c->label2->value, c->label3->value); - break; - - case EXEC_IF: - d = c->block; - fputs ("IF ", dumpfile); - show_expr (d->expr1); - - ++show_level; - show_code (level + 1, d->next); - --show_level; - - d = d->block; - for (; d; d = d->block) - { - fputs("\n", dumpfile); - code_indent (level, 0); - if (d->expr1 == NULL) - fputs ("ELSE", dumpfile); - else - { - fputs ("ELSE IF ", dumpfile); - show_expr (d->expr1); - } - - ++show_level; - show_code (level + 1, d->next); - --show_level; - } - - if (c->label1) - code_indent (level, c->label1); - else - show_indent (); - - fputs ("ENDIF", dumpfile); - break; - - case EXEC_BLOCK: - { - const char* blocktype; - gfc_namespace *saved_ns; - gfc_association_list *alist; - - if (c->ext.block.assoc) - blocktype = "ASSOCIATE"; - else - blocktype = "BLOCK"; - show_indent (); - fprintf (dumpfile, "%s ", blocktype); - for (alist = c->ext.block.assoc; alist; alist = alist->next) - { - fprintf (dumpfile, " %s = ", alist->name); - show_expr (alist->target); - } - - ++show_level; - ns = c->ext.block.ns; - saved_ns = gfc_current_ns; - gfc_current_ns = ns; - gfc_traverse_symtree (ns->sym_root, show_symtree); - gfc_current_ns = saved_ns; - show_code (show_level, ns->code); - --show_level; - show_indent (); - fprintf (dumpfile, "END %s ", blocktype); - break; - } - - case EXEC_END_BLOCK: - /* Only come here when there is a label on an - END ASSOCIATE construct. */ - break; - - case EXEC_SELECT: - case EXEC_SELECT_TYPE: - case EXEC_SELECT_RANK: - d = c->block; - fputc ('\n', dumpfile); - code_indent (level, 0); - if (c->op == EXEC_SELECT_RANK) - fputs ("SELECT RANK ", dumpfile); - else if (c->op == EXEC_SELECT_TYPE) - fputs ("SELECT TYPE ", dumpfile); - else - fputs ("SELECT CASE ", dumpfile); - show_expr (c->expr1); - - for (; d; d = d->block) - { - fputc ('\n', dumpfile); - code_indent (level, 0); - fputs ("CASE ", dumpfile); - for (cp = d->ext.block.case_list; cp; cp = cp->next) - { - fputc ('(', dumpfile); - show_expr (cp->low); - fputc (' ', dumpfile); - show_expr (cp->high); - fputc (')', dumpfile); - fputc (' ', dumpfile); - } - - show_code (level + 1, d->next); - fputc ('\n', dumpfile); - } - - code_indent (level, c->label1); - fputs ("END SELECT", dumpfile); - break; - - case EXEC_WHERE: - fputs ("WHERE ", dumpfile); - - d = c->block; - show_expr (d->expr1); - fputc ('\n', dumpfile); - - show_code (level + 1, d->next); - - for (d = d->block; d; d = d->block) - { - code_indent (level, 0); - fputs ("ELSE WHERE ", dumpfile); - show_expr (d->expr1); - fputc ('\n', dumpfile); - show_code (level + 1, d->next); - } - - code_indent (level, 0); - fputs ("END WHERE", dumpfile); - break; - - - case EXEC_FORALL: - fputs ("FORALL ", dumpfile); - for (fa = c->ext.forall_iterator; fa; fa = fa->next) - { - show_expr (fa->var); - fputc (' ', dumpfile); - show_expr (fa->start); - fputc (':', dumpfile); - show_expr (fa->end); - fputc (':', dumpfile); - show_expr (fa->stride); - - if (fa->next != NULL) - fputc (',', dumpfile); - } - - if (c->expr1 != NULL) - { - fputc (',', dumpfile); - show_expr (c->expr1); - } - fputc ('\n', dumpfile); - - show_code (level + 1, c->block->next); - - code_indent (level, 0); - fputs ("END FORALL", dumpfile); - break; - - case EXEC_CRITICAL: - fputs ("CRITICAL\n", dumpfile); - show_code (level + 1, c->block->next); - code_indent (level, 0); - fputs ("END CRITICAL", dumpfile); - break; - - case EXEC_DO: - fputs ("DO ", dumpfile); - if (c->label1) - fprintf (dumpfile, " %-5d ", c->label1->value); - - show_expr (c->ext.iterator->var); - fputc ('=', dumpfile); - show_expr (c->ext.iterator->start); - fputc (' ', dumpfile); - show_expr (c->ext.iterator->end); - fputc (' ', dumpfile); - show_expr (c->ext.iterator->step); - - ++show_level; - show_code (level + 1, c->block->next); - --show_level; - - if (c->label1) - break; - - show_indent (); - fputs ("END DO", dumpfile); - break; - - case EXEC_DO_CONCURRENT: - fputs ("DO CONCURRENT ", dumpfile); - for (fa = c->ext.forall_iterator; fa; fa = fa->next) - { - show_expr (fa->var); - fputc (' ', dumpfile); - show_expr (fa->start); - fputc (':', dumpfile); - show_expr (fa->end); - fputc (':', dumpfile); - show_expr (fa->stride); - - if (fa->next != NULL) - fputc (',', dumpfile); - } - show_expr (c->expr1); - ++show_level; - - show_code (level + 1, c->block->next); - --show_level; - code_indent (level, c->label1); - show_indent (); - fputs ("END DO", dumpfile); - break; - - case EXEC_DO_WHILE: - fputs ("DO WHILE ", dumpfile); - show_expr (c->expr1); - fputc ('\n', dumpfile); - - show_code (level + 1, c->block->next); - - code_indent (level, c->label1); - fputs ("END DO", dumpfile); - break; - - case EXEC_CYCLE: - fputs ("CYCLE", dumpfile); - if (c->symtree) - fprintf (dumpfile, " %s", c->symtree->n.sym->name); - break; - - case EXEC_EXIT: - fputs ("EXIT", dumpfile); - if (c->symtree) - fprintf (dumpfile, " %s", c->symtree->n.sym->name); - break; - - case EXEC_ALLOCATE: - fputs ("ALLOCATE ", dumpfile); - if (c->expr1) - { - fputs (" STAT=", dumpfile); - show_expr (c->expr1); - } - - if (c->expr2) - { - fputs (" ERRMSG=", dumpfile); - show_expr (c->expr2); - } - - if (c->expr3) - { - if (c->expr3->mold) - fputs (" MOLD=", dumpfile); - else - fputs (" SOURCE=", dumpfile); - show_expr (c->expr3); - } - - for (a = c->ext.alloc.list; a; a = a->next) - { - fputc (' ', dumpfile); - show_expr (a->expr); - } - - break; - - case EXEC_DEALLOCATE: - fputs ("DEALLOCATE ", dumpfile); - if (c->expr1) - { - fputs (" STAT=", dumpfile); - show_expr (c->expr1); - } - - if (c->expr2) - { - fputs (" ERRMSG=", dumpfile); - show_expr (c->expr2); - } - - for (a = c->ext.alloc.list; a; a = a->next) - { - fputc (' ', dumpfile); - show_expr (a->expr); - } - - break; - - case EXEC_OPEN: - fputs ("OPEN", dumpfile); - open = c->ext.open; - - if (open->unit) - { - fputs (" UNIT=", dumpfile); - show_expr (open->unit); - } - if (open->iomsg) - { - fputs (" IOMSG=", dumpfile); - show_expr (open->iomsg); - } - if (open->iostat) - { - fputs (" IOSTAT=", dumpfile); - show_expr (open->iostat); - } - if (open->file) - { - fputs (" FILE=", dumpfile); - show_expr (open->file); - } - if (open->status) - { - fputs (" STATUS=", dumpfile); - show_expr (open->status); - } - if (open->access) - { - fputs (" ACCESS=", dumpfile); - show_expr (open->access); - } - if (open->form) - { - fputs (" FORM=", dumpfile); - show_expr (open->form); - } - if (open->recl) - { - fputs (" RECL=", dumpfile); - show_expr (open->recl); - } - if (open->blank) - { - fputs (" BLANK=", dumpfile); - show_expr (open->blank); - } - if (open->position) - { - fputs (" POSITION=", dumpfile); - show_expr (open->position); - } - if (open->action) - { - fputs (" ACTION=", dumpfile); - show_expr (open->action); - } - if (open->delim) - { - fputs (" DELIM=", dumpfile); - show_expr (open->delim); - } - if (open->pad) - { - fputs (" PAD=", dumpfile); - show_expr (open->pad); - } - if (open->decimal) - { - fputs (" DECIMAL=", dumpfile); - show_expr (open->decimal); - } - if (open->encoding) - { - fputs (" ENCODING=", dumpfile); - show_expr (open->encoding); - } - if (open->round) - { - fputs (" ROUND=", dumpfile); - show_expr (open->round); - } - if (open->sign) - { - fputs (" SIGN=", dumpfile); - show_expr (open->sign); - } - if (open->convert) - { - fputs (" CONVERT=", dumpfile); - show_expr (open->convert); - } - if (open->asynchronous) - { - fputs (" ASYNCHRONOUS=", dumpfile); - show_expr (open->asynchronous); - } - if (open->err != NULL) - fprintf (dumpfile, " ERR=%d", open->err->value); - - break; - - case EXEC_CLOSE: - fputs ("CLOSE", dumpfile); - close = c->ext.close; - - if (close->unit) - { - fputs (" UNIT=", dumpfile); - show_expr (close->unit); - } - if (close->iomsg) - { - fputs (" IOMSG=", dumpfile); - show_expr (close->iomsg); - } - if (close->iostat) - { - fputs (" IOSTAT=", dumpfile); - show_expr (close->iostat); - } - if (close->status) - { - fputs (" STATUS=", dumpfile); - show_expr (close->status); - } - if (close->err != NULL) - fprintf (dumpfile, " ERR=%d", close->err->value); - break; - - case EXEC_BACKSPACE: - fputs ("BACKSPACE", dumpfile); - goto show_filepos; - - case EXEC_ENDFILE: - fputs ("ENDFILE", dumpfile); - goto show_filepos; - - case EXEC_REWIND: - fputs ("REWIND", dumpfile); - goto show_filepos; - - case EXEC_FLUSH: - fputs ("FLUSH", dumpfile); - - show_filepos: - fp = c->ext.filepos; - - if (fp->unit) - { - fputs (" UNIT=", dumpfile); - show_expr (fp->unit); - } - if (fp->iomsg) - { - fputs (" IOMSG=", dumpfile); - show_expr (fp->iomsg); - } - if (fp->iostat) - { - fputs (" IOSTAT=", dumpfile); - show_expr (fp->iostat); - } - if (fp->err != NULL) - fprintf (dumpfile, " ERR=%d", fp->err->value); - break; - - case EXEC_INQUIRE: - fputs ("INQUIRE", dumpfile); - i = c->ext.inquire; - - if (i->unit) - { - fputs (" UNIT=", dumpfile); - show_expr (i->unit); - } - if (i->file) - { - fputs (" FILE=", dumpfile); - show_expr (i->file); - } - - if (i->iomsg) - { - fputs (" IOMSG=", dumpfile); - show_expr (i->iomsg); - } - if (i->iostat) - { - fputs (" IOSTAT=", dumpfile); - show_expr (i->iostat); - } - if (i->exist) - { - fputs (" EXIST=", dumpfile); - show_expr (i->exist); - } - if (i->opened) - { - fputs (" OPENED=", dumpfile); - show_expr (i->opened); - } - if (i->number) - { - fputs (" NUMBER=", dumpfile); - show_expr (i->number); - } - if (i->named) - { - fputs (" NAMED=", dumpfile); - show_expr (i->named); - } - if (i->name) - { - fputs (" NAME=", dumpfile); - show_expr (i->name); - } - if (i->access) - { - fputs (" ACCESS=", dumpfile); - show_expr (i->access); - } - if (i->sequential) - { - fputs (" SEQUENTIAL=", dumpfile); - show_expr (i->sequential); - } - - if (i->direct) - { - fputs (" DIRECT=", dumpfile); - show_expr (i->direct); - } - if (i->form) - { - fputs (" FORM=", dumpfile); - show_expr (i->form); - } - if (i->formatted) - { - fputs (" FORMATTED", dumpfile); - show_expr (i->formatted); - } - if (i->unformatted) - { - fputs (" UNFORMATTED=", dumpfile); - show_expr (i->unformatted); - } - if (i->recl) - { - fputs (" RECL=", dumpfile); - show_expr (i->recl); - } - if (i->nextrec) - { - fputs (" NEXTREC=", dumpfile); - show_expr (i->nextrec); - } - if (i->blank) - { - fputs (" BLANK=", dumpfile); - show_expr (i->blank); - } - if (i->position) - { - fputs (" POSITION=", dumpfile); - show_expr (i->position); - } - if (i->action) - { - fputs (" ACTION=", dumpfile); - show_expr (i->action); - } - if (i->read) - { - fputs (" READ=", dumpfile); - show_expr (i->read); - } - if (i->write) - { - fputs (" WRITE=", dumpfile); - show_expr (i->write); - } - if (i->readwrite) - { - fputs (" READWRITE=", dumpfile); - show_expr (i->readwrite); - } - if (i->delim) - { - fputs (" DELIM=", dumpfile); - show_expr (i->delim); - } - if (i->pad) - { - fputs (" PAD=", dumpfile); - show_expr (i->pad); - } - if (i->convert) - { - fputs (" CONVERT=", dumpfile); - show_expr (i->convert); - } - if (i->asynchronous) - { - fputs (" ASYNCHRONOUS=", dumpfile); - show_expr (i->asynchronous); - } - if (i->decimal) - { - fputs (" DECIMAL=", dumpfile); - show_expr (i->decimal); - } - if (i->encoding) - { - fputs (" ENCODING=", dumpfile); - show_expr (i->encoding); - } - if (i->pending) - { - fputs (" PENDING=", dumpfile); - show_expr (i->pending); - } - if (i->round) - { - fputs (" ROUND=", dumpfile); - show_expr (i->round); - } - if (i->sign) - { - fputs (" SIGN=", dumpfile); - show_expr (i->sign); - } - if (i->size) - { - fputs (" SIZE=", dumpfile); - show_expr (i->size); - } - if (i->id) - { - fputs (" ID=", dumpfile); - show_expr (i->id); - } - - if (i->err != NULL) - fprintf (dumpfile, " ERR=%d", i->err->value); - break; - - case EXEC_IOLENGTH: - fputs ("IOLENGTH ", dumpfile); - show_expr (c->expr1); - goto show_dt_code; - break; - - case EXEC_READ: - fputs ("READ", dumpfile); - goto show_dt; - - case EXEC_WRITE: - fputs ("WRITE", dumpfile); - - show_dt: - dt = c->ext.dt; - if (dt->io_unit) - { - fputs (" UNIT=", dumpfile); - show_expr (dt->io_unit); - } - - if (dt->format_expr) - { - fputs (" FMT=", dumpfile); - show_expr (dt->format_expr); - } - - if (dt->format_label != NULL) - fprintf (dumpfile, " FMT=%d", dt->format_label->value); - if (dt->namelist) - fprintf (dumpfile, " NML=%s", dt->namelist->name); - - if (dt->iomsg) - { - fputs (" IOMSG=", dumpfile); - show_expr (dt->iomsg); - } - if (dt->iostat) - { - fputs (" IOSTAT=", dumpfile); - show_expr (dt->iostat); - } - if (dt->size) - { - fputs (" SIZE=", dumpfile); - show_expr (dt->size); - } - if (dt->rec) - { - fputs (" REC=", dumpfile); - show_expr (dt->rec); - } - if (dt->advance) - { - fputs (" ADVANCE=", dumpfile); - show_expr (dt->advance); - } - if (dt->id) - { - fputs (" ID=", dumpfile); - show_expr (dt->id); - } - if (dt->pos) - { - fputs (" POS=", dumpfile); - show_expr (dt->pos); - } - if (dt->asynchronous) - { - fputs (" ASYNCHRONOUS=", dumpfile); - show_expr (dt->asynchronous); - } - if (dt->blank) - { - fputs (" BLANK=", dumpfile); - show_expr (dt->blank); - } - if (dt->decimal) - { - fputs (" DECIMAL=", dumpfile); - show_expr (dt->decimal); - } - if (dt->delim) - { - fputs (" DELIM=", dumpfile); - show_expr (dt->delim); - } - if (dt->pad) - { - fputs (" PAD=", dumpfile); - show_expr (dt->pad); - } - if (dt->round) - { - fputs (" ROUND=", dumpfile); - show_expr (dt->round); - } - if (dt->sign) - { - fputs (" SIGN=", dumpfile); - show_expr (dt->sign); - } - - show_dt_code: - for (c = c->block->next; c; c = c->next) - show_code_node (level + (c->next != NULL), c); - return; - - case EXEC_TRANSFER: - fputs ("TRANSFER ", dumpfile); - show_expr (c->expr1); - break; - - case EXEC_DT_END: - fputs ("DT_END", dumpfile); - dt = c->ext.dt; - - if (dt->err != NULL) - fprintf (dumpfile, " ERR=%d", dt->err->value); - if (dt->end != NULL) - fprintf (dumpfile, " END=%d", dt->end->value); - if (dt->eor != NULL) - fprintf (dumpfile, " EOR=%d", dt->eor->value); - break; - - case EXEC_WAIT: - fputs ("WAIT", dumpfile); - - if (c->ext.wait != NULL) - { - gfc_wait *wait = c->ext.wait; - if (wait->unit) - { - fputs (" UNIT=", dumpfile); - show_expr (wait->unit); - } - if (wait->iostat) - { - fputs (" IOSTAT=", dumpfile); - show_expr (wait->iostat); - } - if (wait->iomsg) - { - fputs (" IOMSG=", dumpfile); - show_expr (wait->iomsg); - } - if (wait->id) - { - fputs (" ID=", dumpfile); - show_expr (wait->id); - } - if (wait->err) - fprintf (dumpfile, " ERR=%d", wait->err->value); - if (wait->end) - fprintf (dumpfile, " END=%d", wait->end->value); - if (wait->eor) - fprintf (dumpfile, " EOR=%d", wait->eor->value); - } - break; - - case EXEC_OACC_PARALLEL_LOOP: - case EXEC_OACC_PARALLEL: - case EXEC_OACC_KERNELS_LOOP: - case EXEC_OACC_KERNELS: - case EXEC_OACC_SERIAL_LOOP: - case EXEC_OACC_SERIAL: - case EXEC_OACC_DATA: - case EXEC_OACC_HOST_DATA: - case EXEC_OACC_LOOP: - case EXEC_OACC_UPDATE: - case EXEC_OACC_WAIT: - case EXEC_OACC_CACHE: - case EXEC_OACC_ENTER_DATA: - case EXEC_OACC_EXIT_DATA: - case EXEC_OMP_ATOMIC: - case EXEC_OMP_CANCEL: - case EXEC_OMP_CANCELLATION_POINT: - case EXEC_OMP_BARRIER: - case EXEC_OMP_CRITICAL: - case EXEC_OMP_DEPOBJ: - case EXEC_OMP_DISTRIBUTE: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_DISTRIBUTE_SIMD: - case EXEC_OMP_DO: - case EXEC_OMP_DO_SIMD: - case EXEC_OMP_ERROR: - case EXEC_OMP_FLUSH: - case EXEC_OMP_LOOP: - case EXEC_OMP_MASKED: - case EXEC_OMP_MASKED_TASKLOOP: - case EXEC_OMP_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_MASTER: - case EXEC_OMP_MASTER_TASKLOOP: - case EXEC_OMP_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_ORDERED: - case EXEC_OMP_PARALLEL: - case EXEC_OMP_PARALLEL_DO: - case EXEC_OMP_PARALLEL_DO_SIMD: - case EXEC_OMP_PARALLEL_LOOP: - case EXEC_OMP_PARALLEL_MASKED: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_MASTER: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_SECTIONS: - case EXEC_OMP_PARALLEL_WORKSHARE: - case EXEC_OMP_SCAN: - case EXEC_OMP_SCOPE: - case EXEC_OMP_SECTIONS: - case EXEC_OMP_SIMD: - case EXEC_OMP_SINGLE: - case EXEC_OMP_TARGET: - case EXEC_OMP_TARGET_DATA: - case EXEC_OMP_TARGET_ENTER_DATA: - case EXEC_OMP_TARGET_EXIT_DATA: - case EXEC_OMP_TARGET_PARALLEL: - case EXEC_OMP_TARGET_PARALLEL_DO: - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_PARALLEL_LOOP: - case EXEC_OMP_TARGET_SIMD: - case EXEC_OMP_TARGET_TEAMS: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TARGET_TEAMS_LOOP: - case EXEC_OMP_TARGET_UPDATE: - case EXEC_OMP_TASK: - case EXEC_OMP_TASKGROUP: - case EXEC_OMP_TASKLOOP: - case EXEC_OMP_TASKLOOP_SIMD: - case EXEC_OMP_TASKWAIT: - case EXEC_OMP_TASKYIELD: - case EXEC_OMP_TEAMS: - case EXEC_OMP_TEAMS_DISTRIBUTE: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TEAMS_LOOP: - case EXEC_OMP_WORKSHARE: - show_omp_node (level, c); - break; - - default: - gfc_internal_error ("show_code_node(): Bad statement code"); - } -} - - -/* Show an equivalence chain. */ - -static void -show_equiv (gfc_equiv *eq) -{ - show_indent (); - fputs ("Equivalence: ", dumpfile); - while (eq) - { - show_expr (eq->expr); - eq = eq->eq; - if (eq) - fputs (", ", dumpfile); - } -} - - -/* Show a freakin' whole namespace. */ - -static void -show_namespace (gfc_namespace *ns) -{ - gfc_interface *intr; - gfc_namespace *save; - int op; - gfc_equiv *eq; - int i; - - gcc_assert (ns); - save = gfc_current_ns; - - show_indent (); - fputs ("Namespace:", dumpfile); - - i = 0; - do - { - int l = i; - while (i < GFC_LETTERS - 1 - && gfc_compare_types (&ns->default_type[i+1], - &ns->default_type[l])) - i++; - - if (i > l) - fprintf (dumpfile, " %c-%c: ", l+'A', i+'A'); - else - fprintf (dumpfile, " %c: ", l+'A'); - - show_typespec(&ns->default_type[l]); - i++; - } while (i < GFC_LETTERS); - - if (ns->proc_name != NULL) - { - show_indent (); - fprintf (dumpfile, "procedure name = %s", ns->proc_name->name); - } - - ++show_level; - gfc_current_ns = ns; - gfc_traverse_symtree (ns->common_root, show_common); - - gfc_traverse_symtree (ns->sym_root, show_symtree); - - for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++) - { - /* User operator interfaces */ - intr = ns->op[op]; - if (intr == NULL) - continue; - - show_indent (); - fprintf (dumpfile, "Operator interfaces for %s:", - gfc_op2string ((gfc_intrinsic_op) op)); - - for (; intr; intr = intr->next) - fprintf (dumpfile, " %s", intr->sym->name); - } - - if (ns->uop_root != NULL) - { - show_indent (); - fputs ("User operators:\n", dumpfile); - gfc_traverse_user_op (ns, show_uop); - } - - for (eq = ns->equiv; eq; eq = eq->next) - show_equiv (eq); - - if (ns->oacc_declare) - { - struct gfc_oacc_declare *decl; - /* Dump !$ACC DECLARE clauses. */ - for (decl = ns->oacc_declare; decl; decl = decl->next) - { - show_indent (); - fprintf (dumpfile, "!$ACC DECLARE"); - show_omp_clauses (decl->clauses); - } - } - - fputc ('\n', dumpfile); - show_indent (); - fputs ("code:", dumpfile); - show_code (show_level, ns->code); - --show_level; - - for (ns = ns->contained; ns; ns = ns->sibling) - { - fputs ("\nCONTAINS\n", dumpfile); - ++show_level; - show_namespace (ns); - --show_level; - } - - fputc ('\n', dumpfile); - gfc_current_ns = save; -} - - -/* Main function for dumping a parse tree. */ - -void -gfc_dump_parse_tree (gfc_namespace *ns, FILE *file) -{ - dumpfile = file; - show_namespace (ns); -} - -/* This part writes BIND(C) definition for use in external C programs. */ - -static void write_interop_decl (gfc_symbol *); -static void write_proc (gfc_symbol *, bool); - -void -gfc_dump_c_prototypes (gfc_namespace *ns, FILE *file) -{ - int error_count; - gfc_get_errors (NULL, &error_count); - if (error_count != 0) - return; - dumpfile = file; - gfc_traverse_ns (ns, write_interop_decl); -} - -/* Loop over all global symbols, writing out their declrations. */ - -void -gfc_dump_external_c_prototypes (FILE * file) -{ - dumpfile = file; - fprintf (dumpfile, - _("/* Prototypes for external procedures generated from %s\n" - " by GNU Fortran %s%s.\n\n" - " Use of this interface is discouraged, consider using the\n" - " BIND(C) feature of standard Fortran instead. */\n\n"), - gfc_source_file, pkgversion_string, version_string); - - for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; - gfc_current_ns = gfc_current_ns->sibling) - { - gfc_symbol *sym = gfc_current_ns->proc_name; - - if (sym == NULL || sym->attr.flavor != FL_PROCEDURE - || sym->attr.is_bind_c) - continue; - - write_proc (sym, false); - } - return; -} - -enum type_return { T_OK=0, T_WARN, T_ERROR }; - -/* Return the name of the type for later output. Both function pointers and - void pointers will be mapped to void *. */ - -static enum type_return -get_c_type_name (gfc_typespec *ts, gfc_array_spec *as, const char **pre, - const char **type_name, bool *asterisk, const char **post, - bool func_ret) -{ - static char post_buffer[40]; - enum type_return ret; - ret = T_ERROR; - - *pre = " "; - *asterisk = false; - *post = ""; - *type_name = "<error>"; - if (ts->type == BT_REAL || ts->type == BT_INTEGER || ts->type == BT_COMPLEX) - { - if (ts->is_c_interop && ts->interop_kind) - ret = T_OK; - else - ret = T_WARN; - - for (int i = 0; i < ISOCBINDING_NUMBER; i++) - { - if (c_interop_kinds_table[i].f90_type == ts->type - && c_interop_kinds_table[i].value == ts->kind) - { - *type_name = c_interop_kinds_table[i].name + 2; - if (strcmp (*type_name, "signed_char") == 0) - *type_name = "signed char"; - else if (strcmp (*type_name, "size_t") == 0) - *type_name = "ssize_t"; - else if (strcmp (*type_name, "float_complex") == 0) - *type_name = "__GFORTRAN_FLOAT_COMPLEX"; - else if (strcmp (*type_name, "double_complex") == 0) - *type_name = "__GFORTRAN_DOUBLE_COMPLEX"; - else if (strcmp (*type_name, "long_double_complex") == 0) - *type_name = "__GFORTRAN_LONG_DOUBLE_COMPLEX"; - - break; - } - } - } - else if (ts->type == BT_LOGICAL) - { - if (ts->is_c_interop && ts->interop_kind) - { - *type_name = "_Bool"; - ret = T_OK; - } - else - { - /* Let's select an appropriate int, with a warning. */ - for (int i = 0; i < ISOCBINDING_NUMBER; i++) - { - if (c_interop_kinds_table[i].f90_type == BT_INTEGER - && c_interop_kinds_table[i].value == ts->kind) - { - *type_name = c_interop_kinds_table[i].name + 2; - ret = T_WARN; - } - } - } - } - else if (ts->type == BT_CHARACTER) - { - if (ts->is_c_interop) - { - *type_name = "char"; - ret = T_OK; - } - else - { - if (ts->kind == gfc_default_character_kind) - *type_name = "char"; - else - /* Let's select an appropriate int. */ - for (int i = 0; i < ISOCBINDING_NUMBER; i++) - { - if (c_interop_kinds_table[i].f90_type == BT_INTEGER - && c_interop_kinds_table[i].value == ts->kind) - { - *type_name = c_interop_kinds_table[i].name + 2; - break; - } - } - ret = T_WARN; - - } - } - else if (ts->type == BT_DERIVED) - { - if (ts->u.derived->from_intmod == INTMOD_ISO_C_BINDING) - { - if (strcmp (ts->u.derived->name, "c_ptr") == 0) - *type_name = "void"; - else if (strcmp (ts->u.derived->name, "c_funptr") == 0) - { - *type_name = "int "; - if (func_ret) - { - *pre = "("; - *post = "())"; - } - else - { - *pre = "("; - *post = ")()"; - } - } - *asterisk = true; - ret = T_OK; - } - else - *type_name = ts->u.derived->name; - - ret = T_OK; - } - - if (ret != T_ERROR && as) - { - mpz_t sz; - bool size_ok; - size_ok = spec_size (as, &sz); - gcc_assert (size_ok == true); - gmp_snprintf (post_buffer, sizeof(post_buffer), "[%Zd]", sz); - *post = post_buffer; - mpz_clear (sz); - } - return ret; -} - -/* Write out a declaration. */ -static void -write_decl (gfc_typespec *ts, gfc_array_spec *as, const char *sym_name, - bool func_ret, locus *where, bool bind_c) -{ - const char *pre, *type_name, *post; - bool asterisk; - enum type_return rok; - - rok = get_c_type_name (ts, as, &pre, &type_name, &asterisk, &post, func_ret); - if (rok == T_ERROR) - { - gfc_error_now ("Cannot convert %qs to interoperable type at %L", - gfc_typename (ts), where); - fprintf (dumpfile, "/* Cannot convert '%s' to interoperable type */", - gfc_typename (ts)); - return; - } - fputs (type_name, dumpfile); - fputs (pre, dumpfile); - if (asterisk) - fputs ("*", dumpfile); - - fputs (sym_name, dumpfile); - fputs (post, dumpfile); - - if (rok == T_WARN && bind_c) - fprintf (dumpfile," /* WARNING: Converting '%s' to interoperable type */", - gfc_typename (ts)); -} - -/* Write out an interoperable type. It will be written as a typedef - for a struct. */ - -static void -write_type (gfc_symbol *sym) -{ - gfc_component *c; - - fprintf (dumpfile, "typedef struct %s {\n", sym->name); - for (c = sym->components; c; c = c->next) - { - fputs (" ", dumpfile); - write_decl (&(c->ts), c->as, c->name, false, &sym->declared_at, true); - fputs (";\n", dumpfile); - } - - fprintf (dumpfile, "} %s;\n", sym->name); -} - -/* Write out a variable. */ - -static void -write_variable (gfc_symbol *sym) -{ - const char *sym_name; - - gcc_assert (sym->attr.flavor == FL_VARIABLE); - - if (sym->binding_label) - sym_name = sym->binding_label; - else - sym_name = sym->name; - - fputs ("extern ", dumpfile); - write_decl (&(sym->ts), sym->as, sym_name, false, &sym->declared_at, true); - fputs (";\n", dumpfile); -} - - -/* Write out a procedure, including its arguments. */ -static void -write_proc (gfc_symbol *sym, bool bind_c) -{ - const char *pre, *type_name, *post; - bool asterisk; - enum type_return rok; - gfc_formal_arglist *f; - const char *sym_name; - const char *intent_in; - bool external_character; - - external_character = sym->ts.type == BT_CHARACTER && !bind_c; - - if (sym->binding_label) - sym_name = sym->binding_label; - else - sym_name = sym->name; - - if (sym->ts.type == BT_UNKNOWN || external_character) - { - fprintf (dumpfile, "void "); - fputs (sym_name, dumpfile); - } - else - write_decl (&(sym->ts), sym->as, sym_name, true, &sym->declared_at, bind_c); - - if (!bind_c) - fputs ("_", dumpfile); - - fputs (" (", dumpfile); - if (external_character) - { - fprintf (dumpfile, "char *result_%s, size_t result_%s_len", - sym_name, sym_name); - if (sym->formal) - fputs (", ", dumpfile); - } - - for (f = sym->formal; f; f = f->next) - { - gfc_symbol *s; - s = f->sym; - rok = get_c_type_name (&(s->ts), NULL, &pre, &type_name, &asterisk, - &post, false); - if (rok == T_ERROR) - { - gfc_error_now ("Cannot convert %qs to interoperable type at %L", - gfc_typename (&s->ts), &s->declared_at); - fprintf (dumpfile, "/* Cannot convert '%s' to interoperable type */", - gfc_typename (&s->ts)); - return; - } - - if (!s->attr.value) - asterisk = true; - - if (s->attr.intent == INTENT_IN && !s->attr.value) - intent_in = "const "; - else - intent_in = ""; - - fputs (intent_in, dumpfile); - fputs (type_name, dumpfile); - fputs (pre, dumpfile); - if (asterisk) - fputs ("*", dumpfile); - - fputs (s->name, dumpfile); - fputs (post, dumpfile); - if (bind_c && rok == T_WARN) - fputs(" /* WARNING: non-interoperable KIND */ ", dumpfile); - - if (f->next) - fputs(", ", dumpfile); - } - if (!bind_c) - for (f = sym->formal; f; f = f->next) - if (f->sym->ts.type == BT_CHARACTER) - fprintf (dumpfile, ", size_t %s_len", f->sym->name); - - fputs (");\n", dumpfile); -} - - -/* Write a C-interoperable declaration as a C prototype or extern - declaration. */ - -static void -write_interop_decl (gfc_symbol *sym) -{ - /* Only dump bind(c) entities. */ - if (!sym->attr.is_bind_c) - return; - - /* Don't dump our iso c module. */ - if (sym->from_intmod == INTMOD_ISO_C_BINDING) - return; - - if (sym->attr.flavor == FL_VARIABLE) - write_variable (sym); - else if (sym->attr.flavor == FL_DERIVED) - write_type (sym); - else if (sym->attr.flavor == FL_PROCEDURE) - write_proc (sym, true); -} - -/* This section deals with dumping the global symbol tree. */ - -/* Callback function for printing out the contents of the tree. */ - -static void -show_global_symbol (gfc_gsymbol *gsym, void *f_data) -{ - FILE *out; - out = (FILE *) f_data; - - if (gsym->name) - fprintf (out, "name=%s", gsym->name); - - if (gsym->sym_name) - fprintf (out, ", sym_name=%s", gsym->sym_name); - - if (gsym->mod_name) - fprintf (out, ", mod_name=%s", gsym->mod_name); - - if (gsym->binding_label) - fprintf (out, ", binding_label=%s", gsym->binding_label); - - fputc ('\n', out); -} - -/* Show all global symbols. */ - -void -gfc_dump_global_symbols (FILE *f) -{ - if (gfc_gsym_root == NULL) - fprintf (f, "empty\n"); - else - gfc_traverse_gsymbol (gfc_gsym_root, show_global_symbol, (void *) f); -} - -/* Show an array ref. */ - -void debug (gfc_array_ref *ar) -{ - FILE *tmp = dumpfile; - dumpfile = stderr; - show_array_ref (ar); - fputc ('\n', dumpfile); - dumpfile = tmp; -} |