1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 #include "target-memory.h" /* for gfc_simplify_transfer */
32 #include "constructor.h"
34 /* Types used in equivalence statements. */
38 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
42 /* Stack to keep track of the nesting of blocks as we move through the
43 code. See resolve_branch() and resolve_code(). */
45 typedef struct code_stack
47 struct gfc_code *head, *current;
48 struct code_stack *prev;
50 /* This bitmap keeps track of the targets valid for a branch from
51 inside this block except for END {IF|SELECT}s of enclosing
53 bitmap reachable_labels;
57 static code_stack *cs_base = NULL;
60 /* Nonzero if we're inside a FORALL block. */
62 static int forall_flag;
64 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
66 static int omp_workshare_flag;
68 /* Nonzero if we are processing a formal arglist. The corresponding function
69 resets the flag each time that it is read. */
70 static int formal_arg_flag = 0;
72 /* True if we are resolving a specification expression. */
73 static int specification_expr = 0;
75 /* The id of the last entry seen. */
76 static int current_entry_id;
78 /* We use bitmaps to determine if a branch target is valid. */
79 static bitmap_obstack labels_obstack;
81 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
82 static bool inquiry_argument = false;
85 gfc_is_formal_arg (void)
87 return formal_arg_flag;
90 /* Is the symbol host associated? */
92 is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
94 for (ns = ns->parent; ns; ns = ns->parent)
103 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
104 an ABSTRACT derived-type. If where is not NULL, an error message with that
105 locus is printed, optionally using name. */
108 resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
110 if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
115 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
116 name, where, ts->u.derived->name);
118 gfc_error ("ABSTRACT type '%s' used at %L",
119 ts->u.derived->name, where);
129 static void resolve_symbol (gfc_symbol *sym);
130 static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc);
133 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
136 resolve_procedure_interface (gfc_symbol *sym)
138 if (sym->ts.interface == sym)
140 gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
141 sym->name, &sym->declared_at);
144 if (sym->ts.interface->attr.procedure)
146 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
147 "in a later PROCEDURE statement", sym->ts.interface->name,
148 sym->name, &sym->declared_at);
152 /* Get the attributes from the interface (now resolved). */
153 if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
155 gfc_symbol *ifc = sym->ts.interface;
156 resolve_symbol (ifc);
158 if (ifc->attr.intrinsic)
159 resolve_intrinsic (ifc, &ifc->declared_at);
162 sym->ts = ifc->result->ts;
165 sym->ts.interface = ifc;
166 sym->attr.function = ifc->attr.function;
167 sym->attr.subroutine = ifc->attr.subroutine;
168 gfc_copy_formal_args (sym, ifc);
170 sym->attr.allocatable = ifc->attr.allocatable;
171 sym->attr.pointer = ifc->attr.pointer;
172 sym->attr.pure = ifc->attr.pure;
173 sym->attr.elemental = ifc->attr.elemental;
174 sym->attr.dimension = ifc->attr.dimension;
175 sym->attr.contiguous = ifc->attr.contiguous;
176 sym->attr.recursive = ifc->attr.recursive;
177 sym->attr.always_explicit = ifc->attr.always_explicit;
178 sym->attr.ext_attr |= ifc->attr.ext_attr;
179 /* Copy array spec. */
180 sym->as = gfc_copy_array_spec (ifc->as);
184 for (i = 0; i < sym->as->rank; i++)
186 gfc_expr_replace_symbols (sym->as->lower[i], sym);
187 gfc_expr_replace_symbols (sym->as->upper[i], sym);
190 /* Copy char length. */
191 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
193 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
194 gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
195 if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
196 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
200 else if (sym->ts.interface->name[0] != '\0')
202 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
203 sym->ts.interface->name, sym->name, &sym->declared_at);
211 /* Resolve types of formal argument lists. These have to be done early so that
212 the formal argument lists of module procedures can be copied to the
213 containing module before the individual procedures are resolved
214 individually. We also resolve argument lists of procedures in interface
215 blocks because they are self-contained scoping units.
217 Since a dummy argument cannot be a non-dummy procedure, the only
218 resort left for untyped names are the IMPLICIT types. */
221 resolve_formal_arglist (gfc_symbol *proc)
223 gfc_formal_arglist *f;
227 if (proc->result != NULL)
232 if (gfc_elemental (proc)
233 || sym->attr.pointer || sym->attr.allocatable
234 || (sym->as && sym->as->rank > 0))
236 proc->attr.always_explicit = 1;
237 sym->attr.always_explicit = 1;
242 for (f = proc->formal; f; f = f->next)
248 /* Alternate return placeholder. */
249 if (gfc_elemental (proc))
250 gfc_error ("Alternate return specifier in elemental subroutine "
251 "'%s' at %L is not allowed", proc->name,
253 if (proc->attr.function)
254 gfc_error ("Alternate return specifier in function "
255 "'%s' at %L is not allowed", proc->name,
259 else if (sym->attr.procedure && sym->ts.interface
260 && sym->attr.if_source != IFSRC_DECL)
261 resolve_procedure_interface (sym);
263 if (sym->attr.if_source != IFSRC_UNKNOWN)
264 resolve_formal_arglist (sym);
266 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
268 if (gfc_pure (proc) && !gfc_pure (sym))
270 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
271 "also be PURE", sym->name, &sym->declared_at);
275 if (gfc_elemental (proc))
277 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
278 "procedure", &sym->declared_at);
282 if (sym->attr.function
283 && sym->ts.type == BT_UNKNOWN
284 && sym->attr.intrinsic)
286 gfc_intrinsic_sym *isym;
287 isym = gfc_find_function (sym->name);
288 if (isym == NULL || !isym->specific)
290 gfc_error ("Unable to find a specific INTRINSIC procedure "
291 "for the reference '%s' at %L", sym->name,
300 if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
301 && (!sym->attr.function || sym->result == sym))
302 gfc_set_default_type (sym, 1, sym->ns);
304 gfc_resolve_array_spec (sym->as, 0);
306 /* We can't tell if an array with dimension (:) is assumed or deferred
307 shape until we know if it has the pointer or allocatable attributes.
309 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
310 && !(sym->attr.pointer || sym->attr.allocatable))
312 sym->as->type = AS_ASSUMED_SHAPE;
313 for (i = 0; i < sym->as->rank; i++)
314 sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
318 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
319 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
320 || sym->attr.optional)
322 proc->attr.always_explicit = 1;
324 proc->result->attr.always_explicit = 1;
327 /* If the flavor is unknown at this point, it has to be a variable.
328 A procedure specification would have already set the type. */
330 if (sym->attr.flavor == FL_UNKNOWN)
331 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
333 if (gfc_pure (proc) && !sym->attr.pointer
334 && sym->attr.flavor != FL_PROCEDURE)
336 if (proc->attr.function && sym->attr.intent != INTENT_IN)
337 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
338 "INTENT(IN)", sym->name, proc->name,
341 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
342 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
343 "have its INTENT specified", sym->name, proc->name,
347 if (gfc_elemental (proc))
350 if (sym->attr.codimension)
352 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
353 "procedure", sym->name, &sym->declared_at);
359 gfc_error ("Argument '%s' of elemental procedure at %L must "
360 "be scalar", sym->name, &sym->declared_at);
364 if (sym->attr.allocatable)
366 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
367 "have the ALLOCATABLE attribute", sym->name,
372 if (sym->attr.pointer)
374 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
375 "have the POINTER attribute", sym->name,
380 if (sym->attr.flavor == FL_PROCEDURE)
382 gfc_error ("Dummy procedure '%s' not allowed in elemental "
383 "procedure '%s' at %L", sym->name, proc->name,
388 if (sym->attr.intent == INTENT_UNKNOWN)
390 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
391 "have its INTENT specified", sym->name, proc->name,
397 /* Each dummy shall be specified to be scalar. */
398 if (proc->attr.proc == PROC_ST_FUNCTION)
402 gfc_error ("Argument '%s' of statement function at %L must "
403 "be scalar", sym->name, &sym->declared_at);
407 if (sym->ts.type == BT_CHARACTER)
409 gfc_charlen *cl = sym->ts.u.cl;
410 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
412 gfc_error ("Character-valued argument '%s' of statement "
413 "function at %L must have constant length",
414 sym->name, &sym->declared_at);
424 /* Work function called when searching for symbols that have argument lists
425 associated with them. */
428 find_arglists (gfc_symbol *sym)
430 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
433 resolve_formal_arglist (sym);
437 /* Given a namespace, resolve all formal argument lists within the namespace.
441 resolve_formal_arglists (gfc_namespace *ns)
446 gfc_traverse_ns (ns, find_arglists);
451 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
455 /* If this namespace is not a function or an entry master function,
457 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
458 || sym->attr.entry_master)
461 /* Try to find out of what the return type is. */
462 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
464 t = gfc_set_default_type (sym->result, 0, ns);
466 if (t == FAILURE && !sym->result->attr.untyped)
468 if (sym->result == sym)
469 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
470 sym->name, &sym->declared_at);
471 else if (!sym->result->attr.proc_pointer)
472 gfc_error ("Result '%s' of contained function '%s' at %L has "
473 "no IMPLICIT type", sym->result->name, sym->name,
474 &sym->result->declared_at);
475 sym->result->attr.untyped = 1;
479 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
480 type, lists the only ways a character length value of * can be used:
481 dummy arguments of procedures, named constants, and function results
482 in external functions. Internal function results and results of module
483 procedures are not on this list, ergo, not permitted. */
485 if (sym->result->ts.type == BT_CHARACTER)
487 gfc_charlen *cl = sym->result->ts.u.cl;
488 if (!cl || !cl->length)
490 /* See if this is a module-procedure and adapt error message
493 gcc_assert (ns->parent && ns->parent->proc_name);
494 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
496 gfc_error ("Character-valued %s '%s' at %L must not be"
498 module_proc ? _("module procedure")
499 : _("internal function"),
500 sym->name, &sym->declared_at);
506 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
507 introduce duplicates. */
510 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
512 gfc_formal_arglist *f, *new_arglist;
515 for (; new_args != NULL; new_args = new_args->next)
517 new_sym = new_args->sym;
518 /* See if this arg is already in the formal argument list. */
519 for (f = proc->formal; f; f = f->next)
521 if (new_sym == f->sym)
528 /* Add a new argument. Argument order is not important. */
529 new_arglist = gfc_get_formal_arglist ();
530 new_arglist->sym = new_sym;
531 new_arglist->next = proc->formal;
532 proc->formal = new_arglist;
537 /* Flag the arguments that are not present in all entries. */
540 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
542 gfc_formal_arglist *f, *head;
545 for (f = proc->formal; f; f = f->next)
550 for (new_args = head; new_args; new_args = new_args->next)
552 if (new_args->sym == f->sym)
559 f->sym->attr.not_always_present = 1;
564 /* Resolve alternate entry points. If a symbol has multiple entry points we
565 create a new master symbol for the main routine, and turn the existing
566 symbol into an entry point. */
569 resolve_entries (gfc_namespace *ns)
571 gfc_namespace *old_ns;
575 char name[GFC_MAX_SYMBOL_LEN + 1];
576 static int master_count = 0;
578 if (ns->proc_name == NULL)
581 /* No need to do anything if this procedure doesn't have alternate entry
586 /* We may already have resolved alternate entry points. */
587 if (ns->proc_name->attr.entry_master)
590 /* If this isn't a procedure something has gone horribly wrong. */
591 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
593 /* Remember the current namespace. */
594 old_ns = gfc_current_ns;
598 /* Add the main entry point to the list of entry points. */
599 el = gfc_get_entry_list ();
600 el->sym = ns->proc_name;
602 el->next = ns->entries;
604 ns->proc_name->attr.entry = 1;
606 /* If it is a module function, it needs to be in the right namespace
607 so that gfc_get_fake_result_decl can gather up the results. The
608 need for this arose in get_proc_name, where these beasts were
609 left in their own namespace, to keep prior references linked to
610 the entry declaration.*/
611 if (ns->proc_name->attr.function
612 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
615 /* Do the same for entries where the master is not a module
616 procedure. These are retained in the module namespace because
617 of the module procedure declaration. */
618 for (el = el->next; el; el = el->next)
619 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
620 && el->sym->attr.mod_proc)
624 /* Add an entry statement for it. */
631 /* Create a new symbol for the master function. */
632 /* Give the internal function a unique name (within this file).
633 Also include the function name so the user has some hope of figuring
634 out what is going on. */
635 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
636 master_count++, ns->proc_name->name);
637 gfc_get_ha_symbol (name, &proc);
638 gcc_assert (proc != NULL);
640 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
641 if (ns->proc_name->attr.subroutine)
642 gfc_add_subroutine (&proc->attr, proc->name, NULL);
646 gfc_typespec *ts, *fts;
647 gfc_array_spec *as, *fas;
648 gfc_add_function (&proc->attr, proc->name, NULL);
650 fas = ns->entries->sym->as;
651 fas = fas ? fas : ns->entries->sym->result->as;
652 fts = &ns->entries->sym->result->ts;
653 if (fts->type == BT_UNKNOWN)
654 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
655 for (el = ns->entries->next; el; el = el->next)
657 ts = &el->sym->result->ts;
659 as = as ? as : el->sym->result->as;
660 if (ts->type == BT_UNKNOWN)
661 ts = gfc_get_default_type (el->sym->result->name, NULL);
663 if (! gfc_compare_types (ts, fts)
664 || (el->sym->result->attr.dimension
665 != ns->entries->sym->result->attr.dimension)
666 || (el->sym->result->attr.pointer
667 != ns->entries->sym->result->attr.pointer))
669 else if (as && fas && ns->entries->sym->result != el->sym->result
670 && gfc_compare_array_spec (as, fas) == 0)
671 gfc_error ("Function %s at %L has entries with mismatched "
672 "array specifications", ns->entries->sym->name,
673 &ns->entries->sym->declared_at);
674 /* The characteristics need to match and thus both need to have
675 the same string length, i.e. both len=*, or both len=4.
676 Having both len=<variable> is also possible, but difficult to
677 check at compile time. */
678 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
679 && (((ts->u.cl->length && !fts->u.cl->length)
680 ||(!ts->u.cl->length && fts->u.cl->length))
682 && ts->u.cl->length->expr_type
683 != fts->u.cl->length->expr_type)
685 && ts->u.cl->length->expr_type == EXPR_CONSTANT
686 && mpz_cmp (ts->u.cl->length->value.integer,
687 fts->u.cl->length->value.integer) != 0)))
688 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
689 "entries returning variables of different "
690 "string lengths", ns->entries->sym->name,
691 &ns->entries->sym->declared_at);
696 sym = ns->entries->sym->result;
697 /* All result types the same. */
699 if (sym->attr.dimension)
700 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
701 if (sym->attr.pointer)
702 gfc_add_pointer (&proc->attr, NULL);
706 /* Otherwise the result will be passed through a union by
708 proc->attr.mixed_entry_master = 1;
709 for (el = ns->entries; el; el = el->next)
711 sym = el->sym->result;
712 if (sym->attr.dimension)
714 if (el == ns->entries)
715 gfc_error ("FUNCTION result %s can't be an array in "
716 "FUNCTION %s at %L", sym->name,
717 ns->entries->sym->name, &sym->declared_at);
719 gfc_error ("ENTRY result %s can't be an array in "
720 "FUNCTION %s at %L", sym->name,
721 ns->entries->sym->name, &sym->declared_at);
723 else if (sym->attr.pointer)
725 if (el == ns->entries)
726 gfc_error ("FUNCTION result %s can't be a POINTER in "
727 "FUNCTION %s at %L", sym->name,
728 ns->entries->sym->name, &sym->declared_at);
730 gfc_error ("ENTRY result %s can't be a POINTER in "
731 "FUNCTION %s at %L", sym->name,
732 ns->entries->sym->name, &sym->declared_at);
737 if (ts->type == BT_UNKNOWN)
738 ts = gfc_get_default_type (sym->name, NULL);
742 if (ts->kind == gfc_default_integer_kind)
746 if (ts->kind == gfc_default_real_kind
747 || ts->kind == gfc_default_double_kind)
751 if (ts->kind == gfc_default_complex_kind)
755 if (ts->kind == gfc_default_logical_kind)
759 /* We will issue error elsewhere. */
767 if (el == ns->entries)
768 gfc_error ("FUNCTION result %s can't be of type %s "
769 "in FUNCTION %s at %L", sym->name,
770 gfc_typename (ts), ns->entries->sym->name,
773 gfc_error ("ENTRY result %s can't be of type %s "
774 "in FUNCTION %s at %L", sym->name,
775 gfc_typename (ts), ns->entries->sym->name,
782 proc->attr.access = ACCESS_PRIVATE;
783 proc->attr.entry_master = 1;
785 /* Merge all the entry point arguments. */
786 for (el = ns->entries; el; el = el->next)
787 merge_argument_lists (proc, el->sym->formal);
789 /* Check the master formal arguments for any that are not
790 present in all entry points. */
791 for (el = ns->entries; el; el = el->next)
792 check_argument_lists (proc, el->sym->formal);
794 /* Use the master function for the function body. */
795 ns->proc_name = proc;
797 /* Finalize the new symbols. */
798 gfc_commit_symbols ();
800 /* Restore the original namespace. */
801 gfc_current_ns = old_ns;
805 /* Resolve common variables. */
807 resolve_common_vars (gfc_symbol *sym, bool named_common)
809 gfc_symbol *csym = sym;
811 for (; csym; csym = csym->common_next)
813 if (csym->value || csym->attr.data)
815 if (!csym->ns->is_block_data)
816 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
817 "but only in BLOCK DATA initialization is "
818 "allowed", csym->name, &csym->declared_at);
819 else if (!named_common)
820 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
821 "in a blank COMMON but initialization is only "
822 "allowed in named common blocks", csym->name,
826 if (csym->ts.type != BT_DERIVED)
829 if (!(csym->ts.u.derived->attr.sequence
830 || csym->ts.u.derived->attr.is_bind_c))
831 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
832 "has neither the SEQUENCE nor the BIND(C) "
833 "attribute", csym->name, &csym->declared_at);
834 if (csym->ts.u.derived->attr.alloc_comp)
835 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
836 "has an ultimate component that is "
837 "allocatable", csym->name, &csym->declared_at);
838 if (gfc_has_default_initializer (csym->ts.u.derived))
839 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
840 "may not have default initializer", csym->name,
843 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
844 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
848 /* Resolve common blocks. */
850 resolve_common_blocks (gfc_symtree *common_root)
854 if (common_root == NULL)
857 if (common_root->left)
858 resolve_common_blocks (common_root->left);
859 if (common_root->right)
860 resolve_common_blocks (common_root->right);
862 resolve_common_vars (common_root->n.common->head, true);
864 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
868 if (sym->attr.flavor == FL_PARAMETER)
869 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
870 sym->name, &common_root->n.common->where, &sym->declared_at);
872 if (sym->attr.intrinsic)
873 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
874 sym->name, &common_root->n.common->where);
875 else if (sym->attr.result
876 || gfc_is_function_return_value (sym, gfc_current_ns))
877 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
878 "that is also a function result", sym->name,
879 &common_root->n.common->where);
880 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
881 && sym->attr.proc != PROC_ST_FUNCTION)
882 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
883 "that is also a global procedure", sym->name,
884 &common_root->n.common->where);
888 /* Resolve contained function types. Because contained functions can call one
889 another, they have to be worked out before any of the contained procedures
892 The good news is that if a function doesn't already have a type, the only
893 way it can get one is through an IMPLICIT type or a RESULT variable, because
894 by definition contained functions are contained namespace they're contained
895 in, not in a sibling or parent namespace. */
898 resolve_contained_functions (gfc_namespace *ns)
900 gfc_namespace *child;
903 resolve_formal_arglists (ns);
905 for (child = ns->contained; child; child = child->sibling)
907 /* Resolve alternate entry points first. */
908 resolve_entries (child);
910 /* Then check function return types. */
911 resolve_contained_fntype (child->proc_name, child);
912 for (el = child->entries; el; el = el->next)
913 resolve_contained_fntype (el->sym, child);
918 /* Resolve all of the elements of a structure constructor and make sure that
919 the types are correct. The 'init' flag indicates that the given
920 constructor is an initializer. */
923 resolve_structure_cons (gfc_expr *expr, int init)
925 gfc_constructor *cons;
932 if (expr->ts.type == BT_DERIVED)
933 resolve_symbol (expr->ts.u.derived);
935 cons = gfc_constructor_first (expr->value.constructor);
936 /* A constructor may have references if it is the result of substituting a
937 parameter variable. In this case we just pull out the component we
940 comp = expr->ref->u.c.sym->components;
942 comp = expr->ts.u.derived->components;
944 /* See if the user is trying to invoke a structure constructor for one of
945 the iso_c_binding derived types. */
946 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
947 && expr->ts.u.derived->ts.is_iso_c && cons
948 && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
950 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
951 expr->ts.u.derived->name, &(expr->where));
955 /* Return if structure constructor is c_null_(fun)prt. */
956 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
957 && expr->ts.u.derived->ts.is_iso_c && cons
958 && cons->expr && cons->expr->expr_type == EXPR_NULL)
961 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
968 if (gfc_resolve_expr (cons->expr) == FAILURE)
974 rank = comp->as ? comp->as->rank : 0;
975 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
976 && (comp->attr.allocatable || cons->expr->rank))
978 gfc_error ("The rank of the element in the derived type "
979 "constructor at %L does not match that of the "
980 "component (%d/%d)", &cons->expr->where,
981 cons->expr->rank, rank);
985 /* If we don't have the right type, try to convert it. */
987 if (!comp->attr.proc_pointer &&
988 !gfc_compare_types (&cons->expr->ts, &comp->ts))
991 if (strcmp (comp->name, "$extends") == 0)
993 /* Can afford to be brutal with the $extends initializer.
994 The derived type can get lost because it is PRIVATE
995 but it is not usage constrained by the standard. */
996 cons->expr->ts = comp->ts;
999 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1000 gfc_error ("The element in the derived type constructor at %L, "
1001 "for pointer component '%s', is %s but should be %s",
1002 &cons->expr->where, comp->name,
1003 gfc_basic_typename (cons->expr->ts.type),
1004 gfc_basic_typename (comp->ts.type));
1006 t = gfc_convert_type (cons->expr, &comp->ts, 1);
1009 /* For strings, the length of the constructor should be the same as
1010 the one of the structure, ensure this if the lengths are known at
1011 compile time and when we are dealing with PARAMETER or structure
1013 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1014 && comp->ts.u.cl->length
1015 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1016 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1017 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1018 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1019 comp->ts.u.cl->length->value.integer) != 0)
1021 if (cons->expr->expr_type == EXPR_VARIABLE
1022 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1024 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1025 to make use of the gfc_resolve_character_array_constructor
1026 machinery. The expression is later simplified away to
1027 an array of string literals. */
1028 gfc_expr *para = cons->expr;
1029 cons->expr = gfc_get_expr ();
1030 cons->expr->ts = para->ts;
1031 cons->expr->where = para->where;
1032 cons->expr->expr_type = EXPR_ARRAY;
1033 cons->expr->rank = para->rank;
1034 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1035 gfc_constructor_append_expr (&cons->expr->value.constructor,
1036 para, &cons->expr->where);
1038 if (cons->expr->expr_type == EXPR_ARRAY)
1041 p = gfc_constructor_first (cons->expr->value.constructor);
1042 if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
1044 gfc_charlen *cl, *cl2;
1047 for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
1049 if (cl == cons->expr->ts.u.cl)
1057 cl2->next = cl->next;
1059 gfc_free_expr (cl->length);
1063 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1064 cons->expr->ts.u.cl->length_from_typespec = true;
1065 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1066 gfc_resolve_character_array_constructor (cons->expr);
1070 if (cons->expr->expr_type == EXPR_NULL
1071 && !(comp->attr.pointer || comp->attr.allocatable
1072 || comp->attr.proc_pointer
1073 || (comp->ts.type == BT_CLASS
1074 && (CLASS_DATA (comp)->attr.class_pointer
1075 || CLASS_DATA (comp)->attr.allocatable))))
1078 gfc_error ("The NULL in the derived type constructor at %L is "
1079 "being applied to component '%s', which is neither "
1080 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1084 if (!comp->attr.pointer || comp->attr.proc_pointer
1085 || cons->expr->expr_type == EXPR_NULL)
1088 a = gfc_expr_attr (cons->expr);
1090 if (!a.pointer && !a.target)
1093 gfc_error ("The element in the derived type constructor at %L, "
1094 "for pointer component '%s' should be a POINTER or "
1095 "a TARGET", &cons->expr->where, comp->name);
1100 /* F08:C461. Additional checks for pointer initialization. */
1104 gfc_error ("Pointer initialization target at %L "
1105 "must not be ALLOCATABLE ", &cons->expr->where);
1110 gfc_error ("Pointer initialization target at %L "
1111 "must have the SAVE attribute", &cons->expr->where);
1115 /* F2003, C1272 (3). */
1116 if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
1117 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1118 || gfc_is_coindexed (cons->expr)))
1121 gfc_error ("Invalid expression in the derived type constructor for "
1122 "pointer component '%s' at %L in PURE procedure",
1123 comp->name, &cons->expr->where);
1132 /****************** Expression name resolution ******************/
1134 /* Returns 0 if a symbol was not declared with a type or
1135 attribute declaration statement, nonzero otherwise. */
1138 was_declared (gfc_symbol *sym)
1144 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1147 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1148 || a.optional || a.pointer || a.save || a.target || a.volatile_
1149 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1150 || a.asynchronous || a.codimension)
1157 /* Determine if a symbol is generic or not. */
1160 generic_sym (gfc_symbol *sym)
1164 if (sym->attr.generic ||
1165 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1168 if (was_declared (sym) || sym->ns->parent == NULL)
1171 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1178 return generic_sym (s);
1185 /* Determine if a symbol is specific or not. */
1188 specific_sym (gfc_symbol *sym)
1192 if (sym->attr.if_source == IFSRC_IFBODY
1193 || sym->attr.proc == PROC_MODULE
1194 || sym->attr.proc == PROC_INTERNAL
1195 || sym->attr.proc == PROC_ST_FUNCTION
1196 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1197 || sym->attr.external)
1200 if (was_declared (sym) || sym->ns->parent == NULL)
1203 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1205 return (s == NULL) ? 0 : specific_sym (s);
1209 /* Figure out if the procedure is specific, generic or unknown. */
1212 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1216 procedure_kind (gfc_symbol *sym)
1218 if (generic_sym (sym))
1219 return PTYPE_GENERIC;
1221 if (specific_sym (sym))
1222 return PTYPE_SPECIFIC;
1224 return PTYPE_UNKNOWN;
1227 /* Check references to assumed size arrays. The flag need_full_assumed_size
1228 is nonzero when matching actual arguments. */
1230 static int need_full_assumed_size = 0;
1233 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1235 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1238 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1239 What should it be? */
1240 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1241 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1242 && (e->ref->u.ar.type == AR_FULL))
1244 gfc_error ("The upper bound in the last dimension must "
1245 "appear in the reference to the assumed size "
1246 "array '%s' at %L", sym->name, &e->where);
1253 /* Look for bad assumed size array references in argument expressions
1254 of elemental and array valued intrinsic procedures. Since this is
1255 called from procedure resolution functions, it only recurses at
1259 resolve_assumed_size_actual (gfc_expr *e)
1264 switch (e->expr_type)
1267 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1272 if (resolve_assumed_size_actual (e->value.op.op1)
1273 || resolve_assumed_size_actual (e->value.op.op2))
1284 /* Check a generic procedure, passed as an actual argument, to see if
1285 there is a matching specific name. If none, it is an error, and if
1286 more than one, the reference is ambiguous. */
1288 count_specific_procs (gfc_expr *e)
1295 sym = e->symtree->n.sym;
1297 for (p = sym->generic; p; p = p->next)
1298 if (strcmp (sym->name, p->sym->name) == 0)
1300 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1306 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1310 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1311 "argument at %L", sym->name, &e->where);
1317 /* See if a call to sym could possibly be a not allowed RECURSION because of
1318 a missing RECURIVE declaration. This means that either sym is the current
1319 context itself, or sym is the parent of a contained procedure calling its
1320 non-RECURSIVE containing procedure.
1321 This also works if sym is an ENTRY. */
1324 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1326 gfc_symbol* proc_sym;
1327 gfc_symbol* context_proc;
1328 gfc_namespace* real_context;
1330 if (sym->attr.flavor == FL_PROGRAM)
1333 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1335 /* If we've got an ENTRY, find real procedure. */
1336 if (sym->attr.entry && sym->ns->entries)
1337 proc_sym = sym->ns->entries->sym;
1341 /* If sym is RECURSIVE, all is well of course. */
1342 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1345 /* Find the context procedure's "real" symbol if it has entries.
1346 We look for a procedure symbol, so recurse on the parents if we don't
1347 find one (like in case of a BLOCK construct). */
1348 for (real_context = context; ; real_context = real_context->parent)
1350 /* We should find something, eventually! */
1351 gcc_assert (real_context);
1353 context_proc = (real_context->entries ? real_context->entries->sym
1354 : real_context->proc_name);
1356 /* In some special cases, there may not be a proc_name, like for this
1358 real(bad_kind()) function foo () ...
1359 when checking the call to bad_kind ().
1360 In these cases, we simply return here and assume that the
1365 if (context_proc->attr.flavor != FL_LABEL)
1369 /* A call from sym's body to itself is recursion, of course. */
1370 if (context_proc == proc_sym)
1373 /* The same is true if context is a contained procedure and sym the
1375 if (context_proc->attr.contained)
1377 gfc_symbol* parent_proc;
1379 gcc_assert (context->parent);
1380 parent_proc = (context->parent->entries ? context->parent->entries->sym
1381 : context->parent->proc_name);
1383 if (parent_proc == proc_sym)
1391 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1392 its typespec and formal argument list. */
1395 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1397 gfc_intrinsic_sym* isym = NULL;
1403 /* We already know this one is an intrinsic, so we don't call
1404 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1405 gfc_find_subroutine directly to check whether it is a function or
1408 if (sym->intmod_sym_id)
1409 isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
1411 isym = gfc_find_function (sym->name);
1415 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1416 && !sym->attr.implicit_type)
1417 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1418 " ignored", sym->name, &sym->declared_at);
1420 if (!sym->attr.function &&
1421 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1426 else if ((isym = gfc_find_subroutine (sym->name)))
1428 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1430 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1431 " specifier", sym->name, &sym->declared_at);
1435 if (!sym->attr.subroutine &&
1436 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1441 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1446 gfc_copy_formal_args_intr (sym, isym);
1448 /* Check it is actually available in the standard settings. */
1449 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1452 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1453 " available in the current standard settings but %s. Use"
1454 " an appropriate -std=* option or enable -fall-intrinsics"
1455 " in order to use it.",
1456 sym->name, &sym->declared_at, symstd);
1464 /* Resolve a procedure expression, like passing it to a called procedure or as
1465 RHS for a procedure pointer assignment. */
1468 resolve_procedure_expression (gfc_expr* expr)
1472 if (expr->expr_type != EXPR_VARIABLE)
1474 gcc_assert (expr->symtree);
1476 sym = expr->symtree->n.sym;
1478 if (sym->attr.intrinsic)
1479 resolve_intrinsic (sym, &expr->where);
1481 if (sym->attr.flavor != FL_PROCEDURE
1482 || (sym->attr.function && sym->result == sym))
1485 /* A non-RECURSIVE procedure that is used as procedure expression within its
1486 own body is in danger of being called recursively. */
1487 if (is_illegal_recursion (sym, gfc_current_ns))
1488 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1489 " itself recursively. Declare it RECURSIVE or use"
1490 " -frecursive", sym->name, &expr->where);
1496 /* Resolve an actual argument list. Most of the time, this is just
1497 resolving the expressions in the list.
1498 The exception is that we sometimes have to decide whether arguments
1499 that look like procedure arguments are really simple variable
1503 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1504 bool no_formal_args)
1507 gfc_symtree *parent_st;
1509 int save_need_full_assumed_size;
1510 gfc_component *comp;
1512 for (; arg; arg = arg->next)
1517 /* Check the label is a valid branching target. */
1520 if (arg->label->defined == ST_LABEL_UNKNOWN)
1522 gfc_error ("Label %d referenced at %L is never defined",
1523 arg->label->value, &arg->label->where);
1530 if (gfc_is_proc_ptr_comp (e, &comp))
1533 if (e->expr_type == EXPR_PPC)
1535 if (comp->as != NULL)
1536 e->rank = comp->as->rank;
1537 e->expr_type = EXPR_FUNCTION;
1539 if (gfc_resolve_expr (e) == FAILURE)
1544 if (e->expr_type == EXPR_VARIABLE
1545 && e->symtree->n.sym->attr.generic
1547 && count_specific_procs (e) != 1)
1550 if (e->ts.type != BT_PROCEDURE)
1552 save_need_full_assumed_size = need_full_assumed_size;
1553 if (e->expr_type != EXPR_VARIABLE)
1554 need_full_assumed_size = 0;
1555 if (gfc_resolve_expr (e) != SUCCESS)
1557 need_full_assumed_size = save_need_full_assumed_size;
1561 /* See if the expression node should really be a variable reference. */
1563 sym = e->symtree->n.sym;
1565 if (sym->attr.flavor == FL_PROCEDURE
1566 || sym->attr.intrinsic
1567 || sym->attr.external)
1571 /* If a procedure is not already determined to be something else
1572 check if it is intrinsic. */
1573 if (!sym->attr.intrinsic
1574 && !(sym->attr.external || sym->attr.use_assoc
1575 || sym->attr.if_source == IFSRC_IFBODY)
1576 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1577 sym->attr.intrinsic = 1;
1579 if (sym->attr.proc == PROC_ST_FUNCTION)
1581 gfc_error ("Statement function '%s' at %L is not allowed as an "
1582 "actual argument", sym->name, &e->where);
1585 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1586 sym->attr.subroutine);
1587 if (sym->attr.intrinsic && actual_ok == 0)
1589 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1590 "actual argument", sym->name, &e->where);
1593 if (sym->attr.contained && !sym->attr.use_assoc
1594 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1596 if (gfc_notify_std (GFC_STD_F2008,
1597 "Fortran 2008: Internal procedure '%s' is"
1598 " used as actual argument at %L",
1599 sym->name, &e->where) == FAILURE)
1603 if (sym->attr.elemental && !sym->attr.intrinsic)
1605 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1606 "allowed as an actual argument at %L", sym->name,
1610 /* Check if a generic interface has a specific procedure
1611 with the same name before emitting an error. */
1612 if (sym->attr.generic && count_specific_procs (e) != 1)
1615 /* Just in case a specific was found for the expression. */
1616 sym = e->symtree->n.sym;
1618 /* If the symbol is the function that names the current (or
1619 parent) scope, then we really have a variable reference. */
1621 if (gfc_is_function_return_value (sym, sym->ns))
1624 /* If all else fails, see if we have a specific intrinsic. */
1625 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1627 gfc_intrinsic_sym *isym;
1629 isym = gfc_find_function (sym->name);
1630 if (isym == NULL || !isym->specific)
1632 gfc_error ("Unable to find a specific INTRINSIC procedure "
1633 "for the reference '%s' at %L", sym->name,
1638 sym->attr.intrinsic = 1;
1639 sym->attr.function = 1;
1642 if (gfc_resolve_expr (e) == FAILURE)
1647 /* See if the name is a module procedure in a parent unit. */
1649 if (was_declared (sym) || sym->ns->parent == NULL)
1652 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1654 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1658 if (parent_st == NULL)
1661 sym = parent_st->n.sym;
1662 e->symtree = parent_st; /* Point to the right thing. */
1664 if (sym->attr.flavor == FL_PROCEDURE
1665 || sym->attr.intrinsic
1666 || sym->attr.external)
1668 if (gfc_resolve_expr (e) == FAILURE)
1674 e->expr_type = EXPR_VARIABLE;
1676 if (sym->as != NULL)
1678 e->rank = sym->as->rank;
1679 e->ref = gfc_get_ref ();
1680 e->ref->type = REF_ARRAY;
1681 e->ref->u.ar.type = AR_FULL;
1682 e->ref->u.ar.as = sym->as;
1685 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1686 primary.c (match_actual_arg). If above code determines that it
1687 is a variable instead, it needs to be resolved as it was not
1688 done at the beginning of this function. */
1689 save_need_full_assumed_size = need_full_assumed_size;
1690 if (e->expr_type != EXPR_VARIABLE)
1691 need_full_assumed_size = 0;
1692 if (gfc_resolve_expr (e) != SUCCESS)
1694 need_full_assumed_size = save_need_full_assumed_size;
1697 /* Check argument list functions %VAL, %LOC and %REF. There is
1698 nothing to do for %REF. */
1699 if (arg->name && arg->name[0] == '%')
1701 if (strncmp ("%VAL", arg->name, 4) == 0)
1703 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1705 gfc_error ("By-value argument at %L is not of numeric "
1712 gfc_error ("By-value argument at %L cannot be an array or "
1713 "an array section", &e->where);
1717 /* Intrinsics are still PROC_UNKNOWN here. However,
1718 since same file external procedures are not resolvable
1719 in gfortran, it is a good deal easier to leave them to
1721 if (ptype != PROC_UNKNOWN
1722 && ptype != PROC_DUMMY
1723 && ptype != PROC_EXTERNAL
1724 && ptype != PROC_MODULE)
1726 gfc_error ("By-value argument at %L is not allowed "
1727 "in this context", &e->where);
1732 /* Statement functions have already been excluded above. */
1733 else if (strncmp ("%LOC", arg->name, 4) == 0
1734 && e->ts.type == BT_PROCEDURE)
1736 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1738 gfc_error ("Passing internal procedure at %L by location "
1739 "not allowed", &e->where);
1745 /* Fortran 2008, C1237. */
1746 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1747 && gfc_has_ultimate_pointer (e))
1749 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1750 "component", &e->where);
1759 /* Do the checks of the actual argument list that are specific to elemental
1760 procedures. If called with c == NULL, we have a function, otherwise if
1761 expr == NULL, we have a subroutine. */
1764 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1766 gfc_actual_arglist *arg0;
1767 gfc_actual_arglist *arg;
1768 gfc_symbol *esym = NULL;
1769 gfc_intrinsic_sym *isym = NULL;
1771 gfc_intrinsic_arg *iformal = NULL;
1772 gfc_formal_arglist *eformal = NULL;
1773 bool formal_optional = false;
1774 bool set_by_optional = false;
1778 /* Is this an elemental procedure? */
1779 if (expr && expr->value.function.actual != NULL)
1781 if (expr->value.function.esym != NULL
1782 && expr->value.function.esym->attr.elemental)
1784 arg0 = expr->value.function.actual;
1785 esym = expr->value.function.esym;
1787 else if (expr->value.function.isym != NULL
1788 && expr->value.function.isym->elemental)
1790 arg0 = expr->value.function.actual;
1791 isym = expr->value.function.isym;
1796 else if (c && c->ext.actual != NULL)
1798 arg0 = c->ext.actual;
1800 if (c->resolved_sym)
1801 esym = c->resolved_sym;
1803 esym = c->symtree->n.sym;
1806 if (!esym->attr.elemental)
1812 /* The rank of an elemental is the rank of its array argument(s). */
1813 for (arg = arg0; arg; arg = arg->next)
1815 if (arg->expr != NULL && arg->expr->rank > 0)
1817 rank = arg->expr->rank;
1818 if (arg->expr->expr_type == EXPR_VARIABLE
1819 && arg->expr->symtree->n.sym->attr.optional)
1820 set_by_optional = true;
1822 /* Function specific; set the result rank and shape. */
1826 if (!expr->shape && arg->expr->shape)
1828 expr->shape = gfc_get_shape (rank);
1829 for (i = 0; i < rank; i++)
1830 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1837 /* If it is an array, it shall not be supplied as an actual argument
1838 to an elemental procedure unless an array of the same rank is supplied
1839 as an actual argument corresponding to a nonoptional dummy argument of
1840 that elemental procedure(12.4.1.5). */
1841 formal_optional = false;
1843 iformal = isym->formal;
1845 eformal = esym->formal;
1847 for (arg = arg0; arg; arg = arg->next)
1851 if (eformal->sym && eformal->sym->attr.optional)
1852 formal_optional = true;
1853 eformal = eformal->next;
1855 else if (isym && iformal)
1857 if (iformal->optional)
1858 formal_optional = true;
1859 iformal = iformal->next;
1862 formal_optional = true;
1864 if (pedantic && arg->expr != NULL
1865 && arg->expr->expr_type == EXPR_VARIABLE
1866 && arg->expr->symtree->n.sym->attr.optional
1869 && (set_by_optional || arg->expr->rank != rank)
1870 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1872 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1873 "MISSING, it cannot be the actual argument of an "
1874 "ELEMENTAL procedure unless there is a non-optional "
1875 "argument with the same rank (12.4.1.5)",
1876 arg->expr->symtree->n.sym->name, &arg->expr->where);
1881 for (arg = arg0; arg; arg = arg->next)
1883 if (arg->expr == NULL || arg->expr->rank == 0)
1886 /* Being elemental, the last upper bound of an assumed size array
1887 argument must be present. */
1888 if (resolve_assumed_size_actual (arg->expr))
1891 /* Elemental procedure's array actual arguments must conform. */
1894 if (gfc_check_conformance (arg->expr, e,
1895 "elemental procedure") == FAILURE)
1902 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1903 is an array, the intent inout/out variable needs to be also an array. */
1904 if (rank > 0 && esym && expr == NULL)
1905 for (eformal = esym->formal, arg = arg0; arg && eformal;
1906 arg = arg->next, eformal = eformal->next)
1907 if ((eformal->sym->attr.intent == INTENT_OUT
1908 || eformal->sym->attr.intent == INTENT_INOUT)
1909 && arg->expr && arg->expr->rank == 0)
1911 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1912 "ELEMENTAL subroutine '%s' is a scalar, but another "
1913 "actual argument is an array", &arg->expr->where,
1914 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1915 : "INOUT", eformal->sym->name, esym->name);
1922 /* This function does the checking of references to global procedures
1923 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1924 77 and 95 standards. It checks for a gsymbol for the name, making
1925 one if it does not already exist. If it already exists, then the
1926 reference being resolved must correspond to the type of gsymbol.
1927 Otherwise, the new symbol is equipped with the attributes of the
1928 reference. The corresponding code that is called in creating
1929 global entities is parse.c.
1931 In addition, for all but -std=legacy, the gsymbols are used to
1932 check the interfaces of external procedures from the same file.
1933 The namespace of the gsymbol is resolved and then, once this is
1934 done the interface is checked. */
1938 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
1940 if (!gsym_ns->proc_name->attr.recursive)
1943 if (sym->ns == gsym_ns)
1946 if (sym->ns->parent && sym->ns->parent == gsym_ns)
1953 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
1955 if (gsym_ns->entries)
1957 gfc_entry_list *entry = gsym_ns->entries;
1959 for (; entry; entry = entry->next)
1961 if (strcmp (sym->name, entry->sym->name) == 0)
1963 if (strcmp (gsym_ns->proc_name->name,
1964 sym->ns->proc_name->name) == 0)
1968 && strcmp (gsym_ns->proc_name->name,
1969 sym->ns->parent->proc_name->name) == 0)
1978 resolve_global_procedure (gfc_symbol *sym, locus *where,
1979 gfc_actual_arglist **actual, int sub)
1983 enum gfc_symbol_type type;
1985 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1987 gsym = gfc_get_gsymbol (sym->name);
1989 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1990 gfc_global_used (gsym, where);
1992 if (gfc_option.flag_whole_file
1993 && (sym->attr.if_source == IFSRC_UNKNOWN
1994 || sym->attr.if_source == IFSRC_IFBODY)
1995 && gsym->type != GSYM_UNKNOWN
1997 && gsym->ns->resolved != -1
1998 && gsym->ns->proc_name
1999 && not_in_recursive (sym, gsym->ns)
2000 && not_entry_self_reference (sym, gsym->ns))
2002 gfc_symbol *def_sym;
2004 /* Resolve the gsymbol namespace if needed. */
2005 if (!gsym->ns->resolved)
2007 gfc_dt_list *old_dt_list;
2009 /* Stash away derived types so that the backend_decls do not
2011 old_dt_list = gfc_derived_types;
2012 gfc_derived_types = NULL;
2014 gfc_resolve (gsym->ns);
2016 /* Store the new derived types with the global namespace. */
2017 if (gfc_derived_types)
2018 gsym->ns->derived_types = gfc_derived_types;
2020 /* Restore the derived types of this namespace. */
2021 gfc_derived_types = old_dt_list;
2024 /* Make sure that translation for the gsymbol occurs before
2025 the procedure currently being resolved. */
2026 ns = gfc_global_ns_list;
2027 for (; ns && ns != gsym->ns; ns = ns->sibling)
2029 if (ns->sibling == gsym->ns)
2031 ns->sibling = gsym->ns->sibling;
2032 gsym->ns->sibling = gfc_global_ns_list;
2033 gfc_global_ns_list = gsym->ns;
2038 def_sym = gsym->ns->proc_name;
2039 if (def_sym->attr.entry_master)
2041 gfc_entry_list *entry;
2042 for (entry = gsym->ns->entries; entry; entry = entry->next)
2043 if (strcmp (entry->sym->name, sym->name) == 0)
2045 def_sym = entry->sym;
2050 /* Differences in constant character lengths. */
2051 if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2053 long int l1 = 0, l2 = 0;
2054 gfc_charlen *cl1 = sym->ts.u.cl;
2055 gfc_charlen *cl2 = def_sym->ts.u.cl;
2058 && cl1->length != NULL
2059 && cl1->length->expr_type == EXPR_CONSTANT)
2060 l1 = mpz_get_si (cl1->length->value.integer);
2063 && cl2->length != NULL
2064 && cl2->length->expr_type == EXPR_CONSTANT)
2065 l2 = mpz_get_si (cl2->length->value.integer);
2067 if (l1 && l2 && l1 != l2)
2068 gfc_error ("Character length mismatch in return type of "
2069 "function '%s' at %L (%ld/%ld)", sym->name,
2070 &sym->declared_at, l1, l2);
2073 /* Type mismatch of function return type and expected type. */
2074 if (sym->attr.function
2075 && !gfc_compare_types (&sym->ts, &def_sym->ts))
2076 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2077 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2078 gfc_typename (&def_sym->ts));
2080 if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2082 gfc_formal_arglist *arg = def_sym->formal;
2083 for ( ; arg; arg = arg->next)
2086 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2087 else if (arg->sym->attr.allocatable
2088 || arg->sym->attr.asynchronous
2089 || arg->sym->attr.optional
2090 || arg->sym->attr.pointer
2091 || arg->sym->attr.target
2092 || arg->sym->attr.value
2093 || arg->sym->attr.volatile_)
2095 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2096 "has an attribute that requires an explicit "
2097 "interface for this procedure", arg->sym->name,
2098 sym->name, &sym->declared_at);
2101 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2102 else if (arg->sym && arg->sym->as
2103 && arg->sym->as->type == AS_ASSUMED_SHAPE)
2105 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2106 "argument '%s' must have an explicit interface",
2107 sym->name, &sym->declared_at, arg->sym->name);
2110 /* F2008, 12.4.2.2 (2c) */
2111 else if (arg->sym->attr.codimension)
2113 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2114 "'%s' must have an explicit interface",
2115 sym->name, &sym->declared_at, arg->sym->name);
2118 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2119 else if (false) /* TODO: is a parametrized derived type */
2121 gfc_error ("Procedure '%s' at %L with parametrized derived "
2122 "type argument '%s' must have an explicit "
2123 "interface", sym->name, &sym->declared_at,
2127 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2128 else if (arg->sym->ts.type == BT_CLASS)
2130 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2131 "argument '%s' must have an explicit interface",
2132 sym->name, &sym->declared_at, arg->sym->name);
2137 if (def_sym->attr.function)
2139 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2140 if (def_sym->as && def_sym->as->rank
2141 && (!sym->as || sym->as->rank != def_sym->as->rank))
2142 gfc_error ("The reference to function '%s' at %L either needs an "
2143 "explicit INTERFACE or the rank is incorrect", sym->name,
2146 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2147 if ((def_sym->result->attr.pointer
2148 || def_sym->result->attr.allocatable)
2149 && (sym->attr.if_source != IFSRC_IFBODY
2150 || def_sym->result->attr.pointer
2151 != sym->result->attr.pointer
2152 || def_sym->result->attr.allocatable
2153 != sym->result->attr.allocatable))
2154 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2155 "result must have an explicit interface", sym->name,
2158 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2159 if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2160 && def_sym->ts.u.cl->length != NULL)
2162 gfc_charlen *cl = sym->ts.u.cl;
2164 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2165 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2167 gfc_error ("Nonconstant character-length function '%s' at %L "
2168 "must have an explicit interface", sym->name,
2174 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2175 if (def_sym->attr.elemental && !sym->attr.elemental)
2177 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2178 "interface", sym->name, &sym->declared_at);
2181 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2182 if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2184 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2185 "an explicit interface", sym->name, &sym->declared_at);
2188 if (gfc_option.flag_whole_file == 1
2189 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2190 && !(gfc_option.warn_std & GFC_STD_GNU)))
2191 gfc_errors_to_warnings (1);
2193 if (sym->attr.if_source != IFSRC_IFBODY)
2194 gfc_procedure_use (def_sym, actual, where);
2196 gfc_errors_to_warnings (0);
2199 if (gsym->type == GSYM_UNKNOWN)
2202 gsym->where = *where;
2209 /************* Function resolution *************/
2211 /* Resolve a function call known to be generic.
2212 Section 14.1.2.4.1. */
2215 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2219 if (sym->attr.generic)
2221 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2224 expr->value.function.name = s->name;
2225 expr->value.function.esym = s;
2227 if (s->ts.type != BT_UNKNOWN)
2229 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2230 expr->ts = s->result->ts;
2233 expr->rank = s->as->rank;
2234 else if (s->result != NULL && s->result->as != NULL)
2235 expr->rank = s->result->as->rank;
2237 gfc_set_sym_referenced (expr->value.function.esym);
2242 /* TODO: Need to search for elemental references in generic
2246 if (sym->attr.intrinsic)
2247 return gfc_intrinsic_func_interface (expr, 0);
2254 resolve_generic_f (gfc_expr *expr)
2259 sym = expr->symtree->n.sym;
2263 m = resolve_generic_f0 (expr, sym);
2266 else if (m == MATCH_ERROR)
2270 if (sym->ns->parent == NULL)
2272 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2276 if (!generic_sym (sym))
2280 /* Last ditch attempt. See if the reference is to an intrinsic
2281 that possesses a matching interface. 14.1.2.4 */
2282 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
2284 gfc_error ("There is no specific function for the generic '%s' at %L",
2285 expr->symtree->n.sym->name, &expr->where);
2289 m = gfc_intrinsic_func_interface (expr, 0);
2293 gfc_error ("Generic function '%s' at %L is not consistent with a "
2294 "specific intrinsic interface", expr->symtree->n.sym->name,
2301 /* Resolve a function call known to be specific. */
2304 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2308 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2310 if (sym->attr.dummy)
2312 sym->attr.proc = PROC_DUMMY;
2316 sym->attr.proc = PROC_EXTERNAL;
2320 if (sym->attr.proc == PROC_MODULE
2321 || sym->attr.proc == PROC_ST_FUNCTION
2322 || sym->attr.proc == PROC_INTERNAL)
2325 if (sym->attr.intrinsic)
2327 m = gfc_intrinsic_func_interface (expr, 1);
2331 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2332 "with an intrinsic", sym->name, &expr->where);
2340 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2343 expr->ts = sym->result->ts;
2346 expr->value.function.name = sym->name;
2347 expr->value.function.esym = sym;
2348 if (sym->as != NULL)
2349 expr->rank = sym->as->rank;
2356 resolve_specific_f (gfc_expr *expr)
2361 sym = expr->symtree->n.sym;
2365 m = resolve_specific_f0 (sym, expr);
2368 if (m == MATCH_ERROR)
2371 if (sym->ns->parent == NULL)
2374 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2380 gfc_error ("Unable to resolve the specific function '%s' at %L",
2381 expr->symtree->n.sym->name, &expr->where);
2387 /* Resolve a procedure call not known to be generic nor specific. */
2390 resolve_unknown_f (gfc_expr *expr)
2395 sym = expr->symtree->n.sym;
2397 if (sym->attr.dummy)
2399 sym->attr.proc = PROC_DUMMY;
2400 expr->value.function.name = sym->name;
2404 /* See if we have an intrinsic function reference. */
2406 if (gfc_is_intrinsic (sym, 0, expr->where))
2408 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2413 /* The reference is to an external name. */
2415 sym->attr.proc = PROC_EXTERNAL;
2416 expr->value.function.name = sym->name;
2417 expr->value.function.esym = expr->symtree->n.sym;
2419 if (sym->as != NULL)
2420 expr->rank = sym->as->rank;
2422 /* Type of the expression is either the type of the symbol or the
2423 default type of the symbol. */
2426 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2428 if (sym->ts.type != BT_UNKNOWN)
2432 ts = gfc_get_default_type (sym->name, sym->ns);
2434 if (ts->type == BT_UNKNOWN)
2436 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2437 sym->name, &expr->where);
2448 /* Return true, if the symbol is an external procedure. */
2450 is_external_proc (gfc_symbol *sym)
2452 if (!sym->attr.dummy && !sym->attr.contained
2453 && !(sym->attr.intrinsic
2454 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2455 && sym->attr.proc != PROC_ST_FUNCTION
2456 && !sym->attr.proc_pointer
2457 && !sym->attr.use_assoc
2465 /* Figure out if a function reference is pure or not. Also set the name
2466 of the function for a potential error message. Return nonzero if the
2467 function is PURE, zero if not. */
2469 pure_stmt_function (gfc_expr *, gfc_symbol *);
2472 pure_function (gfc_expr *e, const char **name)
2478 if (e->symtree != NULL
2479 && e->symtree->n.sym != NULL
2480 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2481 return pure_stmt_function (e, e->symtree->n.sym);
2483 if (e->value.function.esym)
2485 pure = gfc_pure (e->value.function.esym);
2486 *name = e->value.function.esym->name;
2488 else if (e->value.function.isym)
2490 pure = e->value.function.isym->pure
2491 || e->value.function.isym->elemental;
2492 *name = e->value.function.isym->name;
2496 /* Implicit functions are not pure. */
2498 *name = e->value.function.name;
2506 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2507 int *f ATTRIBUTE_UNUSED)
2511 /* Don't bother recursing into other statement functions
2512 since they will be checked individually for purity. */
2513 if (e->expr_type != EXPR_FUNCTION
2515 || e->symtree->n.sym == sym
2516 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2519 return pure_function (e, &name) ? false : true;
2524 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2526 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2531 is_scalar_expr_ptr (gfc_expr *expr)
2533 gfc_try retval = SUCCESS;
2538 /* See if we have a gfc_ref, which means we have a substring, array
2539 reference, or a component. */
2540 if (expr->ref != NULL)
2543 while (ref->next != NULL)
2549 if (ref->u.ss.length != NULL
2550 && ref->u.ss.length->length != NULL
2552 && ref->u.ss.start->expr_type == EXPR_CONSTANT
2554 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
2556 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
2557 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
2558 if (end - start + 1 != 1)
2565 if (ref->u.ar.type == AR_ELEMENT)
2567 else if (ref->u.ar.type == AR_FULL)
2569 /* The user can give a full array if the array is of size 1. */
2570 if (ref->u.ar.as != NULL
2571 && ref->u.ar.as->rank == 1
2572 && ref->u.ar.as->type == AS_EXPLICIT
2573 && ref->u.ar.as->lower[0] != NULL
2574 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2575 && ref->u.ar.as->upper[0] != NULL
2576 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2578 /* If we have a character string, we need to check if
2579 its length is one. */
2580 if (expr->ts.type == BT_CHARACTER)
2582 if (expr->ts.u.cl == NULL
2583 || expr->ts.u.cl->length == NULL
2584 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2590 /* We have constant lower and upper bounds. If the
2591 difference between is 1, it can be considered a
2593 start = (int) mpz_get_si
2594 (ref->u.ar.as->lower[0]->value.integer);
2595 end = (int) mpz_get_si
2596 (ref->u.ar.as->upper[0]->value.integer);
2597 if (end - start + 1 != 1)
2612 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2614 /* Character string. Make sure it's of length 1. */
2615 if (expr->ts.u.cl == NULL
2616 || expr->ts.u.cl->length == NULL
2617 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2620 else if (expr->rank != 0)
2627 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2628 and, in the case of c_associated, set the binding label based on
2632 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2633 gfc_symbol **new_sym)
2635 char name[GFC_MAX_SYMBOL_LEN + 1];
2636 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2637 int optional_arg = 0;
2638 gfc_try retval = SUCCESS;
2639 gfc_symbol *args_sym;
2640 gfc_typespec *arg_ts;
2641 symbol_attribute arg_attr;
2643 if (args->expr->expr_type == EXPR_CONSTANT
2644 || args->expr->expr_type == EXPR_OP
2645 || args->expr->expr_type == EXPR_NULL)
2647 gfc_error ("Argument to '%s' at %L is not a variable",
2648 sym->name, &(args->expr->where));
2652 args_sym = args->expr->symtree->n.sym;
2654 /* The typespec for the actual arg should be that stored in the expr
2655 and not necessarily that of the expr symbol (args_sym), because
2656 the actual expression could be a part-ref of the expr symbol. */
2657 arg_ts = &(args->expr->ts);
2658 arg_attr = gfc_expr_attr (args->expr);
2660 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2662 /* If the user gave two args then they are providing something for
2663 the optional arg (the second cptr). Therefore, set the name and
2664 binding label to the c_associated for two cptrs. Otherwise,
2665 set c_associated to expect one cptr. */
2669 sprintf (name, "%s_2", sym->name);
2670 sprintf (binding_label, "%s_2", sym->binding_label);
2676 sprintf (name, "%s_1", sym->name);
2677 sprintf (binding_label, "%s_1", sym->binding_label);
2681 /* Get a new symbol for the version of c_associated that
2683 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2685 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2686 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2688 sprintf (name, "%s", sym->name);
2689 sprintf (binding_label, "%s", sym->binding_label);
2691 /* Error check the call. */
2692 if (args->next != NULL)
2694 gfc_error_now ("More actual than formal arguments in '%s' "
2695 "call at %L", name, &(args->expr->where));
2698 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2700 /* Make sure we have either the target or pointer attribute. */
2701 if (!arg_attr.target && !arg_attr.pointer)
2703 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2704 "a TARGET or an associated pointer",
2706 sym->name, &(args->expr->where));
2710 /* See if we have interoperable type and type param. */
2711 if (verify_c_interop (arg_ts) == SUCCESS
2712 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2714 if (args_sym->attr.target == 1)
2716 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2717 has the target attribute and is interoperable. */
2718 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2719 allocatable variable that has the TARGET attribute and
2720 is not an array of zero size. */
2721 if (args_sym->attr.allocatable == 1)
2723 if (args_sym->attr.dimension != 0
2724 && (args_sym->as && args_sym->as->rank == 0))
2726 gfc_error_now ("Allocatable variable '%s' used as a "
2727 "parameter to '%s' at %L must not be "
2728 "an array of zero size",
2729 args_sym->name, sym->name,
2730 &(args->expr->where));
2736 /* A non-allocatable target variable with C
2737 interoperable type and type parameters must be
2739 if (args_sym && args_sym->attr.dimension)
2741 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2743 gfc_error ("Assumed-shape array '%s' at %L "
2744 "cannot be an argument to the "
2745 "procedure '%s' because "
2746 "it is not C interoperable",
2748 &(args->expr->where), sym->name);
2751 else if (args_sym->as->type == AS_DEFERRED)
2753 gfc_error ("Deferred-shape array '%s' at %L "
2754 "cannot be an argument to the "
2755 "procedure '%s' because "
2756 "it is not C interoperable",
2758 &(args->expr->where), sym->name);
2763 /* Make sure it's not a character string. Arrays of
2764 any type should be ok if the variable is of a C
2765 interoperable type. */
2766 if (arg_ts->type == BT_CHARACTER)
2767 if (arg_ts->u.cl != NULL
2768 && (arg_ts->u.cl->length == NULL
2769 || arg_ts->u.cl->length->expr_type
2772 (arg_ts->u.cl->length->value.integer, 1)
2774 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2776 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2777 "at %L must have a length of 1",
2778 args_sym->name, sym->name,
2779 &(args->expr->where));
2784 else if (arg_attr.pointer
2785 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2787 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2789 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2790 "associated scalar POINTER", args_sym->name,
2791 sym->name, &(args->expr->where));
2797 /* The parameter is not required to be C interoperable. If it
2798 is not C interoperable, it must be a nonpolymorphic scalar
2799 with no length type parameters. It still must have either
2800 the pointer or target attribute, and it can be
2801 allocatable (but must be allocated when c_loc is called). */
2802 if (args->expr->rank != 0
2803 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2805 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2806 "scalar", args_sym->name, sym->name,
2807 &(args->expr->where));
2810 else if (arg_ts->type == BT_CHARACTER
2811 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2813 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2814 "%L must have a length of 1",
2815 args_sym->name, sym->name,
2816 &(args->expr->where));
2819 else if (arg_ts->type == BT_CLASS)
2821 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2822 "polymorphic", args_sym->name, sym->name,
2823 &(args->expr->where));
2828 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2830 if (args_sym->attr.flavor != FL_PROCEDURE)
2832 /* TODO: Update this error message to allow for procedure
2833 pointers once they are implemented. */
2834 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2836 args_sym->name, sym->name,
2837 &(args->expr->where));
2840 else if (args_sym->attr.is_bind_c != 1)
2842 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2844 args_sym->name, sym->name,
2845 &(args->expr->where));
2850 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2855 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2856 "iso_c_binding function: '%s'!\n", sym->name);
2863 /* Resolve a function call, which means resolving the arguments, then figuring
2864 out which entity the name refers to. */
2867 resolve_function (gfc_expr *expr)
2869 gfc_actual_arglist *arg;
2874 procedure_type p = PROC_INTRINSIC;
2875 bool no_formal_args;
2879 sym = expr->symtree->n.sym;
2881 /* If this is a procedure pointer component, it has already been resolved. */
2882 if (gfc_is_proc_ptr_comp (expr, NULL))
2885 if (sym && sym->attr.intrinsic
2886 && resolve_intrinsic (sym, &expr->where) == FAILURE)
2889 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2891 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2895 /* If this ia a deferred TBP with an abstract interface (which may
2896 of course be referenced), expr->value.function.esym will be set. */
2897 if (sym && sym->attr.abstract && !expr->value.function.esym)
2899 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2900 sym->name, &expr->where);
2904 /* Switch off assumed size checking and do this again for certain kinds
2905 of procedure, once the procedure itself is resolved. */
2906 need_full_assumed_size++;
2908 if (expr->symtree && expr->symtree->n.sym)
2909 p = expr->symtree->n.sym->attr.proc;
2911 if (expr->value.function.isym && expr->value.function.isym->inquiry)
2912 inquiry_argument = true;
2913 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2915 if (resolve_actual_arglist (expr->value.function.actual,
2916 p, no_formal_args) == FAILURE)
2918 inquiry_argument = false;
2922 inquiry_argument = false;
2924 /* Need to setup the call to the correct c_associated, depending on
2925 the number of cptrs to user gives to compare. */
2926 if (sym && sym->attr.is_iso_c == 1)
2928 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2932 /* Get the symtree for the new symbol (resolved func).
2933 the old one will be freed later, when it's no longer used. */
2934 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2937 /* Resume assumed_size checking. */
2938 need_full_assumed_size--;
2940 /* If the procedure is external, check for usage. */
2941 if (sym && is_external_proc (sym))
2942 resolve_global_procedure (sym, &expr->where,
2943 &expr->value.function.actual, 0);
2945 if (sym && sym->ts.type == BT_CHARACTER
2947 && sym->ts.u.cl->length == NULL
2949 && expr->value.function.esym == NULL
2950 && !sym->attr.contained)
2952 /* Internal procedures are taken care of in resolve_contained_fntype. */
2953 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2954 "be used at %L since it is not a dummy argument",
2955 sym->name, &expr->where);
2959 /* See if function is already resolved. */
2961 if (expr->value.function.name != NULL)
2963 if (expr->ts.type == BT_UNKNOWN)
2969 /* Apply the rules of section 14.1.2. */
2971 switch (procedure_kind (sym))
2974 t = resolve_generic_f (expr);
2977 case PTYPE_SPECIFIC:
2978 t = resolve_specific_f (expr);
2982 t = resolve_unknown_f (expr);
2986 gfc_internal_error ("resolve_function(): bad function type");
2990 /* If the expression is still a function (it might have simplified),
2991 then we check to see if we are calling an elemental function. */
2993 if (expr->expr_type != EXPR_FUNCTION)
2996 temp = need_full_assumed_size;
2997 need_full_assumed_size = 0;
2999 if (resolve_elemental_actual (expr, NULL) == FAILURE)
3002 if (omp_workshare_flag
3003 && expr->value.function.esym
3004 && ! gfc_elemental (expr->value.function.esym))
3006 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3007 "in WORKSHARE construct", expr->value.function.esym->name,
3012 #define GENERIC_ID expr->value.function.isym->id
3013 else if (expr->value.function.actual != NULL
3014 && expr->value.function.isym != NULL
3015 && GENERIC_ID != GFC_ISYM_LBOUND
3016 && GENERIC_ID != GFC_ISYM_LEN
3017 && GENERIC_ID != GFC_ISYM_LOC
3018 && GENERIC_ID != GFC_ISYM_PRESENT)
3020 /* Array intrinsics must also have the last upper bound of an
3021 assumed size array argument. UBOUND and SIZE have to be
3022 excluded from the check if the second argument is anything
3025 for (arg = expr->value.function.actual; arg; arg = arg->next)
3027 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3028 && arg->next != NULL && arg->next->expr)
3030 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3033 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3036 if ((int)mpz_get_si (arg->next->expr->value.integer)
3041 if (arg->expr != NULL
3042 && arg->expr->rank > 0
3043 && resolve_assumed_size_actual (arg->expr))
3049 need_full_assumed_size = temp;
3052 if (!pure_function (expr, &name) && name)
3056 gfc_error ("reference to non-PURE function '%s' at %L inside a "
3057 "FORALL %s", name, &expr->where,
3058 forall_flag == 2 ? "mask" : "block");
3061 else if (gfc_pure (NULL))
3063 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3064 "procedure within a PURE procedure", name, &expr->where);
3069 /* Functions without the RECURSIVE attribution are not allowed to
3070 * call themselves. */
3071 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3074 esym = expr->value.function.esym;
3076 if (is_illegal_recursion (esym, gfc_current_ns))
3078 if (esym->attr.entry && esym->ns->entries)
3079 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3080 " function '%s' is not RECURSIVE",
3081 esym->name, &expr->where, esym->ns->entries->sym->name);
3083 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3084 " is not RECURSIVE", esym->name, &expr->where);
3090 /* Character lengths of use associated functions may contains references to
3091 symbols not referenced from the current program unit otherwise. Make sure
3092 those symbols are marked as referenced. */
3094 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3095 && expr->value.function.esym->attr.use_assoc)
3097 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3100 /* Make sure that the expression has a typespec that works. */
3101 if (expr->ts.type == BT_UNKNOWN)
3103 if (expr->symtree->n.sym->result
3104 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3105 && !expr->symtree->n.sym->result->attr.proc_pointer)
3106 expr->ts = expr->symtree->n.sym->result->ts;
3113 /************* Subroutine resolution *************/
3116 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3122 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3123 sym->name, &c->loc);
3124 else if (gfc_pure (NULL))
3125 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3131 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3135 if (sym->attr.generic)
3137 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3140 c->resolved_sym = s;
3141 pure_subroutine (c, s);
3145 /* TODO: Need to search for elemental references in generic interface. */
3148 if (sym->attr.intrinsic)
3149 return gfc_intrinsic_sub_interface (c, 0);
3156 resolve_generic_s (gfc_code *c)
3161 sym = c->symtree->n.sym;
3165 m = resolve_generic_s0 (c, sym);
3168 else if (m == MATCH_ERROR)
3172 if (sym->ns->parent == NULL)
3174 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3178 if (!generic_sym (sym))
3182 /* Last ditch attempt. See if the reference is to an intrinsic
3183 that possesses a matching interface. 14.1.2.4 */
3184 sym = c->symtree->n.sym;
3186 if (!gfc_is_intrinsic (sym, 1, c->loc))
3188 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3189 sym->name, &c->loc);
3193 m = gfc_intrinsic_sub_interface (c, 0);
3197 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3198 "intrinsic subroutine interface", sym->name, &c->loc);
3204 /* Set the name and binding label of the subroutine symbol in the call
3205 expression represented by 'c' to include the type and kind of the
3206 second parameter. This function is for resolving the appropriate
3207 version of c_f_pointer() and c_f_procpointer(). For example, a
3208 call to c_f_pointer() for a default integer pointer could have a
3209 name of c_f_pointer_i4. If no second arg exists, which is an error
3210 for these two functions, it defaults to the generic symbol's name
3211 and binding label. */
3214 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3215 char *name, char *binding_label)
3217 gfc_expr *arg = NULL;
3221 /* The second arg of c_f_pointer and c_f_procpointer determines
3222 the type and kind for the procedure name. */
3223 arg = c->ext.actual->next->expr;
3227 /* Set up the name to have the given symbol's name,
3228 plus the type and kind. */
3229 /* a derived type is marked with the type letter 'u' */
3230 if (arg->ts.type == BT_DERIVED)
3233 kind = 0; /* set the kind as 0 for now */
3237 type = gfc_type_letter (arg->ts.type);
3238 kind = arg->ts.kind;
3241 if (arg->ts.type == BT_CHARACTER)
3242 /* Kind info for character strings not needed. */
3245 sprintf (name, "%s_%c%d", sym->name, type, kind);
3246 /* Set up the binding label as the given symbol's label plus
3247 the type and kind. */
3248 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
3252 /* If the second arg is missing, set the name and label as
3253 was, cause it should at least be found, and the missing
3254 arg error will be caught by compare_parameters(). */
3255 sprintf (name, "%s", sym->name);
3256 sprintf (binding_label, "%s", sym->binding_label);
3263 /* Resolve a generic version of the iso_c_binding procedure given
3264 (sym) to the specific one based on the type and kind of the
3265 argument(s). Currently, this function resolves c_f_pointer() and
3266 c_f_procpointer based on the type and kind of the second argument
3267 (FPTR). Other iso_c_binding procedures aren't specially handled.
3268 Upon successfully exiting, c->resolved_sym will hold the resolved
3269 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3273 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3275 gfc_symbol *new_sym;
3276 /* this is fine, since we know the names won't use the max */
3277 char name[GFC_MAX_SYMBOL_LEN + 1];
3278 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
3279 /* default to success; will override if find error */
3280 match m = MATCH_YES;
3282 /* Make sure the actual arguments are in the necessary order (based on the
3283 formal args) before resolving. */
3284 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3286 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3287 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3289 set_name_and_label (c, sym, name, binding_label);
3291 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3293 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3295 /* Make sure we got a third arg if the second arg has non-zero
3296 rank. We must also check that the type and rank are
3297 correct since we short-circuit this check in
3298 gfc_procedure_use() (called above to sort actual args). */
3299 if (c->ext.actual->next->expr->rank != 0)
3301 if(c->ext.actual->next->next == NULL
3302 || c->ext.actual->next->next->expr == NULL)
3305 gfc_error ("Missing SHAPE parameter for call to %s "
3306 "at %L", sym->name, &(c->loc));
3308 else if (c->ext.actual->next->next->expr->ts.type
3310 || c->ext.actual->next->next->expr->rank != 1)
3313 gfc_error ("SHAPE parameter for call to %s at %L must "
3314 "be a rank 1 INTEGER array", sym->name,
3321 if (m != MATCH_ERROR)
3323 /* the 1 means to add the optional arg to formal list */
3324 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3326 /* for error reporting, say it's declared where the original was */
3327 new_sym->declared_at = sym->declared_at;