diff options
Diffstat (limited to 'gcc/fortran/symbol.cc')
| -rw-r--r-- | gcc/fortran/symbol.cc | 5251 |
1 files changed, 5251 insertions, 0 deletions
diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc new file mode 100644 index 0000000..1a4b022 --- /dev/null +++ b/gcc/fortran/symbol.cc @@ -0,0 +1,5251 @@ +/* Maintain binary trees of symbols. + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught + +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/>. */ + + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "gfortran.h" +#include "parse.h" +#include "match.h" +#include "constructor.h" + + +/* Strings for all symbol attributes. We use these for dumping the + parse tree, in error messages, and also when reading and writing + modules. */ + +const mstring flavors[] = +{ + minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM), + minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE), + minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER), + minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE), + minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST), + minit ("UNION", FL_UNION), minit ("STRUCTURE", FL_STRUCT), + minit (NULL, -1) +}; + +const mstring procedures[] = +{ + minit ("UNKNOWN-PROC", PROC_UNKNOWN), + minit ("MODULE-PROC", PROC_MODULE), + minit ("INTERNAL-PROC", PROC_INTERNAL), + minit ("DUMMY-PROC", PROC_DUMMY), + minit ("INTRINSIC-PROC", PROC_INTRINSIC), + minit ("EXTERNAL-PROC", PROC_EXTERNAL), + minit ("STATEMENT-PROC", PROC_ST_FUNCTION), + minit (NULL, -1) +}; + +const mstring intents[] = +{ + minit ("UNKNOWN-INTENT", INTENT_UNKNOWN), + minit ("IN", INTENT_IN), + minit ("OUT", INTENT_OUT), + minit ("INOUT", INTENT_INOUT), + minit (NULL, -1) +}; + +const mstring access_types[] = +{ + minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN), + minit ("PUBLIC", ACCESS_PUBLIC), + minit ("PRIVATE", ACCESS_PRIVATE), + minit (NULL, -1) +}; + +const mstring ifsrc_types[] = +{ + minit ("UNKNOWN", IFSRC_UNKNOWN), + minit ("DECL", IFSRC_DECL), + minit ("BODY", IFSRC_IFBODY) +}; + +const mstring save_status[] = +{ + minit ("UNKNOWN", SAVE_NONE), + minit ("EXPLICIT-SAVE", SAVE_EXPLICIT), + minit ("IMPLICIT-SAVE", SAVE_IMPLICIT), +}; + +/* Set the mstrings for DTIO procedure names. */ +const mstring dtio_procs[] = +{ + minit ("_dtio_formatted_read", DTIO_RF), + minit ("_dtio_formatted_write", DTIO_WF), + minit ("_dtio_unformatted_read", DTIO_RUF), + minit ("_dtio_unformatted_write", DTIO_WUF), +}; + +/* This is to make sure the backend generates setup code in the correct + order. */ + +static int next_dummy_order = 1; + + +gfc_namespace *gfc_current_ns; +gfc_namespace *gfc_global_ns_list; + +gfc_gsymbol *gfc_gsym_root = NULL; + +gfc_symbol *gfc_derived_types; + +static gfc_undo_change_set default_undo_chgset_var = { vNULL, vNULL, NULL }; +static gfc_undo_change_set *latest_undo_chgset = &default_undo_chgset_var; + + +/*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/ + +/* The following static variable indicates whether a particular element has + been explicitly set or not. */ + +static int new_flag[GFC_LETTERS]; + + +/* Handle a correctly parsed IMPLICIT NONE. */ + +void +gfc_set_implicit_none (bool type, bool external, locus *loc) +{ + int i; + + if (external) + gfc_current_ns->has_implicit_none_export = 1; + + if (type) + { + gfc_current_ns->seen_implicit_none = 1; + for (i = 0; i < GFC_LETTERS; i++) + { + if (gfc_current_ns->set_flag[i]) + { + gfc_error_now ("IMPLICIT NONE (type) statement at %L following an " + "IMPLICIT statement", loc); + return; + } + gfc_clear_ts (&gfc_current_ns->default_type[i]); + gfc_current_ns->set_flag[i] = 1; + } + } +} + + +/* Reset the implicit range flags. */ + +void +gfc_clear_new_implicit (void) +{ + int i; + + for (i = 0; i < GFC_LETTERS; i++) + new_flag[i] = 0; +} + + +/* Prepare for a new implicit range. Sets flags in new_flag[]. */ + +bool +gfc_add_new_implicit_range (int c1, int c2) +{ + int i; + + c1 -= 'a'; + c2 -= 'a'; + + for (i = c1; i <= c2; i++) + { + if (new_flag[i]) + { + gfc_error ("Letter %qc already set in IMPLICIT statement at %C", + i + 'A'); + return false; + } + + new_flag[i] = 1; + } + + return true; +} + + +/* Add a matched implicit range for gfc_set_implicit(). Check if merging + the new implicit types back into the existing types will work. */ + +bool +gfc_merge_new_implicit (gfc_typespec *ts) +{ + int i; + + if (gfc_current_ns->seen_implicit_none) + { + gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE"); + return false; + } + + for (i = 0; i < GFC_LETTERS; i++) + { + if (new_flag[i]) + { + if (gfc_current_ns->set_flag[i]) + { + gfc_error ("Letter %qc already has an IMPLICIT type at %C", + i + 'A'); + return false; + } + + gfc_current_ns->default_type[i] = *ts; + gfc_current_ns->implicit_loc[i] = gfc_current_locus; + gfc_current_ns->set_flag[i] = 1; + } + } + return true; +} + + +/* Given a symbol, return a pointer to the typespec for its default type. */ + +gfc_typespec * +gfc_get_default_type (const char *name, gfc_namespace *ns) +{ + char letter; + + letter = name[0]; + + if (flag_allow_leading_underscore && letter == '_') + gfc_fatal_error ("Option %<-fallow-leading-underscore%> is for use only by " + "gfortran developers, and should not be used for " + "implicitly typed variables"); + + if (letter < 'a' || letter > 'z') + gfc_internal_error ("gfc_get_default_type(): Bad symbol %qs", name); + + if (ns == NULL) + ns = gfc_current_ns; + + return &ns->default_type[letter - 'a']; +} + + +/* Recursively append candidate SYM to CANDIDATES. Store the number of + candidates in CANDIDATES_LEN. */ + +static void +lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym, + char **&candidates, + size_t &candidates_len) +{ + gfc_symtree *p; + + if (sym == NULL) + return; + + if (sym->n.sym->ts.type != BT_UNKNOWN && sym->n.sym->ts.type != BT_PROCEDURE) + vec_push (candidates, candidates_len, sym->name); + p = sym->left; + if (p) + lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len); + + p = sym->right; + if (p) + lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len); +} + + +/* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into account. */ + +static const char* +lookup_symbol_fuzzy (const char *sym_name, gfc_symbol *symbol) +{ + char **candidates = NULL; + size_t candidates_len = 0; + lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, candidates, + candidates_len); + return gfc_closest_fuzzy_match (sym_name, candidates); +} + + +/* Given a pointer to a symbol, set its type according to the first + letter of its name. Fails if the letter in question has no default + type. */ + +bool +gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns) +{ + gfc_typespec *ts; + + if (sym->ts.type != BT_UNKNOWN) + gfc_internal_error ("gfc_set_default_type(): symbol already has a type"); + + ts = gfc_get_default_type (sym->name, ns); + + if (ts->type == BT_UNKNOWN) + { + if (error_flag && !sym->attr.untyped && !gfc_query_suppress_errors ()) + { + const char *guessed = lookup_symbol_fuzzy (sym->name, sym); + if (guessed) + gfc_error ("Symbol %qs at %L has no IMPLICIT type" + "; did you mean %qs?", + sym->name, &sym->declared_at, guessed); + else + gfc_error ("Symbol %qs at %L has no IMPLICIT type", + sym->name, &sym->declared_at); + sym->attr.untyped = 1; /* Ensure we only give an error once. */ + } + + return false; + } + + sym->ts = *ts; + sym->attr.implicit_type = 1; + + if (ts->type == BT_CHARACTER && ts->u.cl) + sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl); + else if (ts->type == BT_CLASS + && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as)) + return false; + + if (sym->attr.is_bind_c == 1 && warn_c_binding_type) + { + /* BIND(C) variables should not be implicitly declared. */ + gfc_warning_now (OPT_Wc_binding_type, "Implicitly declared BIND(C) " + "variable %qs at %L may not be C interoperable", + sym->name, &sym->declared_at); + sym->ts.f90_type = sym->ts.type; + } + + if (sym->attr.dummy != 0) + { + if (sym->ns->proc_name != NULL + && (sym->ns->proc_name->attr.subroutine != 0 + || sym->ns->proc_name->attr.function != 0) + && sym->ns->proc_name->attr.is_bind_c != 0 + && warn_c_binding_type) + { + /* Dummy args to a BIND(C) routine may not be interoperable if + they are implicitly typed. */ + gfc_warning_now (OPT_Wc_binding_type, "Implicitly declared variable " + "%qs at %L may not be C interoperable but it is a " + "dummy argument to the BIND(C) procedure %qs at %L", + sym->name, &(sym->declared_at), + sym->ns->proc_name->name, + &(sym->ns->proc_name->declared_at)); + sym->ts.f90_type = sym->ts.type; + } + } + + return true; +} + + +/* This function is called from parse.c(parse_progunit) to check the + type of the function is not implicitly typed in the host namespace + and to implicitly type the function result, if necessary. */ + +void +gfc_check_function_type (gfc_namespace *ns) +{ + gfc_symbol *proc = ns->proc_name; + + if (!proc->attr.contained || proc->result->attr.implicit_type) + return; + + if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL) + { + if (gfc_set_default_type (proc->result, 0, gfc_current_ns)) + { + if (proc->result != proc) + { + proc->ts = proc->result->ts; + proc->as = gfc_copy_array_spec (proc->result->as); + proc->attr.dimension = proc->result->attr.dimension; + proc->attr.pointer = proc->result->attr.pointer; + proc->attr.allocatable = proc->result->attr.allocatable; + } + } + else if (!proc->result->attr.proc_pointer) + { + gfc_error ("Function result %qs at %L has no IMPLICIT type", + proc->result->name, &proc->result->declared_at); + proc->result->attr.untyped = 1; + } + } +} + + +/******************** Symbol attribute stuff *********************/ + +/* This is a generic conflict-checker. We do this to avoid having a + single conflict in two places. */ + +#define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; } +#define conf2(a) if (attr->a) { a2 = a; goto conflict; } +#define conf_std(a, b, std) if (attr->a && attr->b)\ + {\ + a1 = a;\ + a2 = b;\ + standard = std;\ + goto conflict_std;\ + } + +bool +gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) +{ + static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER", + *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT", + *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC", + *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)", + *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL", + *privat = "PRIVATE", *recursive = "RECURSIVE", + *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST", + *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY", + *function = "FUNCTION", *subroutine = "SUBROUTINE", + *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE", + *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER", + *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE", + *volatile_ = "VOLATILE", *is_protected = "PROTECTED", + *is_bind_c = "BIND(C)", *procedure = "PROCEDURE", + *proc_pointer = "PROCEDURE POINTER", *abstract = "ABSTRACT", + *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION", + *contiguous = "CONTIGUOUS", *generic = "GENERIC", *automatic = "AUTOMATIC", + *pdt_len = "LEN", *pdt_kind = "KIND"; + static const char *threadprivate = "THREADPRIVATE"; + static const char *omp_declare_target = "OMP DECLARE TARGET"; + static const char *omp_declare_target_link = "OMP DECLARE TARGET LINK"; + static const char *oacc_declare_copyin = "OACC DECLARE COPYIN"; + static const char *oacc_declare_create = "OACC DECLARE CREATE"; + static const char *oacc_declare_deviceptr = "OACC DECLARE DEVICEPTR"; + static const char *oacc_declare_device_resident = + "OACC DECLARE DEVICE_RESIDENT"; + + const char *a1, *a2; + int standard; + + if (attr->artificial) + return true; + + if (where == NULL) + where = &gfc_current_locus; + + if (attr->pointer && attr->intent != INTENT_UNKNOWN) + { + a1 = pointer; + a2 = intent; + standard = GFC_STD_F2003; + goto conflict_std; + } + + if (attr->in_namelist && (attr->allocatable || attr->pointer)) + { + a1 = in_namelist; + a2 = attr->allocatable ? allocatable : pointer; + standard = GFC_STD_F2003; + goto conflict_std; + } + + /* Check for attributes not allowed in a BLOCK DATA. */ + if (gfc_current_state () == COMP_BLOCK_DATA) + { + a1 = NULL; + + if (attr->in_namelist) + a1 = in_namelist; + if (attr->allocatable) + a1 = allocatable; + if (attr->external) + a1 = external; + if (attr->optional) + a1 = optional; + if (attr->access == ACCESS_PRIVATE) + a1 = privat; + if (attr->access == ACCESS_PUBLIC) + a1 = publik; + if (attr->intent != INTENT_UNKNOWN) + a1 = intent; + + if (a1 != NULL) + { + gfc_error + ("%s attribute not allowed in BLOCK DATA program unit at %L", + a1, where); + return false; + } + } + + if (attr->save == SAVE_EXPLICIT) + { + conf (dummy, save); + conf (in_common, save); + conf (result, save); + conf (automatic, save); + + switch (attr->flavor) + { + case FL_PROGRAM: + case FL_BLOCK_DATA: + case FL_MODULE: + case FL_LABEL: + case_fl_struct: + case FL_PARAMETER: + a1 = gfc_code2string (flavors, attr->flavor); + a2 = save; + goto conflict; + case FL_NAMELIST: + gfc_error ("Namelist group name at %L cannot have the " + "SAVE attribute", where); + return false; + case FL_PROCEDURE: + /* Conflicts between SAVE and PROCEDURE will be checked at + resolution stage, see "resolve_fl_procedure". */ + case FL_VARIABLE: + default: + break; + } + } + + /* The copying of procedure dummy arguments for module procedures in + a submodule occur whilst the current state is COMP_CONTAINS. It + is necessary, therefore, to let this through. */ + if (name && attr->dummy + && (attr->function || attr->subroutine) + && gfc_current_state () == COMP_CONTAINS + && !(gfc_new_block && gfc_new_block->abr_modproc_decl)) + gfc_error_now ("internal procedure %qs at %L conflicts with " + "DUMMY argument", name, where); + + conf (dummy, entry); + conf (dummy, intrinsic); + conf (dummy, threadprivate); + conf (dummy, omp_declare_target); + conf (dummy, omp_declare_target_link); + conf (pointer, target); + conf (pointer, intrinsic); + conf (pointer, elemental); + conf (pointer, codimension); + conf (allocatable, elemental); + + conf (in_common, automatic); + conf (result, automatic); + conf (use_assoc, automatic); + conf (dummy, automatic); + + conf (target, external); + conf (target, intrinsic); + + if (!attr->if_source) + conf (external, dimension); /* See Fortran 95's R504. */ + + conf (external, intrinsic); + conf (entry, intrinsic); + conf (abstract, intrinsic); + + if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained) + conf (external, subroutine); + + if (attr->proc_pointer && !gfc_notify_std (GFC_STD_F2003, + "Procedure pointer at %C")) + return false; + + conf (allocatable, pointer); + conf_std (allocatable, dummy, GFC_STD_F2003); + conf_std (allocatable, function, GFC_STD_F2003); + conf_std (allocatable, result, GFC_STD_F2003); + conf_std (elemental, recursive, GFC_STD_F2018); + + conf (in_common, dummy); + conf (in_common, allocatable); + conf (in_common, codimension); + conf (in_common, result); + + conf (in_equivalence, use_assoc); + conf (in_equivalence, codimension); + conf (in_equivalence, dummy); + conf (in_equivalence, target); + conf (in_equivalence, pointer); + conf (in_equivalence, function); + conf (in_equivalence, result); + conf (in_equivalence, entry); + conf (in_equivalence, allocatable); + conf (in_equivalence, threadprivate); + conf (in_equivalence, omp_declare_target); + conf (in_equivalence, omp_declare_target_link); + conf (in_equivalence, oacc_declare_create); + conf (in_equivalence, oacc_declare_copyin); + conf (in_equivalence, oacc_declare_deviceptr); + conf (in_equivalence, oacc_declare_device_resident); + conf (in_equivalence, is_bind_c); + + conf (dummy, result); + conf (entry, result); + conf (generic, result); + conf (generic, omp_declare_target); + conf (generic, omp_declare_target_link); + + conf (function, subroutine); + + if (!function && !subroutine) + conf (is_bind_c, dummy); + + conf (is_bind_c, cray_pointer); + conf (is_bind_c, cray_pointee); + conf (is_bind_c, codimension); + conf (is_bind_c, allocatable); + conf (is_bind_c, elemental); + + /* Need to also get volatile attr, according to 5.1 of F2003 draft. + Parameter conflict caught below. Also, value cannot be specified + for a dummy procedure. */ + + /* Cray pointer/pointee conflicts. */ + conf (cray_pointer, cray_pointee); + conf (cray_pointer, dimension); + conf (cray_pointer, codimension); + conf (cray_pointer, contiguous); + conf (cray_pointer, pointer); + conf (cray_pointer, target); + conf (cray_pointer, allocatable); + conf (cray_pointer, external); + conf (cray_pointer, intrinsic); + conf (cray_pointer, in_namelist); + conf (cray_pointer, function); + conf (cray_pointer, subroutine); + conf (cray_pointer, entry); + + conf (cray_pointee, allocatable); + conf (cray_pointee, contiguous); + conf (cray_pointee, codimension); + conf (cray_pointee, intent); + conf (cray_pointee, optional); + conf (cray_pointee, dummy); + conf (cray_pointee, target); + conf (cray_pointee, intrinsic); + conf (cray_pointee, pointer); + conf (cray_pointee, entry); + conf (cray_pointee, in_common); + conf (cray_pointee, in_equivalence); + conf (cray_pointee, threadprivate); + conf (cray_pointee, omp_declare_target); + conf (cray_pointee, omp_declare_target_link); + conf (cray_pointee, oacc_declare_create); + conf (cray_pointee, oacc_declare_copyin); + conf (cray_pointee, oacc_declare_deviceptr); + conf (cray_pointee, oacc_declare_device_resident); + + conf (data, dummy); + conf (data, function); + conf (data, result); + conf (data, allocatable); + + conf (value, pointer) + conf (value, allocatable) + conf (value, subroutine) + conf (value, function) + conf (value, volatile_) + conf (value, dimension) + conf (value, codimension) + conf (value, external) + + conf (codimension, result) + + if (attr->value + && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT)) + { + a1 = value; + a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout; + goto conflict; + } + + conf (is_protected, intrinsic) + conf (is_protected, in_common) + + conf (asynchronous, intrinsic) + conf (asynchronous, external) + + conf (volatile_, intrinsic) + conf (volatile_, external) + + if (attr->volatile_ && attr->intent == INTENT_IN) + { + a1 = volatile_; + a2 = intent_in; + goto conflict; + } + + conf (procedure, allocatable) + conf (procedure, dimension) + conf (procedure, codimension) + conf (procedure, intrinsic) + conf (procedure, target) + conf (procedure, value) + conf (procedure, volatile_) + conf (procedure, asynchronous) + conf (procedure, entry) + + conf (proc_pointer, abstract) + conf (proc_pointer, omp_declare_target) + conf (proc_pointer, omp_declare_target_link) + + conf (entry, omp_declare_target) + conf (entry, omp_declare_target_link) + conf (entry, oacc_declare_create) + conf (entry, oacc_declare_copyin) + conf (entry, oacc_declare_deviceptr) + conf (entry, oacc_declare_device_resident) + + conf (pdt_kind, allocatable) + conf (pdt_kind, pointer) + conf (pdt_kind, dimension) + conf (pdt_kind, codimension) + + conf (pdt_len, allocatable) + conf (pdt_len, pointer) + conf (pdt_len, dimension) + conf (pdt_len, codimension) + conf (pdt_len, pdt_kind) + + if (attr->access == ACCESS_PRIVATE) + { + a1 = privat; + conf2 (pdt_kind); + conf2 (pdt_len); + } + + a1 = gfc_code2string (flavors, attr->flavor); + + if (attr->in_namelist + && attr->flavor != FL_VARIABLE + && attr->flavor != FL_PROCEDURE + && attr->flavor != FL_UNKNOWN) + { + a2 = in_namelist; + goto conflict; + } + + switch (attr->flavor) + { + case FL_PROGRAM: + case FL_BLOCK_DATA: + case FL_MODULE: + case FL_LABEL: + conf2 (codimension); + conf2 (dimension); + conf2 (dummy); + conf2 (volatile_); + conf2 (asynchronous); + conf2 (contiguous); + conf2 (pointer); + conf2 (is_protected); + conf2 (target); + conf2 (external); + conf2 (intrinsic); + conf2 (allocatable); + conf2 (result); + conf2 (in_namelist); + conf2 (optional); + conf2 (function); + conf2 (subroutine); + conf2 (threadprivate); + conf2 (omp_declare_target); + conf2 (omp_declare_target_link); + conf2 (oacc_declare_create); + conf2 (oacc_declare_copyin); + conf2 (oacc_declare_deviceptr); + conf2 (oacc_declare_device_resident); + + if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE) + { + a2 = attr->access == ACCESS_PUBLIC ? publik : privat; + gfc_error ("%s attribute applied to %s %s at %L", a2, a1, + name, where); + return false; + } + + if (attr->is_bind_c) + { + gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where); + return false; + } + + break; + + case FL_VARIABLE: + break; + + case FL_NAMELIST: + conf2 (result); + break; + + case FL_PROCEDURE: + /* Conflicts with INTENT, SAVE and RESULT will be checked + at resolution stage, see "resolve_fl_procedure". */ + + if (attr->subroutine) + { + a1 = subroutine; + conf2 (target); + conf2 (allocatable); + conf2 (volatile_); + conf2 (asynchronous); + conf2 (in_namelist); + conf2 (codimension); + conf2 (dimension); + conf2 (function); + if (!attr->proc_pointer) + conf2 (threadprivate); + } + + /* Procedure pointers in COMMON blocks are allowed in F03, + * but forbidden per F08:C5100. */ + if (!attr->proc_pointer || (gfc_option.allow_std & GFC_STD_F2008)) + conf2 (in_common); + + conf2 (omp_declare_target_link); + + switch (attr->proc) + { + case PROC_ST_FUNCTION: + conf2 (dummy); + conf2 (target); + break; + + case PROC_MODULE: + conf2 (dummy); + break; + + case PROC_DUMMY: + conf2 (result); + conf2 (threadprivate); + break; + + default: + break; + } + + break; + + case_fl_struct: + conf2 (dummy); + conf2 (pointer); + conf2 (target); + conf2 (external); + conf2 (intrinsic); + conf2 (allocatable); + conf2 (optional); + conf2 (entry); + conf2 (function); + conf2 (subroutine); + conf2 (threadprivate); + conf2 (result); + conf2 (omp_declare_target); + conf2 (omp_declare_target_link); + conf2 (oacc_declare_create); + conf2 (oacc_declare_copyin); + conf2 (oacc_declare_deviceptr); + conf2 (oacc_declare_device_resident); + + if (attr->intent != INTENT_UNKNOWN) + { + a2 = intent; + goto conflict; + } + break; + + case FL_PARAMETER: + conf2 (external); + conf2 (intrinsic); + conf2 (optional); + conf2 (allocatable); + conf2 (function); + conf2 (subroutine); + conf2 (entry); + conf2 (contiguous); + conf2 (pointer); + conf2 (is_protected); + conf2 (target); + conf2 (dummy); + conf2 (in_common); + conf2 (value); + conf2 (volatile_); + conf2 (asynchronous); + conf2 (threadprivate); + conf2 (value); + conf2 (codimension); + conf2 (result); + if (!attr->is_iso_c) + conf2 (is_bind_c); + break; + + default: + break; + } + + return true; + +conflict: + if (name == NULL) + gfc_error ("%s attribute conflicts with %s attribute at %L", + a1, a2, where); + else + gfc_error ("%s attribute conflicts with %s attribute in %qs at %L", + a1, a2, name, where); + + return false; + +conflict_std: + if (name == NULL) + { + return gfc_notify_std (standard, "%s attribute conflicts " + "with %s attribute at %L", a1, a2, + where); + } + else + { + return gfc_notify_std (standard, "%s attribute conflicts " + "with %s attribute in %qs at %L", + a1, a2, name, where); + } +} + +#undef conf +#undef conf2 +#undef conf_std + + +/* Mark a symbol as referenced. */ + +void +gfc_set_sym_referenced (gfc_symbol *sym) +{ + + if (sym->attr.referenced) + return; + + sym->attr.referenced = 1; + + /* Remember which order dummy variables are accessed in. */ + if (sym->attr.dummy) + sym->dummy_order = next_dummy_order++; +} + + +/* Common subroutine called by attribute changing subroutines in order + to prevent them from changing a symbol that has been + use-associated. Returns zero if it is OK to change the symbol, + nonzero if not. */ + +static int +check_used (symbol_attribute *attr, const char *name, locus *where) +{ + + if (attr->use_assoc == 0) + return 0; + + if (where == NULL) + where = &gfc_current_locus; + + if (name == NULL) + gfc_error ("Cannot change attributes of USE-associated symbol at %L", + where); + else + gfc_error ("Cannot change attributes of USE-associated symbol %s at %L", + name, where); + + return 1; +} + + +/* Generate an error because of a duplicate attribute. */ + +static void +duplicate_attr (const char *attr, locus *where) +{ + + if (where == NULL) + where = &gfc_current_locus; + + gfc_error ("Duplicate %s attribute specified at %L", attr, where); +} + + +bool +gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr, + locus *where ATTRIBUTE_UNUSED) +{ + attr->ext_attr |= 1 << ext_attr; + return true; +} + + +/* Called from decl.c (attr_decl1) to check attributes, when declared + separately. */ + +bool +gfc_add_attribute (symbol_attribute *attr, locus *where) +{ + if (check_used (attr, NULL, where)) + return false; + + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_allocatable (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->allocatable && ! gfc_submodule_procedure(attr)) + { + duplicate_attr ("ALLOCATABLE", where); + return false; + } + + if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY + && !gfc_find_state (COMP_INTERFACE)) + { + gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L", + where); + return false; + } + + attr->allocatable = 1; + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_automatic (symbol_attribute *attr, const char *name, locus *where) +{ + if (check_used (attr, name, where)) + return false; + + if (attr->automatic && !gfc_notify_std (GFC_STD_LEGACY, + "Duplicate AUTOMATIC attribute specified at %L", where)) + return false; + + attr->automatic = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->codimension) + { + duplicate_attr ("CODIMENSION", where); + return false; + } + + if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY + && !gfc_find_state (COMP_INTERFACE)) + { + gfc_error ("CODIMENSION specified for %qs outside its INTERFACE body " + "at %L", name, where); + return false; + } + + attr->codimension = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->dimension && ! gfc_submodule_procedure(attr)) + { + duplicate_attr ("DIMENSION", where); + return false; + } + + if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY + && !gfc_find_state (COMP_INTERFACE)) + { + gfc_error ("DIMENSION specified for %qs outside its INTERFACE body " + "at %L", name, where); + return false; + } + + attr->dimension = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + attr->contiguous = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_external (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->external) + { + duplicate_attr ("EXTERNAL", where); + return false; + } + + if (attr->pointer && attr->if_source != IFSRC_IFBODY) + { + attr->pointer = 0; + attr->proc_pointer = 1; + } + + attr->external = 1; + + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_intrinsic (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->intrinsic) + { + duplicate_attr ("INTRINSIC", where); + return false; + } + + attr->intrinsic = 1; + + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_optional (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->optional) + { + duplicate_attr ("OPTIONAL", where); + return false; + } + + attr->optional = 1; + return gfc_check_conflict (attr, NULL, where); +} + +bool +gfc_add_kind (symbol_attribute *attr, locus *where) +{ + if (attr->pdt_kind) + { + duplicate_attr ("KIND", where); + return false; + } + + attr->pdt_kind = 1; + return gfc_check_conflict (attr, NULL, where); +} + +bool +gfc_add_len (symbol_attribute *attr, locus *where) +{ + if (attr->pdt_len) + { + duplicate_attr ("LEN", where); + return false; + } + + attr->pdt_len = 1; + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_pointer (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->pointer && !(attr->if_source == IFSRC_IFBODY + && !gfc_find_state (COMP_INTERFACE)) + && ! gfc_submodule_procedure(attr)) + { + duplicate_attr ("POINTER", where); + return false; + } + + if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY) + || (attr->if_source == IFSRC_IFBODY + && !gfc_find_state (COMP_INTERFACE))) + attr->proc_pointer = 1; + else + attr->pointer = 1; + + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_cray_pointer (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + attr->cray_pointer = 1; + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_cray_pointee (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->cray_pointee) + { + gfc_error ("Cray Pointee at %L appears in multiple pointer()" + " statements", where); + return false; + } + + attr->cray_pointee = 1; + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_protected (symbol_attribute *attr, const char *name, locus *where) +{ + if (check_used (attr, name, where)) + return false; + + if (attr->is_protected) + { + if (!gfc_notify_std (GFC_STD_LEGACY, + "Duplicate PROTECTED attribute specified at %L", + where)) + return false; + } + + attr->is_protected = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_result (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + attr->result = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_save (symbol_attribute *attr, save_state s, const char *name, + locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (s == SAVE_EXPLICIT && gfc_pure (NULL)) + { + gfc_error + ("SAVE attribute at %L cannot be specified in a PURE procedure", + where); + return false; + } + + if (s == SAVE_EXPLICIT) + gfc_unset_implicit_pure (NULL); + + if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT + && (flag_automatic || pedantic)) + { + if (!gfc_notify_std (GFC_STD_LEGACY, + "Duplicate SAVE attribute specified at %L", + where)) + return false; + } + + attr->save = s; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_value (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->value) + { + if (!gfc_notify_std (GFC_STD_LEGACY, + "Duplicate VALUE attribute specified at %L", + where)) + return false; + } + + attr->value = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where) +{ + /* No check_used needed as 11.2.1 of the F2003 standard allows + that the local identifier made accessible by a use statement can be + given a VOLATILE attribute - unless it is a coarray (F2008, C560). */ + + if (attr->volatile_ && attr->volatile_ns == gfc_current_ns) + if (!gfc_notify_std (GFC_STD_LEGACY, + "Duplicate VOLATILE attribute specified at %L", + where)) + return false; + + /* F2008: C1282 A designator of a variable with the VOLATILE attribute + shall not appear in a pure subprogram. + + F2018: C1588 A local variable of a pure subprogram, or of a BLOCK + construct within a pure subprogram, shall not have the SAVE or + VOLATILE attribute. */ + if (gfc_pure (NULL)) + { + gfc_error ("VOLATILE attribute at %L cannot be specified in a " + "PURE procedure", where); + return false; + } + + + attr->volatile_ = 1; + attr->volatile_ns = gfc_current_ns; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where) +{ + /* No check_used needed as 11.2.1 of the F2003 standard allows + that the local identifier made accessible by a use statement can be + given a ASYNCHRONOUS attribute. */ + + if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns) + if (!gfc_notify_std (GFC_STD_LEGACY, + "Duplicate ASYNCHRONOUS attribute specified at %L", + where)) + return false; + + attr->asynchronous = 1; + attr->asynchronous_ns = gfc_current_ns; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->threadprivate) + { + duplicate_attr ("THREADPRIVATE", where); + return false; + } + + attr->threadprivate = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_omp_declare_target (symbol_attribute *attr, const char *name, + locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->omp_declare_target) + return true; + + attr->omp_declare_target = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_omp_declare_target_link (symbol_attribute *attr, const char *name, + locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->omp_declare_target_link) + return true; + + attr->omp_declare_target_link = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_oacc_declare_create (symbol_attribute *attr, const char *name, + locus *where) +{ + if (check_used (attr, name, where)) + return false; + + if (attr->oacc_declare_create) + return true; + + attr->oacc_declare_create = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_oacc_declare_copyin (symbol_attribute *attr, const char *name, + locus *where) +{ + if (check_used (attr, name, where)) + return false; + + if (attr->oacc_declare_copyin) + return true; + + attr->oacc_declare_copyin = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_oacc_declare_deviceptr (symbol_attribute *attr, const char *name, + locus *where) +{ + if (check_used (attr, name, where)) + return false; + + if (attr->oacc_declare_deviceptr) + return true; + + attr->oacc_declare_deviceptr = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_oacc_declare_device_resident (symbol_attribute *attr, const char *name, + locus *where) +{ + if (check_used (attr, name, where)) + return false; + + if (attr->oacc_declare_device_resident) + return true; + + attr->oacc_declare_device_resident = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_target (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->target) + { + duplicate_attr ("TARGET", where); + return false; + } + + attr->target = 1; + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + /* Duplicate dummy arguments are allowed due to ENTRY statements. */ + attr->dummy = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + /* Duplicate attribute already checked for. */ + attr->in_common = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where) +{ + + /* Duplicate attribute already checked for. */ + attr->in_equivalence = 1; + if (!gfc_check_conflict (attr, name, where)) + return false; + + if (attr->flavor == FL_VARIABLE) + return true; + + return gfc_add_flavor (attr, FL_VARIABLE, name, where); +} + + +bool +gfc_add_data (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + attr->data = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where) +{ + + attr->in_namelist = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + attr->sequence = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_elemental (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->elemental) + { + duplicate_attr ("ELEMENTAL", where); + return false; + } + + attr->elemental = 1; + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_pure (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->pure) + { + duplicate_attr ("PURE", where); + return false; + } + + attr->pure = 1; + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_recursive (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->recursive) + { + duplicate_attr ("RECURSIVE", where); + return false; + } + + attr->recursive = 1; + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_entry (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->entry) + { + duplicate_attr ("ENTRY", where); + return false; + } + + attr->entry = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_function (symbol_attribute *attr, const char *name, locus *where) +{ + + if (attr->flavor != FL_PROCEDURE + && !gfc_add_flavor (attr, FL_PROCEDURE, name, where)) + return false; + + attr->function = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where) +{ + + if (attr->flavor != FL_PROCEDURE + && !gfc_add_flavor (attr, FL_PROCEDURE, name, where)) + return false; + + attr->subroutine = 1; + + /* If we are looking at a BLOCK DATA statement and we encounter a + name with a leading underscore (which must be + compiler-generated), do not check. See PR 84394. */ + + if (name && *name != '_' && gfc_current_state () != COMP_BLOCK_DATA) + return gfc_check_conflict (attr, name, where); + else + return true; +} + + +bool +gfc_add_generic (symbol_attribute *attr, const char *name, locus *where) +{ + + if (attr->flavor != FL_PROCEDURE + && !gfc_add_flavor (attr, FL_PROCEDURE, name, where)) + return false; + + attr->generic = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_proc (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->flavor != FL_PROCEDURE + && !gfc_add_flavor (attr, FL_PROCEDURE, name, where)) + return false; + + if (attr->procedure) + { + duplicate_attr ("PROCEDURE", where); + return false; + } + + attr->procedure = 1; + + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_abstract (symbol_attribute* attr, locus* where) +{ + if (attr->abstract) + { + duplicate_attr ("ABSTRACT", where); + return false; + } + + attr->abstract = 1; + + return gfc_check_conflict (attr, NULL, where); +} + + +/* Flavors are special because some flavors are not what Fortran + considers attributes and can be reaffirmed multiple times. */ + +bool +gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name, + locus *where) +{ + + if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE + || f == FL_PARAMETER || f == FL_LABEL || gfc_fl_struct(f) + || f == FL_NAMELIST) && check_used (attr, name, where)) + return false; + + if (attr->flavor == f && f == FL_VARIABLE) + return true; + + /* Copying a procedure dummy argument for a module procedure in a + submodule results in the flavor being copied and would result in + an error without this. */ + if (attr->flavor == f && f == FL_PROCEDURE + && gfc_new_block && gfc_new_block->abr_modproc_decl) + return true; + + if (attr->flavor != FL_UNKNOWN) + { + if (where == NULL) + where = &gfc_current_locus; + + if (name) + gfc_error ("%s attribute of %qs conflicts with %s attribute at %L", + gfc_code2string (flavors, attr->flavor), name, + gfc_code2string (flavors, f), where); + else + gfc_error ("%s attribute conflicts with %s attribute at %L", + gfc_code2string (flavors, attr->flavor), + gfc_code2string (flavors, f), where); + + return false; + } + + attr->flavor = f; + + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_procedure (symbol_attribute *attr, procedure_type t, + const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->flavor != FL_PROCEDURE + && !gfc_add_flavor (attr, FL_PROCEDURE, name, where)) + return false; + + if (where == NULL) + where = &gfc_current_locus; + + if (attr->proc != PROC_UNKNOWN && !attr->module_procedure + && attr->access == ACCESS_UNKNOWN) + { + if (attr->proc == PROC_ST_FUNCTION && t == PROC_INTERNAL + && !gfc_notification_std (GFC_STD_F2008)) + gfc_error ("%s procedure at %L is already declared as %s " + "procedure. \nF2008: A pointer function assignment " + "is ambiguous if it is the first executable statement " + "after the specification block. Please add any other " + "kind of executable statement before it. FIXME", + gfc_code2string (procedures, t), where, + gfc_code2string (procedures, attr->proc)); + else + gfc_error ("%s procedure at %L is already declared as %s " + "procedure", gfc_code2string (procedures, t), where, + gfc_code2string (procedures, attr->proc)); + + return false; + } + + attr->proc = t; + + /* Statement functions are always scalar and functions. */ + if (t == PROC_ST_FUNCTION + && ((!attr->function && !gfc_add_function (attr, name, where)) + || attr->dimension)) + return false; + + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->intent == INTENT_UNKNOWN) + { + attr->intent = intent; + return gfc_check_conflict (attr, NULL, where); + } + + if (where == NULL) + where = &gfc_current_locus; + + gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L", + gfc_intent_string (attr->intent), + gfc_intent_string (intent), where); + + return false; +} + + +/* No checks for use-association in public and private statements. */ + +bool +gfc_add_access (symbol_attribute *attr, gfc_access access, + const char *name, locus *where) +{ + + if (attr->access == ACCESS_UNKNOWN + || (attr->use_assoc && attr->access != ACCESS_PRIVATE)) + { + attr->access = access; + return gfc_check_conflict (attr, name, where); + } + + if (where == NULL) + where = &gfc_current_locus; + gfc_error ("ACCESS specification at %L was already specified", where); + + return false; +} + + +/* Set the is_bind_c field for the given symbol_attribute. */ + +bool +gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where, + int is_proc_lang_bind_spec) +{ + + if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE) + gfc_error_now ("BIND(C) attribute at %L can only be used for " + "variables or common blocks", where); + else if (attr->is_bind_c) + gfc_error_now ("Duplicate BIND attribute specified at %L", where); + else + attr->is_bind_c = 1; + + if (where == NULL) + where = &gfc_current_locus; + + if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) at %L", where)) + return false; + + return gfc_check_conflict (attr, name, where); +} + + +/* Set the extension field for the given symbol_attribute. */ + +bool +gfc_add_extension (symbol_attribute *attr, locus *where) +{ + if (where == NULL) + where = &gfc_current_locus; + + if (attr->extension) + gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where); + else + attr->extension = 1; + + if (!gfc_notify_std (GFC_STD_F2003, "EXTENDS at %L", where)) + return false; + + return true; +} + + +bool +gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source, + gfc_formal_arglist * formal, locus *where) +{ + if (check_used (&sym->attr, sym->name, where)) + return false; + + /* Skip the following checks in the case of a module_procedures in a + submodule since they will manifestly fail. */ + if (sym->attr.module_procedure == 1 + && source == IFSRC_DECL) + goto finish; + + if (where == NULL) + where = &gfc_current_locus; + + if (sym->attr.if_source != IFSRC_UNKNOWN + && sym->attr.if_source != IFSRC_DECL) + { + gfc_error ("Symbol %qs at %L already has an explicit interface", + sym->name, where); + return false; + } + + if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable)) + { + gfc_error ("%qs at %L has attributes specified outside its INTERFACE " + "body", sym->name, where); + return false; + } + +finish: + sym->formal = formal; + sym->attr.if_source = source; + + return true; +} + + +/* Add a type to a symbol. */ + +bool +gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where) +{ + sym_flavor flavor; + bt type; + + if (where == NULL) + where = &gfc_current_locus; + + if (sym->result) + type = sym->result->ts.type; + else + type = sym->ts.type; + + if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name) + type = sym->ns->proc_name->ts.type; + + if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type) + && !(gfc_state_stack->previous && gfc_state_stack->previous->previous + && gfc_state_stack->previous->previous->state == COMP_SUBMODULE) + && !sym->attr.module_procedure) + { + if (sym->attr.use_assoc) + gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, " + "use-associated at %L", sym->name, where, sym->module, + &sym->declared_at); + else if (sym->attr.function && sym->attr.result) + gfc_error ("Symbol %qs at %L already has basic type of %s", + sym->ns->proc_name->name, where, gfc_basic_typename (type)); + else + gfc_error ("Symbol %qs at %L already has basic type of %s", sym->name, + where, gfc_basic_typename (type)); + return false; + } + + if (sym->attr.procedure && sym->ts.interface) + { + gfc_error ("Procedure %qs at %L may not have basic type of %s", + sym->name, where, gfc_basic_typename (ts->type)); + return false; + } + + flavor = sym->attr.flavor; + + if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE + || flavor == FL_LABEL + || (flavor == FL_PROCEDURE && sym->attr.subroutine) + || flavor == FL_DERIVED || flavor == FL_NAMELIST) + { + gfc_error ("Symbol %qs at %L cannot have a type", + sym->ns->proc_name ? sym->ns->proc_name->name : sym->name, + where); + return false; + } + + sym->ts = *ts; + return true; +} + + +/* Clears all attributes. */ + +void +gfc_clear_attr (symbol_attribute *attr) +{ + memset (attr, 0, sizeof (symbol_attribute)); +} + + +/* Check for missing attributes in the new symbol. Currently does + nothing, but it's not clear that it is unnecessary yet. */ + +bool +gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED, + locus *where ATTRIBUTE_UNUSED) +{ + + return true; +} + + +/* Copy an attribute to a symbol attribute, bit by bit. Some + attributes have a lot of side-effects but cannot be present given + where we are called from, so we ignore some bits. */ + +bool +gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) +{ + int is_proc_lang_bind_spec; + + /* In line with the other attributes, we only add bits but do not remove + them; cf. also PR 41034. */ + dest->ext_attr |= src->ext_attr; + + if (src->allocatable && !gfc_add_allocatable (dest, where)) + goto fail; + + if (src->automatic && !gfc_add_automatic (dest, NULL, where)) + goto fail; + if (src->dimension && !gfc_add_dimension (dest, NULL, where)) + goto fail; + if (src->codimension && !gfc_add_codimension (dest, NULL, where)) + goto fail; + if (src->contiguous && !gfc_add_contiguous (dest, NULL, where)) + goto fail; + if (src->optional && !gfc_add_optional (dest, where)) + goto fail; + if (src->pointer && !gfc_add_pointer (dest, where)) + goto fail; + if (src->is_protected && !gfc_add_protected (dest, NULL, where)) + goto fail; + if (src->save && !gfc_add_save (dest, src->save, NULL, where)) + goto fail; + if (src->value && !gfc_add_value (dest, NULL, where)) + goto fail; + if (src->volatile_ && !gfc_add_volatile (dest, NULL, where)) + goto fail; + if (src->asynchronous && !gfc_add_asynchronous (dest, NULL, where)) + goto fail; + if (src->threadprivate + && !gfc_add_threadprivate (dest, NULL, where)) + goto fail; + if (src->omp_declare_target + && !gfc_add_omp_declare_target (dest, NULL, where)) + goto fail; + if (src->omp_declare_target_link + && !gfc_add_omp_declare_target_link (dest, NULL, where)) + goto fail; + if (src->oacc_declare_create + && !gfc_add_oacc_declare_create (dest, NULL, where)) + goto fail; + if (src->oacc_declare_copyin + && !gfc_add_oacc_declare_copyin (dest, NULL, where)) + goto fail; + if (src->oacc_declare_deviceptr + && !gfc_add_oacc_declare_deviceptr (dest, NULL, where)) + goto fail; + if (src->oacc_declare_device_resident + && !gfc_add_oacc_declare_device_resident (dest, NULL, where)) + goto fail; + if (src->target && !gfc_add_target (dest, where)) + goto fail; + if (src->dummy && !gfc_add_dummy (dest, NULL, where)) + goto fail; + if (src->result && !gfc_add_result (dest, NULL, where)) + goto fail; + if (src->entry) + dest->entry = 1; + + if (src->in_namelist && !gfc_add_in_namelist (dest, NULL, where)) + goto fail; + + if (src->in_common && !gfc_add_in_common (dest, NULL, where)) + goto fail; + + if (src->generic && !gfc_add_generic (dest, NULL, where)) + goto fail; + if (src->function && !gfc_add_function (dest, NULL, where)) + goto fail; + if (src->subroutine && !gfc_add_subroutine (dest, NULL, where)) + goto fail; + + if (src->sequence && !gfc_add_sequence (dest, NULL, where)) + goto fail; + if (src->elemental && !gfc_add_elemental (dest, where)) + goto fail; + if (src->pure && !gfc_add_pure (dest, where)) + goto fail; + if (src->recursive && !gfc_add_recursive (dest, where)) + goto fail; + + if (src->flavor != FL_UNKNOWN + && !gfc_add_flavor (dest, src->flavor, NULL, where)) + goto fail; + + if (src->intent != INTENT_UNKNOWN + && !gfc_add_intent (dest, src->intent, where)) + goto fail; + + if (src->access != ACCESS_UNKNOWN + && !gfc_add_access (dest, src->access, NULL, where)) + goto fail; + + if (!gfc_missing_attr (dest, where)) + goto fail; + + if (src->cray_pointer && !gfc_add_cray_pointer (dest, where)) + goto fail; + if (src->cray_pointee && !gfc_add_cray_pointee (dest, where)) + goto fail; + + is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0); + if (src->is_bind_c + && !gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)) + return false; + + if (src->is_c_interop) + dest->is_c_interop = 1; + if (src->is_iso_c) + dest->is_iso_c = 1; + + if (src->external && !gfc_add_external (dest, where)) + goto fail; + if (src->intrinsic && !gfc_add_intrinsic (dest, where)) + goto fail; + if (src->proc_pointer) + dest->proc_pointer = 1; + + return true; + +fail: + return false; +} + + +/* A function to generate a dummy argument symbol using that from the + interface declaration. Can be used for the result symbol as well if + the flag is set. */ + +int +gfc_copy_dummy_sym (gfc_symbol **dsym, gfc_symbol *sym, int result) +{ + int rc; + + rc = gfc_get_symbol (sym->name, NULL, dsym); + if (rc) + return rc; + + if (!gfc_add_type (*dsym, &(sym->ts), &gfc_current_locus)) + return 1; + + if (!gfc_copy_attr (&(*dsym)->attr, &(sym->attr), + &gfc_current_locus)) + return 1; + + if ((*dsym)->attr.dimension) + (*dsym)->as = gfc_copy_array_spec (sym->as); + + (*dsym)->attr.class_ok = sym->attr.class_ok; + + if ((*dsym) != NULL && !result + && (!gfc_add_dummy(&(*dsym)->attr, (*dsym)->name, NULL) + || !gfc_missing_attr (&(*dsym)->attr, NULL))) + return 1; + else if ((*dsym) != NULL && result + && (!gfc_add_result(&(*dsym)->attr, (*dsym)->name, NULL) + || !gfc_missing_attr (&(*dsym)->attr, NULL))) + return 1; + + return 0; +} + + +/************** Component name management ************/ + +/* Component names of a derived type form their own little namespaces + that are separate from all other spaces. The space is composed of + a singly linked list of gfc_component structures whose head is + located in the parent symbol. */ + + +/* Add a component name to a symbol. The call fails if the name is + already present. On success, the component pointer is modified to + point to the additional component structure. */ + +bool +gfc_add_component (gfc_symbol *sym, const char *name, + gfc_component **component) +{ + gfc_component *p, *tail; + + /* Check for existing components with the same name, but not for union + components or containers. Unions and maps are anonymous so they have + unique internal names which will never conflict. + Don't use gfc_find_component here because it calls gfc_use_derived, + but the derived type may not be fully defined yet. */ + tail = NULL; + + for (p = sym->components; p; p = p->next) + { + if (strcmp (p->name, name) == 0) + { + gfc_error ("Component %qs at %C already declared at %L", + name, &p->loc); + return false; + } + + tail = p; + } + + if (sym->attr.extension + && gfc_find_component (sym->components->ts.u.derived, + name, true, true, NULL)) + { + gfc_error ("Component %qs at %C already in the parent type " + "at %L", name, &sym->components->ts.u.derived->declared_at); + return false; + } + + /* Allocate a new component. */ + p = gfc_get_component (); + + if (tail == NULL) + sym->components = p; + else + tail->next = p; + + p->name = gfc_get_string ("%s", name); + p->loc = gfc_current_locus; + p->ts.type = BT_UNKNOWN; + + *component = p; + return true; +} + + +/* Recursive function to switch derived types of all symbol in a + namespace. */ + +static void +switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to) +{ + gfc_symbol *sym; + + if (st == NULL) + return; + + sym = st->n.sym; + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from) + sym->ts.u.derived = to; + + switch_types (st->left, from, to); + switch_types (st->right, from, to); +} + + +/* This subroutine is called when a derived type is used in order to + make the final determination about which version to use. The + standard requires that a type be defined before it is 'used', but + such types can appear in IMPLICIT statements before the actual + definition. 'Using' in this context means declaring a variable to + be that type or using the type constructor. + + If a type is used and the components haven't been defined, then we + have to have a derived type in a parent unit. We find the node in + the other namespace and point the symtree node in this namespace to + that node. Further reference to this name point to the correct + node. If we can't find the node in a parent namespace, then we have + an error. + + This subroutine takes a pointer to a symbol node and returns a + pointer to the translated node or NULL for an error. Usually there + is no translation and we return the node we were passed. */ + +gfc_symbol * +gfc_use_derived (gfc_symbol *sym) +{ + gfc_symbol *s; + gfc_typespec *t; + gfc_symtree *st; + int i; + + if (!sym) + return NULL; + + if (sym->attr.unlimited_polymorphic) + return sym; + + if (sym->attr.generic) + sym = gfc_find_dt_in_generic (sym); + + if (sym->components != NULL || sym->attr.zero_comp) + return sym; /* Already defined. */ + + if (sym->ns->parent == NULL) + goto bad; + + if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s)) + { + gfc_error ("Symbol %qs at %C is ambiguous", sym->name); + return NULL; + } + + if (s == NULL || !gfc_fl_struct (s->attr.flavor)) + goto bad; + + /* Get rid of symbol sym, translating all references to s. */ + for (i = 0; i < GFC_LETTERS; i++) + { + t = &sym->ns->default_type[i]; + if (t->u.derived == sym) + t->u.derived = s; + } + + st = gfc_find_symtree (sym->ns->sym_root, sym->name); + st->n.sym = s; + + s->refs++; + + /* Unlink from list of modified symbols. */ + gfc_commit_symbol (sym); + + switch_types (sym->ns->sym_root, sym, s); + + /* TODO: Also have to replace sym -> s in other lists like + namelists, common lists and interface lists. */ + gfc_free_symbol (sym); + + return s; + +bad: + gfc_error ("Derived type %qs at %C is being used before it is defined", + sym->name); + return NULL; +} + + +/* Find the component with the given name in the union type symbol. + If ref is not NULL it will be set to the chain of components through which + the component can actually be accessed. This is necessary for unions because + intermediate structures may be maps, nested structures, or other unions, + all of which may (or must) be 'anonymous' to user code. */ + +static gfc_component * +find_union_component (gfc_symbol *un, const char *name, + bool noaccess, gfc_ref **ref) +{ + gfc_component *m, *check; + gfc_ref *sref, *tmp; + + for (m = un->components; m; m = m->next) + { + check = gfc_find_component (m->ts.u.derived, name, noaccess, true, &tmp); + if (check == NULL) + continue; + + /* Found component somewhere in m; chain the refs together. */ + if (ref) + { + /* Map ref. */ + sref = gfc_get_ref (); + sref->type = REF_COMPONENT; + sref->u.c.component = m; + sref->u.c.sym = m->ts.u.derived; + sref->next = tmp; + + *ref = sref; + } + /* Other checks (such as access) were done in the recursive calls. */ + return check; + } + return NULL; +} + + +/* Recursively append candidate COMPONENT structures to CANDIDATES. Store + the number of total candidates in CANDIDATES_LEN. */ + +static void +lookup_component_fuzzy_find_candidates (gfc_component *component, + char **&candidates, + size_t &candidates_len) +{ + for (gfc_component *p = component; p; p = p->next) + vec_push (candidates, candidates_len, p->name); +} + + +/* Lookup component MEMBER fuzzily, taking names in COMPONENT into account. */ + +static const char* +lookup_component_fuzzy (const char *member, gfc_component *component) +{ + char **candidates = NULL; + size_t candidates_len = 0; + lookup_component_fuzzy_find_candidates (component, candidates, + candidates_len); + return gfc_closest_fuzzy_match (member, candidates); +} + + +/* Given a derived type node and a component name, try to locate the + component structure. Returns the NULL pointer if the component is + not found or the components are private. If noaccess is set, no access + checks are done. If silent is set, an error will not be generated if + the component cannot be found or accessed. + + If ref is not NULL, *ref is set to represent the chain of components + required to get to the ultimate component. + + If the component is simply a direct subcomponent, or is inherited from a + parent derived type in the given derived type, this is a single ref with its + component set to the returned component. + + Otherwise, *ref is constructed as a chain of subcomponents. This occurs + when the component is found through an implicit chain of nested union and + map components. Unions and maps are "anonymous" substructures in FORTRAN + which cannot be explicitly referenced, but the reference chain must be + considered as in C for backend translation to correctly compute layouts. + (For example, x.a may refer to x->(UNION)->(MAP)->(UNION)->(MAP)->a). */ + +gfc_component * +gfc_find_component (gfc_symbol *sym, const char *name, + bool noaccess, bool silent, gfc_ref **ref) +{ + gfc_component *p, *check; + gfc_ref *sref = NULL, *tmp = NULL; + + if (name == NULL || sym == NULL) + return NULL; + + if (sym->attr.flavor == FL_DERIVED) + sym = gfc_use_derived (sym); + else + gcc_assert (gfc_fl_struct (sym->attr.flavor)); + + if (sym == NULL) + return NULL; + + /* Handle UNIONs specially - mutually recursive with gfc_find_component. */ + if (sym->attr.flavor == FL_UNION) + return find_union_component (sym, name, noaccess, ref); + + if (ref) *ref = NULL; + for (p = sym->components; p; p = p->next) + { + /* Nest search into union's maps. */ + if (p->ts.type == BT_UNION) + { + check = find_union_component (p->ts.u.derived, name, noaccess, &tmp); + if (check != NULL) + { + /* Union ref. */ + if (ref) + { + sref = gfc_get_ref (); + sref->type = REF_COMPONENT; + sref->u.c.component = p; + sref->u.c.sym = p->ts.u.derived; + sref->next = tmp; + *ref = sref; + } + return check; + } + } + else if (strcmp (p->name, name) == 0) + break; + + continue; + } + + if (p && sym->attr.use_assoc && !noaccess) + { + bool is_parent_comp = sym->attr.extension && (p == sym->components); + if (p->attr.access == ACCESS_PRIVATE || + (p->attr.access != ACCESS_PUBLIC + && sym->component_access == ACCESS_PRIVATE + && !is_parent_comp)) + { + if (!silent) + gfc_error ("Component %qs at %C is a PRIVATE component of %qs", + name, sym->name); + return NULL; + } + } + + if (p == NULL + && sym->attr.extension + && sym->components->ts.type == BT_DERIVED) + { + p = gfc_find_component (sym->components->ts.u.derived, name, + noaccess, silent, ref); + /* Do not overwrite the error. */ + if (p == NULL) + return p; + } + + if (p == NULL && !silent) + { + const char *guessed = lookup_component_fuzzy (name, sym->components); + if (guessed) + gfc_error ("%qs at %C is not a member of the %qs structure" + "; did you mean %qs?", + name, sym->name, guessed); + else + gfc_error ("%qs at %C is not a member of the %qs structure", + name, sym->name); + } + + /* Component was found; build the ultimate component reference. */ + if (p != NULL && ref) + { + tmp = gfc_get_ref (); + tmp->type = REF_COMPONENT; + tmp->u.c.component = p; + tmp->u.c.sym = sym; + /* Link the final component ref to the end of the chain of subrefs. */ + if (sref) + { + *ref = sref; + for (; sref->next; sref = sref->next) + ; + sref->next = tmp; + } + else + *ref = tmp; + } + + return p; +} + + +/* Given a symbol, free all of the component structures and everything + they point to. */ + +static void +free_components (gfc_component *p) +{ + gfc_component *q; + + for (; p; p = q) + { + q = p->next; + + gfc_free_array_spec (p->as); + gfc_free_expr (p->initializer); + if (p->kind_expr) + gfc_free_expr (p->kind_expr); + if (p->param_list) + gfc_free_actual_arglist (p->param_list); + free (p->tb); + p->tb = NULL; + free (p); + } +} + + +/******************** Statement label management ********************/ + +/* Comparison function for statement labels, used for managing the + binary tree. */ + +static int +compare_st_labels (void *a1, void *b1) +{ + int a = ((gfc_st_label *) a1)->value; + int b = ((gfc_st_label *) b1)->value; + + return (b - a); +} + + +/* Free a single gfc_st_label structure, making sure the tree is not + messed up. This function is called only when some parse error + occurs. */ + +void +gfc_free_st_label (gfc_st_label *label) +{ + + if (label == NULL) + return; + + gfc_delete_bbt (&label->ns->st_labels, label, compare_st_labels); + + if (label->format != NULL) + gfc_free_expr (label->format); + + free (label); +} + + +/* Free a whole tree of gfc_st_label structures. */ + +static void +free_st_labels (gfc_st_label *label) +{ + + if (label == NULL) + return; + + free_st_labels (label->left); + free_st_labels (label->right); + + if (label->format != NULL) + gfc_free_expr (label->format); + free (label); +} + + +/* Given a label number, search for and return a pointer to the label + structure, creating it if it does not exist. */ + +gfc_st_label * +gfc_get_st_label (int labelno) +{ + gfc_st_label *lp; + gfc_namespace *ns; + + if (gfc_current_state () == COMP_DERIVED) + ns = gfc_current_block ()->f2k_derived; + else + { + /* Find the namespace of the scoping unit: + If we're in a BLOCK construct, jump to the parent namespace. */ + ns = gfc_current_ns; + while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL) + ns = ns->parent; + } + + /* First see if the label is already in this namespace. */ + lp = ns->st_labels; + while (lp) + { + if (lp->value == labelno) + return lp; + + if (lp->value < labelno) + lp = lp->left; + else + lp = lp->right; + } + + lp = XCNEW (gfc_st_label); + + lp->value = labelno; + lp->defined = ST_LABEL_UNKNOWN; + lp->referenced = ST_LABEL_UNKNOWN; + lp->ns = ns; + + gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels); + + return lp; +} + + +/* Called when a statement with a statement label is about to be + accepted. We add the label to the list of the current namespace, + making sure it hasn't been defined previously and referenced + correctly. */ + +void +gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus) +{ + int labelno; + + labelno = lp->value; + + if (lp->defined != ST_LABEL_UNKNOWN) + gfc_error ("Duplicate statement label %d at %L and %L", labelno, + &lp->where, label_locus); + else + { + lp->where = *label_locus; + + switch (type) + { + case ST_LABEL_FORMAT: + if (lp->referenced == ST_LABEL_TARGET + || lp->referenced == ST_LABEL_DO_TARGET) + gfc_error ("Label %d at %C already referenced as branch target", + labelno); + else + lp->defined = ST_LABEL_FORMAT; + + break; + + case ST_LABEL_TARGET: + case ST_LABEL_DO_TARGET: + if (lp->referenced == ST_LABEL_FORMAT) + gfc_error ("Label %d at %C already referenced as a format label", + labelno); + else + lp->defined = type; + + if (lp->referenced == ST_LABEL_DO_TARGET && type != ST_LABEL_DO_TARGET + && !gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL, + "DO termination statement which is not END DO" + " or CONTINUE with label %d at %C", labelno)) + return; + break; + + default: + lp->defined = ST_LABEL_BAD_TARGET; + lp->referenced = ST_LABEL_BAD_TARGET; + } + } +} + + +/* Reference a label. Given a label and its type, see if that + reference is consistent with what is known about that label, + updating the unknown state. Returns false if something goes + wrong. */ + +bool +gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type) +{ + gfc_sl_type label_type; + int labelno; + bool rc; + + if (lp == NULL) + return true; + + labelno = lp->value; + + if (lp->defined != ST_LABEL_UNKNOWN) + label_type = lp->defined; + else + { + label_type = lp->referenced; + lp->where = gfc_current_locus; + } + + if (label_type == ST_LABEL_FORMAT + && (type == ST_LABEL_TARGET || type == ST_LABEL_DO_TARGET)) + { + gfc_error ("Label %d at %C previously used as a FORMAT label", labelno); + rc = false; + goto done; + } + + if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_DO_TARGET + || label_type == ST_LABEL_BAD_TARGET) + && type == ST_LABEL_FORMAT) + { + gfc_error ("Label %d at %C previously used as branch target", labelno); + rc = false; + goto done; + } + + if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET + && !gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL, + "Shared DO termination label %d at %C", labelno)) + return false; + + if (type == ST_LABEL_DO_TARGET + && !gfc_notify_std (GFC_STD_F2018_OBS, "Labeled DO statement " + "at %L", &gfc_current_locus)) + return false; + + if (lp->referenced != ST_LABEL_DO_TARGET) + lp->referenced = type; + rc = true; + +done: + return rc; +} + + +/************** Symbol table management subroutines ****************/ + +/* Basic details: Fortran 95 requires a potentially unlimited number + of distinct namespaces when compiling a program unit. This case + occurs during a compilation of internal subprograms because all of + the internal subprograms must be read before we can start + generating code for the host. + + Given the tricky nature of the Fortran grammar, we must be able to + undo changes made to a symbol table if the current interpretation + of a statement is found to be incorrect. Whenever a symbol is + looked up, we make a copy of it and link to it. All of these + symbols are kept in a vector so that we can commit or + undo the changes at a later time. + + A symtree may point to a symbol node outside of its namespace. In + this case, that symbol has been used as a host associated variable + at some previous time. */ + +/* Allocate a new namespace structure. Copies the implicit types from + PARENT if PARENT_TYPES is set. */ + +gfc_namespace * +gfc_get_namespace (gfc_namespace *parent, int parent_types) +{ + gfc_namespace *ns; + gfc_typespec *ts; + int in; + int i; + + ns = XCNEW (gfc_namespace); + ns->sym_root = NULL; + ns->uop_root = NULL; + ns->tb_sym_root = NULL; + ns->finalizers = NULL; + ns->default_access = ACCESS_UNKNOWN; + ns->parent = parent; + + for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++) + { + ns->operator_access[in] = ACCESS_UNKNOWN; + ns->tb_op[in] = NULL; + } + + /* Initialize default implicit types. */ + for (i = 'a'; i <= 'z'; i++) + { + ns->set_flag[i - 'a'] = 0; + ts = &ns->default_type[i - 'a']; + + if (parent_types && ns->parent != NULL) + { + /* Copy parent settings. */ + *ts = ns->parent->default_type[i - 'a']; + continue; + } + + if (flag_implicit_none != 0) + { + gfc_clear_ts (ts); + continue; + } + + if ('i' <= i && i <= 'n') + { + ts->type = BT_INTEGER; + ts->kind = gfc_default_integer_kind; + } + else + { + ts->type = BT_REAL; + ts->kind = gfc_default_real_kind; + } + } + + ns->refs = 1; + + return ns; +} + + +/* Comparison function for symtree nodes. */ + +static int +compare_symtree (void *_st1, void *_st2) +{ + gfc_symtree *st1, *st2; + + st1 = (gfc_symtree *) _st1; + st2 = (gfc_symtree *) _st2; + + return strcmp (st1->name, st2->name); +} + + +/* Allocate a new symtree node and associate it with the new symbol. */ + +gfc_symtree * +gfc_new_symtree (gfc_symtree **root, const char *name) +{ + gfc_symtree *st; + + st = XCNEW (gfc_symtree); + st->name = gfc_get_string ("%s", name); + + gfc_insert_bbt (root, st, compare_symtree); + return st; +} + + +/* Delete a symbol from the tree. Does not free the symbol itself! */ + +void +gfc_delete_symtree (gfc_symtree **root, const char *name) +{ + gfc_symtree st, *st0; + const char *p; + + /* Submodules are marked as mod.submod. When freeing a submodule + symbol, the symtree only has "submod", so adjust that here. */ + + p = strrchr(name, '.'); + if (p) + p++; + else + p = name; + + st0 = gfc_find_symtree (*root, p); + + st.name = gfc_get_string ("%s", p); + gfc_delete_bbt (root, &st, compare_symtree); + + free (st0); +} + + +/* Given a root symtree node and a name, try to find the symbol within + the namespace. Returns NULL if the symbol is not found. */ + +gfc_symtree * +gfc_find_symtree (gfc_symtree *st, const char *name) +{ + int c; + + while (st != NULL) + { + c = strcmp (name, st->name); + if (c == 0) + return st; + + st = (c < 0) ? st->left : st->right; + } + + return NULL; +} + + +/* Return a symtree node with a name that is guaranteed to be unique + within the namespace and corresponds to an illegal fortran name. */ + +gfc_symtree * +gfc_get_unique_symtree (gfc_namespace *ns) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + static int serial = 0; + + sprintf (name, "@%d", serial++); + return gfc_new_symtree (&ns->sym_root, name); +} + + +/* Given a name find a user operator node, creating it if it doesn't + exist. These are much simpler than symbols because they can't be + ambiguous with one another. */ + +gfc_user_op * +gfc_get_uop (const char *name) +{ + gfc_user_op *uop; + gfc_symtree *st; + gfc_namespace *ns = gfc_current_ns; + + if (ns->omp_udr_ns) + ns = ns->parent; + st = gfc_find_symtree (ns->uop_root, name); + if (st != NULL) + return st->n.uop; + + st = gfc_new_symtree (&ns->uop_root, name); + + uop = st->n.uop = XCNEW (gfc_user_op); + uop->name = gfc_get_string ("%s", name); + uop->access = ACCESS_UNKNOWN; + uop->ns = ns; + + return uop; +} + + +/* Given a name find the user operator node. Returns NULL if it does + not exist. */ + +gfc_user_op * +gfc_find_uop (const char *name, gfc_namespace *ns) +{ + gfc_symtree *st; + + if (ns == NULL) + ns = gfc_current_ns; + + st = gfc_find_symtree (ns->uop_root, name); + return (st == NULL) ? NULL : st->n.uop; +} + + +/* Update a symbol's common_block field, and take care of the associated + memory management. */ + +static void +set_symbol_common_block (gfc_symbol *sym, gfc_common_head *common_block) +{ + if (sym->common_block == common_block) + return; + + if (sym->common_block && sym->common_block->name[0] != '\0') + { + sym->common_block->refs--; + if (sym->common_block->refs == 0) + free (sym->common_block); + } + sym->common_block = common_block; +} + + +/* Remove a gfc_symbol structure and everything it points to. */ + +void +gfc_free_symbol (gfc_symbol *&sym) +{ + + if (sym == NULL) + return; + + gfc_free_array_spec (sym->as); + + free_components (sym->components); + + gfc_free_expr (sym->value); + + gfc_free_namelist (sym->namelist); + + if (sym->ns != sym->formal_ns) + gfc_free_namespace (sym->formal_ns); + + if (!sym->attr.generic_copy) + gfc_free_interface (sym->generic); + + gfc_free_formal_arglist (sym->formal); + + gfc_free_namespace (sym->f2k_derived); + + set_symbol_common_block (sym, NULL); + + if (sym->param_list) + gfc_free_actual_arglist (sym->param_list); + + free (sym); + sym = NULL; +} + + +/* Decrease the reference counter and free memory when we reach zero. */ + +void +gfc_release_symbol (gfc_symbol *&sym) +{ + if (sym == NULL) + return; + + if (sym->formal_ns != NULL && sym->refs == 2 && sym->formal_ns != sym->ns + && (!sym->attr.entry || !sym->module)) + { + /* As formal_ns contains a reference to sym, delete formal_ns just + before the deletion of sym. */ + gfc_namespace *ns = sym->formal_ns; + sym->formal_ns = NULL; + gfc_free_namespace (ns); + } + + sym->refs--; + if (sym->refs > 0) + return; + + gcc_assert (sym->refs == 0); + gfc_free_symbol (sym); +} + + +/* Allocate and initialize a new symbol node. */ + +gfc_symbol * +gfc_new_symbol (const char *name, gfc_namespace *ns) +{ + gfc_symbol *p; + + p = XCNEW (gfc_symbol); + + gfc_clear_ts (&p->ts); + gfc_clear_attr (&p->attr); + p->ns = ns; + p->declared_at = gfc_current_locus; + p->name = gfc_get_string ("%s", name); + + return p; +} + + +/* Generate an error if a symbol is ambiguous, and set the error flag + on it. */ + +static void +ambiguous_symbol (const char *name, gfc_symtree *st) +{ + + if (st->n.sym->error) + return; + + if (st->n.sym->module) + gfc_error ("Name %qs at %C is an ambiguous reference to %qs " + "from module %qs", name, st->n.sym->name, st->n.sym->module); + else + gfc_error ("Name %qs at %C is an ambiguous reference to %qs " + "from current program unit", name, st->n.sym->name); + + st->n.sym->error = 1; +} + + +/* If we're in a SELECT TYPE block, check if the variable 'st' matches any + selector on the stack. If yes, replace it by the corresponding temporary. */ + +static void +select_type_insert_tmp (gfc_symtree **st) +{ + gfc_select_type_stack *stack = select_type_stack; + for (; stack; stack = stack->prev) + if ((*st)->n.sym == stack->selector && stack->tmp) + { + *st = stack->tmp; + select_type_insert_tmp (st); + return; + } +} + + +/* Look for a symtree in the current procedure -- that is, go up to + parent namespaces but only if inside a BLOCK. Returns NULL if not found. */ + +gfc_symtree* +gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns) +{ + while (ns) + { + gfc_symtree* st = gfc_find_symtree (ns->sym_root, name); + if (st) + return st; + + if (!ns->construct_entities) + break; + ns = ns->parent; + } + + return NULL; +} + + +/* Search for a symtree starting in the current namespace, resorting to + any parent namespaces if requested by a nonzero parent_flag. + Returns nonzero if the name is ambiguous. */ + +int +gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag, + gfc_symtree **result) +{ + gfc_symtree *st; + + if (ns == NULL) + ns = gfc_current_ns; + + do + { + st = gfc_find_symtree (ns->sym_root, name); + if (st != NULL) + { + select_type_insert_tmp (&st); + + *result = st; + /* Ambiguous generic interfaces are permitted, as long + as the specific interfaces are different. */ + if (st->ambiguous && !st->n.sym->attr.generic) + { + ambiguous_symbol (name, st); + return 1; + } + + return 0; + } + + if (!parent_flag) + break; + + /* Don't escape an interface block. */ + if (ns && !ns->has_import_set + && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY) + break; + + ns = ns->parent; + } + while (ns != NULL); + + if (gfc_current_state() == COMP_DERIVED + && gfc_current_block ()->attr.pdt_template) + { + gfc_symbol *der = gfc_current_block (); + for (; der; der = gfc_get_derived_super_type (der)) + { + if (der->f2k_derived && der->f2k_derived->sym_root) + { + st = gfc_find_symtree (der->f2k_derived->sym_root, name); + if (st) + break; + } + } + *result = st; + return 0; + } + + *result = NULL; + + return 0; +} + + +/* Same, but returns the symbol instead. */ + +int +gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag, + gfc_symbol **result) +{ + gfc_symtree *st; + int i; + + i = gfc_find_sym_tree (name, ns, parent_flag, &st); + + if (st == NULL) + *result = NULL; + else + *result = st->n.sym; + + return i; +} + + +/* Tells whether there is only one set of changes in the stack. */ + +static bool +single_undo_checkpoint_p (void) +{ + if (latest_undo_chgset == &default_undo_chgset_var) + { + gcc_assert (latest_undo_chgset->previous == NULL); + return true; + } + else + { + gcc_assert (latest_undo_chgset->previous != NULL); + return false; + } +} + +/* Save symbol with the information necessary to back it out. */ + +void +gfc_save_symbol_data (gfc_symbol *sym) +{ + gfc_symbol *s; + unsigned i; + + if (!single_undo_checkpoint_p ()) + { + /* If there is more than one change set, look for the symbol in the + current one. If it is found there, we can reuse it. */ + FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s) + if (s == sym) + { + gcc_assert (sym->gfc_new || sym->old_symbol != NULL); + return; + } + } + else if (sym->gfc_new || sym->old_symbol != NULL) + return; + + s = XCNEW (gfc_symbol); + *s = *sym; + sym->old_symbol = s; + sym->gfc_new = 0; + + latest_undo_chgset->syms.safe_push (sym); +} + + +/* Given a name, find a symbol, or create it if it does not exist yet + in the current namespace. If the symbol is found we make sure that + it's OK. + + The integer return code indicates + 0 All OK + 1 The symbol name was ambiguous + 2 The name meant to be established was already host associated. + + So if the return value is nonzero, then an error was issued. */ + +int +gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result, + bool allow_subroutine) +{ + gfc_symtree *st; + gfc_symbol *p; + + /* This doesn't usually happen during resolution. */ + if (ns == NULL) + ns = gfc_current_ns; + + /* Try to find the symbol in ns. */ + st = gfc_find_symtree (ns->sym_root, name); + + if (st == NULL && ns->omp_udr_ns) + { + ns = ns->parent; + st = gfc_find_symtree (ns->sym_root, name); + } + + if (st == NULL) + { + /* If not there, create a new symbol. */ + p = gfc_new_symbol (name, ns); + + /* Add to the list of tentative symbols. */ + p->old_symbol = NULL; + p->mark = 1; + p->gfc_new = 1; + latest_undo_chgset->syms.safe_push (p); + + st = gfc_new_symtree (&ns->sym_root, name); + st->n.sym = p; + p->refs++; + + } + else + { + /* Make sure the existing symbol is OK. Ambiguous + generic interfaces are permitted, as long as the + specific interfaces are different. */ + if (st->ambiguous && !st->n.sym->attr.generic) + { + ambiguous_symbol (name, st); + return 1; + } + + p = st->n.sym; + if (p->ns != ns && (!p->attr.function || ns->proc_name != p) + && !(allow_subroutine && p->attr.subroutine) + && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY + && (ns->has_import_set || p->attr.imported))) + { + /* Symbol is from another namespace. */ + gfc_error ("Symbol %qs at %C has already been host associated", + name); + return 2; + } + + p->mark = 1; + + /* Copy in case this symbol is changed. */ + gfc_save_symbol_data (p); + } + + *result = st; + return 0; +} + + +int +gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result) +{ + gfc_symtree *st; + int i; + + i = gfc_get_sym_tree (name, ns, &st, false); + if (i != 0) + return i; + + if (st) + *result = st->n.sym; + else + *result = NULL; + return i; +} + + +/* Subroutine that searches for a symbol, creating it if it doesn't + exist, but tries to host-associate the symbol if possible. */ + +int +gfc_get_ha_sym_tree (const char *name, gfc_symtree **result) +{ + gfc_symtree *st; + int i; + + i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st); + + if (st != NULL) + { + gfc_save_symbol_data (st->n.sym); + *result = st; + return i; + } + + i = gfc_find_sym_tree (name, gfc_current_ns, 1, &st); + if (i) + return i; + + if (st != NULL) + { + *result = st; + return 0; + } + + return gfc_get_sym_tree (name, gfc_current_ns, result, false); +} + + +int +gfc_get_ha_symbol (const char *name, gfc_symbol **result) +{ + int i; + gfc_symtree *st; + + i = gfc_get_ha_sym_tree (name, &st); + + if (st) + *result = st->n.sym; + else + *result = NULL; + + return i; +} + + +/* Search for the symtree belonging to a gfc_common_head; we cannot use + head->name as the common_root symtree's name might be mangled. */ + +static gfc_symtree * +find_common_symtree (gfc_symtree *st, gfc_common_head *head) +{ + + gfc_symtree *result; + + if (st == NULL) + return NULL; + + if (st->n.common == head) + return st; + + result = find_common_symtree (st->left, head); + if (!result) + result = find_common_symtree (st->right, head); + + return result; +} + + +/* Restore previous state of symbol. Just copy simple stuff. */ + +static void +restore_old_symbol (gfc_symbol *p) +{ + gfc_symbol *old; + + p->mark = 0; + old = p->old_symbol; + + p->ts.type = old->ts.type; + p->ts.kind = old->ts.kind; + + p->attr = old->attr; + + if (p->value != old->value) + { + gcc_checking_assert (old->value == NULL); + gfc_free_expr (p->value); + p->value = NULL; + } + + if (p->as != old->as) + { + if (p->as) + gfc_free_array_spec (p->as); + p->as = old->as; + } + + p->generic = old->generic; + p->component_access = old->component_access; + + if (p->namelist != NULL && old->namelist == NULL) + { + gfc_free_namelist (p->namelist); + p->namelist = NULL; + } + else + { + if (p->namelist_tail != old->namelist_tail) + { + gfc_free_namelist (old->namelist_tail->next); + old->namelist_tail->next = NULL; + } + } + + p->namelist_tail = old->namelist_tail; + + if (p->formal != old->formal) + { + gfc_free_formal_arglist (p->formal); + p->formal = old->formal; + } + + set_symbol_common_block (p, old->common_block); + p->common_head = old->common_head; + + p->old_symbol = old->old_symbol; + free (old); +} + + +/* Frees the internal data of a gfc_undo_change_set structure. Doesn't free + the structure itself. */ + +static void +free_undo_change_set_data (gfc_undo_change_set &cs) +{ + cs.syms.release (); + cs.tbps.release (); +} + + +/* Given a change set pointer, free its target's contents and update it with + the address of the previous change set. Note that only the contents are + freed, not the target itself (the contents' container). It is not a problem + as the latter will be a local variable usually. */ + +static void +pop_undo_change_set (gfc_undo_change_set *&cs) +{ + free_undo_change_set_data (*cs); + cs = cs->previous; +} + + +static void free_old_symbol (gfc_symbol *sym); + + +/* Merges the current change set into the previous one. The changes themselves + are left untouched; only one checkpoint is forgotten. */ + +void +gfc_drop_last_undo_checkpoint (void) +{ + gfc_symbol *s, *t; + unsigned i, j; + + FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s) + { + /* No need to loop in this case. */ + if (s->old_symbol == NULL) + continue; + + /* Remove the duplicate symbols. */ + FOR_EACH_VEC_ELT (latest_undo_chgset->previous->syms, j, t) + if (t == s) + { + latest_undo_chgset->previous->syms.unordered_remove (j); + + /* S->OLD_SYMBOL is the backup symbol for S as it was at the + last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL + shall contain from now on the backup symbol for S as it was + at the checkpoint before. */ + if (s->old_symbol->gfc_new) + { + gcc_assert (s->old_symbol->old_symbol == NULL); + s->gfc_new = s->old_symbol->gfc_new; + free_old_symbol (s); + } + else + restore_old_symbol (s->old_symbol); + break; + } + } + + latest_undo_chgset->previous->syms.safe_splice (latest_undo_chgset->syms); + latest_undo_chgset->previous->tbps.safe_splice (latest_undo_chgset->tbps); + + pop_undo_change_set (latest_undo_chgset); +} + + +/* Undoes all the changes made to symbols since the previous checkpoint. + This subroutine is made simpler due to the fact that attributes are + never removed once added. */ + +void +gfc_restore_last_undo_checkpoint (void) +{ + gfc_symbol *p; + unsigned i; + + FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p) + { + /* Symbol in a common block was new. Or was old and just put in common */ + if (p->common_block + && (p->gfc_new || !p->old_symbol->common_block)) + { + /* If the symbol was added to any common block, it + needs to be removed to stop the resolver looking + for a (possibly) dead symbol. */ + if (p->common_block->head == p && !p->common_next) + { + gfc_symtree st, *st0; + st0 = find_common_symtree (p->ns->common_root, + p->common_block); + if (st0) + { + st.name = st0->name; + gfc_delete_bbt (&p->ns->common_root, &st, compare_symtree); + free (st0); + } + } + + if (p->common_block->head == p) + p->common_block->head = p->common_next; + else + { + gfc_symbol *cparent, *csym; + + cparent = p->common_block->head; + csym = cparent->common_next; + + while (csym != p) + { + cparent = csym; + csym = csym->common_next; + } + + gcc_assert(cparent->common_next == p); + cparent->common_next = csym->common_next; + } + p->common_next = NULL; + } + if (p->gfc_new) + { + /* The derived type is saved in the symtree with the first + letter capitalized; the all lower-case version to the + derived type contains its associated generic function. */ + if (gfc_fl_struct (p->attr.flavor)) + gfc_delete_symtree (&p->ns->sym_root,gfc_dt_upper_string (p->name)); + else + gfc_delete_symtree (&p->ns->sym_root, p->name); + + gfc_release_symbol (p); + } + else + restore_old_symbol (p); + } + + latest_undo_chgset->syms.truncate (0); + latest_undo_chgset->tbps.truncate (0); + + if (!single_undo_checkpoint_p ()) + pop_undo_change_set (latest_undo_chgset); +} + + +/* Makes sure that there is only one set of changes; in other words we haven't + forgotten to pair a call to gfc_new_checkpoint with a call to either + gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */ + +static void +enforce_single_undo_checkpoint (void) +{ + gcc_checking_assert (single_undo_checkpoint_p ()); +} + + +/* Undoes all the changes made to symbols in the current statement. */ + +void +gfc_undo_symbols (void) +{ + enforce_single_undo_checkpoint (); + gfc_restore_last_undo_checkpoint (); +} + + +/* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the + components of old_symbol that might need deallocation are the "allocatables" + that are restored in gfc_undo_symbols(), with two exceptions: namelist and + namelist_tail. In case these differ between old_symbol and sym, it's just + because sym->namelist has gotten a few more items. */ + +static void +free_old_symbol (gfc_symbol *sym) +{ + + if (sym->old_symbol == NULL) + return; + + if (sym->old_symbol->as != sym->as) + gfc_free_array_spec (sym->old_symbol->as); + + if (sym->old_symbol->value != sym->value) + gfc_free_expr (sym->old_symbol->value); + + if (sym->old_symbol->formal != sym->formal) + gfc_free_formal_arglist (sym->old_symbol->formal); + + free (sym->old_symbol); + sym->old_symbol = NULL; +} + + +/* Makes the changes made in the current statement permanent-- gets + rid of undo information. */ + +void +gfc_commit_symbols (void) +{ + gfc_symbol *p; + gfc_typebound_proc *tbp; + unsigned i; + + enforce_single_undo_checkpoint (); + + FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p) + { + p->mark = 0; + p->gfc_new = 0; + free_old_symbol (p); + } + latest_undo_chgset->syms.truncate (0); + + FOR_EACH_VEC_ELT (latest_undo_chgset->tbps, i, tbp) + tbp->error = 0; + latest_undo_chgset->tbps.truncate (0); +} + + +/* Makes the changes made in one symbol permanent -- gets rid of undo + information. */ + +void +gfc_commit_symbol (gfc_symbol *sym) +{ + gfc_symbol *p; + unsigned i; + + enforce_single_undo_checkpoint (); + + FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p) + if (p == sym) + { + latest_undo_chgset->syms.unordered_remove (i); + break; + } + + sym->mark = 0; + sym->gfc_new = 0; + + free_old_symbol (sym); +} + + +/* Recursively free trees containing type-bound procedures. */ + +static void +free_tb_tree (gfc_symtree *t) +{ + if (t == NULL) + return; + + free_tb_tree (t->left); + free_tb_tree (t->right); + + /* TODO: Free type-bound procedure u.generic */ + free (t->n.tb); + t->n.tb = NULL; + free (t); +} + + +/* Recursive function that deletes an entire tree and all the common + head structures it points to. */ + +static void +free_common_tree (gfc_symtree * common_tree) +{ + if (common_tree == NULL) + return; + + free_common_tree (common_tree->left); + free_common_tree (common_tree->right); + + free (common_tree); +} + + +/* Recursive function that deletes an entire tree and all the common + head structures it points to. */ + +static void +free_omp_udr_tree (gfc_symtree * omp_udr_tree) +{ + if (omp_udr_tree == NULL) + return; + + free_omp_udr_tree (omp_udr_tree->left); + free_omp_udr_tree (omp_udr_tree->right); + + gfc_free_omp_udr (omp_udr_tree->n.omp_udr); + free (omp_udr_tree); +} + + +/* Recursive function that deletes an entire tree and all the user + operator nodes that it contains. */ + +static void +free_uop_tree (gfc_symtree *uop_tree) +{ + if (uop_tree == NULL) + return; + + free_uop_tree (uop_tree->left); + free_uop_tree (uop_tree->right); + + gfc_free_interface (uop_tree->n.uop->op); + free (uop_tree->n.uop); + free (uop_tree); +} + + +/* Recursive function that deletes an entire tree and all the symbols + that it contains. */ + +static void +free_sym_tree (gfc_symtree *sym_tree) +{ + if (sym_tree == NULL) + return; + + free_sym_tree (sym_tree->left); + free_sym_tree (sym_tree->right); + + gfc_release_symbol (sym_tree->n.sym); + free (sym_tree); +} + + +/* Free the gfc_equiv_info's. */ + +static void +gfc_free_equiv_infos (gfc_equiv_info *s) +{ + if (s == NULL) + return; + gfc_free_equiv_infos (s->next); + free (s); +} + + +/* Free the gfc_equiv_lists. */ + +static void +gfc_free_equiv_lists (gfc_equiv_list *l) +{ + if (l == NULL) + return; + gfc_free_equiv_lists (l->next); + gfc_free_equiv_infos (l->equiv); + free (l); +} + + +/* Free a finalizer procedure list. */ + +void +gfc_free_finalizer (gfc_finalizer* el) +{ + if (el) + { + gfc_release_symbol (el->proc_sym); + free (el); + } +} + +static void +gfc_free_finalizer_list (gfc_finalizer* list) +{ + while (list) + { + gfc_finalizer* current = list; + list = list->next; + gfc_free_finalizer (current); + } +} + + +/* Create a new gfc_charlen structure and add it to a namespace. + If 'old_cl' is given, the newly created charlen will be a copy of it. */ + +gfc_charlen* +gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl) +{ + gfc_charlen *cl; + + cl = gfc_get_charlen (); + + /* Copy old_cl. */ + if (old_cl) + { + cl->length = gfc_copy_expr (old_cl->length); + cl->length_from_typespec = old_cl->length_from_typespec; + cl->backend_decl = old_cl->backend_decl; + cl->passed_length = old_cl->passed_length; + cl->resolved = old_cl->resolved; + } + + /* Put into namespace. */ + cl->next = ns->cl_list; + ns->cl_list = cl; + + return cl; +} + + +/* Free the charlen list from cl to end (end is not freed). + Free the whole list if end is NULL. */ + +static void +gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end) +{ + gfc_charlen *cl2; + + for (; cl != end; cl = cl2) + { + gcc_assert (cl); + + cl2 = cl->next; + gfc_free_expr (cl->length); + free (cl); + } +} + + +/* Free entry list structs. */ + +static void +free_entry_list (gfc_entry_list *el) +{ + gfc_entry_list *next; + + if (el == NULL) + return; + + next = el->next; + free (el); + free_entry_list (next); +} + + +/* Free a namespace structure and everything below it. Interface + lists associated with intrinsic operators are not freed. These are + taken care of when a specific name is freed. */ + +void +gfc_free_namespace (gfc_namespace *&ns) +{ + gfc_namespace *p, *q; + int i; + gfc_was_finalized *f; + + if (ns == NULL) + return; + + ns->refs--; + if (ns->refs > 0) + return; + + gcc_assert (ns->refs == 0); + + gfc_free_statements (ns->code); + + free_sym_tree (ns->sym_root); + free_uop_tree (ns->uop_root); + free_common_tree (ns->common_root); + free_omp_udr_tree (ns->omp_udr_root); + free_tb_tree (ns->tb_sym_root); + free_tb_tree (ns->tb_uop_root); + gfc_free_finalizer_list (ns->finalizers); + gfc_free_omp_declare_simd_list (ns->omp_declare_simd); + gfc_free_omp_declare_variant_list (ns->omp_declare_variant); + gfc_free_charlen (ns->cl_list, NULL); + free_st_labels (ns->st_labels); + + free_entry_list (ns->entries); + gfc_free_equiv (ns->equiv); + gfc_free_equiv_lists (ns->equiv_lists); + gfc_free_use_stmts (ns->use_stmts); + + for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) + gfc_free_interface (ns->op[i]); + + gfc_free_data (ns->data); + + /* Free all the expr + component combinations that have been + finalized. */ + f = ns->was_finalized; + while (f) + { + gfc_was_finalized* current = f; + f = f->next; + free (current); + } + + p = ns->contained; + free (ns); + ns = NULL; + + /* Recursively free any contained namespaces. */ + while (p != NULL) + { + q = p; + p = p->sibling; + gfc_free_namespace (q); + } +} + + +void +gfc_symbol_init_2 (void) +{ + + gfc_current_ns = gfc_get_namespace (NULL, 0); +} + + +void +gfc_symbol_done_2 (void) +{ + if (gfc_current_ns != NULL) + { + /* free everything from the root. */ + while (gfc_current_ns->parent != NULL) + gfc_current_ns = gfc_current_ns->parent; + gfc_free_namespace (gfc_current_ns); + gfc_current_ns = NULL; + } + gfc_derived_types = NULL; + + enforce_single_undo_checkpoint (); + free_undo_change_set_data (*latest_undo_chgset); +} + + +/* Count how many nodes a symtree has. */ + +static unsigned +count_st_nodes (const gfc_symtree *st) +{ + unsigned nodes; + if (!st) + return 0; + + nodes = count_st_nodes (st->left); + nodes++; + nodes += count_st_nodes (st->right); + + return nodes; +} + + +/* Convert symtree tree into symtree vector. */ + +static unsigned +fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr) +{ + if (!st) + return node_cntr; + + node_cntr = fill_st_vector (st->left, st_vec, node_cntr); + st_vec[node_cntr++] = st; + node_cntr = fill_st_vector (st->right, st_vec, node_cntr); + + return node_cntr; +} + + +/* Traverse namespace. As the functions might modify the symtree, we store the + symtree as a vector and operate on this vector. Note: We assume that + sym_func or st_func never deletes nodes from the symtree - only adding is + allowed. Additionally, newly added nodes are not traversed. */ + +static void +do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *), + void (*sym_func) (gfc_symbol *)) +{ + gfc_symtree **st_vec; + unsigned nodes, i, node_cntr; + + gcc_assert ((st_func && !sym_func) || (!st_func && sym_func)); + nodes = count_st_nodes (st); + st_vec = XALLOCAVEC (gfc_symtree *, nodes); + node_cntr = 0; + fill_st_vector (st, st_vec, node_cntr); + + if (sym_func) + { + /* Clear marks. */ + for (i = 0; i < nodes; i++) + st_vec[i]->n.sym->mark = 0; + for (i = 0; i < nodes; i++) + if (!st_vec[i]->n.sym->mark) + { + (*sym_func) (st_vec[i]->n.sym); + st_vec[i]->n.sym->mark = 1; + } + } + else + for (i = 0; i < nodes; i++) + (*st_func) (st_vec[i]); +} + + +/* Recursively traverse the symtree nodes. */ + +void +gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *)) +{ + do_traverse_symtree (st, st_func, NULL); +} + + +/* Call a given function for all symbols in the namespace. We take + care that each gfc_symbol node is called exactly once. */ + +void +gfc_traverse_ns (gfc_namespace *ns, void (*sym_func) (gfc_symbol *)) +{ + do_traverse_symtree (ns->sym_root, NULL, sym_func); +} + + +/* Return TRUE when name is the name of an intrinsic type. */ + +bool +gfc_is_intrinsic_typename (const char *name) +{ + if (strcmp (name, "integer") == 0 + || strcmp (name, "real") == 0 + || strcmp (name, "character") == 0 + || strcmp (name, "logical") == 0 + || strcmp (name, "complex") == 0 + || strcmp (name, "doubleprecision") == 0 + || strcmp (name, "doublecomplex") == 0) + return true; + else + return false; +} + + +/* Return TRUE if the symbol is an automatic variable. */ + +static bool +gfc_is_var_automatic (gfc_symbol *sym) +{ + /* Pointer and allocatable variables are never automatic. */ + if (sym->attr.pointer || sym->attr.allocatable) + return false; + /* Check for arrays with non-constant size. */ + if (sym->attr.dimension && sym->as + && !gfc_is_compile_time_shape (sym->as)) + return true; + /* Check for non-constant length character variables. */ + if (sym->ts.type == BT_CHARACTER + && sym->ts.u.cl + && !gfc_is_constant_expr (sym->ts.u.cl->length)) + return true; + /* Variables with explicit AUTOMATIC attribute. */ + if (sym->attr.automatic) + return true; + + return false; +} + +/* Given a symbol, mark it as SAVEd if it is allowed. */ + +static void +save_symbol (gfc_symbol *sym) +{ + + if (sym->attr.use_assoc) + return; + + if (sym->attr.in_common + || sym->attr.in_equivalence + || sym->attr.dummy + || sym->attr.result + || sym->attr.flavor != FL_VARIABLE) + return; + /* Automatic objects are not saved. */ + if (gfc_is_var_automatic (sym)) + return; + gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at); +} + + +/* Mark those symbols which can be SAVEd as such. */ + +void +gfc_save_all (gfc_namespace *ns) +{ + gfc_traverse_ns (ns, save_symbol); +} + + +/* Make sure that no changes to symbols are pending. */ + +void +gfc_enforce_clean_symbol_state(void) +{ + enforce_single_undo_checkpoint (); + gcc_assert (latest_undo_chgset->syms.is_empty ()); +} + + +/************** Global symbol handling ************/ + + +/* Search a tree for the global symbol. */ + +gfc_gsymbol * +gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name) +{ + int c; + + if (symbol == NULL) + return NULL; + + while (symbol) + { + c = strcmp (name, symbol->name); + if (!c) + return symbol; + + symbol = (c < 0) ? symbol->left : symbol->right; + } + + return NULL; +} + + +/* Case insensitive search a tree for the global symbol. */ + +gfc_gsymbol * +gfc_find_case_gsymbol (gfc_gsymbol *symbol, const char *name) +{ + int c; + + if (symbol == NULL) + return NULL; + + while (symbol) + { + c = strcasecmp (name, symbol->name); + if (!c) + return symbol; + + symbol = (c < 0) ? symbol->left : symbol->right; + } + + return NULL; +} + + +/* Compare two global symbols. Used for managing the BB tree. */ + +static int +gsym_compare (void *_s1, void *_s2) +{ + gfc_gsymbol *s1, *s2; + + s1 = (gfc_gsymbol *) _s1; + s2 = (gfc_gsymbol *) _s2; + return strcmp (s1->name, s2->name); +} + + +/* Get a global symbol, creating it if it doesn't exist. */ + +gfc_gsymbol * +gfc_get_gsymbol (const char *name, bool bind_c) +{ + gfc_gsymbol *s; + + s = gfc_find_gsymbol (gfc_gsym_root, name); + if (s != NULL) + return s; + + s = XCNEW (gfc_gsymbol); + s->type = GSYM_UNKNOWN; + s->name = gfc_get_string ("%s", name); + s->bind_c = bind_c; + + gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare); + + return s; +} + +void +gfc_traverse_gsymbol (gfc_gsymbol *gsym, + void (*do_something) (gfc_gsymbol *, void *), + void *data) +{ + if (gsym->left) + gfc_traverse_gsymbol (gsym->left, do_something, data); + + (*do_something) (gsym, data); + + if (gsym->right) + gfc_traverse_gsymbol (gsym->right, do_something, data); +} + +static gfc_symbol * +get_iso_c_binding_dt (int sym_id) +{ + gfc_symbol *dt_list = gfc_derived_types; + + /* Loop through the derived types in the name list, searching for + the desired symbol from iso_c_binding. Search the parent namespaces + if necessary and requested to (parent_flag). */ + if (dt_list) + { + while (dt_list->dt_next != gfc_derived_types) + { + if (dt_list->from_intmod != INTMOD_NONE + && dt_list->intmod_sym_id == sym_id) + return dt_list; + + dt_list = dt_list->dt_next; + } + } + + return NULL; +} + + +/* Verifies that the given derived type symbol, derived_sym, is interoperable + with C. This is necessary for any derived type that is BIND(C) and for + derived types that are parameters to functions that are BIND(C). All + fields of the derived type are required to be interoperable, and are tested + for such. If an error occurs, the errors are reported here, allowing for + multiple errors to be handled for a single derived type. */ + +bool +verify_bind_c_derived_type (gfc_symbol *derived_sym) +{ + gfc_component *curr_comp = NULL; + bool is_c_interop = false; + bool retval = true; + + if (derived_sym == NULL) + gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is " + "unexpectedly NULL"); + + /* If we've already looked at this derived symbol, do not look at it again + so we don't repeat warnings/errors. */ + if (derived_sym->ts.is_c_interop) + return true; + + /* The derived type must have the BIND attribute to be interoperable + J3/04-007, Section 15.2.3. */ + if (derived_sym->attr.is_bind_c != 1) + { + derived_sym->ts.is_c_interop = 0; + gfc_error_now ("Derived type %qs declared at %L must have the BIND " + "attribute to be C interoperable", derived_sym->name, + &(derived_sym->declared_at)); + retval = false; + } + + curr_comp = derived_sym->components; + + /* Fortran 2003 allows an empty derived type. C99 appears to disallow an + empty struct. Section 15.2 in Fortran 2003 states: "The following + subclauses define the conditions under which a Fortran entity is + interoperable. If a Fortran entity is interoperable, an equivalent + entity may be defined by means of C and the Fortran entity is said + to be interoperable with the C entity. There does not have to be such + an interoperating C entity." + */ + if (curr_comp == NULL) + { + gfc_warning (0, "Derived type %qs with BIND(C) attribute at %L is empty, " + "and may be inaccessible by the C companion processor", + derived_sym->name, &(derived_sym->declared_at)); + derived_sym->ts.is_c_interop = 1; + derived_sym->attr.is_bind_c = 1; + return true; + } + + + /* Initialize the derived type as being C interoperable. + If we find an error in the components, this will be set false. */ + derived_sym->ts.is_c_interop = 1; + + /* Loop through the list of components to verify that the kind of + each is a C interoperable type. */ + do + { + /* The components cannot be pointers (fortran sense). + J3/04-007, Section 15.2.3, C1505. */ + if (curr_comp->attr.pointer != 0) + { + gfc_error ("Component %qs at %L cannot have the " + "POINTER attribute because it is a member " + "of the BIND(C) derived type %qs at %L", + curr_comp->name, &(curr_comp->loc), + derived_sym->name, &(derived_sym->declared_at)); + retval = false; + } + + if (curr_comp->attr.proc_pointer != 0) + { + gfc_error ("Procedure pointer component %qs at %L cannot be a member" + " of the BIND(C) derived type %qs at %L", curr_comp->name, + &curr_comp->loc, derived_sym->name, + &derived_sym->declared_at); + retval = false; + } + + /* The components cannot be allocatable. + J3/04-007, Section 15.2.3, C1505. */ + if (curr_comp->attr.allocatable != 0) + { + gfc_error ("Component %qs at %L cannot have the " + "ALLOCATABLE attribute because it is a member " + "of the BIND(C) derived type %qs at %L", + curr_comp->name, &(curr_comp->loc), + derived_sym->name, &(derived_sym->declared_at)); + retval = false; + } + + /* BIND(C) derived types must have interoperable components. */ + if (curr_comp->ts.type == BT_DERIVED + && curr_comp->ts.u.derived->ts.is_iso_c != 1 + && curr_comp->ts.u.derived != derived_sym) + { + /* This should be allowed; the draft says a derived-type cannot + have type parameters if it is has the BIND attribute. Type + parameters seem to be for making parameterized derived types. + There's no need to verify the type if it is c_ptr/c_funptr. */ + retval = verify_bind_c_derived_type (curr_comp->ts.u.derived); + } + else + { + /* Grab the typespec for the given component and test the kind. */ + is_c_interop = gfc_verify_c_interop (&(curr_comp->ts)); + + if (!is_c_interop) + { + /* Report warning and continue since not fatal. The + draft does specify a constraint that requires all fields + to interoperate, but if the user says real(4), etc., it + may interoperate with *something* in C, but the compiler + most likely won't know exactly what. Further, it may not + interoperate with the same data type(s) in C if the user + recompiles with different flags (e.g., -m32 and -m64 on + x86_64 and using integer(4) to claim interop with a + C_LONG). */ + if (derived_sym->attr.is_bind_c == 1 && warn_c_binding_type) + /* If the derived type is bind(c), all fields must be + interop. */ + gfc_warning (OPT_Wc_binding_type, + "Component %qs in derived type %qs at %L " + "may not be C interoperable, even though " + "derived type %qs is BIND(C)", + curr_comp->name, derived_sym->name, + &(curr_comp->loc), derived_sym->name); + else if (warn_c_binding_type) + /* If derived type is param to bind(c) routine, or to one + of the iso_c_binding procs, it must be interoperable, so + all fields must interop too. */ + gfc_warning (OPT_Wc_binding_type, + "Component %qs in derived type %qs at %L " + "may not be C interoperable", + curr_comp->name, derived_sym->name, + &(curr_comp->loc)); + } + } + + curr_comp = curr_comp->next; + } while (curr_comp != NULL); + + if (derived_sym->attr.sequence != 0) + { + gfc_error ("Derived type %qs at %L cannot have the SEQUENCE " + "attribute because it is BIND(C)", derived_sym->name, + &(derived_sym->declared_at)); + retval = false; + } + + /* Mark the derived type as not being C interoperable if we found an + error. If there were only warnings, proceed with the assumption + it's interoperable. */ + if (!retval) + derived_sym->ts.is_c_interop = 0; + + return retval; +} + + +/* Generate symbols for the named constants c_null_ptr and c_null_funptr. */ + +static bool +gen_special_c_interop_ptr (gfc_symbol *tmp_sym, gfc_symtree *dt_symtree) +{ + gfc_constructor *c; + + gcc_assert (tmp_sym && dt_symtree && dt_symtree->n.sym); + dt_symtree->n.sym->attr.referenced = 1; + + tmp_sym->attr.is_c_interop = 1; + tmp_sym->attr.is_bind_c = 1; + tmp_sym->ts.is_c_interop = 1; + tmp_sym->ts.is_iso_c = 1; + tmp_sym->ts.type = BT_DERIVED; + tmp_sym->ts.f90_type = BT_VOID; + tmp_sym->attr.flavor = FL_PARAMETER; + tmp_sym->ts.u.derived = dt_symtree->n.sym; + + /* Set the c_address field of c_null_ptr and c_null_funptr to + the value of NULL. */ + tmp_sym->value = gfc_get_expr (); + tmp_sym->value->expr_type = EXPR_STRUCTURE; + tmp_sym->value->ts.type = BT_DERIVED; + tmp_sym->value->ts.f90_type = BT_VOID; + tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived; + gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL); + c = gfc_constructor_first (tmp_sym->value->value.constructor); + c->expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); + c->expr->ts.is_iso_c = 1; + + return true; +} + + +/* Add a formal argument, gfc_formal_arglist, to the + end of the given list of arguments. Set the reference to the + provided symbol, param_sym, in the argument. */ + +static void +add_formal_arg (gfc_formal_arglist **head, + gfc_formal_arglist **tail, + gfc_formal_arglist *formal_arg, + gfc_symbol *param_sym) +{ + /* Put in list, either as first arg or at the tail (curr arg). */ + if (*head == NULL) + *head = *tail = formal_arg; + else + { + (*tail)->next = formal_arg; + (*tail) = formal_arg; + } + + (*tail)->sym = param_sym; + (*tail)->next = NULL; + + return; +} + + +/* Add a procedure interface to the given symbol (i.e., store a + reference to the list of formal arguments). */ + +static void +add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal) +{ + + sym->formal = formal; + sym->attr.if_source = source; +} + + +/* Copy the formal args from an existing symbol, src, into a new + symbol, dest. New formal args are created, and the description of + each arg is set according to the existing ones. This function is + used when creating procedure declaration variables from a procedure + declaration statement (see match_proc_decl()) to create the formal + args based on the args of a given named interface. + + When an actual argument list is provided, skip the absent arguments + unless copy_type is true. + To be used together with gfc_se->ignore_optional. */ + +void +gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src, + gfc_actual_arglist *actual, bool copy_type) +{ + gfc_formal_arglist *head = NULL; + gfc_formal_arglist *tail = NULL; + gfc_formal_arglist *formal_arg = NULL; + gfc_intrinsic_arg *curr_arg = NULL; + gfc_formal_arglist *formal_prev = NULL; + gfc_actual_arglist *act_arg = actual; + /* Save current namespace so we can change it for formal args. */ + gfc_namespace *parent_ns = gfc_current_ns; + + /* Create a new namespace, which will be the formal ns (namespace + of the formal args). */ + gfc_current_ns = gfc_get_namespace (parent_ns, 0); + gfc_current_ns->proc_name = dest; + + for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next) + { + /* Skip absent arguments. */ + if (actual) + { + gcc_assert (act_arg != NULL); + if (act_arg->expr == NULL) + { + act_arg = act_arg->next; + continue; + } + } + formal_arg = gfc_get_formal_arglist (); + gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym)); + + /* May need to copy more info for the symbol. */ + if (copy_type && act_arg->expr != NULL) + { + formal_arg->sym->ts = act_arg->expr->ts; + if (act_arg->expr->rank > 0) + { + formal_arg->sym->attr.dimension = 1; + formal_arg->sym->as = gfc_get_array_spec(); + formal_arg->sym->as->rank = -1; + formal_arg->sym->as->type = AS_ASSUMED_RANK; + } + if (act_arg->name && strcmp (act_arg->name, "%VAL") == 0) + formal_arg->sym->pass_as_value = 1; + } + else + formal_arg->sym->ts = curr_arg->ts; + + formal_arg->sym->attr.optional = curr_arg->optional; + formal_arg->sym->attr.value = curr_arg->value; + formal_arg->sym->attr.intent = curr_arg->intent; + formal_arg->sym->attr.flavor = FL_VARIABLE; + formal_arg->sym->attr.dummy = 1; + + if (formal_arg->sym->ts.type == BT_CHARACTER) + formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + + /* If this isn't the first arg, set up the next ptr. For the + last arg built, the formal_arg->next will never get set to + anything other than NULL. */ + if (formal_prev != NULL) + formal_prev->next = formal_arg; + else + formal_arg->next = NULL; + + formal_prev = formal_arg; + + /* Add arg to list of formal args. */ + add_formal_arg (&head, &tail, formal_arg, formal_arg->sym); + + /* Validate changes. */ + gfc_commit_symbol (formal_arg->sym); + if (actual) + act_arg = act_arg->next; + } + + /* Add the interface to the symbol. */ + add_proc_interface (dest, IFSRC_DECL, head); + + /* Store the formal namespace information. */ + if (dest->formal != NULL) + /* The current ns should be that for the dest proc. */ + dest->formal_ns = gfc_current_ns; + /* Restore the current namespace to what it was on entry. */ + gfc_current_ns = parent_ns; +} + + +static int +std_for_isocbinding_symbol (int id) +{ + switch (id) + { +#define NAMED_INTCST(a,b,c,d) \ + case a:\ + return d; +#include "iso-c-binding.def" +#undef NAMED_INTCST + +#define NAMED_FUNCTION(a,b,c,d) \ + case a:\ + return d; +#define NAMED_SUBROUTINE(a,b,c,d) \ + case a:\ + return d; +#include "iso-c-binding.def" +#undef NAMED_FUNCTION +#undef NAMED_SUBROUTINE + + default: + return GFC_STD_F2003; + } +} + +/* Generate the given set of C interoperable kind objects, or all + interoperable kinds. This function will only be given kind objects + for valid iso_c_binding defined types because this is verified when + the 'use' statement is parsed. If the user gives an 'only' clause, + the specific kinds are looked up; if they don't exist, an error is + reported. If the user does not give an 'only' clause, all + iso_c_binding symbols are generated. If a list of specific kinds + is given, it must have a NULL in the first empty spot to mark the + end of the list. For C_null_(fun)ptr, dt_symtree has to be set and + point to the symtree for c_(fun)ptr. */ + +gfc_symtree * +generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, + const char *local_name, gfc_symtree *dt_symtree, + bool hidden) +{ + const char *const name = (local_name && local_name[0]) + ? local_name : c_interop_kinds_table[s].name; + gfc_symtree *tmp_symtree; + gfc_symbol *tmp_sym = NULL; + int index; + + if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR) + return NULL; + + tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); + if (hidden + && (!tmp_symtree || !tmp_symtree->n.sym + || tmp_symtree->n.sym->from_intmod != INTMOD_ISO_C_BINDING + || tmp_symtree->n.sym->intmod_sym_id != s)) + tmp_symtree = NULL; + + /* Already exists in this scope so don't re-add it. */ + if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL + && (!tmp_sym->attr.generic + || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL) + && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING) + { + if (tmp_sym->attr.flavor == FL_DERIVED + && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id)) + { + if (gfc_derived_types) + { + tmp_sym->dt_next = gfc_derived_types->dt_next; + gfc_derived_types->dt_next = tmp_sym; + } + else + { + tmp_sym->dt_next = tmp_sym; + } + gfc_derived_types = tmp_sym; + } + + return tmp_symtree; + } + + /* Create the sym tree in the current ns. */ + if (hidden) + { + tmp_symtree = gfc_get_unique_symtree (gfc_current_ns); + tmp_sym = gfc_new_symbol (name, gfc_current_ns); + + /* Add to the list of tentative symbols. */ + latest_undo_chgset->syms.safe_push (tmp_sym); + tmp_sym->old_symbol = NULL; + tmp_sym->mark = 1; + tmp_sym->gfc_new = 1; + + tmp_symtree->n.sym = tmp_sym; + tmp_sym->refs++; + } + else + { + gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); + gcc_assert (tmp_symtree); + tmp_sym = tmp_symtree->n.sym; + } + + /* Say what module this symbol belongs to. */ + tmp_sym->module = gfc_get_string ("%s", mod_name); + tmp_sym->from_intmod = INTMOD_ISO_C_BINDING; + tmp_sym->intmod_sym_id = s; + tmp_sym->attr.is_iso_c = 1; + tmp_sym->attr.use_assoc = 1; + + gcc_assert (dt_symtree == NULL || s == ISOCBINDING_NULL_FUNPTR + || s == ISOCBINDING_NULL_PTR); + + switch (s) + { + +#define NAMED_INTCST(a,b,c,d) case a : +#define NAMED_REALCST(a,b,c,d) case a : +#define NAMED_CMPXCST(a,b,c,d) case a : +#define NAMED_LOGCST(a,b,c) case a : +#define NAMED_CHARKNDCST(a,b,c) case a : +#include "iso-c-binding.def" + + tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, + c_interop_kinds_table[s].value); + + /* Initialize an integer constant expression node. */ + tmp_sym->attr.flavor = FL_PARAMETER; + tmp_sym->ts.type = BT_INTEGER; + tmp_sym->ts.kind = gfc_default_integer_kind; + + /* Mark this type as a C interoperable one. */ + tmp_sym->ts.is_c_interop = 1; + tmp_sym->ts.is_iso_c = 1; + tmp_sym->value->ts.is_c_interop = 1; + tmp_sym->value->ts.is_iso_c = 1; + tmp_sym->attr.is_c_interop = 1; + + /* Tell what f90 type this c interop kind is valid. */ + tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type; + + break; + + +#define NAMED_CHARCST(a,b,c) case a : +#include "iso-c-binding.def" + + /* Initialize an integer constant expression node for the + length of the character. */ + tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind, + &gfc_current_locus, NULL, 1); + tmp_sym->value->ts.is_c_interop = 1; + tmp_sym->value->ts.is_iso_c = 1; + tmp_sym->value->value.character.length = 1; + tmp_sym->value->value.character.string[0] + = (gfc_char_t) c_interop_kinds_table[s].value; + tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, + NULL, 1); + + /* May not need this in both attr and ts, but do need in + attr for writing module file. */ + tmp_sym->attr.is_c_interop = 1; + + tmp_sym->attr.flavor = FL_PARAMETER; + tmp_sym->ts.type = BT_CHARACTER; + + /* Need to set it to the C_CHAR kind. */ + tmp_sym->ts.kind = gfc_default_character_kind; + + /* Mark this type as a C interoperable one. */ + tmp_sym->ts.is_c_interop = 1; + tmp_sym->ts.is_iso_c = 1; + + /* Tell what f90 type this c interop kind is valid. */ + tmp_sym->ts.f90_type = BT_CHARACTER; + + break; + + case ISOCBINDING_PTR: + case ISOCBINDING_FUNPTR: + { + gfc_symbol *dt_sym; + gfc_component *tmp_comp = NULL; + + /* Generate real derived type. */ + if (hidden) + dt_sym = tmp_sym; + else + { + const char *hidden_name; + gfc_interface *intr, *head; + + hidden_name = gfc_dt_upper_string (tmp_sym->name); + tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, + hidden_name); + gcc_assert (tmp_symtree == NULL); + gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false); + dt_sym = tmp_symtree->n.sym; + dt_sym->name = gfc_get_string (s == ISOCBINDING_PTR + ? "c_ptr" : "c_funptr"); + + /* Generate an artificial generic function. */ + head = tmp_sym->generic; + intr = gfc_get_interface (); + intr->sym = dt_sym; + intr->where = gfc_current_locus; + intr->next = head; + tmp_sym->generic = intr; + + if (!tmp_sym->attr.generic + && !gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL)) + return NULL; + + if (!tmp_sym->attr.function + && !gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL)) + return NULL; + } + + /* Say what module this symbol belongs to. */ + dt_sym->module = gfc_get_string ("%s", mod_name); + dt_sym->from_intmod = INTMOD_ISO_C_BINDING; + dt_sym->intmod_sym_id = s; + dt_sym->attr.use_assoc = 1; + + /* Initialize an integer constant expression node. */ + dt_sym->attr.flavor = FL_DERIVED; + dt_sym->ts.is_c_interop = 1; + dt_sym->attr.is_c_interop = 1; + dt_sym->attr.private_comp = 1; + dt_sym->component_access = ACCESS_PRIVATE; + dt_sym->ts.is_iso_c = 1; + dt_sym->ts.type = BT_DERIVED; + dt_sym->ts.f90_type = BT_VOID; + + /* A derived type must have the bind attribute to be + interoperable (J3/04-007, Section 15.2.3), even though + the binding label is not used. */ + dt_sym->attr.is_bind_c = 1; + + dt_sym->attr.referenced = 1; + dt_sym->ts.u.derived = dt_sym; + + /* Add the symbol created for the derived type to the current ns. */ + if (gfc_derived_types) + { + dt_sym->dt_next = gfc_derived_types->dt_next; + gfc_derived_types->dt_next = dt_sym; + } + else + { + dt_sym->dt_next = dt_sym; + } + gfc_derived_types = dt_sym; + + gfc_add_component (dt_sym, "c_address", &tmp_comp); + if (tmp_comp == NULL) + gcc_unreachable (); + + tmp_comp->ts.type = BT_INTEGER; + + /* Set this because the module will need to read/write this field. */ + tmp_comp->ts.f90_type = BT_INTEGER; + + /* The kinds for c_ptr and c_funptr are the same. */ + index = get_c_kind ("c_ptr", c_interop_kinds_table); + tmp_comp->ts.kind = c_interop_kinds_table[index].value; + tmp_comp->attr.access = ACCESS_PRIVATE; + + /* Mark the component as C interoperable. */ + tmp_comp->ts.is_c_interop = 1; + } + + break; + + case ISOCBINDING_NULL_PTR: + case ISOCBINDING_NULL_FUNPTR: + gen_special_c_interop_ptr (tmp_sym, dt_symtree); + break; + + default: + gcc_unreachable (); + } + gfc_commit_symbol (tmp_sym); + return tmp_symtree; +} + + +/* Check that a symbol is already typed. If strict is not set, an untyped + symbol is acceptable for non-standard-conforming mode. */ + +bool +gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns, + bool strict, locus where) +{ + gcc_assert (sym); + + if (gfc_matching_prefix) + return true; + + /* Check for the type and try to give it an implicit one. */ + if (sym->ts.type == BT_UNKNOWN + && !gfc_set_default_type (sym, 0, ns)) + { + if (strict) + { + gfc_error ("Symbol %qs is used before it is typed at %L", + sym->name, &where); + return false; + } + + if (!gfc_notify_std (GFC_STD_GNU, "Symbol %qs is used before" + " it is typed at %L", sym->name, &where)) + return false; + } + + /* Everything is ok. */ + return true; +} + + +/* Construct a typebound-procedure structure. Those are stored in a tentative + list and marked `error' until symbols are committed. */ + +gfc_typebound_proc* +gfc_get_typebound_proc (gfc_typebound_proc *tb0) +{ + gfc_typebound_proc *result; + + result = XCNEW (gfc_typebound_proc); + if (tb0) + *result = *tb0; + result->error = 1; + + latest_undo_chgset->tbps.safe_push (result); + + return result; +} + + +/* Get the super-type of a given derived type. */ + +gfc_symbol* +gfc_get_derived_super_type (gfc_symbol* derived) +{ + gcc_assert (derived); + + if (derived->attr.generic) + derived = gfc_find_dt_in_generic (derived); + + if (!derived->attr.extension) + return NULL; + + gcc_assert (derived->components); + gcc_assert (derived->components->ts.type == BT_DERIVED); + gcc_assert (derived->components->ts.u.derived); + + if (derived->components->ts.u.derived->attr.generic) + return gfc_find_dt_in_generic (derived->components->ts.u.derived); + + return derived->components->ts.u.derived; +} + + +/* Check if a derived type t2 is an extension of (or equal to) a type t1. */ + +bool +gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2) +{ + while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension) + t2 = gfc_get_derived_super_type (t2); + return gfc_compare_derived_types (t1, t2); +} + + +/* Check if two typespecs are type compatible (F03:5.1.1.2): + If ts1 is nonpolymorphic, ts2 must be the same type. + If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */ + +bool +gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) +{ + bool is_class1 = (ts1->type == BT_CLASS); + bool is_class2 = (ts2->type == BT_CLASS); + bool is_derived1 = (ts1->type == BT_DERIVED); + bool is_derived2 = (ts2->type == BT_DERIVED); + bool is_union1 = (ts1->type == BT_UNION); + bool is_union2 = (ts2->type == BT_UNION); + + if (is_class1 + && ts1->u.derived->components + && ((ts1->u.derived->attr.is_class + && ts1->u.derived->components->ts.u.derived->attr + .unlimited_polymorphic) + || ts1->u.derived->attr.unlimited_polymorphic)) + return 1; + + if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2 + && !is_union1 && !is_union2) + return (ts1->type == ts2->type); + + if ((is_derived1 && is_derived2) || (is_union1 && is_union2)) + return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived); + + if (is_derived1 && is_class2) + return gfc_compare_derived_types (ts1->u.derived, + ts2->u.derived->attr.is_class ? + ts2->u.derived->components->ts.u.derived + : ts2->u.derived); + if (is_class1 && is_derived2) + return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ? + ts1->u.derived->components->ts.u.derived + : ts1->u.derived, + ts2->u.derived); + else if (is_class1 && is_class2) + return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ? + ts1->u.derived->components->ts.u.derived + : ts1->u.derived, + ts2->u.derived->attr.is_class ? + ts2->u.derived->components->ts.u.derived + : ts2->u.derived); + else + return 0; +} + + +/* Find the parent-namespace of the current function. If we're inside + BLOCK constructs, it may not be the current one. */ + +gfc_namespace* +gfc_find_proc_namespace (gfc_namespace* ns) +{ + while (ns->construct_entities) + { + ns = ns->parent; + gcc_assert (ns); + } + + return ns; +} + + +/* Check if an associate-variable should be translated as an `implicit' pointer + internally (if it is associated to a variable and not an array with + descriptor). */ + +bool +gfc_is_associate_pointer (gfc_symbol* sym) +{ + if (!sym->assoc) + return false; + + if (sym->ts.type == BT_CLASS) + return true; + + if (sym->ts.type == BT_CHARACTER + && sym->ts.deferred + && sym->assoc->target + && sym->assoc->target->expr_type == EXPR_FUNCTION) + return true; + + if (!sym->assoc->variable) + return false; + + if (sym->attr.dimension && sym->as->type != AS_EXPLICIT) + return false; + + return true; +} + + +gfc_symbol * +gfc_find_dt_in_generic (gfc_symbol *sym) +{ + gfc_interface *intr = NULL; + + if (!sym || gfc_fl_struct (sym->attr.flavor)) + return sym; + + if (sym->attr.generic) + for (intr = sym->generic; intr; intr = intr->next) + if (gfc_fl_struct (intr->sym->attr.flavor)) + break; + return intr ? intr->sym : NULL; +} + + +/* Get the dummy arguments from a procedure symbol. If it has been declared + via a PROCEDURE statement with a named interface, ts.interface will be set + and the arguments need to be taken from there. */ + +gfc_formal_arglist * +gfc_sym_get_dummy_args (gfc_symbol *sym) +{ + gfc_formal_arglist *dummies; + + if (sym == NULL) + return NULL; + + dummies = sym->formal; + if (dummies == NULL && sym->ts.interface != NULL) + dummies = sym->ts.interface->formal; + + return dummies; +} |