diff options
Diffstat (limited to 'gcc/fortran/module.c')
| -rw-r--r-- | gcc/fortran/module.c | 164 |
1 files changed, 84 insertions, 80 deletions
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 6d3860ef82..4d6afa55d3 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -1,6 +1,6 @@ /* Handle modules, which amounts to loading and saving symbols and their attendant structures. - Copyright (C) 2000-2016 Free Software Foundation, Inc. + Copyright (C) 2000-2017 Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of GCC. @@ -193,10 +193,6 @@ static const char *module_name; /* The name of the .smod file that the submodule will write to. */ static const char *submodule_name; -/* Suppress the output of a .smod file by module, if no module - procedures have been seen. */ -static bool no_module_procedures; - static gfc_use_list *module_list; /* If we're reading an intrinsic module, this is its ID. */ @@ -428,7 +424,7 @@ gfc_dt_lower_string (const char *name) if (name[0] != (char) TOLOWER ((unsigned char) name[0])) return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0]), &name[1]); - return gfc_get_string (name); + return gfc_get_string ("%s", name); } @@ -443,7 +439,7 @@ gfc_dt_upper_string (const char *name) if (name[0] != (char) TOUPPER ((unsigned char) name[0])) return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0]), &name[1]); - return gfc_get_string (name); + return gfc_get_string ("%s", name); } /* Call here during module reading when we know what pointer to @@ -594,7 +590,7 @@ gfc_match_use (void) return m; } - use_list->module_name = gfc_get_string (name); + use_list->module_name = gfc_get_string ("%s", name); if (gfc_match_eos () == MATCH_YES) goto done; @@ -680,7 +676,7 @@ gfc_match_use (void) || strcmp (new_use->local_name, use_list->module_name) == 0) { gfc_error ("The name %qs at %C has already been used as " - "an external module name.", use_list->module_name); + "an external module name", use_list->module_name); goto cleanup; } break; @@ -740,10 +736,18 @@ gfc_match_submodule (void) match m; char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_use_list *use_list; + bool seen_colon = false; if (!gfc_notify_std (GFC_STD_F2008, "SUBMODULE declaration at %C")) return MATCH_ERROR; + if (gfc_current_state () != COMP_NONE) + { + gfc_error ("SUBMODULE declaration at %C cannot appear within " + "another scoping unit"); + return MATCH_ERROR; + } + gfc_new_block = NULL; gcc_assert (module_list == NULL); @@ -772,16 +776,19 @@ gfc_match_submodule (void) } else { - module_list = use_list; - use_list->module_name = gfc_get_string (name); + module_list = use_list; + use_list->module_name = gfc_get_string ("%s", name); use_list->submodule_name = use_list->module_name; } if (gfc_match_char (')') == MATCH_YES) break; - if (gfc_match_char (':') != MATCH_YES) + if (gfc_match_char (':') != MATCH_YES + || seen_colon) goto syntax; + + seen_colon = true; } m = gfc_match (" %s%t", &gfc_new_block); @@ -959,9 +966,9 @@ find_true_name (const char *name, const char *module) gfc_symbol sym; int c; - t.name = gfc_get_string (name); + t.name = gfc_get_string ("%s", name); if (module != NULL) - sym.module = gfc_get_string (module); + sym.module = gfc_get_string ("%s", module); else sym.module = NULL; t.sym = &sym; @@ -1951,7 +1958,8 @@ mio_pool_string (const char **stringp) else { require_atom (ATOM_STRING); - *stringp = atom_string[0] == '\0' ? NULL : gfc_get_string (atom_string); + *stringp = (atom_string[0] == '\0' + ? NULL : gfc_get_string ("%s", atom_string)); free (atom_string); } } @@ -1988,7 +1996,8 @@ enum ab_attribute AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY, AB_OMP_DECLARE_TARGET, AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE, AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR, - AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK + AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK, + AB_OMP_DECLARE_TARGET_LINK }; static const mstring attr_bits[] = @@ -2051,6 +2060,7 @@ static const mstring attr_bits[] = minit ("OACC_DECLARE_DEVICEPTR", AB_OACC_DECLARE_DEVICEPTR), minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT), minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK), + minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK), minit (NULL, -1) }; @@ -2236,10 +2246,7 @@ mio_symbol_attribute (symbol_attribute *attr) if (attr->array_outer_dependency) MIO_NAME (ab_attribute) (AB_ARRAY_OUTER_DEPENDENCY, attr_bits); if (attr->module_procedure) - { MIO_NAME (ab_attribute) (AB_MODULE_PROCEDURE, attr_bits); - no_module_procedures = false; - } if (attr->oacc_declare_create) MIO_NAME (ab_attribute) (AB_OACC_DECLARE_CREATE, attr_bits); if (attr->oacc_declare_copyin) @@ -2250,6 +2257,8 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICE_RESIDENT, attr_bits); if (attr->oacc_declare_link) MIO_NAME (ab_attribute) (AB_OACC_DECLARE_LINK, attr_bits); + if (attr->omp_declare_target_link) + MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LINK, attr_bits); mio_rparen (); @@ -2419,6 +2428,9 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_OMP_DECLARE_TARGET: attr->omp_declare_target = 1; break; + case AB_OMP_DECLARE_TARGET_LINK: + attr->omp_declare_target_link = 1; + break; case AB_ARRAY_OUTER_DEPENDENCY: attr->array_outer_dependency =1; break; @@ -2956,7 +2968,7 @@ mio_symtree_ref (gfc_symtree **stp) { p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name, gfc_current_ns); - p->u.rsym.sym->module = gfc_get_string (p->u.rsym.module); + p->u.rsym.sym->module = gfc_get_string ("%s", p->u.rsym.module); } p->u.rsym.symtree->n.sym = p->u.rsym.sym; @@ -3520,7 +3532,7 @@ mio_expr (gfc_expr **ep) if (atom_string[0] == '\0') e->value.function.name = NULL; else - e->value.function.name = gfc_get_string (atom_string); + e->value.function.name = gfc_get_string ("%s", atom_string); free (atom_string); mio_integer (&flag); @@ -4155,13 +4167,13 @@ mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2, q->u.pointer = (void *) ns; sym = gfc_new_symbol (is_initializer ? "omp_priv" : "omp_out", ns); sym->ts = udr->ts; - sym->module = gfc_get_string (p1->u.rsym.module); + sym->module = gfc_get_string ("%s", p1->u.rsym.module); associate_integer_pointer (p1, sym); sym->attr.omp_udr_artificial_var = 1; gcc_assert (p2->u.rsym.sym == NULL); sym = gfc_new_symbol (is_initializer ? "omp_orig" : "omp_in", ns); sym->ts = udr->ts; - sym->module = gfc_get_string (p2->u.rsym.module); + sym->module = gfc_get_string ("%s", p2->u.rsym.module); associate_integer_pointer (p2, sym); sym->attr.omp_udr_artificial_var = 1; if (mio_name (0, omp_declare_reduction_stmt) == 0) @@ -4280,31 +4292,6 @@ mio_symbol (gfc_symbol *sym) /************************* Top level subroutines *************************/ -/* Given a root symtree node and a symbol, try to find a symtree that - references the symbol that is not a unique name. */ - -static gfc_symtree * -find_symtree_for_symbol (gfc_symtree *st, gfc_symbol *sym) -{ - gfc_symtree *s = NULL; - - if (st == NULL) - return s; - - s = find_symtree_for_symbol (st->right, sym); - if (s != NULL) - return s; - s = find_symtree_for_symbol (st->left, sym); - if (s != NULL) - return s; - - if (st->n.sym == sym && !check_unique_name (st->name)) - return st; - - return s; -} - - /* A recursive function to look for a specific symbol by name and by module. Whilst several symtrees might point to one symbol, its is sufficient for the purposes here than one exist. Note that @@ -4503,7 +4490,7 @@ load_generic_interfaces (void) if (!sym) { gfc_get_symbol (p, NULL, &sym); - sym->name = gfc_get_string (name); + sym->name = gfc_get_string ("%s", name); sym->module = module_name; sym->attr.flavor = FL_PROCEDURE; sym->attr.generic = 1; @@ -4691,7 +4678,7 @@ load_omp_udrs (void) mio_lparen (); while (peek_atom () != ATOM_RPAREN) { - const char *name, *newname; + const char *name = NULL, *newname; char *altname; gfc_typespec ts; gfc_symtree *st; @@ -4699,6 +4686,7 @@ load_omp_udrs (void) mio_lparen (); mio_pool_string (&name); + gfc_clear_ts (&ts); mio_typespec (&ts); if (strncmp (name, "operator ", sizeof ("operator ") - 1) == 0) { @@ -4745,7 +4733,7 @@ load_omp_udrs (void) memcpy (altname + 1, newname, len); altname[len + 1] = '.'; altname[len + 2] = '\0'; - name = gfc_get_string (altname); + name = gfc_get_string ("%s", altname); } st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name); gfc_omp_udr *udr = gfc_omp_udr_find (st, &ts); @@ -4847,7 +4835,7 @@ load_needed (pointer_info *p) sym = gfc_new_symbol (p->u.rsym.true_name, ns); sym->name = gfc_dt_lower_string (p->u.rsym.true_name); - sym->module = gfc_get_string (p->u.rsym.module); + sym->module = gfc_get_string ("%s", p->u.rsym.module); if (p->u.rsym.binding_label) sym->binding_label = IDENTIFIER_POINTER (get_identifier (p->u.rsym.binding_label)); @@ -5106,16 +5094,6 @@ read_module (void) info->u.rsym.referenced = 1; continue; } - - /* If possible recycle the symtree that references the symbol. - If a symtree is not found and the module does not import one, - a unique-name symtree is found by read_cleanup. */ - st = find_symtree_for_symbol (gfc_current_ns->sym_root, sym); - if (st != NULL) - { - info->u.rsym.symtree = st; - info->u.rsym.referenced = 1; - } } mio_rparen (); @@ -5222,12 +5200,13 @@ read_module (void) gfc_current_ns); info->u.rsym.sym->name = gfc_dt_lower_string (info->u.rsym.true_name); sym = info->u.rsym.sym; - sym->module = gfc_get_string (info->u.rsym.module); + sym->module = gfc_get_string ("%s", info->u.rsym.module); if (info->u.rsym.binding_label) - sym->binding_label = - IDENTIFIER_POINTER (get_identifier - (info->u.rsym.binding_label)); + { + tree id = get_identifier (info->u.rsym.binding_label); + sym->binding_label = IDENTIFIER_POINTER (id); + } } st->n.sym = sym; @@ -6033,7 +6012,7 @@ dump_module (const char *name, int dump_flag) char *filename, *filename_tmp; uLong crc, crc_old; - module_name = gfc_get_string (name); + module_name = gfc_get_string ("%s", name); if (dump_smod) { @@ -6125,6 +6104,18 @@ dump_module (const char *name, int dump_flag) } +/* Suppress the output of a .smod file by module, if no module + procedures have been seen. */ +static bool no_module_procedures; + +static void +check_for_module_procedures (gfc_symbol *sym) +{ + if (sym && sym->attr.module_procedure) + no_module_procedures = false; +} + + void gfc_dump_module (const char *name, int dump_flag) { @@ -6134,6 +6125,8 @@ gfc_dump_module (const char *name, int dump_flag) dump_smod =false; no_module_procedures = true; + gfc_traverse_ns (gfc_current_ns, check_for_module_procedures); + dump_module (name, dump_flag); if (no_module_procedures || dump_smod) @@ -6159,9 +6152,11 @@ create_intrinsic_function (const char *name, int id, tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); if (tmp_symtree) { - if (strcmp (modname, tmp_symtree->n.sym->module) == 0) - return; - gfc_error ("Symbol %qs already declared", name); + if (tmp_symtree->n.sym && tmp_symtree->n.sym->module + && strcmp (modname, tmp_symtree->n.sym->module) == 0) + return; + gfc_error ("Symbol %qs at %C already declared", name); + return; } gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); @@ -6196,7 +6191,7 @@ create_intrinsic_function (const char *name, int id, sym->attr.flavor = FL_PROCEDURE; sym->attr.intrinsic = 1; - sym->module = gfc_get_string (modname); + sym->module = gfc_get_string ("%s", modname); sym->attr.use_assoc = 1; sym->from_intmod = module; sym->intmod_sym_id = id; @@ -6236,7 +6231,7 @@ import_iso_c_binding_module (void) mod_sym->attr.flavor = FL_MODULE; mod_sym->attr.intrinsic = 1; - mod_sym->module = gfc_get_string (iso_c_module_name); + mod_sym->module = gfc_get_string ("%s", iso_c_module_name); mod_sym->from_intmod = INTMOD_ISO_C_BINDING; } @@ -6494,7 +6489,7 @@ create_int_parameter (const char *name, int value, const char *modname, gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); sym = tmp_symtree->n.sym; - sym->module = gfc_get_string (modname); + sym->module = gfc_get_string ("%s", modname); sym->attr.flavor = FL_PARAMETER; sym->ts.type = BT_INTEGER; sym->ts.kind = gfc_default_integer_kind; @@ -6527,7 +6522,7 @@ create_int_parameter_array (const char *name, int size, gfc_expr *value, gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); sym = tmp_symtree->n.sym; - sym->module = gfc_get_string (modname); + sym->module = gfc_get_string ("%s", modname); sym->attr.flavor = FL_PARAMETER; sym->ts.type = BT_INTEGER; sym->ts.kind = gfc_default_integer_kind; @@ -6568,7 +6563,7 @@ create_derived_type (const char *name, const char *modname, gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); sym = tmp_symtree->n.sym; - sym->module = gfc_get_string (modname); + sym->module = gfc_get_string ("%s", modname); sym->from_intmod = module; sym->intmod_sym_id = id; sym->attr.flavor = FL_PROCEDURE; @@ -6578,12 +6573,12 @@ create_derived_type (const char *name, const char *modname, gfc_get_sym_tree (gfc_dt_upper_string (sym->name), gfc_current_ns, &tmp_symtree, false); dt_sym = tmp_symtree->n.sym; - dt_sym->name = gfc_get_string (sym->name); + dt_sym->name = gfc_get_string ("%s", sym->name); dt_sym->attr.flavor = FL_DERIVED; dt_sym->attr.private_comp = 1; dt_sym->attr.zero_comp = 1; dt_sym->attr.use_assoc = 1; - dt_sym->module = gfc_get_string (modname); + dt_sym->module = gfc_get_string ("%s", modname); dt_sym->from_intmod = module; dt_sym->intmod_sym_id = id; @@ -6663,7 +6658,7 @@ use_iso_fortran_env_module (void) mod_sym->attr.flavor = FL_MODULE; mod_sym->attr.intrinsic = 1; - mod_sym->module = gfc_get_string (mod); + mod_sym->module = gfc_get_string ("%s", mod); mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV; } else @@ -6917,8 +6912,17 @@ gfc_use_module (gfc_use_list *module) } if (module_fp == NULL) - gfc_fatal_error ("Can't open module file %qs for reading at %C: %s", - filename, xstrerror (errno)); + { + if (gfc_state_stack->state != COMP_SUBMODULE + && module->submodule_name == NULL) + gfc_fatal_error ("Can't open module file %qs for reading at %C: %s", + filename, xstrerror (errno)); + else + gfc_fatal_error ("Module file %qs has not been generated, either " + "because the module does not contain a MODULE " + "PROCEDURE or there is an error in the module.", + filename); + } /* Check that we haven't already USEd an intrinsic module with the same name. */ |