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)
302 if (!sym->attr.function || sym->result == sym)
303 gfc_set_default_type (sym, 1, sym->ns);
306 gfc_resolve_array_spec (sym->as, 0);
308 /* We can't tell if an array with dimension (:) is assumed or deferred
309 shape until we know if it has the pointer or allocatable attributes.
311 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
312 && !(sym->attr.pointer || sym->attr.allocatable))
314 sym->as->type = AS_ASSUMED_SHAPE;
315 for (i = 0; i < sym->as->rank; i++)
316 sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
320 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
321 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
322 || sym->attr.optional)
324 proc->attr.always_explicit = 1;
326 proc->result->attr.always_explicit = 1;
329 /* If the flavor is unknown at this point, it has to be a variable.
330 A procedure specification would have already set the type. */
332 if (sym->attr.flavor == FL_UNKNOWN)
333 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
335 if (gfc_pure (proc) && !sym->attr.pointer
336 && sym->attr.flavor != FL_PROCEDURE)
338 if (proc->attr.function && sym->attr.intent != INTENT_IN)
339 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
340 "INTENT(IN)", sym->name, proc->name,
343 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
344 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
345 "have its INTENT specified", sym->name, proc->name,
349 if (gfc_elemental (proc))
352 if (sym->attr.codimension)
354 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
355 "procedure", sym->name, &sym->declared_at);
361 gfc_error ("Argument '%s' of elemental procedure at %L must "
362 "be scalar", sym->name, &sym->declared_at);
366 if (sym->attr.allocatable)
368 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
369 "have the ALLOCATABLE attribute", sym->name,
374 if (sym->attr.pointer)
376 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
377 "have the POINTER attribute", sym->name,
382 if (sym->attr.flavor == FL_PROCEDURE)
384 gfc_error ("Dummy procedure '%s' not allowed in elemental "
385 "procedure '%s' at %L", sym->name, proc->name,
390 if (sym->attr.intent == INTENT_UNKNOWN)
392 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
393 "have its INTENT specified", sym->name, proc->name,
399 /* Each dummy shall be specified to be scalar. */
400 if (proc->attr.proc == PROC_ST_FUNCTION)
404 gfc_error ("Argument '%s' of statement function at %L must "
405 "be scalar", sym->name, &sym->declared_at);
409 if (sym->ts.type == BT_CHARACTER)
411 gfc_charlen *cl = sym->ts.u.cl;
412 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
414 gfc_error ("Character-valued argument '%s' of statement "
415 "function at %L must have constant length",
416 sym->name, &sym->declared_at);
426 /* Work function called when searching for symbols that have argument lists
427 associated with them. */
430 find_arglists (gfc_symbol *sym)
432 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
435 resolve_formal_arglist (sym);
439 /* Given a namespace, resolve all formal argument lists within the namespace.
443 resolve_formal_arglists (gfc_namespace *ns)
448 gfc_traverse_ns (ns, find_arglists);
453 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
457 /* If this namespace is not a function or an entry master function,
459 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
460 || sym->attr.entry_master)
463 /* Try to find out of what the return type is. */
464 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
466 t = gfc_set_default_type (sym->result, 0, ns);
468 if (t == FAILURE && !sym->result->attr.untyped)
470 if (sym->result == sym)
471 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
472 sym->name, &sym->declared_at);
473 else if (!sym->result->attr.proc_pointer)
474 gfc_error ("Result '%s' of contained function '%s' at %L has "
475 "no IMPLICIT type", sym->result->name, sym->name,
476 &sym->result->declared_at);
477 sym->result->attr.untyped = 1;
481 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
482 type, lists the only ways a character length value of * can be used:
483 dummy arguments of procedures, named constants, and function results
484 in external functions. Internal function results and results of module
485 procedures are not on this list, ergo, not permitted. */
487 if (sym->result->ts.type == BT_CHARACTER)
489 gfc_charlen *cl = sym->result->ts.u.cl;
490 if (!cl || !cl->length)
492 /* See if this is a module-procedure and adapt error message
495 gcc_assert (ns->parent && ns->parent->proc_name);
496 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
498 gfc_error ("Character-valued %s '%s' at %L must not be"
500 module_proc ? _("module procedure")
501 : _("internal function"),
502 sym->name, &sym->declared_at);
508 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
509 introduce duplicates. */
512 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
514 gfc_formal_arglist *f, *new_arglist;
517 for (; new_args != NULL; new_args = new_args->next)
519 new_sym = new_args->sym;
520 /* See if this arg is already in the formal argument list. */
521 for (f = proc->formal; f; f = f->next)
523 if (new_sym == f->sym)
530 /* Add a new argument. Argument order is not important. */
531 new_arglist = gfc_get_formal_arglist ();
532 new_arglist->sym = new_sym;
533 new_arglist->next = proc->formal;
534 proc->formal = new_arglist;
539 /* Flag the arguments that are not present in all entries. */
542 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
544 gfc_formal_arglist *f, *head;
547 for (f = proc->formal; f; f = f->next)
552 for (new_args = head; new_args; new_args = new_args->next)
554 if (new_args->sym == f->sym)
561 f->sym->attr.not_always_present = 1;
566 /* Resolve alternate entry points. If a symbol has multiple entry points we
567 create a new master symbol for the main routine, and turn the existing
568 symbol into an entry point. */
571 resolve_entries (gfc_namespace *ns)
573 gfc_namespace *old_ns;
577 char name[GFC_MAX_SYMBOL_LEN + 1];
578 static int master_count = 0;
580 if (ns->proc_name == NULL)
583 /* No need to do anything if this procedure doesn't have alternate entry
588 /* We may already have resolved alternate entry points. */
589 if (ns->proc_name->attr.entry_master)
592 /* If this isn't a procedure something has gone horribly wrong. */
593 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
595 /* Remember the current namespace. */
596 old_ns = gfc_current_ns;
600 /* Add the main entry point to the list of entry points. */
601 el = gfc_get_entry_list ();
602 el->sym = ns->proc_name;
604 el->next = ns->entries;
606 ns->proc_name->attr.entry = 1;
608 /* If it is a module function, it needs to be in the right namespace
609 so that gfc_get_fake_result_decl can gather up the results. The
610 need for this arose in get_proc_name, where these beasts were
611 left in their own namespace, to keep prior references linked to
612 the entry declaration.*/
613 if (ns->proc_name->attr.function
614 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
617 /* Do the same for entries where the master is not a module
618 procedure. These are retained in the module namespace because
619 of the module procedure declaration. */
620 for (el = el->next; el; el = el->next)
621 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
622 && el->sym->attr.mod_proc)
626 /* Add an entry statement for it. */
633 /* Create a new symbol for the master function. */
634 /* Give the internal function a unique name (within this file).
635 Also include the function name so the user has some hope of figuring
636 out what is going on. */
637 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
638 master_count++, ns->proc_name->name);
639 gfc_get_ha_symbol (name, &proc);
640 gcc_assert (proc != NULL);
642 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
643 if (ns->proc_name->attr.subroutine)
644 gfc_add_subroutine (&proc->attr, proc->name, NULL);
648 gfc_typespec *ts, *fts;
649 gfc_array_spec *as, *fas;
650 gfc_add_function (&proc->attr, proc->name, NULL);
652 fas = ns->entries->sym->as;
653 fas = fas ? fas : ns->entries->sym->result->as;
654 fts = &ns->entries->sym->result->ts;
655 if (fts->type == BT_UNKNOWN)
656 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
657 for (el = ns->entries->next; el; el = el->next)
659 ts = &el->sym->result->ts;
661 as = as ? as : el->sym->result->as;
662 if (ts->type == BT_UNKNOWN)
663 ts = gfc_get_default_type (el->sym->result->name, NULL);
665 if (! gfc_compare_types (ts, fts)
666 || (el->sym->result->attr.dimension
667 != ns->entries->sym->result->attr.dimension)
668 || (el->sym->result->attr.pointer
669 != ns->entries->sym->result->attr.pointer))
671 else if (as && fas && ns->entries->sym->result != el->sym->result
672 && gfc_compare_array_spec (as, fas) == 0)
673 gfc_error ("Function %s at %L has entries with mismatched "
674 "array specifications", ns->entries->sym->name,
675 &ns->entries->sym->declared_at);
676 /* The characteristics need to match and thus both need to have
677 the same string length, i.e. both len=*, or both len=4.
678 Having both len=<variable> is also possible, but difficult to
679 check at compile time. */
680 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
681 && (((ts->u.cl->length && !fts->u.cl->length)
682 ||(!ts->u.cl->length && fts->u.cl->length))
684 && ts->u.cl->length->expr_type
685 != fts->u.cl->length->expr_type)
687 && ts->u.cl->length->expr_type == EXPR_CONSTANT
688 && mpz_cmp (ts->u.cl->length->value.integer,
689 fts->u.cl->length->value.integer) != 0)))
690 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
691 "entries returning variables of different "
692 "string lengths", ns->entries->sym->name,
693 &ns->entries->sym->declared_at);
698 sym = ns->entries->sym->result;
699 /* All result types the same. */
701 if (sym->attr.dimension)
702 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
703 if (sym->attr.pointer)
704 gfc_add_pointer (&proc->attr, NULL);
708 /* Otherwise the result will be passed through a union by
710 proc->attr.mixed_entry_master = 1;
711 for (el = ns->entries; el; el = el->next)
713 sym = el->sym->result;
714 if (sym->attr.dimension)
716 if (el == ns->entries)
717 gfc_error ("FUNCTION result %s can't be an array in "
718 "FUNCTION %s at %L", sym->name,
719 ns->entries->sym->name, &sym->declared_at);
721 gfc_error ("ENTRY result %s can't be an array in "
722 "FUNCTION %s at %L", sym->name,
723 ns->entries->sym->name, &sym->declared_at);
725 else if (sym->attr.pointer)
727 if (el == ns->entries)
728 gfc_error ("FUNCTION result %s can't be a POINTER in "
729 "FUNCTION %s at %L", sym->name,
730 ns->entries->sym->name, &sym->declared_at);
732 gfc_error ("ENTRY result %s can't be a POINTER in "
733 "FUNCTION %s at %L", sym->name,
734 ns->entries->sym->name, &sym->declared_at);
739 if (ts->type == BT_UNKNOWN)
740 ts = gfc_get_default_type (sym->name, NULL);
744 if (ts->kind == gfc_default_integer_kind)
748 if (ts->kind == gfc_default_real_kind
749 || ts->kind == gfc_default_double_kind)
753 if (ts->kind == gfc_default_complex_kind)
757 if (ts->kind == gfc_default_logical_kind)
761 /* We will issue error elsewhere. */
769 if (el == ns->entries)
770 gfc_error ("FUNCTION result %s can't be of type %s "
771 "in FUNCTION %s at %L", sym->name,
772 gfc_typename (ts), ns->entries->sym->name,
775 gfc_error ("ENTRY result %s can't be of type %s "
776 "in FUNCTION %s at %L", sym->name,
777 gfc_typename (ts), ns->entries->sym->name,
784 proc->attr.access = ACCESS_PRIVATE;
785 proc->attr.entry_master = 1;
787 /* Merge all the entry point arguments. */
788 for (el = ns->entries; el; el = el->next)
789 merge_argument_lists (proc, el->sym->formal);
791 /* Check the master formal arguments for any that are not
792 present in all entry points. */
793 for (el = ns->entries; el; el = el->next)
794 check_argument_lists (proc, el->sym->formal);
796 /* Use the master function for the function body. */
797 ns->proc_name = proc;
799 /* Finalize the new symbols. */
800 gfc_commit_symbols ();
802 /* Restore the original namespace. */
803 gfc_current_ns = old_ns;
807 /* Resolve common variables. */
809 resolve_common_vars (gfc_symbol *sym, bool named_common)
811 gfc_symbol *csym = sym;
813 for (; csym; csym = csym->common_next)
815 if (csym->value || csym->attr.data)
817 if (!csym->ns->is_block_data)
818 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
819 "but only in BLOCK DATA initialization is "
820 "allowed", csym->name, &csym->declared_at);
821 else if (!named_common)
822 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
823 "in a blank COMMON but initialization is only "
824 "allowed in named common blocks", csym->name,
828 if (csym->ts.type != BT_DERIVED)
831 if (!(csym->ts.u.derived->attr.sequence
832 || csym->ts.u.derived->attr.is_bind_c))
833 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
834 "has neither the SEQUENCE nor the BIND(C) "
835 "attribute", csym->name, &csym->declared_at);
836 if (csym->ts.u.derived->attr.alloc_comp)
837 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
838 "has an ultimate component that is "
839 "allocatable", csym->name, &csym->declared_at);
840 if (gfc_has_default_initializer (csym->ts.u.derived))
841 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
842 "may not have default initializer", csym->name,
845 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
846 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
850 /* Resolve common blocks. */
852 resolve_common_blocks (gfc_symtree *common_root)
856 if (common_root == NULL)
859 if (common_root->left)
860 resolve_common_blocks (common_root->left);
861 if (common_root->right)
862 resolve_common_blocks (common_root->right);
864 resolve_common_vars (common_root->n.common->head, true);
866 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
870 if (sym->attr.flavor == FL_PARAMETER)
871 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
872 sym->name, &common_root->n.common->where, &sym->declared_at);
874 if (sym->attr.intrinsic)
875 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
876 sym->name, &common_root->n.common->where);
877 else if (sym->attr.result
878 || gfc_is_function_return_value (sym, gfc_current_ns))
879 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
880 "that is also a function result", sym->name,
881 &common_root->n.common->where);
882 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
883 && sym->attr.proc != PROC_ST_FUNCTION)
884 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
885 "that is also a global procedure", sym->name,
886 &common_root->n.common->where);
890 /* Resolve contained function types. Because contained functions can call one
891 another, they have to be worked out before any of the contained procedures
894 The good news is that if a function doesn't already have a type, the only
895 way it can get one is through an IMPLICIT type or a RESULT variable, because
896 by definition contained functions are contained namespace they're contained
897 in, not in a sibling or parent namespace. */
900 resolve_contained_functions (gfc_namespace *ns)
902 gfc_namespace *child;
905 resolve_formal_arglists (ns);
907 for (child = ns->contained; child; child = child->sibling)
909 /* Resolve alternate entry points first. */
910 resolve_entries (child);
912 /* Then check function return types. */
913 resolve_contained_fntype (child->proc_name, child);
914 for (el = child->entries; el; el = el->next)
915 resolve_contained_fntype (el->sym, child);
920 /* Resolve all of the elements of a structure constructor and make sure that
921 the types are correct. The 'init' flag indicates that the given
922 constructor is an initializer. */
925 resolve_structure_cons (gfc_expr *expr, int init)
927 gfc_constructor *cons;
933 cons = gfc_constructor_first (expr->value.constructor);
934 /* A constructor may have references if it is the result of substituting a
935 parameter variable. In this case we just pull out the component we
938 comp = expr->ref->u.c.sym->components;
940 comp = expr->ts.u.derived->components;
942 /* See if the user is trying to invoke a structure constructor for one of
943 the iso_c_binding derived types. */
944 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
945 && expr->ts.u.derived->ts.is_iso_c && cons
946 && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
948 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
949 expr->ts.u.derived->name, &(expr->where));
953 /* Return if structure constructor is c_null_(fun)prt. */
954 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
955 && expr->ts.u.derived->ts.is_iso_c && cons
956 && cons->expr && cons->expr->expr_type == EXPR_NULL)
959 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
966 if (gfc_resolve_expr (cons->expr) == FAILURE)
972 rank = comp->as ? comp->as->rank : 0;
973 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
974 && (comp->attr.allocatable || cons->expr->rank))
976 gfc_error ("The rank of the element in the derived type "
977 "constructor at %L does not match that of the "
978 "component (%d/%d)", &cons->expr->where,
979 cons->expr->rank, rank);
983 /* If we don't have the right type, try to convert it. */
985 if (!comp->attr.proc_pointer &&
986 !gfc_compare_types (&cons->expr->ts, &comp->ts))
989 if (strcmp (comp->name, "$extends") == 0)
991 /* Can afford to be brutal with the $extends initializer.
992 The derived type can get lost because it is PRIVATE
993 but it is not usage constrained by the standard. */
994 cons->expr->ts = comp->ts;
997 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
998 gfc_error ("The element in the derived type constructor at %L, "
999 "for pointer component '%s', is %s but should be %s",
1000 &cons->expr->where, comp->name,
1001 gfc_basic_typename (cons->expr->ts.type),
1002 gfc_basic_typename (comp->ts.type));
1004 t = gfc_convert_type (cons->expr, &comp->ts, 1);
1007 /* For strings, the length of the constructor should be the same as
1008 the one of the structure, ensure this if the lengths are known at
1009 compile time and when we are dealing with PARAMETER or structure
1011 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1012 && comp->ts.u.cl->length
1013 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1014 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1015 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1016 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1017 comp->ts.u.cl->length->value.integer) != 0)
1019 if (cons->expr->expr_type == EXPR_VARIABLE
1020 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1022 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1023 to make use of the gfc_resolve_character_array_constructor
1024 machinery. The expression is later simplified away to
1025 an array of string literals. */
1026 gfc_expr *para = cons->expr;
1027 cons->expr = gfc_get_expr ();
1028 cons->expr->ts = para->ts;
1029 cons->expr->where = para->where;
1030 cons->expr->expr_type = EXPR_ARRAY;
1031 cons->expr->rank = para->rank;
1032 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1033 gfc_constructor_append_expr (&cons->expr->value.constructor,
1034 para, &cons->expr->where);
1036 if (cons->expr->expr_type == EXPR_ARRAY)
1039 p = gfc_constructor_first (cons->expr->value.constructor);
1040 if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
1042 gfc_charlen *cl, *cl2;
1045 for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
1047 if (cl == cons->expr->ts.u.cl)
1055 cl2->next = cl->next;
1057 gfc_free_expr (cl->length);
1061 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1062 cons->expr->ts.u.cl->length_from_typespec = true;
1063 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1064 gfc_resolve_character_array_constructor (cons->expr);
1068 if (cons->expr->expr_type == EXPR_NULL
1069 && !(comp->attr.pointer || comp->attr.allocatable
1070 || comp->attr.proc_pointer
1071 || (comp->ts.type == BT_CLASS
1072 && (CLASS_DATA (comp)->attr.class_pointer
1073 || CLASS_DATA (comp)->attr.allocatable))))
1076 gfc_error ("The NULL in the derived type constructor at %L is "
1077 "being applied to component '%s', which is neither "
1078 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1082 if (!comp->attr.pointer || cons->expr->expr_type == EXPR_NULL)
1085 a = gfc_expr_attr (cons->expr);
1087 if (!a.pointer && !a.target)
1090 gfc_error ("The element in the derived type constructor at %L, "
1091 "for pointer component '%s' should be a POINTER or "
1092 "a TARGET", &cons->expr->where, comp->name);
1097 /* F08:C461. Additional checks for pointer initialization. */
1101 gfc_error ("Pointer initialization target at %L "
1102 "must not be ALLOCATABLE ", &cons->expr->where);
1107 gfc_error ("Pointer initialization target at %L "
1108 "must have the SAVE attribute", &cons->expr->where);
1112 /* F2003, C1272 (3). */
1113 if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
1114 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1115 || gfc_is_coindexed (cons->expr)))
1118 gfc_error ("Invalid expression in the derived type constructor for "
1119 "pointer component '%s' at %L in PURE procedure",
1120 comp->name, &cons->expr->where);
1129 /****************** Expression name resolution ******************/
1131 /* Returns 0 if a symbol was not declared with a type or
1132 attribute declaration statement, nonzero otherwise. */
1135 was_declared (gfc_symbol *sym)
1141 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1144 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1145 || a.optional || a.pointer || a.save || a.target || a.volatile_
1146 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1147 || a.asynchronous || a.codimension)
1154 /* Determine if a symbol is generic or not. */
1157 generic_sym (gfc_symbol *sym)
1161 if (sym->attr.generic ||
1162 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1165 if (was_declared (sym) || sym->ns->parent == NULL)
1168 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1175 return generic_sym (s);
1182 /* Determine if a symbol is specific or not. */
1185 specific_sym (gfc_symbol *sym)
1189 if (sym->attr.if_source == IFSRC_IFBODY
1190 || sym->attr.proc == PROC_MODULE
1191 || sym->attr.proc == PROC_INTERNAL
1192 || sym->attr.proc == PROC_ST_FUNCTION
1193 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1194 || sym->attr.external)
1197 if (was_declared (sym) || sym->ns->parent == NULL)
1200 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1202 return (s == NULL) ? 0 : specific_sym (s);
1206 /* Figure out if the procedure is specific, generic or unknown. */
1209 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1213 procedure_kind (gfc_symbol *sym)
1215 if (generic_sym (sym))
1216 return PTYPE_GENERIC;
1218 if (specific_sym (sym))
1219 return PTYPE_SPECIFIC;
1221 return PTYPE_UNKNOWN;
1224 /* Check references to assumed size arrays. The flag need_full_assumed_size
1225 is nonzero when matching actual arguments. */
1227 static int need_full_assumed_size = 0;
1230 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1232 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1235 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1236 What should it be? */
1237 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1238 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1239 && (e->ref->u.ar.type == AR_FULL))
1241 gfc_error ("The upper bound in the last dimension must "
1242 "appear in the reference to the assumed size "
1243 "array '%s' at %L", sym->name, &e->where);
1250 /* Look for bad assumed size array references in argument expressions
1251 of elemental and array valued intrinsic procedures. Since this is
1252 called from procedure resolution functions, it only recurses at
1256 resolve_assumed_size_actual (gfc_expr *e)
1261 switch (e->expr_type)
1264 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1269 if (resolve_assumed_size_actual (e->value.op.op1)
1270 || resolve_assumed_size_actual (e->value.op.op2))
1281 /* Check a generic procedure, passed as an actual argument, to see if
1282 there is a matching specific name. If none, it is an error, and if
1283 more than one, the reference is ambiguous. */
1285 count_specific_procs (gfc_expr *e)
1292 sym = e->symtree->n.sym;
1294 for (p = sym->generic; p; p = p->next)
1295 if (strcmp (sym->name, p->sym->name) == 0)
1297 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1303 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1307 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1308 "argument at %L", sym->name, &e->where);
1314 /* See if a call to sym could possibly be a not allowed RECURSION because of
1315 a missing RECURIVE declaration. This means that either sym is the current
1316 context itself, or sym is the parent of a contained procedure calling its
1317 non-RECURSIVE containing procedure.
1318 This also works if sym is an ENTRY. */
1321 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1323 gfc_symbol* proc_sym;
1324 gfc_symbol* context_proc;
1325 gfc_namespace* real_context;
1327 if (sym->attr.flavor == FL_PROGRAM)
1330 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1332 /* If we've got an ENTRY, find real procedure. */
1333 if (sym->attr.entry && sym->ns->entries)
1334 proc_sym = sym->ns->entries->sym;
1338 /* If sym is RECURSIVE, all is well of course. */
1339 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1342 /* Find the context procedure's "real" symbol if it has entries.
1343 We look for a procedure symbol, so recurse on the parents if we don't
1344 find one (like in case of a BLOCK construct). */
1345 for (real_context = context; ; real_context = real_context->parent)
1347 /* We should find something, eventually! */
1348 gcc_assert (real_context);
1350 context_proc = (real_context->entries ? real_context->entries->sym
1351 : real_context->proc_name);
1353 /* In some special cases, there may not be a proc_name, like for this
1355 real(bad_kind()) function foo () ...
1356 when checking the call to bad_kind ().
1357 In these cases, we simply return here and assume that the
1362 if (context_proc->attr.flavor != FL_LABEL)
1366 /* A call from sym's body to itself is recursion, of course. */
1367 if (context_proc == proc_sym)
1370 /* The same is true if context is a contained procedure and sym the
1372 if (context_proc->attr.contained)
1374 gfc_symbol* parent_proc;
1376 gcc_assert (context->parent);
1377 parent_proc = (context->parent->entries ? context->parent->entries->sym
1378 : context->parent->proc_name);
1380 if (parent_proc == proc_sym)
1388 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1389 its typespec and formal argument list. */
1392 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1394 gfc_intrinsic_sym* isym;
1400 /* We already know this one is an intrinsic, so we don't call
1401 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1402 gfc_find_subroutine directly to check whether it is a function or
1405 if ((isym = gfc_find_function (sym->name)))
1407 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1408 && !sym->attr.implicit_type)
1409 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1410 " ignored", sym->name, &sym->declared_at);
1412 if (!sym->attr.function &&
1413 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1418 else if ((isym = gfc_find_subroutine (sym->name)))
1420 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1422 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1423 " specifier", sym->name, &sym->declared_at);
1427 if (!sym->attr.subroutine &&
1428 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1433 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1438 gfc_copy_formal_args_intr (sym, isym);
1440 /* Check it is actually available in the standard settings. */
1441 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1444 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1445 " available in the current standard settings but %s. Use"
1446 " an appropriate -std=* option or enable -fall-intrinsics"
1447 " in order to use it.",
1448 sym->name, &sym->declared_at, symstd);
1456 /* Resolve a procedure expression, like passing it to a called procedure or as
1457 RHS for a procedure pointer assignment. */
1460 resolve_procedure_expression (gfc_expr* expr)
1464 if (expr->expr_type != EXPR_VARIABLE)
1466 gcc_assert (expr->symtree);
1468 sym = expr->symtree->n.sym;
1470 if (sym->attr.intrinsic)
1471 resolve_intrinsic (sym, &expr->where);
1473 if (sym->attr.flavor != FL_PROCEDURE
1474 || (sym->attr.function && sym->result == sym))
1477 /* A non-RECURSIVE procedure that is used as procedure expression within its
1478 own body is in danger of being called recursively. */
1479 if (is_illegal_recursion (sym, gfc_current_ns))
1480 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1481 " itself recursively. Declare it RECURSIVE or use"
1482 " -frecursive", sym->name, &expr->where);
1488 /* Resolve an actual argument list. Most of the time, this is just
1489 resolving the expressions in the list.
1490 The exception is that we sometimes have to decide whether arguments
1491 that look like procedure arguments are really simple variable
1495 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1496 bool no_formal_args)
1499 gfc_symtree *parent_st;
1501 int save_need_full_assumed_size;
1502 gfc_component *comp;
1504 for (; arg; arg = arg->next)
1509 /* Check the label is a valid branching target. */
1512 if (arg->label->defined == ST_LABEL_UNKNOWN)
1514 gfc_error ("Label %d referenced at %L is never defined",
1515 arg->label->value, &arg->label->where);
1522 if (gfc_is_proc_ptr_comp (e, &comp))
1525 if (e->expr_type == EXPR_PPC)
1527 if (comp->as != NULL)
1528 e->rank = comp->as->rank;
1529 e->expr_type = EXPR_FUNCTION;
1531 if (gfc_resolve_expr (e) == FAILURE)
1536 if (e->expr_type == EXPR_VARIABLE
1537 && e->symtree->n.sym->attr.generic
1539 && count_specific_procs (e) != 1)
1542 if (e->ts.type != BT_PROCEDURE)
1544 save_need_full_assumed_size = need_full_assumed_size;
1545 if (e->expr_type != EXPR_VARIABLE)
1546 need_full_assumed_size = 0;
1547 if (gfc_resolve_expr (e) != SUCCESS)
1549 need_full_assumed_size = save_need_full_assumed_size;
1553 /* See if the expression node should really be a variable reference. */
1555 sym = e->symtree->n.sym;
1557 if (sym->attr.flavor == FL_PROCEDURE
1558 || sym->attr.intrinsic
1559 || sym->attr.external)
1563 /* If a procedure is not already determined to be something else
1564 check if it is intrinsic. */
1565 if (!sym->attr.intrinsic
1566 && !(sym->attr.external || sym->attr.use_assoc
1567 || sym->attr.if_source == IFSRC_IFBODY)
1568 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1569 sym->attr.intrinsic = 1;
1571 if (sym->attr.proc == PROC_ST_FUNCTION)
1573 gfc_error ("Statement function '%s' at %L is not allowed as an "
1574 "actual argument", sym->name, &e->where);
1577 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1578 sym->attr.subroutine);
1579 if (sym->attr.intrinsic && actual_ok == 0)
1581 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1582 "actual argument", sym->name, &e->where);
1585 if (sym->attr.contained && !sym->attr.use_assoc
1586 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1588 gfc_error ("Internal procedure '%s' is not allowed as an "
1589 "actual argument at %L", sym->name, &e->where);
1592 if (sym->attr.elemental && !sym->attr.intrinsic)
1594 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1595 "allowed as an actual argument at %L", sym->name,
1599 /* Check if a generic interface has a specific procedure
1600 with the same name before emitting an error. */
1601 if (sym->attr.generic && count_specific_procs (e) != 1)
1604 /* Just in case a specific was found for the expression. */
1605 sym = e->symtree->n.sym;
1607 /* If the symbol is the function that names the current (or
1608 parent) scope, then we really have a variable reference. */
1610 if (gfc_is_function_return_value (sym, sym->ns))
1613 /* If all else fails, see if we have a specific intrinsic. */
1614 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1616 gfc_intrinsic_sym *isym;
1618 isym = gfc_find_function (sym->name);
1619 if (isym == NULL || !isym->specific)
1621 gfc_error ("Unable to find a specific INTRINSIC procedure "
1622 "for the reference '%s' at %L", sym->name,
1627 sym->attr.intrinsic = 1;
1628 sym->attr.function = 1;
1631 if (gfc_resolve_expr (e) == FAILURE)
1636 /* See if the name is a module procedure in a parent unit. */
1638 if (was_declared (sym) || sym->ns->parent == NULL)
1641 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1643 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1647 if (parent_st == NULL)
1650 sym = parent_st->n.sym;
1651 e->symtree = parent_st; /* Point to the right thing. */
1653 if (sym->attr.flavor == FL_PROCEDURE
1654 || sym->attr.intrinsic
1655 || sym->attr.external)
1657 if (gfc_resolve_expr (e) == FAILURE)
1663 e->expr_type = EXPR_VARIABLE;
1665 if (sym->as != NULL)
1667 e->rank = sym->as->rank;
1668 e->ref = gfc_get_ref ();
1669 e->ref->type = REF_ARRAY;
1670 e->ref->u.ar.type = AR_FULL;
1671 e->ref->u.ar.as = sym->as;
1674 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1675 primary.c (match_actual_arg). If above code determines that it
1676 is a variable instead, it needs to be resolved as it was not
1677 done at the beginning of this function. */
1678 save_need_full_assumed_size = need_full_assumed_size;
1679 if (e->expr_type != EXPR_VARIABLE)
1680 need_full_assumed_size = 0;
1681 if (gfc_resolve_expr (e) != SUCCESS)
1683 need_full_assumed_size = save_need_full_assumed_size;
1686 /* Check argument list functions %VAL, %LOC and %REF. There is
1687 nothing to do for %REF. */
1688 if (arg->name && arg->name[0] == '%')
1690 if (strncmp ("%VAL", arg->name, 4) == 0)
1692 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1694 gfc_error ("By-value argument at %L is not of numeric "
1701 gfc_error ("By-value argument at %L cannot be an array or "
1702 "an array section", &e->where);
1706 /* Intrinsics are still PROC_UNKNOWN here. However,
1707 since same file external procedures are not resolvable
1708 in gfortran, it is a good deal easier to leave them to
1710 if (ptype != PROC_UNKNOWN
1711 && ptype != PROC_DUMMY
1712 && ptype != PROC_EXTERNAL
1713 && ptype != PROC_MODULE)
1715 gfc_error ("By-value argument at %L is not allowed "
1716 "in this context", &e->where);
1721 /* Statement functions have already been excluded above. */
1722 else if (strncmp ("%LOC", arg->name, 4) == 0
1723 && e->ts.type == BT_PROCEDURE)
1725 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1727 gfc_error ("Passing internal procedure at %L by location "
1728 "not allowed", &e->where);
1734 /* Fortran 2008, C1237. */
1735 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1736 && gfc_has_ultimate_pointer (e))
1738 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1739 "component", &e->where);
1748 /* Do the checks of the actual argument list that are specific to elemental
1749 procedures. If called with c == NULL, we have a function, otherwise if
1750 expr == NULL, we have a subroutine. */
1753 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1755 gfc_actual_arglist *arg0;
1756 gfc_actual_arglist *arg;
1757 gfc_symbol *esym = NULL;
1758 gfc_intrinsic_sym *isym = NULL;
1760 gfc_intrinsic_arg *iformal = NULL;
1761 gfc_formal_arglist *eformal = NULL;
1762 bool formal_optional = false;
1763 bool set_by_optional = false;
1767 /* Is this an elemental procedure? */
1768 if (expr && expr->value.function.actual != NULL)
1770 if (expr->value.function.esym != NULL
1771 && expr->value.function.esym->attr.elemental)
1773 arg0 = expr->value.function.actual;
1774 esym = expr->value.function.esym;
1776 else if (expr->value.function.isym != NULL
1777 && expr->value.function.isym->elemental)
1779 arg0 = expr->value.function.actual;
1780 isym = expr->value.function.isym;
1785 else if (c && c->ext.actual != NULL)
1787 arg0 = c->ext.actual;
1789 if (c->resolved_sym)
1790 esym = c->resolved_sym;
1792 esym = c->symtree->n.sym;
1795 if (!esym->attr.elemental)
1801 /* The rank of an elemental is the rank of its array argument(s). */
1802 for (arg = arg0; arg; arg = arg->next)
1804 if (arg->expr != NULL && arg->expr->rank > 0)
1806 rank = arg->expr->rank;
1807 if (arg->expr->expr_type == EXPR_VARIABLE
1808 && arg->expr->symtree->n.sym->attr.optional)
1809 set_by_optional = true;
1811 /* Function specific; set the result rank and shape. */
1815 if (!expr->shape && arg->expr->shape)
1817 expr->shape = gfc_get_shape (rank);
1818 for (i = 0; i < rank; i++)
1819 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1826 /* If it is an array, it shall not be supplied as an actual argument
1827 to an elemental procedure unless an array of the same rank is supplied
1828 as an actual argument corresponding to a nonoptional dummy argument of
1829 that elemental procedure(12.4.1.5). */
1830 formal_optional = false;
1832 iformal = isym->formal;
1834 eformal = esym->formal;
1836 for (arg = arg0; arg; arg = arg->next)
1840 if (eformal->sym && eformal->sym->attr.optional)
1841 formal_optional = true;
1842 eformal = eformal->next;
1844 else if (isym && iformal)
1846 if (iformal->optional)
1847 formal_optional = true;
1848 iformal = iformal->next;
1851 formal_optional = true;
1853 if (pedantic && arg->expr != NULL
1854 && arg->expr->expr_type == EXPR_VARIABLE
1855 && arg->expr->symtree->n.sym->attr.optional
1858 && (set_by_optional || arg->expr->rank != rank)
1859 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1861 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1862 "MISSING, it cannot be the actual argument of an "
1863 "ELEMENTAL procedure unless there is a non-optional "
1864 "argument with the same rank (12.4.1.5)",
1865 arg->expr->symtree->n.sym->name, &arg->expr->where);
1870 for (arg = arg0; arg; arg = arg->next)
1872 if (arg->expr == NULL || arg->expr->rank == 0)
1875 /* Being elemental, the last upper bound of an assumed size array
1876 argument must be present. */
1877 if (resolve_assumed_size_actual (arg->expr))
1880 /* Elemental procedure's array actual arguments must conform. */
1883 if (gfc_check_conformance (arg->expr, e,
1884 "elemental procedure") == FAILURE)
1891 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1892 is an array, the intent inout/out variable needs to be also an array. */
1893 if (rank > 0 && esym && expr == NULL)
1894 for (eformal = esym->formal, arg = arg0; arg && eformal;
1895 arg = arg->next, eformal = eformal->next)
1896 if ((eformal->sym->attr.intent == INTENT_OUT
1897 || eformal->sym->attr.intent == INTENT_INOUT)
1898 && arg->expr && arg->expr->rank == 0)
1900 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1901 "ELEMENTAL subroutine '%s' is a scalar, but another "
1902 "actual argument is an array", &arg->expr->where,
1903 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1904 : "INOUT", eformal->sym->name, esym->name);
1911 /* Go through each actual argument in ACTUAL and see if it can be
1912 implemented as an inlined, non-copying intrinsic. FNSYM is the
1913 function being called, or NULL if not known. */
1916 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1918 gfc_actual_arglist *ap;
1921 for (ap = actual; ap; ap = ap->next)
1923 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1924 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual,
1926 ap->expr->inline_noncopying_intrinsic = 1;
1930 /* This function does the checking of references to global procedures
1931 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1932 77 and 95 standards. It checks for a gsymbol for the name, making
1933 one if it does not already exist. If it already exists, then the
1934 reference being resolved must correspond to the type of gsymbol.
1935 Otherwise, the new symbol is equipped with the attributes of the
1936 reference. The corresponding code that is called in creating
1937 global entities is parse.c.
1939 In addition, for all but -std=legacy, the gsymbols are used to
1940 check the interfaces of external procedures from the same file.
1941 The namespace of the gsymbol is resolved and then, once this is
1942 done the interface is checked. */
1946 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
1948 if (!gsym_ns->proc_name->attr.recursive)
1951 if (sym->ns == gsym_ns)
1954 if (sym->ns->parent && sym->ns->parent == gsym_ns)
1961 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
1963 if (gsym_ns->entries)
1965 gfc_entry_list *entry = gsym_ns->entries;
1967 for (; entry; entry = entry->next)
1969 if (strcmp (sym->name, entry->sym->name) == 0)
1971 if (strcmp (gsym_ns->proc_name->name,
1972 sym->ns->proc_name->name) == 0)
1976 && strcmp (gsym_ns->proc_name->name,
1977 sym->ns->parent->proc_name->name) == 0)
1986 resolve_global_procedure (gfc_symbol *sym, locus *where,
1987 gfc_actual_arglist **actual, int sub)
1991 enum gfc_symbol_type type;
1993 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1995 gsym = gfc_get_gsymbol (sym->name);
1997 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1998 gfc_global_used (gsym, where);
2000 if (gfc_option.flag_whole_file
2001 && (sym->attr.if_source == IFSRC_UNKNOWN
2002 || sym->attr.if_source == IFSRC_IFBODY)
2003 && gsym->type != GSYM_UNKNOWN
2005 && gsym->ns->resolved != -1
2006 && gsym->ns->proc_name
2007 && not_in_recursive (sym, gsym->ns)
2008 && not_entry_self_reference (sym, gsym->ns))
2010 gfc_symbol *def_sym;
2012 /* Resolve the gsymbol namespace if needed. */
2013 if (!gsym->ns->resolved)
2015 gfc_dt_list *old_dt_list;
2017 /* Stash away derived types so that the backend_decls do not
2019 old_dt_list = gfc_derived_types;
2020 gfc_derived_types = NULL;
2022 gfc_resolve (gsym->ns);
2024 /* Store the new derived types with the global namespace. */
2025 if (gfc_derived_types)
2026 gsym->ns->derived_types = gfc_derived_types;
2028 /* Restore the derived types of this namespace. */
2029 gfc_derived_types = old_dt_list;
2032 /* Make sure that translation for the gsymbol occurs before
2033 the procedure currently being resolved. */
2034 ns = gfc_global_ns_list;
2035 for (; ns && ns != gsym->ns; ns = ns->sibling)
2037 if (ns->sibling == gsym->ns)
2039 ns->sibling = gsym->ns->sibling;
2040 gsym->ns->sibling = gfc_global_ns_list;
2041 gfc_global_ns_list = gsym->ns;
2046 def_sym = gsym->ns->proc_name;
2047 if (def_sym->attr.entry_master)
2049 gfc_entry_list *entry;
2050 for (entry = gsym->ns->entries; entry; entry = entry->next)
2051 if (strcmp (entry->sym->name, sym->name) == 0)
2053 def_sym = entry->sym;
2058 /* Differences in constant character lengths. */
2059 if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2061 long int l1 = 0, l2 = 0;
2062 gfc_charlen *cl1 = sym->ts.u.cl;
2063 gfc_charlen *cl2 = def_sym->ts.u.cl;
2066 && cl1->length != NULL
2067 && cl1->length->expr_type == EXPR_CONSTANT)
2068 l1 = mpz_get_si (cl1->length->value.integer);
2071 && cl2->length != NULL
2072 && cl2->length->expr_type == EXPR_CONSTANT)
2073 l2 = mpz_get_si (cl2->length->value.integer);
2075 if (l1 && l2 && l1 != l2)
2076 gfc_error ("Character length mismatch in return type of "
2077 "function '%s' at %L (%ld/%ld)", sym->name,
2078 &sym->declared_at, l1, l2);
2081 /* Type mismatch of function return type and expected type. */
2082 if (sym->attr.function
2083 && !gfc_compare_types (&sym->ts, &def_sym->ts))
2084 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2085 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2086 gfc_typename (&def_sym->ts));
2088 if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2090 gfc_formal_arglist *arg = def_sym->formal;
2091 for ( ; arg; arg = arg->next)
2094 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2095 else if (arg->sym->attr.allocatable
2096 || arg->sym->attr.asynchronous
2097 || arg->sym->attr.optional
2098 || arg->sym->attr.pointer
2099 || arg->sym->attr.target
2100 || arg->sym->attr.value
2101 || arg->sym->attr.volatile_)
2103 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2104 "has an attribute that requires an explicit "
2105 "interface for this procedure", arg->sym->name,
2106 sym->name, &sym->declared_at);
2109 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2110 else if (arg->sym && arg->sym->as
2111 && arg->sym->as->type == AS_ASSUMED_SHAPE)
2113 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2114 "argument '%s' must have an explicit interface",
2115 sym->name, &sym->declared_at, arg->sym->name);
2118 /* F2008, 12.4.2.2 (2c) */
2119 else if (arg->sym->attr.codimension)
2121 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2122 "'%s' must have an explicit interface",
2123 sym->name, &sym->declared_at, arg->sym->name);
2126 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2127 else if (false) /* TODO: is a parametrized derived type */
2129 gfc_error ("Procedure '%s' at %L with parametrized derived "
2130 "type argument '%s' must have an explicit "
2131 "interface", sym->name, &sym->declared_at,
2135 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2136 else if (arg->sym->ts.type == BT_CLASS)
2138 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2139 "argument '%s' must have an explicit interface",
2140 sym->name, &sym->declared_at, arg->sym->name);
2145 if (def_sym->attr.function)
2147 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2148 if (def_sym->as && def_sym->as->rank
2149 && (!sym->as || sym->as->rank != def_sym->as->rank))
2150 gfc_error ("The reference to function '%s' at %L either needs an "
2151 "explicit INTERFACE or the rank is incorrect", sym->name,
2154 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2155 if ((def_sym->result->attr.pointer
2156 || def_sym->result->attr.allocatable)
2157 && (sym->attr.if_source != IFSRC_IFBODY
2158 || def_sym->result->attr.pointer
2159 != sym->result->attr.pointer
2160 || def_sym->result->attr.allocatable
2161 != sym->result->attr.allocatable))
2162 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2163 "result must have an explicit interface", sym->name,
2166 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2167 if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2168 && def_sym->ts.u.cl->length != NULL)
2170 gfc_charlen *cl = sym->ts.u.cl;
2172 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2173 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2175 gfc_error ("Nonconstant character-length function '%s' at %L "
2176 "must have an explicit interface", sym->name,
2182 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2183 if (def_sym->attr.elemental && !sym->attr.elemental)
2185 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2186 "interface", sym->name, &sym->declared_at);
2189 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2190 if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2192 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2193 "an explicit interface", sym->name, &sym->declared_at);
2196 if (gfc_option.flag_whole_file == 1
2197 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2198 && !(gfc_option.warn_std & GFC_STD_GNU)))
2199 gfc_errors_to_warnings (1);
2201 if (sym->attr.if_source != IFSRC_IFBODY)
2202 gfc_procedure_use (def_sym, actual, where);
2204 gfc_errors_to_warnings (0);
2207 if (gsym->type == GSYM_UNKNOWN)
2210 gsym->where = *where;
2217 /************* Function resolution *************/
2219 /* Resolve a function call known to be generic.
2220 Section 14.1.2.4.1. */
2223 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2227 if (sym->attr.generic)
2229 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2232 expr->value.function.name = s->name;
2233 expr->value.function.esym = s;
2235 if (s->ts.type != BT_UNKNOWN)
2237 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2238 expr->ts = s->result->ts;
2241 expr->rank = s->as->rank;
2242 else if (s->result != NULL && s->result->as != NULL)
2243 expr->rank = s->result->as->rank;
2245 gfc_set_sym_referenced (expr->value.function.esym);
2250 /* TODO: Need to search for elemental references in generic
2254 if (sym->attr.intrinsic)
2255 return gfc_intrinsic_func_interface (expr, 0);
2262 resolve_generic_f (gfc_expr *expr)
2267 sym = expr->symtree->n.sym;
2271 m = resolve_generic_f0 (expr, sym);
2274 else if (m == MATCH_ERROR)
2278 if (sym->ns->parent == NULL)
2280 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2284 if (!generic_sym (sym))
2288 /* Last ditch attempt. See if the reference is to an intrinsic
2289 that possesses a matching interface. 14.1.2.4 */
2290 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
2292 gfc_error ("There is no specific function for the generic '%s' at %L",
2293 expr->symtree->n.sym->name, &expr->where);
2297 m = gfc_intrinsic_func_interface (expr, 0);
2301 gfc_error ("Generic function '%s' at %L is not consistent with a "
2302 "specific intrinsic interface", expr->symtree->n.sym->name,
2309 /* Resolve a function call known to be specific. */
2312 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2316 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2318 if (sym->attr.dummy)
2320 sym->attr.proc = PROC_DUMMY;
2324 sym->attr.proc = PROC_EXTERNAL;
2328 if (sym->attr.proc == PROC_MODULE
2329 || sym->attr.proc == PROC_ST_FUNCTION
2330 || sym->attr.proc == PROC_INTERNAL)
2333 if (sym->attr.intrinsic)
2335 m = gfc_intrinsic_func_interface (expr, 1);
2339 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2340 "with an intrinsic", sym->name, &expr->where);
2348 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2351 expr->ts = sym->result->ts;
2354 expr->value.function.name = sym->name;
2355 expr->value.function.esym = sym;
2356 if (sym->as != NULL)
2357 expr->rank = sym->as->rank;
2364 resolve_specific_f (gfc_expr *expr)
2369 sym = expr->symtree->n.sym;
2373 m = resolve_specific_f0 (sym, expr);
2376 if (m == MATCH_ERROR)
2379 if (sym->ns->parent == NULL)
2382 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2388 gfc_error ("Unable to resolve the specific function '%s' at %L",
2389 expr->symtree->n.sym->name, &expr->where);
2395 /* Resolve a procedure call not known to be generic nor specific. */
2398 resolve_unknown_f (gfc_expr *expr)
2403 sym = expr->symtree->n.sym;
2405 if (sym->attr.dummy)
2407 sym->attr.proc = PROC_DUMMY;
2408 expr->value.function.name = sym->name;
2412 /* See if we have an intrinsic function reference. */
2414 if (gfc_is_intrinsic (sym, 0, expr->where))
2416 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2421 /* The reference is to an external name. */
2423 sym->attr.proc = PROC_EXTERNAL;
2424 expr->value.function.name = sym->name;
2425 expr->value.function.esym = expr->symtree->n.sym;
2427 if (sym->as != NULL)
2428 expr->rank = sym->as->rank;
2430 /* Type of the expression is either the type of the symbol or the
2431 default type of the symbol. */
2434 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2436 if (sym->ts.type != BT_UNKNOWN)
2440 ts = gfc_get_default_type (sym->name, sym->ns);
2442 if (ts->type == BT_UNKNOWN)
2444 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2445 sym->name, &expr->where);
2456 /* Return true, if the symbol is an external procedure. */
2458 is_external_proc (gfc_symbol *sym)
2460 if (!sym->attr.dummy && !sym->attr.contained
2461 && !(sym->attr.intrinsic
2462 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2463 && sym->attr.proc != PROC_ST_FUNCTION
2464 && !sym->attr.proc_pointer
2465 && !sym->attr.use_assoc
2473 /* Figure out if a function reference is pure or not. Also set the name
2474 of the function for a potential error message. Return nonzero if the
2475 function is PURE, zero if not. */
2477 pure_stmt_function (gfc_expr *, gfc_symbol *);
2480 pure_function (gfc_expr *e, const char **name)
2486 if (e->symtree != NULL
2487 && e->symtree->n.sym != NULL
2488 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2489 return pure_stmt_function (e, e->symtree->n.sym);
2491 if (e->value.function.esym)
2493 pure = gfc_pure (e->value.function.esym);
2494 *name = e->value.function.esym->name;
2496 else if (e->value.function.isym)
2498 pure = e->value.function.isym->pure
2499 || e->value.function.isym->elemental;
2500 *name = e->value.function.isym->name;
2504 /* Implicit functions are not pure. */
2506 *name = e->value.function.name;
2514 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2515 int *f ATTRIBUTE_UNUSED)
2519 /* Don't bother recursing into other statement functions
2520 since they will be checked individually for purity. */
2521 if (e->expr_type != EXPR_FUNCTION
2523 || e->symtree->n.sym == sym
2524 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2527 return pure_function (e, &name) ? false : true;
2532 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2534 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2539 is_scalar_expr_ptr (gfc_expr *expr)
2541 gfc_try retval = SUCCESS;
2546 /* See if we have a gfc_ref, which means we have a substring, array
2547 reference, or a component. */
2548 if (expr->ref != NULL)
2551 while (ref->next != NULL)
2557 if (ref->u.ss.length != NULL
2558 && ref->u.ss.length->length != NULL
2560 && ref->u.ss.start->expr_type == EXPR_CONSTANT
2562 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
2564 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
2565 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
2566 if (end - start + 1 != 1)
2573 if (ref->u.ar.type == AR_ELEMENT)
2575 else if (ref->u.ar.type == AR_FULL)
2577 /* The user can give a full array if the array is of size 1. */
2578 if (ref->u.ar.as != NULL
2579 && ref->u.ar.as->rank == 1
2580 && ref->u.ar.as->type == AS_EXPLICIT
2581 && ref->u.ar.as->lower[0] != NULL
2582 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2583 && ref->u.ar.as->upper[0] != NULL
2584 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2586 /* If we have a character string, we need to check if
2587 its length is one. */
2588 if (expr->ts.type == BT_CHARACTER)
2590 if (expr->ts.u.cl == NULL
2591 || expr->ts.u.cl->length == NULL
2592 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2598 /* We have constant lower and upper bounds. If the
2599 difference between is 1, it can be considered a
2601 start = (int) mpz_get_si
2602 (ref->u.ar.as->lower[0]->value.integer);
2603 end = (int) mpz_get_si
2604 (ref->u.ar.as->upper[0]->value.integer);
2605 if (end - start + 1 != 1)
2620 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2622 /* Character string. Make sure it's of length 1. */
2623 if (expr->ts.u.cl == NULL
2624 || expr->ts.u.cl->length == NULL
2625 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2628 else if (expr->rank != 0)
2635 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2636 and, in the case of c_associated, set the binding label based on
2640 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2641 gfc_symbol **new_sym)
2643 char name[GFC_MAX_SYMBOL_LEN + 1];
2644 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2645 int optional_arg = 0;
2646 gfc_try retval = SUCCESS;
2647 gfc_symbol *args_sym;
2648 gfc_typespec *arg_ts;
2649 symbol_attribute arg_attr;
2651 if (args->expr->expr_type == EXPR_CONSTANT
2652 || args->expr->expr_type == EXPR_OP
2653 || args->expr->expr_type == EXPR_NULL)
2655 gfc_error ("Argument to '%s' at %L is not a variable",
2656 sym->name, &(args->expr->where));
2660 args_sym = args->expr->symtree->n.sym;
2662 /* The typespec for the actual arg should be that stored in the expr
2663 and not necessarily that of the expr symbol (args_sym), because
2664 the actual expression could be a part-ref of the expr symbol. */
2665 arg_ts = &(args->expr->ts);
2666 arg_attr = gfc_expr_attr (args->expr);
2668 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2670 /* If the user gave two args then they are providing something for
2671 the optional arg (the second cptr). Therefore, set the name and
2672 binding label to the c_associated for two cptrs. Otherwise,
2673 set c_associated to expect one cptr. */
2677 sprintf (name, "%s_2", sym->name);
2678 sprintf (binding_label, "%s_2", sym->binding_label);
2684 sprintf (name, "%s_1", sym->name);
2685 sprintf (binding_label, "%s_1", sym->binding_label);
2689 /* Get a new symbol for the version of c_associated that
2691 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2693 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2694 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2696 sprintf (name, "%s", sym->name);
2697 sprintf (binding_label, "%s", sym->binding_label);
2699 /* Error check the call. */
2700 if (args->next != NULL)
2702 gfc_error_now ("More actual than formal arguments in '%s' "
2703 "call at %L", name, &(args->expr->where));
2706 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2708 /* Make sure we have either the target or pointer attribute. */
2709 if (!arg_attr.target && !arg_attr.pointer)
2711 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2712 "a TARGET or an associated pointer",
2714 sym->name, &(args->expr->where));
2718 /* See if we have interoperable type and type param. */
2719 if (verify_c_interop (arg_ts) == SUCCESS
2720 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2722 if (args_sym->attr.target == 1)
2724 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2725 has the target attribute and is interoperable. */
2726 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2727 allocatable variable that has the TARGET attribute and
2728 is not an array of zero size. */
2729 if (args_sym->attr.allocatable == 1)
2731 if (args_sym->attr.dimension != 0
2732 && (args_sym->as && args_sym->as->rank == 0))
2734 gfc_error_now ("Allocatable variable '%s' used as a "
2735 "parameter to '%s' at %L must not be "
2736 "an array of zero size",
2737 args_sym->name, sym->name,
2738 &(args->expr->where));
2744 /* A non-allocatable target variable with C
2745 interoperable type and type parameters must be
2747 if (args_sym && args_sym->attr.dimension)
2749 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2751 gfc_error ("Assumed-shape array '%s' at %L "
2752 "cannot be an argument to the "
2753 "procedure '%s' because "
2754 "it is not C interoperable",
2756 &(args->expr->where), sym->name);
2759 else if (args_sym->as->type == AS_DEFERRED)
2761 gfc_error ("Deferred-shape array '%s' at %L "
2762 "cannot be an argument to the "
2763 "procedure '%s' because "
2764 "it is not C interoperable",
2766 &(args->expr->where), sym->name);
2771 /* Make sure it's not a character string. Arrays of
2772 any type should be ok if the variable is of a C
2773 interoperable type. */
2774 if (arg_ts->type == BT_CHARACTER)
2775 if (arg_ts->u.cl != NULL
2776 && (arg_ts->u.cl->length == NULL
2777 || arg_ts->u.cl->length->expr_type
2780 (arg_ts->u.cl->length->value.integer, 1)
2782 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2784 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2785 "at %L must have a length of 1",
2786 args_sym->name, sym->name,
2787 &(args->expr->where));
2792 else if (arg_attr.pointer
2793 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2795 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2797 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2798 "associated scalar POINTER", args_sym->name,
2799 sym->name, &(args->expr->where));
2805 /* The parameter is not required to be C interoperable. If it
2806 is not C interoperable, it must be a nonpolymorphic scalar
2807 with no length type parameters. It still must have either
2808 the pointer or target attribute, and it can be
2809 allocatable (but must be allocated when c_loc is called). */
2810 if (args->expr->rank != 0
2811 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2813 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2814 "scalar", args_sym->name, sym->name,
2815 &(args->expr->where));
2818 else if (arg_ts->type == BT_CHARACTER
2819 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2821 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2822 "%L must have a length of 1",
2823 args_sym->name, sym->name,
2824 &(args->expr->where));
2827 else if (arg_ts->type == BT_CLASS)
2829 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2830 "polymorphic", args_sym->name, sym->name,
2831 &(args->expr->where));
2836 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2838 if (args_sym->attr.flavor != FL_PROCEDURE)
2840 /* TODO: Update this error message to allow for procedure
2841 pointers once they are implemented. */
2842 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2844 args_sym->name, sym->name,
2845 &(args->expr->where));
2848 else if (args_sym->attr.is_bind_c != 1)
2850 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2852 args_sym->name, sym->name,
2853 &(args->expr->where));
2858 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2863 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2864 "iso_c_binding function: '%s'!\n", sym->name);
2871 /* Resolve a function call, which means resolving the arguments, then figuring
2872 out which entity the name refers to. */
2873 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2874 to INTENT(OUT) or INTENT(INOUT). */
2877 resolve_function (gfc_expr *expr)
2879 gfc_actual_arglist *arg;
2884 procedure_type p = PROC_INTRINSIC;
2885 bool no_formal_args;
2889 sym = expr->symtree->n.sym;
2891 /* If this is a procedure pointer component, it has already been resolved. */
2892 if (gfc_is_proc_ptr_comp (expr, NULL))
2895 if (sym && sym->attr.intrinsic
2896 && resolve_intrinsic (sym, &expr->where) == FAILURE)
2899 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2901 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2905 /* If this ia a deferred TBP with an abstract interface (which may
2906 of course be referenced), expr->value.function.esym will be set. */
2907 if (sym && sym->attr.abstract && !expr->value.function.esym)
2909 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2910 sym->name, &expr->where);
2914 /* Switch off assumed size checking and do this again for certain kinds
2915 of procedure, once the procedure itself is resolved. */
2916 need_full_assumed_size++;
2918 if (expr->symtree && expr->symtree->n.sym)
2919 p = expr->symtree->n.sym->attr.proc;
2921 if (expr->value.function.isym && expr->value.function.isym->inquiry)
2922 inquiry_argument = true;
2923 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2925 if (resolve_actual_arglist (expr->value.function.actual,
2926 p, no_formal_args) == FAILURE)
2928 inquiry_argument = false;
2932 inquiry_argument = false;
2934 /* Need to setup the call to the correct c_associated, depending on
2935 the number of cptrs to user gives to compare. */
2936 if (sym && sym->attr.is_iso_c == 1)
2938 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2942 /* Get the symtree for the new symbol (resolved func).
2943 the old one will be freed later, when it's no longer used. */
2944 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2947 /* Resume assumed_size checking. */
2948 need_full_assumed_size--;
2950 /* If the procedure is external, check for usage. */
2951 if (sym && is_external_proc (sym))
2952 resolve_global_procedure (sym, &expr->where,
2953 &expr->value.function.actual, 0);
2955 if (sym && sym->ts.type == BT_CHARACTER
2957 && sym->ts.u.cl->length == NULL
2959 && expr->value.function.esym == NULL
2960 && !sym->attr.contained)
2962 /* Internal procedures are taken care of in resolve_contained_fntype. */
2963 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2964 "be used at %L since it is not a dummy argument",
2965 sym->name, &expr->where);
2969 /* See if function is already resolved. */
2971 if (expr->value.function.name != NULL)
2973 if (expr->ts.type == BT_UNKNOWN)
2979 /* Apply the rules of section 14.1.2. */
2981 switch (procedure_kind (sym))
2984 t = resolve_generic_f (expr);
2987 case PTYPE_SPECIFIC:
2988 t = resolve_specific_f (expr);
2992 t = resolve_unknown_f (expr);
2996 gfc_internal_error ("resolve_function(): bad function type");
3000 /* If the expression is still a function (it might have simplified),
3001 then we check to see if we are calling an elemental function. */
3003 if (expr->expr_type != EXPR_FUNCTION)
3006 temp = need_full_assumed_size;
3007 need_full_assumed_size = 0;
3009 if (resolve_elemental_actual (expr, NULL) == FAILURE)
3012 if (omp_workshare_flag
3013 && expr->value.function.esym
3014 && ! gfc_elemental (expr->value.function.esym))
3016 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3017 "in WORKSHARE construct", expr->value.function.esym->name,
3022 #define GENERIC_ID expr->value.function.isym->id
3023 else if (expr->value.function.actual != NULL
3024 && expr->value.function.isym != NULL
3025 && GENERIC_ID != GFC_ISYM_LBOUND
3026 && GENERIC_ID != GFC_ISYM_LEN
3027 && GENERIC_ID != GFC_ISYM_LOC
3028 && GENERIC_ID != GFC_ISYM_PRESENT)
3030 /* Array intrinsics must also have the last upper bound of an
3031 assumed size array argument. UBOUND and SIZE have to be
3032 excluded from the check if the second argument is anything
3035 for (arg = expr->value.function.actual; arg; arg = arg->next)
3037 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3038 && arg->next != NULL && arg->next->expr)
3040 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3043 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3046 if ((int)mpz_get_si (arg->next->expr->value.integer)
3051 if (arg->expr != NULL
3052 && arg->expr->rank > 0
3053 && resolve_assumed_size_actual (arg->expr))
3059 need_full_assumed_size = temp;
3062 if (!pure_function (expr, &name) && name)
3066 gfc_error ("reference to non-PURE function '%s' at %L inside a "
3067 "FORALL %s", name, &expr->where,
3068 forall_flag == 2 ? "mask" : "block");
3071 else if (gfc_pure (NULL))
3073 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3074 "procedure within a PURE procedure", name, &expr->where);
3079 /* Functions without the RECURSIVE attribution are not allowed to
3080 * call themselves. */
3081 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3084 esym = expr->value.function.esym;
3086 if (is_illegal_recursion (esym, gfc_current_ns))
3088 if (esym->attr.entry && esym->ns->entries)
3089 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3090 " function '%s' is not RECURSIVE",
3091 esym->name, &expr->where, esym->ns->entries->sym->name);
3093 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3094 " is not RECURSIVE", esym->name, &expr->where);
3100 /* Character lengths of use associated functions may contains references to
3101 symbols not referenced from the current program unit otherwise. Make sure
3102 those symbols are marked as referenced. */
3104 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3105 && expr->value.function.esym->attr.use_assoc)
3107 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3111 && !((expr->value.function.esym
3112 && expr->value.function.esym->attr.elemental)
3114 (expr->value.function.isym
3115 && expr->value.function.isym->elemental)))
3116 find_noncopying_intrinsics (expr->value.function.esym,
3117 expr->value.function.actual);
3119 /* Make sure that the expression has a typespec that works. */
3120 if (expr->ts.type == BT_UNKNOWN)
3122 if (expr->symtree->n.sym->result
3123 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3124 && !expr->symtree->n.sym->result->attr.proc_pointer)
3125 expr->ts = expr->symtree->n.sym->result->ts;
3132 /************* Subroutine resolution *************/
3135 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3141 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3142 sym->name, &c->loc);
3143 else if (gfc_pure (NULL))
3144 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3150 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3154 if (sym->attr.generic)
3156 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3159 c->resolved_sym = s;
3160 pure_subroutine (c, s);
3164 /* TODO: Need to search for elemental references in generic interface. */
3167 if (sym->attr.intrinsic)
3168 return gfc_intrinsic_sub_interface (c, 0);
3175 resolve_generic_s (gfc_code *c)
3180 sym = c->symtree->n.sym;
3184 m = resolve_generic_s0 (c, sym);
3187 else if (m == MATCH_ERROR)
3191 if (sym->ns->parent == NULL)
3193 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3197 if (!generic_sym (sym))
3201 /* Last ditch attempt. See if the reference is to an intrinsic
3202 that possesses a matching interface. 14.1.2.4 */
3203 sym = c->symtree->n.sym;
3205 if (!gfc_is_intrinsic (sym, 1, c->loc))
3207 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3208 sym->name, &c->loc);
3212 m = gfc_intrinsic_sub_interface (c, 0);
3216 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3217 "intrinsic subroutine interface", sym->name, &c->loc);
3223 /* Set the name and binding label of the subroutine symbol in the call
3224 expression represented by 'c' to include the type and kind of the
3225 second parameter. This function is for resolving the appropriate
3226 version of c_f_pointer() and c_f_procpointer(). For example, a
3227 call to c_f_pointer() for a default integer pointer could have a
3228 name of c_f_pointer_i4. If no second arg exists, which is an error
3229 for these two functions, it defaults to the generic symbol's name
3230 and binding label. */
3233 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3234 char *name, char *binding_label)
3236 gfc_expr *arg = NULL;
3240 /* The second arg of c_f_pointer and c_f_procpointer determines
3241 the type and kind for the procedure name. */
3242 arg = c->ext.actual->next->expr;
3246 /* Set up the name to have the given symbol's name,
3247 plus the type and kind. */
3248 /* a derived type is marked with the type letter 'u' */
3249 if (arg->ts.type == BT_DERIVED)
3252 kind = 0; /* set the kind as 0 for now */
3256 type = gfc_type_letter (arg->ts.type);
3257 kind = arg->ts.kind;
3260 if (arg->ts.type == BT_CHARACTER)
3261 /* Kind info for character strings not needed. */
3264 sprintf (name, "%s_%c%d", sym->name, type, kind);
3265 /* Set up the binding label as the given symbol's label plus
3266 the type and kind. */
3267 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
3271 /* If the second arg is missing, set the name and label as
3272 was, cause it should at least be found, and the missing
3273 arg error will be caught by compare_parameters(). */
3274 sprintf (name, "%s", sym->name);
3275 sprintf (binding_label, "%s", sym->binding_label);
3282 /* Resolve a generic version of the iso_c_binding procedure given
3283 (sym) to the specific one based on the type and kind of the
3284 argument(s). Currently, this function resolves c_f_pointer() and
3285 c_f_procpointer based on the type and kind of the second argument
3286 (FPTR). Other iso_c_binding procedures aren't specially handled.
3287 Upon successfully exiting, c->resolved_sym will hold the resolved
3288 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3292 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3294 gfc_symbol *new_sym;
3295 /* this is fine, since we know the names won't use the max */
3296 char name[GFC_MAX_SYMBOL_LEN + 1];
3297 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
3298 /* default to success; will override if find error */
3299 match m = MATCH_YES;
3301 /* Make sure the actual arguments are in the necessary order (based on the
3302 formal args) before resolving. */
3303 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3305 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3306 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3308 set_name_and_label (c, sym, name, binding_label);
3310 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3312 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3314 /* Make sure we got a third arg if the second arg has non-zero
3315 rank. We must also check that the type and rank are
3316 correct since we short-circuit this check in
3317 gfc_procedure_use() (called above to sort actual args). */
3318 if (c->ext.actual->next->expr->rank != 0)
3320 if(c->ext.actual->next->next == NULL
3321 || c->ext.actual->next->next->expr == NULL)
3324 gfc_error ("Missing SHAPE parameter for call to %s "
3325 "at %L", sym->name, &(c->loc));
3327 else if (c->ext.actual->next->next->expr->ts.type
3329 || c->ext.actual->next->next->expr->rank != 1)
3332 gfc_error ("SHAPE parameter for call to %s at %L must "
3333 "be a rank 1 INTEGER array", sym->name,
3340 if (m != MATCH_ERROR)
3342 /* the 1 means to add the optional arg to formal list */
3343 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3345 /* for error reporting, say it's declared where the original was */
3346 new_sym->declared_at = sym->declared_at;
3351 /* no differences for c_loc or c_funloc */
3355 /* set the resolved symbol */
3356 if (m != MATCH_ERROR)
3357 c->resolved_sym = new_sym;
3359 c->resolved_sym = sym;
3365 /* Resolve a subroutine call known to be specific. */
3368 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3372 if(sym->attr.is_iso_c)
3374 m = gfc_iso_c_sub_interface (c,sym);
3378 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3380 if (sym->attr.dummy)
3382 sym->attr.proc = PROC_DUMMY;
3386 sym->attr.proc = PROC_EXTERNAL;
3390 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3393 if (sym->attr.intrinsic)
3395 m = gfc_intrinsic_sub_interface (c, 1);
3399 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3400 "with an intrinsic", sym->name, &c->loc);
3408 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3410 c->resolved_sym = sym;
3411 pure_subroutine (c, sym);
3418 resolve_specific_s (gfc_code *c)
3423 sym = c->symtree->n.sym;
3427 m = resolve_specific_s0 (c, sym);
3430 if (m == MATCH_ERROR)
3433 if (sym->ns->parent == NULL)
3436 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3442 sym = c->symtree->n.sym;
3443 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3444 sym->name, &c->loc);
3450 /* Resolve a subroutine call not known to be generic nor specific. */
3453 resolve_unknown_s (gfc_code *c)
3457 sym = c->symtree->n.sym;
3459 if (sym->attr.dummy)
3461 sym->attr.proc = PROC_DUMMY;
3465 /* See if we have an intrinsic function reference. */
3467 if (gfc_is_intrinsic (sym, 1, c->loc))
3469 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3474 /* The reference is to an external name. */
3477 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3479 c->resolved_sym = sym;
3481 pure_subroutine (c, sym);
3487 /* Resolve a subroutine call. Although it was tempting to use the same code
3488 for functions, subroutines and functions are stored differently and this
3489 makes things awkward. */
3492 resolve_call (gfc_code *c)
3495 procedure_type ptype = PROC_INTRINSIC;
3496 gfc_symbol *csym, *sym;
3497 bool no_formal_args;
3499 csym = c->symtree ? c->symtree->n.sym : NULL;
3501 if (csym && csym->ts.type != BT_UNKNOWN)
3503 gfc_error ("'%s' at %L has a type, which is not consistent with "
3504 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3508 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3511 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3512 sym = st ? st->n.sym : NULL;
3513 if (sym && csym != sym
3514 && sym->ns == gfc_current_ns
3515 && sym->attr.flavor == FL_PROCEDURE
3516 && sym->attr.contained)
3519 if (csym->attr.generic)
3520 c->symtree->n.sym = sym;
3523 csym = c->symtree->n.sym;
3527 /* If this ia a deferred TBP with an abstract interface
3528 (which may of course be referenced), c->expr1 will be set. */
3529 if (csym && csym->attr.abstract && !c->expr1)
3531 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3532 csym->name, &c->loc);
3536 /* Subroutines without the RECURSIVE attribution are not allowed to
3537 * call themselves. */
3538 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3540 if (csym->attr.entry && csym->ns->entries)
3541 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3542 " subroutine '%s' is not RECURSIVE",
3543 csym->name, &c->loc, csym->ns->entries->sym->name);
3545 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3546 " is not RECURSIVE", csym->name, &c->loc);
3551 /* Switch off assumed size checking and do this again for certain kinds
3552 of procedure, once the procedure itself is resolved. */
3553 need_full_assumed_size++;
3556 ptype = csym->attr.proc;
3558 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3559 if (resolve_actual_arglist (c->ext.actual, ptype,
3560 no_formal_args) == FAILURE)
3563 /* Resume assumed_size checking. */
3564 need_full_assumed_size--;
3566 /* If external, check for usage. */
3567 if (csym && is_external_proc (csym))
3568 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3571 if (c->resolved_sym == NULL)
3573 c->resolved_isym = NULL;
3574 switch (procedure_kind (csym))
3577 t = resolve_generic_s (c);
3580 case PTYPE_SPECIFIC:
3581 t = resolve_specific_s (c);
3585 t = resolve_unknown_s (c);
3589 gfc_internal_error ("resolve_subroutine(): bad function type");
3593 /* Some checks of elemental subroutine actual arguments. */
3594 if (resolve_elemental_actual (NULL, c) == FAILURE)
3597 if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental))
3598 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
3603 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3604 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3605 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3606 if their shapes do not match. If either op1->shape or op2->shape is
3607 NULL, return SUCCESS. */
3610 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3617 if (op1->shape != NULL && op2->shape != NULL)
3619 for (i = 0; i < op1->rank; i++)
3621 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3623 gfc_error ("Shapes for operands at %L and %L are not conformable",
3624 &op1->where, &op2->where);
3635 /* Resolve an operator expression node. This can involve replacing the
3636 operation with a user defined function call. */
3639 resolve_operator (gfc_expr *e)
3641 gfc_expr *op1, *op2;
3643 bool dual_locus_error;
3646 /* Resolve all subnodes-- give them types. */
3648 switch (e->value.op.op)
3651 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3654 /* Fall through... */
3657 case INTRINSIC_UPLUS:
3658 case INTRINSIC_UMINUS:
3659 case INTRINSIC_PARENTHESES:
3660 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3665 /* Typecheck the new node. */
3667 op1 = e->value.op.op1;
3668 op2 = e->value.op.op2;
3669 dual_locus_error = false;
3671 if ((op1 && op1->expr_type == EXPR_NULL)
3672 || (op2 && op2->expr_type == EXPR_NULL))
3674 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3678 switch (e->value.op.op)
3680 case INTRINSIC_UPLUS:
3681 case INTRINSIC_UMINUS:
3682 if (op1->ts.type == BT_INTEGER
3683 || op1->ts.type == BT_REAL
3684 || op1->ts.type == BT_COMPLEX)
3690 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3691 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3694 case INTRINSIC_PLUS:
3695 case INTRINSIC_MINUS:
3696 case INTRINSIC_TIMES:
3697 case INTRINSIC_DIVIDE:
3698 case INTRINSIC_POWER:
3699 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3701 gfc_type_convert_binary (e, 1);
3706 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3707 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3708 gfc_typename (&op2->ts));
3711 case INTRINSIC_CONCAT:
3712 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3713 && op1->ts.kind == op2->ts.kind)
3715 e->ts.type = BT_CHARACTER;
3716 e->ts.kind = op1->ts.kind;
3721 _("Operands of string concatenation operator at %%L are %s/%s"),
3722 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3728 case INTRINSIC_NEQV:
3729 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3731 e->ts.type = BT_LOGICAL;
3732 e->ts.kind = gfc_kind_max (op1, op2);
3733 if (op1->ts.kind < e->ts.kind)
3734 gfc_convert_type (op1, &e->ts, 2);
3735 else if (op2->ts.kind < e->ts.kind)
3736 gfc_convert_type (op2, &e->ts, 2);
3740 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3741 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3742 gfc_typename (&op2->ts));
3747 if (op1->ts.type == BT_LOGICAL)
3749 e->ts.type = BT_LOGICAL;
3750 e->ts.kind = op1->ts.kind;
3754 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3755 gfc_typename (&op1->ts));
3759 case INTRINSIC_GT_OS:
3761 case INTRINSIC_GE_OS:
3763 case INTRINSIC_LT_OS:
3765 case INTRINSIC_LE_OS:
3766 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3768 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3772 /* Fall through... */
3775 case INTRINSIC_EQ_OS:
3777 case INTRINSIC_NE_OS:
3778 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3779 && op1->ts.kind == op2->ts.kind)
3781 e->ts.type = BT_LOGICAL;
3782 e->ts.kind = gfc_default_logical_kind;
3786 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3788 gfc_type_convert_binary (e, 1);
3790 e->ts.type = BT_LOGICAL;
3791 e->ts.kind = gfc_default_logical_kind;
3795 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3797 _("Logicals at %%L must be compared with %s instead of %s"),
3798 (e->value.op.op == INTRINSIC_EQ
3799 || e->value.op.op == INTRINSIC_EQ_OS)
3800 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3803 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3804 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3805 gfc_typename (&op2->ts));
3809 case INTRINSIC_USER:
3810 if (e->value.op.uop->op == NULL)
3811 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3812 else if (op2 == NULL)
3813 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3814 e->value.op.uop->name, gfc_typename (&op1->ts));
3816 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3817 e->value.op.uop->name, gfc_typename (&op1->ts),
3818 gfc_typename (&op2->ts));
3822 case INTRINSIC_PARENTHESES:
3824 if (e->ts.type == BT_CHARACTER)
3825 e->ts.u.cl = op1->ts.u.cl;
3829 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3832 /* Deal with arrayness of an operand through an operator. */
3836 switch (e->value.op.op)
3838 case INTRINSIC_PLUS:
3839 case INTRINSIC_MINUS:
3840 case INTRINSIC_TIMES:
3841 case INTRINSIC_DIVIDE:
3842 case INTRINSIC_POWER:
3843 case INTRINSIC_CONCAT:
3847 case INTRINSIC_NEQV:
3849 case INTRINSIC_EQ_OS:
3851 case INTRINSIC_NE_OS:
3853 case INTRINSIC_GT_OS:
3855 case INTRINSIC_GE_OS:
3857 case INTRINSIC_LT_OS:
3859 case INTRINSIC_LE_OS:
3861 if (op1->rank == 0 && op2->rank == 0)
3864 if (op1->rank == 0 && op2->rank != 0)
3866 e->rank = op2->rank;
3868 if (e->shape == NULL)
3869 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3872 if (op1->rank != 0 && op2->rank == 0)
3874 e->rank = op1->rank;
3876 if (e->shape == NULL)
3877 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3880 if (op1->rank != 0 && op2->rank != 0)
3882 if (op1->rank == op2->rank)
3884 e->rank = op1->rank;
3885 if (e->shape == NULL)
3887 t = compare_shapes (op1, op2);
3891 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3896 /* Allow higher level expressions to work. */
3899 /* Try user-defined operators, and otherwise throw an error. */
3900 dual_locus_error = true;
3902 _("Inconsistent ranks for operator at %%L and %%L"));
3909 case INTRINSIC_PARENTHESES:
3911 case INTRINSIC_UPLUS:
3912 case INTRINSIC_UMINUS:
3913 /* Simply copy arrayness attribute */
3914 e->rank = op1->rank;
3916 if (e->shape == NULL)
3917 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3925 /* Attempt to simplify the expression. */
3928 t = gfc_simplify_expr (e, 0);
3929 /* Some calls do not succeed in simplification and return FAILURE
3930 even though there is no error; e.g. variable references to
3931 PARAMETER arrays. */
3932 if (!gfc_is_constant_expr (e))
3941 if (gfc_extend_expr (e, &real_error) == SUCCESS)
3948 if (dual_locus_error)
3949 gfc_error (msg, &op1->where, &op2->where);
3951 gfc_error (msg, &e->where);
3957 /************** Array resolution subroutines **************/
3960 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3963 /* Compare two integer expressions. */
3966 compare_bound (gfc_expr *a, gfc_expr *b)
3970 if (a == NULL || a->expr_type != EXPR_CONSTANT
3971 || b == NULL || b->expr_type != EXPR_CONSTANT)
3974 /* If either of the types isn't INTEGER, we must have
3975 raised an error earlier. */
3977 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3980 i = mpz_cmp (a->value.integer, b->value.integer);
3990 /* Compare an integer expression with an integer. */
3993 compare_bound_int (gfc_expr *a, int b)
3997 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4000 if (a->ts.type != BT_INTEGER)
4001 gfc_internal_error ("compare_bound_int(): Bad expression");
4003 i = mpz_cmp_si (a->value.integer, b);
4013 /* Compare an integer expression with a mpz_t. */
4016 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4020 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4023 if (a->ts.type != BT_INTEGER)
4024 gfc_internal_error ("compare_bound_int(): Bad expression");
4026 i = mpz_cmp (a->value.integer, b);
4036 /* Compute the last value of a sequence given by a triplet.
4037 Return 0 if it wasn't able to compute the last value, or if the
4038 sequence if empty, and 1 otherwise. */
4041 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4042 gfc_expr *stride, mpz_t last)
4046 if (start == NULL || start->expr_type != EXPR_CONSTANT
4047 || end == NULL || end->expr_type != EXPR_CONSTANT
4048 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4051 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4052 || (stride != NULL && stride->ts.type != BT_INTEGER))
4055 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
4057 if (compare_bound (start, end) == CMP_GT)
4059 mpz_set (last, end->value.integer);
4063 if (compare_bound_int (stride, 0) == CMP_GT)
4065 /* Stride is positive */
4066 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4071 /* Stride is negative */
4072 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4077 mpz_sub (rem, end->value.integer, start->value.integer);
4078 mpz_tdiv_r (rem, rem, stride->value.integer);
4079 mpz_sub (last, end->value.integer, rem);
4086 /* Compare a single dimension of an array reference to the array
4090 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4094 if (ar->dimen_type[i] == DIMEN_STAR)
4096 gcc_assert (ar->stride[i] == NULL);
4097 /* This implies [*] as [*:] and [*:3] are not possible. */
4098 if (ar->start[i] == NULL)
4100 gcc_assert (ar->end[i] == NULL);
4105 /* Given start, end and stride values, calculate the minimum and
4106 maximum referenced indexes. */
4108 switch (ar->dimen_type[i])
4115 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4118 gfc_warning ("Array reference at %L is out of bounds "
4119 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4120 mpz_get_si (ar->start[i]->value.integer),
4121 mpz_get_si (as->lower[i]->value.integer), i+1);
4123 gfc_warning ("Array reference at %L is out of bounds "
4124 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4125 mpz_get_si (ar->start[i]->value.integer),
4126 mpz_get_si (as->lower[i]->value.integer),
4130 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4133 gfc_warning ("Array reference at %L is out of bounds "
4134 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4135 mpz_get_si (ar->start[i]->value.integer),
4136 mpz_get_si (as->upper[i]->value.integer), i+1);
4138 gfc_warning ("Array reference at %L is out of bounds "
4139 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4140 mpz_get_si (ar->start[i]->value.integer),
4141 mpz_get_si (as->upper[i]->value.integer),
4150 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4151 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4153 comparison comp_start_end = compare_bound (AR_START, AR_END);
4155 /* Check for zero stride, which is not allowed. */
4156 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4158 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4162 /* if start == len || (stride > 0 && start < len)
4163 || (stride < 0 && start > len),
4164 then the array section contains at least one element. In this
4165 case, there is an out-of-bounds access if
4166 (start < lower || start > upper). */
4167 if (compare_bound (AR_START, AR_END) == CMP_EQ
4168 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4169 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4170 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4171 && comp_start_end == CMP_GT))
4173 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4175 gfc_warning ("Lower array reference at %L is out of bounds "
4176 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4177 mpz_get_si (AR_START->value.integer),
4178 mpz_get_si (as->lower[i]->value.integer), i+1);
4181 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4183 gfc_warning ("Lower array reference at %L is out of bounds "
4184 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4185 mpz_get_si (AR_START->value.integer),
4186 mpz_get_si (as->upper[i]->value.integer), i+1);
4191 /* If we can compute the highest index of the array section,
4192 then it also has to be between lower and upper. */
4193 mpz_init (last_value);
4194 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4197 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4199 gfc_warning ("Upper array reference at %L is out of bounds "
4200 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4201 mpz_get_si (last_value),
4202 mpz_get_si (as->lower[i]->value.integer), i+1);
4203 mpz_clear (last_value);
4206 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4208 gfc_warning ("Upper array reference at %L is out of bounds "
4209 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4210 mpz_get_si (last_value),
4211 mpz_get_si (as->upper[i]->value.integer), i+1);
4212 mpz_clear (last_value);
4216 mpz_clear (last_value);
4224 gfc_internal_error ("check_dimension(): Bad array reference");
4231 /* Compare an array reference with an array specification. */
4234 compare_spec_to_ref (gfc_array_ref *ar)
4241 /* TODO: Full array sections are only allowed as actual parameters. */
4242 if (as->type == AS_ASSUMED_SIZE
4243 && (/*ar->type == AR_FULL
4244 ||*/ (ar->type == AR_SECTION
4245 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4247 gfc_error ("Rightmost upper bound of assumed size array section "
4248 "not specified at %L", &ar->where);
4252 if (ar->type == AR_FULL)
4255 if (as->rank != ar->dimen)
4257 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4258 &ar->where, ar->dimen, as->rank);
4262 /* ar->codimen == 0 is a local array. */
4263 if (as->corank != ar->codimen && ar->codimen != 0)
4265 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4266 &ar->where, ar->codimen, as->corank);
4270 for (i = 0; i < as->rank; i++)
4271 if (check_dimension (i, ar, as) == FAILURE)
4274 /* Local access has no coarray spec. */
4275 if (ar->codimen != 0)
4276 for (i = as->rank; i < as->rank + as->corank; i++)
4278 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
4280 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4281 i + 1 - as->rank, &ar->where);
4284 if (check_dimension (i, ar, as) == FAILURE)
4292 /* Resolve one part of an array index. */
4295 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4296 int force_index_integer_kind)
4303 if (gfc_resolve_expr (index) == FAILURE)
4306 if (check_scalar && index->rank != 0)
4308 gfc_error ("Array index at %L must be scalar", &index->where);
4312 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4314 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4315 &index->where, gfc_basic_typename (index->ts.type));
4319 if (index->ts.type == BT_REAL)
4320 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
4321 &index->where) == FAILURE)
4324 if ((index->ts.kind != gfc_index_integer_kind
4325 && force_index_integer_kind)
4326 || index->ts.type != BT_INTEGER)
4329 ts.type = BT_INTEGER;
4330 ts.kind = gfc_index_integer_kind;
4332 gfc_convert_type_warn (index, &ts, 2, 0);
4338 /* Resolve one part of an array index. */
4341 gfc_resolve_index (gfc_expr *index, int check_scalar)
4343 return gfc_resolve_index_1 (index, check_scalar, 1);
4346 /* Resolve a dim argument to an intrinsic function. */
4349 gfc_resolve_dim_arg (gfc_expr *dim)
4354 if (gfc_resolve_expr (dim) == FAILURE)
4359 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4364 if (dim->ts.type != BT_INTEGER)
4366 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4370 if (dim->ts.kind != gfc_index_integer_kind)
4375 ts.type = BT_INTEGER;
4376 ts.kind = gfc_index_integer_kind;
4378 gfc_convert_type_warn (dim, &ts, 2, 0);
4384 /* Given an expression that contains array references, update those array
4385 references to point to the right array specifications. While this is
4386 filled in during matching, this information is difficult to save and load
4387 in a module, so we take care of it here.
4389 The idea here is that the original array reference comes from the
4390 base symbol. We traverse the list of reference structures, setting
4391 the stored reference to references. Component references can
4392 provide an additional array specification. */
4395 find_array_spec (gfc_expr *e)
4399 gfc_symbol *derived;
4402 if (e->symtree->n.sym->ts.type == BT_CLASS)
4403 as = CLASS_DATA (e->symtree->n.sym)->as;
4405 as = e->symtree->n.sym->as;
4408 for (ref = e->ref; ref; ref = ref->next)
4413 gfc_internal_error ("find_array_spec(): Missing spec");
4420 if (derived == NULL)
4421 derived = e->symtree->n.sym->ts.u.derived;
4423 if (derived->attr.is_class)
4424 derived = derived->components->ts.u.derived;
4426 c = derived->components;
4428 for (; c; c = c->next)
4429 if (c == ref->u.c.component)
4431 /* Track the sequence of component references. */
4432 if (c->ts.type == BT_DERIVED)
4433 derived = c->ts.u.derived;
4438 gfc_internal_error ("find_array_spec(): Component not found");
4440 if (c->attr.dimension)
4443 gfc_internal_error ("find_array_spec(): unused as(1)");
4454 gfc_internal_error ("find_array_spec(): unused as(2)");
4458 /* Resolve an array reference. */
4461 resolve_array_ref (gfc_array_ref *ar)
4463 int i, check_scalar;
4466 for (i = 0; i < ar->dimen + ar->codimen; i++)
4468 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4470 /* Do not force gfc_index_integer_kind for the start. We can
4471 do fine with any integer kind. This avoids temporary arrays
4472 created for indexing with a vector. */
4473 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4475 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4477 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4482 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4486 ar->dimen_type[i] = DIMEN_ELEMENT;
4490 ar->dimen_type[i] = DIMEN_VECTOR;
4491 if (e->expr_type == EXPR_VARIABLE
4492 && e->symtree->n.sym->ts.type == BT_DERIVED)
4493 ar->start[i] = gfc_get_parentheses (e);
4497 gfc_error ("Array index at %L is an array of rank %d",
4498 &ar->c_where[i], e->rank);
4502 /* Fill in the upper bound, which may be lower than the
4503 specified one for something like a(2:10:5), which is
4504 identical to a(2:7:5). Only relevant for strides not equal
4506 if (ar->dimen_type[i] == DIMEN_RANGE
4507 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4508 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0)
4512 if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4514 if (ar->end[i] == NULL)
4517 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4519 mpz_set (ar->end[i]->value.integer, end);
4521 else if (ar->end[i]->ts.type == BT_INTEGER
4522 && ar->end[i]->expr_type == EXPR_CONSTANT)
4524 mpz_set (ar->end[i]->value.integer, end);
4535 if (ar->type == AR_FULL && ar->as->rank == 0)
4536 ar->type = AR_ELEMENT;
4538 /* If the reference type is unknown, figure out what kind it is. */
4540 if (ar->type == AR_UNKNOWN)
4542 ar->type = AR_ELEMENT;
4543 for (i = 0; i < ar->dimen; i++)
4544 if (ar->dimen_type[i] == DIMEN_RANGE
4545 || ar->dimen_type[i] == DIMEN_VECTOR)
4547 ar->type = AR_SECTION;
4552 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4560 resolve_substring (gfc_ref *ref)
4562 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4564 if (ref->u.ss.start != NULL)
4566 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4569 if (ref->u.ss.start->ts.type != BT_INTEGER)
4571 gfc_error ("Substring start index at %L must be of type INTEGER",
4572 &ref->u.ss.start->where);
4576 if (ref->u.ss.start->rank != 0)
4578 gfc_error ("Substring start index at %L must be scalar",
4579 &ref->u.ss.start->where);
4583 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4584 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4585 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4587 gfc_error ("Substring start index at %L is less than one",
4588 &ref->u.ss.start->where);
4593 if (ref->u.ss.end != NULL)
4595 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4598 if (ref->u.ss.end->ts.type != BT_INTEGER)
4600 gfc_error ("Substring end index at %L must be of type INTEGER",
4601 &ref->u.ss.end->where);
4605 if (ref->u.ss.end->rank != 0)
4607 gfc_error ("Substring end index at %L must be scalar",
4608 &ref->u.ss.end->where);
4612 if (ref->u.ss.length != NULL
4613 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4614 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4615 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4617 gfc_error ("Substring end index at %L exceeds the string length",
4618 &ref->u.ss.start->where);
4622 if (compare_bound_mpz_t (ref->u.ss.end,
4623 gfc_integer_kinds[k].huge) == CMP_GT
4624 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4625 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4627 gfc_error ("Substring end index at %L is too large",
4628 &ref->u.ss.end->where);
4637 /* This function supplies missing substring charlens. */
4640 gfc_resolve_substring_charlen (gfc_expr *e)
4643 gfc_expr *start, *end;
4645 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4646 if (char_ref->type == REF_SUBSTRING)
4652 gcc_assert (char_ref->next == NULL);
4656 if (e->ts.u.cl->length)
4657 gfc_free_expr (e->ts.u.cl->length);
4658 else if (e->expr_type == EXPR_VARIABLE
4659 && e->symtree->n.sym->attr.dummy)
4663 e->ts.type = BT_CHARACTER;
4664 e->ts.kind = gfc_default_character_kind;
4667 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4669 if (char_ref->u.ss.start)
4670 start = gfc_copy_expr (char_ref->u.ss.start);
4672 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4674 if (char_ref->u.ss.end)
4675 end = gfc_copy_expr (char_ref->u.ss.end);
4676 else if (e->expr_type == EXPR_VARIABLE)
4677 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4684 /* Length = (end - start +1). */
4685 e->ts.u.cl->length = gfc_subtract (end, start);
4686 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4687 gfc_get_int_expr (gfc_default_integer_kind,
4690 e->ts.u.cl->length->ts.type = BT_INTEGER;
4691 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4693 /* Make sure that the length is simplified. */
4694 gfc_simplify_expr (e->ts.u.cl->length, 1);
4695 gfc_resolve_expr (e->ts.u.cl->length);
4699 /* Resolve subtype references. */
4702 resolve_ref (gfc_expr *expr)
4704 int current_part_dimension, n_components, seen_part_dimension;
4707 for (ref = expr->ref; ref; ref = ref->next)
4708 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4710 find_array_spec (expr);
4714 for (ref = expr->ref; ref; ref = ref->next)
4718 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4726 resolve_substring (ref);
4730 /* Check constraints on part references. */
4732 current_part_dimension = 0;
4733 seen_part_dimension = 0;
4736 for (ref = expr->ref; ref; ref = ref->next)
4741 switch (ref->u.ar.type)
4744 /* Coarray scalar. */
4745 if (ref->u.ar.as->rank == 0)
4747 current_part_dimension = 0;
4752 current_part_dimension = 1;
4756 current_part_dimension = 0;
4760 gfc_internal_error ("resolve_ref(): Bad array reference");
4766 if (current_part_dimension || seen_part_dimension)
4769 if (ref->u.c.component->attr.pointer
4770 || ref->u.c.component->attr.proc_pointer)
4772 gfc_error ("Component to the right of a part reference "
4773 "with nonzero rank must not have the POINTER "
4774 "attribute at %L", &expr->where);
4777 else if (ref->u.c.component->attr.allocatable)
4779 gfc_error ("Component to the right of a part reference "
4780 "with nonzero rank must not have the ALLOCATABLE "
4781 "attribute at %L", &expr->where);
4793 if (((ref->type == REF_COMPONENT && n_components > 1)
4794 || ref->next == NULL)
4795 && current_part_dimension
4796 && seen_part_dimension)
4798 gfc_error ("Two or more part references with nonzero rank must "
4799 "not be specified at %L", &expr->where);
4803 if (ref->type == REF_COMPONENT)
4805 if (current_part_dimension)
4806 seen_part_dimension = 1;
4808 /* reset to make sure */
4809 current_part_dimension = 0;
4817 /* Given an expression, determine its shape. This is easier than it sounds.
4818 Leaves the shape array NULL if it is not possible to determine the shape. */
4821 expression_shape (gfc_expr *e)
4823 mpz_t array[GFC_MAX_DIMENSIONS];
4826 if (e->rank == 0 || e->shape != NULL)
4829 for (i = 0; i < e->rank; i++)
4830 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4833 e->shape = gfc_get_shape (e->rank);
4835 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4840 for (i--; i >= 0; i--)
4841 mpz_clear (array[i]);
4845 /* Given a variable expression node, compute the rank of the expression by
4846 examining the base symbol and any reference structures it may have. */
4849 expression_rank (gfc_expr *e)
4854 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4855 could lead to serious confusion... */
4856 gcc_assert (e->expr_type != EXPR_COMPCALL);
4860 if (e->expr_type == EXPR_ARRAY)
4862 /* Constructors can have a rank different from one via RESHAPE(). */
4864 if (e->symtree == NULL)
4870 e->rank = (e->symtree->n.sym->as == NULL)
4871 ? 0 : e->symtree->n.sym->as->rank;
4877 for (ref = e->ref; ref; ref = ref->next)
4879 if (ref->type != REF_ARRAY)
4882 if (ref->u.ar.type == AR_FULL)
4884 rank = ref->u.ar.as->rank;
4888 if (ref->u.ar.type == AR_SECTION)
4890 /* Figure out the rank of the section. */
4892 gfc_internal_error ("expression_rank(): Two array specs");
4894 for (i = 0; i < ref->u.ar.dimen; i++)
4895 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4896 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4906 expression_shape (e);
4910 /* Resolve a variable expression. */
4913 resolve_variable (gfc_expr *e)
4920 if (e->symtree == NULL)
4922 sym = e->symtree->n.sym;
4924 /* If this is an associate-name, it may be parsed with an array reference
4925 in error even though the target is scalar. Fail directly in this case. */
4926 if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
4929 /* On the other hand, the parser may not have known this is an array;
4930 in this case, we have to add a FULL reference. */
4931 if (sym->assoc && sym->attr.dimension && !e->ref)
4933 e->ref = gfc_get_ref ();
4934 e->ref->type = REF_ARRAY;
4935 e->ref->u.ar.type = AR_FULL;
4936 e->ref->u.ar.dimen = 0;
4939 if (e->ref && resolve_ref (e) == FAILURE)
4942 if (sym->attr.flavor == FL_PROCEDURE
4943 && (!sym->attr.function
4944 || (sym->attr.function && sym->result
4945 && sym->result->attr.proc_pointer
4946 && !sym->result->attr.function)))
4948 e->ts.type = BT_PROCEDURE;
4949 goto resolve_procedure;
4952 if (sym->ts.type != BT_UNKNOWN)
4953 gfc_variable_attr (e, &e->ts);
4956 /* Must be a simple variable reference. */
4957 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4962 if (check_assumed_size_reference (sym, e))
4965 /* Deal with forward references to entries during resolve_code, to
4966 satisfy, at least partially, 12.5.2.5. */
4967 if (gfc_current_ns->entries
4968 && current_entry_id == sym->entry_id
4971 && cs_base->current->op != EXEC_ENTRY)
4973 gfc_entry_list *entry;
4974 gfc_formal_arglist *formal;
4978 /* If the symbol is a dummy... */
4979 if (sym->attr.dummy && sym->ns == gfc_current_ns)
4981 entry = gfc_current_ns->entries;
4984 /* ...test if the symbol is a parameter of previous entries. */
4985 for (; entry && entry->id <= current_entry_id; entry = entry->next)
4986 for (formal = entry->sym->formal; formal; formal = formal->next)
4988 if (formal->sym && sym->name == formal->sym->name)
4992 /* If it has not been seen as a dummy, this is an error. */
4995 if (specification_expr)
4996 gfc_error ("Variable '%s', used in a specification expression"
4997 ", is referenced at %L before the ENTRY statement "
4998 "in which it is a parameter",
4999 sym->name, &cs_base->current->loc);
5001 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5002 "statement in which it is a parameter",
5003 sym->name, &cs_base->current->loc);
5008 /* Now do the same check on the specification expressions. */
5009 specification_expr = 1;
5010 if (sym->ts.type == BT_CHARACTER
5011 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
5015 for (n = 0; n < sym->as->rank; n++)
5017 specification_expr = 1;
5018 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
5020 specification_expr = 1;
5021 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
5024 specification_expr = 0;
5027 /* Update the symbol's entry level. */
5028 sym->entry_id = current_entry_id + 1;
5031 /* If a symbol has been host_associated mark it. This is used latter,
5032 to identify if aliasing is possible via host association. */
5033 if (sym->attr.flavor == FL_VARIABLE
5034 && gfc_current_ns->parent
5035 && (gfc_current_ns->parent == sym->ns
5036 || (gfc_current_ns->parent->parent
5037 && gfc_current_ns->parent->parent == sym->ns)))
5038 sym->attr.host_assoc = 1;
5041 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
5044 /* F2008, C617 and C1229. */
5045 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5046 && gfc_is_coindexed (e))
5048 gfc_ref *ref, *ref2 = NULL;
5050 if (e->ts.type == BT_CLASS)
5052 gfc_error ("Polymorphic subobject of coindexed object at %L",
5057 for (ref = e->ref; ref; ref = ref->next)
5059 if (ref->type == REF_COMPONENT)
5061 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5065 for ( ; ref; ref = ref->next)
5066 if (ref->type == REF_COMPONENT)
5069 /* Expression itself is coindexed object. */
5073 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5074 for ( ; c; c = c->next)
5075 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5077 gfc_error ("Coindexed object with polymorphic allocatable "
5078 "subcomponent at %L", &e->where);
5089 /* Checks to see that the correct symbol has been host associated.
5090 The only situation where this arises is that in which a twice
5091 contained function is parsed after the host association is made.
5092 Therefore, on detecting this, change the symbol in the expression
5093 and convert the array reference into an actual arglist if the old
5094 symbol is a variable. */
5096 check_host_association (gfc_expr *e)
5098 gfc_symbol *sym, *old_sym;
5102 gfc_actual_arglist *arg, *tail = NULL;
5103 bool retval = e->expr_type == EXPR_FUNCTION;
5105 /* If the expression is the result of substitution in
5106 interface.c(gfc_extend_expr) because there is no way in
5107 which the host association can be wrong. */
5108 if (e->symtree == NULL
5109 || e->symtree->n.sym == NULL
5110 || e->user_operator)
5113 old_sym = e->symtree->n.sym;
5115 if (gfc_current_ns->parent
5116 && old_sym->ns != gfc_current_ns)
5118 /* Use the 'USE' name so that renamed module symbols are
5119 correctly handled. */
5120 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5122 if (sym && old_sym != sym
5123 && sym->ts.type == old_sym->ts.type
5124 && sym->attr.flavor == FL_PROCEDURE
5125 && sym->attr.contained)
5127 /* Clear the shape, since it might not be valid. */
5128 if (e->shape != NULL)
5130 for (n = 0; n < e->rank; n++)
5131 mpz_clear (e->shape[n]);
5133 gfc_free (e->shape);
5136 /* Give the expression the right symtree! */
5137 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5138 gcc_assert (st != NULL);
5140 if (old_sym->attr.flavor == FL_PROCEDURE
5141 || e->expr_type == EXPR_FUNCTION)
5143 /* Original was function so point to the new symbol, since
5144 the actual argument list is already attached to the
5146 e->value.function.esym = NULL;
5151 /* Original was variable so convert array references into
5152 an actual arglist. This does not need any checking now
5153 since gfc_resolve_function will take care of it. */
5154 e->value.function.actual = NULL;
5155 e->expr_type = EXPR_FUNCTION;
5158 /* Ambiguity will not arise if the array reference is not
5159 the last reference. */
5160 for (ref = e->ref; ref; ref = ref->next)
5161 if (ref->type == REF_ARRAY && ref->next == NULL)
5164 gcc_assert (ref->type == REF_ARRAY);
5166 /* Grab the start expressions from the array ref and
5167 copy them into actual arguments. */
5168 for (n = 0; n < ref->u.ar.dimen; n++)
5170 arg = gfc_get_actual_arglist ();
5171 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5172 if (e->value.function.actual == NULL)
5173 tail = e->value.function.actual = arg;
5181 /* Dump the reference list and set the rank. */
5182 gfc_free_ref_list (e->ref);
5184 e->rank = sym->as ? sym->as->rank : 0;
5187 gfc_resolve_expr (e);
5191 /* This might have changed! */
5192 return e->expr_type == EXPR_FUNCTION;
5197 gfc_resolve_character_operator (gfc_expr *e)
5199 gfc_expr *op1 = e->value.op.op1;
5200 gfc_expr *op2 = e->value.op.op2;
5201 gfc_expr *e1 = NULL;
5202 gfc_expr *e2 = NULL;
5204 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5206 if (op1->ts.u.cl && op1->ts.u.cl->length)
5207 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5208 else if (op1->expr_type == EXPR_CONSTANT)
5209 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5210 op1->value.character.length);
5212 if (op2->ts.u.cl && op2->ts.u.cl->length)
5213 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5214 else if (op2->expr_type == EXPR_CONSTANT)
5215 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5216 op2->value.character.length);
5218 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5223 e->ts.u.cl->length = gfc_add (e1, e2);
5224 e->ts.u.cl->length->ts.type = BT_INTEGER;
5225 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5226 gfc_simplify_expr (e->ts.u.cl->length, 0);
5227 gfc_resolve_expr (e->ts.u.cl->length);
5233 /* Ensure that an character expression has a charlen and, if possible, a
5234 length expression. */
5237 fixup_charlen (gfc_expr *e)
5239 /* The cases fall through so that changes in expression type and the need
5240 for multiple fixes are picked up. In all circumstances, a charlen should
5241 be available for the middle end to hang a backend_decl on. */
5242 switch (e->expr_type)
5245 gfc_resolve_character_operator (e);
5248 if (e->expr_type == EXPR_ARRAY)
5249 gfc_resolve_character_array_constructor (e);
5251 case EXPR_SUBSTRING:
5252 if (!e->ts.u.cl && e->ref)
5253 gfc_resolve_substring_charlen (e);
5257 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5264 /* Update an actual argument to include the passed-object for type-bound
5265 procedures at the right position. */
5267 static gfc_actual_arglist*
5268 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5271 gcc_assert (argpos > 0);
5275 gfc_actual_arglist* result;
5277 result = gfc_get_actual_arglist ();
5281 result->name = name;
5287 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5289 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5294 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5297 extract_compcall_passed_object (gfc_expr* e)
5301 gcc_assert (e->expr_type == EXPR_COMPCALL);
5303 if (e->value.compcall.base_object)
5304 po = gfc_copy_expr (e->value.compcall.base_object);
5307 po = gfc_get_expr ();
5308 po->expr_type = EXPR_VARIABLE;
5309 po->symtree = e->symtree;
5310 po->ref = gfc_copy_ref (e->ref);
5311 po->where = e->where;
5314 if (gfc_resolve_expr (po) == FAILURE)
5321 /* Update the arglist of an EXPR_COMPCALL expression to include the
5325 update_compcall_arglist (gfc_expr* e)
5328 gfc_typebound_proc* tbp;
5330 tbp = e->value.compcall.tbp;
5335 po = extract_compcall_passed_object (e);
5339 if (tbp->nopass || e->value.compcall.ignore_pass)
5345 gcc_assert (tbp->pass_arg_num > 0);
5346 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5354 /* Extract the passed object from a PPC call (a copy of it). */
5357 extract_ppc_passed_object (gfc_expr *e)
5362 po = gfc_get_expr ();
5363 po->expr_type = EXPR_VARIABLE;
5364 po->symtree = e->symtree;
5365 po->ref = gfc_copy_ref (e->ref);
5366 po->where = e->where;
5368 /* Remove PPC reference. */
5370 while ((*ref)->next)
5371 ref = &(*ref)->next;
5372 gfc_free_ref_list (*ref);
5375 if (gfc_resolve_expr (po) == FAILURE)
5382 /* Update the actual arglist of a procedure pointer component to include the
5386 update_ppc_arglist (gfc_expr* e)
5390 gfc_typebound_proc* tb;
5392 if (!gfc_is_proc_ptr_comp (e, &ppc))
5399 else if (tb->nopass)
5402 po = extract_ppc_passed_object (e);
5408 gfc_error ("Passed-object at %L must be scalar", &e->where);
5412 gcc_assert (tb->pass_arg_num > 0);
5413 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5421 /* Check that the object a TBP is called on is valid, i.e. it must not be
5422 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5425 check_typebound_baseobject (gfc_expr* e)
5429 base = extract_compcall_passed_object (e);
5433 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5435 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5437 gfc_error ("Base object for type-bound procedure call at %L is of"
5438 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5442 /* If the procedure called is NOPASS, the base object must be scalar. */
5443 if (e->value.compcall.tbp->nopass && base->rank > 0)
5445 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5446 " be scalar", &e->where);
5450 /* FIXME: Remove once PR 41177 (this problem) is fixed completely. */
5453 gfc_error ("Non-scalar base object at %L currently not implemented",
5462 /* Resolve a call to a type-bound procedure, either function or subroutine,
5463 statically from the data in an EXPR_COMPCALL expression. The adapted
5464 arglist and the target-procedure symtree are returned. */
5467 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5468 gfc_actual_arglist** actual)
5470 gcc_assert (e->expr_type == EXPR_COMPCALL);
5471 gcc_assert (!e->value.compcall.tbp->is_generic);
5473 /* Update the actual arglist for PASS. */
5474 if (update_compcall_arglist (e) == FAILURE)
5477 *actual = e->value.compcall.actual;
5478 *target = e->value.compcall.tbp->u.specific;
5480 gfc_free_ref_list (e->ref);
5482 e->value.compcall.actual = NULL;
5488 /* Get the ultimate declared type from an expression. In addition,
5489 return the last class/derived type reference and the copy of the
5492 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5495 gfc_symbol *declared;
5502 *new_ref = gfc_copy_ref (e->ref);
5504 for (ref = e->ref; ref; ref = ref->next)
5506 if (ref->type != REF_COMPONENT)
5509 if (ref->u.c.component->ts.type == BT_CLASS
5510 || ref->u.c.component->ts.type == BT_DERIVED)
5512 declared = ref->u.c.component->ts.u.derived;
5518 if (declared == NULL)
5519 declared = e->symtree->n.sym->ts.u.derived;
5525 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5526 which of the specific bindings (if any) matches the arglist and transform
5527 the expression into a call of that binding. */
5530 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5532 gfc_typebound_proc* genproc;
5533 const char* genname;
5535 gfc_symbol *derived;
5537 gcc_assert (e->expr_type == EXPR_COMPCALL);
5538 genname = e->value.compcall.name;
5539 genproc = e->value.compcall.tbp;
5541 if (!genproc->is_generic)
5544 /* Try the bindings on this type and in the inheritance hierarchy. */
5545 for (; genproc; genproc = genproc->overridden)
5549 gcc_assert (genproc->is_generic);
5550 for (g = genproc->u.generic; g; g = g->next)
5553 gfc_actual_arglist* args;
5556 gcc_assert (g->specific);
5558 if (g->specific->error)
5561 target = g->specific->u.specific->n.sym;
5563 /* Get the right arglist by handling PASS/NOPASS. */
5564 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5565 if (!g->specific->nopass)
5568 po = extract_compcall_passed_object (e);
5572 gcc_assert (g->specific->pass_arg_num > 0);
5573 gcc_assert (!g->specific->error);
5574 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5575 g->specific->pass_arg);
5577 resolve_actual_arglist (args, target->attr.proc,
5578 is_external_proc (target) && !target->formal);
5580 /* Check if this arglist matches the formal. */
5581 matches = gfc_arglist_matches_symbol (&args, target);
5583 /* Clean up and break out of the loop if we've found it. */
5584 gfc_free_actual_arglist (args);
5587 e->value.compcall.tbp = g->specific;
5588 genname = g->specific_st->name;
5589 /* Pass along the name for CLASS methods, where the vtab
5590 procedure pointer component has to be referenced. */
5598 /* Nothing matching found! */
5599 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5600 " '%s' at %L", genname, &e->where);
5604 /* Make sure that we have the right specific instance for the name. */
5605 derived = get_declared_from_expr (NULL, NULL, e);
5607 st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where);
5609 e->value.compcall.tbp = st->n.tb;
5615 /* Resolve a call to a type-bound subroutine. */
5618 resolve_typebound_call (gfc_code* c, const char **name)
5620 gfc_actual_arglist* newactual;
5621 gfc_symtree* target;
5623 /* Check that's really a SUBROUTINE. */
5624 if (!c->expr1->value.compcall.tbp->subroutine)
5626 gfc_error ("'%s' at %L should be a SUBROUTINE",
5627 c->expr1->value.compcall.name, &c->loc);
5631 if (check_typebound_baseobject (c->expr1) == FAILURE)
5634 /* Pass along the name for CLASS methods, where the vtab
5635 procedure pointer component has to be referenced. */
5637 *name = c->expr1->value.compcall.name;
5639 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5642 /* Transform into an ordinary EXEC_CALL for now. */
5644 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5647 c->ext.actual = newactual;
5648 c->symtree = target;
5649 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5651 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5653 gfc_free_expr (c->expr1);
5654 c->expr1 = gfc_get_expr ();
5655 c->expr1->expr_type = EXPR_FUNCTION;
5656 c->expr1->symtree = target;
5657 c->expr1->where = c->loc;
5659 return resolve_call (c);
5663 /* Resolve a component-call expression. */
5665 resolve_compcall (gfc_expr* e, const char **name)
5667 gfc_actual_arglist* newactual;
5668 gfc_symtree* target;
5670 /* Check that's really a FUNCTION. */
5671 if (!e->value.compcall.tbp->function)
5673 gfc_error ("'%s' at %L should be a FUNCTION",
5674 e->value.compcall.name, &e->where);
5678 /* These must not be assign-calls! */
5679 gcc_assert (!e->value.compcall.assign);
5681 if (check_typebound_baseobject (e) == FAILURE)
5684 /* Pass along the name for CLASS methods, where the vtab
5685 procedure pointer component has to be referenced. */
5687 *name = e->value.compcall.name;
5689 if (resolve_typebound_generic_call (e, name) == FAILURE)
5691 gcc_assert (!e->value.compcall.tbp->is_generic);
5693 /* Take the rank from the function's symbol. */
5694 if (e->value.compcall.tbp->u.specific->n.sym->as)
5695 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5697 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5698 arglist to the TBP's binding target. */
5700 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5703 e->value.function.actual = newactual;
5704 e->value.function.name = NULL;
5705 e->value.function.esym = target->n.sym;
5706 e->value.function.isym = NULL;
5707 e->symtree = target;
5708 e->ts = target->n.sym->ts;
5709 e->expr_type = EXPR_FUNCTION;
5711 /* Resolution is not necessary if this is a class subroutine; this
5712 function only has to identify the specific proc. Resolution of
5713 the call will be done next in resolve_typebound_call. */
5714 return gfc_resolve_expr (e);
5719 /* Resolve a typebound function, or 'method'. First separate all
5720 the non-CLASS references by calling resolve_compcall directly. */
5723 resolve_typebound_function (gfc_expr* e)
5725 gfc_symbol *declared;
5736 /* Deal with typebound operators for CLASS objects. */
5737 expr = e->value.compcall.base_object;
5738 if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
5739 && e->value.compcall.name)
5741 /* Since the typebound operators are generic, we have to ensure
5742 that any delays in resolution are corrected and that the vtab
5744 ts = expr->symtree->n.sym->ts;
5745 declared = ts.u.derived;
5746 c = gfc_find_component (declared, "$vptr", true, true);
5747 if (c->ts.u.derived == NULL)
5748 c->ts.u.derived = gfc_find_derived_vtab (declared);
5750 if (resolve_compcall (e, &name) == FAILURE)
5753 /* Use the generic name if it is there. */
5754 name = name ? name : e->value.function.esym->name;
5755 e->symtree = expr->symtree;
5756 expr->symtree->n.sym->ts.u.derived = declared;
5757 gfc_add_component_ref (e, "$vptr");
5758 gfc_add_component_ref (e, name);
5759 e->value.function.esym = NULL;
5764 return resolve_compcall (e, NULL);
5766 if (resolve_ref (e) == FAILURE)
5769 /* Get the CLASS declared type. */
5770 declared = get_declared_from_expr (&class_ref, &new_ref, e);
5772 /* Weed out cases of the ultimate component being a derived type. */
5773 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5774 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5776 gfc_free_ref_list (new_ref);
5777 return resolve_compcall (e, NULL);
5780 c = gfc_find_component (declared, "$data", true, true);
5781 declared = c->ts.u.derived;
5783 /* Treat the call as if it is a typebound procedure, in order to roll
5784 out the correct name for the specific function. */
5785 if (resolve_compcall (e, &name) == FAILURE)
5789 /* Then convert the expression to a procedure pointer component call. */
5790 e->value.function.esym = NULL;
5796 /* '$vptr' points to the vtab, which contains the procedure pointers. */
5797 gfc_add_component_ref (e, "$vptr");
5798 gfc_add_component_ref (e, name);
5800 /* Recover the typespec for the expression. This is really only
5801 necessary for generic procedures, where the additional call
5802 to gfc_add_component_ref seems to throw the collection of the
5803 correct typespec. */
5808 /* Resolve a typebound subroutine, or 'method'. First separate all
5809 the non-CLASS references by calling resolve_typebound_call
5813 resolve_typebound_subroutine (gfc_code *code)
5815 gfc_symbol *declared;
5824 st = code->expr1->symtree;
5826 /* Deal with typebound operators for CLASS objects. */
5827 expr = code->expr1->value.compcall.base_object;
5828 if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
5829 && code->expr1->value.compcall.name)
5831 /* Since the typebound operators are generic, we have to ensure
5832 that any delays in resolution are corrected and that the vtab
5834 ts = expr->symtree->n.sym->ts;
5835 declared = ts.u.derived;
5836 c = gfc_find_component (declared, "$vptr", true, true);
5837 if (c->ts.u.derived == NULL)
5838 c->ts.u.derived = gfc_find_derived_vtab (declared);
5840 if (resolve_typebound_call (code, &name) == FAILURE)
5843 /* Use the generic name if it is there. */
5844 name = name ? name : code->expr1->value.function.esym->name;
5845 code->expr1->symtree = expr->symtree;
5846 expr->symtree->n.sym->ts.u.derived = declared;
5847 gfc_add_component_ref (code->expr1, "$vptr");
5848 gfc_add_component_ref (code->expr1, name);
5849 code->expr1->value.function.esym = NULL;
5854 return resolve_typebound_call (code, NULL);
5856 if (resolve_ref (code->expr1) == FAILURE)
5859 /* Get the CLASS declared type. */
5860 get_declared_from_expr (&class_ref, &new_ref, code->expr1);
5862 /* Weed out cases of the ultimate component being a derived type. */
5863 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5864 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5866 gfc_free_ref_list (new_ref);
5867 return resolve_typebound_call (code, NULL);
5870 if (resolve_typebound_call (code, &name) == FAILURE)
5872 ts = code->expr1->ts;
5874 /* Then convert the expression to a procedure pointer component call. */
5875 code->expr1->value.function.esym = NULL;
5876 code->expr1->symtree = st;
5879 code->expr1->ref = new_ref;
5881 /* '$vptr' points to the vtab, which contains the procedure pointers. */
5882 gfc_add_component_ref (code->expr1, "$vptr");
5883 gfc_add_component_ref (code->expr1, name);
5885 /* Recover the typespec for the expression. This is really only
5886 necessary for generic procedures, where the additional call
5887 to gfc_add_component_ref seems to throw the collection of the
5888 correct typespec. */
5889 code->expr1->ts = ts;
5894 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5897 resolve_ppc_call (gfc_code* c)
5899 gfc_component *comp;
5902 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
5905 c->resolved_sym = c->expr1->symtree->n.sym;
5906 c->expr1->expr_type = EXPR_VARIABLE;
5908 if (!comp->attr.subroutine)
5909 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
5911 if (resolve_ref (c->expr1) == FAILURE)
5914 if (update_ppc_arglist (c->expr1) == FAILURE)
5917 c->ext.actual = c->expr1->value.compcall.actual;
5919 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
5920 comp->formal == NULL) == FAILURE)
5923 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
5929 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5932 resolve_expr_ppc (gfc_expr* e)
5934 gfc_component *comp;
5937 b = gfc_is_proc_ptr_comp (e, &comp);
5940 /* Convert to EXPR_FUNCTION. */
5941 e->expr_type = EXPR_FUNCTION;
5942 e->value.function.isym = NULL;
5943 e->value.function.actual = e->value.compcall.actual;
5945 if (comp->as != NULL)
5946 e->rank = comp->as->rank;
5948 if (!comp->attr.function)
5949 gfc_add_function (&comp->attr, comp->name, &e->where);
5951 if (resolve_ref (e) == FAILURE)
5954 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
5955 comp->formal == NULL) == FAILURE)
5958 if (update_ppc_arglist (e) == FAILURE)
5961 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
5968 gfc_is_expandable_expr (gfc_expr *e)
5970 gfc_constructor *con;
5972 if (e->expr_type == EXPR_ARRAY)
5974 /* Traverse the constructor looking for variables that are flavor
5975 parameter. Parameters must be expanded since they are fully used at
5977 con = gfc_constructor_first (e->value.constructor);
5978 for (; con; con = gfc_constructor_next (con))
5980 if (con->expr->expr_type == EXPR_VARIABLE
5981 && con->expr->symtree
5982 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
5983 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
5985 if (con->expr->expr_type == EXPR_ARRAY
5986 && gfc_is_expandable_expr (con->expr))
5994 /* Resolve an expression. That is, make sure that types of operands agree
5995 with their operators, intrinsic operators are converted to function calls
5996 for overloaded types and unresolved function references are resolved. */
5999 gfc_resolve_expr (gfc_expr *e)
6007 /* inquiry_argument only applies to variables. */
6008 inquiry_save = inquiry_argument;
6009 if (e->expr_type != EXPR_VARIABLE)
6010 inquiry_argument = false;
6012 switch (e->expr_type)
6015 t = resolve_operator (e);
6021 if (check_host_association (e))
6022 t = resolve_function (e);
6025 t = resolve_variable (e);
6027 expression_rank (e);
6030 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6031 && e->ref->type != REF_SUBSTRING)
6032 gfc_resolve_substring_charlen (e);
6037 t = resolve_typebound_function (e);
6040 case EXPR_SUBSTRING:
6041 t = resolve_ref (e);
6050 t = resolve_expr_ppc (e);
6055 if (resolve_ref (e) == FAILURE)
6058 t = gfc_resolve_array_constructor (e);
6059 /* Also try to expand a constructor. */
6062 expression_rank (e);
6063 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6064 gfc_expand_constructor (e, false);
6067 /* This provides the opportunity for the length of constructors with
6068 character valued function elements to propagate the string length
6069 to the expression. */
6070 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6072 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6073 here rather then add a duplicate test for it above. */
6074 gfc_expand_constructor (e, false);
6075 t = gfc_resolve_character_array_constructor (e);
6080 case EXPR_STRUCTURE:
6081 t = resolve_ref (e);
6085 t = resolve_structure_cons (e, 0);
6089 t = gfc_simplify_expr (e, 0);
6093 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6096 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6099 inquiry_argument = inquiry_save;
6105 /* Resolve an expression from an iterator. They must be scalar and have
6106 INTEGER or (optionally) REAL type. */
6109 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6110 const char *name_msgid)
6112 if (gfc_resolve_expr (expr) == FAILURE)
6115 if (expr->rank != 0)
6117 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6121 if (expr->ts.type != BT_INTEGER)
6123 if (expr->ts.type == BT_REAL)
6126 return gfc_notify_std (GFC_STD_F95_DEL,
6127 "Deleted feature: %s at %L must be integer",
6128 _(name_msgid), &expr->where);
6131 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6138 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6146 /* Resolve the expressions in an iterator structure. If REAL_OK is
6147 false allow only INTEGER type iterators, otherwise allow REAL types. */
6150 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6152 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6156 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
6158 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
6163 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6164 "Start expression in DO loop") == FAILURE)
6167 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6168 "End expression in DO loop") == FAILURE)
6171 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6172 "Step expression in DO loop") == FAILURE)
6175 if (iter->step->expr_type == EXPR_CONSTANT)
6177 if ((iter->step->ts.type == BT_INTEGER
6178 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6179 || (iter->step->ts.type == BT_REAL
6180 && mpfr_sgn (iter->step->value.real) == 0))
6182 gfc_error ("Step expression in DO loop at %L cannot be zero",
6183 &iter->step->where);
6188 /* Convert start, end, and step to the same type as var. */
6189 if (iter->start->ts.kind != iter->var->ts.kind
6190 || iter->start->ts.type != iter->var->ts.type)
6191 gfc_convert_type (iter->start, &iter->var->ts, 2);
6193 if (iter->end->ts.kind != iter->var->ts.kind
6194 || iter->end->ts.type != iter->var->ts.type)
6195 gfc_convert_type (iter->end, &iter->var->ts, 2);
6197 if (iter->step->ts.kind != iter->var->ts.kind
6198 || iter->step->ts.type != iter->var->ts.type)
6199 gfc_convert_type (iter->step, &iter->var->ts, 2);
6201 if (iter->start->expr_type == EXPR_CONSTANT
6202 && iter->end->expr_type == EXPR_CONSTANT
6203 && iter->step->expr_type == EXPR_CONSTANT)
6206 if (iter->start->ts.type == BT_INTEGER)
6208 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6209 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6213 sgn = mpfr_sgn (iter->step->value.real);
6214 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6216 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6217 gfc_warning ("DO loop at %L will be executed zero times",
6218 &iter->step->where);
6225 /* Traversal function for find_forall_index. f == 2 signals that
6226 that variable itself is not to be checked - only the references. */
6229 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6231 if (expr->expr_type != EXPR_VARIABLE)
6234 /* A scalar assignment */
6235 if (!expr->ref || *f == 1)
6237 if (expr->symtree->n.sym == sym)
6249 /* Check whether the FORALL index appears in the expression or not.
6250 Returns SUCCESS if SYM is found in EXPR. */
6253 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6255 if (gfc_traverse_expr (expr, sym, forall_index, f))
6262 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6263 to be a scalar INTEGER variable. The subscripts and stride are scalar
6264 INTEGERs, and if stride is a constant it must be nonzero.
6265 Furthermore "A subscript or stride in a forall-triplet-spec shall
6266 not contain a reference to any index-name in the
6267 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6270 resolve_forall_iterators (gfc_forall_iterator *it)
6272 gfc_forall_iterator *iter, *iter2;
6274 for (iter = it; iter; iter = iter->next)
6276 if (gfc_resolve_expr (iter->var) == SUCCESS
6277 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6278 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6281 if (gfc_resolve_expr (iter->start) == SUCCESS
6282 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6283 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6284 &iter->start->where);
6285 if (iter->var->ts.kind != iter->start->ts.kind)
6286 gfc_convert_type (iter->start, &iter->var->ts, 2);
6288 if (gfc_resolve_expr (iter->end) == SUCCESS
6289 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6290 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6292 if (iter->var->ts.kind != iter->end->ts.kind)
6293 gfc_convert_type (iter->end, &iter->var->ts, 2);
6295 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6297 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6298 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6299 &iter->stride->where, "INTEGER");
6301 if (iter->stride->expr_type == EXPR_CONSTANT
6302 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6303 gfc_error ("FORALL stride expression at %L cannot be zero",
6304 &iter->stride->where);
6306 if (iter->var->ts.kind != iter->stride->ts.kind)
6307 gfc_convert_type (iter->stride, &iter->var->ts, 2);
6310 for (iter = it; iter; iter = iter->next)
6311 for (iter2 = iter; iter2; iter2 = iter2->next)
6313 if (find_forall_index (iter2->start,
6314 iter->var->symtree->n.sym, 0) == SUCCESS
6315 || find_forall_index (iter2->end,
6316 iter->var->symtree->n.sym, 0) == SUCCESS
6317 || find_forall_index (iter2->stride,
6318 iter->var->symtree->n.sym, 0) == SUCCESS)
6319 gfc_error ("FORALL index '%s' may not appear in triplet "
6320 "specification at %L", iter->var->symtree->name,
6321 &iter2->start->where);
6326 /* Given a pointer to a symbol that is a derived type, see if it's
6327 inaccessible, i.e. if it's defined in another module and the components are
6328 PRIVATE. The search is recursive if necessary. Returns zero if no
6329 inaccessible components are found, nonzero otherwise. */
6332 derived_inaccessible (gfc_symbol *sym)
6336 if (sym->attr.use_assoc && sym->attr.private_comp)
6339 for (c = sym->components; c; c = c->next)
6341 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6349 /* Resolve the argument of a deallocate expression. The expression must be
6350 a pointer or a full array. */
6353 resolve_deallocate_expr (gfc_expr *e)
6355 symbol_attribute attr;
6356 int allocatable, pointer, check_intent_in;
6361 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
6362 check_intent_in = 1;
6364 if (gfc_resolve_expr (e) == FAILURE)
6367 if (e->expr_type != EXPR_VARIABLE)
6370 sym = e->symtree->n.sym;
6372 if (sym->ts.type == BT_CLASS)
6374 allocatable = CLASS_DATA (sym)->attr.allocatable;
6375 pointer = CLASS_DATA (sym)->attr.class_pointer;
6379 allocatable = sym->attr.allocatable;
6380 pointer = sym->attr.pointer;
6382 for (ref = e->ref; ref; ref = ref->next)
6385 check_intent_in = 0;
6390 if (ref->u.ar.type != AR_FULL)
6395 c = ref->u.c.component;
6396 if (c->ts.type == BT_CLASS)
6398 allocatable = CLASS_DATA (c)->attr.allocatable;
6399 pointer = CLASS_DATA (c)->attr.class_pointer;
6403 allocatable = c->attr.allocatable;
6404 pointer = c->attr.pointer;
6414 attr = gfc_expr_attr (e);
6416 if (allocatable == 0 && attr.pointer == 0)
6419 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6424 if (check_intent_in && sym->attr.intent == INTENT_IN)
6426 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
6427 sym->name, &e->where);
6431 if (e->ts.type == BT_CLASS)
6433 /* Only deallocate the DATA component. */
6434 gfc_add_component_ref (e, "$data");
6441 /* Returns true if the expression e contains a reference to the symbol sym. */
6443 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6445 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6452 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6454 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6458 /* Given the expression node e for an allocatable/pointer of derived type to be
6459 allocated, get the expression node to be initialized afterwards (needed for
6460 derived types with default initializers, and derived types with allocatable
6461 components that need nullification.) */
6464 gfc_expr_to_initialize (gfc_expr *e)
6470 result = gfc_copy_expr (e);
6472 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6473 for (ref = result->ref; ref; ref = ref->next)
6474 if (ref->type == REF_ARRAY && ref->next == NULL)
6476 ref->u.ar.type = AR_FULL;
6478 for (i = 0; i < ref->u.ar.dimen; i++)
6479 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6481 result->rank = ref->u.ar.dimen;
6489 /* Used in resolve_allocate_expr to check that a allocation-object and
6490 a source-expr are conformable. This does not catch all possible
6491 cases; in particular a runtime checking is needed. */
6494 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6497 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6499 /* First compare rank. */
6500 if (tail && e1->rank != tail->u.ar.as->rank)
6502 gfc_error ("Source-expr at %L must be scalar or have the "
6503 "same rank as the allocate-object at %L",
6504 &e1->where, &e2->where);
6515 for (i = 0; i < e1->rank; i++)
6517 if (tail->u.ar.end[i])
6519 mpz_set (s, tail->u.ar.end[i]->value.integer);
6520 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6521 mpz_add_ui (s, s, 1);
6525 mpz_set (s, tail->u.ar.start[i]->value.integer);
6528 if (mpz_cmp (e1->shape[i], s) != 0)
6530 gfc_error ("Source-expr at %L and allocate-object at %L must "
6531 "have the same shape", &e1->where, &e2->where);
6544 /* Resolve the expression in an ALLOCATE statement, doing the additional
6545 checks to see whether the expression is OK or not. The expression must
6546 have a trailing array reference that gives the size of the array. */
6549 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6551 int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
6553 symbol_attribute attr;
6554 gfc_ref *ref, *ref2;
6556 gfc_symbol *sym = NULL;
6560 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
6561 check_intent_in = 1;
6563 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6564 checking of coarrays. */
6565 for (ref = e->ref; ref; ref = ref->next)
6566 if (ref->next == NULL)
6569 if (ref && ref->type == REF_ARRAY)
6570 ref->u.ar.in_allocate = true;
6572 if (gfc_resolve_expr (e) == FAILURE)
6575 /* Make sure the expression is allocatable or a pointer. If it is
6576 pointer, the next-to-last reference must be a pointer. */
6580 sym = e->symtree->n.sym;
6582 /* Check whether ultimate component is abstract and CLASS. */
6585 if (e->expr_type != EXPR_VARIABLE)
6588 attr = gfc_expr_attr (e);
6589 pointer = attr.pointer;
6590 dimension = attr.dimension;
6591 codimension = attr.codimension;
6595 if (sym->ts.type == BT_CLASS)
6597 allocatable = CLASS_DATA (sym)->attr.allocatable;
6598 pointer = CLASS_DATA (sym)->attr.class_pointer;
6599 dimension = CLASS_DATA (sym)->attr.dimension;
6600 codimension = CLASS_DATA (sym)->attr.codimension;
6601 is_abstract = CLASS_DATA (sym)->attr.abstract;
6605 allocatable = sym->attr.allocatable;
6606 pointer = sym->attr.pointer;
6607 dimension = sym->attr.dimension;
6608 codimension = sym->attr.codimension;
6611 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6614 check_intent_in = 0;
6619 if (ref->next != NULL)
6625 if (gfc_is_coindexed (e))
6627 gfc_error ("Coindexed allocatable object at %L",
6632 c = ref->u.c.component;
6633 if (c->ts.type == BT_CLASS)
6635 allocatable = CLASS_DATA (c)->attr.allocatable;
6636 pointer = CLASS_DATA (c)->attr.class_pointer;
6637 dimension = CLASS_DATA (c)->attr.dimension;
6638 codimension = CLASS_DATA (c)->attr.codimension;
6639 is_abstract = CLASS_DATA (c)->attr.abstract;
6643 allocatable = c->attr.allocatable;
6644 pointer = c->attr.pointer;
6645 dimension = c->attr.dimension;
6646 codimension = c->attr.codimension;
6647 is_abstract = c->attr.abstract;
6659 if (allocatable == 0 && pointer == 0)
6661 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6666 /* Some checks for the SOURCE tag. */
6669 /* Check F03:C631. */
6670 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6672 gfc_error ("Type of entity at %L is type incompatible with "
6673 "source-expr at %L", &e->where, &code->expr3->where);
6677 /* Check F03:C632 and restriction following Note 6.18. */
6678 if (code->expr3->rank > 0
6679 && conformable_arrays (code->expr3, e) == FAILURE)
6682 /* Check F03:C633. */
6683 if (code->expr3->ts.kind != e->ts.kind)
6685 gfc_error ("The allocate-object at %L and the source-expr at %L "
6686 "shall have the same kind type parameter",
6687 &e->where, &code->expr3->where);
6692 /* Check F08:C629. */
6693 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
6696 gcc_assert (e->ts.type == BT_CLASS);
6697 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6698 "type-spec or source-expr", sym->name, &e->where);
6702 if (check_intent_in && sym->attr.intent == INTENT_IN)
6704 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
6705 sym->name, &e->where);
6709 if (!code->expr3 || code->expr3->mold)
6711 /* Add default initializer for those derived types that need them. */
6712 gfc_expr *init_e = NULL;
6715 if (code->ext.alloc.ts.type == BT_DERIVED)
6716 ts = code->ext.alloc.ts;
6717 else if (code->expr3)
6718 ts = code->expr3->ts;
6722 if (ts.type == BT_DERIVED)
6723 init_e = gfc_default_initializer (&ts);
6724 /* FIXME: Use default init of dynamic type (cf. PR 44541). */
6725 else if (e->ts.type == BT_CLASS)
6726 init_e = gfc_default_initializer (&ts.u.derived->components->ts);
6730 gfc_code *init_st = gfc_get_code ();
6731 init_st->loc = code->loc;
6732 init_st->op = EXEC_INIT_ASSIGN;
6733 init_st->expr1 = gfc_expr_to_initialize (e);
6734 init_st->expr2 = init_e;
6735 init_st->next = code->next;
6736 code->next = init_st;
6740 if (e->ts.type == BT_CLASS)
6742 /* Make sure the vtab symbol is present when
6743 the module variables are generated. */
6744 gfc_typespec ts = e->ts;
6746 ts = code->expr3->ts;
6747 else if (code->ext.alloc.ts.type == BT_DERIVED)
6748 ts = code->ext.alloc.ts;
6749 gfc_find_derived_vtab (ts.u.derived);
6752 if (pointer || (dimension == 0 && codimension == 0))
6755 /* Make sure the next-to-last reference node is an array specification. */
6757 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
6758 || (dimension && ref2->u.ar.dimen == 0))
6760 gfc_error ("Array specification required in ALLOCATE statement "
6761 "at %L", &e->where);
6765 /* Make sure that the array section reference makes sense in the
6766 context of an ALLOCATE specification. */
6770 if (codimension && ar->codimen == 0)
6772 gfc_error ("Coarray specification required in ALLOCATE statement "
6773 "at %L", &e->where);
6777 for (i = 0; i < ar->dimen; i++)
6779 if (ref2->u.ar.type == AR_ELEMENT)
6782 switch (ar->dimen_type[i])
6788 if (ar->start[i] != NULL
6789 && ar->end[i] != NULL
6790 && ar->stride[i] == NULL)
6793 /* Fall Through... */
6798 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6804 for (a = code->ext.alloc.list; a; a = a->next)
6806 sym = a->expr->symtree->n.sym;
6808 /* TODO - check derived type components. */
6809 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6812 if ((ar->start[i] != NULL
6813 && gfc_find_sym_in_expr (sym, ar->start[i]))
6814 || (ar->end[i] != NULL
6815 && gfc_find_sym_in_expr (sym, ar->end[i])))
6817 gfc_error ("'%s' must not appear in the array specification at "
6818 "%L in the same ALLOCATE statement where it is "
6819 "itself allocated", sym->name, &ar->where);
6825 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
6827 if (ar->dimen_type[i] == DIMEN_ELEMENT
6828 || ar->dimen_type[i] == DIMEN_RANGE)
6830 if (i == (ar->dimen + ar->codimen - 1))
6832 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
6833 "statement at %L", &e->where);
6839 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
6840 && ar->stride[i] == NULL)
6843 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
6848 if (codimension && ar->as->rank == 0)
6850 gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
6851 "at %L", &e->where);
6863 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
6865 gfc_expr *stat, *errmsg, *pe, *qe;
6866 gfc_alloc *a, *p, *q;
6868 stat = code->expr1 ? code->expr1 : NULL;
6870 errmsg = code->expr2 ? code->expr2 : NULL;
6872 /* Check the stat variable. */
6875 if (stat->symtree->n.sym->attr.intent == INTENT_IN)
6876 gfc_error ("Stat-variable '%s' at %L cannot be INTENT(IN)",
6877 stat->symtree->n.sym->name, &stat->where);
6879 if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
6880 gfc_error ("Illegal stat-variable at %L for a PURE procedure",
6883 if ((stat->ts.type != BT_INTEGER
6884 && !(stat->ref && (stat->ref->type == REF_ARRAY
6885 || stat->ref->type == REF_COMPONENT)))
6887 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
6888 "variable", &stat->where);
6890 for (p = code->ext.alloc.list; p; p = p->next)
6891 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
6893 gfc_ref *ref1, *ref2;
6896 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
6897 ref1 = ref1->next, ref2 = ref2->next)
6899 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6901 if (ref1->u.c.component->name != ref2->u.c.component->name)
6910 gfc_error ("Stat-variable at %L shall not be %sd within "
6911 "the same %s statement", &stat->where, fcn, fcn);
6917 /* Check the errmsg variable. */
6921 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
6924 if (errmsg->symtree->n.sym->attr.intent == INTENT_IN)
6925 gfc_error ("Errmsg-variable '%s' at %L cannot be INTENT(IN)",
6926 errmsg->symtree->n.sym->name, &errmsg->where);
6928 if (gfc_pure (NULL) && gfc_impure_variable (errmsg->symtree->n.sym))
6929 gfc_error ("Illegal errmsg-variable at %L for a PURE procedure",
6932 if ((errmsg->ts.type != BT_CHARACTER
6934 && (errmsg->ref->type == REF_ARRAY
6935 || errmsg->ref->type == REF_COMPONENT)))
6936 || errmsg->rank > 0 )
6937 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
6938 "variable", &errmsg->where);
6940 for (p = code->ext.alloc.list; p; p = p->next)
6941 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
6943 gfc_ref *ref1, *ref2;
6946 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
6947 ref1 = ref1->next, ref2 = ref2->next)
6949 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6951 if (ref1->u.c.component->name != ref2->u.c.component->name)
6960 gfc_error ("Errmsg-variable at %L shall not be %sd within "
6961 "the same %s statement", &errmsg->where, fcn, fcn);
6967 /* Check that an allocate-object appears only once in the statement.
6968 FIXME: Checking derived types is disabled. */
6969 for (p = code->ext.alloc.list; p; p = p->next)
6972 if ((pe->ref && pe->ref->type != REF_COMPONENT)
6973 && (pe->symtree->n.sym->ts.type != BT_DERIVED))
6975 for (q = p->next; q; q = q->next)
6978 if ((qe->ref && qe->ref->type != REF_COMPONENT)
6979 && (qe->symtree->n.sym->ts.type != BT_DERIVED)
6980 && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
6981 gfc_error ("Allocate-object at %L also appears at %L",
6982 &pe->where, &qe->where);
6987 if (strcmp (fcn, "ALLOCATE") == 0)
6989 for (a = code->ext.alloc.list; a; a = a->next)
6990 resolve_allocate_expr (a->expr, code);
6994 for (a = code->ext.alloc.list; a; a = a->next)
6995 resolve_deallocate_expr (a->expr);
7000 /************ SELECT CASE resolution subroutines ************/
7002 /* Callback function for our mergesort variant. Determines interval
7003 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7004 op1 > op2. Assumes we're not dealing with the default case.
7005 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7006 There are nine situations to check. */
7009 compare_cases (const gfc_case *op1, const gfc_case *op2)
7013 if (op1->low == NULL) /* op1 = (:L) */
7015 /* op2 = (:N), so overlap. */
7017 /* op2 = (M:) or (M:N), L < M */
7018 if (op2->low != NULL
7019 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7022 else if (op1->high == NULL) /* op1 = (K:) */
7024 /* op2 = (M:), so overlap. */
7026 /* op2 = (:N) or (M:N), K > N */
7027 if (op2->high != NULL
7028 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7031 else /* op1 = (K:L) */
7033 if (op2->low == NULL) /* op2 = (:N), K > N */
7034 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7036 else if (op2->high == NULL) /* op2 = (M:), L < M */
7037 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7039 else /* op2 = (M:N) */
7043 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7046 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7055 /* Merge-sort a double linked case list, detecting overlap in the
7056 process. LIST is the head of the double linked case list before it
7057 is sorted. Returns the head of the sorted list if we don't see any
7058 overlap, or NULL otherwise. */
7061 check_case_overlap (gfc_case *list)
7063 gfc_case *p, *q, *e, *tail;
7064 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7066 /* If the passed list was empty, return immediately. */
7073 /* Loop unconditionally. The only exit from this loop is a return
7074 statement, when we've finished sorting the case list. */
7081 /* Count the number of merges we do in this pass. */
7084 /* Loop while there exists a merge to be done. */
7089 /* Count this merge. */
7092 /* Cut the list in two pieces by stepping INSIZE places
7093 forward in the list, starting from P. */
7096 for (i = 0; i < insize; i++)
7105 /* Now we have two lists. Merge them! */
7106 while (psize > 0 || (qsize > 0 && q != NULL))
7108 /* See from which the next case to merge comes from. */
7111 /* P is empty so the next case must come from Q. */
7116 else if (qsize == 0 || q == NULL)
7125 cmp = compare_cases (p, q);
7128 /* The whole case range for P is less than the
7136 /* The whole case range for Q is greater than
7137 the case range for P. */
7144 /* The cases overlap, or they are the same
7145 element in the list. Either way, we must
7146 issue an error and get the next case from P. */
7147 /* FIXME: Sort P and Q by line number. */
7148 gfc_error ("CASE label at %L overlaps with CASE "
7149 "label at %L", &p->where, &q->where);
7157 /* Add the next element to the merged list. */
7166 /* P has now stepped INSIZE places along, and so has Q. So
7167 they're the same. */
7172 /* If we have done only one merge or none at all, we've
7173 finished sorting the cases. */
7182 /* Otherwise repeat, merging lists twice the size. */
7188 /* Check to see if an expression is suitable for use in a CASE statement.
7189 Makes sure that all case expressions are scalar constants of the same
7190 type. Return FAILURE if anything is wrong. */
7193 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7195 if (e == NULL) return SUCCESS;
7197 if (e->ts.type != case_expr->ts.type)
7199 gfc_error ("Expression in CASE statement at %L must be of type %s",
7200 &e->where, gfc_basic_typename (case_expr->ts.type));
7204 /* C805 (R808) For a given case-construct, each case-value shall be of
7205 the same type as case-expr. For character type, length differences
7206 are allowed, but the kind type parameters shall be the same. */
7208 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7210 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7211 &e->where, case_expr->ts.kind);
7215 /* Convert the case value kind to that of case expression kind,
7218 if (e->ts.kind != case_expr->ts.kind)
7219 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7223 gfc_error ("Expression in CASE statement at %L must be scalar",
7232 /* Given a completely parsed select statement, we:
7234 - Validate all expressions and code within the SELECT.
7235 - Make sure that the selection expression is not of the wrong type.
7236 - Make sure that no case ranges overlap.
7237 - Eliminate unreachable cases and unreachable code resulting from
7238 removing case labels.
7240 The standard does allow unreachable cases, e.g. CASE (5:3). But
7241 they are a hassle for code generation, and to prevent that, we just
7242 cut them out here. This is not necessary for overlapping cases
7243 because they are illegal and we never even try to generate code.
7245 We have the additional caveat that a SELECT construct could have
7246 been a computed GOTO in the source code. Fortunately we can fairly
7247 easily work around that here: The case_expr for a "real" SELECT CASE
7248 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7249 we have to do is make sure that the case_expr is a scalar integer
7253 resolve_select (gfc_code *code)
7256 gfc_expr *case_expr;
7257 gfc_case *cp, *default_case, *tail, *head;
7258 int seen_unreachable;
7264 if (code->expr1 == NULL)
7266 /* This was actually a computed GOTO statement. */
7267 case_expr = code->expr2;
7268 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7269 gfc_error ("Selection expression in computed GOTO statement "
7270 "at %L must be a scalar integer expression",
7273 /* Further checking is not necessary because this SELECT was built
7274 by the compiler, so it should always be OK. Just move the
7275 case_expr from expr2 to expr so that we can handle computed
7276 GOTOs as normal SELECTs from here on. */
7277 code->expr1 = code->expr2;
7282 case_expr = code->expr1;
7284 type = case_expr->ts.type;
7285 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7287 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7288 &case_expr->where, gfc_typename (&case_expr->ts));
7290 /* Punt. Going on here just produce more garbage error messages. */
7294 if (case_expr->rank != 0)
7296 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7297 "expression", &case_expr->where);
7304 /* Raise a warning if an INTEGER case value exceeds the range of
7305 the case-expr. Later, all expressions will be promoted to the
7306 largest kind of all case-labels. */
7308 if (type == BT_INTEGER)
7309 for (body = code->block; body; body = body->block)
7310 for (cp = body->ext.case_list; cp; cp = cp->next)
7313 && gfc_check_integer_range (cp->low->value.integer,
7314 case_expr->ts.kind) != ARITH_OK)
7315 gfc_warning ("Expression in CASE statement at %L is "
7316 "not in the range of %s", &cp->low->where,
7317 gfc_typename (&case_expr->ts));
7320 && cp->low != cp->high
7321 && gfc_check_integer_range (cp->high->value.integer,
7322 case_expr->ts.kind) != ARITH_OK)
7323 gfc_warning ("Expression in CASE statement at %L is "
7324 "not in the range of %s", &cp->high->where,
7325 gfc_typename (&case_expr->ts));
7328 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7329 of the SELECT CASE expression and its CASE values. Walk the lists
7330 of case values, and if we find a mismatch, promote case_expr to
7331 the appropriate kind. */
7333 if (type == BT_LOGICAL || type == BT_INTEGER)
7335 for (body = code->block; body; body = body->block)
7337 /* Walk the case label list. */
7338 for (cp = body->ext.case_list; cp; cp = cp->next)
7340 /* Intercept the DEFAULT case. It does not have a kind. */
7341 if (cp->low == NULL && cp->high == NULL)
7344 /* Unreachable case ranges are discarded, so ignore. */
7345 if (cp->low != NULL && cp->high != NULL
7346 && cp->low != cp->high
7347 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7351 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7352 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7354 if (cp->high != NULL
7355 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7356 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7361 /* Assume there is no DEFAULT case. */
7362 default_case = NULL;
7367 for (body = code->block; body; body = body->block)
7369 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7371 seen_unreachable = 0;
7373 /* Walk the case label list, making sure that all case labels
7375 for (cp = body->ext.case_list; cp; cp = cp->next)
7377 /* Count the number of cases in the whole construct. */
7380 /* Intercept the DEFAULT case. */
7381 if (cp->low == NULL && cp->high == NULL)
7383 if (default_case != NULL)
7385 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7386 "by a second DEFAULT CASE at %L",
7387 &default_case->where, &cp->where);
7398 /* Deal with single value cases and case ranges. Errors are
7399 issued from the validation function. */
7400 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7401 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7407 if (type == BT_LOGICAL
7408 && ((cp->low == NULL || cp->high == NULL)
7409 || cp->low != cp->high))
7411 gfc_error ("Logical range in CASE statement at %L is not "
7412 "allowed", &cp->low->where);
7417 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7420 value = cp->low->value.logical == 0 ? 2 : 1;
7421 if (value & seen_logical)
7423 gfc_error ("Constant logical value in CASE statement "
7424 "is repeated at %L",
7429 seen_logical |= value;
7432 if (cp->low != NULL && cp->high != NULL
7433 && cp->low != cp->high
7434 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7436 if (gfc_option.warn_surprising)
7437 gfc_warning ("Range specification at %L can never "
7438 "be matched", &cp->where);
7440 cp->unreachable = 1;
7441 seen_unreachable = 1;
7445 /* If the case range can be matched, it can also overlap with
7446 other cases. To make sure it does not, we put it in a
7447 double linked list here. We sort that with a merge sort
7448 later on to detect any overlapping cases. */
7452 head->right = head->left = NULL;
7457 tail->right->left = tail;
7464 /* It there was a failure in the previous case label, give up
7465 for this case label list. Continue with the next block. */
7469 /* See if any case labels that are unreachable have been seen.
7470 If so, we eliminate them. This is a bit of a kludge because
7471 the case lists for a single case statement (label) is a
7472 single forward linked lists. */
7473 if (seen_unreachable)
7475 /* Advance until the first case in the list is reachable. */
7476 while (body->ext.case_list != NULL
7477 && body->ext.case_list->unreachable)
7479 gfc_case *n = body->ext.case_list;
7480 body->ext.case_list = body->ext.case_list->next;
7482 gfc_free_case_list (n);
7485 /* Strip all other unreachable cases. */
7486 if (body->ext.case_list)
7488 for (cp = body->ext.case_list; cp->next; cp = cp->next)
7490 if (cp->next->unreachable)
7492 gfc_case *n = cp->next;
7493 cp->next = cp->next->next;
7495 gfc_free_case_list (n);
7502 /* See if there were overlapping cases. If the check returns NULL,
7503 there was overlap. In that case we don't do anything. If head
7504 is non-NULL, we prepend the DEFAULT case. The sorted list can
7505 then used during code generation for SELECT CASE constructs with
7506 a case expression of a CHARACTER type. */
7509 head = check_case_overlap (head);
7511 /* Prepend the default_case if it is there. */
7512 if (head != NULL && default_case)
7514 default_case->left = NULL;
7515 default_case->right = head;
7516 head->left = default_case;
7520 /* Eliminate dead blocks that may be the result if we've seen
7521 unreachable case labels for a block. */
7522 for (body = code; body && body->block; body = body->block)
7524 if (body->block->ext.case_list == NULL)
7526 /* Cut the unreachable block from the code chain. */
7527 gfc_code *c = body->block;
7528 body->block = c->block;
7530 /* Kill the dead block, but not the blocks below it. */
7532 gfc_free_statements (c);
7536 /* More than two cases is legal but insane for logical selects.
7537 Issue a warning for it. */
7538 if (gfc_option.warn_surprising && type == BT_LOGICAL
7540 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7545 /* Check if a derived type is extensible. */
7548 gfc_type_is_extensible (gfc_symbol *sym)
7550 return !(sym->attr.is_bind_c || sym->attr.sequence);
7554 /* Resolve an associate name: Resolve target and ensure the type-spec is
7555 correct as well as possibly the array-spec. */
7558 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
7563 gcc_assert (sym->assoc);
7564 gcc_assert (sym->attr.flavor == FL_VARIABLE);
7566 /* If this is for SELECT TYPE, the target may not yet be set. In that
7567 case, return. Resolution will be called later manually again when
7569 target = sym->assoc->target;
7572 gcc_assert (!sym->assoc->dangling);
7574 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
7577 /* For variable targets, we get some attributes from the target. */
7578 if (target->expr_type == EXPR_VARIABLE)
7582 gcc_assert (target->symtree);
7583 tsym = target->symtree->n.sym;
7585 sym->attr.asynchronous = tsym->attr.asynchronous;
7586 sym->attr.volatile_ = tsym->attr.volatile_;
7588 sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
7591 sym->ts = target->ts;
7592 gcc_assert (sym->ts.type != BT_UNKNOWN);
7594 /* See if this is a valid association-to-variable. */
7595 to_var = (target->expr_type == EXPR_VARIABLE
7596 && !gfc_has_vector_subscript (target));
7597 if (sym->assoc->variable && !to_var)
7599 if (target->expr_type == EXPR_VARIABLE)
7600 gfc_error ("'%s' at %L associated to vector-indexed target can not"
7601 " be used in a variable definition context",
7602 sym->name, &sym->declared_at);
7604 gfc_error ("'%s' at %L associated to expression can not"
7605 " be used in a variable definition context",
7606 sym->name, &sym->declared_at);
7610 sym->assoc->variable = to_var;
7612 /* Finally resolve if this is an array or not. */
7613 if (sym->attr.dimension && target->rank == 0)
7615 gfc_error ("Associate-name '%s' at %L is used as array",
7616 sym->name, &sym->declared_at);
7617 sym->attr.dimension = 0;
7620 if (target->rank > 0)
7621 sym->attr.dimension = 1;
7623 if (sym->attr.dimension)
7625 sym->as = gfc_get_array_spec ();
7626 sym->as->rank = target->rank;
7627 sym->as->type = AS_DEFERRED;
7629 /* Target must not be coindexed, thus the associate-variable
7631 sym->as->corank = 0;
7636 /* Resolve a SELECT TYPE statement. */
7639 resolve_select_type (gfc_code *code)
7641 gfc_symbol *selector_type;
7642 gfc_code *body, *new_st, *if_st, *tail;
7643 gfc_code *class_is = NULL, *default_case = NULL;
7646 char name[GFC_MAX_SYMBOL_LEN];
7650 ns = code->ext.block.ns;
7653 /* Check for F03:C813. */
7654 if (code->expr1->ts.type != BT_CLASS
7655 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
7657 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7658 "at %L", &code->loc);
7664 if (code->expr1->symtree->n.sym->attr.untyped)
7665 code->expr1->symtree->n.sym->ts = code->expr2->ts;
7666 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
7669 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
7671 /* Loop over TYPE IS / CLASS IS cases. */
7672 for (body = code->block; body; body = body->block)
7674 c = body->ext.case_list;
7676 /* Check F03:C815. */
7677 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7678 && !gfc_type_is_extensible (c->ts.u.derived))
7680 gfc_error ("Derived type '%s' at %L must be extensible",
7681 c->ts.u.derived->name, &c->where);
7686 /* Check F03:C816. */
7687 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7688 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
7690 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7691 c->ts.u.derived->name, &c->where, selector_type->name);
7696 /* Intercept the DEFAULT case. */
7697 if (c->ts.type == BT_UNKNOWN)
7699 /* Check F03:C818. */
7702 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7703 "by a second DEFAULT CASE at %L",
7704 &default_case->ext.case_list->where, &c->where);
7709 default_case = body;
7716 /* Transform SELECT TYPE statement to BLOCK and associate selector to
7717 target if present. */
7718 code->op = EXEC_BLOCK;
7721 gfc_association_list* assoc;
7723 assoc = gfc_get_association_list ();
7724 assoc->st = code->expr1->symtree;
7725 assoc->target = gfc_copy_expr (code->expr2);
7726 /* assoc->variable will be set by resolve_assoc_var. */
7728 code->ext.block.assoc = assoc;
7729 code->expr1->symtree->n.sym->assoc = assoc;
7731 resolve_assoc_var (code->expr1->symtree->n.sym, false);
7734 code->ext.block.assoc = NULL;
7736 /* Add EXEC_SELECT to switch on type. */
7737 new_st = gfc_get_code ();
7738 new_st->op = code->op;
7739 new_st->expr1 = code->expr1;
7740 new_st->expr2 = code->expr2;
7741 new_st->block = code->block;
7742 code->expr1 = code->expr2 = NULL;
7747 ns->code->next = new_st;
7749 code->op = EXEC_SELECT;
7750 gfc_add_component_ref (code->expr1, "$vptr");
7751 gfc_add_component_ref (code->expr1, "$hash");
7753 /* Loop over TYPE IS / CLASS IS cases. */
7754 for (body = code->block; body; body = body->block)
7756 c = body->ext.case_list;
7758 if (c->ts.type == BT_DERIVED)
7759 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7760 c->ts.u.derived->hash_value);
7762 else if (c->ts.type == BT_UNKNOWN)
7765 /* Associate temporary to selector. This should only be done
7766 when this case is actually true, so build a new ASSOCIATE
7767 that does precisely this here (instead of using the
7770 if (c->ts.type == BT_CLASS)
7771 sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
7773 sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
7774 st = gfc_find_symtree (ns->sym_root, name);
7775 gcc_assert (st->n.sym->assoc);
7776 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
7777 if (c->ts.type == BT_DERIVED)
7778 gfc_add_component_ref (st->n.sym->assoc->target, "$data");
7780 new_st = gfc_get_code ();
7781 new_st->op = EXEC_BLOCK;
7782 new_st->ext.block.ns = gfc_build_block_ns (ns);
7783 new_st->ext.block.ns->code = body->next;
7784 body->next = new_st;
7786 /* Chain in the new list only if it is marked as dangling. Otherwise
7787 there is a CASE label overlap and this is already used. Just ignore,
7788 the error is diagonsed elsewhere. */
7789 if (st->n.sym->assoc->dangling)
7791 new_st->ext.block.assoc = st->n.sym->assoc;
7792 st->n.sym->assoc->dangling = 0;
7795 resolve_assoc_var (st->n.sym, false);
7798 /* Take out CLASS IS cases for separate treatment. */
7800 while (body && body->block)
7802 if (body->block->ext.case_list->ts.type == BT_CLASS)
7804 /* Add to class_is list. */
7805 if (class_is == NULL)
7807 class_is = body->block;
7812 for (tail = class_is; tail->block; tail = tail->block) ;
7813 tail->block = body->block;
7816 /* Remove from EXEC_SELECT list. */
7817 body->block = body->block->block;
7830 /* Add a default case to hold the CLASS IS cases. */
7831 for (tail = code; tail->block; tail = tail->block) ;
7832 tail->block = gfc_get_code ();
7834 tail->op = EXEC_SELECT_TYPE;
7835 tail->ext.case_list = gfc_get_case ();
7836 tail->ext.case_list->ts.type = BT_UNKNOWN;
7838 default_case = tail;
7841 /* More than one CLASS IS block? */
7842 if (class_is->block)
7846 /* Sort CLASS IS blocks by extension level. */
7850 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
7853 /* F03:C817 (check for doubles). */
7854 if ((*c1)->ext.case_list->ts.u.derived->hash_value
7855 == c2->ext.case_list->ts.u.derived->hash_value)
7857 gfc_error ("Double CLASS IS block in SELECT TYPE "
7858 "statement at %L", &c2->ext.case_list->where);
7861 if ((*c1)->ext.case_list->ts.u.derived->attr.extension
7862 < c2->ext.case_list->ts.u.derived->attr.extension)
7865 (*c1)->block = c2->block;
7875 /* Generate IF chain. */
7876 if_st = gfc_get_code ();
7877 if_st->op = EXEC_IF;
7879 for (body = class_is; body; body = body->block)
7881 new_st->block = gfc_get_code ();
7882 new_st = new_st->block;
7883 new_st->op = EXEC_IF;
7884 /* Set up IF condition: Call _gfortran_is_extension_of. */
7885 new_st->expr1 = gfc_get_expr ();
7886 new_st->expr1->expr_type = EXPR_FUNCTION;
7887 new_st->expr1->ts.type = BT_LOGICAL;
7888 new_st->expr1->ts.kind = 4;
7889 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
7890 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
7891 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
7892 /* Set up arguments. */
7893 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
7894 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
7895 gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
7896 vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
7897 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
7898 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
7899 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
7900 new_st->next = body->next;
7902 if (default_case->next)
7904 new_st->block = gfc_get_code ();
7905 new_st = new_st->block;
7906 new_st->op = EXEC_IF;
7907 new_st->next = default_case->next;
7910 /* Replace CLASS DEFAULT code by the IF chain. */
7911 default_case->next = if_st;
7914 resolve_select (code);
7919 /* Resolve a transfer statement. This is making sure that:
7920 -- a derived type being transferred has only non-pointer components
7921 -- a derived type being transferred doesn't have private components, unless
7922 it's being transferred from the module where the type was defined
7923 -- we're not trying to transfer a whole assumed size array. */
7926 resolve_transfer (gfc_code *code)
7935 while (exp != NULL && exp->expr_type == EXPR_OP
7936 && exp->value.op.op == INTRINSIC_PARENTHESES)
7937 exp = exp->value.op.op1;
7939 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
7940 && exp->expr_type != EXPR_FUNCTION))
7943 sym = exp->symtree->n.sym;
7946 /* Go to actual component transferred. */
7947 for (ref = code->expr1->ref; ref; ref = ref->next)
7948 if (ref->type == REF_COMPONENT)
7949 ts = &ref->u.c.component->ts;
7951 if (ts->type == BT_DERIVED)
7953 /* Check that transferred derived type doesn't contain POINTER
7955 if (ts->u.derived->attr.pointer_comp)
7957 gfc_error ("Data transfer element at %L cannot have "
7958 "POINTER components", &code->loc);
7962 if (ts->u.derived->attr.alloc_comp)
7964 gfc_error ("Data transfer element at %L cannot have "
7965 "ALLOCATABLE components", &code->loc);
7969 if (derived_inaccessible (ts->u.derived))
7971 gfc_error ("Data transfer element at %L cannot have "
7972 "PRIVATE components",&code->loc);
7977 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
7978 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
7980 gfc_error ("Data transfer element at %L cannot be a full reference to "
7981 "an assumed-size array", &code->loc);
7987 /*********** Toplevel code resolution subroutines ***********/
7989 /* Find the set of labels that are reachable from this block. We also
7990 record the last statement in each block. */
7993 find_reachable_labels (gfc_code *block)
8000 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
8002 /* Collect labels in this block. We don't keep those corresponding
8003 to END {IF|SELECT}, these are checked in resolve_branch by going
8004 up through the code_stack. */
8005 for (c = block; c; c = c->next)
8007 if (c->here && c->op != EXEC_END_BLOCK)
8008 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8011 /* Merge with labels from parent block. */
8014 gcc_assert (cs_base->prev->reachable_labels);
8015 bitmap_ior_into (cs_base->reachable_labels,
8016 cs_base->prev->reachable_labels);
8022 resolve_sync (gfc_code *code)
8024 /* Check imageset. The * case matches expr1 == NULL. */
8027 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8028 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8029 "INTEGER expression", &code->expr1->where);
8030 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8031 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8032 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8033 &code->expr1->where);
8034 else if (code->expr1->expr_type == EXPR_ARRAY
8035 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8037 gfc_constructor *cons;
8038 cons = gfc_constructor_first (code->expr1->value.constructor);
8039 for (; cons; cons = gfc_constructor_next (cons))
8040 if (cons->expr->expr_type == EXPR_CONSTANT
8041 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8042 gfc_error ("Imageset argument at %L must between 1 and "
8043 "num_images()", &cons->expr->where);
8049 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8050 || code->expr2->expr_type != EXPR_VARIABLE))
8051 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8052 &code->expr2->where);
8056 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8057 || code->expr3->expr_type != EXPR_VARIABLE))
8058 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8059 &code->expr3->where);
8063 /* Given a branch to a label, see if the branch is conforming.
8064 The code node describes where the branch is located. */
8067 resolve_branch (gfc_st_label *label, gfc_code *code)
8074 /* Step one: is this a valid branching target? */
8076 if (label->defined == ST_LABEL_UNKNOWN)
8078 gfc_error ("Label %d referenced at %L is never defined", label->value,
8083 if (label->defined != ST_LABEL_TARGET)
8085 gfc_error ("Statement at %L is not a valid branch target statement "
8086 "for the branch statement at %L", &label->where, &code->loc);
8090 /* Step two: make sure this branch is not a branch to itself ;-) */
8092 if (code->here == label)
8094 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8098 /* Step three: See if the label is in the same block as the
8099 branching statement. The hard work has been done by setting up
8100 the bitmap reachable_labels. */
8102 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8104 /* Check now whether there is a CRITICAL construct; if so, check
8105 whether the label is still visible outside of the CRITICAL block,
8106 which is invalid. */
8107 for (stack = cs_base; stack; stack = stack->prev)
8108 if (stack->current->op == EXEC_CRITICAL
8109 && bitmap_bit_p (stack->reachable_labels, label->value))
8110 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8111 " at %L", &code->loc, &label->where);
8116 /* Step four: If we haven't found the label in the bitmap, it may
8117 still be the label of the END of the enclosing block, in which
8118 case we find it by going up the code_stack. */
8120 for (stack = cs_base; stack; stack = stack->prev)
8122 if (stack->current->next && stack->current->next->here == label)
8124 if (stack->current->op == EXEC_CRITICAL)
8126 /* Note: A label at END CRITICAL does not leave the CRITICAL
8127 construct as END CRITICAL is still part of it. */
8128 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8129 " at %L", &code->loc, &label->where);
8136 gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
8140 /* The label is not in an enclosing block, so illegal. This was
8141 allowed in Fortran 66, so we allow it as extension. No
8142 further checks are necessary in this case. */
8143 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
8144 "as the GOTO statement at %L", &label->where,
8150 /* Check whether EXPR1 has the same shape as EXPR2. */
8153 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
8155 mpz_t shape[GFC_MAX_DIMENSIONS];
8156 mpz_t shape2[GFC_MAX_DIMENSIONS];
8157 gfc_try result = FAILURE;
8160 /* Compare the rank. */
8161 if (expr1->rank != expr2->rank)
8164 /* Compare the size of each dimension. */
8165 for (i=0; i<expr1->rank; i++)
8167 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
8170 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
8173 if (mpz_cmp (shape[i], shape2[i]))
8177 /* When either of the two expression is an assumed size array, we
8178 ignore the comparison of dimension sizes. */
8183 for (i--; i >= 0; i--)
8185 mpz_clear (shape[i]);
8186 mpz_clear (shape2[i]);
8192 /* Check whether a WHERE assignment target or a WHERE mask expression
8193 has the same shape as the outmost WHERE mask expression. */
8196 resolve_where (gfc_code *code, gfc_expr *mask)
8202 cblock = code->block;
8204 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8205 In case of nested WHERE, only the outmost one is stored. */
8206 if (mask == NULL) /* outmost WHERE */
8208 else /* inner WHERE */
8215 /* Check if the mask-expr has a consistent shape with the
8216 outmost WHERE mask-expr. */
8217 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8218 gfc_error ("WHERE mask at %L has inconsistent shape",
8219 &cblock->expr1->where);
8222 /* the assignment statement of a WHERE statement, or the first
8223 statement in where-body-construct of a WHERE construct */
8224 cnext = cblock->next;
8229 /* WHERE assignment statement */
8232 /* Check shape consistent for WHERE assignment target. */
8233 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8234 gfc_error ("WHERE assignment target at %L has "
8235 "inconsistent shape", &cnext->expr1->where);
8239 case EXEC_ASSIGN_CALL:
8240 resolve_call (cnext);
8241 if (!cnext->resolved_sym->attr.elemental)
8242 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8243 &cnext->ext.actual->expr->where);
8246 /* WHERE or WHERE construct is part of a where-body-construct */
8248 resolve_where (cnext, e);
8252 gfc_error ("Unsupported statement inside WHERE at %L",
8255 /* the next statement within the same where-body-construct */
8256 cnext = cnext->next;
8258 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8259 cblock = cblock->block;
8264 /* Resolve assignment in FORALL construct.
8265 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8266 FORALL index variables. */
8269 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8273 for (n = 0; n < nvar; n++)
8275 gfc_symbol *forall_index;
8277 forall_index = var_expr[n]->symtree->n.sym;
8279 /* Check whether the assignment target is one of the FORALL index
8281 if ((code->expr1->expr_type == EXPR_VARIABLE)
8282 && (code->expr1->symtree->n.sym == forall_index))
8283 gfc_error ("Assignment to a FORALL index variable at %L",
8284 &code->expr1->where);
8287 /* If one of the FORALL index variables doesn't appear in the
8288 assignment variable, then there could be a many-to-one
8289 assignment. Emit a warning rather than an error because the
8290 mask could be resolving this problem. */
8291 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8292 gfc_warning ("The FORALL with index '%s' is not used on the "
8293 "left side of the assignment at %L and so might "
8294 "cause multiple assignment to this object",
8295 var_expr[n]->symtree->name, &code->expr1->where);
8301 /* Resolve WHERE statement in FORALL construct. */
8304 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8305 gfc_expr **var_expr)
8310 cblock = code->block;
8313 /* the assignment statement of a WHERE statement, or the first
8314 statement in where-body-construct of a WHERE construct */
8315 cnext = cblock->next;
8320 /* WHERE assignment statement */
8322 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8325 /* WHERE operator assignment statement */
8326 case EXEC_ASSIGN_CALL:
8327 resolve_call (cnext);
8328 if (!cnext->resolved_sym->attr.elemental)
8329 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8330 &cnext->ext.actual->expr->where);
8333 /* WHERE or WHERE construct is part of a where-body-construct */
8335 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8339 gfc_error ("Unsupported statement inside WHERE at %L",
8342 /* the next statement within the same where-body-construct */
8343 cnext = cnext->next;
8345 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8346 cblock = cblock->block;
8351 /* Traverse the FORALL body to check whether the following errors exist:
8352 1. For assignment, check if a many-to-one assignment happens.
8353 2. For WHERE statement, check the WHERE body to see if there is any
8354 many-to-one assignment. */
8357 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8361 c = code->block->next;
8367 case EXEC_POINTER_ASSIGN:
8368 gfc_resolve_assign_in_forall (c, nvar, var_expr);
8371 case EXEC_ASSIGN_CALL:
8375 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8376 there is no need to handle it here. */
8380 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8385 /* The next statement in the FORALL body. */
8391 /* Counts the number of iterators needed inside a forall construct, including
8392 nested forall constructs. This is used to allocate the needed memory
8393 in gfc_resolve_forall. */
8396 gfc_count_forall_iterators (gfc_code *code)
8398 int max_iters, sub_iters, current_iters;
8399 gfc_forall_iterator *fa;
8401 gcc_assert(code->op == EXEC_FORALL);
8405 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8408 code = code->block->next;
8412 if (code->op == EXEC_FORALL)
8414 sub_iters = gfc_count_forall_iterators (code);
8415 if (sub_iters > max_iters)
8416 max_iters = sub_iters;
8421 return current_iters + max_iters;
8425 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8426 gfc_resolve_forall_body to resolve the FORALL body. */
8429 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8431 static gfc_expr **var_expr;
8432 static int total_var = 0;
8433 static int nvar = 0;
8435 gfc_forall_iterator *fa;
8440 /* Start to resolve a FORALL construct */
8441 if (forall_save == 0)
8443 /* Count the total number of FORALL index in the nested FORALL
8444 construct in order to allocate the VAR_EXPR with proper size. */
8445 total_var = gfc_count_forall_iterators (code);
8447 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8448 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
8451 /* The information about FORALL iterator, including FORALL index start, end
8452 and stride. The FORALL index can not appear in start, end or stride. */
8453 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8455 /* Check if any outer FORALL index name is the same as the current
8457 for (i = 0; i < nvar; i++)
8459 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8461 gfc_error ("An outer FORALL construct already has an index "
8462 "with this name %L", &fa->var->where);
8466 /* Record the current FORALL index. */
8467 var_expr[nvar] = gfc_copy_expr (fa->var);
8471 /* No memory leak. */
8472 gcc_assert (nvar <= total_var);
8475 /* Resolve the FORALL body. */
8476 gfc_resolve_forall_body (code, nvar, var_expr);
8478 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8479 gfc_resolve_blocks (code->block, ns);
8483 /* Free only the VAR_EXPRs allocated in this frame. */
8484 for (i = nvar; i < tmp; i++)
8485 gfc_free_expr (var_expr[i]);
8489 /* We are in the outermost FORALL construct. */
8490 gcc_assert (forall_save == 0);
8492 /* VAR_EXPR is not needed any more. */
8493 gfc_free (var_expr);
8499 /* Resolve a BLOCK construct statement. */
8502 resolve_block_construct (gfc_code* code)
8504 /* Resolve the BLOCK's namespace. */
8505 gfc_resolve (code->ext.block.ns);
8507 /* For an ASSOCIATE block, the associations (and their targets) are already
8508 resolved during resolve_symbol. */
8512 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8515 static void resolve_code (gfc_code *, gfc_namespace *);
8518 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8522 for (; b; b = b->block)
8524 t = gfc_resolve_expr (b->expr1);
8525 if (gfc_resolve_expr (b->expr2) == FAILURE)
8531 if (t == SUCCESS && b->expr1 != NULL
8532 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
8533 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8540 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
8541 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8546 resolve_branch (b->label1, b);
8550 resolve_block_construct (b);
8554 case EXEC_SELECT_TYPE:
8565 case EXEC_OMP_ATOMIC:
8566 case EXEC_OMP_CRITICAL:
8568 case EXEC_OMP_MASTER:
8569 case EXEC_OMP_ORDERED:
8570 case EXEC_OMP_PARALLEL:
8571 case EXEC_OMP_PARALLEL_DO:
8572 case EXEC_OMP_PARALLEL_SECTIONS:
8573 case EXEC_OMP_PARALLEL_WORKSHARE:
8574 case EXEC_OMP_SECTIONS:
8575 case EXEC_OMP_SINGLE:
8577 case EXEC_OMP_TASKWAIT:
8578 case EXEC_OMP_WORKSHARE:
8582 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
8585 resolve_code (b->next, ns);
8590 /* Does everything to resolve an ordinary assignment. Returns true
8591 if this is an interface assignment. */
8593 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
8603 if (gfc_extend_assign (code, ns) == SUCCESS)
8607 if (code->op == EXEC_ASSIGN_CALL)
8609 lhs = code->ext.actual->expr;
8610 rhsptr = &code->ext.actual->next->expr;
8614 gfc_actual_arglist* args;
8615 gfc_typebound_proc* tbp;
8617 gcc_assert (code->op == EXEC_COMPCALL);
8619 args = code->expr1->value.compcall.actual;
8621 rhsptr = &args->next->expr;
8623 tbp = code->expr1->value.compcall.tbp;
8624 gcc_assert (!tbp->is_generic);
8627 /* Make a temporary rhs when there is a default initializer
8628 and rhs is the same symbol as the lhs. */
8629 if ((*rhsptr)->expr_type == EXPR_VARIABLE
8630 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
8631 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
8632 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
8633 *rhsptr = gfc_get_parentheses (*rhsptr);
8642 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
8643 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
8644 &code->loc) == FAILURE)
8647 /* Handle the case of a BOZ literal on the RHS. */
8648 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
8651 if (gfc_option.warn_surprising)
8652 gfc_warning ("BOZ literal at %L is bitwise transferred "
8653 "non-integer symbol '%s'", &code->loc,
8654 lhs->symtree->n.sym->name);
8656 if (!gfc_convert_boz (rhs, &lhs->ts))
8658 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
8660 if (rc == ARITH_UNDERFLOW)
8661 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
8662 ". This check can be disabled with the option "
8663 "-fno-range-check", &rhs->where);
8664 else if (rc == ARITH_OVERFLOW)
8665 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
8666 ". This check can be disabled with the option "
8667 "-fno-range-check", &rhs->where);
8668 else if (rc == ARITH_NAN)
8669 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
8670 ". This check can be disabled with the option "
8671 "-fno-range-check", &rhs->where);
8677 if (lhs->ts.type == BT_CHARACTER
8678 && gfc_option.warn_character_truncation)
8680 if (lhs->ts.u.cl != NULL
8681 && lhs->ts.u.cl->length != NULL
8682 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8683 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
8685 if (rhs->expr_type == EXPR_CONSTANT)
8686 rlen = rhs->value.character.length;
8688 else if (rhs->ts.u.cl != NULL
8689 && rhs->ts.u.cl->length != NULL
8690 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8691 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
8693 if (rlen && llen && rlen > llen)
8694 gfc_warning_now ("CHARACTER expression will be truncated "
8695 "in assignment (%d/%d) at %L",
8696 llen, rlen, &code->loc);
8699 /* Ensure that a vector index expression for the lvalue is evaluated
8700 to a temporary if the lvalue symbol is referenced in it. */
8703 for (ref = lhs->ref; ref; ref= ref->next)
8704 if (ref->type == REF_ARRAY)
8706 for (n = 0; n < ref->u.ar.dimen; n++)
8707 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
8708 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
8709 ref->u.ar.start[n]))
8711 = gfc_get_parentheses (ref->u.ar.start[n]);
8715 if (gfc_pure (NULL))
8717 if (gfc_impure_variable (lhs->symtree->n.sym))
8719 gfc_error ("Cannot assign to variable '%s' in PURE "
8721 lhs->symtree->n.sym->name,
8726 if (lhs->ts.type == BT_DERIVED
8727 && lhs->expr_type == EXPR_VARIABLE
8728 && lhs->ts.u.derived->attr.pointer_comp
8729 && rhs->expr_type == EXPR_VARIABLE
8730 && (gfc_impure_variable (rhs->symtree->n.sym)
8731 || gfc_is_coindexed (rhs)))
8734 if (gfc_is_coindexed (rhs))
8735 gfc_error ("Coindexed expression at %L is assigned to "
8736 "a derived type variable with a POINTER "
8737 "component in a PURE procedure",
8740 gfc_error ("The impure variable at %L is assigned to "
8741 "a derived type variable with a POINTER "
8742 "component in a PURE procedure (12.6)",
8747 /* Fortran 2008, C1283. */
8748 if (gfc_is_coindexed (lhs))
8750 gfc_error ("Assignment to coindexed variable at %L in a PURE "
8751 "procedure", &rhs->where);
8757 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
8758 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
8759 if (lhs->ts.type == BT_CLASS)
8761 gfc_error ("Variable must not be polymorphic in assignment at %L",
8766 /* F2008, Section 7.2.1.2. */
8767 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
8769 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
8770 "component in assignment at %L", &lhs->where);
8774 gfc_check_assign (lhs, rhs, 1);
8779 /* Given a block of code, recursively resolve everything pointed to by this
8783 resolve_code (gfc_code *code, gfc_namespace *ns)
8785 int omp_workshare_save;
8790 frame.prev = cs_base;
8794 find_reachable_labels (code);
8796 for (; code; code = code->next)
8798 frame.current = code;
8799 forall_save = forall_flag;
8801 if (code->op == EXEC_FORALL)
8804 gfc_resolve_forall (code, ns, forall_save);
8807 else if (code->block)
8809 omp_workshare_save = -1;
8812 case EXEC_OMP_PARALLEL_WORKSHARE:
8813 omp_workshare_save = omp_workshare_flag;
8814 omp_workshare_flag = 1;
8815 gfc_resolve_omp_parallel_blocks (code, ns);
8817 case EXEC_OMP_PARALLEL:
8818 case EXEC_OMP_PARALLEL_DO:
8819 case EXEC_OMP_PARALLEL_SECTIONS:
8821 omp_workshare_save = omp_workshare_flag;
8822 omp_workshare_flag = 0;
8823 gfc_resolve_omp_parallel_blocks (code, ns);
8826 gfc_resolve_omp_do_blocks (code, ns);
8828 case EXEC_SELECT_TYPE:
8829 gfc_current_ns = code->ext.block.ns;
8830 gfc_resolve_blocks (code->block, gfc_current_ns);
8831 gfc_current_ns = ns;
8833 case EXEC_OMP_WORKSHARE:
8834 omp_workshare_save = omp_workshare_flag;
8835 omp_workshare_flag = 1;
8838 gfc_resolve_blocks (code->block, ns);
8842 if (omp_workshare_save != -1)
8843 omp_workshare_flag = omp_workshare_save;
8847 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
8848 t = gfc_resolve_expr (code->expr1);
8849 forall_flag = forall_save;
8851 if (gfc_resolve_expr (code->expr2) == FAILURE)
8854 if (code->op == EXEC_ALLOCATE
8855 && gfc_resolve_expr (code->expr3) == FAILURE)
8861 case EXEC_END_BLOCK:
8865 case EXEC_ERROR_STOP:
8869 case EXEC_ASSIGN_CALL:
8874 case EXEC_SYNC_IMAGES:
8875 case EXEC_SYNC_MEMORY:
8876 resolve_sync (code);
8880 /* Keep track of which entry we are up to. */
8881 current_entry_id = code->ext.entry->id;
8885 resolve_where (code, NULL);
8889 if (code->expr1 != NULL)
8891 if (code->expr1->ts.type != BT_INTEGER)
8892 gfc_error ("ASSIGNED GOTO statement at %L requires an "
8893 "INTEGER variable", &code->expr1->where);
8894 else if (code->expr1->symtree->n.sym->attr.assign != 1)
8895 gfc_error ("Variable '%s' has not been assigned a target "
8896 "label at %L", code->expr1->symtree->n.sym->name,
8897 &code->expr1->where);
8900 resolve_branch (code->label1, code);
8904 if (code->expr1 != NULL
8905 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
8906 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
8907 "INTEGER return specifier", &code->expr1->where);
8910 case EXEC_INIT_ASSIGN:
8911 case EXEC_END_PROCEDURE:
8918 if (resolve_ordinary_assign (code, ns))
8920 if (code->op == EXEC_COMPCALL)
8927 case EXEC_LABEL_ASSIGN:
8928 if (code->label1->defined == ST_LABEL_UNKNOWN)
8929 gfc_error ("Label %d referenced at %L is never defined",
8930 code->label1->value, &code->label1->where);
8932 && (code->expr1->expr_type != EXPR_VARIABLE
8933 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
8934 || code->expr1->symtree->n.sym->ts.kind
8935 != gfc_default_integer_kind
8936 || code->expr1->symtree->n.sym->as != NULL))
8937 gfc_error ("ASSIGN statement at %L requires a scalar "
8938 "default INTEGER variable", &code->expr1->where);
8941 case EXEC_POINTER_ASSIGN:
8945 gfc_check_pointer_assign (code->expr1, code->expr2);
8948 case EXEC_ARITHMETIC_IF:
8950 && code->expr1->ts.type != BT_INTEGER
8951 && code->expr1->ts.type != BT_REAL)
8952 gfc_error ("Arithmetic IF statement at %L requires a numeric "
8953 "expression", &code->expr1->where);
8955 resolve_branch (code->label1, code);
8956 resolve_branch (code->label2, code);
8957 resolve_branch (code->label3, code);
8961 if (t == SUCCESS && code->expr1 != NULL
8962 && (code->expr1->ts.type != BT_LOGICAL
8963 || code->expr1->rank != 0))
8964 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8965 &code->expr1->where);
8970 resolve_call (code);
8975 resolve_typebound_subroutine (code);
8979 resolve_ppc_call (code);
8983 /* Select is complicated. Also, a SELECT construct could be
8984 a transformed computed GOTO. */
8985 resolve_select (code);
8988 case EXEC_SELECT_TYPE:
8989 resolve_select_type (code);
8993 resolve_block_construct (code);
8997 if (code->ext.iterator != NULL)
8999 gfc_iterator *iter = code->ext.iterator;
9000 if (gfc_resolve_iterator (iter, true) != FAILURE)
9001 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
9006 if (code->expr1 == NULL)
9007 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9009 && (code->expr1->rank != 0
9010 || code->expr1->ts.type != BT_LOGICAL))
9011 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9012 "a scalar LOGICAL expression", &code->expr1->where);
9017 resolve_allocate_deallocate (code, "ALLOCATE");
9021 case EXEC_DEALLOCATE:
9023 resolve_allocate_deallocate (code, "DEALLOCATE");
9028 if (gfc_resolve_open (code->ext.open) == FAILURE)
9031 resolve_branch (code->ext.open->err, code);
9035 if (gfc_resolve_close (code->ext.close) == FAILURE)
9038 resolve_branch (code->ext.close->err, code);
9041 case EXEC_BACKSPACE:
9045 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
9048 resolve_branch (code->ext.filepos->err, code);
9052 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9055 resolve_branch (code->ext.inquire->err, code);
9059 gcc_assert (code->ext.inquire != NULL);
9060 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9063 resolve_branch (code->ext.inquire->err, code);
9067 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
9070 resolve_branch (code->ext.wait->err, code);
9071 resolve_branch (code->ext.wait->end, code);
9072 resolve_branch (code->ext.wait->eor, code);
9077 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
9080 resolve_branch (code->ext.dt->err, code);
9081 resolve_branch (code->ext.dt->end, code);
9082 resolve_branch (code->ext.dt->eor, code);
9086 resolve_transfer (code);
9090 resolve_forall_iterators (code->ext.forall_iterator);
9092 if (code->expr1 != NULL && code->expr1->ts.type != BT_LOGICAL)
9093 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
9094 "expression", &code->expr1->where);
9097 case EXEC_OMP_ATOMIC:
9098 case EXEC_OMP_BARRIER:
9099 case EXEC_OMP_CRITICAL:
9100 case EXEC_OMP_FLUSH:
9102 case EXEC_OMP_MASTER:
9103 case EXEC_OMP_ORDERED:
9104 case EXEC_OMP_SECTIONS:
9105 case EXEC_OMP_SINGLE:
9106 case EXEC_OMP_TASKWAIT:
9107 case EXEC_OMP_WORKSHARE:
9108 gfc_resolve_omp_directive (code, ns);
9111 case EXEC_OMP_PARALLEL:
9112 case EXEC_OMP_PARALLEL_DO:
9113 case EXEC_OMP_PARALLEL_SECTIONS:
9114 case EXEC_OMP_PARALLEL_WORKSHARE:
9116 omp_workshare_save = omp_workshare_flag;
9117 omp_workshare_flag = 0;
9118 gfc_resolve_omp_directive (code, ns);
9119 omp_workshare_flag = omp_workshare_save;
9123 gfc_internal_error ("resolve_code(): Bad statement code");
9127 cs_base = frame.prev;
9131 /* Resolve initial values and make sure they are compatible with
9135 resolve_values (gfc_symbol *sym)
9139 if (sym->value == NULL)
9142 if (sym->value->expr_type == EXPR_STRUCTURE)
9143 t= resolve_structure_cons (sym->value, 1);
9145 t = gfc_resolve_expr (sym->value);
9150 gfc_check_assign_symbol (sym, sym->value);
9154 /* Verify the binding labels for common blocks that are BIND(C). The label
9155 for a BIND(C) common block must be identical in all scoping units in which
9156 the common block is declared. Further, the binding label can not collide
9157 with any other global entity in the program. */
9160 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
9162 if (comm_block_tree->n.common->is_bind_c == 1)
9164 gfc_gsymbol *binding_label_gsym;
9165 gfc_gsymbol *comm_name_gsym;
9167 /* See if a global symbol exists by the common block's name. It may
9168 be NULL if the common block is use-associated. */
9169 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
9170 comm_block_tree->n.common->name);
9171 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
9172 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9173 "with the global entity '%s' at %L",
9174 comm_block_tree->n.common->binding_label,
9175 comm_block_tree->n.common->name,
9176 &(comm_block_tree->n.common->where),
9177 comm_name_gsym->name, &(comm_name_gsym->where));
9178 else if (comm_name_gsym != NULL
9179 && strcmp (comm_name_gsym->name,
9180 comm_block_tree->n.common->name) == 0)
9182 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9184 if (comm_name_gsym->binding_label == NULL)
9185 /* No binding label for common block stored yet; save this one. */
9186 comm_name_gsym->binding_label =
9187 comm_block_tree->n.common->binding_label;
9189 if (strcmp (comm_name_gsym->binding_label,
9190 comm_block_tree->n.common->binding_label) != 0)
9192 /* Common block names match but binding labels do not. */
9193 gfc_error ("Binding label '%s' for common block '%s' at %L "
9194 "does not match the binding label '%s' for common "
9196 comm_block_tree->n.common->binding_label,
9197 comm_block_tree->n.common->name,
9198 &(comm_block_tree->n.common->where),
9199 comm_name_gsym->binding_label,
9200 comm_name_gsym->name,
9201 &(comm_name_gsym->where));
9206 /* There is no binding label (NAME="") so we have nothing further to
9207 check and nothing to add as a global symbol for the label. */
9208 if (comm_block_tree->n.common->binding_label[0] == '\0' )
9211 binding_label_gsym =
9212 gfc_find_gsymbol (gfc_gsym_root,
9213 comm_block_tree->n.common->binding_label);
9214 if (binding_label_gsym == NULL)
9216 /* Need to make a global symbol for the binding label to prevent
9217 it from colliding with another. */
9218 binding_label_gsym =
9219 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9220 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9221 binding_label_gsym->type = GSYM_COMMON;
9225 /* If comm_name_gsym is NULL, the name common block is use
9226 associated and the name could be colliding. */
9227 if (binding_label_gsym->type != GSYM_COMMON)
9228 gfc_error ("Binding label '%s' for common block '%s' at %L "
9229 "collides with the global entity '%s' at %L",
9230 comm_block_tree->n.common->binding_label,
9231 comm_block_tree->n.common->name,
9232 &(comm_block_tree->n.common->where),
9233 binding_label_gsym->name,
9234 &(binding_label_gsym->where));
9235 else if (comm_name_gsym != NULL
9236 && (strcmp (binding_label_gsym->name,
9237 comm_name_gsym->binding_label) != 0)
9238 && (strcmp (binding_label_gsym->sym_name,
9239 comm_name_gsym->name) != 0))
9240 gfc_error ("Binding label '%s' for common block '%s' at %L "
9241 "collides with global entity '%s' at %L",
9242 binding_label_gsym->name, binding_label_gsym->sym_name,
9243 &(comm_block_tree->n.common->where),
9244 comm_name_gsym->name, &(comm_name_gsym->where));
9252 /* Verify any BIND(C) derived types in the namespace so we can report errors
9253 for them once, rather than for each variable declared of that type. */
9256 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9258 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9259 && derived_sym->attr.is_bind_c == 1)
9260 verify_bind_c_derived_type (derived_sym);
9266 /* Verify that any binding labels used in a given namespace do not collide
9267 with the names or binding labels of any global symbols. */
9270 gfc_verify_binding_labels (gfc_symbol *sym)
9274 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9275 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
9277 gfc_gsymbol *bind_c_sym;
9279 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9280 if (bind_c_sym != NULL
9281 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9283 if (sym->attr.if_source == IFSRC_DECL
9284 && (bind_c_sym->type != GSYM_SUBROUTINE
9285 && bind_c_sym->type != GSYM_FUNCTION)
9286 && ((sym->attr.contained == 1
9287 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9288 || (sym->attr.use_assoc == 1
9289 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9291 /* Make sure global procedures don't collide with anything. */
9292 gfc_error ("Binding label '%s' at %L collides with the global "
9293 "entity '%s' at %L", sym->binding_label,
9294 &(sym->declared_at), bind_c_sym->name,
9295 &(bind_c_sym->where));
9298 else if (sym->attr.contained == 0
9299 && (sym->attr.if_source == IFSRC_IFBODY
9300 && sym->attr.flavor == FL_PROCEDURE)
9301 && (bind_c_sym->sym_name != NULL
9302 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9304 /* Make sure procedures in interface bodies don't collide. */
9305 gfc_error ("Binding label '%s' in interface body at %L collides "
9306 "with the global entity '%s' at %L",
9308 &(sym->declared_at), bind_c_sym->name,
9309 &(bind_c_sym->where));
9312 else if (sym->attr.contained == 0
9313 && sym->attr.if_source == IFSRC_UNKNOWN)
9314 if ((sym->attr.use_assoc && bind_c_sym->mod_name
9315 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9316 || sym->attr.use_assoc == 0)
9318 gfc_error ("Binding label '%s' at %L collides with global "
9319 "entity '%s' at %L", sym->binding_label,
9320 &(sym->declared_at), bind_c_sym->name,
9321 &(bind_c_sym->where));
9326 /* Clear the binding label to prevent checking multiple times. */
9327 sym->binding_label[0] = '\0';
9329 else if (bind_c_sym == NULL)
9331 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9332 bind_c_sym->where = sym->declared_at;
9333 bind_c_sym->sym_name = sym->name;
9335 if (sym->attr.use_assoc == 1)
9336 bind_c_sym->mod_name = sym->module;
9338 if (sym->ns->proc_name != NULL)
9339 bind_c_sym->mod_name = sym->ns->proc_name->name;
9341 if (sym->attr.contained == 0)
9343 if (sym->attr.subroutine)
9344 bind_c_sym->type = GSYM_SUBROUTINE;
9345 else if (sym->attr.function)
9346 bind_c_sym->type = GSYM_FUNCTION;
9354 /* Resolve an index expression. */
9357 resolve_index_expr (gfc_expr *e)
9359 if (gfc_resolve_expr (e) == FAILURE)
9362 if (gfc_simplify_expr (e, 0) == FAILURE)
9365 if (gfc_specification_expr (e) == FAILURE)
9371 /* Resolve a charlen structure. */
9374 resolve_charlen (gfc_charlen *cl)
9383 specification_expr = 1;
9385 if (resolve_index_expr (cl->length) == FAILURE)
9387 specification_expr = 0;
9391 /* "If the character length parameter value evaluates to a negative
9392 value, the length of character entities declared is zero." */
9393 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9395 if (gfc_option.warn_surprising)
9396 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9397 " the length has been set to zero",
9398 &cl->length->where, i);
9399 gfc_replace_expr (cl->length,
9400 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9403 /* Check that the character length is not too large. */
9404 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9405 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9406 && cl->length->ts.type == BT_INTEGER
9407 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9409 gfc_error ("String length at %L is too large", &cl->length->where);
9417 /* Test for non-constant shape arrays. */
9420 is_non_constant_shape_array (gfc_symbol *sym)
9426 not_constant = false;
9427 if (sym->as != NULL)
9429 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9430 has not been simplified; parameter array references. Do the
9431 simplification now. */
9432 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9434 e = sym->as->lower[i];
9435 if (e && (resolve_index_expr (e) == FAILURE
9436 || !gfc_is_constant_expr (e)))
9437 not_constant = true;
9438 e = sym->as->upper[i];
9439 if (e && (resolve_index_expr (e) == FAILURE
9440 || !gfc_is_constant_expr (e)))
9441 not_constant = true;
9444 return not_constant;
9447 /* Given a symbol and an initialization expression, add code to initialize
9448 the symbol to the function entry. */
9450 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9454 gfc_namespace *ns = sym->ns;
9456 /* Search for the function namespace if this is a contained
9457 function without an explicit result. */
9458 if (sym->attr.function && sym == sym->result
9459 && sym->name != sym->ns->proc_name->name)
9462 for (;ns; ns = ns->sibling)
9463 if (strcmp (ns->proc_name->name, sym->name) == 0)
9469 gfc_free_expr (init);
9473 /* Build an l-value expression for the result. */
9474 lval = gfc_lval_expr_from_sym (sym);
9476 /* Add the code at scope entry. */
9477 init_st = gfc_get_code ();
9478 init_st->next = ns->code;
9481 /* Assign the default initializer to the l-value. */
9482 init_st->loc = sym->declared_at;
9483 init_st->op = EXEC_INIT_ASSIGN;
9484 init_st->expr1 = lval;
9485 init_st->expr2 = init;
9488 /* Assign the default initializer to a derived type variable or result. */
9491 apply_default_init (gfc_symbol *sym)
9493 gfc_expr *init = NULL;
9495 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9498 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
9499 init = gfc_default_initializer (&sym->ts);
9504 build_init_assign (sym, init);
9507 /* Build an initializer for a local integer, real, complex, logical, or
9508 character variable, based on the command line flags finit-local-zero,
9509 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
9510 null if the symbol should not have a default initialization. */
9512 build_default_init_expr (gfc_symbol *sym)
9515 gfc_expr *init_expr;
9518 /* These symbols should never have a default initialization. */
9519 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
9520 || sym->attr.external
9522 || sym->attr.pointer
9523 || sym->attr.in_equivalence
9524 || sym->attr.in_common
9527 || sym->attr.cray_pointee
9528 || sym->attr.cray_pointer)
9531 /* Now we'll try to build an initializer expression. */
9532 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
9535 /* We will only initialize integers, reals, complex, logicals, and
9536 characters, and only if the corresponding command-line flags
9537 were set. Otherwise, we free init_expr and return null. */
9538 switch (sym->ts.type)
9541 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
9542 mpz_set_si (init_expr->value.integer,
9543 gfc_option.flag_init_integer_value);
9546 gfc_free_expr (init_expr);
9552 switch (gfc_option.flag_init_real)
9554 case GFC_INIT_REAL_SNAN:
9555 init_expr->is_snan = 1;
9557 case GFC_INIT_REAL_NAN:
9558 mpfr_set_nan (init_expr->value.real);
9561 case GFC_INIT_REAL_INF:
9562 mpfr_set_inf (init_expr->value.real, 1);
9565 case GFC_INIT_REAL_NEG_INF:
9566 mpfr_set_inf (init_expr->value.real, -1);
9569 case GFC_INIT_REAL_ZERO:
9570 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
9574 gfc_free_expr (init_expr);
9581 switch (gfc_option.flag_init_real)
9583 case GFC_INIT_REAL_SNAN:
9584 init_expr->is_snan = 1;
9586 case GFC_INIT_REAL_NAN:
9587 mpfr_set_nan (mpc_realref (init_expr->value.complex));
9588 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
9591 case GFC_INIT_REAL_INF:
9592 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
9593 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
9596 case GFC_INIT_REAL_NEG_INF:
9597 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
9598 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
9601 case GFC_INIT_REAL_ZERO:
9602 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
9606 gfc_free_expr (init_expr);
9613 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
9614 init_expr->value.logical = 0;
9615 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
9616 init_expr->value.logical = 1;
9619 gfc_free_expr (init_expr);
9625 /* For characters, the length must be constant in order to
9626 create a default initializer. */
9627 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
9628 && sym->ts.u.cl->length
9629 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9631 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
9632 init_expr->value.character.length = char_len;
9633 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
9634 for (i = 0; i < char_len; i++)
9635 init_expr->value.character.string[i]
9636 = (unsigned char) gfc_option.flag_init_character_value;
9640 gfc_free_expr (init_expr);
9646 gfc_free_expr (init_expr);
9652 /* Add an initialization expression to a local variable. */
9654 apply_default_init_local (gfc_symbol *sym)
9656 gfc_expr *init = NULL;
9658 /* The symbol should be a variable or a function return value. */
9659 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9660 || (sym->attr.function && sym->result != sym))
9663 /* Try to build the initializer expression. If we can't initialize
9664 this symbol, then init will be NULL. */
9665 init = build_default_init_expr (sym);
9669 /* For saved variables, we don't want to add an initializer at
9670 function entry, so we just add a static initializer. */
9671 if (sym->attr.save || sym->ns->save_all
9672 || gfc_option.flag_max_stack_var_size == 0)
9674 /* Don't clobber an existing initializer! */
9675 gcc_assert (sym->value == NULL);
9680 build_init_assign (sym, init);
9683 /* Resolution of common features of flavors variable and procedure. */
9686 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
9688 /* Constraints on deferred shape variable. */
9689 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
9691 if (sym->attr.allocatable)
9693 if (sym->attr.dimension)
9695 gfc_error ("Allocatable array '%s' at %L must have "
9696 "a deferred shape", sym->name, &sym->declared_at);
9699 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
9700 "may not be ALLOCATABLE", sym->name,
9701 &sym->declared_at) == FAILURE)
9705 if (sym->attr.pointer && sym->attr.dimension)
9707 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
9708 sym->name, &sym->declared_at);
9714 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
9715 && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc)
9717 gfc_error ("Array '%s' at %L cannot have a deferred shape",
9718 sym->name, &sym->declared_at);
9723 /* Constraints on polymorphic variables. */
9724 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
9727 if (sym->attr.class_ok
9728 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
9730 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
9731 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
9737 /* Assume that use associated symbols were checked in the module ns.
9738 Class-variables that are associate-names are also something special
9739 and excepted from the test. */
9740 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
9742 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
9743 "or pointer", sym->name, &sym->declared_at);
9752 /* Additional checks for symbols with flavor variable and derived
9753 type. To be called from resolve_fl_variable. */
9756 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
9758 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
9760 /* Check to see if a derived type is blocked from being host
9761 associated by the presence of another class I symbol in the same
9762 namespace. 14.6.1.3 of the standard and the discussion on
9763 comp.lang.fortran. */
9764 if (sym->ns != sym->ts.u.derived->ns
9765 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
9768 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
9769 if (s && s->attr.flavor != FL_DERIVED)
9771 gfc_error ("The type '%s' cannot be host associated at %L "
9772 "because it is blocked by an incompatible object "
9773 "of the same name declared at %L",
9774 sym->ts.u.derived->name, &sym->declared_at,
9780 /* 4th constraint in section 11.3: "If an object of a type for which
9781 component-initialization is specified (R429) appears in the
9782 specification-part of a module and does not have the ALLOCATABLE
9783 or POINTER attribute, the object shall have the SAVE attribute."
9785 The check for initializers is performed with
9786 gfc_has_default_initializer because gfc_default_initializer generates
9787 a hidden default for allocatable components. */
9788 if (!(sym->value || no_init_flag) && sym->ns->proc_name
9789 && sym->ns->proc_name->attr.flavor == FL_MODULE
9790 && !sym->ns->save_all && !sym->attr.save
9791 && !sym->attr.pointer && !sym->attr.allocatable
9792 && gfc_has_default_initializer (sym->ts.u.derived)
9793 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
9794 "module variable '%s' at %L, needed due to "
9795 "the default initialization", sym->name,
9796 &sym->declared_at) == FAILURE)
9799 /* Assign default initializer. */
9800 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
9801 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
9803 sym->value = gfc_default_initializer (&sym->ts);
9810 /* Resolve symbols with flavor variable. */
9813 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
9815 int no_init_flag, automatic_flag;
9817 const char *auto_save_msg;
9819 auto_save_msg = "Automatic object '%s' at %L cannot have the "
9822 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9825 /* Set this flag to check that variables are parameters of all entries.
9826 This check is effected by the call to gfc_resolve_expr through
9827 is_non_constant_shape_array. */
9828 specification_expr = 1;
9830 if (sym->ns->proc_name
9831 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9832 || sym->ns->proc_name->attr.is_main_program)
9833 && !sym->attr.use_assoc
9834 && !sym->attr.allocatable
9835 && !sym->attr.pointer
9836 && is_non_constant_shape_array (sym))
9838 /* The shape of a main program or module array needs to be
9840 gfc_error ("The module or main program array '%s' at %L must "
9841 "have constant shape", sym->name, &sym->declared_at);
9842 specification_expr = 0;
9846 if (sym->ts.type == BT_CHARACTER)
9848 /* Make sure that character string variables with assumed length are
9850 e = sym->ts.u.cl->length;
9851 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
9853 gfc_error ("Entity with assumed character length at %L must be a "
9854 "dummy argument or a PARAMETER", &sym->declared_at);
9858 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
9860 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9864 if (!gfc_is_constant_expr (e)
9865 && !(e->expr_type == EXPR_VARIABLE
9866 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
9867 && sym->ns->proc_name
9868 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9869 || sym->ns->proc_name->attr.is_main_program)
9870 && !sym->attr.use_assoc)
9872 gfc_error ("'%s' at %L must have constant character length "
9873 "in this context", sym->name, &sym->declared_at);
9878 if (sym->value == NULL && sym->attr.referenced)
9879 apply_default_init_local (sym); /* Try to apply a default initialization. */
9881 /* Determine if the symbol may not have an initializer. */
9882 no_init_flag = automatic_flag = 0;
9883 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
9884 || sym->attr.intrinsic || sym->attr.result)
9886 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
9887 && is_non_constant_shape_array (sym))
9889 no_init_flag = automatic_flag = 1;
9891 /* Also, they must not have the SAVE attribute.
9892 SAVE_IMPLICIT is checked below. */
9893 if (sym->attr.save == SAVE_EXPLICIT)
9895 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9900 /* Ensure that any initializer is simplified. */
9902 gfc_simplify_expr (sym->value, 1);
9904 /* Reject illegal initializers. */
9905 if (!sym->mark && sym->value)
9907 if (sym->attr.allocatable)
9908 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
9909 sym->name, &sym->declared_at);
9910 else if (sym->attr.external)
9911 gfc_error ("External '%s' at %L cannot have an initializer",
9912 sym->name, &sym->declared_at);
9913 else if (sym->attr.dummy
9914 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
9915 gfc_error ("Dummy '%s' at %L cannot have an initializer",
9916 sym->name, &sym->declared_at);
9917 else if (sym->attr.intrinsic)
9918 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
9919 sym->name, &sym->declared_at);
9920 else if (sym->attr.result)
9921 gfc_error ("Function result '%s' at %L cannot have an initializer",
9922 sym->name, &sym->declared_at);
9923 else if (automatic_flag)
9924 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
9925 sym->name, &sym->declared_at);
9932 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
9933 return resolve_fl_variable_derived (sym, no_init_flag);
9939 /* Resolve a procedure. */
9942 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
9944 gfc_formal_arglist *arg;
9946 if (sym->attr.function
9947 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9950 if (sym->ts.type == BT_CHARACTER)
9952 gfc_charlen *cl = sym->ts.u.cl;
9954 if (cl && cl->length && gfc_is_constant_expr (cl->length)
9955 && resolve_charlen (cl) == FAILURE)
9958 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
9959 && sym->attr.proc == PROC_ST_FUNCTION)
9961 gfc_error ("Character-valued statement function '%s' at %L must "
9962 "have constant length", sym->name, &sym->declared_at);
9967 /* Ensure that derived type for are not of a private type. Internal
9968 module procedures are excluded by 2.2.3.3 - i.e., they are not
9969 externally accessible and can access all the objects accessible in
9971 if (!(sym->ns->parent
9972 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
9973 && gfc_check_access(sym->attr.access, sym->ns->default_access))
9975 gfc_interface *iface;
9977 for (arg = sym->formal; arg; arg = arg->next)
9980 && arg->sym->ts.type == BT_DERIVED
9981 && !arg->sym->ts.u.derived->attr.use_assoc
9982 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
9983 arg->sym->ts.u.derived->ns->default_access)
9984 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
9985 "PRIVATE type and cannot be a dummy argument"
9986 " of '%s', which is PUBLIC at %L",
9987 arg->sym->name, sym->name, &sym->declared_at)
9990 /* Stop this message from recurring. */
9991 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
9996 /* PUBLIC interfaces may expose PRIVATE procedures that take types
9997 PRIVATE to the containing module. */
9998 for (iface = sym->generic; iface; iface = iface->next)
10000 for (arg = iface->sym->formal; arg; arg = arg->next)
10003 && arg->sym->ts.type == BT_DERIVED
10004 && !arg->sym->ts.u.derived->attr.use_assoc
10005 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10006 arg->sym->ts.u.derived->ns->default_access)
10007 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10008 "'%s' in PUBLIC interface '%s' at %L "
10009 "takes dummy arguments of '%s' which is "
10010 "PRIVATE", iface->sym->name, sym->name,
10011 &iface->sym->declared_at,
10012 gfc_typename (&arg->sym->ts)) == FAILURE)
10014 /* Stop this message from recurring. */
10015 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10021 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10022 PRIVATE to the containing module. */
10023 for (iface = sym->generic; iface; iface = iface->next)
10025 for (arg = iface->sym->formal; arg; arg = arg->next)
10028 && arg->sym->ts.type == BT_DERIVED
10029 && !arg->sym->ts.u.derived->attr.use_assoc
10030 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10031 arg->sym->ts.u.derived->ns->default_access)
10032 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10033 "'%s' in PUBLIC interface '%s' at %L "
10034 "takes dummy arguments of '%s' which is "
10035 "PRIVATE", iface->sym->name, sym->name,
10036 &iface->sym->declared_at,
10037 gfc_typename (&arg->sym->ts)) == FAILURE)
10039 /* Stop this message from recurring. */
10040 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10047 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10048 && !sym->attr.proc_pointer)
10050 gfc_error ("Function '%s' at %L cannot have an initializer",
10051 sym->name, &sym->declared_at);
10055 /* An external symbol may not have an initializer because it is taken to be
10056 a procedure. Exception: Procedure Pointers. */
10057 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10059 gfc_error ("External object '%s' at %L may not have an initializer",
10060 sym->name, &sym->declared_at);
10064 /* An elemental function is required to return a scalar 12.7.1 */
10065 if (sym->attr.elemental && sym->attr.function && sym->as)
10067 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10068 "result", sym->name, &sym->declared_at);
10069 /* Reset so that the error only occurs once. */
10070 sym->attr.elemental = 0;
10074 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10075 char-len-param shall not be array-valued, pointer-valued, recursive
10076 or pure. ....snip... A character value of * may only be used in the
10077 following ways: (i) Dummy arg of procedure - dummy associates with
10078 actual length; (ii) To declare a named constant; or (iii) External
10079 function - but length must be declared in calling scoping unit. */
10080 if (sym->attr.function
10081 && sym->ts.type == BT_CHARACTER
10082 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10084 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10085 || (sym->attr.recursive) || (sym->attr.pure))
10087 if (sym->as && sym->as->rank)
10088 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10089 "array-valued", sym->name, &sym->declared_at);
10091 if (sym->attr.pointer)
10092 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10093 "pointer-valued", sym->name, &sym->declared_at);
10095 if (sym->attr.pure)
10096 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10097 "pure", sym->name, &sym->declared_at);
10099 if (sym->attr.recursive)
10100 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10101 "recursive", sym->name, &sym->declared_at);
10106 /* Appendix B.2 of the standard. Contained functions give an
10107 error anyway. Fixed-form is likely to be F77/legacy. */
10108 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
10109 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10110 "CHARACTER(*) function '%s' at %L",
10111 sym->name, &sym->declared_at);
10114 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10116 gfc_formal_arglist *curr_arg;
10117 int has_non_interop_arg = 0;
10119 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10120 sym->common_block) == FAILURE)
10122 /* Clear these to prevent looking at them again if there was an
10124 sym->attr.is_bind_c = 0;
10125 sym->attr.is_c_interop = 0;
10126 sym->ts.is_c_interop = 0;
10130 /* So far, no errors have been found. */
10131 sym->attr.is_c_interop = 1;
10132 sym->ts.is_c_interop = 1;
10135 curr_arg = sym->formal;
10136 while (curr_arg != NULL)
10138 /* Skip implicitly typed dummy args here. */
10139 if (curr_arg->sym->attr.implicit_type == 0)
10140 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
10141 /* If something is found to fail, record the fact so we
10142 can mark the symbol for the procedure as not being
10143 BIND(C) to try and prevent multiple errors being
10145 has_non_interop_arg = 1;
10147 curr_arg = curr_arg->next;
10150 /* See if any of the arguments were not interoperable and if so, clear
10151 the procedure symbol to prevent duplicate error messages. */
10152 if (has_non_interop_arg != 0)
10154 sym->attr.is_c_interop = 0;
10155 sym->ts.is_c_interop = 0;
10156 sym->attr.is_bind_c = 0;
10160 if (!sym->attr.proc_pointer)
10162 if (sym->attr.save == SAVE_EXPLICIT)
10164 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10165 "in '%s' at %L", sym->name, &sym->declared_at);
10168 if (sym->attr.intent)
10170 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10171 "in '%s' at %L", sym->name, &sym->declared_at);
10174 if (sym->attr.subroutine && sym->attr.result)
10176 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10177 "in '%s' at %L", sym->name, &sym->declared_at);
10180 if (sym->attr.external && sym->attr.function
10181 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10182 || sym->attr.contained))
10184 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10185 "in '%s' at %L", sym->name, &sym->declared_at);
10188 if (strcmp ("ppr@", sym->name) == 0)
10190 gfc_error ("Procedure pointer result '%s' at %L "
10191 "is missing the pointer attribute",
10192 sym->ns->proc_name->name, &sym->declared_at);
10201 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10202 been defined and we now know their defined arguments, check that they fulfill
10203 the requirements of the standard for procedures used as finalizers. */
10206 gfc_resolve_finalizers (gfc_symbol* derived)
10208 gfc_finalizer* list;
10209 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10210 gfc_try result = SUCCESS;
10211 bool seen_scalar = false;
10213 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10216 /* Walk over the list of finalizer-procedures, check them, and if any one
10217 does not fit in with the standard's definition, print an error and remove
10218 it from the list. */
10219 prev_link = &derived->f2k_derived->finalizers;
10220 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10226 /* Skip this finalizer if we already resolved it. */
10227 if (list->proc_tree)
10229 prev_link = &(list->next);
10233 /* Check this exists and is a SUBROUTINE. */
10234 if (!list->proc_sym->attr.subroutine)
10236 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10237 list->proc_sym->name, &list->where);
10241 /* We should have exactly one argument. */
10242 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10244 gfc_error ("FINAL procedure at %L must have exactly one argument",
10248 arg = list->proc_sym->formal->sym;
10250 /* This argument must be of our type. */
10251 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10253 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10254 &arg->declared_at, derived->name);
10258 /* It must neither be a pointer nor allocatable nor optional. */
10259 if (arg->attr.pointer)
10261 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10262 &arg->declared_at);
10265 if (arg->attr.allocatable)
10267 gfc_error ("Argument of FINAL procedure at %L must not be"
10268 " ALLOCATABLE", &arg->declared_at);
10271 if (arg->attr.optional)
10273 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10274 &arg->declared_at);
10278 /* It must not be INTENT(OUT). */
10279 if (arg->attr.intent == INTENT_OUT)
10281 gfc_error ("Argument of FINAL procedure at %L must not be"
10282 " INTENT(OUT)", &arg->declared_at);
10286 /* Warn if the procedure is non-scalar and not assumed shape. */
10287 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10288 && arg->as->type != AS_ASSUMED_SHAPE)
10289 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10290 " shape argument", &arg->declared_at);
10292 /* Check that it does not match in kind and rank with a FINAL procedure
10293 defined earlier. To really loop over the *earlier* declarations,
10294 we need to walk the tail of the list as new ones were pushed at the
10296 /* TODO: Handle kind parameters once they are implemented. */
10297 my_rank = (arg->as ? arg->as->rank : 0);
10298 for (i = list->next; i; i = i->next)
10300 /* Argument list might be empty; that is an error signalled earlier,
10301 but we nevertheless continued resolving. */
10302 if (i->proc_sym->formal)
10304 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10305 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10306 if (i_rank == my_rank)
10308 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10309 " rank (%d) as '%s'",
10310 list->proc_sym->name, &list->where, my_rank,
10311 i->proc_sym->name);
10317 /* Is this the/a scalar finalizer procedure? */
10318 if (!arg->as || arg->as->rank == 0)
10319 seen_scalar = true;
10321 /* Find the symtree for this procedure. */
10322 gcc_assert (!list->proc_tree);
10323 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10325 prev_link = &list->next;
10328 /* Remove wrong nodes immediately from the list so we don't risk any
10329 troubles in the future when they might fail later expectations. */
10333 *prev_link = list->next;
10334 gfc_free_finalizer (i);
10337 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10338 were nodes in the list, must have been for arrays. It is surely a good
10339 idea to have a scalar version there if there's something to finalize. */
10340 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10341 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10342 " defined at %L, suggest also scalar one",
10343 derived->name, &derived->declared_at);
10345 /* TODO: Remove this error when finalization is finished. */
10346 gfc_error ("Finalization at %L is not yet implemented",
10347 &derived->declared_at);
10353 /* Check that it is ok for the typebound procedure proc to override the
10357 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
10360 const gfc_symbol* proc_target;
10361 const gfc_symbol* old_target;
10362 unsigned proc_pass_arg, old_pass_arg, argpos;
10363 gfc_formal_arglist* proc_formal;
10364 gfc_formal_arglist* old_formal;
10366 /* This procedure should only be called for non-GENERIC proc. */
10367 gcc_assert (!proc->n.tb->is_generic);
10369 /* If the overwritten procedure is GENERIC, this is an error. */
10370 if (old->n.tb->is_generic)
10372 gfc_error ("Can't overwrite GENERIC '%s' at %L",
10373 old->name, &proc->n.tb->where);
10377 where = proc->n.tb->where;
10378 proc_target = proc->n.tb->u.specific->n.sym;
10379 old_target = old->n.tb->u.specific->n.sym;
10381 /* Check that overridden binding is not NON_OVERRIDABLE. */
10382 if (old->n.tb->non_overridable)
10384 gfc_error ("'%s' at %L overrides a procedure binding declared"
10385 " NON_OVERRIDABLE", proc->name, &where);
10389 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
10390 if (!old->n.tb->deferred && proc->n.tb->deferred)
10392 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
10393 " non-DEFERRED binding", proc->name, &where);
10397 /* If the overridden binding is PURE, the overriding must be, too. */
10398 if (old_target->attr.pure && !proc_target->attr.pure)
10400 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
10401 proc->name, &where);
10405 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
10406 is not, the overriding must not be either. */
10407 if (old_target->attr.elemental && !proc_target->attr.elemental)
10409 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
10410 " ELEMENTAL", proc->name, &where);
10413 if (!old_target->attr.elemental && proc_target->attr.elemental)
10415 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
10416 " be ELEMENTAL, either", proc->name, &where);
10420 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
10422 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
10424 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
10425 " SUBROUTINE", proc->name, &where);
10429 /* If the overridden binding is a FUNCTION, the overriding must also be a
10430 FUNCTION and have the same characteristics. */
10431 if (old_target->attr.function)
10433 if (!proc_target->attr.function)
10435 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
10436 " FUNCTION", proc->name, &where);
10440 /* FIXME: Do more comprehensive checking (including, for instance, the
10441 rank and array-shape). */
10442 gcc_assert (proc_target->result && old_target->result);
10443 if (!gfc_compare_types (&proc_target->result->ts,
10444 &old_target->result->ts))
10446 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
10447 " matching result types", proc->name, &where);
10452 /* If the overridden binding is PUBLIC, the overriding one must not be
10454 if (old->n.tb->access == ACCESS_PUBLIC
10455 && proc->n.tb->access == ACCESS_PRIVATE)
10457 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
10458 " PRIVATE", proc->name, &where);
10462 /* Compare the formal argument lists of both procedures. This is also abused
10463 to find the position of the passed-object dummy arguments of both
10464 bindings as at least the overridden one might not yet be resolved and we
10465 need those positions in the check below. */
10466 proc_pass_arg = old_pass_arg = 0;
10467 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
10469 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
10472 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
10473 proc_formal && old_formal;
10474 proc_formal = proc_formal->next, old_formal = old_formal->next)
10476 if (proc->n.tb->pass_arg
10477 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
10478 proc_pass_arg = argpos;
10479 if (old->n.tb->pass_arg
10480 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
10481 old_pass_arg = argpos;
10483 /* Check that the names correspond. */
10484 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
10486 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
10487 " to match the corresponding argument of the overridden"
10488 " procedure", proc_formal->sym->name, proc->name, &where,
10489 old_formal->sym->name);
10493 /* Check that the types correspond if neither is the passed-object
10495 /* FIXME: Do more comprehensive testing here. */
10496 if (proc_pass_arg != argpos && old_pass_arg != argpos
10497 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
10499 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
10500 "in respect to the overridden procedure",
10501 proc_formal->sym->name, proc->name, &where);
10507 if (proc_formal || old_formal)
10509 gfc_error ("'%s' at %L must have the same number of formal arguments as"
10510 " the overridden procedure", proc->name, &where);
10514 /* If the overridden binding is NOPASS, the overriding one must also be
10516 if (old->n.tb->nopass && !proc->n.tb->nopass)
10518 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
10519 " NOPASS", proc->name, &where);
10523 /* If the overridden binding is PASS(x), the overriding one must also be
10524 PASS and the passed-object dummy arguments must correspond. */
10525 if (!old->n.tb->nopass)
10527 if (proc->n.tb->nopass)
10529 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
10530 " PASS", proc->name, &where);
10534 if (proc_pass_arg != old_pass_arg)
10536 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
10537 " the same position as the passed-object dummy argument of"
10538 " the overridden procedure", proc->name, &where);
10547 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10550 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10551 const char* generic_name, locus where)
10556 gcc_assert (t1->specific && t2->specific);
10557 gcc_assert (!t1->specific->is_generic);
10558 gcc_assert (!t2->specific->is_generic);
10560 sym1 = t1->specific->u.specific->n.sym;
10561 sym2 = t2->specific->u.specific->n.sym;
10566 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10567 if (sym1->attr.subroutine != sym2->attr.subroutine
10568 || sym1->attr.function != sym2->attr.function)
10570 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10571 " GENERIC '%s' at %L",
10572 sym1->name, sym2->name, generic_name, &where);
10576 /* Compare the interfaces. */
10577 if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
10579 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10580 sym1->name, sym2->name, generic_name, &where);
10588 /* Worker function for resolving a generic procedure binding; this is used to
10589 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10591 The difference between those cases is finding possible inherited bindings
10592 that are overridden, as one has to look for them in tb_sym_root,
10593 tb_uop_root or tb_op, respectively. Thus the caller must already find
10594 the super-type and set p->overridden correctly. */
10597 resolve_tb_generic_targets (gfc_symbol* super_type,
10598 gfc_typebound_proc* p, const char* name)
10600 gfc_tbp_generic* target;
10601 gfc_symtree* first_target;
10602 gfc_symtree* inherited;
10604 gcc_assert (p && p->is_generic);
10606 /* Try to find the specific bindings for the symtrees in our target-list. */
10607 gcc_assert (p->u.generic);
10608 for (target = p->u.generic; target; target = target->next)
10609 if (!target->specific)
10611 gfc_typebound_proc* overridden_tbp;
10612 gfc_tbp_generic* g;
10613 const char* target_name;
10615 target_name = target->specific_st->name;
10617 /* Defined for this type directly. */
10618 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
10620 target->specific = target->specific_st->n.tb;
10621 goto specific_found;
10624 /* Look for an inherited specific binding. */
10627 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
10632 gcc_assert (inherited->n.tb);
10633 target->specific = inherited->n.tb;
10634 goto specific_found;
10638 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
10639 " at %L", target_name, name, &p->where);
10642 /* Once we've found the specific binding, check it is not ambiguous with
10643 other specifics already found or inherited for the same GENERIC. */
10645 gcc_assert (target->specific);
10647 /* This must really be a specific binding! */
10648 if (target->specific->is_generic)
10650 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
10651 " '%s' is GENERIC, too", name, &p->where, target_name);
10655 /* Check those already resolved on this type directly. */
10656 for (g = p->u.generic; g; g = g->next)
10657 if (g != target && g->specific
10658 && check_generic_tbp_ambiguity (target, g, name, p->where)
10662 /* Check for ambiguity with inherited specific targets. */
10663 for (overridden_tbp = p->overridden; overridden_tbp;
10664 overridden_tbp = overridden_tbp->overridden)
10665 if (overridden_tbp->is_generic)
10667 for (g = overridden_tbp->u.generic; g; g = g->next)
10669 gcc_assert (g->specific);
10670 if (check_generic_tbp_ambiguity (target, g,
10671 name, p->where) == FAILURE)
10677 /* If we attempt to "overwrite" a specific binding, this is an error. */
10678 if (p->overridden && !p->overridden->is_generic)
10680 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
10681 " the same name", name, &p->where);
10685 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
10686 all must have the same attributes here. */
10687 first_target = p->u.generic->specific->u.specific;
10688 gcc_assert (first_target);
10689 p->subroutine = first_target->n.sym->attr.subroutine;
10690 p->function = first_target->n.sym->attr.function;
10696 /* Resolve a GENERIC procedure binding for a derived type. */
10699 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
10701 gfc_symbol* super_type;
10703 /* Find the overridden binding if any. */
10704 st->n.tb->overridden = NULL;
10705 super_type = gfc_get_derived_super_type (derived);
10708 gfc_symtree* overridden;
10709 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
10712 if (overridden && overridden->n.tb)
10713 st->n.tb->overridden = overridden->n.tb;
10716 /* Resolve using worker function. */
10717 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
10721 /* Retrieve the target-procedure of an operator binding and do some checks in
10722 common for intrinsic and user-defined type-bound operators. */
10725 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
10727 gfc_symbol* target_proc;
10729 gcc_assert (target->specific && !target->specific->is_generic);
10730 target_proc = target->specific->u.specific->n.sym;
10731 gcc_assert (target_proc);
10733 /* All operator bindings must have a passed-object dummy argument. */
10734 if (target->specific->nopass)
10736 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
10740 return target_proc;
10744 /* Resolve a type-bound intrinsic operator. */
10747 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
10748 gfc_typebound_proc* p)
10750 gfc_symbol* super_type;
10751 gfc_tbp_generic* target;
10753 /* If there's already an error here, do nothing (but don't fail again). */
10757 /* Operators should always be GENERIC bindings. */
10758 gcc_assert (p->is_generic);
10760 /* Look for an overridden binding. */
10761 super_type = gfc_get_derived_super_type (derived);
10762 if (super_type && super_type->f2k_derived)
10763 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
10766 p->overridden = NULL;
10768 /* Resolve general GENERIC properties using worker function. */
10769 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
10772 /* Check the targets to be procedures of correct interface. */
10773 for (target = p->u.generic; target; target = target->next)
10775 gfc_symbol* target_proc;
10777 target_proc = get_checked_tb_operator_target (target, p->where);
10781 if (!gfc_check_operator_interface (target_proc, op, p->where))
10793 /* Resolve a type-bound user operator (tree-walker callback). */
10795 static gfc_symbol* resolve_bindings_derived;
10796 static gfc_try resolve_bindings_result;
10798 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
10801 resolve_typebound_user_op (gfc_symtree* stree)
10803 gfc_symbol* super_type;
10804 gfc_tbp_generic* target;
10806 gcc_assert (stree && stree->n.tb);
10808 if (stree->n.tb->error)
10811 /* Operators should always be GENERIC bindings. */
10812 gcc_assert (stree->n.tb->is_generic);
10814 /* Find overridden procedure, if any. */
10815 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10816 if (super_type && super_type->f2k_derived)
10818 gfc_symtree* overridden;
10819 overridden = gfc_find_typebound_user_op (super_type, NULL,
10820 stree->name, true, NULL);
10822 if (overridden && overridden->n.tb)
10823 stree->n.tb->overridden = overridden->n.tb;
10826 stree->n.tb->overridden = NULL;
10828 /* Resolve basically using worker function. */
10829 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
10833 /* Check the targets to be functions of correct interface. */
10834 for (target = stree->n.tb->u.generic; target; target = target->next)
10836 gfc_symbol* target_proc;
10838 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
10842 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
10849 resolve_bindings_result = FAILURE;
10850 stree->n.tb->error = 1;
10854 /* Resolve the type-bound procedures for a derived type. */
10857 resolve_typebound_procedure (gfc_symtree* stree)
10861 gfc_symbol* me_arg;
10862 gfc_symbol* super_type;
10863 gfc_component* comp;
10865 gcc_assert (stree);
10867 /* Undefined specific symbol from GENERIC target definition. */
10871 if (stree->n.tb->error)
10874 /* If this is a GENERIC binding, use that routine. */
10875 if (stree->n.tb->is_generic)
10877 if (resolve_typebound_generic (resolve_bindings_derived, stree)
10883 /* Get the target-procedure to check it. */
10884 gcc_assert (!stree->n.tb->is_generic);
10885 gcc_assert (stree->n.tb->u.specific);
10886 proc = stree->n.tb->u.specific->n.sym;
10887 where = stree->n.tb->where;
10889 /* Default access should already be resolved from the parser. */
10890 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
10892 /* It should be a module procedure or an external procedure with explicit
10893 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
10894 if ((!proc->attr.subroutine && !proc->attr.function)
10895 || (proc->attr.proc != PROC_MODULE
10896 && proc->attr.if_source != IFSRC_IFBODY)
10897 || (proc->attr.abstract && !stree->n.tb->deferred))
10899 gfc_error ("'%s' must be a module procedure or an external procedure with"
10900 " an explicit interface at %L", proc->name, &where);
10903 stree->n.tb->subroutine = proc->attr.subroutine;
10904 stree->n.tb->function = proc->attr.function;
10906 /* Find the super-type of the current derived type. We could do this once and
10907 store in a global if speed is needed, but as long as not I believe this is
10908 more readable and clearer. */
10909 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10911 /* If PASS, resolve and check arguments if not already resolved / loaded
10912 from a .mod file. */
10913 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
10915 if (stree->n.tb->pass_arg)
10917 gfc_formal_arglist* i;
10919 /* If an explicit passing argument name is given, walk the arg-list
10920 and look for it. */
10923 stree->n.tb->pass_arg_num = 1;
10924 for (i = proc->formal; i; i = i->next)
10926 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
10931 ++stree->n.tb->pass_arg_num;
10936 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
10938 proc->name, stree->n.tb->pass_arg, &where,
10939 stree->n.tb->pass_arg);
10945 /* Otherwise, take the first one; there should in fact be at least
10947 stree->n.tb->pass_arg_num = 1;
10950 gfc_error ("Procedure '%s' with PASS at %L must have at"
10951 " least one argument", proc->name, &where);
10954 me_arg = proc->formal->sym;
10957 /* Now check that the argument-type matches and the passed-object
10958 dummy argument is generally fine. */
10960 gcc_assert (me_arg);
10962 if (me_arg->ts.type != BT_CLASS)
10964 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
10965 " at %L", proc->name, &where);
10969 if (CLASS_DATA (me_arg)->ts.u.derived
10970 != resolve_bindings_derived)
10972 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
10973 " the derived-type '%s'", me_arg->name, proc->name,
10974 me_arg->name, &where, resolve_bindings_derived->name);
10978 gcc_assert (me_arg->ts.type == BT_CLASS);
10979 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
10981 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
10982 " scalar", proc->name, &where);
10985 if (CLASS_DATA (me_arg)->attr.allocatable)
10987 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
10988 " be ALLOCATABLE", proc->name, &where);
10991 if (CLASS_DATA (me_arg)->attr.class_pointer)
10993 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
10994 " be POINTER", proc->name, &where);
10999 /* If we are extending some type, check that we don't override a procedure
11000 flagged NON_OVERRIDABLE. */
11001 stree->n.tb->overridden = NULL;
11004 gfc_symtree* overridden;
11005 overridden = gfc_find_typebound_proc (super_type, NULL,
11006 stree->name, true, NULL);
11008 if (overridden && overridden->n.tb)
11009 stree->n.tb->overridden = overridden->n.tb;
11011 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
11015 /* See if there's a name collision with a component directly in this type. */
11016 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11017 if (!strcmp (comp->name, stree->name))
11019 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11021 stree->name, &where, resolve_bindings_derived->name);
11025 /* Try to find a name collision with an inherited component. */
11026 if (super_type && gfc_find_component (super_type, stree->name, true, true))
11028 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11029 " component of '%s'",
11030 stree->name, &where, resolve_bindings_derived->name);
11034 stree->n.tb->error = 0;
11038 resolve_bindings_result = FAILURE;
11039 stree->n.tb->error = 1;
11043 resolve_typebound_procedures (gfc_symbol* derived)
11047 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11050 resolve_bindings_derived = derived;
11051 resolve_bindings_result = SUCCESS;
11053 if (derived->f2k_derived->tb_sym_root)
11054 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11055 &resolve_typebound_procedure);
11057 if (derived->f2k_derived->tb_uop_root)
11058 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11059 &resolve_typebound_user_op);
11061 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11063 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11064 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11066 resolve_bindings_result = FAILURE;
11069 return resolve_bindings_result;
11073 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11074 to give all identical derived types the same backend_decl. */
11076 add_dt_to_dt_list (gfc_symbol *derived)
11078 gfc_dt_list *dt_list;
11080 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11081 if (derived == dt_list->derived)
11084 if (dt_list == NULL)
11086 dt_list = gfc_get_dt_list ();
11087 dt_list->next = gfc_derived_types;
11088 dt_list->derived = derived;
11089 gfc_derived_types = dt_list;
11094 /* Ensure that a derived-type is really not abstract, meaning that every
11095 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11098 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11103 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11105 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11108 if (st->n.tb && st->n.tb->deferred)
11110 gfc_symtree* overriding;
11111 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11114 gcc_assert (overriding->n.tb);
11115 if (overriding->n.tb->deferred)
11117 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11118 " '%s' is DEFERRED and not overridden",
11119 sub->name, &sub->declared_at, st->name);
11128 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11130 /* The algorithm used here is to recursively travel up the ancestry of sub
11131 and for each ancestor-type, check all bindings. If any of them is
11132 DEFERRED, look it up starting from sub and see if the found (overriding)
11133 binding is not DEFERRED.
11134 This is not the most efficient way to do this, but it should be ok and is
11135 clearer than something sophisticated. */
11137 gcc_assert (ancestor && !sub->attr.abstract);
11139 if (!ancestor->attr.abstract)
11142 /* Walk bindings of this ancestor. */
11143 if (ancestor->f2k_derived)
11146 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11151 /* Find next ancestor type and recurse on it. */
11152 ancestor = gfc_get_derived_super_type (ancestor);
11154 return ensure_not_abstract (sub, ancestor);
11160 /* Resolve the components of a derived type. */
11163 resolve_fl_derived (gfc_symbol *sym)
11165 gfc_symbol* super_type;
11168 super_type = gfc_get_derived_super_type (sym);
11170 if (sym->attr.is_class && sym->ts.u.derived == NULL)
11172 /* Fix up incomplete CLASS symbols. */
11173 gfc_component *data = gfc_find_component (sym, "$data", true, true);
11174 gfc_component *vptr = gfc_find_component (sym, "$vptr", true, true);
11175 if (vptr->ts.u.derived == NULL)
11177 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
11179 vptr->ts.u.derived = vtab->ts.u.derived;
11184 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11186 gfc_error ("As extending type '%s' at %L has a coarray component, "
11187 "parent type '%s' shall also have one", sym->name,
11188 &sym->declared_at, super_type->name);
11192 /* Ensure the extended type gets resolved before we do. */
11193 if (super_type && resolve_fl_derived (super_type) == FAILURE)
11196 /* An ABSTRACT type must be extensible. */
11197 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11199 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11200 sym->name, &sym->declared_at);
11204 for (c = sym->components; c != NULL; c = c->next)
11207 if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */
11208 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11210 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11211 "deferred shape", c->name, &c->loc);
11216 if (c->attr.codimension && c->ts.type == BT_DERIVED
11217 && c->ts.u.derived->ts.is_iso_c)
11219 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11220 "shall not be a coarray", c->name, &c->loc);
11225 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11226 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11227 || c->attr.allocatable))
11229 gfc_error ("Component '%s' at %L with coarray component "
11230 "shall be a nonpointer, nonallocatable scalar",
11236 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11238 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11239 "is not an array pointer", c->name, &c->loc);
11243 if (c->attr.proc_pointer && c->ts.interface)
11245 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11246 gfc_error ("Interface '%s', used by procedure pointer component "
11247 "'%s' at %L, is declared in a later PROCEDURE statement",
11248 c->ts.interface->name, c->name, &c->loc);
11250 /* Get the attributes from the interface (now resolved). */
11251 if (c->ts.interface->attr.if_source
11252 || c->ts.interface->attr.intrinsic)
11254 gfc_symbol *ifc = c->ts.interface;
11256 if (ifc->formal && !ifc->formal_ns)
11257 resolve_symbol (ifc);
11259 if (ifc->attr.intrinsic)
11260 resolve_intrinsic (ifc, &ifc->declared_at);
11264 c->ts = ifc->result->ts;
11265 c->attr.allocatable = ifc->result->attr.allocatable;
11266 c->attr.pointer = ifc->result->attr.pointer;
11267 c->attr.dimension = ifc->result->attr.dimension;
11268 c->as = gfc_copy_array_spec (ifc->result->as);
11273 c->attr.allocatable = ifc->attr.allocatable;
11274 c->attr.pointer = ifc->attr.pointer;
11275 c->attr.dimension = ifc->attr.dimension;
11276 c->as = gfc_copy_array_spec (ifc->as);
11278 c->ts.interface = ifc;
11279 c->attr.function = ifc->attr.function;
11280 c->attr.subroutine = ifc->attr.subroutine;
11281 gfc_copy_formal_args_ppc (c, ifc);
11283 c->attr.pure = ifc->attr.pure;
11284 c->attr.elemental = ifc->attr.elemental;
11285 c->attr.recursive = ifc->attr.recursive;
11286 c->attr.always_explicit = ifc->attr.always_explicit;
11287 c->attr.ext_attr |= ifc->attr.ext_attr;
11288 /* Replace symbols in array spec. */
11292 for (i = 0; i < c->as->rank; i++)
11294 gfc_expr_replace_comp (c->as->lower[i], c);
11295 gfc_expr_replace_comp (c->as->upper[i], c);
11298 /* Copy char length. */
11299 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11301 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11302 gfc_expr_replace_comp (cl->length, c);
11303 if (cl->length && !cl->resolved
11304 && gfc_resolve_expr (cl->length) == FAILURE)
11309 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11311 gfc_error ("Interface '%s' of procedure pointer component "
11312 "'%s' at %L must be explicit", c->ts.interface->name,
11317 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11319 /* Since PPCs are not implicitly typed, a PPC without an explicit
11320 interface must be a subroutine. */
11321 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11324 /* Procedure pointer components: Check PASS arg. */
11325 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11326 && !sym->attr.vtype)
11328 gfc_symbol* me_arg;
11330 if (c->tb->pass_arg)
11332 gfc_formal_arglist* i;
11334 /* If an explicit passing argument name is given, walk the arg-list
11335 and look for it. */
11338 c->tb->pass_arg_num = 1;
11339 for (i = c->formal; i; i = i->next)
11341 if (!strcmp (i->sym->name, c->tb->pass_arg))
11346 c->tb->pass_arg_num++;
11351 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11352 "at %L has no argument '%s'", c->name,
11353 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11360 /* Otherwise, take the first one; there should in fact be at least
11362 c->tb->pass_arg_num = 1;
11365 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11366 "must have at least one argument",
11371 me_arg = c->formal->sym;
11374 /* Now check that the argument-type matches. */
11375 gcc_assert (me_arg);
11376 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11377 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11378 || (me_arg->ts.type == BT_CLASS
11379 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11381 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11382 " the derived type '%s'", me_arg->name, c->name,
11383 me_arg->name, &c->loc, sym->name);
11388 /* Check for C453. */
11389 if (me_arg->attr.dimension)
11391 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11392 "must be scalar", me_arg->name, c->name, me_arg->name,
11398 if (me_arg->attr.pointer)
11400 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11401 "may not have the POINTER attribute", me_arg->name,
11402 c->name, me_arg->name, &c->loc);
11407 if (me_arg->attr.allocatable)
11409 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11410 "may not be ALLOCATABLE", me_arg->name, c->name,
11411 me_arg->name, &c->loc);
11416 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11417 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11418 " at %L", c->name, &c->loc);
11422 /* Check type-spec if this is not the parent-type component. */
11423 if ((!sym->attr.extension || c != sym->components)
11424 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11427 /* If this type is an extension, set the accessibility of the parent
11429 if (super_type && c == sym->components
11430 && strcmp (super_type->name, c->name) == 0)
11431 c->attr.access = super_type->attr.access;
11433 /* If this type is an extension, see if this component has the same name
11434 as an inherited type-bound procedure. */
11435 if (super_type && !sym->attr.is_class
11436 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11438 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11439 " inherited type-bound procedure",
11440 c->name, sym->name, &c->loc);
11444 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
11446 if (c->ts.u.cl->length == NULL
11447 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11448 || !gfc_is_constant_expr (c->ts.u.cl->length))
11450 gfc_error ("Character length of component '%s' needs to "
11451 "be a constant specification expression at %L",
11453 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11458 if (c->ts.type == BT_DERIVED
11459 && sym->component_access != ACCESS_PRIVATE
11460 && gfc_check_access (sym->attr.access, sym->ns->default_access)
11461 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11462 && !c->ts.u.derived->attr.use_assoc
11463 && !gfc_check_access (c->ts.u.derived->attr.access,
11464 c->ts.u.derived->ns->default_access)
11465 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11466 "is a PRIVATE type and cannot be a component of "
11467 "'%s', which is PUBLIC at %L", c->name,
11468 sym->name, &sym->declared_at) == FAILURE)
11471 if (sym->attr.sequence)
11473 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11475 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11476 "not have the SEQUENCE attribute",
11477 c->ts.u.derived->name, &sym->declared_at);
11482 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && c->attr.pointer
11483 && c->ts.u.derived->components == NULL
11484 && !c->ts.u.derived->attr.zero_comp)
11486 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11487 "that has not been declared", c->name, sym->name,
11492 if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer
11493 && CLASS_DATA (c)->ts.u.derived->components == NULL
11494 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11496 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11497 "that has not been declared", c->name, sym->name,
11503 if (c->ts.type == BT_CLASS
11504 && !(CLASS_DATA (c)->attr.class_pointer
11505 || CLASS_DATA (c)->attr.allocatable))
11507 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11508 "or pointer", c->name, &c->loc);
11512 /* Ensure that all the derived type components are put on the
11513 derived type list; even in formal namespaces, where derived type
11514 pointer components might not have been declared. */
11515 if (c->ts.type == BT_DERIVED
11517 && c->ts.u.derived->components
11519 && sym != c->ts.u.derived)
11520 add_dt_to_dt_list (c->ts.u.derived);
11522 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11523 || c->attr.proc_pointer
11524 || c->attr.allocatable)) == FAILURE)
11528 /* Resolve the type-bound procedures. */
11529 if (resolve_typebound_procedures (sym) == FAILURE)
11532 /* Resolve the finalizer procedures. */
11533 if (gfc_resolve_finalizers (sym) == FAILURE)
11536 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11537 all DEFERRED bindings are overridden. */
11538 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11539 && !sym->attr.is_class
11540 && ensure_not_abstract (sym, super_type) == FAILURE)
11543 /* Add derived type to the derived type list. */
11544 add_dt_to_dt_list (sym);
11551 resolve_fl_namelist (gfc_symbol *sym)
11556 /* Reject PRIVATE objects in a PUBLIC namelist. */
11557 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
11559 for (nl = sym->namelist; nl; nl = nl->next)
11561 if (!nl->sym->attr.use_assoc
11562 && !is_sym_host_assoc (nl->sym, sym->ns)
11563 && !gfc_check_access(nl->sym->attr.access,
11564 nl->sym->ns->default_access))
11566 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
11567 "cannot be member of PUBLIC namelist '%s' at %L",
11568 nl->sym->name, sym->name, &sym->declared_at);
11572 /* Types with private components that came here by USE-association. */
11573 if (nl->sym->ts.type == BT_DERIVED
11574 && derived_inaccessible (nl->sym->ts.u.derived))
11576 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
11577 "components and cannot be member of namelist '%s' at %L",
11578 nl->sym->name, sym->name, &sym->declared_at);
11582 /* Types with private components that are defined in the same module. */
11583 if (nl->sym->ts.type == BT_DERIVED
11584 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
11585 && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
11586 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
11587 nl->sym->ns->default_access))
11589 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
11590 "cannot be a member of PUBLIC namelist '%s' at %L",
11591 nl->sym->name, sym->name, &sym->declared_at);
11597 for (nl = sym->namelist; nl; nl = nl->next)
11599 /* Reject namelist arrays of assumed shape. */
11600 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
11601 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
11602 "must not have assumed shape in namelist "
11603 "'%s' at %L", nl->sym->name, sym->name,
11604 &sym->declared_at) == FAILURE)
11607 /* Reject namelist arrays that are not constant shape. */
11608 if (is_non_constant_shape_array (nl->sym))
11610 gfc_error ("NAMELIST array object '%s' must have constant "
11611 "shape in namelist '%s' at %L", nl->sym->name,
11612 sym->name, &sym->declared_at);
11616 /* Namelist objects cannot have allocatable or pointer components. */
11617 if (nl->sym->ts.type != BT_DERIVED)
11620 if (nl->sym->ts.u.derived->attr.alloc_comp)
11622 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11623 "have ALLOCATABLE components",
11624 nl->sym->name, sym->name, &sym->declared_at);
11628 if (nl->sym->ts.u.derived->attr.pointer_comp)
11630 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11631 "have POINTER components",
11632 nl->sym->name, sym->name, &sym->declared_at);
11638 /* 14.1.2 A module or internal procedure represent local entities
11639 of the same type as a namelist member and so are not allowed. */
11640 for (nl = sym->namelist; nl; nl = nl->next)
11642 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
11645 if (nl->sym->attr.function && nl->sym == nl->sym->result)
11646 if ((nl->sym == sym->ns->proc_name)
11648 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
11652 if (nl->sym && nl->sym->name)
11653 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
11654 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
11656 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
11657 "attribute in '%s' at %L", nlsym->name,
11658 &sym->declared_at);
11668 resolve_fl_parameter (gfc_symbol *sym)
11670 /* A parameter array's shape needs to be constant. */
11671 if (sym->as != NULL
11672 && (sym->as->type == AS_DEFERRED
11673 || is_non_constant_shape_array (sym)))
11675 gfc_error ("Parameter array '%s' at %L cannot be automatic "
11676 "or of deferred shape", sym->name, &sym->declared_at);
11680 /* Make sure a parameter that has been implicitly typed still
11681 matches the implicit type, since PARAMETER statements can precede
11682 IMPLICIT statements. */
11683 if (sym->attr.implicit_type
11684 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
11687 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
11688 "later IMPLICIT type", sym->name, &sym->declared_at);
11692 /* Make sure the types of derived parameters are consistent. This
11693 type checking is deferred until resolution because the type may
11694 refer to a derived type from the host. */
11695 if (sym->ts.type == BT_DERIVED
11696 && !gfc_compare_types (&sym->ts, &sym->value->ts))
11698 gfc_error ("Incompatible derived type in PARAMETER at %L",
11699 &sym->value->where);
11706 /* Do anything necessary to resolve a symbol. Right now, we just
11707 assume that an otherwise unknown symbol is a variable. This sort
11708 of thing commonly happens for symbols in module. */
11711 resolve_symbol (gfc_symbol *sym)
11713 int check_constant, mp_flag;
11714 gfc_symtree *symtree;
11715 gfc_symtree *this_symtree;
11719 /* Avoid double resolution of function result symbols. */
11720 if ((sym->result || sym->attr.result) && !sym->attr.dummy
11721 && (sym->ns != gfc_current_ns))
11724 if (sym->attr.flavor == FL_UNKNOWN)
11727 /* If we find that a flavorless symbol is an interface in one of the
11728 parent namespaces, find its symtree in this namespace, free the
11729 symbol and set the symtree to point to the interface symbol. */
11730 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
11732 symtree = gfc_find_symtree (ns->sym_root, sym->name);
11733 if (symtree && symtree->n.sym->generic)
11735 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
11737 gfc_release_symbol (sym);
11738 symtree->n.sym->refs++;
11739 this_symtree->n.sym = symtree->n.sym;
11744 /* Otherwise give it a flavor according to such attributes as
11746 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
11747 sym->attr.flavor = FL_VARIABLE;
11750 sym->attr.flavor = FL_PROCEDURE;
11751 if (sym->attr.dimension)
11752 sym->attr.function = 1;
11756 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
11757 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
11759 if (sym->attr.procedure && sym->ts.interface
11760 && sym->attr.if_source != IFSRC_DECL
11761 && resolve_procedure_interface (sym) == FAILURE)
11764 if (sym->attr.is_protected && !sym->attr.proc_pointer
11765 && (sym->attr.procedure || sym->attr.external))
11767 if (sym->attr.external)
11768 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
11769 "at %L", &sym->declared_at);
11771 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
11772 "at %L", &sym->declared_at);
11779 if (sym->attr.contiguous
11780 && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE
11781 && !sym->attr.pointer)))
11783 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
11784 "array pointer or an assumed-shape array", sym->name,
11785 &sym->declared_at);
11789 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
11792 /* Symbols that are module procedures with results (functions) have
11793 the types and array specification copied for type checking in
11794 procedures that call them, as well as for saving to a module
11795 file. These symbols can't stand the scrutiny that their results
11797 mp_flag = (sym->result != NULL && sym->result != sym);
11799 /* Make sure that the intrinsic is consistent with its internal
11800 representation. This needs to be done before assigning a default
11801 type to avoid spurious warnings. */
11802 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
11803 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
11806 /* Resolve associate names. */
11808 resolve_assoc_var (sym, true);
11810 /* Assign default type to symbols that need one and don't have one. */
11811 if (sym->ts.type == BT_UNKNOWN)
11813 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
11814 gfc_set_default_type (sym, 1, NULL);
11816 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
11817 && !sym->attr.function && !sym->attr.subroutine
11818 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
11819 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
11821 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
11823 /* The specific case of an external procedure should emit an error
11824 in the case that there is no implicit type. */
11826 gfc_set_default_type (sym, sym->attr.external, NULL);
11829 /* Result may be in another namespace. */
11830 resolve_symbol (sym->result);
11832 if (!sym->result->attr.proc_pointer)
11834 sym->ts = sym->result->ts;
11835 sym->as = gfc_copy_array_spec (sym->result->as);
11836 sym->attr.dimension = sym->result->attr.dimension;
11837 sym->attr.pointer = sym->result->attr.pointer;
11838 sym->attr.allocatable = sym->result->attr.allocatable;
11839 sym->attr.contiguous = sym->result->attr.contiguous;
11845 /* Assumed size arrays and assumed shape arrays must be dummy
11846 arguments. Array-spec's of implied-shape should have been resolved to
11847 AS_EXPLICIT already. */
11851 gcc_assert (sym->as->type != AS_IMPLIED_SHAPE);
11852 if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
11853 || sym->as->type == AS_ASSUMED_SHAPE)
11854 && sym->attr.dummy == 0)
11856 if (sym->as->type == AS_ASSUMED_SIZE)
11857 gfc_error ("Assumed size array at %L must be a dummy argument",
11858 &sym->declared_at);
11860 gfc_error ("Assumed shape array at %L must be a dummy argument",
11861 &sym->declared_at);
11866 /* Make sure symbols with known intent or optional are really dummy
11867 variable. Because of ENTRY statement, this has to be deferred
11868 until resolution time. */
11870 if (!sym->attr.dummy
11871 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
11873 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
11877 if (sym->attr.value && !sym->attr.dummy)
11879 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
11880 "it is not a dummy argument", sym->name, &sym->declared_at);
11884 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
11886 gfc_charlen *cl = sym->ts.u.cl;
11887 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
11889 gfc_error ("Character dummy variable '%s' at %L with VALUE "
11890 "attribute must have constant length",
11891 sym->name, &sym->declared_at);
11895 if (sym->ts.is_c_interop
11896 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
11898 gfc_error ("C interoperable character dummy variable '%s' at %L "
11899 "with VALUE attribute must have length one",
11900 sym->name, &sym->declared_at);
11905 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
11906 do this for something that was implicitly typed because that is handled
11907 in gfc_set_default_type. Handle dummy arguments and procedure
11908 definitions separately. Also, anything that is use associated is not
11909 handled here but instead is handled in the module it is declared in.
11910 Finally, derived type definitions are allowed to be BIND(C) since that
11911 only implies that they're interoperable, and they are checked fully for
11912 interoperability when a variable is declared of that type. */
11913 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
11914 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
11915 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
11917 gfc_try t = SUCCESS;
11919 /* First, make sure the variable is declared at the
11920 module-level scope (J3/04-007, Section 15.3). */
11921 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
11922 sym->attr.in_common == 0)
11924 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
11925 "is neither a COMMON block nor declared at the "
11926 "module level scope", sym->name, &(sym->declared_at));
11929 else if (sym->common_head != NULL)
11931 t = verify_com_block_vars_c_interop (sym->common_head);
11935 /* If type() declaration, we need to verify that the components
11936 of the given type are all C interoperable, etc. */
11937 if (sym->ts.type == BT_DERIVED &&
11938 sym->ts.u.derived->attr.is_c_interop != 1)
11940 /* Make sure the user marked the derived type as BIND(C). If
11941 not, call the verify routine. This could print an error
11942 for the derived type more than once if multiple variables
11943 of that type are declared. */
11944 if (sym->ts.u.derived->attr.is_bind_c != 1)
11945 verify_bind_c_derived_type (sym->ts.u.derived);
11949 /* Verify the variable itself as C interoperable if it
11950 is BIND(C). It is not possible for this to succeed if
11951 the verify_bind_c_derived_type failed, so don't have to handle
11952 any error returned by verify_bind_c_derived_type. */
11953 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
11954 sym->common_block);
11959 /* clear the is_bind_c flag to prevent reporting errors more than
11960 once if something failed. */
11961 sym->attr.is_bind_c = 0;
11966 /* If a derived type symbol has reached this point, without its
11967 type being declared, we have an error. Notice that most
11968 conditions that produce undefined derived types have already
11969 been dealt with. However, the likes of:
11970 implicit type(t) (t) ..... call foo (t) will get us here if
11971 the type is not declared in the scope of the implicit
11972 statement. Change the type to BT_UNKNOWN, both because it is so
11973 and to prevent an ICE. */
11974 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
11975 && !sym->ts.u.derived->attr.zero_comp)
11977 gfc_error ("The derived type '%s' at %L is of type '%s', "
11978 "which has not been defined", sym->name,
11979 &sym->declared_at, sym->ts.u.derived->name);
11980 sym->ts.type = BT_UNKNOWN;
11984 /* Make sure that the derived type has been resolved and that the
11985 derived type is visible in the symbol's namespace, if it is a
11986 module function and is not PRIVATE. */
11987 if (sym->ts.type == BT_DERIVED
11988 && sym->ts.u.derived->attr.use_assoc
11989 && sym->ns->proc_name
11990 && sym->ns->proc_name->attr.flavor == FL_MODULE)
11994 if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
11997 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
11998 if (!ds && sym->attr.function
11999 && gfc_check_access (sym->attr.access, sym->ns->default_access))
12001 symtree = gfc_new_symtree (&sym->ns->sym_root,
12002 sym->ts.u.derived->name);
12003 symtree->n.sym = sym->ts.u.derived;
12004 sym->ts.u.derived->refs++;
12008 /* Unless the derived-type declaration is use associated, Fortran 95
12009 does not allow public entries of private derived types.
12010 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12011 161 in 95-006r3. */
12012 if (sym->ts.type == BT_DERIVED
12013 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12014 && !sym->ts.u.derived->attr.use_assoc
12015 && gfc_check_access (sym->attr.access, sym->ns->default_access)
12016 && !gfc_check_access (sym->ts.u.derived->attr.access,
12017 sym->ts.u.derived->ns->default_access)
12018 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12019 "of PRIVATE derived type '%s'",
12020 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12021 : "variable", sym->name, &sym->declared_at,
12022 sym->ts.u.derived->name) == FAILURE)
12025 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12026 default initialization is defined (5.1.2.4.4). */
12027 if (sym->ts.type == BT_DERIVED
12029 && sym->attr.intent == INTENT_OUT
12031 && sym->as->type == AS_ASSUMED_SIZE)
12033 for (c = sym->ts.u.derived->components; c; c = c->next)
12035 if (c->initializer)
12037 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12038 "ASSUMED SIZE and so cannot have a default initializer",
12039 sym->name, &sym->declared_at);
12046 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12047 || sym->attr.codimension)
12048 && sym->attr.result)
12049 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12050 "a coarray component", sym->name, &sym->declared_at);
12053 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12054 && sym->ts.u.derived->ts.is_iso_c)
12055 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12056 "shall not be a coarray", sym->name, &sym->declared_at);
12059 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
12060 && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
12061 || sym->attr.allocatable))
12062 gfc_error ("Variable '%s' at %L with coarray component "
12063 "shall be a nonpointer, nonallocatable scalar",
12064 sym->name, &sym->declared_at);
12066 /* F2008, C526. The function-result case was handled above. */
12067 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12068 || sym->attr.codimension)
12069 && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
12070 || sym->ns->proc_name->attr.flavor == FL_MODULE
12071 || sym->ns->proc_name->attr.is_main_program
12072 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12073 gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
12074 "component and is not ALLOCATABLE, SAVE nor a "
12075 "dummy argument", sym->name, &sym->declared_at);
12076 /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
12077 else if (sym->attr.codimension && !sym->attr.allocatable
12078 && sym->as && sym->as->cotype == AS_DEFERRED)
12079 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12080 "deferred shape", sym->name, &sym->declared_at);
12081 else if (sym->attr.codimension && sym->attr.allocatable
12082 && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
12083 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12084 "deferred shape", sym->name, &sym->declared_at);
12088 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12089 || (sym->attr.codimension && sym->attr.allocatable))
12090 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12091 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12092 "allocatable coarray or have coarray components",
12093 sym->name, &sym->declared_at);
12095 if (sym->attr.codimension && sym->attr.dummy
12096 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12097 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12098 "procedure '%s'", sym->name, &sym->declared_at,
12099 sym->ns->proc_name->name);
12101 switch (sym->attr.flavor)
12104 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12109 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12114 if (resolve_fl_namelist (sym) == FAILURE)
12119 if (resolve_fl_parameter (sym) == FAILURE)
12127 /* Resolve array specifier. Check as well some constraints
12128 on COMMON blocks. */
12130 check_constant = sym->attr.in_common && !sym->attr.pointer;
12132 /* Set the formal_arg_flag so that check_conflict will not throw
12133 an error for host associated variables in the specification
12134 expression for an array_valued function. */
12135 if (sym->attr.function && sym->as)
12136 formal_arg_flag = 1;
12138 gfc_resolve_array_spec (sym->as, check_constant);
12140 formal_arg_flag = 0;
12142 /* Resolve formal namespaces. */
12143 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12144 && !sym->attr.contained && !sym->attr.intrinsic)
12145 gfc_resolve (sym->formal_ns);
12147 /* Make sure the formal namespace is present. */
12148 if (sym->formal && !sym->formal_ns)
12150 gfc_formal_arglist *formal = sym->formal;
12151 while (formal && !formal->sym)
12152 formal = formal->next;
12156 sym->formal_ns = formal->sym->ns;
12157 sym->formal_ns->refs++;
12161 /* Check threadprivate restrictions. */
12162 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12163 && (!sym->attr.in_common
12164 && sym->module == NULL
12165 && (sym->ns->proc_name == NULL
12166 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12167 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12169 /* If we have come this far we can apply default-initializers, as
12170 described in 14.7.5, to those variables that have not already
12171 been assigned one. */
12172 if (sym->ts.type == BT_DERIVED
12173 && sym->attr.referenced
12174 && sym->ns == gfc_current_ns
12176 && !sym->attr.allocatable
12177 && !sym->attr.alloc_comp)
12179 symbol_attribute *a = &sym->attr;
12181 if ((!a->save && !a->dummy && !a->pointer
12182 && !a->in_common && !a->use_assoc
12183 && !(a->function && sym != sym->result))
12184 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12185 apply_default_init (sym);
12188 /* If this symbol has a type-spec, check it. */
12189 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12190 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12191 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12197 /************* Resolve DATA statements *************/
12201 gfc_data_value *vnode;
12207 /* Advance the values structure to point to the next value in the data list. */
12210 next_data_value (void)
12212 while (mpz_cmp_ui (values.left, 0) == 0)
12215 if (values.vnode->next == NULL)
12218 values.vnode = values.vnode->next;
12219 mpz_set (values.left, values.vnode->repeat);
12227 check_data_variable (gfc_data_variable *var, locus *where)
12233 ar_type mark = AR_UNKNOWN;
12235 mpz_t section_index[GFC_MAX_DIMENSIONS];
12241 if (gfc_resolve_expr (var->expr) == FAILURE)
12245 mpz_init_set_si (offset, 0);
12248 if (e->expr_type != EXPR_VARIABLE)
12249 gfc_internal_error ("check_data_variable(): Bad expression");
12251 sym = e->symtree->n.sym;
12253 if (sym->ns->is_block_data && !sym->attr.in_common)
12255 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12256 sym->name, &sym->declared_at);
12259 if (e->ref == NULL && sym->as)
12261 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12262 " declaration", sym->name, where);
12266 has_pointer = sym->attr.pointer;
12268 for (ref = e->ref; ref; ref = ref->next)
12270 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12273 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
12275 gfc_error ("DATA element '%s' at %L cannot have a coindex",
12281 && ref->type == REF_ARRAY
12282 && ref->u.ar.type != AR_FULL)
12284 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12285 "be a full array", sym->name, where);
12290 if (e->rank == 0 || has_pointer)
12292 mpz_init_set_ui (size, 1);
12299 /* Find the array section reference. */
12300 for (ref = e->ref; ref; ref = ref->next)
12302 if (ref->type != REF_ARRAY)
12304 if (ref->u.ar.type == AR_ELEMENT)
12310 /* Set marks according to the reference pattern. */
12311 switch (ref->u.ar.type)
12319 /* Get the start position of array section. */
12320 gfc_get_section_index (ar, section_index, &offset);
12325 gcc_unreachable ();
12328 if (gfc_array_size (e, &size) == FAILURE)
12330 gfc_error ("Nonconstant array section at %L in DATA statement",
12332 mpz_clear (offset);
12339 while (mpz_cmp_ui (size, 0) > 0)
12341 if (next_data_value () == FAILURE)
12343 gfc_error ("DATA statement at %L has more variables than values",
12349 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12353 /* If we have more than one element left in the repeat count,
12354 and we have more than one element left in the target variable,
12355 then create a range assignment. */
12356 /* FIXME: Only done for full arrays for now, since array sections
12358 if (mark == AR_FULL && ref && ref->next == NULL
12359 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12363 if (mpz_cmp (size, values.left) >= 0)
12365 mpz_init_set (range, values.left);
12366 mpz_sub (size, size, values.left);
12367 mpz_set_ui (values.left, 0);
12371 mpz_init_set (range, size);
12372 mpz_sub (values.left, values.left, size);
12373 mpz_set_ui (size, 0);
12376 t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
12379 mpz_add (offset, offset, range);
12386 /* Assign initial value to symbol. */
12389 mpz_sub_ui (values.left, values.left, 1);
12390 mpz_sub_ui (size, size, 1);
12392 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
12396 if (mark == AR_FULL)
12397 mpz_add_ui (offset, offset, 1);
12399 /* Modify the array section indexes and recalculate the offset
12400 for next element. */
12401 else if (mark == AR_SECTION)
12402 gfc_advance_section (section_index, ar, &offset);
12406 if (mark == AR_SECTION)
12408 for (i = 0; i < ar->dimen; i++)
12409 mpz_clear (section_index[i]);
12413 mpz_clear (offset);
12419 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
12421 /* Iterate over a list of elements in a DATA statement. */
12424 traverse_data_list (gfc_data_variable *var, locus *where)
12427 iterator_stack frame;
12428 gfc_expr *e, *start, *end, *step;
12429 gfc_try retval = SUCCESS;
12431 mpz_init (frame.value);
12434 start = gfc_copy_expr (var->iter.start);
12435 end = gfc_copy_expr (var->iter.end);
12436 step = gfc_copy_expr (var->iter.step);
12438 if (gfc_simplify_expr (start, 1) == FAILURE
12439 || start->expr_type != EXPR_CONSTANT)
12441 gfc_error ("start of implied-do loop at %L could not be "
12442 "simplified to a constant value", &start->where);
12446 if (gfc_simplify_expr (end, 1) == FAILURE
12447 || end->expr_type != EXPR_CONSTANT)
12449 gfc_error ("end of implied-do loop at %L could not be "
12450 "simplified to a constant value", &start->where);
12454 if (gfc_simplify_expr (step, 1) == FAILURE
12455 || step->expr_type != EXPR_CONSTANT)
12457 gfc_error ("step of implied-do loop at %L could not be "
12458 "simplified to a constant value", &start->where);
12463 mpz_set (trip, end->value.integer);
12464 mpz_sub (trip, trip, start->value.integer);
12465 mpz_add (trip, trip, step->value.integer);
12467 mpz_div (trip, trip, step->value.integer);
12469 mpz_set (frame.value, start->value.integer);
12471 frame.prev = iter_stack;
12472 frame.variable = var->iter.var->symtree;
12473 iter_stack = &frame;
12475 while (mpz_cmp_ui (trip, 0) > 0)
12477 if (traverse_data_var (var->list, where) == FAILURE)
12483 e = gfc_copy_expr (var->expr);
12484 if (gfc_simplify_expr (e, 1) == FAILURE)
12491 mpz_add (frame.value, frame.value, step->value.integer);
12493 mpz_sub_ui (trip, trip, 1);
12497 mpz_clear (frame.value);
12500 gfc_free_expr (start);
12501 gfc_free_expr (end);
12502 gfc_free_expr (step);
12504 iter_stack = frame.prev;
12509 /* Type resolve variables in the variable list of a DATA statement. */
12512 traverse_data_var (gfc_data_variable *var, locus *where)
12516 for (; var; var = var->next)
12518 if (var->expr == NULL)
12519 t = traverse_data_list (var, where);
12521 t = check_data_variable (var, where);
12531 /* Resolve the expressions and iterators associated with a data statement.
12532 This is separate from the assignment checking because data lists should
12533 only be resolved once. */
12536 resolve_data_variables (gfc_data_variable *d)
12538 for (; d; d = d->next)
12540 if (d->list == NULL)
12542 if (gfc_resolve_expr (d->expr) == FAILURE)
12547 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
12550 if (resolve_data_variables (d->list) == FAILURE)
12559 /* Resolve a single DATA statement. We implement this by storing a pointer to
12560 the value list into static variables, and then recursively traversing the
12561 variables list, expanding iterators and such. */
12564 resolve_data (gfc_data *d)
12567 if (resolve_data_variables (d->var) == FAILURE)
12570 values.vnode = d->value;
12571 if (d->value == NULL)
12572 mpz_set_ui (values.left, 0);
12574 mpz_set (values.left, d->value->repeat);
12576 if (traverse_data_var (d->var, &d->where) == FAILURE)
12579 /* At this point, we better not have any values left. */
12581 if (next_data_value () == SUCCESS)
12582 gfc_error ("DATA statement at %L has more values than variables",
12587 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
12588 accessed by host or use association, is a dummy argument to a pure function,
12589 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
12590 is storage associated with any such variable, shall not be used in the
12591 following contexts: (clients of this function). */
12593 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
12594 procedure. Returns zero if assignment is OK, nonzero if there is a
12597 gfc_impure_variable (gfc_symbol *sym)
12602 if (sym->attr.use_assoc || sym->attr.in_common)
12605 /* Check if the symbol's ns is inside the pure procedure. */
12606 for (ns = gfc_current_ns; ns; ns = ns->parent)
12610 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
12614 proc = sym->ns->proc_name;
12615 if (sym->attr.dummy && gfc_pure (proc)
12616 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
12618 proc->attr.function))
12621 /* TODO: Sort out what can be storage associated, if anything, and include
12622 it here. In principle equivalences should be scanned but it does not
12623 seem to be possible to storage associate an impure variable this way. */
12628 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
12629 current namespace is inside a pure procedure. */
12632 gfc_pure (gfc_symbol *sym)
12634 symbol_attribute attr;
12639 /* Check if the current namespace or one of its parents
12640 belongs to a pure procedure. */
12641 for (ns = gfc_current_ns; ns; ns = ns->parent)
12643 sym = ns->proc_name;
12647 if (attr.flavor == FL_PROCEDURE && attr.pure)
12655 return attr.flavor == FL_PROCEDURE && attr.pure;
12659 /* Test whether the current procedure is elemental or not. */
12662 gfc_elemental (gfc_symbol *sym)
12664 symbol_attribute attr;
12667 sym = gfc_current_ns->proc_name;
12672 return attr.flavor == FL_PROCEDURE && attr.elemental;
12676 /* Warn about unused labels. */
12679 warn_unused_fortran_label (gfc_st_label *label)
12684 warn_unused_fortran_label (label->left);
12686 if (label->defined == ST_LABEL_UNKNOWN)
12689 switch (label->referenced)
12691 case ST_LABEL_UNKNOWN:
12692 gfc_warning ("Label %d at %L defined but not used", label->value,
12696 case ST_LABEL_BAD_TARGET:
12697 gfc_warning ("Label %d at %L defined but cannot be used",
12698 label->value, &label->where);
12705 warn_unused_fortran_label (label->right);
12709 /* Returns the sequence type of a symbol or sequence. */
12712 sequence_type (gfc_typespec ts)
12721 if (ts.u.derived->components == NULL)
12722 return SEQ_NONDEFAULT;
12724 result = sequence_type (ts.u.derived->components->ts);
12725 for (c = ts.u.derived->components->next; c; c = c->next)
12726 if (sequence_type (c->ts) != result)
12732 if (ts.kind != gfc_default_character_kind)
12733 return SEQ_NONDEFAULT;
12735 return SEQ_CHARACTER;
12738 if (ts.kind != gfc_default_integer_kind)
12739 return SEQ_NONDEFAULT;
12741 return SEQ_NUMERIC;
12744 if (!(ts.kind == gfc_default_real_kind
12745 || ts.kind == gfc_default_double_kind))
12746 return SEQ_NONDEFAULT;
12748 return SEQ_NUMERIC;
12751 if (ts.kind != gfc_default_complex_kind)
12752 return SEQ_NONDEFAULT;
12754 return SEQ_NUMERIC;
12757 if (ts.kind != gfc_default_logical_kind)
12758 return SEQ_NONDEFAULT;
12760 return SEQ_NUMERIC;
12763 return SEQ_NONDEFAULT;
12768 /* Resolve derived type EQUIVALENCE object. */
12771 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
12773 gfc_component *c = derived->components;
12778 /* Shall not be an object of nonsequence derived type. */
12779 if (!derived->attr.sequence)
12781 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
12782 "attribute to be an EQUIVALENCE object", sym->name,
12787 /* Shall not have allocatable components. */
12788 if (derived->attr.alloc_comp)
12790 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
12791 "components to be an EQUIVALENCE object",sym->name,
12796 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
12798 gfc_error ("Derived type variable '%s' at %L with default "
12799 "initialization cannot be in EQUIVALENCE with a variable "
12800 "in COMMON", sym->name, &e->where);
12804 for (; c ; c = c->next)
12806 if (c->ts.type == BT_DERIVED
12807 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
12810 /* Shall not be an object of sequence derived type containing a pointer
12811 in the structure. */
12812 if (c->attr.pointer)
12814 gfc_error ("Derived type variable '%s' at %L with pointer "
12815 "component(s) cannot be an EQUIVALENCE object",
12816 sym->name, &e->where);
12824 /* Resolve equivalence object.
12825 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
12826 an allocatable array, an object of nonsequence derived type, an object of
12827 sequence derived type containing a pointer at any level of component
12828 selection, an automatic object, a function name, an entry name, a result
12829 name, a named constant, a structure component, or a subobject of any of
12830 the preceding objects. A substring shall not have length zero. A
12831 derived type shall not have components with default initialization nor
12832 shall two objects of an equivalence group be initialized.
12833 Either all or none of the objects shall have an protected attribute.
12834 The simple constraints are done in symbol.c(check_conflict) and the rest
12835 are implemented here. */
12838 resolve_equivalence (gfc_equiv *eq)
12841 gfc_symbol *first_sym;
12844 locus *last_where = NULL;
12845 seq_type eq_type, last_eq_type;
12846 gfc_typespec *last_ts;
12847 int object, cnt_protected;
12850 last_ts = &eq->expr->symtree->n.sym->ts;
12852 first_sym = eq->expr->symtree->n.sym;
12856 for (object = 1; eq; eq = eq->eq, object++)
12860 e->ts = e->symtree->n.sym->ts;
12861 /* match_varspec might not know yet if it is seeing
12862 array reference or substring reference, as it doesn't
12864 if (e->ref && e->ref->type == REF_ARRAY)
12866 gfc_ref *ref = e->ref;
12867 sym = e->symtree->n.sym;
12869 if (sym->attr.dimension)
12871 ref->u.ar.as = sym->as;
12875 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
12876 if (e->ts.type == BT_CHARACTER
12878 && ref->type == REF_ARRAY
12879 && ref->u.ar.dimen == 1
12880 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
12881 && ref->u.ar.stride[0] == NULL)
12883 gfc_expr *start = ref->u.ar.start[0];
12884 gfc_expr *end = ref->u.ar.end[0];
12887 /* Optimize away the (:) reference. */
12888 if (start == NULL && end == NULL)
12891 e->ref = ref->next;
12893 e->ref->next = ref->next;
12898 ref->type = REF_SUBSTRING;
12900 start = gfc_get_int_expr (gfc_default_integer_kind,
12902 ref->u.ss.start = start;
12903 if (end == NULL && e->ts.u.cl)
12904 end = gfc_copy_expr (e->ts.u.cl->length);
12905 ref->u.ss.end = end;
12906 ref->u.ss.length = e->ts.u.cl;
12913 /* Any further ref is an error. */
12916 gcc_assert (ref->type == REF_ARRAY);
12917 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
12923 if (gfc_resolve_expr (e) == FAILURE)
12926 sym = e->symtree->n.sym;
12928 if (sym->attr.is_protected)
12930 if (cnt_protected > 0 && cnt_protected != object)
12932 gfc_error ("Either all or none of the objects in the "
12933 "EQUIVALENCE set at %L shall have the "
12934 "PROTECTED attribute",
12939 /* Shall not equivalence common block variables in a PURE procedure. */
12940 if (sym->ns->proc_name
12941 && sym->ns->proc_name->attr.pure
12942 && sym->attr.in_common)
12944 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
12945 "object in the pure procedure '%s'",
12946 sym->name, &e->where, sym->ns->proc_name->name);
12950 /* Shall not be a named constant. */
12951 if (e->expr_type == EXPR_CONSTANT)
12953 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
12954 "object", sym->name, &e->where);
12958 if (e->ts.type == BT_DERIVED
12959 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
12962 /* Check that the types correspond correctly:
12964 A numeric sequence structure may be equivalenced to another sequence
12965 structure, an object of default integer type, default real type, double
12966 precision real type, default logical type such that components of the
12967 structure ultimately only become associated to objects of the same
12968 kind. A character sequence structure may be equivalenced to an object
12969 of default character kind or another character sequence structure.
12970 Other objects may be equivalenced only to objects of the same type and
12971 kind parameters. */
12973 /* Identical types are unconditionally OK. */
12974 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
12975 goto identical_types;
12977 last_eq_type = sequence_type (*last_ts);
12978 eq_type = sequence_type (sym->ts);
12980 /* Since the pair of objects is not of the same type, mixed or
12981 non-default sequences can be rejected. */
12983 msg = "Sequence %s with mixed components in EQUIVALENCE "
12984 "statement at %L with different type objects";
12986 && last_eq_type == SEQ_MIXED
12987 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
12989 || (eq_type == SEQ_MIXED
12990 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
12991 &e->where) == FAILURE))
12994 msg = "Non-default type object or sequence %s in EQUIVALENCE "
12995 "statement at %L with objects of different type";
12997 && last_eq_type == SEQ_NONDEFAULT
12998 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
12999 last_where) == FAILURE)
13000 || (eq_type == SEQ_NONDEFAULT
13001 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13002 &e->where) == FAILURE))
13005 msg ="Non-CHARACTER object '%s' in default CHARACTER "
13006 "EQUIVALENCE statement at %L";
13007 if (last_eq_type == SEQ_CHARACTER
13008 && eq_type != SEQ_CHARACTER
13009 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13010 &e->where) == FAILURE)
13013 msg ="Non-NUMERIC object '%s' in default NUMERIC "
13014 "EQUIVALENCE statement at %L";
13015 if (last_eq_type == SEQ_NUMERIC
13016 && eq_type != SEQ_NUMERIC
13017 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13018 &e->where) == FAILURE)
13023 last_where = &e->where;
13028 /* Shall not be an automatic array. */
13029 if (e->ref->type == REF_ARRAY
13030 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
13032 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13033 "an EQUIVALENCE object", sym->name, &e->where);
13040 /* Shall not be a structure component. */
13041 if (r->type == REF_COMPONENT)
13043 gfc_error ("Structure component '%s' at %L cannot be an "
13044 "EQUIVALENCE object",
13045 r->u.c.component->name, &e->where);
13049 /* A substring shall not have length zero. */
13050 if (r->type == REF_SUBSTRING)
13052 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13054 gfc_error ("Substring at %L has length zero",
13055 &r->u.ss.start->where);
13065 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13068 resolve_fntype (gfc_namespace *ns)
13070 gfc_entry_list *el;
13073 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13076 /* If there are any entries, ns->proc_name is the entry master
13077 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13079 sym = ns->entries->sym;
13081 sym = ns->proc_name;
13082 if (sym->result == sym
13083 && sym->ts.type == BT_UNKNOWN
13084 && gfc_set_default_type (sym, 0, NULL) == FAILURE
13085 && !sym->attr.untyped)
13087 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13088 sym->name, &sym->declared_at);
13089 sym->attr.untyped = 1;
13092 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13093 && !sym->attr.contained
13094 && !gfc_check_access (sym->ts.u.derived->attr.access,
13095 sym->ts.u.derived->ns->default_access)
13096 && gfc_check_access (sym->attr.access, sym->ns->default_access))
13098 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13099 "%L of PRIVATE type '%s'", sym->name,
13100 &sym->declared_at, sym->ts.u.derived->name);
13104 for (el = ns->entries->next; el; el = el->next)
13106 if (el->sym->result == el->sym
13107 && el->sym->ts.type == BT_UNKNOWN
13108 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13109 && !el->sym->attr.untyped)
13111 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13112 el->sym->name, &el->sym->declared_at);
13113 el->sym->attr.untyped = 1;
13119 /* 12.3.2.1.1 Defined operators. */
13122 check_uop_procedure (gfc_symbol *sym, locus where)
13124 gfc_formal_arglist *formal;
13126 if (!sym->attr.function)
13128 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13129 sym->name, &where);
13133 if (sym->ts.type == BT_CHARACTER
13134 && !(sym->ts.u.cl && sym->ts.u.cl->length)
13135 && !(sym->result && sym->result->ts.u.cl
13136 && sym->result->ts.u.cl->length))
13138 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13139 "character length", sym->name, &where);
13143 formal = sym->formal;
13144 if (!formal || !formal->sym)
13146 gfc_error ("User operator procedure '%s' at %L must have at least "
13147 "one argument", sym->name, &where);
13151 if (formal->sym->attr.intent != INTENT_IN)
13153 gfc_error ("First argument of operator interface at %L must be "
13154 "INTENT(IN)", &where);
13158 if (formal->sym->attr.optional)
13160 gfc_error ("First argument of operator interface at %L cannot be "
13161 "optional", &where);
13165 formal = formal->next;
13166 if (!formal || !formal->sym)
13169 if (formal->sym->attr.intent != INTENT_IN)
13171 gfc_error ("Second argument of operator interface at %L must be "
13172 "INTENT(IN)", &where);
13176 if (formal->sym->attr.optional)
13178 gfc_error ("Second argument of operator interface at %L cannot be "
13179 "optional", &where);
13185 gfc_error ("Operator interface at %L must have, at most, two "
13186 "arguments", &where);
13194 gfc_resolve_uops (gfc_symtree *symtree)
13196 gfc_interface *itr;
13198 if (symtree == NULL)
13201 gfc_resolve_uops (symtree->left);
13202 gfc_resolve_uops (symtree->right);
13204 for (itr = symtree->n.uop->op; itr; itr = itr->next)
13205 check_uop_procedure (itr->sym, itr->sym->declared_at);
13209 /* Examine all of the expressions associated with a program unit,
13210 assign types to all intermediate expressions, make sure that all
13211 assignments are to compatible types and figure out which names
13212 refer to which functions or subroutines. It doesn't check code
13213 block, which is handled by resolve_code. */
13216 resolve_types (gfc_namespace *ns)
13222 gfc_namespace* old_ns = gfc_current_ns;
13224 /* Check that all IMPLICIT types are ok. */
13225 if (!ns->seen_implicit_none)
13228 for (letter = 0; letter != GFC_LETTERS; ++letter)
13229 if (ns->set_flag[letter]
13230 && resolve_typespec_used (&ns->default_type[letter],
13231 &ns->implicit_loc[letter],
13236 gfc_current_ns = ns;
13238 resolve_entries (ns);
13240 resolve_common_vars (ns->blank_common.head, false);
13241 resolve_common_blocks (ns->common_root);
13243 resolve_contained_functions (ns);
13245 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13247 for (cl = ns->cl_list; cl; cl = cl->next)
13248 resolve_charlen (cl);
13250 gfc_traverse_ns (ns, resolve_symbol);
13252 resolve_fntype (ns);
13254 for (n = ns->contained; n; n = n->sibling)
13256 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13257 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13258 "also be PURE", n->proc_name->name,
13259 &n->proc_name->declared_at);
13265 gfc_check_interfaces (ns);
13267 gfc_traverse_ns (ns, resolve_values);
13273 for (d = ns->data; d; d = d->next)
13277 gfc_traverse_ns (ns, gfc_formalize_init_value);
13279 gfc_traverse_ns (ns, gfc_verify_binding_labels);
13281 if (ns->common_root != NULL)
13282 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13284 for (eq = ns->equiv; eq; eq = eq->next)
13285 resolve_equivalence (eq);
13287 /* Warn about unused labels. */
13288 if (warn_unused_label)
13289 warn_unused_fortran_label (ns->st_labels);
13291 gfc_resolve_uops (ns->uop_root);
13293 gfc_current_ns = old_ns;
13297 /* Call resolve_code recursively. */
13300 resolve_codes (gfc_namespace *ns)
13303 bitmap_obstack old_obstack;
13305 for (n = ns->contained; n; n = n->sibling)
13308 gfc_current_ns = ns;
13310 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13311 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13314 /* Set to an out of range value. */
13315 current_entry_id = -1;
13317 old_obstack = labels_obstack;
13318 bitmap_obstack_initialize (&labels_obstack);
13320 resolve_code (ns->code, ns);
13322 bitmap_obstack_release (&labels_obstack);
13323 labels_obstack = old_obstack;
13327 /* This function is called after a complete program unit has been compiled.
13328 Its purpose is to examine all of the expressions associated with a program
13329 unit, assign types to all intermediate expressions, make sure that all
13330 assignments are to compatible types and figure out which names refer to
13331 which functions or subroutines. */
13334 gfc_resolve (gfc_namespace *ns)
13336 gfc_namespace *old_ns;
13337 code_stack *old_cs_base;
13343 old_ns = gfc_current_ns;
13344 old_cs_base = cs_base;
13346 resolve_types (ns);
13347 resolve_codes (ns);
13349 gfc_current_ns = old_ns;
13350 cs_base = old_cs_base;
13353 gfc_run_passes (ns);