| /* Perform type resolution on the various structures. |
| Copyright (C) 2001-2018 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 "bitmap.h" |
| #include "gfortran.h" |
| #include "arith.h" /* For gfc_compare_expr(). */ |
| #include "dependency.h" |
| #include "data.h" |
| #include "target-memory.h" /* for gfc_simplify_transfer */ |
| #include "constructor.h" |
| |
| /* Types used in equivalence statements. */ |
| |
| enum seq_type |
| { |
| SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED |
| }; |
| |
| /* Stack to keep track of the nesting of blocks as we move through the |
| code. See resolve_branch() and gfc_resolve_code(). */ |
| |
| typedef struct code_stack |
| { |
| struct gfc_code *head, *current; |
| struct code_stack *prev; |
| |
| /* This bitmap keeps track of the targets valid for a branch from |
| inside this block except for END {IF|SELECT}s of enclosing |
| blocks. */ |
| bitmap reachable_labels; |
| } |
| code_stack; |
| |
| static code_stack *cs_base = NULL; |
| |
| |
| /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */ |
| |
| static int forall_flag; |
| int gfc_do_concurrent_flag; |
| |
| /* True when we are resolving an expression that is an actual argument to |
| a procedure. */ |
| static bool actual_arg = false; |
| /* True when we are resolving an expression that is the first actual argument |
| to a procedure. */ |
| static bool first_actual_arg = false; |
| |
| |
| /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */ |
| |
| static int omp_workshare_flag; |
| |
| /* True if we are processing a formal arglist. The corresponding function |
| resets the flag each time that it is read. */ |
| static bool formal_arg_flag = false; |
| |
| /* True if we are resolving a specification expression. */ |
| static bool specification_expr = false; |
| |
| /* The id of the last entry seen. */ |
| static int current_entry_id; |
| |
| /* We use bitmaps to determine if a branch target is valid. */ |
| static bitmap_obstack labels_obstack; |
| |
| /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */ |
| static bool inquiry_argument = false; |
| |
| |
| bool |
| gfc_is_formal_arg (void) |
| { |
| return formal_arg_flag; |
| } |
| |
| /* Is the symbol host associated? */ |
| static bool |
| is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns) |
| { |
| for (ns = ns->parent; ns; ns = ns->parent) |
| { |
| if (sym->ns == ns) |
| return true; |
| } |
| |
| return false; |
| } |
| |
| /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is |
| an ABSTRACT derived-type. If where is not NULL, an error message with that |
| locus is printed, optionally using name. */ |
| |
| static bool |
| resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name) |
| { |
| if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract) |
| { |
| if (where) |
| { |
| if (name) |
| gfc_error ("%qs at %L is of the ABSTRACT type %qs", |
| name, where, ts->u.derived->name); |
| else |
| gfc_error ("ABSTRACT type %qs used at %L", |
| ts->u.derived->name, where); |
| } |
| |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| static bool |
| check_proc_interface (gfc_symbol *ifc, locus *where) |
| { |
| /* Several checks for F08:C1216. */ |
| if (ifc->attr.procedure) |
| { |
| gfc_error ("Interface %qs at %L is declared " |
| "in a later PROCEDURE statement", ifc->name, where); |
| return false; |
| } |
| if (ifc->generic) |
| { |
| /* For generic interfaces, check if there is |
| a specific procedure with the same name. */ |
| gfc_interface *gen = ifc->generic; |
| while (gen && strcmp (gen->sym->name, ifc->name) != 0) |
| gen = gen->next; |
| if (!gen) |
| { |
| gfc_error ("Interface %qs at %L may not be generic", |
| ifc->name, where); |
| return false; |
| } |
| } |
| if (ifc->attr.proc == PROC_ST_FUNCTION) |
| { |
| gfc_error ("Interface %qs at %L may not be a statement function", |
| ifc->name, where); |
| return false; |
| } |
| if (gfc_is_intrinsic (ifc, 0, ifc->declared_at) |
| || gfc_is_intrinsic (ifc, 1, ifc->declared_at)) |
| ifc->attr.intrinsic = 1; |
| if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0)) |
| { |
| gfc_error ("Intrinsic procedure %qs not allowed in " |
| "PROCEDURE statement at %L", ifc->name, where); |
| return false; |
| } |
| if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0') |
| { |
| gfc_error ("Interface %qs at %L must be explicit", ifc->name, where); |
| return false; |
| } |
| return true; |
| } |
| |
| |
| static void resolve_symbol (gfc_symbol *sym); |
| |
| |
| /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */ |
| |
| static bool |
| resolve_procedure_interface (gfc_symbol *sym) |
| { |
| gfc_symbol *ifc = sym->ts.interface; |
| |
| if (!ifc) |
| return true; |
| |
| if (ifc == sym) |
| { |
| gfc_error ("PROCEDURE %qs at %L may not be used as its own interface", |
| sym->name, &sym->declared_at); |
| return false; |
| } |
| if (!check_proc_interface (ifc, &sym->declared_at)) |
| return false; |
| |
| if (ifc->attr.if_source || ifc->attr.intrinsic) |
| { |
| /* Resolve interface and copy attributes. */ |
| resolve_symbol (ifc); |
| if (ifc->attr.intrinsic) |
| gfc_resolve_intrinsic (ifc, &ifc->declared_at); |
| |
| if (ifc->result) |
| { |
| sym->ts = ifc->result->ts; |
| sym->attr.allocatable = ifc->result->attr.allocatable; |
| sym->attr.pointer = ifc->result->attr.pointer; |
| sym->attr.dimension = ifc->result->attr.dimension; |
| sym->attr.class_ok = ifc->result->attr.class_ok; |
| sym->as = gfc_copy_array_spec (ifc->result->as); |
| sym->result = sym; |
| } |
| else |
| { |
| sym->ts = ifc->ts; |
| sym->attr.allocatable = ifc->attr.allocatable; |
| sym->attr.pointer = ifc->attr.pointer; |
| sym->attr.dimension = ifc->attr.dimension; |
| sym->attr.class_ok = ifc->attr.class_ok; |
| sym->as = gfc_copy_array_spec (ifc->as); |
| } |
| sym->ts.interface = ifc; |
| sym->attr.function = ifc->attr.function; |
| sym->attr.subroutine = ifc->attr.subroutine; |
| |
| sym->attr.pure = ifc->attr.pure; |
| sym->attr.elemental = ifc->attr.elemental; |
| sym->attr.contiguous = ifc->attr.contiguous; |
| sym->attr.recursive = ifc->attr.recursive; |
| sym->attr.always_explicit = ifc->attr.always_explicit; |
| sym->attr.ext_attr |= ifc->attr.ext_attr; |
| sym->attr.is_bind_c = ifc->attr.is_bind_c; |
| /* Copy char length. */ |
| if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) |
| { |
| sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); |
| if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved |
| && !gfc_resolve_expr (sym->ts.u.cl->length)) |
| return false; |
| } |
| } |
| |
| return true; |
| } |
| |
| |
| /* Resolve types of formal argument lists. These have to be done early so that |
| the formal argument lists of module procedures can be copied to the |
| containing module before the individual procedures are resolved |
| individually. We also resolve argument lists of procedures in interface |
| blocks because they are self-contained scoping units. |
| |
| Since a dummy argument cannot be a non-dummy procedure, the only |
| resort left for untyped names are the IMPLICIT types. */ |
| |
| static void |
| resolve_formal_arglist (gfc_symbol *proc) |
| { |
| gfc_formal_arglist *f; |
| gfc_symbol *sym; |
| bool saved_specification_expr; |
| int i; |
| |
| if (proc->result != NULL) |
| sym = proc->result; |
| else |
| sym = proc; |
| |
| if (gfc_elemental (proc) |
| || sym->attr.pointer || sym->attr.allocatable |
| || (sym->as && sym->as->rank != 0)) |
| { |
| proc->attr.always_explicit = 1; |
| sym->attr.always_explicit = 1; |
| } |
| |
| formal_arg_flag = true; |
| |
| for (f = proc->formal; f; f = f->next) |
| { |
| gfc_array_spec *as; |
| |
| sym = f->sym; |
| |
| if (sym == NULL) |
| { |
| /* Alternate return placeholder. */ |
| if (gfc_elemental (proc)) |
| gfc_error ("Alternate return specifier in elemental subroutine " |
| "%qs at %L is not allowed", proc->name, |
| &proc->declared_at); |
| if (proc->attr.function) |
| gfc_error ("Alternate return specifier in function " |
| "%qs at %L is not allowed", proc->name, |
| &proc->declared_at); |
| continue; |
| } |
| else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL |
| && !resolve_procedure_interface (sym)) |
| return; |
| |
| if (strcmp (proc->name, sym->name) == 0) |
| { |
| gfc_error ("Self-referential argument " |
| "%qs at %L is not allowed", sym->name, |
| &proc->declared_at); |
| return; |
| } |
| |
| if (sym->attr.if_source != IFSRC_UNKNOWN) |
| resolve_formal_arglist (sym); |
| |
| if (sym->attr.subroutine || sym->attr.external) |
| { |
| if (sym->attr.flavor == FL_UNKNOWN) |
| gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at); |
| } |
| else |
| { |
| if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic |
| && (!sym->attr.function || sym->result == sym)) |
| gfc_set_default_type (sym, 1, sym->ns); |
| } |
| |
| as = sym->ts.type == BT_CLASS && sym->attr.class_ok |
| ? CLASS_DATA (sym)->as : sym->as; |
| |
| saved_specification_expr = specification_expr; |
| specification_expr = true; |
| gfc_resolve_array_spec (as, 0); |
| specification_expr = saved_specification_expr; |
| |
| /* We can't tell if an array with dimension (:) is assumed or deferred |
| shape until we know if it has the pointer or allocatable attributes. |
| */ |
| if (as && as->rank > 0 && as->type == AS_DEFERRED |
| && ((sym->ts.type != BT_CLASS |
| && !(sym->attr.pointer || sym->attr.allocatable)) |
| || (sym->ts.type == BT_CLASS |
| && !(CLASS_DATA (sym)->attr.class_pointer |
| || CLASS_DATA (sym)->attr.allocatable))) |
| && sym->attr.flavor != FL_PROCEDURE) |
| { |
| as->type = AS_ASSUMED_SHAPE; |
| for (i = 0; i < as->rank; i++) |
| as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); |
| } |
| |
| if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE) |
| || (as && as->type == AS_ASSUMED_RANK) |
| || sym->attr.pointer || sym->attr.allocatable || sym->attr.target |
| || (sym->ts.type == BT_CLASS && sym->attr.class_ok |
| && (CLASS_DATA (sym)->attr.class_pointer |
| || CLASS_DATA (sym)->attr.allocatable |
| || CLASS_DATA (sym)->attr.target)) |
| || sym->attr.optional) |
| { |
| proc->attr.always_explicit = 1; |
| if (proc->result) |
| proc->result->attr.always_explicit = 1; |
| } |
| |
| /* If the flavor is unknown at this point, it has to be a variable. |
| A procedure specification would have already set the type. */ |
| |
| if (sym->attr.flavor == FL_UNKNOWN) |
| gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at); |
| |
| if (gfc_pure (proc)) |
| { |
| if (sym->attr.flavor == FL_PROCEDURE) |
| { |
| /* F08:C1279. */ |
| if (!gfc_pure (sym)) |
| { |
| gfc_error ("Dummy procedure %qs of PURE procedure at %L must " |
| "also be PURE", sym->name, &sym->declared_at); |
| continue; |
| } |
| } |
| else if (!sym->attr.pointer) |
| { |
| if (proc->attr.function && sym->attr.intent != INTENT_IN) |
| { |
| if (sym->attr.value) |
| gfc_notify_std (GFC_STD_F2008, "Argument %qs" |
| " of pure function %qs at %L with VALUE " |
| "attribute but without INTENT(IN)", |
| sym->name, proc->name, &sym->declared_at); |
| else |
| gfc_error ("Argument %qs of pure function %qs at %L must " |
| "be INTENT(IN) or VALUE", sym->name, proc->name, |
| &sym->declared_at); |
| } |
| |
| if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN) |
| { |
| if (sym->attr.value) |
| gfc_notify_std (GFC_STD_F2008, "Argument %qs" |
| " of pure subroutine %qs at %L with VALUE " |
| "attribute but without INTENT", sym->name, |
| proc->name, &sym->declared_at); |
| else |
| gfc_error ("Argument %qs of pure subroutine %qs at %L " |
| "must have its INTENT specified or have the " |
| "VALUE attribute", sym->name, proc->name, |
| &sym->declared_at); |
| } |
| } |
| |
| /* F08:C1278a. */ |
| if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT) |
| { |
| gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L" |
| " may not be polymorphic", sym->name, proc->name, |
| &sym->declared_at); |
| continue; |
| } |
| } |
| |
| if (proc->attr.implicit_pure) |
| { |
| if (sym->attr.flavor == FL_PROCEDURE) |
| { |
| if (!gfc_pure (sym)) |
| proc->attr.implicit_pure = 0; |
| } |
| else if (!sym->attr.pointer) |
| { |
| if (proc->attr.function && sym->attr.intent != INTENT_IN |
| && !sym->value) |
| proc->attr.implicit_pure = 0; |
| |
| if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN |
| && !sym->value) |
| proc->attr.implicit_pure = 0; |
| } |
| } |
| |
| if (gfc_elemental (proc)) |
| { |
| /* F08:C1289. */ |
| if (sym->attr.codimension |
| || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
| && CLASS_DATA (sym)->attr.codimension)) |
| { |
| gfc_error ("Coarray dummy argument %qs at %L to elemental " |
| "procedure", sym->name, &sym->declared_at); |
| continue; |
| } |
| |
| if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
| && CLASS_DATA (sym)->as)) |
| { |
| gfc_error ("Argument %qs of elemental procedure at %L must " |
| "be scalar", sym->name, &sym->declared_at); |
| continue; |
| } |
| |
| if (sym->attr.allocatable |
| || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
| && CLASS_DATA (sym)->attr.allocatable)) |
| { |
| gfc_error ("Argument %qs of elemental procedure at %L cannot " |
| "have the ALLOCATABLE attribute", sym->name, |
| &sym->declared_at); |
| continue; |
| } |
| |
| if (sym->attr.pointer |
| || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
| && CLASS_DATA (sym)->attr.class_pointer)) |
| { |
| gfc_error ("Argument %qs of elemental procedure at %L cannot " |
| "have the POINTER attribute", sym->name, |
| &sym->declared_at); |
| continue; |
| } |
| |
| if (sym->attr.flavor == FL_PROCEDURE) |
| { |
| gfc_error ("Dummy procedure %qs not allowed in elemental " |
| "procedure %qs at %L", sym->name, proc->name, |
| &sym->declared_at); |
| continue; |
| } |
| |
| /* Fortran 2008 Corrigendum 1, C1290a. */ |
| if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value) |
| { |
| gfc_error ("Argument %qs of elemental procedure %qs at %L must " |
| "have its INTENT specified or have the VALUE " |
| "attribute", sym->name, proc->name, |
| &sym->declared_at); |
| continue; |
| } |
| } |
| |
| /* Each dummy shall be specified to be scalar. */ |
| if (proc->attr.proc == PROC_ST_FUNCTION) |
| { |
| if (sym->as != NULL) |
| { |
| /* F03:C1263 (R1238) The function-name and each dummy-arg-name |
| shall be specified, explicitly or implicitly, to be scalar. */ |
| gfc_error ("Argument '%s' of statement function '%s' at %L " |
| "must be scalar", sym->name, proc->name, |
| &proc->declared_at); |
| continue; |
| } |
| |
| if (sym->ts.type == BT_CHARACTER) |
| { |
| gfc_charlen *cl = sym->ts.u.cl; |
| if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) |
| { |
| gfc_error ("Character-valued argument %qs of statement " |
| "function at %L must have constant length", |
| sym->name, &sym->declared_at); |
| continue; |
| } |
| } |
| } |
| } |
| formal_arg_flag = false; |
| } |
| |
| |
| /* Work function called when searching for symbols that have argument lists |
| associated with them. */ |
| |
| static void |
| find_arglists (gfc_symbol *sym) |
| { |
| if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns |
| || gfc_fl_struct (sym->attr.flavor) || sym->attr.intrinsic) |
| return; |
| |
| resolve_formal_arglist (sym); |
| } |
| |
| |
| /* Given a namespace, resolve all formal argument lists within the namespace. |
| */ |
| |
| static void |
| resolve_formal_arglists (gfc_namespace *ns) |
| { |
| if (ns == NULL) |
| return; |
| |
| gfc_traverse_ns (ns, find_arglists); |
| } |
| |
| |
| static void |
| resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns) |
| { |
| bool t; |
| |
| if (sym && sym->attr.flavor == FL_PROCEDURE |
| && sym->ns->parent |
| && sym->ns->parent->proc_name |
| && sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE |
| && !strcmp (sym->name, sym->ns->parent->proc_name->name)) |
| gfc_error ("Contained procedure %qs at %L has the same name as its " |
| "encompassing procedure", sym->name, &sym->declared_at); |
| |
| /* If this namespace is not a function or an entry master function, |
| ignore it. */ |
| if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE) |
| || sym->attr.entry_master) |
| return; |
| |
| /* Try to find out of what the return type is. */ |
| if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL) |
| { |
| t = gfc_set_default_type (sym->result, 0, ns); |
| |
| if (!t && !sym->result->attr.untyped) |
| { |
| if (sym->result == sym) |
| gfc_error ("Contained function %qs at %L has no IMPLICIT type", |
| sym->name, &sym->declared_at); |
| else if (!sym->result->attr.proc_pointer) |
| gfc_error ("Result %qs of contained function %qs at %L has " |
| "no IMPLICIT type", sym->result->name, sym->name, |
| &sym->result->declared_at); |
| sym->result->attr.untyped = 1; |
| } |
| } |
| |
| /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character |
| type, lists the only ways a character length value of * can be used: |
| dummy arguments of procedures, named constants, and function results |
| in external functions. Internal function results and results of module |
| procedures are not on this list, ergo, not permitted. */ |
| |
| if (sym->result->ts.type == BT_CHARACTER) |
| { |
| gfc_charlen *cl = sym->result->ts.u.cl; |
| if ((!cl || !cl->length) && !sym->result->ts.deferred) |
| { |
| /* See if this is a module-procedure and adapt error message |
| accordingly. */ |
| bool module_proc; |
| gcc_assert (ns->parent && ns->parent->proc_name); |
| module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE); |
| |
| gfc_error (module_proc |
| ? G_("Character-valued module procedure %qs at %L" |
| " must not be assumed length") |
| : G_("Character-valued internal function %qs at %L" |
| " must not be assumed length"), |
| sym->name, &sym->declared_at); |
| } |
| } |
| } |
| |
| |
| /* Add NEW_ARGS to the formal argument list of PROC, taking care not to |
| introduce duplicates. */ |
| |
| static void |
| merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args) |
| { |
| gfc_formal_arglist *f, *new_arglist; |
| gfc_symbol *new_sym; |
| |
| for (; new_args != NULL; new_args = new_args->next) |
| { |
| new_sym = new_args->sym; |
| /* See if this arg is already in the formal argument list. */ |
| for (f = proc->formal; f; f = f->next) |
| { |
| if (new_sym == f->sym) |
| break; |
| } |
| |
| if (f) |
| continue; |
| |
| /* Add a new argument. Argument order is not important. */ |
| new_arglist = gfc_get_formal_arglist (); |
| new_arglist->sym = new_sym; |
| new_arglist->next = proc->formal; |
| proc->formal = new_arglist; |
| } |
| } |
| |
| |
| /* Flag the arguments that are not present in all entries. */ |
| |
| static void |
| check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args) |
| { |
| gfc_formal_arglist *f, *head; |
| head = new_args; |
| |
| for (f = proc->formal; f; f = f->next) |
| { |
| if (f->sym == NULL) |
| continue; |
| |
| for (new_args = head; new_args; new_args = new_args->next) |
| { |
| if (new_args->sym == f->sym) |
| break; |
| } |
| |
| if (new_args) |
| continue; |
| |
| f->sym->attr.not_always_present = 1; |
| } |
| } |
| |
| |
| /* Resolve alternate entry points. If a symbol has multiple entry points we |
| create a new master symbol for the main routine, and turn the existing |
| symbol into an entry point. */ |
| |
| static void |
| resolve_entries (gfc_namespace *ns) |
| { |
| gfc_namespace *old_ns; |
| gfc_code *c; |
| gfc_symbol *proc; |
| gfc_entry_list *el; |
| char name[GFC_MAX_SYMBOL_LEN + 1]; |
| static int master_count = 0; |
| |
| if (ns->proc_name == NULL) |
| return; |
| |
| /* No need to do anything if this procedure doesn't have alternate entry |
| points. */ |
| if (!ns->entries) |
| return; |
| |
| /* We may already have resolved alternate entry points. */ |
| if (ns->proc_name->attr.entry_master) |
| return; |
| |
| /* If this isn't a procedure something has gone horribly wrong. */ |
| gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE); |
| |
| /* Remember the current namespace. */ |
| old_ns = gfc_current_ns; |
| |
| gfc_current_ns = ns; |
| |
| /* Add the main entry point to the list of entry points. */ |
| el = gfc_get_entry_list (); |
| el->sym = ns->proc_name; |
| el->id = 0; |
| el->next = ns->entries; |
| ns->entries = el; |
| ns->proc_name->attr.entry = 1; |
| |
| /* If it is a module function, it needs to be in the right namespace |
| so that gfc_get_fake_result_decl can gather up the results. The |
| need for this arose in get_proc_name, where these beasts were |
| left in their own namespace, to keep prior references linked to |
| the entry declaration.*/ |
| if (ns->proc_name->attr.function |
| && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE) |
| el->sym->ns = ns; |
| |
| /* Do the same for entries where the master is not a module |
| procedure. These are retained in the module namespace because |
| of the module procedure declaration. */ |
| for (el = el->next; el; el = el->next) |
| if (el->sym->ns->proc_name->attr.flavor == FL_MODULE |
| && el->sym->attr.mod_proc) |
| el->sym->ns = ns; |
| el = ns->entries; |
| |
| /* Add an entry statement for it. */ |
| c = gfc_get_code (EXEC_ENTRY); |
| c->ext.entry = el; |
| c->next = ns->code; |
| ns->code = c; |
| |
| /* Create a new symbol for the master function. */ |
| /* Give the internal function a unique name (within this file). |
| Also include the function name so the user has some hope of figuring |
| out what is going on. */ |
| snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s", |
| master_count++, ns->proc_name->name); |
| gfc_get_ha_symbol (name, &proc); |
| gcc_assert (proc != NULL); |
| |
| gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL); |
| if (ns->proc_name->attr.subroutine) |
| gfc_add_subroutine (&proc->attr, proc->name, NULL); |
| else |
| { |
| gfc_symbol *sym; |
| gfc_typespec *ts, *fts; |
| gfc_array_spec *as, *fas; |
| gfc_add_function (&proc->attr, proc->name, NULL); |
| proc->result = proc; |
| fas = ns->entries->sym->as; |
| fas = fas ? fas : ns->entries->sym->result->as; |
| fts = &ns->entries->sym->result->ts; |
| if (fts->type == BT_UNKNOWN) |
| fts = gfc_get_default_type (ns->entries->sym->result->name, NULL); |
| for (el = ns->entries->next; el; el = el->next) |
| { |
| ts = &el->sym->result->ts; |
| as = el->sym->as; |
| as = as ? as : el->sym->result->as; |
| if (ts->type == BT_UNKNOWN) |
| ts = gfc_get_default_type (el->sym->result->name, NULL); |
| |
| if (! gfc_compare_types (ts, fts) |
| || (el->sym->result->attr.dimension |
| != ns->entries->sym->result->attr.dimension) |
| || (el->sym->result->attr.pointer |
| != ns->entries->sym->result->attr.pointer)) |
| break; |
| else if (as && fas && ns->entries->sym->result != el->sym->result |
| && gfc_compare_array_spec (as, fas) == 0) |
| gfc_error ("Function %s at %L has entries with mismatched " |
| "array specifications", ns->entries->sym->name, |
| &ns->entries->sym->declared_at); |
| /* The characteristics need to match and thus both need to have |
| the same string length, i.e. both len=*, or both len=4. |
| Having both len=<variable> is also possible, but difficult to |
| check at compile time. */ |
| else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl |
| && (((ts->u.cl->length && !fts->u.cl->length) |
| ||(!ts->u.cl->length && fts->u.cl->length)) |
| || (ts->u.cl->length |
| && ts->u.cl->length->expr_type |
| != fts->u.cl->length->expr_type) |
| || (ts->u.cl->length |
| && ts->u.cl->length->expr_type == EXPR_CONSTANT |
| && mpz_cmp (ts->u.cl->length->value.integer, |
| fts->u.cl->length->value.integer) != 0))) |
| gfc_notify_std (GFC_STD_GNU, "Function %s at %L with " |
| "entries returning variables of different " |
| "string lengths", ns->entries->sym->name, |
| &ns->entries->sym->declared_at); |
| } |
| |
| if (el == NULL) |
| { |
| sym = ns->entries->sym->result; |
| /* All result types the same. */ |
| proc->ts = *fts; |
| if (sym->attr.dimension) |
| gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL); |
| if (sym->attr.pointer) |
| gfc_add_pointer (&proc->attr, NULL); |
| } |
| else |
| { |
| /* Otherwise the result will be passed through a union by |
| reference. */ |
| proc->attr.mixed_entry_master = 1; |
| for (el = ns->entries; el; el = el->next) |
| { |
| sym = el->sym->result; |
| if (sym->attr.dimension) |
| { |
| if (el == ns->entries) |
| gfc_error ("FUNCTION result %s can't be an array in " |
| "FUNCTION %s at %L", sym->name, |
| ns->entries->sym->name, &sym->declared_at); |
| else |
| gfc_error ("ENTRY result %s can't be an array in " |
| "FUNCTION %s at %L", sym->name, |
| ns->entries->sym->name, &sym->declared_at); |
| } |
| else if (sym->attr.pointer) |
| { |
| if (el == ns->entries) |
| gfc_error ("FUNCTION result %s can't be a POINTER in " |
| "FUNCTION %s at %L", sym->name, |
| ns->entries->sym->name, &sym->declared_at); |
| else |
| gfc_error ("ENTRY result %s can't be a POINTER in " |
| "FUNCTION %s at %L", sym->name, |
| ns->entries->sym->name, &sym->declared_at); |
| } |
| else |
| { |
| ts = &sym->ts; |
| if (ts->type == BT_UNKNOWN) |
| ts = gfc_get_default_type (sym->name, NULL); |
| switch (ts->type) |
| { |
| case BT_INTEGER: |
| if (ts->kind == gfc_default_integer_kind) |
| sym = NULL; |
| break; |
| case BT_REAL: |
| if (ts->kind == gfc_default_real_kind |
| || ts->kind == gfc_default_double_kind) |
| sym = NULL; |
| break; |
| case BT_COMPLEX: |
| if (ts->kind == gfc_default_complex_kind) |
| sym = NULL; |
| break; |
| case BT_LOGICAL: |
| if (ts->kind == gfc_default_logical_kind) |
| sym = NULL; |
| break; |
| case BT_UNKNOWN: |
| /* We will issue error elsewhere. */ |
| sym = NULL; |
| break; |
| default: |
| break; |
| } |
| if (sym) |
| { |
| if (el == ns->entries) |
| gfc_error ("FUNCTION result %s can't be of type %s " |
| "in FUNCTION %s at %L", sym->name, |
| gfc_typename (ts), ns->entries->sym->name, |
| &sym->declared_at); |
| else |
| gfc_error ("ENTRY result %s can't be of type %s " |
| "in FUNCTION %s at %L", sym->name, |
| gfc_typename (ts), ns->entries->sym->name, |
| &sym->declared_at); |
| } |
| } |
| } |
| } |
| } |
| proc->attr.access = ACCESS_PRIVATE; |
| proc->attr.entry_master = 1; |
| |
| /* Merge all the entry point arguments. */ |
| for (el = ns->entries; el; el = el->next) |
| merge_argument_lists (proc, el->sym->formal); |
| |
| /* Check the master formal arguments for any that are not |
| present in all entry points. */ |
| for (el = ns->entries; el; el = el->next) |
| check_argument_lists (proc, el->sym->formal); |
| |
| /* Use the master function for the function body. */ |
| ns->proc_name = proc; |
| |
| /* Finalize the new symbols. */ |
| gfc_commit_symbols (); |
| |
| /* Restore the original namespace. */ |
| gfc_current_ns = old_ns; |
| } |
| |
| |
| /* Resolve common variables. */ |
| static void |
| resolve_common_vars (gfc_common_head *common_block, bool named_common) |
| { |
| gfc_symbol *csym = common_block->head; |
| |
| for (; csym; csym = csym->common_next) |
| { |
| /* gfc_add_in_common may have been called before, but the reported errors |
| have been ignored to continue parsing. |
| We do the checks again here. */ |
| if (!csym->attr.use_assoc) |
| gfc_add_in_common (&csym->attr, csym->name, &common_block->where); |
| |
| if (csym->value || csym->attr.data) |
| { |
| if (!csym->ns->is_block_data) |
| gfc_notify_std (GFC_STD_GNU, "Variable %qs at %L is in COMMON " |
| "but only in BLOCK DATA initialization is " |
| "allowed", csym->name, &csym->declared_at); |
| else if (!named_common) |
| gfc_notify_std (GFC_STD_GNU, "Initialized variable %qs at %L is " |
| "in a blank COMMON but initialization is only " |
| "allowed in named common blocks", csym->name, |
| &csym->declared_at); |
| } |
| |
| if (UNLIMITED_POLY (csym)) |
| gfc_error_now ("%qs in cannot appear in COMMON at %L " |
| "[F2008:C5100]", csym->name, &csym->declared_at); |
| |
| if (csym->ts.type != BT_DERIVED) |
| continue; |
| |
| if (!(csym->ts.u.derived->attr.sequence |
| || csym->ts.u.derived->attr.is_bind_c)) |
| gfc_error_now ("Derived type variable %qs in COMMON at %L " |
| "has neither the SEQUENCE nor the BIND(C) " |
| "attribute", csym->name, &csym->declared_at); |
| if (csym->ts.u.derived->attr.alloc_comp) |
| gfc_error_now ("Derived type variable %qs in COMMON at %L " |
| "has an ultimate component that is " |
| "allocatable", csym->name, &csym->declared_at); |
| if (gfc_has_default_initializer (csym->ts.u.derived)) |
| gfc_error_now ("Derived type variable %qs in COMMON at %L " |
| "may not have default initializer", csym->name, |
| &csym->declared_at); |
| |
| if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer) |
| gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at); |
| } |
| } |
| |
| /* Resolve common blocks. */ |
| static void |
| resolve_common_blocks (gfc_symtree *common_root) |
| { |
| gfc_symbol *sym; |
| gfc_gsymbol * gsym; |
| |
| if (common_root == NULL) |
| return; |
| |
| if (common_root->left) |
| resolve_common_blocks (common_root->left); |
| if (common_root->right) |
| resolve_common_blocks (common_root->right); |
| |
| resolve_common_vars (common_root->n.common, true); |
| |
| /* The common name is a global name - in Fortran 2003 also if it has a |
| C binding name, since Fortran 2008 only the C binding name is a global |
| identifier. */ |
| if (!common_root->n.common->binding_label |
| || gfc_notification_std (GFC_STD_F2008)) |
| { |
| gsym = gfc_find_gsymbol (gfc_gsym_root, |
| common_root->n.common->name); |
| |
| if (gsym && gfc_notification_std (GFC_STD_F2008) |
| && gsym->type == GSYM_COMMON |
| && ((common_root->n.common->binding_label |
| && (!gsym->binding_label |
| || strcmp (common_root->n.common->binding_label, |
| gsym->binding_label) != 0)) |
| || (!common_root->n.common->binding_label |
| && gsym->binding_label))) |
| { |
| gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global " |
| "identifier and must thus have the same binding name " |
| "as the same-named COMMON block at %L: %s vs %s", |
| common_root->n.common->name, &common_root->n.common->where, |
| &gsym->where, |
| common_root->n.common->binding_label |
| ? common_root->n.common->binding_label : "(blank)", |
| gsym->binding_label ? gsym->binding_label : "(blank)"); |
| return; |
| } |
| |
| if (gsym && gsym->type != GSYM_COMMON |
| && !common_root->n.common->binding_label) |
| { |
| gfc_error ("COMMON block %qs at %L uses the same global identifier " |
| "as entity at %L", |
| common_root->n.common->name, &common_root->n.common->where, |
| &gsym->where); |
| return; |
| } |
| if (gsym && gsym->type != GSYM_COMMON) |
| { |
| gfc_error ("Fortran 2008: COMMON block %qs with binding label at " |
| "%L sharing the identifier with global non-COMMON-block " |
| "entity at %L", common_root->n.common->name, |
| &common_root->n.common->where, &gsym->where); |
| return; |
| } |
| if (!gsym) |
| { |
| gsym = gfc_get_gsymbol (common_root->n.common->name); |
| gsym->type = GSYM_COMMON; |
| gsym->where = common_root->n.common->where; |
| gsym->defined = 1; |
| } |
| gsym->used = 1; |
| } |
| |
| if (common_root->n.common->binding_label) |
| { |
| gsym = gfc_find_gsymbol (gfc_gsym_root, |
| common_root->n.common->binding_label); |
| if (gsym && gsym->type != GSYM_COMMON) |
| { |
| gfc_error ("COMMON block at %L with binding label %qs uses the same " |
| "global identifier as entity at %L", |
| &common_root->n.common->where, |
| common_root->n.common->binding_label, &gsym->where); |
| return; |
| } |
| if (!gsym) |
| { |
| gsym = gfc_get_gsymbol (common_root->n.common->binding_label); |
| gsym->type = GSYM_COMMON; |
| gsym->where = common_root->n.common->where; |
| gsym->defined = 1; |
| } |
| gsym->used = 1; |
| } |
| |
| gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym); |
| if (sym == NULL) |
| return; |
| |
| if (sym->attr.flavor == FL_PARAMETER) |
| gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L", |
| sym->name, &common_root->n.common->where, &sym->declared_at); |
| |
| if (sym->attr.external) |
| gfc_error ("COMMON block %qs at %L can not have the EXTERNAL attribute", |
| sym->name, &common_root->n.common->where); |
| |
| if (sym->attr.intrinsic) |
| gfc_error ("COMMON block %qs at %L is also an intrinsic procedure", |
| sym->name, &common_root->n.common->where); |
| else if (sym->attr.result |
| || gfc_is_function_return_value (sym, gfc_current_ns)) |
| gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L " |
| "that is also a function result", sym->name, |
| &common_root->n.common->where); |
| else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL |
| && sym->attr.proc != PROC_ST_FUNCTION) |
| gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L " |
| "that is also a global procedure", sym->name, |
| &common_root->n.common->where); |
| } |
| |
| |
| /* Resolve contained function types. Because contained functions can call one |
| another, they have to be worked out before any of the contained procedures |
| can be resolved. |
| |
| The good news is that if a function doesn't already have a type, the only |
| way it can get one is through an IMPLICIT type or a RESULT variable, because |
| by definition contained functions are contained namespace they're contained |
| in, not in a sibling or parent namespace. */ |
| |
| static void |
| resolve_contained_functions (gfc_namespace *ns) |
| { |
| gfc_namespace *child; |
| gfc_entry_list *el; |
| |
| resolve_formal_arglists (ns); |
| |
| for (child = ns->contained; child; child = child->sibling) |
| { |
| /* Resolve alternate entry points first. */ |
| resolve_entries (child); |
| |
| /* Then check function return types. */ |
| resolve_contained_fntype (child->proc_name, child); |
| for (el = child->entries; el; el = el->next) |
| resolve_contained_fntype (el->sym, child); |
| } |
| } |
| |
| |
| |
| /* A Parameterized Derived Type constructor must contain values for |
| the PDT KIND parameters or they must have a default initializer. |
| Go through the constructor picking out the KIND expressions, |
| storing them in 'param_list' and then call gfc_get_pdt_instance |
| to obtain the PDT instance. */ |
| |
| static gfc_actual_arglist *param_list, *param_tail, *param; |
| |
| static bool |
| get_pdt_spec_expr (gfc_component *c, gfc_expr *expr) |
| { |
| param = gfc_get_actual_arglist (); |
| if (!param_list) |
| param_list = param_tail = param; |
| else |
| { |
| param_tail->next = param; |
| param_tail = param_tail->next; |
| } |
| |
| param_tail->name = c->name; |
| if (expr) |
| param_tail->expr = gfc_copy_expr (expr); |
| else if (c->initializer) |
| param_tail->expr = gfc_copy_expr (c->initializer); |
| else |
| { |
| param_tail->spec_type = SPEC_ASSUMED; |
| if (c->attr.pdt_kind) |
| { |
| gfc_error ("The KIND parameter %qs in the PDT constructor " |
| "at %C has no value", param->name); |
| return false; |
| } |
| } |
| |
| return true; |
| } |
| |
| static bool |
| get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr, |
| gfc_symbol *derived) |
| { |
| gfc_constructor *cons = NULL; |
| gfc_component *comp; |
| bool t = true; |
| |
| if (expr && expr->expr_type == EXPR_STRUCTURE) |
| cons = gfc_constructor_first (expr->value.constructor); |
| else if (constr) |
| cons = *constr; |
| gcc_assert (cons); |
| |
| comp = derived->components; |
| |
| for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons)) |
| { |
| if (cons->expr |
| && cons->expr->expr_type == EXPR_STRUCTURE |
| && comp->ts.type == BT_DERIVED) |
| { |
| t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived); |
| if (!t) |
| return t; |
| } |
| else if (comp->ts.type == BT_DERIVED) |
| { |
| t = get_pdt_constructor (NULL, &cons, comp->ts.u.derived); |
| if (!t) |
| return t; |
| } |
| else if ((comp->attr.pdt_kind || comp->attr.pdt_len) |
| && derived->attr.pdt_template) |
| { |
| t = get_pdt_spec_expr (comp, cons->expr); |
| if (!t) |
| return t; |
| } |
| } |
| return t; |
| } |
| |
| |
| static bool resolve_fl_derived0 (gfc_symbol *sym); |
| static bool resolve_fl_struct (gfc_symbol *sym); |
| |
| |
| /* Resolve all of the elements of a structure constructor and make sure that |
| the types are correct. The 'init' flag indicates that the given |
| constructor is an initializer. */ |
| |
| static bool |
| resolve_structure_cons (gfc_expr *expr, int init) |
| { |
| gfc_constructor *cons; |
| gfc_component *comp; |
| bool t; |
| symbol_attribute a; |
| |
| t = true; |
| |
| if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION) |
| { |
| if (expr->ts.u.derived->attr.flavor == FL_DERIVED) |
| resolve_fl_derived0 (expr->ts.u.derived); |
| else |
| resolve_fl_struct (expr->ts.u.derived); |
| |
| /* If this is a Parameterized Derived Type template, find the |
| instance corresponding to the PDT kind parameters. */ |
| if (expr->ts.u.derived->attr.pdt_template) |
| { |
| param_list = NULL; |
| t = get_pdt_constructor (expr, NULL, expr->ts.u.derived); |
| if (!t) |
| return t; |
| gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL); |
| |
| expr->param_list = gfc_copy_actual_arglist (param_list); |
| |
| if (param_list) |
| gfc_free_actual_arglist (param_list); |
| |
| if (!expr->ts.u.derived->attr.pdt_type) |
| return false; |
| } |
| } |
| |
| cons = gfc_constructor_first (expr->value.constructor); |
| |
| /* A constructor may have references if it is the result of substituting a |
| parameter variable. In this case we just pull out the component we |
| want. */ |
| if (expr->ref) |
| comp = expr->ref->u.c.sym->components; |
| else |
| comp = expr->ts.u.derived->components; |
| |
| for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons)) |
| { |
| int rank; |
| |
| if (!cons->expr) |
| continue; |
| |
| /* Unions use an EXPR_NULL contrived expression to tell the translation |
| phase to generate an initializer of the appropriate length. |
| Ignore it here. */ |
| if (cons->expr->ts.type == BT_UNION && cons->expr->expr_type == EXPR_NULL) |
| continue; |
| |
| if (!gfc_resolve_expr (cons->expr)) |
| { |
| t = false; |
| continue; |
| } |
| |
| rank = comp->as ? comp->as->rank : 0; |
| if (comp->ts.type == BT_CLASS |
| && !comp->ts.u.derived->attr.unlimited_polymorphic |
| && CLASS_DATA (comp)->as) |
| rank = CLASS_DATA (comp)->as->rank; |
| |
| if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank |
| && (comp->attr.allocatable || cons->expr->rank)) |
| { |
| gfc_error ("The rank of the element in the structure " |
| "constructor at %L does not match that of the " |
| "component (%d/%d)", &cons->expr->where, |
| cons->expr->rank, rank); |
| t = false; |
| } |
| |
| /* If we don't have the right type, try to convert it. */ |
| |
| if (!comp->attr.proc_pointer && |
| !gfc_compare_types (&cons->expr->ts, &comp->ts)) |
| { |
| if (strcmp (comp->name, "_extends") == 0) |
| { |
| /* Can afford to be brutal with the _extends initializer. |
| The derived type can get lost because it is PRIVATE |
| but it is not usage constrained by the standard. */ |
| cons->expr->ts = comp->ts; |
| } |
| else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN) |
| { |
| gfc_error ("The element in the structure constructor at %L, " |
| "for pointer component %qs, is %s but should be %s", |
| &cons->expr->where, comp->name, |
| gfc_basic_typename (cons->expr->ts.type), |
| gfc_basic_typename (comp->ts.type)); |
| t = false; |
| } |
| else |
| { |
| bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1); |
| if (t) |
| t = t2; |
| } |
| } |
| |
| /* For strings, the length of the constructor should be the same as |
| the one of the structure, ensure this if the lengths are known at |
| compile time and when we are dealing with PARAMETER or structure |
| constructors. */ |
| if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl |
| && comp->ts.u.cl->length |
| && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT |
| && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length |
| && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT |
| && cons->expr->rank != 0 |
| && mpz_cmp (cons->expr->ts.u.cl->length->value.integer, |
| comp->ts.u.cl->length->value.integer) != 0) |
| { |
| if (cons->expr->expr_type == EXPR_VARIABLE |
| && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER) |
| { |
| /* Wrap the parameter in an array constructor (EXPR_ARRAY) |
| to make use of the gfc_resolve_character_array_constructor |
| machinery. The expression is later simplified away to |
| an array of string literals. */ |
| gfc_expr *para = cons->expr; |
| cons->expr = gfc_get_expr (); |
| cons->expr->ts = para->ts; |
| cons->expr->where = para->where; |
| cons->expr->expr_type = EXPR_ARRAY; |
| cons->expr->rank = para->rank; |
| cons->expr->shape = gfc_copy_shape (para->shape, para->rank); |
| gfc_constructor_append_expr (&cons->expr->value.constructor, |
| para, &cons->expr->where); |
| } |
| |
| if (cons->expr->expr_type == EXPR_ARRAY) |
| { |
| /* Rely on the cleanup of the namespace to deal correctly with |
| the old charlen. (There was a block here that attempted to |
| remove the charlen but broke the chain in so doing.) */ |
| cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); |
| cons->expr->ts.u.cl->length_from_typespec = true; |
| cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length); |
| gfc_resolve_character_array_constructor (cons->expr); |
| } |
| } |
| |
| if (cons->expr->expr_type == EXPR_NULL |
| && !(comp->attr.pointer || comp->attr.allocatable |
| || comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID |
| || (comp->ts.type == BT_CLASS |
| && (CLASS_DATA (comp)->attr.class_pointer |
| || CLASS_DATA (comp)->attr.allocatable)))) |
| { |
| t = false; |
| gfc_error ("The NULL in the structure constructor at %L is " |
| "being applied to component %qs, which is neither " |
| "a POINTER nor ALLOCATABLE", &cons->expr->where, |
| comp->name); |
| } |
| |
| if (comp->attr.proc_pointer && comp->ts.interface) |
| { |
| /* Check procedure pointer interface. */ |
| gfc_symbol *s2 = NULL; |
| gfc_component *c2; |
| const char *name; |
| char err[200]; |
| |
| c2 = gfc_get_proc_ptr_comp (cons->expr); |
| if (c2) |
| { |
| s2 = c2->ts.interface; |
| name = c2->name; |
| } |
| else if (cons->expr->expr_type == EXPR_FUNCTION) |
| { |
| s2 = cons->expr->symtree->n.sym->result; |
| name = cons->expr->symtree->n.sym->result->name; |
| } |
| else if (cons->expr->expr_type != EXPR_NULL) |
| { |
| s2 = cons->expr->symtree->n.sym; |
| name = cons->expr->symtree->n.sym->name; |
| } |
| |
| if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1, |
| err, sizeof (err), NULL, NULL)) |
| { |
| gfc_error_opt (OPT_Wargument_mismatch, |
| "Interface mismatch for procedure-pointer " |
| "component %qs in structure constructor at %L:" |
| " %s", comp->name, &cons->expr->where, err); |
| return false; |
| } |
| } |
| |
| if (!comp->attr.pointer || comp->attr.proc_pointer |
| || cons->expr->expr_type == EXPR_NULL) |
| continue; |
| |
| a = gfc_expr_attr (cons->expr); |
| |
| if (!a.pointer && !a.target) |
| { |
| t = false; |
| gfc_error ("The element in the structure constructor at %L, " |
| "for pointer component %qs should be a POINTER or " |
| "a TARGET", &cons->expr->where, comp->name); |
| } |
| |
| if (init) |
| { |
| /* F08:C461. Additional checks for pointer initialization. */ |
| if (a.allocatable) |
| { |
| t = false; |
| gfc_error ("Pointer initialization target at %L " |
| "must not be ALLOCATABLE", &cons->expr->where); |
| } |
| if (!a.save) |
| { |
| t = false; |
| gfc_error ("Pointer initialization target at %L " |
| "must have the SAVE attribute", &cons->expr->where); |
| } |
| } |
| |
| /* F2003, C1272 (3). */ |
| bool impure = cons->expr->expr_type == EXPR_VARIABLE |
| && (gfc_impure_variable (cons->expr->symtree->n.sym) |
| || gfc_is_coindexed (cons->expr)); |
| if (impure && gfc_pure (NULL)) |
| { |
| t = false; |
| gfc_error ("Invalid expression in the structure constructor for " |
| "pointer component %qs at %L in PURE procedure", |
| comp->name, &cons->expr->where); |
| } |
| |
| if (impure) |
| gfc_unset_implicit_pure (NULL); |
| } |
| |
| return t; |
| } |
| |
| |
| /****************** Expression name resolution ******************/ |
| |
| /* Returns 0 if a symbol was not declared with a type or |
| attribute declaration statement, nonzero otherwise. */ |
| |
| static int |
| was_declared (gfc_symbol *sym) |
| { |
| symbol_attribute a; |
| |
| a = sym->attr; |
| |
| if (!a.implicit_type && sym->ts.type != BT_UNKNOWN) |
| return 1; |
| |
| if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic |
| || a.optional || a.pointer || a.save || a.target || a.volatile_ |
| || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN |
| || a.asynchronous || a.codimension) |
| return 1; |
| |
| return 0; |
| } |
| |
| |
| /* Determine if a symbol is generic or not. */ |
| |
| static int |
| generic_sym (gfc_symbol *sym) |
| { |
| gfc_symbol *s; |
| |
| if (sym->attr.generic || |
| (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name))) |
| return 1; |
| |
| if (was_declared (sym) || sym->ns->parent == NULL) |
| return 0; |
| |
| gfc_find_symbol (sym->name, sym->ns->parent, 1, &s); |
| |
| if (s != NULL) |
| { |
| if (s == sym) |
| return 0; |
| else |
| return generic_sym (s); |
| } |
| |
| return 0; |
| } |
| |
| |
| /* Determine if a symbol is specific or not. */ |
| |
| static int |
| specific_sym (gfc_symbol *sym) |
| { |
| gfc_symbol *s; |
| |
| if (sym->attr.if_source == IFSRC_IFBODY |
| || sym->attr.proc == PROC_MODULE |
| || sym->attr.proc == PROC_INTERNAL |
| || sym->attr.proc == PROC_ST_FUNCTION |
| || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name)) |
| || sym->attr.external) |
| return 1; |
| |
| if (was_declared (sym) || sym->ns->parent == NULL) |
| return 0; |
| |
| gfc_find_symbol (sym->name, sym->ns->parent, 1, &s); |
| |
| return (s == NULL) ? 0 : specific_sym (s); |
| } |
| |
| |
| /* Figure out if the procedure is specific, generic or unknown. */ |
| |
| enum proc_type |
| { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }; |
| |
| static proc_type |
| procedure_kind (gfc_symbol *sym) |
| { |
| if (generic_sym (sym)) |
| return PTYPE_GENERIC; |
| |
| if (specific_sym (sym)) |
| return PTYPE_SPECIFIC; |
| |
| return PTYPE_UNKNOWN; |
| } |
| |
| /* Check references to assumed size arrays. The flag need_full_assumed_size |
| is nonzero when matching actual arguments. */ |
| |
| static int need_full_assumed_size = 0; |
| |
| static bool |
| check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e) |
| { |
| if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE)) |
| return false; |
| |
| /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong. |
| What should it be? */ |
| if (e->ref && (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL) |
| && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE) |
| && (e->ref->u.ar.type == AR_FULL)) |
| { |
| gfc_error ("The upper bound in the last dimension must " |
| "appear in the reference to the assumed size " |
| "array %qs at %L", sym->name, &e->where); |
| return true; |
| } |
| return false; |
| } |
| |
| |
| /* Look for bad assumed size array references in argument expressions |
| of elemental and array valued intrinsic procedures. Since this is |
| called from procedure resolution functions, it only recurses at |
| operators. */ |
| |
| static bool |
| resolve_assumed_size_actual (gfc_expr *e) |
| { |
| if (e == NULL) |
| return false; |
| |
| switch (e->expr_type) |
| { |
| case EXPR_VARIABLE: |
| if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e)) |
| return true; |
| break; |
| |
| case EXPR_OP: |
| if (resolve_assumed_size_actual (e->value.op.op1) |
| || resolve_assumed_size_actual (e->value.op.op2)) |
| return true; |
| break; |
| |
| default: |
| break; |
| } |
| return false; |
| } |
| |
| |
| /* Check a generic procedure, passed as an actual argument, to see if |
| there is a matching specific name. If none, it is an error, and if |
| more than one, the reference is ambiguous. */ |
| static int |
| count_specific_procs (gfc_expr *e) |
| { |
| int n; |
| gfc_interface *p; |
| gfc_symbol *sym; |
| |
| n = 0; |
| sym = e->symtree->n.sym; |
| |
| for (p = sym->generic; p; p = p->next) |
| if (strcmp (sym->name, p->sym->name) == 0) |
| { |
| e->symtree = gfc_find_symtree (p->sym->ns->sym_root, |
| sym->name); |
| n++; |
| } |
| |
| if (n > 1) |
| gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name, |
| &e->where); |
| |
| if (n == 0) |
| gfc_error ("GENERIC procedure %qs is not allowed as an actual " |
| "argument at %L", sym->name, &e->where); |
| |
| return n; |
| } |
| |
| |
| /* See if a call to sym could possibly be a not allowed RECURSION because of |
| a missing RECURSIVE declaration. This means that either sym is the current |
| context itself, or sym is the parent of a contained procedure calling its |
| non-RECURSIVE containing procedure. |
| This also works if sym is an ENTRY. */ |
| |
| static bool |
| is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context) |
| { |
| gfc_symbol* proc_sym; |
| gfc_symbol* context_proc; |
| gfc_namespace* real_context; |
| |
| if (sym->attr.flavor == FL_PROGRAM |
| || gfc_fl_struct (sym->attr.flavor)) |
| return false; |
| |
| gcc_assert (sym->attr.flavor == FL_PROCEDURE); |
| |
| /* If we've got an ENTRY, find real procedure. */ |
| if (sym->attr.entry && sym->ns->entries) |
| proc_sym = sym->ns->entries->sym; |
| else |
| proc_sym = sym; |
| |
| /* If sym is RECURSIVE, all is well of course. */ |
| if (proc_sym->attr.recursive || flag_recursive) |
| return false; |
| |
| /* Find the context procedure's "real" symbol if it has entries. |
| We look for a procedure symbol, so recurse on the parents if we don't |
| find one (like in case of a BLOCK construct). */ |
| for (real_context = context; ; real_context = real_context->parent) |
| { |
| /* We should find something, eventually! */ |
| gcc_assert (real_context); |
| |
| context_proc = (real_context->entries ? real_context->entries->sym |
| : real_context->proc_name); |
| |
| /* In some special cases, there may not be a proc_name, like for this |
| invalid code: |
| real(bad_kind()) function foo () ... |
| when checking the call to bad_kind (). |
| In these cases, we simply return here and assume that the |
| call is ok. */ |
| if (!context_proc) |
| return false; |
| |
| if (context_proc->attr.flavor != FL_LABEL) |
| break; |
| } |
| |
| /* A call from sym's body to itself is recursion, of course. */ |
| if (context_proc == proc_sym) |
| return true; |
| |
| /* The same is true if context is a contained procedure and sym the |
| containing one. */ |
| if (context_proc->attr.contained) |
| { |
| gfc_symbol* parent_proc; |
| |
| gcc_assert (context->parent); |
| parent_proc = (context->parent->entries ? context->parent->entries->sym |
| : context->parent->proc_name); |
| |
| if (parent_proc == proc_sym) |
| return true; |
| } |
| |
| return false; |
| } |
| |
| |
| /* Resolve an intrinsic procedure: Set its function/subroutine attribute, |
| its typespec and formal argument list. */ |
| |
| bool |
| gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc) |
| { |
| gfc_intrinsic_sym* isym = NULL; |
| const char* symstd; |
| |
| if (sym->formal) |
| return true; |
| |
| /* Already resolved. */ |
| if (sym->from_intmod && sym->ts.type != BT_UNKNOWN) |
| return true; |
| |
| /* We already know this one is an intrinsic, so we don't call |
| gfc_is_intrinsic for full checking but rather use gfc_find_function and |
| gfc_find_subroutine directly to check whether it is a function or |
| subroutine. */ |
| |
| if (sym->intmod_sym_id && sym->attr.subroutine) |
| { |
| gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym); |
| isym = gfc_intrinsic_subroutine_by_id (id); |
| } |
| else if (sym->intmod_sym_id) |
| { |
| gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym); |
| isym = gfc_intrinsic_function_by_id (id); |
| } |
| else if (!sym->attr.subroutine) |
| isym = gfc_find_function (sym->name); |
| |
| if (isym && !sym->attr.subroutine) |
| { |
| if (sym->ts.type != BT_UNKNOWN && warn_surprising |
| && !sym->attr.implicit_type) |
| gfc_warning (OPT_Wsurprising, |
| "Type specified for intrinsic function %qs at %L is" |
| " ignored", sym->name, &sym->declared_at); |
| |
| if (!sym->attr.function && |
| !gfc_add_function(&sym->attr, sym->name, loc)) |
| return false; |
| |
| sym->ts = isym->ts; |
| } |
| else if (isym || (isym = gfc_find_subroutine (sym->name))) |
| { |
| if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type) |
| { |
| gfc_error ("Intrinsic subroutine %qs at %L shall not have a type" |
| " specifier", sym->name, &sym->declared_at); |
| return false; |
| } |
| |
| if (!sym->attr.subroutine && |
| !gfc_add_subroutine(&sym->attr, sym->name, loc)) |
| return false; |
| } |
| else |
| { |
| gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name, |
| &sym->declared_at); |
| return false; |
| } |
| |
| gfc_copy_formal_args_intr (sym, isym, NULL); |
| |
| sym->attr.pure = isym->pure; |
| sym->attr.elemental = isym->elemental; |
| |
| /* Check it is actually available in the standard settings. */ |
| if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)) |
| { |
| gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not " |
| "available in the current standard settings but %s. Use " |
| "an appropriate %<-std=*%> option or enable " |
| "%<-fall-intrinsics%> in order to use it.", |
| sym->name, &sym->declared_at, symstd); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| /* Resolve a procedure expression, like passing it to a called procedure or as |
| RHS for a procedure pointer assignment. */ |
| |
| static bool |
| resolve_procedure_expression (gfc_expr* expr) |
| { |
| gfc_symbol* sym; |
| |
| if (expr->expr_type != EXPR_VARIABLE) |
| return true; |
| gcc_assert (expr->symtree); |
| |
| sym = expr->symtree->n.sym; |
| |
| if (sym->attr.intrinsic) |
| gfc_resolve_intrinsic (sym, &expr->where); |
| |
| if (sym->attr.flavor != FL_PROCEDURE |
| || (sym->attr.function && sym->result == sym)) |
| return true; |
| |
| /* A non-RECURSIVE procedure that is used as procedure expression within its |
| own body is in danger of being called recursively. */ |
| if (is_illegal_recursion (sym, gfc_current_ns)) |
| gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling" |
| " itself recursively. Declare it RECURSIVE or use" |
| " %<-frecursive%>", sym->name, &expr->where); |
| |
| return true; |
| } |
| |
| |
| /* Resolve an actual argument list. Most of the time, this is just |
| resolving the expressions in the list. |
| The exception is that we sometimes have to decide whether arguments |
| that look like procedure arguments are really simple variable |
| references. */ |
| |
| static bool |
| resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, |
| bool no_formal_args) |
| { |
| gfc_symbol *sym; |
| gfc_symtree *parent_st; |
| gfc_expr *e; |
| gfc_component *comp; |
| int save_need_full_assumed_size; |
| bool return_value = false; |
| bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg; |
| |
| actual_arg = true; |
| first_actual_arg = true; |
| |
| for (; arg; arg = arg->next) |
| { |
| e = arg->expr; |
| if (e == NULL) |
| { |
| /* Check the label is a valid branching target. */ |
| if (arg->label) |
| { |
| if (arg->label->defined == ST_LABEL_UNKNOWN) |
| { |
| gfc_error ("Label %d referenced at %L is never defined", |
| arg->label->value, &arg->label->where); |
| goto cleanup; |
| } |
| } |
| first_actual_arg = false; |
| continue; |
| } |
| |
| if (e->expr_type == EXPR_VARIABLE |
| && e->symtree->n.sym->attr.generic |
| && no_formal_args |
| && count_specific_procs (e) != 1) |
| goto cleanup; |
| |
| if (e->ts.type != BT_PROCEDURE) |
| { |
| save_need_full_assumed_size = need_full_assumed_size; |
| if (e->expr_type != EXPR_VARIABLE) |
| need_full_assumed_size = 0; |
| if (!gfc_resolve_expr (e)) |
| goto cleanup; |
| need_full_assumed_size = save_need_full_assumed_size; |
| goto argument_list; |
| } |
| |
| /* See if the expression node should really be a variable reference. */ |
| |
| sym = e->symtree->n.sym; |
| |
| if (sym->attr.flavor == FL_PROCEDURE |
| || sym->attr.intrinsic |
| || sym->attr.external) |
| { |
| int actual_ok; |
| |
| /* If a procedure is not already determined to be something else |
| check if it is intrinsic. */ |
| if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where)) |
| sym->attr.intrinsic = 1; |
| |
| if (sym->attr.proc == PROC_ST_FUNCTION) |
| { |
| gfc_error ("Statement function %qs at %L is not allowed as an " |
| "actual argument", sym->name, &e->where); |
| } |
| |
| actual_ok = gfc_intrinsic_actual_ok (sym->name, |
| sym->attr.subroutine); |
| if (sym->attr.intrinsic && actual_ok == 0) |
| { |
| gfc_error ("Intrinsic %qs at %L is not allowed as an " |
| "actual argument", sym->name, &e->where); |
| } |
| |
| if (sym->attr.contained && !sym->attr.use_assoc |
| && sym->ns->proc_name->attr.flavor != FL_MODULE) |
| { |
| if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure %qs is" |
| " used as actual argument at %L", |
| sym->name, &e->where)) |
| goto cleanup; |
| } |
| |
| if (sym->attr.elemental && !sym->attr.intrinsic) |
| { |
| gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not " |
| "allowed as an actual argument at %L", sym->name, |
| &e->where); |
| } |
| |
| /* Check if a generic interface has a specific procedure |
| with the same name before emitting an error. */ |
| if (sym->attr.generic && count_specific_procs (e) != 1) |
| goto cleanup; |
| |
| /* Just in case a specific was found for the expression. */ |
| sym = e->symtree->n.sym; |
| |
| /* If the symbol is the function that names the current (or |
| parent) scope, then we really have a variable reference. */ |
| |
| if (gfc_is_function_return_value (sym, sym->ns)) |
| goto got_variable; |
| |
| /* If all else fails, see if we have a specific intrinsic. */ |
| if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic) |
| { |
| gfc_intrinsic_sym *isym; |
| |
| isym = gfc_find_function (sym->name); |
| if (isym == NULL || !isym->specific) |
| { |
| gfc_error ("Unable to find a specific INTRINSIC procedure " |
| "for the reference %qs at %L", sym->name, |
| &e->where); |
| goto cleanup; |
| } |
| sym->ts = isym->ts; |
| sym->attr.intrinsic = 1; |
| sym->attr.function = 1; |
| } |
| |
| if (!gfc_resolve_expr (e)) |
| goto cleanup; |
| goto argument_list; |
| } |
| |
| /* See if the name is a module procedure in a parent unit. */ |
| |
| if (was_declared (sym) || sym->ns->parent == NULL) |
| goto got_variable; |
| |
| if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st)) |
| { |
| gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where); |
| goto cleanup; |
| } |
| |
| if (parent_st == NULL) |
| goto got_variable; |
| |
| sym = parent_st->n.sym; |
| e->symtree = parent_st; /* Point to the right thing. */ |
| |
| if (sym->attr.flavor == FL_PROCEDURE |
| || sym->attr.intrinsic |
| || sym->attr.external) |
| { |
| if (!gfc_resolve_expr (e)) |
| goto cleanup; |
| goto argument_list; |
| } |
| |
| got_variable: |
| e->expr_type = EXPR_VARIABLE; |
| e->ts = sym->ts; |
| if ((sym->as != NULL && sym->ts.type != BT_CLASS) |
| || (sym->ts.type == BT_CLASS && sym->attr.class_ok |
| && CLASS_DATA (sym)->as)) |
| { |
| e->rank = sym->ts.type == BT_CLASS |
| ? CLASS_DATA (sym)->as->rank : sym->as->rank; |
| e->ref = gfc_get_ref (); |
| e->ref->type = REF_ARRAY; |
| e->ref->u.ar.type = AR_FULL; |
| e->ref->u.ar.as = sym->ts.type == BT_CLASS |
| ? CLASS_DATA (sym)->as : sym->as; |
| } |
| |
| /* Expressions are assigned a default ts.type of BT_PROCEDURE in |
| primary.c (match_actual_arg). If above code determines that it |
| is a variable instead, it needs to be resolved as it was not |
| done at the beginning of this function. */ |
| save_need_full_assumed_size = need_full_assumed_size; |
| if (e->expr_type != EXPR_VARIABLE) |
| need_full_assumed_size = 0; |
| if (!gfc_resolve_expr (e)) |
| goto cleanup; |
| need_full_assumed_size = save_need_full_assumed_size; |
| |
| argument_list: |
| /* Check argument list functions %VAL, %LOC and %REF. There is |
| nothing to do for %REF. */ |
| if (arg->name && arg->name[0] == '%') |
| { |
| if (strncmp ("%VAL", arg->name, 4) == 0) |
| { |
| if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED) |
| { |
| gfc_error ("By-value argument at %L is not of numeric " |
| "type", &e->where); |
| goto cleanup; |
| } |
| |
| if (e->rank) |
| { |
| gfc_error ("By-value argument at %L cannot be an array or " |
| "an array section", &e->where); |
| goto cleanup; |
| } |
| |
| /* Intrinsics are still PROC_UNKNOWN here. However, |
| since same file external procedures are not resolvable |
| in gfortran, it is a good deal easier to leave them to |
| intrinsic.c. */ |
| if (ptype != PROC_UNKNOWN |
| && ptype != PROC_DUMMY |
| && ptype != PROC_EXTERNAL |
| && ptype != PROC_MODULE) |
| { |
| gfc_error ("By-value argument at %L is not allowed " |
| "in this context", &e->where); |
| goto cleanup; |
| } |
| } |
| |
| /* Statement functions have already been excluded above. */ |
| else if (strncmp ("%LOC", arg->name, 4) == 0 |
| && e->ts.type == BT_PROCEDURE) |
| { |
| if (e->symtree->n.sym->attr.proc == PROC_INTERNAL) |
| { |
| gfc_error ("Passing internal procedure at %L by location " |
| "not allowed", &e->where); |
| goto cleanup; |
| } |
| } |
| } |
| |
| comp = gfc_get_proc_ptr_comp(e); |
| if (e->expr_type == EXPR_VARIABLE |
| && comp && comp->attr.elemental) |
| { |
| gfc_error ("ELEMENTAL procedure pointer component %qs is not " |
| "allowed as an actual argument at %L", comp->name, |
| &e->where); |
| } |
| |
| /* Fortran 2008, C1237. */ |
| if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e) |
| && gfc_has_ultimate_pointer (e)) |
| { |
| gfc_error ("Coindexed actual argument at %L with ultimate pointer " |
| "component", &e->where); |
| goto cleanup; |
| } |
| |
| first_actual_arg = false; |
| } |
| |
| return_value = true; |
| |
| cleanup: |
| actual_arg = actual_arg_sav; |
| first_actual_arg = first_actual_arg_sav; |
| |
| return return_value; |
| } |
| |
| |
| /* Do the checks of the actual argument list that are specific to elemental |
| procedures. If called with c == NULL, we have a function, otherwise if |
| expr == NULL, we have a subroutine. */ |
| |
| static bool |
| resolve_elemental_actual (gfc_expr *expr, gfc_code *c) |
| { |
| gfc_actual_arglist *arg0; |
| gfc_actual_arglist *arg; |
| gfc_symbol *esym = NULL; |
| gfc_intrinsic_sym *isym = NULL; |
| gfc_expr *e = NULL; |
| gfc_intrinsic_arg *iformal = NULL; |
| gfc_formal_arglist *eformal = NULL; |
| bool formal_optional = false; |
| bool set_by_optional = false; |
| int i; |
| int rank = 0; |
| |
| /* Is this an elemental procedure? */ |
| if (expr && expr->value.function.actual != NULL) |
| { |
| if (expr->value.function.esym != NULL |
| && expr->value.function.esym->attr.elemental) |
| { |
| arg0 = expr->value.function.actual; |
| esym = expr->value.function.esym; |
| } |
| else if (expr->value.function.isym != NULL |
| && expr->value.function.isym->elemental) |
| { |
| arg0 = expr->value.function.actual; |
| isym = expr->value.function.isym; |
| } |
| else |
| return true; |
| } |
| else if (c && c->ext.actual != NULL) |
| { |
| arg0 = c->ext.actual; |
| |
| if (c->resolved_sym) |
| esym = c->resolved_sym; |
| else |
| esym = c->symtree->n.sym; |
| gcc_assert (esym); |
| |
| if (!esym->attr.elemental) |
| return true; |
| } |
| else |
| return true; |
| |
| /* The rank of an elemental is the rank of its array argument(s). */ |
| for (arg = arg0; arg; arg = arg->next) |
| { |
| if (arg->expr != NULL && arg->expr->rank != 0) |
| { |
| rank = arg->expr->rank; |
| if (arg->expr->expr_type == EXPR_VARIABLE |
| && arg->expr->symtree->n.sym->attr.optional) |
| set_by_optional = true; |
| |
| /* Function specific; set the result rank and shape. */ |
| if (expr) |
| { |
| expr->rank = rank; |
| if (!expr->shape && arg->expr->shape) |
| { |
| expr->shape = gfc_get_shape (rank); |
| for (i = 0; i < rank; i++) |
| mpz_init_set (expr->shape[i], arg->expr->shape[i]); |
| } |
| } |
| break; |
| } |
| } |
| |
| /* If it is an array, it shall not be supplied as an actual argument |
| to an elemental procedure unless an array of the same rank is supplied |
| as an actual argument corresponding to a nonoptional dummy argument of |
| that elemental procedure(12.4.1.5). */ |
| formal_optional = false; |
| if (isym) |
| iformal = isym->formal; |
| else |
| eformal = esym->formal; |
| |
| for (arg = arg0; arg; arg = arg->next) |
| { |
| if (eformal) |
| { |
| if (eformal->sym && eformal->sym->attr.optional) |
| formal_optional = true; |
| eformal = eformal->next; |
| } |
| else if (isym && iformal) |
| { |
| if (iformal->optional) |
| formal_optional = true; |
| iformal = iformal->next; |
| } |
| else if (isym) |
| formal_optional = true; |
| |
| if (pedantic && arg->expr != NULL |
| && arg->expr->expr_type == EXPR_VARIABLE |
| && arg->expr->symtree->n.sym->attr.optional |
| && formal_optional |
| && arg->expr->rank |
| && (set_by_optional || arg->expr->rank != rank) |
| && !(isym && isym->id == GFC_ISYM_CONVERSION)) |
| { |
| gfc_warning (OPT_Wpedantic, |
| "%qs at %L is an array and OPTIONAL; IF IT IS " |
| "MISSING, it cannot be the actual argument of an " |
| "ELEMENTAL procedure unless there is a non-optional " |
| "argument with the same rank (12.4.1.5)", |
| arg->expr->symtree->n.sym->name, &arg->expr->where); |
| } |
| } |
| |
| for (arg = arg0; arg; arg = arg->next) |
| { |
| if (arg->expr == NULL || arg->expr->rank == 0) |
| continue; |
| |
| /* Being elemental, the last upper bound of an assumed size array |
| argument must be present. */ |
| if (resolve_assumed_size_actual (arg->expr)) |
| return false; |
| |
| /* Elemental procedure's array actual arguments must conform. */ |
| if (e != NULL) |
| { |
| if (!gfc_check_conformance (arg->expr, e, "elemental procedure")) |
| return false; |
| } |
| else |
| e = arg->expr; |
| } |
| |
| /* INTENT(OUT) is only allowed for subroutines; if any actual argument |
| is an array, the intent inout/out variable needs to be also an array. */ |
| if (rank > 0 && esym && expr == NULL) |
| for (eformal = esym->formal, arg = arg0; arg && eformal; |
| arg = arg->next, eformal = eformal->next) |
| if ((eformal->sym->attr.intent == INTENT_OUT |
| || eformal->sym->attr.intent == INTENT_INOUT) |
| && arg->expr && arg->expr->rank == 0) |
| { |
| gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of " |
| "ELEMENTAL subroutine %qs is a scalar, but another " |
| "actual argument is an array", &arg->expr->where, |
| (eformal->sym->attr.intent == INTENT_OUT) ? "OUT" |
| : "INOUT", eformal->sym->name, esym->name); |
| return false; |
| } |
| return true; |
| } |
| |
| |
| /* This function does the checking of references to global procedures |
| as defined in sections 18.1 and 14.1, respectively, of the Fortran |
| 77 and 95 standards. It checks for a gsymbol for the name, making |
| one if it does not already exist. If it already exists, then the |
| reference being resolved must correspond to the type of gsymbol. |
| Otherwise, the new symbol is equipped with the attributes of the |
| reference. The corresponding code that is called in creating |
| global entities is parse.c. |
| |
| In addition, for all but -std=legacy, the gsymbols are used to |
| check the interfaces of external procedures from the same file. |
| The namespace of the gsymbol is resolved and then, once this is |
| done the interface is checked. */ |
| |
| |
| static bool |
| not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns) |
| { |
| if (!gsym_ns->proc_name->attr.recursive) |
| return true; |
| |
| if (sym->ns == gsym_ns) |
| return false; |
| |
| if (sym->ns->parent && sym->ns->parent == gsym_ns) |
| return false; |
| |
| return true; |
| } |
| |
| static bool |
| not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns) |
| { |
| if (gsym_ns->entries) |
| { |
| gfc_entry_list *entry = gsym_ns->entries; |
| |
| for (; entry; entry = entry->next) |
| { |
| if (strcmp (sym->name, entry->sym->name) == 0) |
| { |
| if (strcmp (gsym_ns->proc_name->name, |
| sym->ns->proc_name->name) == 0) |
| return false; |
| |
| if (sym->ns->parent |
| && strcmp (gsym_ns->proc_name->name, |
| sym->ns->parent->proc_name->name) == 0) |
| return false; |
| } |
| } |
| } |
| return true; |
| } |
| |
| |
| /* Check for the requirement of an explicit interface. F08:12.4.2.2. */ |
| |
| bool |
| gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len) |
| { |
| gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym); |
| |
| for ( ; arg; arg = arg->next) |
| { |
| if (!arg->sym) |
| continue; |
| |
| if (arg->sym->attr.allocatable) /* (2a) */ |
| { |
| strncpy (errmsg, _("allocatable argument"), err_len); |
| return true; |
| } |
| else if (arg->sym->attr.asynchronous) |
| { |
| strncpy (errmsg, _("asynchronous argument"), err_len); |
| return true; |
| } |
| else if (arg->sym->attr.optional) |
| { |
| strncpy (errmsg, _("optional argument"), err_len); |
| return true; |
| } |
| else if (arg->sym->attr.pointer) |
| { |
| strncpy (errmsg, _("pointer argument"), err_len); |
| return true; |
| } |
| else if (arg->sym->attr.target) |
| { |
| strncpy (errmsg, _("target argument"), err_len); |
| return true; |
| } |
| else if (arg->sym->attr.value) |
| { |
| strncpy (errmsg, _("value argument"), err_len); |
| return true; |
| } |
| else if (arg->sym->attr.volatile_) |
| { |
| strncpy (errmsg, _("volatile argument"), err_len); |
| return true; |
| } |
| else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE) /* (2b) */ |
| { |
| strncpy (errmsg, _("assumed-shape argument"), err_len); |
| return true; |
| } |
| else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK) /* TS 29113, 6.2. */ |
| { |
| strncpy (errmsg, _("assumed-rank argument"), err_len); |
| return true; |
| } |
| else if (arg->sym->attr.codimension) /* (2c) */ |
| { |
| strncpy (errmsg, _("coarray argument"), err_len); |
| return true; |
| } |
| else if (false) /* (2d) TODO: parametrized derived type */ |
| { |
| strncpy (errmsg, _("parametrized derived type argument"), err_len); |
| return true; |
| } |
| else if (arg->sym->ts.type == BT_CLASS) /* (2e) */ |
| { |
| strncpy (errmsg, _("polymorphic argument"), err_len); |
| return true; |
| } |
| else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) |
| { |
| strncpy (errmsg, _("NO_ARG_CHECK attribute"), err_len); |
| return true; |
| } |
| else if (arg->sym->ts.type == BT_ASSUMED) |
| { |
| /* As assumed-type is unlimited polymorphic (cf. above). |
| See also TS 29113, Note 6.1. */ |
| strncpy (errmsg, _("assumed-type argument"), err_len); |
| return true; |
| } |
| } |
| |
| if (sym->attr.function) |
| { |
| gfc_symbol *res = sym->result ? sym->result : sym; |
| |
| if (res->attr.dimension) /* (3a) */ |
| { |
| strncpy (errmsg, _("array result"), err_len); |
| return true; |
| } |
| else if (res->attr.pointer || res->attr.allocatable) /* (3b) */ |
| { |
| strncpy (errmsg, _("pointer or allocatable result"), err_len); |
| return true; |
| } |
| else if (res->ts.type == BT_CHARACTER && res->ts.u.cl |
| && res->ts.u.cl->length |
| && res->ts.u.cl->length->expr_type != EXPR_CONSTANT) /* (3c) */ |
| { |
| strncpy (errmsg, _("result with non-constant character length"), err_len); |
| return true; |
| } |
| } |
| |
| if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */ |
| { |
| strncpy (errmsg, _("elemental procedure"), err_len); |
| return true; |
| } |
| else if (sym->attr.is_bind_c) /* (5) */ |
| { |
| strncpy (errmsg, _("bind(c) procedure"), err_len); |
| return true; |
| } |
| |
| return false; |
| } |
| |
| |
| static void |
| resolve_global_procedure (gfc_symbol *sym, locus *where, |
| gfc_actual_arglist **actual, int sub) |
| { |
| gfc_gsymbol * gsym; |
| gfc_namespace *ns; |
| enum gfc_symbol_type type; |
| char reason[200]; |
| |
| type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; |
| |
| gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name); |
| |
| if ((gsym->type != GSYM_UNKNOWN && gsym->type != type)) |
| gfc_global_used (gsym, where); |
| |
| if ((sym->attr.if_source == IFSRC_UNKNOWN |
| || sym->attr.if_source == IFSRC_IFBODY) |
| && gsym->type != GSYM_UNKNOWN |
| && !gsym->binding_label |
| && gsym->ns |
| && gsym->ns->resolved != -1 |
| && gsym->ns->proc_name |
| && not_in_recursive (sym, gsym->ns) |
| && not_entry_self_reference (sym, gsym->ns)) |
| { |
| gfc_symbol *def_sym; |
| |
| /* Resolve the gsymbol namespace if needed. */ |
| if (!gsym->ns->resolved) |
| { |
| gfc_dt_list *old_dt_list; |
| |
| /* Stash away derived types so that the backend_decls do not |
| get mixed up. */ |
| old_dt_list = gfc_derived_types; |
| gfc_derived_types = NULL; |
| |
| gfc_resolve (gsym->ns); |
| |
| /* Store the new derived types with the global namespace. */ |
| if (gfc_derived_types) |
| gsym->ns->derived_types = gfc_derived_types; |
| |
| /* Restore the derived types of this namespace. */ |
| gfc_derived_types = old_dt_list; |
| } |
| |
| /* Make sure that translation for the gsymbol occurs before |
| the procedure currently being resolved. */ |
| ns = gfc_global_ns_list; |
| for (; ns && ns != gsym->ns; ns = ns->sibling) |
| { |
| if (ns->sibling == gsym->ns) |
| { |
| ns->sibling = gsym->ns->sibling; |
| gsym->ns->sibling = gfc_global_ns_list; |
| gfc_global_ns_list = gsym->ns; |
| break; |
| } |
| } |
| |
| def_sym = gsym->ns->proc_name; |
| |
| /* This can happen if a binding name has been specified. */ |
| if (gsym->binding_label && gsym->sym_name != def_sym->name) |
| gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym); |
| |
| if (def_sym->attr.entry_master) |
| { |
| gfc_entry_list *entry; |
| for (entry = gsym->ns->entries; entry; entry = entry->next) |
| if (strcmp (entry->sym->name, sym->name) == 0) |
| { |
| def_sym = entry->sym; |
| break; |
| } |
| } |
| |
| if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts)) |
| { |
| gfc_error ("Return type mismatch of function %qs at %L (%s/%s)", |
| sym->name, &sym->declared_at, gfc_typename (&sym->ts), |
| gfc_typename (&def_sym->ts)); |
| goto done; |
| } |
| |
| if (sym->attr.if_source == IFSRC_UNKNOWN |
| && gfc_explicit_interface_required (def_sym, reason, sizeof(reason))) |
| { |
| gfc_error ("Explicit interface required for %qs at %L: %s", |
| sym->name, &sym->declared_at, reason); |
| goto done; |
| } |
| |
| if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU)) |
| /* Turn erros into warnings with -std=gnu and -std=legacy. */ |
| gfc_errors_to_warnings (true); |
| |
| if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, |
| reason, sizeof(reason), NULL, NULL)) |
| { |
| gfc_error_opt (OPT_Wargument_mismatch, |
| "Interface mismatch in global procedure %qs at %L:" |
| " %s", sym->name, &sym->declared_at, reason); |
| goto done; |
| } |
| |
| if (!pedantic |
| || ((gfc_option.warn_std & GFC_STD_LEGACY) |
| && !(gfc_option.warn_std & GFC_STD_GNU))) |
| gfc_errors_to_warnings (true); |
| |
| if (sym->attr.if_source != IFSRC_IFBODY) |
| gfc_procedure_use (def_sym, actual, where); |
| } |
| |
| done: |
| gfc_errors_to_warnings (false); |
| |
| if (gsym->type == GSYM_UNKNOWN) |
| { |
| gsym->type = type; |
| gsym->where = *where; |
| } |
| |
| gsym->used = 1; |
| } |
| |
| |
| /************* Function resolution *************/ |
| |
| /* Resolve a function call known to be generic. |
| Section 14.1.2.4.1. */ |
| |
| static match |
| resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym) |
| { |
| gfc_symbol *s; |
| |
| if (sym->attr.generic) |
| { |
| s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual); |
| if (s != NULL) |
| { |
| expr->value.function.name = s->name; |
| expr->value.function.esym = s; |
| |
| if (s->ts.type != BT_UNKNOWN) |
| expr->ts = s->ts; |
| else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN) |
| expr->ts = s->result->ts; |
| |
| if (s->as != NULL) |
| expr->rank = s->as->rank; |
| else if (s->result != NULL && s->result->as != NULL) |
| expr->rank = s->result->as->rank; |
| |
| gfc_set_sym_referenced (expr->value.function.esym); |
| |
| return MATCH_YES; |
| } |
| |
| /* TODO: Need to search for elemental references in generic |
| interface. */ |
| } |
| |
| if (sym->attr.intrinsic) |
| return gfc_intrinsic_func_interface (expr, 0); |
| |
| return MATCH_NO; |
| } |
| |
| |
| static bool |
| resolve_generic_f (gfc_expr *expr) |
| { |
| gfc_symbol *sym; |
| match m; |
| gfc_interface *intr = NULL; |
| |
| sym = expr->symtree->n.sym; |
| |
| for (;;) |
| { |
| m = resolve_generic_f0 (expr, sym); |
| if (m == MATCH_YES) |
| return true; |
| else if (m == MATCH_ERROR) |
| return false; |
| |
| generic: |
| if (!intr) |
| for (intr = sym->generic; intr; intr = intr->next) |
| if (gfc_fl_struct (intr->sym->attr.flavor)) |
| break; |
| |
| if (sym->ns->parent == NULL) |
| break; |
| gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); |
| |
| if (sym == NULL) |
| break; |
| if (!generic_sym (sym)) |
| goto generic; |
| } |
| |
| /* Last ditch attempt. See if the reference is to an intrinsic |
| that possesses a matching interface. 14.1.2.4 */ |
| if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where)) |
| { |
| if (gfc_init_expr_flag) |
| gfc_error ("Function %qs in initialization expression at %L " |
| "must be an intrinsic function", |
| expr->symtree->n.sym->name, &expr->where); |
| else |
| gfc_error ("There is no specific function for the generic %qs " |
| "at %L", expr->symtree->n.sym->name, &expr->where); |
| return false; |
| } |
| |
| if (intr) |
| { |
| if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL, |
| NULL, false)) |
| return false; |
| if (!gfc_use_derived (expr->ts.u.derived)) |
| return false; |
| return resolve_structure_cons (expr, 0); |
| } |
| |
| m = gfc_intrinsic_func_interface (expr, 0); |
| if (m == MATCH_YES) |
| return true; |
| |
| if (m == MATCH_NO) |
| gfc_error ("Generic function %qs at %L is not consistent with a " |
| "specific intrinsic interface", expr->symtree->n.sym->name, |
| &expr->where); |
| |
| return false; |
| } |
| |
| |
| /* Resolve a function call known to be specific. */ |
| |
| static match |
| resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr) |
| { |
| match m; |
| |
| if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY) |
| { |
| if (sym->attr.dummy) |
| { |
| sym->attr.proc = PROC_DUMMY; |
| goto found; |
| } |
| |
| sym->attr.proc = PROC_EXTERNAL; |
| goto found; |
| } |
| |
| if (sym->attr.proc == PROC_MODULE |
| || sym->attr.proc == PROC_ST_FUNCTION |
| || sym->attr.proc == PROC_INTERNAL) |
| goto found; |
| |
| if (sym->attr.intrinsic) |
| { |
| m = gfc_intrinsic_func_interface (expr, 1); |
| if (m == MATCH_YES) |
| return MATCH_YES; |
| if (m == MATCH_NO) |
| gfc_error ("Function %qs at %L is INTRINSIC but is not compatible " |
| "with an intrinsic", sym->name, &expr->where); |
| |
| return MATCH_ERROR; |
| } |
| |
| return MATCH_NO; |
| |
| found: |
| gfc_procedure_use (sym, &expr->value.function.actual, &expr->where); |
| |
| if (sym->result) |
| expr->ts = sym->result->ts; |
| else |
| expr->ts = sym->ts; |
| expr->value.function.name = sym->name; |
| expr->value.function.esym = sym; |
| /* Prevent crash when sym->ts.u.derived->components is not set due to previous |
| error(s). */ |
| if (sym->ts.type == BT_CLASS && !CLASS_DATA (sym)) |
| return MATCH_ERROR; |
| if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as) |
| expr->rank = CLASS_DATA (sym)->as->rank; |
| else if (sym->as != NULL) |
| expr->rank = sym->as->rank; |
| |
| return MATCH_YES; |
| } |
| |
| |
| static bool |
| resolve_specific_f (gfc_expr *expr) |
| { |
| gfc_symbol *sym; |
| match m; |
| |
| sym = expr->symtree->n.sym; |
| |
| for (;;) |
| { |
| m = resolve_specific_f0 (sym, expr); |
| if (m == MATCH_YES) |
| return true; |
| if (m == MATCH_ERROR) |
| return false; |
| |
| if (sym->ns->parent == NULL) |
| break; |
| |
| gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); |
| |
| if (sym == NULL) |
| break; |
| } |
| |
| gfc_error ("Unable to resolve the specific function %qs at %L", |
| expr->symtree->n.sym->name, &expr->where); |
| |
| return true; |
| } |
| |
| /* Recursively append candidate SYM to CANDIDATES. Store the number of |
| candidates in CANDIDATES_LEN. */ |
| |
| static void |
| lookup_function_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->attr.external) |
| && sym->n.sym->attr.flavor == FL_PROCEDURE) |
| vec_push (candidates, candidates_len, sym->name); |
| |
| p = sym->left; |
| if (p) |
| lookup_function_fuzzy_find_candidates (p, candidates, candidates_len); |
| |
| p = sym->right; |
| if (p) |
| lookup_function_fuzzy_find_candidates (p, candidates, candidates_len); |
| } |
| |
| |
| /* Lookup function FN fuzzily, taking names in SYMROOT into account. */ |
| |
| const char* |
| gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot) |
| { |
| char **candidates = NULL; |
| size_t candidates_len = 0; |
| lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len); |
| return gfc_closest_fuzzy_match (fn, candidates); |
| } |
| |
| |
| /* Resolve a procedure call not known to be generic nor specific. */ |
| |
| static bool |
| resolve_unknown_f (gfc_expr *expr) |
| { |
| gfc_symbol *sym; |
| gfc_typespec *ts; |
| |
| sym = expr->symtree->n.sym; |
| |
| if (sym->attr.dummy) |
| { |
| sym->attr.proc = PROC_DUMMY; |
| expr->value.function.name = sym->name; |
| goto set_type; |
| } |
| |
| /* See if we have an intrinsic function reference. */ |
| |
| if (gfc_is_intrinsic (sym, 0, expr->where)) |
| { |
| if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES) |
| return true; |
| return false; |
| } |
| |
| /* The reference is to an external name. */ |
| |
| sym->attr.proc = PROC_EXTERNAL; |
| expr->value.function.name = sym->name; |
| expr->value.function.esym = expr->symtree->n.sym; |
| |
| if (sym->as != NULL) |
| expr->rank = sym->as->rank; |
| |
| /* Type of the expression is either the type of the symbol or the |
| default type of the symbol. */ |
| |
| set_type: |
| gfc_procedure_use (sym, &expr->value.function.actual, &expr->where); |
| |
| if (sym->ts.type != BT_UNKNOWN) |
| expr->ts = sym->ts; |
| else |
| { |
| ts = gfc_get_default_type (sym->name, sym->ns); |
| |
| if (ts->type == BT_UNKNOWN) |
| { |
| const char *guessed |
| = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root); |
| if (guessed) |
| gfc_error ("Function %qs at %L has no IMPLICIT type" |
| "; did you mean %qs?", |
| sym->name, &expr->where, guessed); |
| else |
| gfc_error ("Function %qs at %L has no IMPLICIT type", |
| sym->name, &expr->where); |
| return false; |
| } |
| else |
| expr->ts = *ts; |
| } |
| |
| return true; |
| } |
| |
| |
| /* Return true, if the symbol is an external procedure. */ |
| static bool |
| is_external_proc (gfc_symbol *sym) |
| { |
| if (!sym->attr.dummy && !sym->attr.contained |
| && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at) |
| && sym->attr.proc != PROC_ST_FUNCTION |
| && !sym->attr.proc_pointer |
| && !sym->attr.use_assoc |
| && sym->name) |
| return true; |
| |
| return false; |
| } |
| |
| |
| /* Figure out if a function reference is pure or not. Also set the name |
| of the function for a potential error message. Return nonzero if the |
| function is PURE, zero if not. */ |
| static int |
| pure_stmt_function (gfc_expr *, gfc_symbol *); |
| |
| static int |
| pure_function (gfc_expr *e, const char **name) |
| { |
| int pure; |
| gfc_component *comp; |
| |
| *name = NULL; |
| |
| if (e->symtree != NULL |
| && e->symtree->n.sym != NULL |
| && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION) |
| return pure_stmt_function (e, e->symtree->n.sym); |
| |
| comp = gfc_get_proc_ptr_comp (e); |
| if (comp) |
| { |
| pure = gfc_pure (comp->ts.interface); |
| *name = comp->name; |
| } |
| else if (e->value.function.esym) |
| { |
| pure = gfc_pure (e->value.function.esym); |
| *name = e->value.function.esym->name; |
| } |
| else if (e->value.function.isym) |
| { |
| pure = e->value.function.isym->pure |
| |