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;
934 if (expr->ts.type == BT_DERIVED)
935 resolve_symbol (expr->ts.u.derived);
937 cons = gfc_constructor_first (expr->value.constructor);
938 /* A constructor may have references if it is the result of substituting a
939 parameter variable. In this case we just pull out the component we
942 comp = expr->ref->u.c.sym->components;
944 comp = expr->ts.u.derived->components;
946 /* See if the user is trying to invoke a structure constructor for one of
947 the iso_c_binding derived types. */
948 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
949 && expr->ts.u.derived->ts.is_iso_c && cons
950 && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
952 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
953 expr->ts.u.derived->name, &(expr->where));
957 /* Return if structure constructor is c_null_(fun)prt. */
958 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
959 && expr->ts.u.derived->ts.is_iso_c && cons
960 && cons->expr && cons->expr->expr_type == EXPR_NULL)
963 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
970 if (gfc_resolve_expr (cons->expr) == FAILURE)
976 rank = comp->as ? comp->as->rank : 0;
977 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
978 && (comp->attr.allocatable || cons->expr->rank))
980 gfc_error ("The rank of the element in the derived type "
981 "constructor at %L does not match that of the "
982 "component (%d/%d)", &cons->expr->where,
983 cons->expr->rank, rank);
987 /* If we don't have the right type, try to convert it. */
989 if (!comp->attr.proc_pointer &&
990 !gfc_compare_types (&cons->expr->ts, &comp->ts))
993 if (strcmp (comp->name, "$extends") == 0)
995 /* Can afford to be brutal with the $extends initializer.
996 The derived type can get lost because it is PRIVATE
997 but it is not usage constrained by the standard. */
998 cons->expr->ts = comp->ts;
1001 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1002 gfc_error ("The element in the derived type constructor at %L, "
1003 "for pointer component '%s', is %s but should be %s",
1004 &cons->expr->where, comp->name,
1005 gfc_basic_typename (cons->expr->ts.type),
1006 gfc_basic_typename (comp->ts.type));
1008 t = gfc_convert_type (cons->expr, &comp->ts, 1);
1011 /* For strings, the length of the constructor should be the same as
1012 the one of the structure, ensure this if the lengths are known at
1013 compile time and when we are dealing with PARAMETER or structure
1015 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1016 && comp->ts.u.cl->length
1017 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1018 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1019 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1020 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1021 comp->ts.u.cl->length->value.integer) != 0)
1023 if (cons->expr->expr_type == EXPR_VARIABLE
1024 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1026 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1027 to make use of the gfc_resolve_character_array_constructor
1028 machinery. The expression is later simplified away to
1029 an array of string literals. */
1030 gfc_expr *para = cons->expr;
1031 cons->expr = gfc_get_expr ();
1032 cons->expr->ts = para->ts;
1033 cons->expr->where = para->where;
1034 cons->expr->expr_type = EXPR_ARRAY;
1035 cons->expr->rank = para->rank;
1036 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1037 gfc_constructor_append_expr (&cons->expr->value.constructor,
1038 para, &cons->expr->where);
1040 if (cons->expr->expr_type == EXPR_ARRAY)
1043 p = gfc_constructor_first (cons->expr->value.constructor);
1044 if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
1046 gfc_charlen *cl, *cl2;
1049 for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
1051 if (cl == cons->expr->ts.u.cl)
1059 cl2->next = cl->next;
1061 gfc_free_expr (cl->length);
1065 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1066 cons->expr->ts.u.cl->length_from_typespec = true;
1067 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1068 gfc_resolve_character_array_constructor (cons->expr);
1072 if (cons->expr->expr_type == EXPR_NULL
1073 && !(comp->attr.pointer || comp->attr.allocatable
1074 || comp->attr.proc_pointer
1075 || (comp->ts.type == BT_CLASS
1076 && (CLASS_DATA (comp)->attr.class_pointer
1077 || CLASS_DATA (comp)->attr.allocatable))))
1080 gfc_error ("The NULL in the derived type constructor at %L is "
1081 "being applied to component '%s', which is neither "
1082 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1086 if (!comp->attr.pointer || comp->attr.proc_pointer
1087 || cons->expr->expr_type == EXPR_NULL)
1090 a = gfc_expr_attr (cons->expr);
1092 if (!a.pointer && !a.target)
1095 gfc_error ("The element in the derived type constructor at %L, "
1096 "for pointer component '%s' should be a POINTER or "
1097 "a TARGET", &cons->expr->where, comp->name);
1102 /* F08:C461. Additional checks for pointer initialization. */
1106 gfc_error ("Pointer initialization target at %L "
1107 "must not be ALLOCATABLE ", &cons->expr->where);
1112 gfc_error ("Pointer initialization target at %L "
1113 "must have the SAVE attribute", &cons->expr->where);
1117 /* F2003, C1272 (3). */
1118 if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
1119 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1120 || gfc_is_coindexed (cons->expr)))
1123 gfc_error ("Invalid expression in the derived type constructor for "
1124 "pointer component '%s' at %L in PURE procedure",
1125 comp->name, &cons->expr->where);
1134 /****************** Expression name resolution ******************/
1136 /* Returns 0 if a symbol was not declared with a type or
1137 attribute declaration statement, nonzero otherwise. */
1140 was_declared (gfc_symbol *sym)
1146 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1149 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1150 || a.optional || a.pointer || a.save || a.target || a.volatile_
1151 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1152 || a.asynchronous || a.codimension)
1159 /* Determine if a symbol is generic or not. */
1162 generic_sym (gfc_symbol *sym)
1166 if (sym->attr.generic ||
1167 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1170 if (was_declared (sym) || sym->ns->parent == NULL)
1173 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1180 return generic_sym (s);
1187 /* Determine if a symbol is specific or not. */
1190 specific_sym (gfc_symbol *sym)
1194 if (sym->attr.if_source == IFSRC_IFBODY
1195 || sym->attr.proc == PROC_MODULE
1196 || sym->attr.proc == PROC_INTERNAL
1197 || sym->attr.proc == PROC_ST_FUNCTION
1198 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1199 || sym->attr.external)
1202 if (was_declared (sym) || sym->ns->parent == NULL)
1205 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1207 return (s == NULL) ? 0 : specific_sym (s);
1211 /* Figure out if the procedure is specific, generic or unknown. */
1214 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1218 procedure_kind (gfc_symbol *sym)
1220 if (generic_sym (sym))
1221 return PTYPE_GENERIC;
1223 if (specific_sym (sym))
1224 return PTYPE_SPECIFIC;
1226 return PTYPE_UNKNOWN;
1229 /* Check references to assumed size arrays. The flag need_full_assumed_size
1230 is nonzero when matching actual arguments. */
1232 static int need_full_assumed_size = 0;
1235 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1237 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1240 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1241 What should it be? */
1242 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1243 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1244 && (e->ref->u.ar.type == AR_FULL))
1246 gfc_error ("The upper bound in the last dimension must "
1247 "appear in the reference to the assumed size "
1248 "array '%s' at %L", sym->name, &e->where);
1255 /* Look for bad assumed size array references in argument expressions
1256 of elemental and array valued intrinsic procedures. Since this is
1257 called from procedure resolution functions, it only recurses at
1261 resolve_assumed_size_actual (gfc_expr *e)
1266 switch (e->expr_type)
1269 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1274 if (resolve_assumed_size_actual (e->value.op.op1)
1275 || resolve_assumed_size_actual (e->value.op.op2))
1286 /* Check a generic procedure, passed as an actual argument, to see if
1287 there is a matching specific name. If none, it is an error, and if
1288 more than one, the reference is ambiguous. */
1290 count_specific_procs (gfc_expr *e)
1297 sym = e->symtree->n.sym;
1299 for (p = sym->generic; p; p = p->next)
1300 if (strcmp (sym->name, p->sym->name) == 0)
1302 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1308 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1312 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1313 "argument at %L", sym->name, &e->where);
1319 /* See if a call to sym could possibly be a not allowed RECURSION because of
1320 a missing RECURIVE declaration. This means that either sym is the current
1321 context itself, or sym is the parent of a contained procedure calling its
1322 non-RECURSIVE containing procedure.
1323 This also works if sym is an ENTRY. */
1326 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1328 gfc_symbol* proc_sym;
1329 gfc_symbol* context_proc;
1330 gfc_namespace* real_context;
1332 if (sym->attr.flavor == FL_PROGRAM)
1335 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1337 /* If we've got an ENTRY, find real procedure. */
1338 if (sym->attr.entry && sym->ns->entries)
1339 proc_sym = sym->ns->entries->sym;
1343 /* If sym is RECURSIVE, all is well of course. */
1344 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1347 /* Find the context procedure's "real" symbol if it has entries.
1348 We look for a procedure symbol, so recurse on the parents if we don't
1349 find one (like in case of a BLOCK construct). */
1350 for (real_context = context; ; real_context = real_context->parent)
1352 /* We should find something, eventually! */
1353 gcc_assert (real_context);
1355 context_proc = (real_context->entries ? real_context->entries->sym
1356 : real_context->proc_name);
1358 /* In some special cases, there may not be a proc_name, like for this
1360 real(bad_kind()) function foo () ...
1361 when checking the call to bad_kind ().
1362 In these cases, we simply return here and assume that the
1367 if (context_proc->attr.flavor != FL_LABEL)
1371 /* A call from sym's body to itself is recursion, of course. */
1372 if (context_proc == proc_sym)
1375 /* The same is true if context is a contained procedure and sym the
1377 if (context_proc->attr.contained)
1379 gfc_symbol* parent_proc;
1381 gcc_assert (context->parent);
1382 parent_proc = (context->parent->entries ? context->parent->entries->sym
1383 : context->parent->proc_name);
1385 if (parent_proc == proc_sym)
1393 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1394 its typespec and formal argument list. */
1397 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1399 gfc_intrinsic_sym* isym;
1405 /* We already know this one is an intrinsic, so we don't call
1406 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1407 gfc_find_subroutine directly to check whether it is a function or
1410 if ((isym = gfc_find_function (sym->name)))
1412 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1413 && !sym->attr.implicit_type)
1414 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1415 " ignored", sym->name, &sym->declared_at);
1417 if (!sym->attr.function &&
1418 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1423 else if ((isym = gfc_find_subroutine (sym->name)))
1425 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1427 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1428 " specifier", sym->name, &sym->declared_at);
1432 if (!sym->attr.subroutine &&
1433 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1438 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1443 gfc_copy_formal_args_intr (sym, isym);
1445 /* Check it is actually available in the standard settings. */
1446 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1449 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1450 " available in the current standard settings but %s. Use"
1451 " an appropriate -std=* option or enable -fall-intrinsics"
1452 " in order to use it.",
1453 sym->name, &sym->declared_at, symstd);
1461 /* Resolve a procedure expression, like passing it to a called procedure or as
1462 RHS for a procedure pointer assignment. */
1465 resolve_procedure_expression (gfc_expr* expr)
1469 if (expr->expr_type != EXPR_VARIABLE)
1471 gcc_assert (expr->symtree);
1473 sym = expr->symtree->n.sym;
1475 if (sym->attr.intrinsic)
1476 resolve_intrinsic (sym, &expr->where);
1478 if (sym->attr.flavor != FL_PROCEDURE
1479 || (sym->attr.function && sym->result == sym))
1482 /* A non-RECURSIVE procedure that is used as procedure expression within its
1483 own body is in danger of being called recursively. */
1484 if (is_illegal_recursion (sym, gfc_current_ns))
1485 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1486 " itself recursively. Declare it RECURSIVE or use"
1487 " -frecursive", sym->name, &expr->where);
1493 /* Resolve an actual argument list. Most of the time, this is just
1494 resolving the expressions in the list.
1495 The exception is that we sometimes have to decide whether arguments
1496 that look like procedure arguments are really simple variable
1500 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1501 bool no_formal_args)
1504 gfc_symtree *parent_st;
1506 int save_need_full_assumed_size;
1507 gfc_component *comp;
1509 for (; arg; arg = arg->next)
1514 /* Check the label is a valid branching target. */
1517 if (arg->label->defined == ST_LABEL_UNKNOWN)
1519 gfc_error ("Label %d referenced at %L is never defined",
1520 arg->label->value, &arg->label->where);
1527 if (gfc_is_proc_ptr_comp (e, &comp))
1530 if (e->expr_type == EXPR_PPC)
1532 if (comp->as != NULL)
1533 e->rank = comp->as->rank;
1534 e->expr_type = EXPR_FUNCTION;
1536 if (gfc_resolve_expr (e) == FAILURE)
1541 if (e->expr_type == EXPR_VARIABLE
1542 && e->symtree->n.sym->attr.generic
1544 && count_specific_procs (e) != 1)
1547 if (e->ts.type != BT_PROCEDURE)
1549 save_need_full_assumed_size = need_full_assumed_size;
1550 if (e->expr_type != EXPR_VARIABLE)
1551 need_full_assumed_size = 0;
1552 if (gfc_resolve_expr (e) != SUCCESS)
1554 need_full_assumed_size = save_need_full_assumed_size;
1558 /* See if the expression node should really be a variable reference. */
1560 sym = e->symtree->n.sym;
1562 if (sym->attr.flavor == FL_PROCEDURE
1563 || sym->attr.intrinsic
1564 || sym->attr.external)
1568 /* If a procedure is not already determined to be something else
1569 check if it is intrinsic. */
1570 if (!sym->attr.intrinsic
1571 && !(sym->attr.external || sym->attr.use_assoc
1572 || sym->attr.if_source == IFSRC_IFBODY)
1573 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1574 sym->attr.intrinsic = 1;
1576 if (sym->attr.proc == PROC_ST_FUNCTION)
1578 gfc_error ("Statement function '%s' at %L is not allowed as an "
1579 "actual argument", sym->name, &e->where);
1582 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1583 sym->attr.subroutine);
1584 if (sym->attr.intrinsic && actual_ok == 0)
1586 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1587 "actual argument", sym->name, &e->where);
1590 if (sym->attr.contained && !sym->attr.use_assoc
1591 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1593 if (gfc_notify_std (GFC_STD_F2008,
1594 "Fortran 2008: Internal procedure '%s' is"
1595 " used as actual argument at %L",
1596 sym->name, &e->where) == FAILURE)
1600 if (sym->attr.elemental && !sym->attr.intrinsic)
1602 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1603 "allowed as an actual argument at %L", sym->name,
1607 /* Check if a generic interface has a specific procedure
1608 with the same name before emitting an error. */
1609 if (sym->attr.generic && count_specific_procs (e) != 1)
1612 /* Just in case a specific was found for the expression. */
1613 sym = e->symtree->n.sym;
1615 /* If the symbol is the function that names the current (or
1616 parent) scope, then we really have a variable reference. */
1618 if (gfc_is_function_return_value (sym, sym->ns))
1621 /* If all else fails, see if we have a specific intrinsic. */
1622 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1624 gfc_intrinsic_sym *isym;
1626 isym = gfc_find_function (sym->name);
1627 if (isym == NULL || !isym->specific)
1629 gfc_error ("Unable to find a specific INTRINSIC procedure "
1630 "for the reference '%s' at %L", sym->name,
1635 sym->attr.intrinsic = 1;
1636 sym->attr.function = 1;
1639 if (gfc_resolve_expr (e) == FAILURE)
1644 /* See if the name is a module procedure in a parent unit. */
1646 if (was_declared (sym) || sym->ns->parent == NULL)
1649 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1651 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1655 if (parent_st == NULL)
1658 sym = parent_st->n.sym;
1659 e->symtree = parent_st; /* Point to the right thing. */
1661 if (sym->attr.flavor == FL_PROCEDURE
1662 || sym->attr.intrinsic
1663 || sym->attr.external)
1665 if (gfc_resolve_expr (e) == FAILURE)
1671 e->expr_type = EXPR_VARIABLE;
1673 if (sym->as != NULL)
1675 e->rank = sym->as->rank;
1676 e->ref = gfc_get_ref ();
1677 e->ref->type = REF_ARRAY;
1678 e->ref->u.ar.type = AR_FULL;
1679 e->ref->u.ar.as = sym->as;
1682 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1683 primary.c (match_actual_arg). If above code determines that it
1684 is a variable instead, it needs to be resolved as it was not
1685 done at the beginning of this function. */
1686 save_need_full_assumed_size = need_full_assumed_size;
1687 if (e->expr_type != EXPR_VARIABLE)
1688 need_full_assumed_size = 0;
1689 if (gfc_resolve_expr (e) != SUCCESS)
1691 need_full_assumed_size = save_need_full_assumed_size;
1694 /* Check argument list functions %VAL, %LOC and %REF. There is
1695 nothing to do for %REF. */
1696 if (arg->name && arg->name[0] == '%')
1698 if (strncmp ("%VAL", arg->name, 4) == 0)
1700 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1702 gfc_error ("By-value argument at %L is not of numeric "
1709 gfc_error ("By-value argument at %L cannot be an array or "
1710 "an array section", &e->where);
1714 /* Intrinsics are still PROC_UNKNOWN here. However,
1715 since same file external procedures are not resolvable
1716 in gfortran, it is a good deal easier to leave them to
1718 if (ptype != PROC_UNKNOWN
1719 && ptype != PROC_DUMMY
1720 && ptype != PROC_EXTERNAL
1721 && ptype != PROC_MODULE)
1723 gfc_error ("By-value argument at %L is not allowed "
1724 "in this context", &e->where);
1729 /* Statement functions have already been excluded above. */
1730 else if (strncmp ("%LOC", arg->name, 4) == 0
1731 && e->ts.type == BT_PROCEDURE)
1733 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1735 gfc_error ("Passing internal procedure at %L by location "
1736 "not allowed", &e->where);
1742 /* Fortran 2008, C1237. */
1743 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1744 && gfc_has_ultimate_pointer (e))
1746 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1747 "component", &e->where);
1756 /* Do the checks of the actual argument list that are specific to elemental
1757 procedures. If called with c == NULL, we have a function, otherwise if
1758 expr == NULL, we have a subroutine. */
1761 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1763 gfc_actual_arglist *arg0;
1764 gfc_actual_arglist *arg;
1765 gfc_symbol *esym = NULL;
1766 gfc_intrinsic_sym *isym = NULL;
1768 gfc_intrinsic_arg *iformal = NULL;
1769 gfc_formal_arglist *eformal = NULL;
1770 bool formal_optional = false;
1771 bool set_by_optional = false;
1775 /* Is this an elemental procedure? */
1776 if (expr && expr->value.function.actual != NULL)
1778 if (expr->value.function.esym != NULL
1779 && expr->value.function.esym->attr.elemental)
1781 arg0 = expr->value.function.actual;
1782 esym = expr->value.function.esym;
1784 else if (expr->value.function.isym != NULL
1785 && expr->value.function.isym->elemental)
1787 arg0 = expr->value.function.actual;
1788 isym = expr->value.function.isym;
1793 else if (c && c->ext.actual != NULL)
1795 arg0 = c->ext.actual;
1797 if (c->resolved_sym)
1798 esym = c->resolved_sym;
1800 esym = c->symtree->n.sym;
1803 if (!esym->attr.elemental)
1809 /* The rank of an elemental is the rank of its array argument(s). */
1810 for (arg = arg0; arg; arg = arg->next)
1812 if (arg->expr != NULL && arg->expr->rank > 0)
1814 rank = arg->expr->rank;
1815 if (arg->expr->expr_type == EXPR_VARIABLE
1816 && arg->expr->symtree->n.sym->attr.optional)
1817 set_by_optional = true;
1819 /* Function specific; set the result rank and shape. */
1823 if (!expr->shape && arg->expr->shape)
1825 expr->shape = gfc_get_shape (rank);
1826 for (i = 0; i < rank; i++)
1827 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1834 /* If it is an array, it shall not be supplied as an actual argument
1835 to an elemental procedure unless an array of the same rank is supplied
1836 as an actual argument corresponding to a nonoptional dummy argument of
1837 that elemental procedure(12.4.1.5). */
1838 formal_optional = false;
1840 iformal = isym->formal;
1842 eformal = esym->formal;
1844 for (arg = arg0; arg; arg = arg->next)
1848 if (eformal->sym && eformal->sym->attr.optional)
1849 formal_optional = true;
1850 eformal = eformal->next;
1852 else if (isym && iformal)
1854 if (iformal->optional)
1855 formal_optional = true;
1856 iformal = iformal->next;
1859 formal_optional = true;
1861 if (pedantic && arg->expr != NULL
1862 && arg->expr->expr_type == EXPR_VARIABLE
1863 && arg->expr->symtree->n.sym->attr.optional
1866 && (set_by_optional || arg->expr->rank != rank)
1867 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1869 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1870 "MISSING, it cannot be the actual argument of an "
1871 "ELEMENTAL procedure unless there is a non-optional "
1872 "argument with the same rank (12.4.1.5)",
1873 arg->expr->symtree->n.sym->name, &arg->expr->where);
1878 for (arg = arg0; arg; arg = arg->next)
1880 if (arg->expr == NULL || arg->expr->rank == 0)
1883 /* Being elemental, the last upper bound of an assumed size array
1884 argument must be present. */
1885 if (resolve_assumed_size_actual (arg->expr))
1888 /* Elemental procedure's array actual arguments must conform. */
1891 if (gfc_check_conformance (arg->expr, e,
1892 "elemental procedure") == FAILURE)
1899 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1900 is an array, the intent inout/out variable needs to be also an array. */
1901 if (rank > 0 && esym && expr == NULL)
1902 for (eformal = esym->formal, arg = arg0; arg && eformal;
1903 arg = arg->next, eformal = eformal->next)
1904 if ((eformal->sym->attr.intent == INTENT_OUT
1905 || eformal->sym->attr.intent == INTENT_INOUT)
1906 && arg->expr && arg->expr->rank == 0)
1908 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1909 "ELEMENTAL subroutine '%s' is a scalar, but another "
1910 "actual argument is an array", &arg->expr->where,
1911 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1912 : "INOUT", eformal->sym->name, esym->name);
1919 /* Go through each actual argument in ACTUAL and see if it can be
1920 implemented as an inlined, non-copying intrinsic. FNSYM is the
1921 function being called, or NULL if not known. */
1924 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1926 gfc_actual_arglist *ap;
1929 for (ap = actual; ap; ap = ap->next)
1931 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1932 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual,
1934 ap->expr->inline_noncopying_intrinsic = 1;
1938 /* This function does the checking of references to global procedures
1939 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1940 77 and 95 standards. It checks for a gsymbol for the name, making
1941 one if it does not already exist. If it already exists, then the
1942 reference being resolved must correspond to the type of gsymbol.
1943 Otherwise, the new symbol is equipped with the attributes of the
1944 reference. The corresponding code that is called in creating
1945 global entities is parse.c.
1947 In addition, for all but -std=legacy, the gsymbols are used to
1948 check the interfaces of external procedures from the same file.
1949 The namespace of the gsymbol is resolved and then, once this is
1950 done the interface is checked. */
1954 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
1956 if (!gsym_ns->proc_name->attr.recursive)
1959 if (sym->ns == gsym_ns)
1962 if (sym->ns->parent && sym->ns->parent == gsym_ns)
1969 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
1971 if (gsym_ns->entries)
1973 gfc_entry_list *entry = gsym_ns->entries;
1975 for (; entry; entry = entry->next)
1977 if (strcmp (sym->name, entry->sym->name) == 0)
1979 if (strcmp (gsym_ns->proc_name->name,
1980 sym->ns->proc_name->name) == 0)
1984 && strcmp (gsym_ns->proc_name->name,
1985 sym->ns->parent->proc_name->name) == 0)
1994 resolve_global_procedure (gfc_symbol *sym, locus *where,
1995 gfc_actual_arglist **actual, int sub)
1999 enum gfc_symbol_type type;
2001 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2003 gsym = gfc_get_gsymbol (sym->name);
2005 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2006 gfc_global_used (gsym, where);
2008 if (gfc_option.flag_whole_file
2009 && (sym->attr.if_source == IFSRC_UNKNOWN
2010 || sym->attr.if_source == IFSRC_IFBODY)
2011 && gsym->type != GSYM_UNKNOWN
2013 && gsym->ns->resolved != -1
2014 && gsym->ns->proc_name
2015 && not_in_recursive (sym, gsym->ns)
2016 && not_entry_self_reference (sym, gsym->ns))
2018 gfc_symbol *def_sym;
2020 /* Resolve the gsymbol namespace if needed. */
2021 if (!gsym->ns->resolved)
2023 gfc_dt_list *old_dt_list;
2025 /* Stash away derived types so that the backend_decls do not
2027 old_dt_list = gfc_derived_types;
2028 gfc_derived_types = NULL;
2030 gfc_resolve (gsym->ns);
2032 /* Store the new derived types with the global namespace. */
2033 if (gfc_derived_types)
2034 gsym->ns->derived_types = gfc_derived_types;
2036 /* Restore the derived types of this namespace. */
2037 gfc_derived_types = old_dt_list;
2040 /* Make sure that translation for the gsymbol occurs before
2041 the procedure currently being resolved. */
2042 ns = gfc_global_ns_list;
2043 for (; ns && ns != gsym->ns; ns = ns->sibling)
2045 if (ns->sibling == gsym->ns)
2047 ns->sibling = gsym->ns->sibling;
2048 gsym->ns->sibling = gfc_global_ns_list;
2049 gfc_global_ns_list = gsym->ns;
2054 def_sym = gsym->ns->proc_name;
2055 if (def_sym->attr.entry_master)
2057 gfc_entry_list *entry;
2058 for (entry = gsym->ns->entries; entry; entry = entry->next)
2059 if (strcmp (entry->sym->name, sym->name) == 0)
2061 def_sym = entry->sym;
2066 /* Differences in constant character lengths. */
2067 if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2069 long int l1 = 0, l2 = 0;
2070 gfc_charlen *cl1 = sym->ts.u.cl;
2071 gfc_charlen *cl2 = def_sym->ts.u.cl;
2074 && cl1->length != NULL
2075 && cl1->length->expr_type == EXPR_CONSTANT)
2076 l1 = mpz_get_si (cl1->length->value.integer);
2079 && cl2->length != NULL
2080 && cl2->length->expr_type == EXPR_CONSTANT)
2081 l2 = mpz_get_si (cl2->length->value.integer);
2083 if (l1 && l2 && l1 != l2)
2084 gfc_error ("Character length mismatch in return type of "
2085 "function '%s' at %L (%ld/%ld)", sym->name,
2086 &sym->declared_at, l1, l2);
2089 /* Type mismatch of function return type and expected type. */
2090 if (sym->attr.function
2091 && !gfc_compare_types (&sym->ts, &def_sym->ts))
2092 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2093 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2094 gfc_typename (&def_sym->ts));
2096 if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2098 gfc_formal_arglist *arg = def_sym->formal;
2099 for ( ; arg; arg = arg->next)
2102 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2103 else if (arg->sym->attr.allocatable
2104 || arg->sym->attr.asynchronous
2105 || arg->sym->attr.optional
2106 || arg->sym->attr.pointer
2107 || arg->sym->attr.target
2108 || arg->sym->attr.value
2109 || arg->sym->attr.volatile_)
2111 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2112 "has an attribute that requires an explicit "
2113 "interface for this procedure", arg->sym->name,
2114 sym->name, &sym->declared_at);
2117 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2118 else if (arg->sym && arg->sym->as
2119 && arg->sym->as->type == AS_ASSUMED_SHAPE)
2121 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2122 "argument '%s' must have an explicit interface",
2123 sym->name, &sym->declared_at, arg->sym->name);
2126 /* F2008, 12.4.2.2 (2c) */
2127 else if (arg->sym->attr.codimension)
2129 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2130 "'%s' must have an explicit interface",
2131 sym->name, &sym->declared_at, arg->sym->name);
2134 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2135 else if (false) /* TODO: is a parametrized derived type */
2137 gfc_error ("Procedure '%s' at %L with parametrized derived "
2138 "type argument '%s' must have an explicit "
2139 "interface", sym->name, &sym->declared_at,
2143 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2144 else if (arg->sym->ts.type == BT_CLASS)
2146 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2147 "argument '%s' must have an explicit interface",
2148 sym->name, &sym->declared_at, arg->sym->name);
2153 if (def_sym->attr.function)
2155 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2156 if (def_sym->as && def_sym->as->rank
2157 && (!sym->as || sym->as->rank != def_sym->as->rank))
2158 gfc_error ("The reference to function '%s' at %L either needs an "
2159 "explicit INTERFACE or the rank is incorrect", sym->name,
2162 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2163 if ((def_sym->result->attr.pointer
2164 || def_sym->result->attr.allocatable)
2165 && (sym->attr.if_source != IFSRC_IFBODY
2166 || def_sym->result->attr.pointer
2167 != sym->result->attr.pointer
2168 || def_sym->result->attr.allocatable
2169 != sym->result->attr.allocatable))
2170 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2171 "result must have an explicit interface", sym->name,
2174 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2175 if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2176 && def_sym->ts.u.cl->length != NULL)
2178 gfc_charlen *cl = sym->ts.u.cl;
2180 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2181 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2183 gfc_error ("Nonconstant character-length function '%s' at %L "
2184 "must have an explicit interface", sym->name,
2190 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2191 if (def_sym->attr.elemental && !sym->attr.elemental)
2193 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2194 "interface", sym->name, &sym->declared_at);
2197 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2198 if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2200 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2201 "an explicit interface", sym->name, &sym->declared_at);
2204 if (gfc_option.flag_whole_file == 1
2205 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2206 && !(gfc_option.warn_std & GFC_STD_GNU)))
2207 gfc_errors_to_warnings (1);
2209 if (sym->attr.if_source != IFSRC_IFBODY)
2210 gfc_procedure_use (def_sym, actual, where);
2212 gfc_errors_to_warnings (0);
2215 if (gsym->type == GSYM_UNKNOWN)
2218 gsym->where = *where;
2225 /************* Function resolution *************/
2227 /* Resolve a function call known to be generic.
2228 Section 14.1.2.4.1. */
2231 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2235 if (sym->attr.generic)
2237 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2240 expr->value.function.name = s->name;
2241 expr->value.function.esym = s;
2243 if (s->ts.type != BT_UNKNOWN)
2245 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2246 expr->ts = s->result->ts;
2249 expr->rank = s->as->rank;
2250 else if (s->result != NULL && s->result->as != NULL)
2251 expr->rank = s->result->as->rank;
2253 gfc_set_sym_referenced (expr->value.function.esym);
2258 /* TODO: Need to search for elemental references in generic
2262 if (sym->attr.intrinsic)
2263 return gfc_intrinsic_func_interface (expr, 0);
2270 resolve_generic_f (gfc_expr *expr)
2275 sym = expr->symtree->n.sym;
2279 m = resolve_generic_f0 (expr, sym);
2282 else if (m == MATCH_ERROR)
2286 if (sym->ns->parent == NULL)
2288 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2292 if (!generic_sym (sym))
2296 /* Last ditch attempt. See if the reference is to an intrinsic
2297 that possesses a matching interface. 14.1.2.4 */
2298 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
2300 gfc_error ("There is no specific function for the generic '%s' at %L",
2301 expr->symtree->n.sym->name, &expr->where);
2305 m = gfc_intrinsic_func_interface (expr, 0);
2309 gfc_error ("Generic function '%s' at %L is not consistent with a "
2310 "specific intrinsic interface", expr->symtree->n.sym->name,
2317 /* Resolve a function call known to be specific. */
2320 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2324 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2326 if (sym->attr.dummy)
2328 sym->attr.proc = PROC_DUMMY;
2332 sym->attr.proc = PROC_EXTERNAL;
2336 if (sym->attr.proc == PROC_MODULE
2337 || sym->attr.proc == PROC_ST_FUNCTION
2338 || sym->attr.proc == PROC_INTERNAL)
2341 if (sym->attr.intrinsic)
2343 m = gfc_intrinsic_func_interface (expr, 1);
2347 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2348 "with an intrinsic", sym->name, &expr->where);
2356 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2359 expr->ts = sym->result->ts;
2362 expr->value.function.name = sym->name;
2363 expr->value.function.esym = sym;
2364 if (sym->as != NULL)
2365 expr->rank = sym->as->rank;
2372 resolve_specific_f (gfc_expr *expr)
2377 sym = expr->symtree->n.sym;
2381 m = resolve_specific_f0 (sym, expr);
2384 if (m == MATCH_ERROR)
2387 if (sym->ns->parent == NULL)
2390 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2396 gfc_error ("Unable to resolve the specific function '%s' at %L",
2397 expr->symtree->n.sym->name, &expr->where);
2403 /* Resolve a procedure call not known to be generic nor specific. */
2406 resolve_unknown_f (gfc_expr *expr)
2411 sym = expr->symtree->n.sym;
2413 if (sym->attr.dummy)
2415 sym->attr.proc = PROC_DUMMY;
2416 expr->value.function.name = sym->name;
2420 /* See if we have an intrinsic function reference. */
2422 if (gfc_is_intrinsic (sym, 0, expr->where))
2424 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2429 /* The reference is to an external name. */
2431 sym->attr.proc = PROC_EXTERNAL;
2432 expr->value.function.name = sym->name;
2433 expr->value.function.esym = expr->symtree->n.sym;
2435 if (sym->as != NULL)
2436 expr->rank = sym->as->rank;
2438 /* Type of the expression is either the type of the symbol or the
2439 default type of the symbol. */
2442 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2444 if (sym->ts.type != BT_UNKNOWN)
2448 ts = gfc_get_default_type (sym->name, sym->ns);
2450 if (ts->type == BT_UNKNOWN)
2452 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2453 sym->name, &expr->where);
2464 /* Return true, if the symbol is an external procedure. */
2466 is_external_proc (gfc_symbol *sym)
2468 if (!sym->attr.dummy && !sym->attr.contained
2469 && !(sym->attr.intrinsic
2470 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2471 && sym->attr.proc != PROC_ST_FUNCTION
2472 && !sym->attr.proc_pointer
2473 && !sym->attr.use_assoc
2481 /* Figure out if a function reference is pure or not. Also set the name
2482 of the function for a potential error message. Return nonzero if the
2483 function is PURE, zero if not. */
2485 pure_stmt_function (gfc_expr *, gfc_symbol *);
2488 pure_function (gfc_expr *e, const char **name)
2494 if (e->symtree != NULL
2495 && e->symtree->n.sym != NULL
2496 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2497 return pure_stmt_function (e, e->symtree->n.sym);
2499 if (e->value.function.esym)
2501 pure = gfc_pure (e->value.function.esym);
2502 *name = e->value.function.esym->name;
2504 else if (e->value.function.isym)
2506 pure = e->value.function.isym->pure
2507 || e->value.function.isym->elemental;
2508 *name = e->value.function.isym->name;
2512 /* Implicit functions are not pure. */
2514 *name = e->value.function.name;
2522 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2523 int *f ATTRIBUTE_UNUSED)
2527 /* Don't bother recursing into other statement functions
2528 since they will be checked individually for purity. */
2529 if (e->expr_type != EXPR_FUNCTION
2531 || e->symtree->n.sym == sym
2532 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2535 return pure_function (e, &name) ? false : true;
2540 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2542 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2547 is_scalar_expr_ptr (gfc_expr *expr)
2549 gfc_try retval = SUCCESS;
2554 /* See if we have a gfc_ref, which means we have a substring, array
2555 reference, or a component. */
2556 if (expr->ref != NULL)
2559 while (ref->next != NULL)
2565 if (ref->u.ss.length != NULL
2566 && ref->u.ss.length->length != NULL
2568 && ref->u.ss.start->expr_type == EXPR_CONSTANT
2570 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
2572 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
2573 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
2574 if (end - start + 1 != 1)
2581 if (ref->u.ar.type == AR_ELEMENT)
2583 else if (ref->u.ar.type == AR_FULL)
2585 /* The user can give a full array if the array is of size 1. */
2586 if (ref->u.ar.as != NULL
2587 && ref->u.ar.as->rank == 1
2588 && ref->u.ar.as->type == AS_EXPLICIT
2589 && ref->u.ar.as->lower[0] != NULL
2590 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2591 && ref->u.ar.as->upper[0] != NULL
2592 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2594 /* If we have a character string, we need to check if
2595 its length is one. */
2596 if (expr->ts.type == BT_CHARACTER)
2598 if (expr->ts.u.cl == NULL
2599 || expr->ts.u.cl->length == NULL
2600 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2606 /* We have constant lower and upper bounds. If the
2607 difference between is 1, it can be considered a
2609 start = (int) mpz_get_si
2610 (ref->u.ar.as->lower[0]->value.integer);
2611 end = (int) mpz_get_si
2612 (ref->u.ar.as->upper[0]->value.integer);
2613 if (end - start + 1 != 1)
2628 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2630 /* Character string. Make sure it's of length 1. */
2631 if (expr->ts.u.cl == NULL
2632 || expr->ts.u.cl->length == NULL
2633 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2636 else if (expr->rank != 0)
2643 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2644 and, in the case of c_associated, set the binding label based on
2648 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2649 gfc_symbol **new_sym)
2651 char name[GFC_MAX_SYMBOL_LEN + 1];
2652 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2653 int optional_arg = 0;
2654 gfc_try retval = SUCCESS;
2655 gfc_symbol *args_sym;
2656 gfc_typespec *arg_ts;
2657 symbol_attribute arg_attr;
2659 if (args->expr->expr_type == EXPR_CONSTANT
2660 || args->expr->expr_type == EXPR_OP
2661 || args->expr->expr_type == EXPR_NULL)
2663 gfc_error ("Argument to '%s' at %L is not a variable",
2664 sym->name, &(args->expr->where));
2668 args_sym = args->expr->symtree->n.sym;
2670 /* The typespec for the actual arg should be that stored in the expr
2671 and not necessarily that of the expr symbol (args_sym), because
2672 the actual expression could be a part-ref of the expr symbol. */
2673 arg_ts = &(args->expr->ts);
2674 arg_attr = gfc_expr_attr (args->expr);
2676 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2678 /* If the user gave two args then they are providing something for
2679 the optional arg (the second cptr). Therefore, set the name and
2680 binding label to the c_associated for two cptrs. Otherwise,
2681 set c_associated to expect one cptr. */
2685 sprintf (name, "%s_2", sym->name);
2686 sprintf (binding_label, "%s_2", sym->binding_label);
2692 sprintf (name, "%s_1", sym->name);
2693 sprintf (binding_label, "%s_1", sym->binding_label);
2697 /* Get a new symbol for the version of c_associated that
2699 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2701 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2702 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2704 sprintf (name, "%s", sym->name);
2705 sprintf (binding_label, "%s", sym->binding_label);
2707 /* Error check the call. */
2708 if (args->next != NULL)
2710 gfc_error_now ("More actual than formal arguments in '%s' "
2711 "call at %L", name, &(args->expr->where));
2714 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2716 /* Make sure we have either the target or pointer attribute. */
2717 if (!arg_attr.target && !arg_attr.pointer)
2719 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2720 "a TARGET or an associated pointer",
2722 sym->name, &(args->expr->where));
2726 /* See if we have interoperable type and type param. */
2727 if (verify_c_interop (arg_ts) == SUCCESS
2728 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2730 if (args_sym->attr.target == 1)
2732 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2733 has the target attribute and is interoperable. */
2734 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2735 allocatable variable that has the TARGET attribute and
2736 is not an array of zero size. */
2737 if (args_sym->attr.allocatable == 1)
2739 if (args_sym->attr.dimension != 0
2740 && (args_sym->as && args_sym->as->rank == 0))
2742 gfc_error_now ("Allocatable variable '%s' used as a "
2743 "parameter to '%s' at %L must not be "
2744 "an array of zero size",
2745 args_sym->name, sym->name,
2746 &(args->expr->where));
2752 /* A non-allocatable target variable with C
2753 interoperable type and type parameters must be
2755 if (args_sym && args_sym->attr.dimension)
2757 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2759 gfc_error ("Assumed-shape array '%s' at %L "
2760 "cannot be an argument to the "
2761 "procedure '%s' because "
2762 "it is not C interoperable",
2764 &(args->expr->where), sym->name);
2767 else if (args_sym->as->type == AS_DEFERRED)
2769 gfc_error ("Deferred-shape array '%s' at %L "
2770 "cannot be an argument to the "
2771 "procedure '%s' because "
2772 "it is not C interoperable",
2774 &(args->expr->where), sym->name);
2779 /* Make sure it's not a character string. Arrays of
2780 any type should be ok if the variable is of a C
2781 interoperable type. */
2782 if (arg_ts->type == BT_CHARACTER)
2783 if (arg_ts->u.cl != NULL
2784 && (arg_ts->u.cl->length == NULL
2785 || arg_ts->u.cl->length->expr_type
2788 (arg_ts->u.cl->length->value.integer, 1)
2790 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2792 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2793 "at %L must have a length of 1",
2794 args_sym->name, sym->name,
2795 &(args->expr->where));
2800 else if (arg_attr.pointer
2801 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2803 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2805 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2806 "associated scalar POINTER", args_sym->name,
2807 sym->name, &(args->expr->where));
2813 /* The parameter is not required to be C interoperable. If it
2814 is not C interoperable, it must be a nonpolymorphic scalar
2815 with no length type parameters. It still must have either
2816 the pointer or target attribute, and it can be
2817 allocatable (but must be allocated when c_loc is called). */
2818 if (args->expr->rank != 0
2819 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2821 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2822 "scalar", args_sym->name, sym->name,
2823 &(args->expr->where));
2826 else if (arg_ts->type == BT_CHARACTER
2827 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2829 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2830 "%L must have a length of 1",
2831 args_sym->name, sym->name,
2832 &(args->expr->where));
2835 else if (arg_ts->type == BT_CLASS)
2837 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2838 "polymorphic", args_sym->name, sym->name,
2839 &(args->expr->where));
2844 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2846 if (args_sym->attr.flavor != FL_PROCEDURE)
2848 /* TODO: Update this error message to allow for procedure
2849 pointers once they are implemented. */
2850 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2852 args_sym->name, sym->name,
2853 &(args->expr->where));
2856 else if (args_sym->attr.is_bind_c != 1)
2858 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2860 args_sym->name, sym->name,
2861 &(args->expr->where));
2866 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2871 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2872 "iso_c_binding function: '%s'!\n", sym->name);
2879 /* Resolve a function call, which means resolving the arguments, then figuring
2880 out which entity the name refers to. */
2881 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2882 to INTENT(OUT) or INTENT(INOUT). */
2885 resolve_function (gfc_expr *expr)
2887 gfc_actual_arglist *arg;
2892 procedure_type p = PROC_INTRINSIC;
2893 bool no_formal_args;
2897 sym = expr->symtree->n.sym;
2899 /* If this is a procedure pointer component, it has already been resolved. */
2900 if (gfc_is_proc_ptr_comp (expr, NULL))
2903 if (sym && sym->attr.intrinsic
2904 && resolve_intrinsic (sym, &expr->where) == FAILURE)
2907 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2909 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2913 /* If this ia a deferred TBP with an abstract interface (which may
2914 of course be referenced), expr->value.function.esym will be set. */
2915 if (sym && sym->attr.abstract && !expr->value.function.esym)
2917 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2918 sym->name, &expr->where);
2922 /* Switch off assumed size checking and do this again for certain kinds
2923 of procedure, once the procedure itself is resolved. */
2924 need_full_assumed_size++;
2926 if (expr->symtree && expr->symtree->n.sym)
2927 p = expr->symtree->n.sym->attr.proc;
2929 if (expr->value.function.isym && expr->value.function.isym->inquiry)
2930 inquiry_argument = true;
2931 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2933 if (resolve_actual_arglist (expr->value.function.actual,
2934 p, no_formal_args) == FAILURE)
2936 inquiry_argument = false;
2940 inquiry_argument = false;
2942 /* Need to setup the call to the correct c_associated, depending on
2943 the number of cptrs to user gives to compare. */
2944 if (sym && sym->attr.is_iso_c == 1)
2946 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2950 /* Get the symtree for the new symbol (resolved func).
2951 the old one will be freed later, when it's no longer used. */
2952 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2955 /* Resume assumed_size checking. */
2956 need_full_assumed_size--;
2958 /* If the procedure is external, check for usage. */
2959 if (sym && is_external_proc (sym))
2960 resolve_global_procedure (sym, &expr->where,
2961 &expr->value.function.actual, 0);
2963 if (sym && sym->ts.type == BT_CHARACTER
2965 && sym->ts.u.cl->length == NULL
2967 && expr->value.function.esym == NULL
2968 && !sym->attr.contained)
2970 /* Internal procedures are taken care of in resolve_contained_fntype. */
2971 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2972 "be used at %L since it is not a dummy argument",
2973 sym->name, &expr->where);
2977 /* See if function is already resolved. */
2979 if (expr->value.function.name != NULL)
2981 if (expr->ts.type == BT_UNKNOWN)
2987 /* Apply the rules of section 14.1.2. */
2989 switch (procedure_kind (sym))
2992 t = resolve_generic_f (expr);
2995 case PTYPE_SPECIFIC:
2996 t = resolve_specific_f (expr);
3000 t = resolve_unknown_f (expr);
3004 gfc_internal_error ("resolve_function(): bad function type");
3008 /* If the expression is still a function (it might have simplified),
3009 then we check to see if we are calling an elemental function. */
3011 if (expr->expr_type != EXPR_FUNCTION)
3014 temp = need_full_assumed_size;
3015 need_full_assumed_size = 0;
3017 if (resolve_elemental_actual (expr, NULL) == FAILURE)
3020 if (omp_workshare_flag
3021 && expr->value.function.esym
3022 && ! gfc_elemental (expr->value.function.esym))
3024 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3025 "in WORKSHARE construct", expr->value.function.esym->name,
3030 #define GENERIC_ID expr->value.function.isym->id
3031 else if (expr->value.function.actual != NULL
3032 && expr->value.function.isym != NULL
3033 && GENERIC_ID != GFC_ISYM_LBOUND
3034 && GENERIC_ID != GFC_ISYM_LEN
3035 && GENERIC_ID != GFC_ISYM_LOC
3036 && GENERIC_ID != GFC_ISYM_PRESENT)
3038 /* Array intrinsics must also have the last upper bound of an
3039 assumed size array argument. UBOUND and SIZE have to be
3040 excluded from the check if the second argument is anything
3043 for (arg = expr->value.function.actual; arg; arg = arg->next)
3045 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3046 && arg->next != NULL && arg->next->expr)
3048 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3051 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3054 if ((int)mpz_get_si (arg->next->expr->value.integer)
3059 if (arg->expr != NULL
3060 && arg->expr->rank > 0
3061 && resolve_assumed_size_actual (arg->expr))
3067 need_full_assumed_size = temp;
3070 if (!pure_function (expr, &name) && name)
3074 gfc_error ("reference to non-PURE function '%s' at %L inside a "
3075 "FORALL %s", name, &expr->where,
3076 forall_flag == 2 ? "mask" : "block");
3079 else if (gfc_pure (NULL))
3081 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3082 "procedure within a PURE procedure", name, &expr->where);
3087 /* Functions without the RECURSIVE attribution are not allowed to
3088 * call themselves. */
3089 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3092 esym = expr->value.function.esym;
3094 if (is_illegal_recursion (esym, gfc_current_ns))
3096 if (esym->attr.entry && esym->ns->entries)
3097 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3098 " function '%s' is not RECURSIVE",
3099 esym->name, &expr->where, esym->ns->entries->sym->name);
3101 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3102 " is not RECURSIVE", esym->name, &expr->where);
3108 /* Character lengths of use associated functions may contains references to
3109 symbols not referenced from the current program unit otherwise. Make sure
3110 those symbols are marked as referenced. */
3112 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3113 && expr->value.function.esym->attr.use_assoc)
3115 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3119 && !((expr->value.function.esym
3120 && expr->value.function.esym->attr.elemental)
3122 (expr->value.function.isym
3123 && expr->value.function.isym->elemental)))
3124 find_noncopying_intrinsics (expr->value.function.esym,
3125 expr->value.function.actual);
3127 /* Make sure that the expression has a typespec that works. */
3128 if (expr->ts.type == BT_UNKNOWN)
3130 if (expr->symtree->n.sym->result
3131 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3132 && !expr->symtree->n.sym->result->attr.proc_pointer)
3133 expr->ts = expr->symtree->n.sym->result->ts;
3140 /************* Subroutine resolution *************/
3143 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3149 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3150 sym->name, &c->loc);
3151 else if (gfc_pure (NULL))
3152 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3158 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3162 if (sym->attr.generic)
3164 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3167 c->resolved_sym = s;
3168 pure_subroutine (c, s);
3172 /* TODO: Need to search for elemental references in generic interface. */
3175 if (sym->attr.intrinsic)
3176 return gfc_intrinsic_sub_interface (c, 0);
3183 resolve_generic_s (gfc_code *c)
3188 sym = c->symtree->n.sym;
3192 m = resolve_generic_s0 (c, sym);
3195 else if (m == MATCH_ERROR)
3199 if (sym->ns->parent == NULL)
3201 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3205 if (!generic_sym (sym))
3209 /* Last ditch attempt. See if the reference is to an intrinsic
3210 that possesses a matching interface. 14.1.2.4 */
3211 sym = c->symtree->n.sym;
3213 if (!gfc_is_intrinsic (sym, 1, c->loc))
3215 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3216 sym->name, &c->loc);
3220 m = gfc_intrinsic_sub_interface (c, 0);
3224 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3225 "intrinsic subroutine interface", sym->name, &c->loc);
3231 /* Set the name and binding label of the subroutine symbol in the call
3232 expression represented by 'c' to include the type and kind of the
3233 second parameter. This function is for resolving the appropriate
3234 version of c_f_pointer() and c_f_procpointer(). For example, a
3235 call to c_f_pointer() for a default integer pointer could have a
3236 name of c_f_pointer_i4. If no second arg exists, which is an error
3237 for these two functions, it defaults to the generic symbol's name
3238 and binding label. */
3241 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3242 char *name, char *binding_label)
3244 gfc_expr *arg = NULL;
3248 /* The second arg of c_f_pointer and c_f_procpointer determines
3249 the type and kind for the procedure name. */
3250 arg = c->ext.actual->next->expr;
3254 /* Set up the name to have the given symbol's name,
3255 plus the type and kind. */
3256 /* a derived type is marked with the type letter 'u' */
3257 if (arg->ts.type == BT_DERIVED)
3260 kind = 0; /* set the kind as 0 for now */
3264 type = gfc_type_letter (arg->ts.type);
3265 kind = arg->ts.kind;
3268 if (arg->ts.type == BT_CHARACTER)
3269 /* Kind info for character strings not needed. */
3272 sprintf (name, "%s_%c%d", sym->name, type, kind);
3273 /* Set up the binding label as the given symbol's label plus
3274 the type and kind. */
3275 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
3279 /* If the second arg is missing, set the name and label as
3280 was, cause it should at least be found, and the missing
3281 arg error will be caught by compare_parameters(). */
3282 sprintf (name, "%s", sym->name);
3283 sprintf (binding_label, "%s", sym->binding_label);
3290 /* Resolve a generic version of the iso_c_binding procedure given
3291 (sym) to the specific one based on the type and kind of the
3292 argument(s). Currently, this function resolves c_f_pointer() and
3293 c_f_procpointer based on the type and kind of the second argument
3294 (FPTR). Other iso_c_binding procedures aren't specially handled.
3295 Upon successfully exiting, c->resolved_sym will hold the resolved
3296 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3300 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3302 gfc_symbol *new_sym;
3303 /* this is fine, since we know the names won't use the max */
3304 char name[GFC_MAX_SYMBOL_LEN + 1];
3305 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
3306 /* default to success; will override if find error */
3307 match m = MATCH_YES;
3309 /* Make sure the actual arguments are in the necessary order (based on the
3310 formal args) before resolving. */
3311 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3313 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3314 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3316 set_name_and_label (c, sym, name, binding_label);
3318 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3320 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3322 /* Make sure we got a third arg if the second arg has non-zero
3323 rank. We must also check that the type and rank are
3324 correct since we short-circuit this check in
3325 gfc_procedure_use() (called above to sort actual args). */
3326 if (c->ext.actual->next->expr->rank != 0)
3328 if(c->ext.actual->next->next == NULL
3329 || c->ext.actual->next->next->expr == NULL)
3332 gfc_error ("Missing SHAPE parameter for call to %s "
3333 "at %L", sym->name, &(c->loc));
3335 else if (c->ext.actual->next->next->expr->ts.type
3337 || c->ext.actual->next->next->expr->rank != 1)
3340 gfc_error ("SHAPE parameter for call to %s at %L must "
3341 "be a rank 1 INTEGER array", sym->name,
3348 if (m != MATCH_ERROR)
3350 /* the 1 means to add the optional arg to formal list */
3351 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3353 /* for error reporting, say it's declared where the original was */
3354 new_sym->declared_at = sym->declared_at;
3359 /* no differences for c_loc or c_funloc */
3363 /* set the resolved symbol */
3364 if (m != MATCH_ERROR)
3365 c->resolved_sym = new_sym;
3367 c->resolved_sym = sym;
3373 /* Resolve a subroutine call known to be specific. */
3376 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3380 if(sym->attr.is_iso_c)
3382 m = gfc_iso_c_sub_interface (c,sym);
3386 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3388 if (sym->attr.dummy)
3390 sym->attr.proc = PROC_DUMMY;
3394 sym->attr.proc = PROC_EXTERNAL;
3398 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3401 if (sym->attr.intrinsic)
3403 m = gfc_intrinsic_sub_interface (c, 1);
3407 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3408 "with an intrinsic", sym->name, &c->loc);
3416 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3418 c->resolved_sym = sym;
3419 pure_subroutine (c, sym);
3426 resolve_specific_s (gfc_code *c)
3431 sym = c->symtree->n.sym;
3435 m = resolve_specific_s0 (c, sym);
3438 if (m == MATCH_ERROR)
3441 if (sym->ns->parent == NULL)
3444 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3450 sym = c->symtree->n.sym;
3451 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3452 sym->name, &c->loc);
3458 /* Resolve a subroutine call not known to be generic nor specific. */
3461 resolve_unknown_s (gfc_code *c)
3465 sym = c->symtree->n.sym;
3467 if (sym->attr.dummy)
3469 sym->attr.proc = PROC_DUMMY;
3473 /* See if we have an intrinsic function reference. */
3475 if (gfc_is_intrinsic (sym, 1, c->loc))
3477 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3482 /* The reference is to an external name. */
3485 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3487 c->resolved_sym = sym;
3489 pure_subroutine (c, sym);
3495 /* Resolve a subroutine call. Although it was tempting to use the same code
3496 for functions, subroutines and functions are stored differently and this
3497 makes things awkward. */
3500 resolve_call (gfc_code *c)
3503 procedure_type ptype = PROC_INTRINSIC;
3504 gfc_symbol *csym, *sym;
3505 bool no_formal_args;
3507 csym = c->symtree ? c->symtree->n.sym : NULL;
3509 if (csym && csym->ts.type != BT_UNKNOWN)
3511 gfc_error ("'%s' at %L has a type, which is not consistent with "
3512 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3516 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3519 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3520 sym = st ? st->n.sym : NULL;
3521 if (sym && csym != sym
3522 && sym->ns == gfc_current_ns
3523 && sym->attr.flavor == FL_PROCEDURE
3524 && sym->attr.contained)
3527 if (csym->attr.generic)
3528 c->symtree->n.sym = sym;
3531 csym = c->symtree->n.sym;
3535 /* If this ia a deferred TBP with an abstract interface
3536 (which may of course be referenced), c->expr1 will be set. */
3537 if (csym && csym->attr.abstract && !c->expr1)
3539 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3540 csym->name, &c->loc);
3544 /* Subroutines without the RECURSIVE attribution are not allowed to
3545 * call themselves. */
3546 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3548 if (csym->attr.entry && csym->ns->entries)
3549 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3550 " subroutine '%s' is not RECURSIVE",
3551 csym->name, &c->loc, csym->ns->entries->sym->name);
3553 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3554 " is not RECURSIVE", csym->name, &c->loc);
3559 /* Switch off assumed size checking and do this again for certain kinds
3560 of procedure, once the procedure itself is resolved. */
3561 need_full_assumed_size++;
3564 ptype = csym->attr.proc;
3566 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3567 if (resolve_actual_arglist (c->ext.actual, ptype,
3568 no_formal_args) == FAILURE)
3571 /* Resume assumed_size checking. */
3572 need_full_assumed_size--;
3574 /* If external, check for usage. */
3575 if (csym && is_external_proc (csym))
3576 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3579 if (c->resolved_sym == NULL)
3581 c->resolved_isym = NULL;
3582 switch (procedure_kind (csym))
3585 t = resolve_generic_s (c);
3588 case PTYPE_SPECIFIC:
3589 t = resolve_specific_s (c);
3593 t = resolve_unknown_s (c);
3597 gfc_internal_error ("resolve_subroutine(): bad function type");
3601 /* Some checks of elemental subroutine actual arguments. */
3602 if (resolve_elemental_actual (NULL, c) == FAILURE)
3605 if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental))
3606 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
3611 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3612 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3613 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3614 if their shapes do not match. If either op1->shape or op2->shape is
3615 NULL, return SUCCESS. */
3618 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3625 if (op1->shape != NULL && op2->shape != NULL)
3627 for (i = 0; i < op1->rank; i++)
3629 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3631 gfc_error ("Shapes for operands at %L and %L are not conformable",
3632 &op1->where, &op2->where);
3643 /* Resolve an operator expression node. This can involve replacing the
3644 operation with a user defined function call. */
3647 resolve_operator (gfc_expr *e)
3649 gfc_expr *op1, *op2;
3651 bool dual_locus_error;
3654 /* Resolve all subnodes-- give them types. */
3656 switch (e->value.op.op)
3659 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3662 /* Fall through... */
3665 case INTRINSIC_UPLUS:
3666 case INTRINSIC_UMINUS:
3667 case INTRINSIC_PARENTHESES:
3668 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3673 /* Typecheck the new node. */
3675 op1 = e->value.op.op1;
3676 op2 = e->value.op.op2;
3677 dual_locus_error = false;
3679 if ((op1 && op1->expr_type == EXPR_NULL)
3680 || (op2 && op2->expr_type == EXPR_NULL))
3682 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3686 switch (e->value.op.op)
3688 case INTRINSIC_UPLUS:
3689 case INTRINSIC_UMINUS:
3690 if (op1->ts.type == BT_INTEGER
3691 || op1->ts.type == BT_REAL
3692 || op1->ts.type == BT_COMPLEX)
3698 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3699 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3702 case INTRINSIC_PLUS:
3703 case INTRINSIC_MINUS:
3704 case INTRINSIC_TIMES:
3705 case INTRINSIC_DIVIDE:
3706 case INTRINSIC_POWER:
3707 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3709 gfc_type_convert_binary (e, 1);
3714 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3715 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3716 gfc_typename (&op2->ts));
3719 case INTRINSIC_CONCAT:
3720 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3721 && op1->ts.kind == op2->ts.kind)
3723 e->ts.type = BT_CHARACTER;
3724 e->ts.kind = op1->ts.kind;
3729 _("Operands of string concatenation operator at %%L are %s/%s"),
3730 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3736 case INTRINSIC_NEQV:
3737 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3739 e->ts.type = BT_LOGICAL;
3740 e->ts.kind = gfc_kind_max (op1, op2);
3741 if (op1->ts.kind < e->ts.kind)
3742 gfc_convert_type (op1, &e->ts, 2);
3743 else if (op2->ts.kind < e->ts.kind)
3744 gfc_convert_type (op2, &e->ts, 2);
3748 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3749 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3750 gfc_typename (&op2->ts));
3755 if (op1->ts.type == BT_LOGICAL)
3757 e->ts.type = BT_LOGICAL;
3758 e->ts.kind = op1->ts.kind;
3762 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3763 gfc_typename (&op1->ts));
3767 case INTRINSIC_GT_OS:
3769 case INTRINSIC_GE_OS:
3771 case INTRINSIC_LT_OS:
3773 case INTRINSIC_LE_OS:
3774 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3776 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3780 /* Fall through... */
3783 case INTRINSIC_EQ_OS:
3785 case INTRINSIC_NE_OS:
3786 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3787 && op1->ts.kind == op2->ts.kind)
3789 e->ts.type = BT_LOGICAL;
3790 e->ts.kind = gfc_default_logical_kind;
3794 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3796 gfc_type_convert_binary (e, 1);
3798 e->ts.type = BT_LOGICAL;
3799 e->ts.kind = gfc_default_logical_kind;
3803 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3805 _("Logicals at %%L must be compared with %s instead of %s"),
3806 (e->value.op.op == INTRINSIC_EQ
3807 || e->value.op.op == INTRINSIC_EQ_OS)
3808 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3811 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3812 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3813 gfc_typename (&op2->ts));
3817 case INTRINSIC_USER:
3818 if (e->value.op.uop->op == NULL)
3819 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3820 else if (op2 == NULL)
3821 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3822 e->value.op.uop->name, gfc_typename (&op1->ts));
3824 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3825 e->value.op.uop->name, gfc_typename (&op1->ts),
3826 gfc_typename (&op2->ts));
3830 case INTRINSIC_PARENTHESES:
3832 if (e->ts.type == BT_CHARACTER)
3833 e->ts.u.cl = op1->ts.u.cl;
3837 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3840 /* Deal with arrayness of an operand through an operator. */
3844 switch (e->value.op.op)
3846 case INTRINSIC_PLUS:
3847 case INTRINSIC_MINUS:
3848 case INTRINSIC_TIMES:
3849 case INTRINSIC_DIVIDE:
3850 case INTRINSIC_POWER:
3851 case INTRINSIC_CONCAT:
3855 case INTRINSIC_NEQV:
3857 case INTRINSIC_EQ_OS:
3859 case INTRINSIC_NE_OS:
3861 case INTRINSIC_GT_OS:
3863 case INTRINSIC_GE_OS:
3865 case INTRINSIC_LT_OS:
3867 case INTRINSIC_LE_OS:
3869 if (op1->rank == 0 && op2->rank == 0)
3872 if (op1->rank == 0 && op2->rank != 0)
3874 e->rank = op2->rank;
3876 if (e->shape == NULL)
3877 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3880 if (op1->rank != 0 && op2->rank == 0)
3882 e->rank = op1->rank;
3884 if (e->shape == NULL)
3885 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3888 if (op1->rank != 0 && op2->rank != 0)
3890 if (op1->rank == op2->rank)
3892 e->rank = op1->rank;
3893 if (e->shape == NULL)
3895 t = compare_shapes (op1, op2);
3899 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3904 /* Allow higher level expressions to work. */
3907 /* Try user-defined operators, and otherwise throw an error. */
3908 dual_locus_error = true;
3910 _("Inconsistent ranks for operator at %%L and %%L"));
3917 case INTRINSIC_PARENTHESES:
3919 case INTRINSIC_UPLUS:
3920 case INTRINSIC_UMINUS:
3921 /* Simply copy arrayness attribute */
3922 e->rank = op1->rank;
3924 if (e->shape == NULL)
3925 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3933 /* Attempt to simplify the expression. */
3936 t = gfc_simplify_expr (e, 0);
3937 /* Some calls do not succeed in simplification and return FAILURE
3938 even though there is no error; e.g. variable references to
3939 PARAMETER arrays. */
3940 if (!gfc_is_constant_expr (e))
3949 if (gfc_extend_expr (e, &real_error) == SUCCESS)
3956 if (dual_locus_error)
3957 gfc_error (msg, &op1->where, &op2->where);
3959 gfc_error (msg, &e->where);
3965 /************** Array resolution subroutines **************/
3968 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3971 /* Compare two integer expressions. */
3974 compare_bound (gfc_expr *a, gfc_expr *b)
3978 if (a == NULL || a->expr_type != EXPR_CONSTANT
3979 || b == NULL || b->expr_type != EXPR_CONSTANT)
3982 /* If either of the types isn't INTEGER, we must have
3983 raised an error earlier. */
3985 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3988 i = mpz_cmp (a->value.integer, b->value.integer);
3998 /* Compare an integer expression with an integer. */
4001 compare_bound_int (gfc_expr *a, int b)
4005 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4008 if (a->ts.type != BT_INTEGER)
4009 gfc_internal_error ("compare_bound_int(): Bad expression");
4011 i = mpz_cmp_si (a->value.integer, b);
4021 /* Compare an integer expression with a mpz_t. */
4024 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4028 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4031 if (a->ts.type != BT_INTEGER)
4032 gfc_internal_error ("compare_bound_int(): Bad expression");
4034 i = mpz_cmp (a->value.integer, b);
4044 /* Compute the last value of a sequence given by a triplet.
4045 Return 0 if it wasn't able to compute the last value, or if the
4046 sequence if empty, and 1 otherwise. */
4049 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4050 gfc_expr *stride, mpz_t last)
4054 if (start == NULL || start->expr_type != EXPR_CONSTANT
4055 || end == NULL || end->expr_type != EXPR_CONSTANT
4056 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4059 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4060 || (stride != NULL && stride->ts.type != BT_INTEGER))
4063 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
4065 if (compare_bound (start, end) == CMP_GT)
4067 mpz_set (last, end->value.integer);
4071 if (compare_bound_int (stride, 0) == CMP_GT)
4073 /* Stride is positive */
4074 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4079 /* Stride is negative */
4080 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4085 mpz_sub (rem, end->value.integer, start->value.integer);
4086 mpz_tdiv_r (rem, rem, stride->value.integer);
4087 mpz_sub (last, end->value.integer, rem);
4094 /* Compare a single dimension of an array reference to the array
4098 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4102 if (ar->dimen_type[i] == DIMEN_STAR)
4104 gcc_assert (ar->stride[i] == NULL);
4105 /* This implies [*] as [*:] and [*:3] are not possible. */
4106 if (ar->start[i] == NULL)
4108 gcc_assert (ar->end[i] == NULL);
4113 /* Given start, end and stride values, calculate the minimum and
4114 maximum referenced indexes. */
4116 switch (ar->dimen_type[i])
4123 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4126 gfc_warning ("Array reference at %L is out of bounds "
4127 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4128 mpz_get_si (ar->start[i]->value.integer),
4129 mpz_get_si (as->lower[i]->value.integer), i+1);
4131 gfc_warning ("Array reference at %L is out of bounds "
4132 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4133 mpz_get_si (ar->start[i]->value.integer),
4134 mpz_get_si (as->lower[i]->value.integer),
4138 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4141 gfc_warning ("Array reference at %L is out of bounds "
4142 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4143 mpz_get_si (ar->start[i]->value.integer),
4144 mpz_get_si (as->upper[i]->value.integer), i+1);
4146 gfc_warning ("Array reference at %L is out of bounds "
4147 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4148 mpz_get_si (ar->start[i]->value.integer),
4149 mpz_get_si (as->upper[i]->value.integer),
4158 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4159 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4161 comparison comp_start_end = compare_bound (AR_START, AR_END);
4163 /* Check for zero stride, which is not allowed. */
4164 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4166 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4170 /* if start == len || (stride > 0 && start < len)
4171 || (stride < 0 && start > len),
4172 then the array section contains at least one element. In this
4173 case, there is an out-of-bounds access if
4174 (start < lower || start > upper). */
4175 if (compare_bound (AR_START, AR_END) == CMP_EQ
4176 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4177 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4178 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4179 && comp_start_end == CMP_GT))
4181 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
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->lower[i]->value.integer), i+1);
4189 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4191 gfc_warning ("Lower array reference at %L is out of bounds "
4192 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4193 mpz_get_si (AR_START->value.integer),
4194 mpz_get_si (as->upper[i]->value.integer), i+1);
4199 /* If we can compute the highest index of the array section,
4200 then it also has to be between lower and upper. */
4201 mpz_init (last_value);
4202 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4205 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4207 gfc_warning ("Upper array reference at %L is out of bounds "
4208 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4209 mpz_get_si (last_value),
4210 mpz_get_si (as->lower[i]->value.integer), i+1);
4211 mpz_clear (last_value);
4214 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4216 gfc_warning ("Upper array reference at %L is out of bounds "
4217 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4218 mpz_get_si (last_value),
4219 mpz_get_si (as->upper[i]->value.integer), i+1);
4220 mpz_clear (last_value);
4224 mpz_clear (last_value);
4232 gfc_internal_error ("check_dimension(): Bad array reference");
4239 /* Compare an array reference with an array specification. */
4242 compare_spec_to_ref (gfc_array_ref *ar)
4249 /* TODO: Full array sections are only allowed as actual parameters. */
4250 if (as->type == AS_ASSUMED_SIZE
4251 && (/*ar->type == AR_FULL
4252 ||*/ (ar->type == AR_SECTION
4253 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4255 gfc_error ("Rightmost upper bound of assumed size array section "
4256 "not specified at %L", &ar->where);
4260 if (ar->type == AR_FULL)
4263 if (as->rank != ar->dimen)
4265 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4266 &ar->where, ar->dimen, as->rank);
4270 /* ar->codimen == 0 is a local array. */
4271 if (as->corank != ar->codimen && ar->codimen != 0)
4273 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4274 &ar->where, ar->codimen, as->corank);
4278 for (i = 0; i < as->rank; i++)
4279 if (check_dimension (i, ar, as) == FAILURE)
4282 /* Local access has no coarray spec. */
4283 if (ar->codimen != 0)
4284 for (i = as->rank; i < as->rank + as->corank; i++)
4286 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
4288 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4289 i + 1 - as->rank, &ar->where);
4292 if (check_dimension (i, ar, as) == FAILURE)
4300 /* Resolve one part of an array index. */
4303 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4304 int force_index_integer_kind)
4311 if (gfc_resolve_expr (index) == FAILURE)
4314 if (check_scalar && index->rank != 0)
4316 gfc_error ("Array index at %L must be scalar", &index->where);
4320 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4322 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4323 &index->where, gfc_basic_typename (index->ts.type));
4327 if (index->ts.type == BT_REAL)
4328 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
4329 &index->where) == FAILURE)
4332 if ((index->ts.kind != gfc_index_integer_kind
4333 && force_index_integer_kind)
4334 || index->ts.type != BT_INTEGER)
4337 ts.type = BT_INTEGER;
4338 ts.kind = gfc_index_integer_kind;
4340 gfc_convert_type_warn (index, &ts, 2, 0);
4346 /* Resolve one part of an array index. */
4349 gfc_resolve_index (gfc_expr *index, int check_scalar)
4351 return gfc_resolve_index_1 (index, check_scalar, 1);
4354 /* Resolve a dim argument to an intrinsic function. */
4357 gfc_resolve_dim_arg (gfc_expr *dim)
4362 if (gfc_resolve_expr (dim) == FAILURE)
4367 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4372 if (dim->ts.type != BT_INTEGER)
4374 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4378 if (dim->ts.kind != gfc_index_integer_kind)
4383 ts.type = BT_INTEGER;
4384 ts.kind = gfc_index_integer_kind;
4386 gfc_convert_type_warn (dim, &ts, 2, 0);
4392 /* Given an expression that contains array references, update those array
4393 references to point to the right array specifications. While this is
4394 filled in during matching, this information is difficult to save and load
4395 in a module, so we take care of it here.
4397 The idea here is that the original array reference comes from the
4398 base symbol. We traverse the list of reference structures, setting
4399 the stored reference to references. Component references can
4400 provide an additional array specification. */
4403 find_array_spec (gfc_expr *e)
4407 gfc_symbol *derived;
4410 if (e->symtree->n.sym->ts.type == BT_CLASS)
4411 as = CLASS_DATA (e->symtree->n.sym)->as;
4413 as = e->symtree->n.sym->as;
4416 for (ref = e->ref; ref; ref = ref->next)
4421 gfc_internal_error ("find_array_spec(): Missing spec");
4428 if (derived == NULL)
4429 derived = e->symtree->n.sym->ts.u.derived;
4431 if (derived->attr.is_class)
4432 derived = derived->components->ts.u.derived;
4434 c = derived->components;
4436 for (; c; c = c->next)
4437 if (c == ref->u.c.component)
4439 /* Track the sequence of component references. */
4440 if (c->ts.type == BT_DERIVED)
4441 derived = c->ts.u.derived;
4446 gfc_internal_error ("find_array_spec(): Component not found");
4448 if (c->attr.dimension)
4451 gfc_internal_error ("find_array_spec(): unused as(1)");
4462 gfc_internal_error ("find_array_spec(): unused as(2)");
4466 /* Resolve an array reference. */
4469 resolve_array_ref (gfc_array_ref *ar)
4471 int i, check_scalar;
4474 for (i = 0; i < ar->dimen + ar->codimen; i++)
4476 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4478 /* Do not force gfc_index_integer_kind for the start. We can
4479 do fine with any integer kind. This avoids temporary arrays
4480 created for indexing with a vector. */
4481 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4483 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4485 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4490 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4494 ar->dimen_type[i] = DIMEN_ELEMENT;
4498 ar->dimen_type[i] = DIMEN_VECTOR;
4499 if (e->expr_type == EXPR_VARIABLE
4500 && e->symtree->n.sym->ts.type == BT_DERIVED)
4501 ar->start[i] = gfc_get_parentheses (e);
4505 gfc_error ("Array index at %L is an array of rank %d",
4506 &ar->c_where[i], e->rank);
4510 /* Fill in the upper bound, which may be lower than the
4511 specified one for something like a(2:10:5), which is
4512 identical to a(2:7:5). Only relevant for strides not equal
4514 if (ar->dimen_type[i] == DIMEN_RANGE
4515 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4516 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0)
4520 if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4522 if (ar->end[i] == NULL)
4525 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4527 mpz_set (ar->end[i]->value.integer, end);
4529 else if (ar->end[i]->ts.type == BT_INTEGER
4530 && ar->end[i]->expr_type == EXPR_CONSTANT)
4532 mpz_set (ar->end[i]->value.integer, end);
4543 if (ar->type == AR_FULL && ar->as->rank == 0)
4544 ar->type = AR_ELEMENT;
4546 /* If the reference type is unknown, figure out what kind it is. */
4548 if (ar->type == AR_UNKNOWN)
4550 ar->type = AR_ELEMENT;
4551 for (i = 0; i < ar->dimen; i++)
4552 if (ar->dimen_type[i] == DIMEN_RANGE
4553 || ar->dimen_type[i] == DIMEN_VECTOR)
4555 ar->type = AR_SECTION;
4560 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4568 resolve_substring (gfc_ref *ref)
4570 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4572 if (ref->u.ss.start != NULL)
4574 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4577 if (ref->u.ss.start->ts.type != BT_INTEGER)
4579 gfc_error ("Substring start index at %L must be of type INTEGER",
4580 &ref->u.ss.start->where);
4584 if (ref->u.ss.start->rank != 0)
4586 gfc_error ("Substring start index at %L must be scalar",
4587 &ref->u.ss.start->where);
4591 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4592 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4593 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4595 gfc_error ("Substring start index at %L is less than one",
4596 &ref->u.ss.start->where);
4601 if (ref->u.ss.end != NULL)
4603 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4606 if (ref->u.ss.end->ts.type != BT_INTEGER)
4608 gfc_error ("Substring end index at %L must be of type INTEGER",
4609 &ref->u.ss.end->where);
4613 if (ref->u.ss.end->rank != 0)
4615 gfc_error ("Substring end index at %L must be scalar",
4616 &ref->u.ss.end->where);
4620 if (ref->u.ss.length != NULL
4621 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4622 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4623 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4625 gfc_error ("Substring end index at %L exceeds the string length",
4626 &ref->u.ss.start->where);
4630 if (compare_bound_mpz_t (ref->u.ss.end,
4631 gfc_integer_kinds[k].huge) == CMP_GT
4632 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4633 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4635 gfc_error ("Substring end index at %L is too large",
4636 &ref->u.ss.end->where);
4645 /* This function supplies missing substring charlens. */
4648 gfc_resolve_substring_charlen (gfc_expr *e)
4651 gfc_expr *start, *end;
4653 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4654 if (char_ref->type == REF_SUBSTRING)
4660 gcc_assert (char_ref->next == NULL);
4664 if (e->ts.u.cl->length)
4665 gfc_free_expr (e->ts.u.cl->length);
4666 else if (e->expr_type == EXPR_VARIABLE
4667 && e->symtree->n.sym->attr.dummy)
4671 e->ts.type = BT_CHARACTER;
4672 e->ts.kind = gfc_default_character_kind;
4675 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4677 if (char_ref->u.ss.start)
4678 start = gfc_copy_expr (char_ref->u.ss.start);
4680 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4682 if (char_ref->u.ss.end)
4683 end = gfc_copy_expr (char_ref->u.ss.end);
4684 else if (e->expr_type == EXPR_VARIABLE)
4685 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4692 /* Length = (end - start +1). */
4693 e->ts.u.cl->length = gfc_subtract (end, start);
4694 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4695 gfc_get_int_expr (gfc_default_integer_kind,
4698 e->ts.u.cl->length->ts.type = BT_INTEGER;
4699 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4701 /* Make sure that the length is simplified. */
4702 gfc_simplify_expr (e->ts.u.cl->length, 1);
4703 gfc_resolve_expr (e->ts.u.cl->length);
4707 /* Resolve subtype references. */
4710 resolve_ref (gfc_expr *expr)
4712 int current_part_dimension, n_components, seen_part_dimension;
4715 for (ref = expr->ref; ref; ref = ref->next)
4716 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4718 find_array_spec (expr);
4722 for (ref = expr->ref; ref; ref = ref->next)
4726 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4734 resolve_substring (ref);
4738 /* Check constraints on part references. */
4740 current_part_dimension = 0;
4741 seen_part_dimension = 0;
4744 for (ref = expr->ref; ref; ref = ref->next)
4749 switch (ref->u.ar.type)
4752 /* Coarray scalar. */
4753 if (ref->u.ar.as->rank == 0)
4755 current_part_dimension = 0;
4760 current_part_dimension = 1;
4764 current_part_dimension = 0;
4768 gfc_internal_error ("resolve_ref(): Bad array reference");
4774 if (current_part_dimension || seen_part_dimension)
4777 if (ref->u.c.component->attr.pointer
4778 || ref->u.c.component->attr.proc_pointer)
4780 gfc_error ("Component to the right of a part reference "
4781 "with nonzero rank must not have the POINTER "
4782 "attribute at %L", &expr->where);
4785 else if (ref->u.c.component->attr.allocatable)
4787 gfc_error ("Component to the right of a part reference "
4788 "with nonzero rank must not have the ALLOCATABLE "
4789 "attribute at %L", &expr->where);
4801 if (((ref->type == REF_COMPONENT && n_components > 1)
4802 || ref->next == NULL)
4803 && current_part_dimension
4804 && seen_part_dimension)
4806 gfc_error ("Two or more part references with nonzero rank must "
4807 "not be specified at %L", &expr->where);
4811 if (ref->type == REF_COMPONENT)
4813 if (current_part_dimension)
4814 seen_part_dimension = 1;
4816 /* reset to make sure */
4817 current_part_dimension = 0;
4825 /* Given an expression, determine its shape. This is easier than it sounds.
4826 Leaves the shape array NULL if it is not possible to determine the shape. */
4829 expression_shape (gfc_expr *e)
4831 mpz_t array[GFC_MAX_DIMENSIONS];
4834 if (e->rank == 0 || e->shape != NULL)
4837 for (i = 0; i < e->rank; i++)
4838 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4841 e->shape = gfc_get_shape (e->rank);
4843 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4848 for (i--; i >= 0; i--)
4849 mpz_clear (array[i]);
4853 /* Given a variable expression node, compute the rank of the expression by
4854 examining the base symbol and any reference structures it may have. */
4857 expression_rank (gfc_expr *e)
4862 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4863 could lead to serious confusion... */
4864 gcc_assert (e->expr_type != EXPR_COMPCALL);
4868 if (e->expr_type == EXPR_ARRAY)
4870 /* Constructors can have a rank different from one via RESHAPE(). */
4872 if (e->symtree == NULL)
4878 e->rank = (e->symtree->n.sym->as == NULL)
4879 ? 0 : e->symtree->n.sym->as->rank;
4885 for (ref = e->ref; ref; ref = ref->next)
4887 if (ref->type != REF_ARRAY)
4890 if (ref->u.ar.type == AR_FULL)
4892 rank = ref->u.ar.as->rank;
4896 if (ref->u.ar.type == AR_SECTION)
4898 /* Figure out the rank of the section. */
4900 gfc_internal_error ("expression_rank(): Two array specs");
4902 for (i = 0; i < ref->u.ar.dimen; i++)
4903 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4904 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4914 expression_shape (e);
4918 /* Resolve a variable expression. */
4921 resolve_variable (gfc_expr *e)
4928 if (e->symtree == NULL)
4930 sym = e->symtree->n.sym;
4932 /* If this is an associate-name, it may be parsed with an array reference
4933 in error even though the target is scalar. Fail directly in this case. */
4934 if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
4937 /* On the other hand, the parser may not have known this is an array;
4938 in this case, we have to add a FULL reference. */
4939 if (sym->assoc && sym->attr.dimension && !e->ref)
4941 e->ref = gfc_get_ref ();
4942 e->ref->type = REF_ARRAY;
4943 e->ref->u.ar.type = AR_FULL;
4944 e->ref->u.ar.dimen = 0;
4947 if (e->ref && resolve_ref (e) == FAILURE)
4950 if (sym->attr.flavor == FL_PROCEDURE
4951 && (!sym->attr.function
4952 || (sym->attr.function && sym->result
4953 && sym->result->attr.proc_pointer
4954 && !sym->result->attr.function)))
4956 e->ts.type = BT_PROCEDURE;
4957 goto resolve_procedure;
4960 if (sym->ts.type != BT_UNKNOWN)
4961 gfc_variable_attr (e, &e->ts);
4964 /* Must be a simple variable reference. */
4965 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4970 if (check_assumed_size_reference (sym, e))
4973 /* Deal with forward references to entries during resolve_code, to
4974 satisfy, at least partially, 12.5.2.5. */
4975 if (gfc_current_ns->entries
4976 && current_entry_id == sym->entry_id
4979 && cs_base->current->op != EXEC_ENTRY)
4981 gfc_entry_list *entry;
4982 gfc_formal_arglist *formal;
4986 /* If the symbol is a dummy... */
4987 if (sym->attr.dummy && sym->ns == gfc_current_ns)
4989 entry = gfc_current_ns->entries;
4992 /* ...test if the symbol is a parameter of previous entries. */
4993 for (; entry && entry->id <= current_entry_id; entry = entry->next)
4994 for (formal = entry->sym->formal; formal; formal = formal->next)
4996 if (formal->sym && sym->name == formal->sym->name)
5000 /* If it has not been seen as a dummy, this is an error. */
5003 if (specification_expr)
5004 gfc_error ("Variable '%s', used in a specification expression"
5005 ", is referenced at %L before the ENTRY statement "
5006 "in which it is a parameter",
5007 sym->name, &cs_base->current->loc);
5009 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5010 "statement in which it is a parameter",
5011 sym->name, &cs_base->current->loc);
5016 /* Now do the same check on the specification expressions. */
5017 specification_expr = 1;
5018 if (sym->ts.type == BT_CHARACTER
5019 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
5023 for (n = 0; n < sym->as->rank; n++)
5025 specification_expr = 1;
5026 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
5028 specification_expr = 1;
5029 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
5032 specification_expr = 0;
5035 /* Update the symbol's entry level. */
5036 sym->entry_id = current_entry_id + 1;
5039 /* If a symbol has been host_associated mark it. This is used latter,
5040 to identify if aliasing is possible via host association. */
5041 if (sym->attr.flavor == FL_VARIABLE
5042 && gfc_current_ns->parent
5043 && (gfc_current_ns->parent == sym->ns
5044 || (gfc_current_ns->parent->parent
5045 && gfc_current_ns->parent->parent == sym->ns)))
5046 sym->attr.host_assoc = 1;
5049 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
5052 /* F2008, C617 and C1229. */
5053 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5054 && gfc_is_coindexed (e))
5056 gfc_ref *ref, *ref2 = NULL;
5058 if (e->ts.type == BT_CLASS)
5060 gfc_error ("Polymorphic subobject of coindexed object at %L",
5065 for (ref = e->ref; ref; ref = ref->next)
5067 if (ref->type == REF_COMPONENT)
5069 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5073 for ( ; ref; ref = ref->next)
5074 if (ref->type == REF_COMPONENT)
5077 /* Expression itself is coindexed object. */
5081 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5082 for ( ; c; c = c->next)
5083 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5085 gfc_error ("Coindexed object with polymorphic allocatable "
5086 "subcomponent at %L", &e->where);
5097 /* Checks to see that the correct symbol has been host associated.
5098 The only situation where this arises is that in which a twice
5099 contained function is parsed after the host association is made.
5100 Therefore, on detecting this, change the symbol in the expression
5101 and convert the array reference into an actual arglist if the old
5102 symbol is a variable. */
5104 check_host_association (gfc_expr *e)
5106 gfc_symbol *sym, *old_sym;
5110 gfc_actual_arglist *arg, *tail = NULL;
5111 bool retval = e->expr_type == EXPR_FUNCTION;
5113 /* If the expression is the result of substitution in
5114 interface.c(gfc_extend_expr) because there is no way in
5115 which the host association can be wrong. */
5116 if (e->symtree == NULL
5117 || e->symtree->n.sym == NULL
5118 || e->user_operator)
5121 old_sym = e->symtree->n.sym;
5123 if (gfc_current_ns->parent
5124 && old_sym->ns != gfc_current_ns)
5126 /* Use the 'USE' name so that renamed module symbols are
5127 correctly handled. */
5128 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5130 if (sym && old_sym != sym
5131 && sym->ts.type == old_sym->ts.type
5132 && sym->attr.flavor == FL_PROCEDURE
5133 && sym->attr.contained)
5135 /* Clear the shape, since it might not be valid. */
5136 if (e->shape != NULL)
5138 for (n = 0; n < e->rank; n++)
5139 mpz_clear (e->shape[n]);
5141 gfc_free (e->shape);
5144 /* Give the expression the right symtree! */
5145 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5146 gcc_assert (st != NULL);
5148 if (old_sym->attr.flavor == FL_PROCEDURE
5149 || e->expr_type == EXPR_FUNCTION)
5151 /* Original was function so point to the new symbol, since
5152 the actual argument list is already attached to the
5154 e->value.function.esym = NULL;
5159 /* Original was variable so convert array references into
5160 an actual arglist. This does not need any checking now
5161 since gfc_resolve_function will take care of it. */
5162 e->value.function.actual = NULL;
5163 e->expr_type = EXPR_FUNCTION;
5166 /* Ambiguity will not arise if the array reference is not
5167 the last reference. */
5168 for (ref = e->ref; ref; ref = ref->next)
5169 if (ref->type == REF_ARRAY && ref->next == NULL)
5172 gcc_assert (ref->type == REF_ARRAY);
5174 /* Grab the start expressions from the array ref and
5175 copy them into actual arguments. */
5176 for (n = 0; n < ref->u.ar.dimen; n++)
5178 arg = gfc_get_actual_arglist ();
5179 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5180 if (e->value.function.actual == NULL)
5181 tail = e->value.function.actual = arg;
5189 /* Dump the reference list and set the rank. */
5190 gfc_free_ref_list (e->ref);
5192 e->rank = sym->as ? sym->as->rank : 0;
5195 gfc_resolve_expr (e);
5199 /* This might have changed! */
5200 return e->expr_type == EXPR_FUNCTION;
5205 gfc_resolve_character_operator (gfc_expr *e)
5207 gfc_expr *op1 = e->value.op.op1;
5208 gfc_expr *op2 = e->value.op.op2;
5209 gfc_expr *e1 = NULL;
5210 gfc_expr *e2 = NULL;
5212 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5214 if (op1->ts.u.cl && op1->ts.u.cl->length)
5215 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5216 else if (op1->expr_type == EXPR_CONSTANT)
5217 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5218 op1->value.character.length);
5220 if (op2->ts.u.cl && op2->ts.u.cl->length)
5221 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5222 else if (op2->expr_type == EXPR_CONSTANT)
5223 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5224 op2->value.character.length);
5226 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5231 e->ts.u.cl->length = gfc_add (e1, e2);
5232 e->ts.u.cl->length->ts.type = BT_INTEGER;
5233 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5234 gfc_simplify_expr (e->ts.u.cl->length, 0);
5235 gfc_resolve_expr (e->ts.u.cl->length);
5241 /* Ensure that an character expression has a charlen and, if possible, a
5242 length expression. */
5245 fixup_charlen (gfc_expr *e)
5247 /* The cases fall through so that changes in expression type and the need
5248 for multiple fixes are picked up. In all circumstances, a charlen should
5249 be available for the middle end to hang a backend_decl on. */
5250 switch (e->expr_type)
5253 gfc_resolve_character_operator (e);
5256 if (e->expr_type == EXPR_ARRAY)
5257 gfc_resolve_character_array_constructor (e);
5259 case EXPR_SUBSTRING:
5260 if (!e->ts.u.cl && e->ref)
5261 gfc_resolve_substring_charlen (e);
5265 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5272 /* Update an actual argument to include the passed-object for type-bound
5273 procedures at the right position. */
5275 static gfc_actual_arglist*
5276 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5279 gcc_assert (argpos > 0);
5283 gfc_actual_arglist* result;
5285 result = gfc_get_actual_arglist ();
5289 result->name = name;
5295 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5297 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5302 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5305 extract_compcall_passed_object (gfc_expr* e)
5309 gcc_assert (e->expr_type == EXPR_COMPCALL);
5311 if (e->value.compcall.base_object)
5312 po = gfc_copy_expr (e->value.compcall.base_object);
5315 po = gfc_get_expr ();
5316 po->expr_type = EXPR_VARIABLE;
5317 po->symtree = e->symtree;
5318 po->ref = gfc_copy_ref (e->ref);
5319 po->where = e->where;
5322 if (gfc_resolve_expr (po) == FAILURE)
5329 /* Update the arglist of an EXPR_COMPCALL expression to include the
5333 update_compcall_arglist (gfc_expr* e)
5336 gfc_typebound_proc* tbp;
5338 tbp = e->value.compcall.tbp;
5343 po = extract_compcall_passed_object (e);
5347 if (tbp->nopass || e->value.compcall.ignore_pass)
5353 gcc_assert (tbp->pass_arg_num > 0);
5354 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5362 /* Extract the passed object from a PPC call (a copy of it). */
5365 extract_ppc_passed_object (gfc_expr *e)
5370 po = gfc_get_expr ();
5371 po->expr_type = EXPR_VARIABLE;
5372 po->symtree = e->symtree;
5373 po->ref = gfc_copy_ref (e->ref);
5374 po->where = e->where;
5376 /* Remove PPC reference. */
5378 while ((*ref)->next)
5379 ref = &(*ref)->next;
5380 gfc_free_ref_list (*ref);
5383 if (gfc_resolve_expr (po) == FAILURE)
5390 /* Update the actual arglist of a procedure pointer component to include the
5394 update_ppc_arglist (gfc_expr* e)
5398 gfc_typebound_proc* tb;
5400 if (!gfc_is_proc_ptr_comp (e, &ppc))
5407 else if (tb->nopass)
5410 po = extract_ppc_passed_object (e);
5416 gfc_error ("Passed-object at %L must be scalar", &e->where);
5420 gcc_assert (tb->pass_arg_num > 0);
5421 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5429 /* Check that the object a TBP is called on is valid, i.e. it must not be
5430 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5433 check_typebound_baseobject (gfc_expr* e)
5437 base = extract_compcall_passed_object (e);
5441 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5443 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5445 gfc_error ("Base object for type-bound procedure call at %L is of"
5446 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5450 /* If the procedure called is NOPASS, the base object must be scalar. */
5451 if (e->value.compcall.tbp->nopass && base->rank > 0)
5453 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5454 " be scalar", &e->where);
5458 /* FIXME: Remove once PR 41177 (this problem) is fixed completely. */
5461 gfc_error ("Non-scalar base object at %L currently not implemented",
5470 /* Resolve a call to a type-bound procedure, either function or subroutine,
5471 statically from the data in an EXPR_COMPCALL expression. The adapted
5472 arglist and the target-procedure symtree are returned. */
5475 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5476 gfc_actual_arglist** actual)
5478 gcc_assert (e->expr_type == EXPR_COMPCALL);
5479 gcc_assert (!e->value.compcall.tbp->is_generic);
5481 /* Update the actual arglist for PASS. */
5482 if (update_compcall_arglist (e) == FAILURE)
5485 *actual = e->value.compcall.actual;
5486 *target = e->value.compcall.tbp->u.specific;
5488 gfc_free_ref_list (e->ref);
5490 e->value.compcall.actual = NULL;
5496 /* Get the ultimate declared type from an expression. In addition,
5497 return the last class/derived type reference and the copy of the
5500 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5503 gfc_symbol *declared;
5510 *new_ref = gfc_copy_ref (e->ref);
5512 for (ref = e->ref; ref; ref = ref->next)
5514 if (ref->type != REF_COMPONENT)
5517 if (ref->u.c.component->ts.type == BT_CLASS
5518 || ref->u.c.component->ts.type == BT_DERIVED)
5520 declared = ref->u.c.component->ts.u.derived;
5526 if (declared == NULL)
5527 declared = e->symtree->n.sym->ts.u.derived;
5533 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5534 which of the specific bindings (if any) matches the arglist and transform
5535 the expression into a call of that binding. */
5538 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5540 gfc_typebound_proc* genproc;
5541 const char* genname;
5543 gfc_symbol *derived;
5545 gcc_assert (e->expr_type == EXPR_COMPCALL);
5546 genname = e->value.compcall.name;
5547 genproc = e->value.compcall.tbp;
5549 if (!genproc->is_generic)
5552 /* Try the bindings on this type and in the inheritance hierarchy. */
5553 for (; genproc; genproc = genproc->overridden)
5557 gcc_assert (genproc->is_generic);
5558 for (g = genproc->u.generic; g; g = g->next)
5561 gfc_actual_arglist* args;
5564 gcc_assert (g->specific);
5566 if (g->specific->error)
5569 target = g->specific->u.specific->n.sym;
5571 /* Get the right arglist by handling PASS/NOPASS. */
5572 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5573 if (!g->specific->nopass)
5576 po = extract_compcall_passed_object (e);
5580 gcc_assert (g->specific->pass_arg_num > 0);
5581 gcc_assert (!g->specific->error);
5582 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5583 g->specific->pass_arg);
5585 resolve_actual_arglist (args, target->attr.proc,
5586 is_external_proc (target) && !target->formal);
5588 /* Check if this arglist matches the formal. */
5589 matches = gfc_arglist_matches_symbol (&args, target);
5591 /* Clean up and break out of the loop if we've found it. */
5592 gfc_free_actual_arglist (args);
5595 e->value.compcall.tbp = g->specific;
5596 genname = g->specific_st->name;
5597 /* Pass along the name for CLASS methods, where the vtab
5598 procedure pointer component has to be referenced. */
5606 /* Nothing matching found! */
5607 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5608 " '%s' at %L", genname, &e->where);
5612 /* Make sure that we have the right specific instance for the name. */
5613 derived = get_declared_from_expr (NULL, NULL, e);
5615 st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where);
5617 e->value.compcall.tbp = st->n.tb;
5623 /* Resolve a call to a type-bound subroutine. */
5626 resolve_typebound_call (gfc_code* c, const char **name)
5628 gfc_actual_arglist* newactual;
5629 gfc_symtree* target;
5631 /* Check that's really a SUBROUTINE. */
5632 if (!c->expr1->value.compcall.tbp->subroutine)
5634 gfc_error ("'%s' at %L should be a SUBROUTINE",
5635 c->expr1->value.compcall.name, &c->loc);
5639 if (check_typebound_baseobject (c->expr1) == FAILURE)
5642 /* Pass along the name for CLASS methods, where the vtab
5643 procedure pointer component has to be referenced. */
5645 *name = c->expr1->value.compcall.name;
5647 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5650 /* Transform into an ordinary EXEC_CALL for now. */
5652 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5655 c->ext.actual = newactual;
5656 c->symtree = target;
5657 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5659 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5661 gfc_free_expr (c->expr1);
5662 c->expr1 = gfc_get_expr ();
5663 c->expr1->expr_type = EXPR_FUNCTION;
5664 c->expr1->symtree = target;
5665 c->expr1->where = c->loc;
5667 return resolve_call (c);
5671 /* Resolve a component-call expression. */
5673 resolve_compcall (gfc_expr* e, const char **name)
5675 gfc_actual_arglist* newactual;
5676 gfc_symtree* target;
5678 /* Check that's really a FUNCTION. */
5679 if (!e->value.compcall.tbp->function)
5681 gfc_error ("'%s' at %L should be a FUNCTION",
5682 e->value.compcall.name, &e->where);
5686 /* These must not be assign-calls! */
5687 gcc_assert (!e->value.compcall.assign);
5689 if (check_typebound_baseobject (e) == FAILURE)
5692 /* Pass along the name for CLASS methods, where the vtab
5693 procedure pointer component has to be referenced. */
5695 *name = e->value.compcall.name;
5697 if (resolve_typebound_generic_call (e, name) == FAILURE)
5699 gcc_assert (!e->value.compcall.tbp->is_generic);
5701 /* Take the rank from the function's symbol. */
5702 if (e->value.compcall.tbp->u.specific->n.sym->as)
5703 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5705 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5706 arglist to the TBP's binding target. */
5708 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5711 e->value.function.actual = newactual;
5712 e->value.function.name = NULL;
5713 e->value.function.esym = target->n.sym;
5714 e->value.function.isym = NULL;
5715 e->symtree = target;
5716 e->ts = target->n.sym->ts;
5717 e->expr_type = EXPR_FUNCTION;
5719 /* Resolution is not necessary if this is a class subroutine; this
5720 function only has to identify the specific proc. Resolution of
5721 the call will be done next in resolve_typebound_call. */
5722 return gfc_resolve_expr (e);
5727 /* Resolve a typebound function, or 'method'. First separate all
5728 the non-CLASS references by calling resolve_compcall directly. */
5731 resolve_typebound_function (gfc_expr* e)
5733 gfc_symbol *declared;
5744 /* Deal with typebound operators for CLASS objects. */
5745 expr = e->value.compcall.base_object;
5746 if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
5747 && e->value.compcall.name)
5749 /* Since the typebound operators are generic, we have to ensure
5750 that any delays in resolution are corrected and that the vtab
5752 ts = expr->symtree->n.sym->ts;
5753 declared = ts.u.derived;
5754 c = gfc_find_component (declared, "$vptr", true, true);
5755 if (c->ts.u.derived == NULL)
5756 c->ts.u.derived = gfc_find_derived_vtab (declared);
5758 if (resolve_compcall (e, &name) == FAILURE)
5761 /* Use the generic name if it is there. */
5762 name = name ? name : e->value.function.esym->name;
5763 e->symtree = expr->symtree;
5764 expr->symtree->n.sym->ts.u.derived = declared;
5765 gfc_add_component_ref (e, "$vptr");
5766 gfc_add_component_ref (e, name);
5767 e->value.function.esym = NULL;
5772 return resolve_compcall (e, NULL);
5774 if (resolve_ref (e) == FAILURE)
5777 /* Get the CLASS declared type. */
5778 declared = get_declared_from_expr (&class_ref, &new_ref, e);
5780 /* Weed out cases of the ultimate component being a derived type. */
5781 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5782 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5784 gfc_free_ref_list (new_ref);
5785 return resolve_compcall (e, NULL);
5788 c = gfc_find_component (declared, "$data", true, true);
5789 declared = c->ts.u.derived;
5791 /* Treat the call as if it is a typebound procedure, in order to roll
5792 out the correct name for the specific function. */
5793 if (resolve_compcall (e, &name) == FAILURE)
5797 /* Then convert the expression to a procedure pointer component call. */
5798 e->value.function.esym = NULL;
5804 /* '$vptr' points to the vtab, which contains the procedure pointers. */
5805 gfc_add_component_ref (e, "$vptr");
5806 gfc_add_component_ref (e, name);
5808 /* Recover the typespec for the expression. This is really only
5809 necessary for generic procedures, where the additional call
5810 to gfc_add_component_ref seems to throw the collection of the
5811 correct typespec. */
5816 /* Resolve a typebound subroutine, or 'method'. First separate all
5817 the non-CLASS references by calling resolve_typebound_call
5821 resolve_typebound_subroutine (gfc_code *code)
5823 gfc_symbol *declared;
5832 st = code->expr1->symtree;
5834 /* Deal with typebound operators for CLASS objects. */
5835 expr = code->expr1->value.compcall.base_object;
5836 if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
5837 && code->expr1->value.compcall.name)
5839 /* Since the typebound operators are generic, we have to ensure
5840 that any delays in resolution are corrected and that the vtab
5842 ts = expr->symtree->n.sym->ts;
5843 declared = ts.u.derived;
5844 c = gfc_find_component (declared, "$vptr", true, true);
5845 if (c->ts.u.derived == NULL)
5846 c->ts.u.derived = gfc_find_derived_vtab (declared);
5848 if (resolve_typebound_call (code, &name) == FAILURE)
5851 /* Use the generic name if it is there. */
5852 name = name ? name : code->expr1->value.function.esym->name;
5853 code->expr1->symtree = expr->symtree;
5854 expr->symtree->n.sym->ts.u.derived = declared;
5855 gfc_add_component_ref (code->expr1, "$vptr");
5856 gfc_add_component_ref (code->expr1, name);
5857 code->expr1->value.function.esym = NULL;
5862 return resolve_typebound_call (code, NULL);
5864 if (resolve_ref (code->expr1) == FAILURE)
5867 /* Get the CLASS declared type. */
5868 get_declared_from_expr (&class_ref, &new_ref, code->expr1);
5870 /* Weed out cases of the ultimate component being a derived type. */
5871 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5872 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5874 gfc_free_ref_list (new_ref);
5875 return resolve_typebound_call (code, NULL);
5878 if (resolve_typebound_call (code, &name) == FAILURE)
5880 ts = code->expr1->ts;
5882 /* Then convert the expression to a procedure pointer component call. */
5883 code->expr1->value.function.esym = NULL;
5884 code->expr1->symtree = st;
5887 code->expr1->ref = new_ref;
5889 /* '$vptr' points to the vtab, which contains the procedure pointers. */
5890 gfc_add_component_ref (code->expr1, "$vptr");
5891 gfc_add_component_ref (code->expr1, name);
5893 /* Recover the typespec for the expression. This is really only
5894 necessary for generic procedures, where the additional call
5895 to gfc_add_component_ref seems to throw the collection of the
5896 correct typespec. */
5897 code->expr1->ts = ts;
5902 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5905 resolve_ppc_call (gfc_code* c)
5907 gfc_component *comp;
5910 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
5913 c->resolved_sym = c->expr1->symtree->n.sym;
5914 c->expr1->expr_type = EXPR_VARIABLE;
5916 if (!comp->attr.subroutine)
5917 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
5919 if (resolve_ref (c->expr1) == FAILURE)
5922 if (update_ppc_arglist (c->expr1) == FAILURE)
5925 c->ext.actual = c->expr1->value.compcall.actual;
5927 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
5928 comp->formal == NULL) == FAILURE)
5931 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
5937 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5940 resolve_expr_ppc (gfc_expr* e)
5942 gfc_component *comp;
5945 b = gfc_is_proc_ptr_comp (e, &comp);
5948 /* Convert to EXPR_FUNCTION. */
5949 e->expr_type = EXPR_FUNCTION;
5950 e->value.function.isym = NULL;
5951 e->value.function.actual = e->value.compcall.actual;
5953 if (comp->as != NULL)
5954 e->rank = comp->as->rank;
5956 if (!comp->attr.function)
5957 gfc_add_function (&comp->attr, comp->name, &e->where);
5959 if (resolve_ref (e) == FAILURE)
5962 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
5963 comp->formal == NULL) == FAILURE)
5966 if (update_ppc_arglist (e) == FAILURE)
5969 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
5976 gfc_is_expandable_expr (gfc_expr *e)
5978 gfc_constructor *con;
5980 if (e->expr_type == EXPR_ARRAY)
5982 /* Traverse the constructor looking for variables that are flavor
5983 parameter. Parameters must be expanded since they are fully used at
5985 con = gfc_constructor_first (e->value.constructor);
5986 for (; con; con = gfc_constructor_next (con))
5988 if (con->expr->expr_type == EXPR_VARIABLE
5989 && con->expr->symtree
5990 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
5991 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
5993 if (con->expr->expr_type == EXPR_ARRAY
5994 && gfc_is_expandable_expr (con->expr))
6002 /* Resolve an expression. That is, make sure that types of operands agree
6003 with their operators, intrinsic operators are converted to function calls
6004 for overloaded types and unresolved function references are resolved. */
6007 gfc_resolve_expr (gfc_expr *e)
6015 /* inquiry_argument only applies to variables. */
6016 inquiry_save = inquiry_argument;
6017 if (e->expr_type != EXPR_VARIABLE)
6018 inquiry_argument = false;
6020 switch (e->expr_type)
6023 t = resolve_operator (e);
6029 if (check_host_association (e))
6030 t = resolve_function (e);
6033 t = resolve_variable (e);
6035 expression_rank (e);
6038 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6039 && e->ref->type != REF_SUBSTRING)
6040 gfc_resolve_substring_charlen (e);
6045 t = resolve_typebound_function (e);
6048 case EXPR_SUBSTRING:
6049 t = resolve_ref (e);
6058 t = resolve_expr_ppc (e);
6063 if (resolve_ref (e) == FAILURE)
6066 t = gfc_resolve_array_constructor (e);
6067 /* Also try to expand a constructor. */
6070 expression_rank (e);
6071 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6072 gfc_expand_constructor (e, false);
6075 /* This provides the opportunity for the length of constructors with
6076 character valued function elements to propagate the string length
6077 to the expression. */
6078 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6080 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6081 here rather then add a duplicate test for it above. */
6082 gfc_expand_constructor (e, false);
6083 t = gfc_resolve_character_array_constructor (e);
6088 case EXPR_STRUCTURE:
6089 t = resolve_ref (e);
6093 t = resolve_structure_cons (e, 0);
6097 t = gfc_simplify_expr (e, 0);
6101 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6104 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6107 inquiry_argument = inquiry_save;
6113 /* Resolve an expression from an iterator. They must be scalar and have
6114 INTEGER or (optionally) REAL type. */
6117 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6118 const char *name_msgid)
6120 if (gfc_resolve_expr (expr) == FAILURE)
6123 if (expr->rank != 0)
6125 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6129 if (expr->ts.type != BT_INTEGER)
6131 if (expr->ts.type == BT_REAL)
6134 return gfc_notify_std (GFC_STD_F95_DEL,
6135 "Deleted feature: %s at %L must be integer",
6136 _(name_msgid), &expr->where);
6139 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6146 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6154 /* Resolve the expressions in an iterator structure. If REAL_OK is
6155 false allow only INTEGER type iterators, otherwise allow REAL types. */
6158 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6160 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6164 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
6166 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
6171 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6172 "Start expression in DO loop") == FAILURE)
6175 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6176 "End expression in DO loop") == FAILURE)
6179 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6180 "Step expression in DO loop") == FAILURE)
6183 if (iter->step->expr_type == EXPR_CONSTANT)
6185 if ((iter->step->ts.type == BT_INTEGER
6186 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6187 || (iter->step->ts.type == BT_REAL
6188 && mpfr_sgn (iter->step->value.real) == 0))
6190 gfc_error ("Step expression in DO loop at %L cannot be zero",
6191 &iter->step->where);
6196 /* Convert start, end, and step to the same type as var. */
6197 if (iter->start->ts.kind != iter->var->ts.kind
6198 || iter->start->ts.type != iter->var->ts.type)
6199 gfc_convert_type (iter->start, &iter->var->ts, 2);
6201 if (iter->end->ts.kind != iter->var->ts.kind
6202 || iter->end->ts.type != iter->var->ts.type)
6203 gfc_convert_type (iter->end, &iter->var->ts, 2);
6205 if (iter->step->ts.kind != iter->var->ts.kind
6206 || iter->step->ts.type != iter->var->ts.type)
6207 gfc_convert_type (iter->step, &iter->var->ts, 2);
6209 if (iter->start->expr_type == EXPR_CONSTANT
6210 && iter->end->expr_type == EXPR_CONSTANT
6211 && iter->step->expr_type == EXPR_CONSTANT)
6214 if (iter->start->ts.type == BT_INTEGER)
6216 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6217 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6221 sgn = mpfr_sgn (iter->step->value.real);
6222 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6224 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6225 gfc_warning ("DO loop at %L will be executed zero times",
6226 &iter->step->where);
6233 /* Traversal function for find_forall_index. f == 2 signals that
6234 that variable itself is not to be checked - only the references. */
6237 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6239 if (expr->expr_type != EXPR_VARIABLE)
6242 /* A scalar assignment */
6243 if (!expr->ref || *f == 1)
6245 if (expr->symtree->n.sym == sym)
6257 /* Check whether the FORALL index appears in the expression or not.
6258 Returns SUCCESS if SYM is found in EXPR. */
6261 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6263 if (gfc_traverse_expr (expr, sym, forall_index, f))
6270 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6271 to be a scalar INTEGER variable. The subscripts and stride are scalar
6272 INTEGERs, and if stride is a constant it must be nonzero.
6273 Furthermore "A subscript or stride in a forall-triplet-spec shall
6274 not contain a reference to any index-name in the
6275 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6278 resolve_forall_iterators (gfc_forall_iterator *it)
6280 gfc_forall_iterator *iter, *iter2;
6282 for (iter = it; iter; iter = iter->next)
6284 if (gfc_resolve_expr (iter->var) == SUCCESS
6285 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6286 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6289 if (gfc_resolve_expr (iter->start) == SUCCESS
6290 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6291 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6292 &iter->start->where);
6293 if (iter->var->ts.kind != iter->start->ts.kind)
6294 gfc_convert_type (iter->start, &iter->var->ts, 2);
6296 if (gfc_resolve_expr (iter->end) == SUCCESS
6297 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6298 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6300 if (iter->var->ts.kind != iter->end->ts.kind)
6301 gfc_convert_type (iter->end, &iter->var->ts, 2);
6303 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6305 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6306 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6307 &iter->stride->where, "INTEGER");
6309 if (iter->stride->expr_type == EXPR_CONSTANT
6310 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6311 gfc_error ("FORALL stride expression at %L cannot be zero",
6312 &iter->stride->where);
6314 if (iter->var->ts.kind != iter->stride->ts.kind)
6315 gfc_convert_type (iter->stride, &iter->var->ts, 2);
6318 for (iter = it; iter; iter = iter->next)
6319 for (iter2 = iter; iter2; iter2 = iter2->next)
6321 if (find_forall_index (iter2->start,
6322 iter->var->symtree->n.sym, 0) == SUCCESS
6323 || find_forall_index (iter2->end,
6324 iter->var->symtree->n.sym, 0) == SUCCESS
6325 || find_forall_index (iter2->stride,
6326 iter->var->symtree->n.sym, 0) == SUCCESS)
6327 gfc_error ("FORALL index '%s' may not appear in triplet "
6328 "specification at %L", iter->var->symtree->name,
6329 &iter2->start->where);
6334 /* Given a pointer to a symbol that is a derived type, see if it's
6335 inaccessible, i.e. if it's defined in another module and the components are
6336 PRIVATE. The search is recursive if necessary. Returns zero if no
6337 inaccessible components are found, nonzero otherwise. */
6340 derived_inaccessible (gfc_symbol *sym)
6344 if (sym->attr.use_assoc && sym->attr.private_comp)
6347 for (c = sym->components; c; c = c->next)
6349 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6357 /* Resolve the argument of a deallocate expression. The expression must be
6358 a pointer or a full array. */
6361 resolve_deallocate_expr (gfc_expr *e)
6363 symbol_attribute attr;
6364 int allocatable, pointer, check_intent_in;
6369 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
6370 check_intent_in = 1;
6372 if (gfc_resolve_expr (e) == FAILURE)
6375 if (e->expr_type != EXPR_VARIABLE)
6378 sym = e->symtree->n.sym;
6380 if (sym->ts.type == BT_CLASS)
6382 allocatable = CLASS_DATA (sym)->attr.allocatable;
6383 pointer = CLASS_DATA (sym)->attr.class_pointer;
6387 allocatable = sym->attr.allocatable;
6388 pointer = sym->attr.pointer;
6390 for (ref = e->ref; ref; ref = ref->next)
6393 check_intent_in = 0;
6398 if (ref->u.ar.type != AR_FULL)
6403 c = ref->u.c.component;
6404 if (c->ts.type == BT_CLASS)
6406 allocatable = CLASS_DATA (c)->attr.allocatable;
6407 pointer = CLASS_DATA (c)->attr.class_pointer;
6411 allocatable = c->attr.allocatable;
6412 pointer = c->attr.pointer;
6422 attr = gfc_expr_attr (e);
6424 if (allocatable == 0 && attr.pointer == 0)
6427 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6432 if (check_intent_in && sym->attr.intent == INTENT_IN)
6434 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
6435 sym->name, &e->where);
6439 if (e->ts.type == BT_CLASS)
6441 /* Only deallocate the DATA component. */
6442 gfc_add_component_ref (e, "$data");
6449 /* Returns true if the expression e contains a reference to the symbol sym. */
6451 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6453 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6460 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6462 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6466 /* Given the expression node e for an allocatable/pointer of derived type to be
6467 allocated, get the expression node to be initialized afterwards (needed for
6468 derived types with default initializers, and derived types with allocatable
6469 components that need nullification.) */
6472 gfc_expr_to_initialize (gfc_expr *e)
6478 result = gfc_copy_expr (e);
6480 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6481 for (ref = result->ref; ref; ref = ref->next)
6482 if (ref->type == REF_ARRAY && ref->next == NULL)
6484 ref->u.ar.type = AR_FULL;
6486 for (i = 0; i < ref->u.ar.dimen; i++)
6487 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6489 result->rank = ref->u.ar.dimen;
6497 /* Used in resolve_allocate_expr to check that a allocation-object and
6498 a source-expr are conformable. This does not catch all possible
6499 cases; in particular a runtime checking is needed. */
6502 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6505 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6507 /* First compare rank. */
6508 if (tail && e1->rank != tail->u.ar.as->rank)
6510 gfc_error ("Source-expr at %L must be scalar or have the "
6511 "same rank as the allocate-object at %L",
6512 &e1->where, &e2->where);
6523 for (i = 0; i < e1->rank; i++)
6525 if (tail->u.ar.end[i])
6527 mpz_set (s, tail->u.ar.end[i]->value.integer);
6528 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6529 mpz_add_ui (s, s, 1);
6533 mpz_set (s, tail->u.ar.start[i]->value.integer);
6536 if (mpz_cmp (e1->shape[i], s) != 0)
6538 gfc_error ("Source-expr at %L and allocate-object at %L must "
6539 "have the same shape", &e1->where, &e2->where);
6552 /* Resolve the expression in an ALLOCATE statement, doing the additional
6553 checks to see whether the expression is OK or not. The expression must
6554 have a trailing array reference that gives the size of the array. */
6557 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6559 int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
6561 symbol_attribute attr;
6562 gfc_ref *ref, *ref2;
6564 gfc_symbol *sym = NULL;
6568 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
6569 check_intent_in = 1;
6571 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6572 checking of coarrays. */
6573 for (ref = e->ref; ref; ref = ref->next)
6574 if (ref->next == NULL)
6577 if (ref && ref->type == REF_ARRAY)
6578 ref->u.ar.in_allocate = true;
6580 if (gfc_resolve_expr (e) == FAILURE)
6583 /* Make sure the expression is allocatable or a pointer. If it is
6584 pointer, the next-to-last reference must be a pointer. */
6588 sym = e->symtree->n.sym;
6590 /* Check whether ultimate component is abstract and CLASS. */
6593 if (e->expr_type != EXPR_VARIABLE)
6596 attr = gfc_expr_attr (e);
6597 pointer = attr.pointer;
6598 dimension = attr.dimension;
6599 codimension = attr.codimension;
6603 if (sym->ts.type == BT_CLASS)
6605 allocatable = CLASS_DATA (sym)->attr.allocatable;
6606 pointer = CLASS_DATA (sym)->attr.class_pointer;
6607 dimension = CLASS_DATA (sym)->attr.dimension;
6608 codimension = CLASS_DATA (sym)->attr.codimension;
6609 is_abstract = CLASS_DATA (sym)->attr.abstract;
6613 allocatable = sym->attr.allocatable;
6614 pointer = sym->attr.pointer;
6615 dimension = sym->attr.dimension;
6616 codimension = sym->attr.codimension;
6619 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6622 check_intent_in = 0;
6627 if (ref->next != NULL)
6633 if (gfc_is_coindexed (e))
6635 gfc_error ("Coindexed allocatable object at %L",
6640 c = ref->u.c.component;
6641 if (c->ts.type == BT_CLASS)
6643 allocatable = CLASS_DATA (c)->attr.allocatable;
6644 pointer = CLASS_DATA (c)->attr.class_pointer;
6645 dimension = CLASS_DATA (c)->attr.dimension;
6646 codimension = CLASS_DATA (c)->attr.codimension;
6647 is_abstract = CLASS_DATA (c)->attr.abstract;
6651 allocatable = c->attr.allocatable;
6652 pointer = c->attr.pointer;
6653 dimension = c->attr.dimension;
6654 codimension = c->attr.codimension;
6655 is_abstract = c->attr.abstract;
6667 if (allocatable == 0 && pointer == 0)
6669 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6674 /* Some checks for the SOURCE tag. */
6677 /* Check F03:C631. */
6678 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6680 gfc_error ("Type of entity at %L is type incompatible with "
6681 "source-expr at %L", &e->where, &code->expr3->where);
6685 /* Check F03:C632 and restriction following Note 6.18. */
6686 if (code->expr3->rank > 0
6687 && conformable_arrays (code->expr3, e) == FAILURE)
6690 /* Check F03:C633. */
6691 if (code->expr3->ts.kind != e->ts.kind)
6693 gfc_error ("The allocate-object at %L and the source-expr at %L "
6694 "shall have the same kind type parameter",
6695 &e->where, &code->expr3->where);
6700 /* Check F08:C629. */
6701 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
6704 gcc_assert (e->ts.type == BT_CLASS);
6705 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6706 "type-spec or source-expr", sym->name, &e->where);
6710 if (check_intent_in && sym->attr.intent == INTENT_IN)
6712 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
6713 sym->name, &e->where);
6719 /* Set up default initializer if needed. */
6722 if (code->ext.alloc.ts.type == BT_DERIVED)
6723 ts = code->ext.alloc.ts;
6727 if (ts.type == BT_CLASS)
6728 ts = ts.u.derived->components->ts;
6730 if (ts.type == BT_DERIVED)
6732 code->expr3 = gfc_default_initializer (&ts);
6733 gfc_resolve_expr (code->expr3);
6736 else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
6738 /* Default initialization via MOLD (non-polymorphic). */
6739 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
6740 gfc_resolve_expr (rhs);
6741 gfc_free_expr (code->expr3);
6745 if (e->ts.type == BT_CLASS)
6747 /* Make sure the vtab symbol is present when
6748 the module variables are generated. */
6749 gfc_typespec ts = e->ts;
6751 ts = code->expr3->ts;
6752 else if (code->ext.alloc.ts.type == BT_DERIVED)
6753 ts = code->ext.alloc.ts;
6754 gfc_find_derived_vtab (ts.u.derived);
6757 if (pointer || (dimension == 0 && codimension == 0))
6760 /* Make sure the next-to-last reference node is an array specification. */
6762 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
6763 || (dimension && ref2->u.ar.dimen == 0))
6765 gfc_error ("Array specification required in ALLOCATE statement "
6766 "at %L", &e->where);
6770 /* Make sure that the array section reference makes sense in the
6771 context of an ALLOCATE specification. */
6775 if (codimension && ar->codimen == 0)
6777 gfc_error ("Coarray specification required in ALLOCATE statement "
6778 "at %L", &e->where);
6782 for (i = 0; i < ar->dimen; i++)
6784 if (ref2->u.ar.type == AR_ELEMENT)
6787 switch (ar->dimen_type[i])
6793 if (ar->start[i] != NULL
6794 && ar->end[i] != NULL
6795 && ar->stride[i] == NULL)
6798 /* Fall Through... */
6803 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6809 for (a = code->ext.alloc.list; a; a = a->next)
6811 sym = a->expr->symtree->n.sym;
6813 /* TODO - check derived type components. */
6814 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6817 if ((ar->start[i] != NULL
6818 && gfc_find_sym_in_expr (sym, ar->start[i]))
6819 || (ar->end[i] != NULL
6820 && gfc_find_sym_in_expr (sym, ar->end[i])))
6822 gfc_error ("'%s' must not appear in the array specification at "
6823 "%L in the same ALLOCATE statement where it is "
6824 "itself allocated", sym->name, &ar->where);
6830 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
6832 if (ar->dimen_type[i] == DIMEN_ELEMENT
6833 || ar->dimen_type[i] == DIMEN_RANGE)
6835 if (i == (ar->dimen + ar->codimen - 1))
6837 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
6838 "statement at %L", &e->where);
6844 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
6845 && ar->stride[i] == NULL)
6848 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
6853 if (codimension && ar->as->rank == 0)
6855 gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
6856 "at %L", &e->where);
6868 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
6870 gfc_expr *stat, *errmsg, *pe, *qe;
6871 gfc_alloc *a, *p, *q;
6873 stat = code->expr1 ? code->expr1 : NULL;
6875 errmsg = code->expr2 ? code->expr2 : NULL;
6877 /* Check the stat variable. */
6880 if (stat->symtree->n.sym->attr.intent == INTENT_IN)
6881 gfc_error ("Stat-variable '%s' at %L cannot be INTENT(IN)",
6882 stat->symtree->n.sym->name, &stat->where);
6884 if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
6885 gfc_error ("Illegal stat-variable at %L for a PURE procedure",
6888 if ((stat->ts.type != BT_INTEGER
6889 && !(stat->ref && (stat->ref->type == REF_ARRAY
6890 || stat->ref->type == REF_COMPONENT)))
6892 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
6893 "variable", &stat->where);
6895 for (p = code->ext.alloc.list; p; p = p->next)
6896 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
6898 gfc_ref *ref1, *ref2;
6901 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
6902 ref1 = ref1->next, ref2 = ref2->next)
6904 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6906 if (ref1->u.c.component->name != ref2->u.c.component->name)
6915 gfc_error ("Stat-variable at %L shall not be %sd within "
6916 "the same %s statement", &stat->where, fcn, fcn);
6922 /* Check the errmsg variable. */
6926 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
6929 if (errmsg->symtree->n.sym->attr.intent == INTENT_IN)
6930 gfc_error ("Errmsg-variable '%s' at %L cannot be INTENT(IN)",
6931 errmsg->symtree->n.sym->name, &errmsg->where);
6933 if (gfc_pure (NULL) && gfc_impure_variable (errmsg->symtree->n.sym))
6934 gfc_error ("Illegal errmsg-variable at %L for a PURE procedure",
6937 if ((errmsg->ts.type != BT_CHARACTER
6939 && (errmsg->ref->type == REF_ARRAY
6940 || errmsg->ref->type == REF_COMPONENT)))
6941 || errmsg->rank > 0 )
6942 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
6943 "variable", &errmsg->where);
6945 for (p = code->ext.alloc.list; p; p = p->next)
6946 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
6948 gfc_ref *ref1, *ref2;
6951 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
6952 ref1 = ref1->next, ref2 = ref2->next)
6954 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6956 if (ref1->u.c.component->name != ref2->u.c.component->name)
6965 gfc_error ("Errmsg-variable at %L shall not be %sd within "
6966 "the same %s statement", &errmsg->where, fcn, fcn);
6972 /* Check that an allocate-object appears only once in the statement.
6973 FIXME: Checking derived types is disabled. */
6974 for (p = code->ext.alloc.list; p; p = p->next)
6977 if ((pe->ref && pe->ref->type != REF_COMPONENT)
6978 && (pe->symtree->n.sym->ts.type != BT_DERIVED))
6980 for (q = p->next; q; q = q->next)
6983 if ((qe->ref && qe->ref->type != REF_COMPONENT)
6984 && (qe->symtree->n.sym->ts.type != BT_DERIVED)
6985 && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
6986 gfc_error ("Allocate-object at %L also appears at %L",
6987 &pe->where, &qe->where);
6992 if (strcmp (fcn, "ALLOCATE") == 0)
6994 for (a = code->ext.alloc.list; a; a = a->next)
6995 resolve_allocate_expr (a->expr, code);
6999 for (a = code->ext.alloc.list; a; a = a->next)
7000 resolve_deallocate_expr (a->expr);
7005 /************ SELECT CASE resolution subroutines ************/
7007 /* Callback function for our mergesort variant. Determines interval
7008 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7009 op1 > op2. Assumes we're not dealing with the default case.
7010 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7011 There are nine situations to check. */
7014 compare_cases (const gfc_case *op1, const gfc_case *op2)
7018 if (op1->low == NULL) /* op1 = (:L) */
7020 /* op2 = (:N), so overlap. */
7022 /* op2 = (M:) or (M:N), L < M */
7023 if (op2->low != NULL
7024 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7027 else if (op1->high == NULL) /* op1 = (K:) */
7029 /* op2 = (M:), so overlap. */
7031 /* op2 = (:N) or (M:N), K > N */
7032 if (op2->high != NULL
7033 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7036 else /* op1 = (K:L) */
7038 if (op2->low == NULL) /* op2 = (:N), K > N */
7039 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7041 else if (op2->high == NULL) /* op2 = (M:), L < M */
7042 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7044 else /* op2 = (M:N) */
7048 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7051 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7060 /* Merge-sort a double linked case list, detecting overlap in the
7061 process. LIST is the head of the double linked case list before it
7062 is sorted. Returns the head of the sorted list if we don't see any
7063 overlap, or NULL otherwise. */
7066 check_case_overlap (gfc_case *list)
7068 gfc_case *p, *q, *e, *tail;
7069 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7071 /* If the passed list was empty, return immediately. */
7078 /* Loop unconditionally. The only exit from this loop is a return
7079 statement, when we've finished sorting the case list. */
7086 /* Count the number of merges we do in this pass. */
7089 /* Loop while there exists a merge to be done. */
7094 /* Count this merge. */
7097 /* Cut the list in two pieces by stepping INSIZE places
7098 forward in the list, starting from P. */
7101 for (i = 0; i < insize; i++)
7110 /* Now we have two lists. Merge them! */
7111 while (psize > 0 || (qsize > 0 && q != NULL))
7113 /* See from which the next case to merge comes from. */
7116 /* P is empty so the next case must come from Q. */
7121 else if (qsize == 0 || q == NULL)
7130 cmp = compare_cases (p, q);
7133 /* The whole case range for P is less than the
7141 /* The whole case range for Q is greater than
7142 the case range for P. */
7149 /* The cases overlap, or they are the same
7150 element in the list. Either way, we must
7151 issue an error and get the next case from P. */
7152 /* FIXME: Sort P and Q by line number. */
7153 gfc_error ("CASE label at %L overlaps with CASE "
7154 "label at %L", &p->where, &q->where);
7162 /* Add the next element to the merged list. */
7171 /* P has now stepped INSIZE places along, and so has Q. So
7172 they're the same. */
7177 /* If we have done only one merge or none at all, we've
7178 finished sorting the cases. */
7187 /* Otherwise repeat, merging lists twice the size. */
7193 /* Check to see if an expression is suitable for use in a CASE statement.
7194 Makes sure that all case expressions are scalar constants of the same
7195 type. Return FAILURE if anything is wrong. */
7198 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7200 if (e == NULL) return SUCCESS;
7202 if (e->ts.type != case_expr->ts.type)
7204 gfc_error ("Expression in CASE statement at %L must be of type %s",
7205 &e->where, gfc_basic_typename (case_expr->ts.type));
7209 /* C805 (R808) For a given case-construct, each case-value shall be of
7210 the same type as case-expr. For character type, length differences
7211 are allowed, but the kind type parameters shall be the same. */
7213 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7215 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7216 &e->where, case_expr->ts.kind);
7220 /* Convert the case value kind to that of case expression kind,
7223 if (e->ts.kind != case_expr->ts.kind)
7224 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7228 gfc_error ("Expression in CASE statement at %L must be scalar",
7237 /* Given a completely parsed select statement, we:
7239 - Validate all expressions and code within the SELECT.
7240 - Make sure that the selection expression is not of the wrong type.
7241 - Make sure that no case ranges overlap.
7242 - Eliminate unreachable cases and unreachable code resulting from
7243 removing case labels.
7245 The standard does allow unreachable cases, e.g. CASE (5:3). But
7246 they are a hassle for code generation, and to prevent that, we just
7247 cut them out here. This is not necessary for overlapping cases
7248 because they are illegal and we never even try to generate code.
7250 We have the additional caveat that a SELECT construct could have
7251 been a computed GOTO in the source code. Fortunately we can fairly
7252 easily work around that here: The case_expr for a "real" SELECT CASE
7253 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7254 we have to do is make sure that the case_expr is a scalar integer
7258 resolve_select (gfc_code *code)
7261 gfc_expr *case_expr;
7262 gfc_case *cp, *default_case, *tail, *head;
7263 int seen_unreachable;
7269 if (code->expr1 == NULL)
7271 /* This was actually a computed GOTO statement. */
7272 case_expr = code->expr2;
7273 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7274 gfc_error ("Selection expression in computed GOTO statement "
7275 "at %L must be a scalar integer expression",
7278 /* Further checking is not necessary because this SELECT was built
7279 by the compiler, so it should always be OK. Just move the
7280 case_expr from expr2 to expr so that we can handle computed
7281 GOTOs as normal SELECTs from here on. */
7282 code->expr1 = code->expr2;
7287 case_expr = code->expr1;
7289 type = case_expr->ts.type;
7290 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7292 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7293 &case_expr->where, gfc_typename (&case_expr->ts));
7295 /* Punt. Going on here just produce more garbage error messages. */
7299 if (case_expr->rank != 0)
7301 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7302 "expression", &case_expr->where);
7309 /* Raise a warning if an INTEGER case value exceeds the range of
7310 the case-expr. Later, all expressions will be promoted to the
7311 largest kind of all case-labels. */
7313 if (type == BT_INTEGER)
7314 for (body = code->block; body; body = body->block)
7315 for (cp = body->ext.case_list; cp; cp = cp->next)
7318 && gfc_check_integer_range (cp->low->value.integer,
7319 case_expr->ts.kind) != ARITH_OK)
7320 gfc_warning ("Expression in CASE statement at %L is "
7321 "not in the range of %s", &cp->low->where,
7322 gfc_typename (&case_expr->ts));
7325 && cp->low != cp->high
7326 && gfc_check_integer_range (cp->high->value.integer,
7327 case_expr->ts.kind) != ARITH_OK)
7328 gfc_warning ("Expression in CASE statement at %L is "
7329 "not in the range of %s", &cp->high->where,
7330 gfc_typename (&case_expr->ts));
7333 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7334 of the SELECT CASE expression and its CASE values. Walk the lists
7335 of case values, and if we find a mismatch, promote case_expr to
7336 the appropriate kind. */
7338 if (type == BT_LOGICAL || type == BT_INTEGER)
7340 for (body = code->block; body; body = body->block)
7342 /* Walk the case label list. */
7343 for (cp = body->ext.case_list; cp; cp = cp->next)
7345 /* Intercept the DEFAULT case. It does not have a kind. */
7346 if (cp->low == NULL && cp->high == NULL)
7349 /* Unreachable case ranges are discarded, so ignore. */
7350 if (cp->low != NULL && cp->high != NULL
7351 && cp->low != cp->high
7352 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7356 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7357 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7359 if (cp->high != NULL
7360 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7361 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7366 /* Assume there is no DEFAULT case. */
7367 default_case = NULL;
7372 for (body = code->block; body; body = body->block)
7374 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7376 seen_unreachable = 0;
7378 /* Walk the case label list, making sure that all case labels
7380 for (cp = body->ext.case_list; cp; cp = cp->next)
7382 /* Count the number of cases in the whole construct. */
7385 /* Intercept the DEFAULT case. */
7386 if (cp->low == NULL && cp->high == NULL)
7388 if (default_case != NULL)
7390 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7391 "by a second DEFAULT CASE at %L",
7392 &default_case->where, &cp->where);
7403 /* Deal with single value cases and case ranges. Errors are
7404 issued from the validation function. */
7405 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7406 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7412 if (type == BT_LOGICAL
7413 && ((cp->low == NULL || cp->high == NULL)
7414 || cp->low != cp->high))
7416 gfc_error ("Logical range in CASE statement at %L is not "
7417 "allowed", &cp->low->where);
7422 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7425 value = cp->low->value.logical == 0 ? 2 : 1;
7426 if (value & seen_logical)
7428 gfc_error ("Constant logical value in CASE statement "
7429 "is repeated at %L",
7434 seen_logical |= value;
7437 if (cp->low != NULL && cp->high != NULL
7438 && cp->low != cp->high
7439 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7441 if (gfc_option.warn_surprising)
7442 gfc_warning ("Range specification at %L can never "
7443 "be matched", &cp->where);
7445 cp->unreachable = 1;
7446 seen_unreachable = 1;
7450 /* If the case range can be matched, it can also overlap with
7451 other cases. To make sure it does not, we put it in a
7452 double linked list here. We sort that with a merge sort
7453 later on to detect any overlapping cases. */
7457 head->right = head->left = NULL;
7462 tail->right->left = tail;
7469 /* It there was a failure in the previous case label, give up
7470 for this case label list. Continue with the next block. */
7474 /* See if any case labels that are unreachable have been seen.
7475 If so, we eliminate them. This is a bit of a kludge because
7476 the case lists for a single case statement (label) is a
7477 single forward linked lists. */
7478 if (seen_unreachable)
7480 /* Advance until the first case in the list is reachable. */
7481 while (body->ext.case_list != NULL
7482 && body->ext.case_list->unreachable)
7484 gfc_case *n = body->ext.case_list;
7485 body->ext.case_list = body->ext.case_list->next;
7487 gfc_free_case_list (n);
7490 /* Strip all other unreachable cases. */
7491 if (body->ext.case_list)
7493 for (cp = body->ext.case_list; cp->next; cp = cp->next)
7495 if (cp->next->unreachable)
7497 gfc_case *n = cp->next;
7498 cp->next = cp->next->next;
7500 gfc_free_case_list (n);
7507 /* See if there were overlapping cases. If the check returns NULL,
7508 there was overlap. In that case we don't do anything. If head
7509 is non-NULL, we prepend the DEFAULT case. The sorted list can
7510 then used during code generation for SELECT CASE constructs with
7511 a case expression of a CHARACTER type. */
7514 head = check_case_overlap (head);
7516 /* Prepend the default_case if it is there. */
7517 if (head != NULL && default_case)
7519 default_case->left = NULL;
7520 default_case->right = head;
7521 head->left = default_case;
7525 /* Eliminate dead blocks that may be the result if we've seen
7526 unreachable case labels for a block. */
7527 for (body = code; body && body->block; body = body->block)
7529 if (body->block->ext.case_list == NULL)
7531 /* Cut the unreachable block from the code chain. */
7532 gfc_code *c = body->block;
7533 body->block = c->block;
7535 /* Kill the dead block, but not the blocks below it. */
7537 gfc_free_statements (c);
7541 /* More than two cases is legal but insane for logical selects.
7542 Issue a warning for it. */
7543 if (gfc_option.warn_surprising && type == BT_LOGICAL
7545 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7550 /* Check if a derived type is extensible. */
7553 gfc_type_is_extensible (gfc_symbol *sym)
7555 return !(sym->attr.is_bind_c || sym->attr.sequence);
7559 /* Resolve an associate name: Resolve target and ensure the type-spec is
7560 correct as well as possibly the array-spec. */
7563 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
7568 gcc_assert (sym->assoc);
7569 gcc_assert (sym->attr.flavor == FL_VARIABLE);
7571 /* If this is for SELECT TYPE, the target may not yet be set. In that
7572 case, return. Resolution will be called later manually again when
7574 target = sym->assoc->target;
7577 gcc_assert (!sym->assoc->dangling);
7579 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
7582 /* For variable targets, we get some attributes from the target. */
7583 if (target->expr_type == EXPR_VARIABLE)
7587 gcc_assert (target->symtree);
7588 tsym = target->symtree->n.sym;
7590 sym->attr.asynchronous = tsym->attr.asynchronous;
7591 sym->attr.volatile_ = tsym->attr.volatile_;
7593 sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
7596 sym->ts = target->ts;
7597 gcc_assert (sym->ts.type != BT_UNKNOWN);
7599 /* See if this is a valid association-to-variable. */
7600 to_var = (target->expr_type == EXPR_VARIABLE
7601 && !gfc_has_vector_subscript (target));
7602 if (sym->assoc->variable && !to_var)
7604 if (target->expr_type == EXPR_VARIABLE)
7605 gfc_error ("'%s' at %L associated to vector-indexed target can not"
7606 " be used in a variable definition context",
7607 sym->name, &sym->declared_at);
7609 gfc_error ("'%s' at %L associated to expression can not"
7610 " be used in a variable definition context",
7611 sym->name, &sym->declared_at);
7615 sym->assoc->variable = to_var;
7617 /* Finally resolve if this is an array or not. */
7618 if (sym->attr.dimension && target->rank == 0)
7620 gfc_error ("Associate-name '%s' at %L is used as array",
7621 sym->name, &sym->declared_at);
7622 sym->attr.dimension = 0;
7625 if (target->rank > 0)
7626 sym->attr.dimension = 1;
7628 if (sym->attr.dimension)
7630 sym->as = gfc_get_array_spec ();
7631 sym->as->rank = target->rank;
7632 sym->as->type = AS_DEFERRED;
7634 /* Target must not be coindexed, thus the associate-variable
7636 sym->as->corank = 0;
7641 /* Resolve a SELECT TYPE statement. */
7644 resolve_select_type (gfc_code *code)
7646 gfc_symbol *selector_type;
7647 gfc_code *body, *new_st, *if_st, *tail;
7648 gfc_code *class_is = NULL, *default_case = NULL;
7651 char name[GFC_MAX_SYMBOL_LEN];
7655 ns = code->ext.block.ns;
7658 /* Check for F03:C813. */
7659 if (code->expr1->ts.type != BT_CLASS
7660 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
7662 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7663 "at %L", &code->loc);
7669 if (code->expr1->symtree->n.sym->attr.untyped)
7670 code->expr1->symtree->n.sym->ts = code->expr2->ts;
7671 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
7674 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
7676 /* Loop over TYPE IS / CLASS IS cases. */
7677 for (body = code->block; body; body = body->block)
7679 c = body->ext.case_list;
7681 /* Check F03:C815. */
7682 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7683 && !gfc_type_is_extensible (c->ts.u.derived))
7685 gfc_error ("Derived type '%s' at %L must be extensible",
7686 c->ts.u.derived->name, &c->where);
7691 /* Check F03:C816. */
7692 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7693 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
7695 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7696 c->ts.u.derived->name, &c->where, selector_type->name);
7701 /* Intercept the DEFAULT case. */
7702 if (c->ts.type == BT_UNKNOWN)
7704 /* Check F03:C818. */
7707 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7708 "by a second DEFAULT CASE at %L",
7709 &default_case->ext.case_list->where, &c->where);
7714 default_case = body;
7721 /* Transform SELECT TYPE statement to BLOCK and associate selector to
7722 target if present. If there are any EXIT statements referring to the
7723 SELECT TYPE construct, this is no problem because the gfc_code
7724 reference stays the same and EXIT is equally possible from the BLOCK
7725 it is changed to. */
7726 code->op = EXEC_BLOCK;
7729 gfc_association_list* assoc;
7731 assoc = gfc_get_association_list ();
7732 assoc->st = code->expr1->symtree;
7733 assoc->target = gfc_copy_expr (code->expr2);
7734 /* assoc->variable will be set by resolve_assoc_var. */
7736 code->ext.block.assoc = assoc;
7737 code->expr1->symtree->n.sym->assoc = assoc;
7739 resolve_assoc_var (code->expr1->symtree->n.sym, false);
7742 code->ext.block.assoc = NULL;
7744 /* Add EXEC_SELECT to switch on type. */
7745 new_st = gfc_get_code ();
7746 new_st->op = code->op;
7747 new_st->expr1 = code->expr1;
7748 new_st->expr2 = code->expr2;
7749 new_st->block = code->block;
7750 code->expr1 = code->expr2 = NULL;
7755 ns->code->next = new_st;
7757 code->op = EXEC_SELECT;
7758 gfc_add_component_ref (code->expr1, "$vptr");
7759 gfc_add_component_ref (code->expr1, "$hash");
7761 /* Loop over TYPE IS / CLASS IS cases. */
7762 for (body = code->block; body; body = body->block)
7764 c = body->ext.case_list;
7766 if (c->ts.type == BT_DERIVED)
7767 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7768 c->ts.u.derived->hash_value);
7770 else if (c->ts.type == BT_UNKNOWN)
7773 /* Associate temporary to selector. This should only be done
7774 when this case is actually true, so build a new ASSOCIATE
7775 that does precisely this here (instead of using the
7778 if (c->ts.type == BT_CLASS)
7779 sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
7781 sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
7782 st = gfc_find_symtree (ns->sym_root, name);
7783 gcc_assert (st->n.sym->assoc);
7784 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
7785 if (c->ts.type == BT_DERIVED)
7786 gfc_add_component_ref (st->n.sym->assoc->target, "$data");
7788 new_st = gfc_get_code ();
7789 new_st->op = EXEC_BLOCK;
7790 new_st->ext.block.ns = gfc_build_block_ns (ns);
7791 new_st->ext.block.ns->code = body->next;
7792 body->next = new_st;
7794 /* Chain in the new list only if it is marked as dangling. Otherwise
7795 there is a CASE label overlap and this is already used. Just ignore,
7796 the error is diagonsed elsewhere. */
7797 if (st->n.sym->assoc->dangling)
7799 new_st->ext.block.assoc = st->n.sym->assoc;
7800 st->n.sym->assoc->dangling = 0;
7803 resolve_assoc_var (st->n.sym, false);
7806 /* Take out CLASS IS cases for separate treatment. */
7808 while (body && body->block)
7810 if (body->block->ext.case_list->ts.type == BT_CLASS)
7812 /* Add to class_is list. */
7813 if (class_is == NULL)
7815 class_is = body->block;
7820 for (tail = class_is; tail->block; tail = tail->block) ;
7821 tail->block = body->block;
7824 /* Remove from EXEC_SELECT list. */
7825 body->block = body->block->block;
7838 /* Add a default case to hold the CLASS IS cases. */
7839 for (tail = code; tail->block; tail = tail->block) ;
7840 tail->block = gfc_get_code ();
7842 tail->op = EXEC_SELECT_TYPE;
7843 tail->ext.case_list = gfc_get_case ();
7844 tail->ext.case_list->ts.type = BT_UNKNOWN;
7846 default_case = tail;
7849 /* More than one CLASS IS block? */
7850 if (class_is->block)
7854 /* Sort CLASS IS blocks by extension level. */
7858 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
7861 /* F03:C817 (check for doubles). */
7862 if ((*c1)->ext.case_list->ts.u.derived->hash_value
7863 == c2->ext.case_list->ts.u.derived->hash_value)
7865 gfc_error ("Double CLASS IS block in SELECT TYPE "
7866 "statement at %L", &c2->ext.case_list->where);
7869 if ((*c1)->ext.case_list->ts.u.derived->attr.extension
7870 < c2->ext.case_list->ts.u.derived->attr.extension)
7873 (*c1)->block = c2->block;
7883 /* Generate IF chain. */
7884 if_st = gfc_get_code ();
7885 if_st->op = EXEC_IF;
7887 for (body = class_is; body; body = body->block)
7889 new_st->block = gfc_get_code ();
7890 new_st = new_st->block;
7891 new_st->op = EXEC_IF;
7892 /* Set up IF condition: Call _gfortran_is_extension_of. */
7893 new_st->expr1 = gfc_get_expr ();
7894 new_st->expr1->expr_type = EXPR_FUNCTION;
7895 new_st->expr1->ts.type = BT_LOGICAL;
7896 new_st->expr1->ts.kind = 4;
7897 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
7898 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
7899 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
7900 /* Set up arguments. */
7901 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
7902 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
7903 gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
7904 vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
7905 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
7906 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
7907 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
7908 new_st->next = body->next;
7910 if (default_case->next)
7912 new_st->block = gfc_get_code ();
7913 new_st = new_st->block;
7914 new_st->op = EXEC_IF;
7915 new_st->next = default_case->next;
7918 /* Replace CLASS DEFAULT code by the IF chain. */
7919 default_case->next = if_st;
7922 resolve_select (code);
7927 /* Resolve a transfer statement. This is making sure that:
7928 -- a derived type being transferred has only non-pointer components
7929 -- a derived type being transferred doesn't have private components, unless
7930 it's being transferred from the module where the type was defined
7931 -- we're not trying to transfer a whole assumed size array. */
7934 resolve_transfer (gfc_code *code)
7943 while (exp != NULL && exp->expr_type == EXPR_OP
7944 && exp->value.op.op == INTRINSIC_PARENTHESES)
7945 exp = exp->value.op.op1;
7947 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
7948 && exp->expr_type != EXPR_FUNCTION))
7951 sym = exp->symtree->n.sym;
7954 /* Go to actual component transferred. */
7955 for (ref = code->expr1->ref; ref; ref = ref->next)
7956 if (ref->type == REF_COMPONENT)
7957 ts = &ref->u.c.component->ts;
7959 if (ts->type == BT_DERIVED)
7961 /* Check that transferred derived type doesn't contain POINTER
7963 if (ts->u.derived->attr.pointer_comp)
7965 gfc_error ("Data transfer element at %L cannot have "
7966 "POINTER components", &code->loc);
7970 if (ts->u.derived->attr.alloc_comp)
7972 gfc_error ("Data transfer element at %L cannot have "
7973 "ALLOCATABLE components", &code->loc);
7977 if (derived_inaccessible (ts->u.derived))
7979 gfc_error ("Data transfer element at %L cannot have "
7980 "PRIVATE components",&code->loc);
7985 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
7986 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
7988 gfc_error ("Data transfer element at %L cannot be a full reference to "
7989 "an assumed-size array", &code->loc);
7995 /*********** Toplevel code resolution subroutines ***********/
7997 /* Find the set of labels that are reachable from this block. We also
7998 record the last statement in each block. */
8001 find_reachable_labels (gfc_code *block)
8008 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
8010 /* Collect labels in this block. We don't keep those corresponding
8011 to END {IF|SELECT}, these are checked in resolve_branch by going
8012 up through the code_stack. */
8013 for (c = block; c; c = c->next)
8015 if (c->here && c->op != EXEC_END_BLOCK)
8016 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8019 /* Merge with labels from parent block. */
8022 gcc_assert (cs_base->prev->reachable_labels);
8023 bitmap_ior_into (cs_base->reachable_labels,
8024 cs_base->prev->reachable_labels);
8030 resolve_sync (gfc_code *code)
8032 /* Check imageset. The * case matches expr1 == NULL. */
8035 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8036 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8037 "INTEGER expression", &code->expr1->where);
8038 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8039 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8040 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8041 &code->expr1->where);
8042 else if (code->expr1->expr_type == EXPR_ARRAY
8043 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8045 gfc_constructor *cons;
8046 cons = gfc_constructor_first (code->expr1->value.constructor);
8047 for (; cons; cons = gfc_constructor_next (cons))
8048 if (cons->expr->expr_type == EXPR_CONSTANT
8049 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8050 gfc_error ("Imageset argument at %L must between 1 and "
8051 "num_images()", &cons->expr->where);
8057 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8058 || code->expr2->expr_type != EXPR_VARIABLE))
8059 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8060 &code->expr2->where);
8064 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8065 || code->expr3->expr_type != EXPR_VARIABLE))
8066 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8067 &code->expr3->where);
8071 /* Given a branch to a label, see if the branch is conforming.
8072 The code node describes where the branch is located. */
8075 resolve_branch (gfc_st_label *label, gfc_code *code)
8082 /* Step one: is this a valid branching target? */
8084 if (label->defined == ST_LABEL_UNKNOWN)
8086 gfc_error ("Label %d referenced at %L is never defined", label->value,
8091 if (label->defined != ST_LABEL_TARGET)
8093 gfc_error ("Statement at %L is not a valid branch target statement "
8094 "for the branch statement at %L", &label->where, &code->loc);
8098 /* Step two: make sure this branch is not a branch to itself ;-) */
8100 if (code->here == label)
8102 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8106 /* Step three: See if the label is in the same block as the
8107 branching statement. The hard work has been done by setting up
8108 the bitmap reachable_labels. */
8110 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8112 /* Check now whether there is a CRITICAL construct; if so, check
8113 whether the label is still visible outside of the CRITICAL block,
8114 which is invalid. */
8115 for (stack = cs_base; stack; stack = stack->prev)
8116 if (stack->current->op == EXEC_CRITICAL
8117 && bitmap_bit_p (stack->reachable_labels, label->value))
8118 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8119 " at %L", &code->loc, &label->where);
8124 /* Step four: If we haven't found the label in the bitmap, it may
8125 still be the label of the END of the enclosing block, in which
8126 case we find it by going up the code_stack. */
8128 for (stack = cs_base; stack; stack = stack->prev)
8130 if (stack->current->next && stack->current->next->here == label)
8132 if (stack->current->op == EXEC_CRITICAL)
8134 /* Note: A label at END CRITICAL does not leave the CRITICAL
8135 construct as END CRITICAL is still part of it. */
8136 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8137 " at %L", &code->loc, &label->where);
8144 gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
8148 /* The label is not in an enclosing block, so illegal. This was
8149 allowed in Fortran 66, so we allow it as extension. No
8150 further checks are necessary in this case. */
8151 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
8152 "as the GOTO statement at %L", &label->where,
8158 /* Check whether EXPR1 has the same shape as EXPR2. */
8161 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
8163 mpz_t shape[GFC_MAX_DIMENSIONS];
8164 mpz_t shape2[GFC_MAX_DIMENSIONS];
8165 gfc_try result = FAILURE;
8168 /* Compare the rank. */
8169 if (expr1->rank != expr2->rank)
8172 /* Compare the size of each dimension. */
8173 for (i=0; i<expr1->rank; i++)
8175 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
8178 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
8181 if (mpz_cmp (shape[i], shape2[i]))
8185 /* When either of the two expression is an assumed size array, we
8186 ignore the comparison of dimension sizes. */
8191 for (i--; i >= 0; i--)
8193 mpz_clear (shape[i]);
8194 mpz_clear (shape2[i]);
8200 /* Check whether a WHERE assignment target or a WHERE mask expression
8201 has the same shape as the outmost WHERE mask expression. */
8204 resolve_where (gfc_code *code, gfc_expr *mask)
8210 cblock = code->block;
8212 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8213 In case of nested WHERE, only the outmost one is stored. */
8214 if (mask == NULL) /* outmost WHERE */
8216 else /* inner WHERE */
8223 /* Check if the mask-expr has a consistent shape with the
8224 outmost WHERE mask-expr. */
8225 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8226 gfc_error ("WHERE mask at %L has inconsistent shape",
8227 &cblock->expr1->where);
8230 /* the assignment statement of a WHERE statement, or the first
8231 statement in where-body-construct of a WHERE construct */
8232 cnext = cblock->next;
8237 /* WHERE assignment statement */
8240 /* Check shape consistent for WHERE assignment target. */
8241 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8242 gfc_error ("WHERE assignment target at %L has "
8243 "inconsistent shape", &cnext->expr1->where);
8247 case EXEC_ASSIGN_CALL:
8248 resolve_call (cnext);
8249 if (!cnext->resolved_sym->attr.elemental)
8250 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8251 &cnext->ext.actual->expr->where);
8254 /* WHERE or WHERE construct is part of a where-body-construct */
8256 resolve_where (cnext, e);
8260 gfc_error ("Unsupported statement inside WHERE at %L",
8263 /* the next statement within the same where-body-construct */
8264 cnext = cnext->next;
8266 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8267 cblock = cblock->block;
8272 /* Resolve assignment in FORALL construct.
8273 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8274 FORALL index variables. */
8277 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8281 for (n = 0; n < nvar; n++)
8283 gfc_symbol *forall_index;
8285 forall_index = var_expr[n]->symtree->n.sym;
8287 /* Check whether the assignment target is one of the FORALL index
8289 if ((code->expr1->expr_type == EXPR_VARIABLE)
8290 && (code->expr1->symtree->n.sym == forall_index))
8291 gfc_error ("Assignment to a FORALL index variable at %L",
8292 &code->expr1->where);
8295 /* If one of the FORALL index variables doesn't appear in the
8296 assignment variable, then there could be a many-to-one
8297 assignment. Emit a warning rather than an error because the
8298 mask could be resolving this problem. */
8299 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8300 gfc_warning ("The FORALL with index '%s' is not used on the "
8301 "left side of the assignment at %L and so might "
8302 "cause multiple assignment to this object",
8303 var_expr[n]->symtree->name, &code->expr1->where);
8309 /* Resolve WHERE statement in FORALL construct. */
8312 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8313 gfc_expr **var_expr)
8318 cblock = code->block;
8321 /* the assignment statement of a WHERE statement, or the first
8322 statement in where-body-construct of a WHERE construct */
8323 cnext = cblock->next;
8328 /* WHERE assignment statement */
8330 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8333 /* WHERE operator assignment statement */
8334 case EXEC_ASSIGN_CALL:
8335 resolve_call (cnext);
8336 if (!cnext->resolved_sym->attr.elemental)
8337 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8338 &cnext->ext.actual->expr->where);
8341 /* WHERE or WHERE construct is part of a where-body-construct */
8343 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8347 gfc_error ("Unsupported statement inside WHERE at %L",
8350 /* the next statement within the same where-body-construct */
8351 cnext = cnext->next;
8353 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8354 cblock = cblock->block;
8359 /* Traverse the FORALL body to check whether the following errors exist:
8360 1. For assignment, check if a many-to-one assignment happens.
8361 2. For WHERE statement, check the WHERE body to see if there is any
8362 many-to-one assignment. */
8365 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8369 c = code->block->next;
8375 case EXEC_POINTER_ASSIGN:
8376 gfc_resolve_assign_in_forall (c, nvar, var_expr);
8379 case EXEC_ASSIGN_CALL:
8383 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8384 there is no need to handle it here. */
8388 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8393 /* The next statement in the FORALL body. */
8399 /* Counts the number of iterators needed inside a forall construct, including
8400 nested forall constructs. This is used to allocate the needed memory
8401 in gfc_resolve_forall. */
8404 gfc_count_forall_iterators (gfc_code *code)
8406 int max_iters, sub_iters, current_iters;
8407 gfc_forall_iterator *fa;
8409 gcc_assert(code->op == EXEC_FORALL);
8413 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8416 code = code->block->next;
8420 if (code->op == EXEC_FORALL)
8422 sub_iters = gfc_count_forall_iterators (code);
8423 if (sub_iters > max_iters)
8424 max_iters = sub_iters;
8429 return current_iters + max_iters;
8433 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8434 gfc_resolve_forall_body to resolve the FORALL body. */
8437 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8439 static gfc_expr **var_expr;
8440 static int total_var = 0;
8441 static int nvar = 0;
8443 gfc_forall_iterator *fa;
8448 /* Start to resolve a FORALL construct */
8449 if (forall_save == 0)
8451 /* Count the total number of FORALL index in the nested FORALL
8452 construct in order to allocate the VAR_EXPR with proper size. */
8453 total_var = gfc_count_forall_iterators (code);
8455 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8456 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
8459 /* The information about FORALL iterator, including FORALL index start, end
8460 and stride. The FORALL index can not appear in start, end or stride. */
8461 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8463 /* Check if any outer FORALL index name is the same as the current
8465 for (i = 0; i < nvar; i++)
8467 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8469 gfc_error ("An outer FORALL construct already has an index "
8470 "with this name %L", &fa->var->where);
8474 /* Record the current FORALL index. */
8475 var_expr[nvar] = gfc_copy_expr (fa->var);
8479 /* No memory leak. */
8480 gcc_assert (nvar <= total_var);
8483 /* Resolve the FORALL body. */
8484 gfc_resolve_forall_body (code, nvar, var_expr);
8486 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8487 gfc_resolve_blocks (code->block, ns);
8491 /* Free only the VAR_EXPRs allocated in this frame. */
8492 for (i = nvar; i < tmp; i++)
8493 gfc_free_expr (var_expr[i]);
8497 /* We are in the outermost FORALL construct. */
8498 gcc_assert (forall_save == 0);
8500 /* VAR_EXPR is not needed any more. */
8501 gfc_free (var_expr);
8507 /* Resolve a BLOCK construct statement. */
8510 resolve_block_construct (gfc_code* code)
8512 /* Resolve the BLOCK's namespace. */
8513 gfc_resolve (code->ext.block.ns);
8515 /* For an ASSOCIATE block, the associations (and their targets) are already
8516 resolved during resolve_symbol. */
8520 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8523 static void resolve_code (gfc_code *, gfc_namespace *);
8526 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8530 for (; b; b = b->block)
8532 t = gfc_resolve_expr (b->expr1);
8533 if (gfc_resolve_expr (b->expr2) == FAILURE)
8539 if (t == SUCCESS && b->expr1 != NULL
8540 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
8541 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8548 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
8549 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8554 resolve_branch (b->label1, b);
8558 resolve_block_construct (b);
8562 case EXEC_SELECT_TYPE:
8573 case EXEC_OMP_ATOMIC:
8574 case EXEC_OMP_CRITICAL:
8576 case EXEC_OMP_MASTER:
8577 case EXEC_OMP_ORDERED:
8578 case EXEC_OMP_PARALLEL:
8579 case EXEC_OMP_PARALLEL_DO:
8580 case EXEC_OMP_PARALLEL_SECTIONS:
8581 case EXEC_OMP_PARALLEL_WORKSHARE:
8582 case EXEC_OMP_SECTIONS:
8583 case EXEC_OMP_SINGLE:
8585 case EXEC_OMP_TASKWAIT:
8586 case EXEC_OMP_WORKSHARE:
8590 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
8593 resolve_code (b->next, ns);
8598 /* Does everything to resolve an ordinary assignment. Returns true
8599 if this is an interface assignment. */
8601 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
8611 if (gfc_extend_assign (code, ns) == SUCCESS)
8615 if (code->op == EXEC_ASSIGN_CALL)
8617 lhs = code->ext.actual->expr;
8618 rhsptr = &code->ext.actual->next->expr;
8622 gfc_actual_arglist* args;
8623 gfc_typebound_proc* tbp;
8625 gcc_assert (code->op == EXEC_COMPCALL);
8627 args = code->expr1->value.compcall.actual;
8629 rhsptr = &args->next->expr;
8631 tbp = code->expr1->value.compcall.tbp;
8632 gcc_assert (!tbp->is_generic);
8635 /* Make a temporary rhs when there is a default initializer
8636 and rhs is the same symbol as the lhs. */
8637 if ((*rhsptr)->expr_type == EXPR_VARIABLE
8638 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
8639 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
8640 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
8641 *rhsptr = gfc_get_parentheses (*rhsptr);
8650 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
8651 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
8652 &code->loc) == FAILURE)
8655 /* Handle the case of a BOZ literal on the RHS. */
8656 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
8659 if (gfc_option.warn_surprising)
8660 gfc_warning ("BOZ literal at %L is bitwise transferred "
8661 "non-integer symbol '%s'", &code->loc,
8662 lhs->symtree->n.sym->name);
8664 if (!gfc_convert_boz (rhs, &lhs->ts))
8666 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
8668 if (rc == ARITH_UNDERFLOW)
8669 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
8670 ". This check can be disabled with the option "
8671 "-fno-range-check", &rhs->where);
8672 else if (rc == ARITH_OVERFLOW)
8673 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
8674 ". This check can be disabled with the option "
8675 "-fno-range-check", &rhs->where);
8676 else if (rc == ARITH_NAN)
8677 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
8678 ". This check can be disabled with the option "
8679 "-fno-range-check", &rhs->where);
8685 if (lhs->ts.type == BT_CHARACTER
8686 && gfc_option.warn_character_truncation)
8688 if (lhs->ts.u.cl != NULL
8689 && lhs->ts.u.cl->length != NULL
8690 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8691 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
8693 if (rhs->expr_type == EXPR_CONSTANT)
8694 rlen = rhs->value.character.length;
8696 else if (rhs->ts.u.cl != NULL
8697 && rhs->ts.u.cl->length != NULL
8698 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8699 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
8701 if (rlen && llen && rlen > llen)
8702 gfc_warning_now ("CHARACTER expression will be truncated "
8703 "in assignment (%d/%d) at %L",
8704 llen, rlen, &code->loc);
8707 /* Ensure that a vector index expression for the lvalue is evaluated
8708 to a temporary if the lvalue symbol is referenced in it. */
8711 for (ref = lhs->ref; ref; ref= ref->next)
8712 if (ref->type == REF_ARRAY)
8714 for (n = 0; n < ref->u.ar.dimen; n++)
8715 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
8716 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
8717 ref->u.ar.start[n]))
8719 = gfc_get_parentheses (ref->u.ar.start[n]);
8723 if (gfc_pure (NULL))
8725 if (gfc_impure_variable (lhs->symtree->n.sym))
8727 gfc_error ("Cannot assign to variable '%s' in PURE "
8729 lhs->symtree->n.sym->name,
8734 if (lhs->ts.type == BT_DERIVED
8735 && lhs->expr_type == EXPR_VARIABLE
8736 && lhs->ts.u.derived->attr.pointer_comp
8737 && rhs->expr_type == EXPR_VARIABLE
8738 && (gfc_impure_variable (rhs->symtree->n.sym)
8739 || gfc_is_coindexed (rhs)))
8742 if (gfc_is_coindexed (rhs))
8743 gfc_error ("Coindexed expression at %L is assigned to "
8744 "a derived type variable with a POINTER "
8745 "component in a PURE procedure",
8748 gfc_error ("The impure variable at %L is assigned to "
8749 "a derived type variable with a POINTER "
8750 "component in a PURE procedure (12.6)",
8755 /* Fortran 2008, C1283. */
8756 if (gfc_is_coindexed (lhs))
8758 gfc_error ("Assignment to coindexed variable at %L in a PURE "
8759 "procedure", &rhs->where);
8765 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
8766 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
8767 if (lhs->ts.type == BT_CLASS)
8769 gfc_error ("Variable must not be polymorphic in assignment at %L",
8774 /* F2008, Section 7.2.1.2. */
8775 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
8777 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
8778 "component in assignment at %L", &lhs->where);
8782 gfc_check_assign (lhs, rhs, 1);
8787 /* Given a block of code, recursively resolve everything pointed to by this
8791 resolve_code (gfc_code *code, gfc_namespace *ns)
8793 int omp_workshare_save;
8798 frame.prev = cs_base;
8802 find_reachable_labels (code);
8804 for (; code; code = code->next)
8806 frame.current = code;
8807 forall_save = forall_flag;
8809 if (code->op == EXEC_FORALL)
8812 gfc_resolve_forall (code, ns, forall_save);
8815 else if (code->block)
8817 omp_workshare_save = -1;
8820 case EXEC_OMP_PARALLEL_WORKSHARE:
8821 omp_workshare_save = omp_workshare_flag;
8822 omp_workshare_flag = 1;
8823 gfc_resolve_omp_parallel_blocks (code, ns);
8825 case EXEC_OMP_PARALLEL:
8826 case EXEC_OMP_PARALLEL_DO:
8827 case EXEC_OMP_PARALLEL_SECTIONS:
8829 omp_workshare_save = omp_workshare_flag;
8830 omp_workshare_flag = 0;
8831 gfc_resolve_omp_parallel_blocks (code, ns);
8834 gfc_resolve_omp_do_blocks (code, ns);
8836 case EXEC_SELECT_TYPE:
8837 gfc_current_ns = code->ext.block.ns;
8838 gfc_resolve_blocks (code->block, gfc_current_ns);
8839 gfc_current_ns = ns;
8841 case EXEC_OMP_WORKSHARE:
8842 omp_workshare_save = omp_workshare_flag;
8843 omp_workshare_flag = 1;
8846 gfc_resolve_blocks (code->block, ns);
8850 if (omp_workshare_save != -1)
8851 omp_workshare_flag = omp_workshare_save;
8855 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
8856 t = gfc_resolve_expr (code->expr1);
8857 forall_flag = forall_save;
8859 if (gfc_resolve_expr (code->expr2) == FAILURE)
8862 if (code->op == EXEC_ALLOCATE
8863 && gfc_resolve_expr (code->expr3) == FAILURE)
8869 case EXEC_END_BLOCK:
8873 case EXEC_ERROR_STOP:
8877 case EXEC_ASSIGN_CALL:
8882 case EXEC_SYNC_IMAGES:
8883 case EXEC_SYNC_MEMORY:
8884 resolve_sync (code);
8888 /* Keep track of which entry we are up to. */
8889 current_entry_id = code->ext.entry->id;
8893 resolve_where (code, NULL);
8897 if (code->expr1 != NULL)
8899 if (code->expr1->ts.type != BT_INTEGER)
8900 gfc_error ("ASSIGNED GOTO statement at %L requires an "
8901 "INTEGER variable", &code->expr1->where);
8902 else if (code->expr1->symtree->n.sym->attr.assign != 1)
8903 gfc_error ("Variable '%s' has not been assigned a target "
8904 "label at %L", code->expr1->symtree->n.sym->name,
8905 &code->expr1->where);
8908 resolve_branch (code->label1, code);
8912 if (code->expr1 != NULL
8913 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
8914 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
8915 "INTEGER return specifier", &code->expr1->where);
8918 case EXEC_INIT_ASSIGN:
8919 case EXEC_END_PROCEDURE:
8926 if (resolve_ordinary_assign (code, ns))
8928 if (code->op == EXEC_COMPCALL)
8935 case EXEC_LABEL_ASSIGN:
8936 if (code->label1->defined == ST_LABEL_UNKNOWN)
8937 gfc_error ("Label %d referenced at %L is never defined",
8938 code->label1->value, &code->label1->where);
8940 && (code->expr1->expr_type != EXPR_VARIABLE
8941 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
8942 || code->expr1->symtree->n.sym->ts.kind
8943 != gfc_default_integer_kind
8944 || code->expr1->symtree->n.sym->as != NULL))
8945 gfc_error ("ASSIGN statement at %L requires a scalar "
8946 "default INTEGER variable", &code->expr1->where);
8949 case EXEC_POINTER_ASSIGN:
8953 gfc_check_pointer_assign (code->expr1, code->expr2);
8956 case EXEC_ARITHMETIC_IF:
8958 && code->expr1->ts.type != BT_INTEGER
8959 && code->expr1->ts.type != BT_REAL)
8960 gfc_error ("Arithmetic IF statement at %L requires a numeric "
8961 "expression", &code->expr1->where);
8963 resolve_branch (code->label1, code);
8964 resolve_branch (code->label2, code);
8965 resolve_branch (code->label3, code);
8969 if (t == SUCCESS && code->expr1 != NULL
8970 && (code->expr1->ts.type != BT_LOGICAL
8971 || code->expr1->rank != 0))
8972 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8973 &code->expr1->where);
8978 resolve_call (code);
8983 resolve_typebound_subroutine (code);
8987 resolve_ppc_call (code);
8991 /* Select is complicated. Also, a SELECT construct could be
8992 a transformed computed GOTO. */
8993 resolve_select (code);
8996 case EXEC_SELECT_TYPE:
8997 resolve_select_type (code);
9001 resolve_block_construct (code);
9005 if (code->ext.iterator != NULL)
9007 gfc_iterator *iter = code->ext.iterator;
9008 if (gfc_resolve_iterator (iter, true) != FAILURE)
9009 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
9014 if (code->expr1 == NULL)
9015 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9017 && (code->expr1->rank != 0
9018 || code->expr1->ts.type != BT_LOGICAL))
9019 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9020 "a scalar LOGICAL expression", &code->expr1->where);
9025 resolve_allocate_deallocate (code, "ALLOCATE");
9029 case EXEC_DEALLOCATE:
9031 resolve_allocate_deallocate (code, "DEALLOCATE");
9036 if (gfc_resolve_open (code->ext.open) == FAILURE)
9039 resolve_branch (code->ext.open->err, code);
9043 if (gfc_resolve_close (code->ext.close) == FAILURE)
9046 resolve_branch (code->ext.close->err, code);
9049 case EXEC_BACKSPACE:
9053 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
9056 resolve_branch (code->ext.filepos->err, code);
9060 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9063 resolve_branch (code->ext.inquire->err, code);
9067 gcc_assert (code->ext.inquire != NULL);
9068 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9071 resolve_branch (code->ext.inquire->err, code);
9075 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
9078 resolve_branch (code->ext.wait->err, code);
9079 resolve_branch (code->ext.wait->end, code);
9080 resolve_branch (code->ext.wait->eor, code);
9085 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
9088 resolve_branch (code->ext.dt->err, code);
9089 resolve_branch (code->ext.dt->end, code);
9090 resolve_branch (code->ext.dt->eor, code);
9094 resolve_transfer (code);
9098 resolve_forall_iterators (code->ext.forall_iterator);
9100 if (code->expr1 != NULL && code->expr1->ts.type != BT_LOGICAL)
9101 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
9102 "expression", &code->expr1->where);
9105 case EXEC_OMP_ATOMIC:
9106 case EXEC_OMP_BARRIER:
9107 case EXEC_OMP_CRITICAL:
9108 case EXEC_OMP_FLUSH:
9110 case EXEC_OMP_MASTER:
9111 case EXEC_OMP_ORDERED:
9112 case EXEC_OMP_SECTIONS:
9113 case EXEC_OMP_SINGLE:
9114 case EXEC_OMP_TASKWAIT:
9115 case EXEC_OMP_WORKSHARE:
9116 gfc_resolve_omp_directive (code, ns);
9119 case EXEC_OMP_PARALLEL:
9120 case EXEC_OMP_PARALLEL_DO:
9121 case EXEC_OMP_PARALLEL_SECTIONS:
9122 case EXEC_OMP_PARALLEL_WORKSHARE:
9124 omp_workshare_save = omp_workshare_flag;
9125 omp_workshare_flag = 0;
9126 gfc_resolve_omp_directive (code, ns);
9127 omp_workshare_flag = omp_workshare_save;
9131 gfc_internal_error ("resolve_code(): Bad statement code");
9135 cs_base = frame.prev;
9139 /* Resolve initial values and make sure they are compatible with
9143 resolve_values (gfc_symbol *sym)
9147 if (sym->value == NULL)
9150 if (sym->value->expr_type == EXPR_STRUCTURE)
9151 t= resolve_structure_cons (sym->value, 1);
9153 t = gfc_resolve_expr (sym->value);
9158 gfc_check_assign_symbol (sym, sym->value);
9162 /* Verify the binding labels for common blocks that are BIND(C). The label
9163 for a BIND(C) common block must be identical in all scoping units in which
9164 the common block is declared. Further, the binding label can not collide
9165 with any other global entity in the program. */
9168 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
9170 if (comm_block_tree->n.common->is_bind_c == 1)
9172 gfc_gsymbol *binding_label_gsym;
9173 gfc_gsymbol *comm_name_gsym;
9175 /* See if a global symbol exists by the common block's name. It may
9176 be NULL if the common block is use-associated. */
9177 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
9178 comm_block_tree->n.common->name);
9179 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
9180 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9181 "with the global entity '%s' at %L",
9182 comm_block_tree->n.common->binding_label,
9183 comm_block_tree->n.common->name,
9184 &(comm_block_tree->n.common->where),
9185 comm_name_gsym->name, &(comm_name_gsym->where));
9186 else if (comm_name_gsym != NULL
9187 && strcmp (comm_name_gsym->name,
9188 comm_block_tree->n.common->name) == 0)
9190 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9192 if (comm_name_gsym->binding_label == NULL)
9193 /* No binding label for common block stored yet; save this one. */
9194 comm_name_gsym->binding_label =
9195 comm_block_tree->n.common->binding_label;
9197 if (strcmp (comm_name_gsym->binding_label,
9198 comm_block_tree->n.common->binding_label) != 0)
9200 /* Common block names match but binding labels do not. */
9201 gfc_error ("Binding label '%s' for common block '%s' at %L "
9202 "does not match the binding label '%s' for common "
9204 comm_block_tree->n.common->binding_label,
9205 comm_block_tree->n.common->name,
9206 &(comm_block_tree->n.common->where),
9207 comm_name_gsym->binding_label,
9208 comm_name_gsym->name,
9209 &(comm_name_gsym->where));
9214 /* There is no binding label (NAME="") so we have nothing further to
9215 check and nothing to add as a global symbol for the label. */
9216 if (comm_block_tree->n.common->binding_label[0] == '\0' )
9219 binding_label_gsym =
9220 gfc_find_gsymbol (gfc_gsym_root,
9221 comm_block_tree->n.common->binding_label);
9222 if (binding_label_gsym == NULL)
9224 /* Need to make a global symbol for the binding label to prevent
9225 it from colliding with another. */
9226 binding_label_gsym =
9227 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9228 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9229 binding_label_gsym->type = GSYM_COMMON;
9233 /* If comm_name_gsym is NULL, the name common block is use
9234 associated and the name could be colliding. */
9235 if (binding_label_gsym->type != GSYM_COMMON)
9236 gfc_error ("Binding label '%s' for common block '%s' at %L "
9237 "collides with the global entity '%s' at %L",
9238 comm_block_tree->n.common->binding_label,
9239 comm_block_tree->n.common->name,
9240 &(comm_block_tree->n.common->where),
9241 binding_label_gsym->name,
9242 &(binding_label_gsym->where));
9243 else if (comm_name_gsym != NULL
9244 && (strcmp (binding_label_gsym->name,
9245 comm_name_gsym->binding_label) != 0)
9246 && (strcmp (binding_label_gsym->sym_name,
9247 comm_name_gsym->name) != 0))
9248 gfc_error ("Binding label '%s' for common block '%s' at %L "
9249 "collides with global entity '%s' at %L",
9250 binding_label_gsym->name, binding_label_gsym->sym_name,
9251 &(comm_block_tree->n.common->where),
9252 comm_name_gsym->name, &(comm_name_gsym->where));
9260 /* Verify any BIND(C) derived types in the namespace so we can report errors
9261 for them once, rather than for each variable declared of that type. */
9264 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9266 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9267 && derived_sym->attr.is_bind_c == 1)
9268 verify_bind_c_derived_type (derived_sym);
9274 /* Verify that any binding labels used in a given namespace do not collide
9275 with the names or binding labels of any global symbols. */
9278 gfc_verify_binding_labels (gfc_symbol *sym)
9282 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9283 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
9285 gfc_gsymbol *bind_c_sym;
9287 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9288 if (bind_c_sym != NULL
9289 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9291 if (sym->attr.if_source == IFSRC_DECL
9292 && (bind_c_sym->type != GSYM_SUBROUTINE
9293 && bind_c_sym->type != GSYM_FUNCTION)
9294 && ((sym->attr.contained == 1
9295 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9296 || (sym->attr.use_assoc == 1
9297 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9299 /* Make sure global procedures don't collide with anything. */
9300 gfc_error ("Binding label '%s' at %L collides with the global "
9301 "entity '%s' at %L", sym->binding_label,
9302 &(sym->declared_at), bind_c_sym->name,
9303 &(bind_c_sym->where));
9306 else if (sym->attr.contained == 0
9307 && (sym->attr.if_source == IFSRC_IFBODY
9308 && sym->attr.flavor == FL_PROCEDURE)
9309 && (bind_c_sym->sym_name != NULL
9310 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9312 /* Make sure procedures in interface bodies don't collide. */
9313 gfc_error ("Binding label '%s' in interface body at %L collides "
9314 "with the global entity '%s' at %L",
9316 &(sym->declared_at), bind_c_sym->name,
9317 &(bind_c_sym->where));
9320 else if (sym->attr.contained == 0
9321 && sym->attr.if_source == IFSRC_UNKNOWN)
9322 if ((sym->attr.use_assoc && bind_c_sym->mod_name
9323 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9324 || sym->attr.use_assoc == 0)
9326 gfc_error ("Binding label '%s' at %L collides with global "
9327 "entity '%s' at %L", sym->binding_label,
9328 &(sym->declared_at), bind_c_sym->name,
9329 &(bind_c_sym->where));
9334 /* Clear the binding label to prevent checking multiple times. */
9335 sym->binding_label[0] = '\0';
9337 else if (bind_c_sym == NULL)
9339 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9340 bind_c_sym->where = sym->declared_at;
9341 bind_c_sym->sym_name = sym->name;
9343 if (sym->attr.use_assoc == 1)
9344 bind_c_sym->mod_name = sym->module;
9346 if (sym->ns->proc_name != NULL)
9347 bind_c_sym->mod_name = sym->ns->proc_name->name;
9349 if (sym->attr.contained == 0)
9351 if (sym->attr.subroutine)
9352 bind_c_sym->type = GSYM_SUBROUTINE;
9353 else if (sym->attr.function)
9354 bind_c_sym->type = GSYM_FUNCTION;
9362 /* Resolve an index expression. */
9365 resolve_index_expr (gfc_expr *e)
9367 if (gfc_resolve_expr (e) == FAILURE)
9370 if (gfc_simplify_expr (e, 0) == FAILURE)
9373 if (gfc_specification_expr (e) == FAILURE)
9379 /* Resolve a charlen structure. */
9382 resolve_charlen (gfc_charlen *cl)
9391 specification_expr = 1;
9393 if (resolve_index_expr (cl->length) == FAILURE)
9395 specification_expr = 0;
9399 /* "If the character length parameter value evaluates to a negative
9400 value, the length of character entities declared is zero." */
9401 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9403 if (gfc_option.warn_surprising)
9404 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9405 " the length has been set to zero",
9406 &cl->length->where, i);
9407 gfc_replace_expr (cl->length,
9408 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9411 /* Check that the character length is not too large. */
9412 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9413 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9414 && cl->length->ts.type == BT_INTEGER
9415 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9417 gfc_error ("String length at %L is too large", &cl->length->where);
9425 /* Test for non-constant shape arrays. */
9428 is_non_constant_shape_array (gfc_symbol *sym)
9434 not_constant = false;
9435 if (sym->as != NULL)
9437 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9438 has not been simplified; parameter array references. Do the
9439 simplification now. */
9440 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9442 e = sym->as->lower[i];
9443 if (e && (resolve_index_expr (e) == FAILURE
9444 || !gfc_is_constant_expr (e)))
9445 not_constant = true;
9446 e = sym->as->upper[i];
9447 if (e && (resolve_index_expr (e) == FAILURE
9448 || !gfc_is_constant_expr (e)))
9449 not_constant = true;
9452 return not_constant;
9455 /* Given a symbol and an initialization expression, add code to initialize
9456 the symbol to the function entry. */
9458 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9462 gfc_namespace *ns = sym->ns;
9464 /* Search for the function namespace if this is a contained
9465 function without an explicit result. */
9466 if (sym->attr.function && sym == sym->result
9467 && sym->name != sym->ns->proc_name->name)
9470 for (;ns; ns = ns->sibling)
9471 if (strcmp (ns->proc_name->name, sym->name) == 0)
9477 gfc_free_expr (init);
9481 /* Build an l-value expression for the result. */
9482 lval = gfc_lval_expr_from_sym (sym);
9484 /* Add the code at scope entry. */
9485 init_st = gfc_get_code ();
9486 init_st->next = ns->code;
9489 /* Assign the default initializer to the l-value. */
9490 init_st->loc = sym->declared_at;
9491 init_st->op = EXEC_INIT_ASSIGN;
9492 init_st->expr1 = lval;
9493 init_st->expr2 = init;
9496 /* Assign the default initializer to a derived type variable or result. */
9499 apply_default_init (gfc_symbol *sym)
9501 gfc_expr *init = NULL;
9503 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9506 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
9507 init = gfc_default_initializer (&sym->ts);
9509 if (init == NULL && sym->ts.type != BT_CLASS)
9512 build_init_assign (sym, init);
9513 sym->attr.referenced = 1;
9516 /* Build an initializer for a local integer, real, complex, logical, or
9517 character variable, based on the command line flags finit-local-zero,
9518 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
9519 null if the symbol should not have a default initialization. */
9521 build_default_init_expr (gfc_symbol *sym)
9524 gfc_expr *init_expr;
9527 /* These symbols should never have a default initialization. */
9528 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
9529 || sym->attr.external
9531 || sym->attr.pointer
9532 || sym->attr.in_equivalence
9533 || sym->attr.in_common
9536 || sym->attr.cray_pointee
9537 || sym->attr.cray_pointer)
9540 /* Now we'll try to build an initializer expression. */
9541 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
9544 /* We will only initialize integers, reals, complex, logicals, and
9545 characters, and only if the corresponding command-line flags
9546 were set. Otherwise, we free init_expr and return null. */
9547 switch (sym->ts.type)
9550 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
9551 mpz_set_si (init_expr->value.integer,
9552 gfc_option.flag_init_integer_value);
9555 gfc_free_expr (init_expr);
9561 switch (gfc_option.flag_init_real)
9563 case GFC_INIT_REAL_SNAN:
9564 init_expr->is_snan = 1;
9566 case GFC_INIT_REAL_NAN:
9567 mpfr_set_nan (init_expr->value.real);
9570 case GFC_INIT_REAL_INF:
9571 mpfr_set_inf (init_expr->value.real, 1);
9574 case GFC_INIT_REAL_NEG_INF:
9575 mpfr_set_inf (init_expr->value.real, -1);
9578 case GFC_INIT_REAL_ZERO:
9579 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
9583 gfc_free_expr (init_expr);
9590 switch (gfc_option.flag_init_real)
9592 case GFC_INIT_REAL_SNAN:
9593 init_expr->is_snan = 1;
9595 case GFC_INIT_REAL_NAN:
9596 mpfr_set_nan (mpc_realref (init_expr->value.complex));
9597 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
9600 case GFC_INIT_REAL_INF:
9601 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
9602 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
9605 case GFC_INIT_REAL_NEG_INF:
9606 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
9607 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
9610 case GFC_INIT_REAL_ZERO:
9611 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
9615 gfc_free_expr (init_expr);
9622 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
9623 init_expr->value.logical = 0;
9624 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
9625 init_expr->value.logical = 1;
9628 gfc_free_expr (init_expr);
9634 /* For characters, the length must be constant in order to
9635 create a default initializer. */
9636 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
9637 && sym->ts.u.cl->length
9638 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9640 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
9641 init_expr->value.character.length = char_len;
9642 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
9643 for (i = 0; i < char_len; i++)
9644 init_expr->value.character.string[i]
9645 = (unsigned char) gfc_option.flag_init_character_value;
9649 gfc_free_expr (init_expr);
9655 gfc_free_expr (init_expr);
9661 /* Add an initialization expression to a local variable. */
9663 apply_default_init_local (gfc_symbol *sym)
9665 gfc_expr *init = NULL;
9667 /* The symbol should be a variable or a function return value. */
9668 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9669 || (sym->attr.function && sym->result != sym))
9672 /* Try to build the initializer expression. If we can't initialize
9673 this symbol, then init will be NULL. */
9674 init = build_default_init_expr (sym);
9678 /* For saved variables, we don't want to add an initializer at
9679 function entry, so we just add a static initializer. */
9680 if (sym->attr.save || sym->ns->save_all
9681 || gfc_option.flag_max_stack_var_size == 0)
9683 /* Don't clobber an existing initializer! */
9684 gcc_assert (sym->value == NULL);
9689 build_init_assign (sym, init);
9692 /* Resolution of common features of flavors variable and procedure. */
9695 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
9697 /* Constraints on deferred shape variable. */
9698 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
9700 if (sym->attr.allocatable)
9702 if (sym->attr.dimension)
9704 gfc_error ("Allocatable array '%s' at %L must have "
9705 "a deferred shape", sym->name, &sym->declared_at);
9708 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
9709 "may not be ALLOCATABLE", sym->name,
9710 &sym->declared_at) == FAILURE)
9714 if (sym->attr.pointer && sym->attr.dimension)
9716 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
9717 sym->name, &sym->declared_at);
9723 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
9724 && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc)
9726 gfc_error ("Array '%s' at %L cannot have a deferred shape",
9727 sym->name, &sym->declared_at);
9732 /* Constraints on polymorphic variables. */
9733 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
9736 if (sym->attr.class_ok
9737 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
9739 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
9740 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
9746 /* Assume that use associated symbols were checked in the module ns.
9747 Class-variables that are associate-names are also something special
9748 and excepted from the test. */
9749 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
9751 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
9752 "or pointer", sym->name, &sym->declared_at);
9761 /* Additional checks for symbols with flavor variable and derived
9762 type. To be called from resolve_fl_variable. */
9765 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
9767 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
9769 /* Check to see if a derived type is blocked from being host
9770 associated by the presence of another class I symbol in the same
9771 namespace. 14.6.1.3 of the standard and the discussion on
9772 comp.lang.fortran. */
9773 if (sym->ns != sym->ts.u.derived->ns
9774 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
9777 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
9778 if (s && s->attr.flavor != FL_DERIVED)
9780 gfc_error ("The type '%s' cannot be host associated at %L "
9781 "because it is blocked by an incompatible object "
9782 "of the same name declared at %L",
9783 sym->ts.u.derived->name, &sym->declared_at,
9789 /* 4th constraint in section 11.3: "If an object of a type for which
9790 component-initialization is specified (R429) appears in the
9791 specification-part of a module and does not have the ALLOCATABLE
9792 or POINTER attribute, the object shall have the SAVE attribute."
9794 The check for initializers is performed with
9795 gfc_has_default_initializer because gfc_default_initializer generates
9796 a hidden default for allocatable components. */
9797 if (!(sym->value || no_init_flag) && sym->ns->proc_name
9798 && sym->ns->proc_name->attr.flavor == FL_MODULE
9799 && !sym->ns->save_all && !sym->attr.save
9800 && !sym->attr.pointer && !sym->attr.allocatable
9801 && gfc_has_default_initializer (sym->ts.u.derived)
9802 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
9803 "module variable '%s' at %L, needed due to "
9804 "the default initialization", sym->name,
9805 &sym->declared_at) == FAILURE)
9808 /* Assign default initializer. */
9809 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
9810 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
9812 sym->value = gfc_default_initializer (&sym->ts);
9819 /* Resolve symbols with flavor variable. */
9822 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
9824 int no_init_flag, automatic_flag;
9826 const char *auto_save_msg;
9828 auto_save_msg = "Automatic object '%s' at %L cannot have the "
9831 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9834 /* Set this flag to check that variables are parameters of all entries.
9835 This check is effected by the call to gfc_resolve_expr through
9836 is_non_constant_shape_array. */
9837 specification_expr = 1;
9839 if (sym->ns->proc_name
9840 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9841 || sym->ns->proc_name->attr.is_main_program)
9842 && !sym->attr.use_assoc
9843 && !sym->attr.allocatable
9844 && !sym->attr.pointer
9845 && is_non_constant_shape_array (sym))
9847 /* The shape of a main program or module array needs to be
9849 gfc_error ("The module or main program array '%s' at %L must "
9850 "have constant shape", sym->name, &sym->declared_at);
9851 specification_expr = 0;
9855 if (sym->ts.type == BT_CHARACTER)
9857 /* Make sure that character string variables with assumed length are
9859 e = sym->ts.u.cl->length;
9860 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
9862 gfc_error ("Entity with assumed character length at %L must be a "
9863 "dummy argument or a PARAMETER", &sym->declared_at);
9867 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
9869 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9873 if (!gfc_is_constant_expr (e)
9874 && !(e->expr_type == EXPR_VARIABLE
9875 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
9876 && sym->ns->proc_name
9877 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9878 || sym->ns->proc_name->attr.is_main_program)
9879 && !sym->attr.use_assoc)
9881 gfc_error ("'%s' at %L must have constant character length "
9882 "in this context", sym->name, &sym->declared_at);
9887 if (sym->value == NULL && sym->attr.referenced)
9888 apply_default_init_local (sym); /* Try to apply a default initialization. */
9890 /* Determine if the symbol may not have an initializer. */
9891 no_init_flag = automatic_flag = 0;
9892 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
9893 || sym->attr.intrinsic || sym->attr.result)
9895 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
9896 && is_non_constant_shape_array (sym))
9898 no_init_flag = automatic_flag = 1;
9900 /* Also, they must not have the SAVE attribute.
9901 SAVE_IMPLICIT is checked below. */
9902 if (sym->attr.save == SAVE_EXPLICIT)
9904 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9909 /* Ensure that any initializer is simplified. */
9911 gfc_simplify_expr (sym->value, 1);
9913 /* Reject illegal initializers. */
9914 if (!sym->mark && sym->value)
9916 if (sym->attr.allocatable)
9917 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
9918 sym->name, &sym->declared_at);
9919 else if (sym->attr.external)
9920 gfc_error ("External '%s' at %L cannot have an initializer",
9921 sym->name, &sym->declared_at);
9922 else if (sym->attr.dummy
9923 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
9924 gfc_error ("Dummy '%s' at %L cannot have an initializer",
9925 sym->name, &sym->declared_at);
9926 else if (sym->attr.intrinsic)
9927 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
9928 sym->name, &sym->declared_at);
9929 else if (sym->attr.result)
9930 gfc_error ("Function result '%s' at %L cannot have an initializer",
9931 sym->name, &sym->declared_at);
9932 else if (automatic_flag)
9933 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
9934 sym->name, &sym->declared_at);
9941 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
9942 return resolve_fl_variable_derived (sym, no_init_flag);
9948 /* Resolve a procedure. */
9951 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
9953 gfc_formal_arglist *arg;
9955 if (sym->attr.function
9956 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9959 if (sym->ts.type == BT_CHARACTER)
9961 gfc_charlen *cl = sym->ts.u.cl;
9963 if (cl && cl->length && gfc_is_constant_expr (cl->length)
9964 && resolve_charlen (cl) == FAILURE)
9967 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
9968 && sym->attr.proc == PROC_ST_FUNCTION)
9970 gfc_error ("Character-valued statement function '%s' at %L must "
9971 "have constant length", sym->name, &sym->declared_at);
9976 /* Ensure that derived type for are not of a private type. Internal
9977 module procedures are excluded by 2.2.3.3 - i.e., they are not
9978 externally accessible and can access all the objects accessible in
9980 if (!(sym->ns->parent
9981 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
9982 && gfc_check_access(sym->attr.access, sym->ns->default_access))
9984 gfc_interface *iface;
9986 for (arg = sym->formal; arg; arg = arg->next)
9989 && arg->sym->ts.type == BT_DERIVED
9990 && !arg->sym->ts.u.derived->attr.use_assoc
9991 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
9992 arg->sym->ts.u.derived->ns->default_access)
9993 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
9994 "PRIVATE type and cannot be a dummy argument"
9995 " of '%s', which is PUBLIC at %L",
9996 arg->sym->name, sym->name, &sym->declared_at)
9999 /* Stop this message from recurring. */
10000 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10005 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10006 PRIVATE to the containing module. */
10007 for (iface = sym->generic; iface; iface = iface->next)
10009 for (arg = iface->sym->formal; arg; arg = arg->next)
10012 && arg->sym->ts.type == BT_DERIVED
10013 && !arg->sym->ts.u.derived->attr.use_assoc
10014 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10015 arg->sym->ts.u.derived->ns->default_access)
10016 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10017 "'%s' in PUBLIC interface '%s' at %L "
10018 "takes dummy arguments of '%s' which is "
10019 "PRIVATE", iface->sym->name, sym->name,
10020 &iface->sym->declared_at,
10021 gfc_typename (&arg->sym->ts)) == FAILURE)
10023 /* Stop this message from recurring. */
10024 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10030 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10031 PRIVATE to the containing module. */
10032 for (iface = sym->generic; iface; iface = iface->next)
10034 for (arg = iface->sym->formal; arg; arg = arg->next)
10037 && arg->sym->ts.type == BT_DERIVED
10038 && !arg->sym->ts.u.derived->attr.use_assoc
10039 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10040 arg->sym->ts.u.derived->ns->default_access)
10041 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10042 "'%s' in PUBLIC interface '%s' at %L "
10043 "takes dummy arguments of '%s' which is "
10044 "PRIVATE", iface->sym->name, sym->name,
10045 &iface->sym->declared_at,
10046 gfc_typename (&arg->sym->ts)) == FAILURE)
10048 /* Stop this message from recurring. */
10049 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10056 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10057 && !sym->attr.proc_pointer)
10059 gfc_error ("Function '%s' at %L cannot have an initializer",
10060 sym->name, &sym->declared_at);
10064 /* An external symbol may not have an initializer because it is taken to be
10065 a procedure. Exception: Procedure Pointers. */
10066 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10068 gfc_error ("External object '%s' at %L may not have an initializer",
10069 sym->name, &sym->declared_at);
10073 /* An elemental function is required to return a scalar 12.7.1 */
10074 if (sym->attr.elemental && sym->attr.function && sym->as)
10076 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10077 "result", sym->name, &sym->declared_at);
10078 /* Reset so that the error only occurs once. */
10079 sym->attr.elemental = 0;
10083 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10084 char-len-param shall not be array-valued, pointer-valued, recursive
10085 or pure. ....snip... A character value of * may only be used in the
10086 following ways: (i) Dummy arg of procedure - dummy associates with
10087 actual length; (ii) To declare a named constant; or (iii) External
10088 function - but length must be declared in calling scoping unit. */
10089 if (sym->attr.function
10090 && sym->ts.type == BT_CHARACTER
10091 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10093 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10094 || (sym->attr.recursive) || (sym->attr.pure))
10096 if (sym->as && sym->as->rank)
10097 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10098 "array-valued", sym->name, &sym->declared_at);
10100 if (sym->attr.pointer)
10101 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10102 "pointer-valued", sym->name, &sym->declared_at);
10104 if (sym->attr.pure)
10105 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10106 "pure", sym->name, &sym->declared_at);
10108 if (sym->attr.recursive)
10109 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10110 "recursive", sym->name, &sym->declared_at);
10115 /* Appendix B.2 of the standard. Contained functions give an
10116 error anyway. Fixed-form is likely to be F77/legacy. */
10117 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
10118 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10119 "CHARACTER(*) function '%s' at %L",
10120 sym->name, &sym->declared_at);
10123 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10125 gfc_formal_arglist *curr_arg;
10126 int has_non_interop_arg = 0;
10128 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10129 sym->common_block) == FAILURE)
10131 /* Clear these to prevent looking at them again if there was an
10133 sym->attr.is_bind_c = 0;
10134 sym->attr.is_c_interop = 0;
10135 sym->ts.is_c_interop = 0;
10139 /* So far, no errors have been found. */
10140 sym->attr.is_c_interop = 1;
10141 sym->ts.is_c_interop = 1;
10144 curr_arg = sym->formal;
10145 while (curr_arg != NULL)
10147 /* Skip implicitly typed dummy args here. */
10148 if (curr_arg->sym->attr.implicit_type == 0)
10149 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
10150 /* If something is found to fail, record the fact so we
10151 can mark the symbol for the procedure as not being
10152 BIND(C) to try and prevent multiple errors being
10154 has_non_interop_arg = 1;
10156 curr_arg = curr_arg->next;
10159 /* See if any of the arguments were not interoperable and if so, clear
10160 the procedure symbol to prevent duplicate error messages. */
10161 if (has_non_interop_arg != 0)
10163 sym->attr.is_c_interop = 0;
10164 sym->ts.is_c_interop = 0;
10165 sym->attr.is_bind_c = 0;
10169 if (!sym->attr.proc_pointer)
10171 if (sym->attr.save == SAVE_EXPLICIT)
10173 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10174 "in '%s' at %L", sym->name, &sym->declared_at);
10177 if (sym->attr.intent)
10179 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10180 "in '%s' at %L", sym->name, &sym->declared_at);
10183 if (sym->attr.subroutine && sym->attr.result)
10185 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10186 "in '%s' at %L", sym->name, &sym->declared_at);
10189 if (sym->attr.external && sym->attr.function
10190 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10191 || sym->attr.contained))
10193 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10194 "in '%s' at %L", sym->name, &sym->declared_at);
10197 if (strcmp ("ppr@", sym->name) == 0)
10199 gfc_error ("Procedure pointer result '%s' at %L "
10200 "is missing the pointer attribute",
10201 sym->ns->proc_name->name, &sym->declared_at);
10210 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10211 been defined and we now know their defined arguments, check that they fulfill
10212 the requirements of the standard for procedures used as finalizers. */
10215 gfc_resolve_finalizers (gfc_symbol* derived)
10217 gfc_finalizer* list;
10218 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10219 gfc_try result = SUCCESS;
10220 bool seen_scalar = false;
10222 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10225 /* Walk over the list of finalizer-procedures, check them, and if any one
10226 does not fit in with the standard's definition, print an error and remove
10227 it from the list. */
10228 prev_link = &derived->f2k_derived->finalizers;
10229 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10235 /* Skip this finalizer if we already resolved it. */
10236 if (list->proc_tree)
10238 prev_link = &(list->next);
10242 /* Check this exists and is a SUBROUTINE. */
10243 if (!list->proc_sym->attr.subroutine)
10245 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10246 list->proc_sym->name, &list->where);
10250 /* We should have exactly one argument. */
10251 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10253 gfc_error ("FINAL procedure at %L must have exactly one argument",
10257 arg = list->proc_sym->formal->sym;
10259 /* This argument must be of our type. */
10260 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10262 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10263 &arg->declared_at, derived->name);
10267 /* It must neither be a pointer nor allocatable nor optional. */
10268 if (arg->attr.pointer)
10270 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10271 &arg->declared_at);
10274 if (arg->attr.allocatable)
10276 gfc_error ("Argument of FINAL procedure at %L must not be"
10277 " ALLOCATABLE", &arg->declared_at);
10280 if (arg->attr.optional)
10282 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10283 &arg->declared_at);
10287 /* It must not be INTENT(OUT). */
10288 if (arg->attr.intent == INTENT_OUT)
10290 gfc_error ("Argument of FINAL procedure at %L must not be"
10291 " INTENT(OUT)", &arg->declared_at);
10295 /* Warn if the procedure is non-scalar and not assumed shape. */
10296 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10297 && arg->as->type != AS_ASSUMED_SHAPE)
10298 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10299 " shape argument", &arg->declared_at);
10301 /* Check that it does not match in kind and rank with a FINAL procedure
10302 defined earlier. To really loop over the *earlier* declarations,
10303 we need to walk the tail of the list as new ones were pushed at the
10305 /* TODO: Handle kind parameters once they are implemented. */
10306 my_rank = (arg->as ? arg->as->rank : 0);
10307 for (i = list->next; i; i = i->next)
10309 /* Argument list might be empty; that is an error signalled earlier,
10310 but we nevertheless continued resolving. */
10311 if (i->proc_sym->formal)
10313 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10314 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10315 if (i_rank == my_rank)
10317 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10318 " rank (%d) as '%s'",
10319 list->proc_sym->name, &list->where, my_rank,
10320 i->proc_sym->name);
10326 /* Is this the/a scalar finalizer procedure? */
10327 if (!arg->as || arg->as->rank == 0)
10328 seen_scalar = true;
10330 /* Find the symtree for this procedure. */
10331 gcc_assert (!list->proc_tree);
10332 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10334 prev_link = &list->next;
10337 /* Remove wrong nodes immediately from the list so we don't risk any
10338 troubles in the future when they might fail later expectations. */
10342 *prev_link = list->next;
10343 gfc_free_finalizer (i);
10346 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10347 were nodes in the list, must have been for arrays. It is surely a good
10348 idea to have a scalar version there if there's something to finalize. */
10349 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10350 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10351 " defined at %L, suggest also scalar one",
10352 derived->name, &derived->declared_at);
10354 /* TODO: Remove this error when finalization is finished. */
10355 gfc_error ("Finalization at %L is not yet implemented",
10356 &derived->declared_at);
10362 /* Check that it is ok for the typebound procedure proc to override the
10366 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
10369 const gfc_symbol* proc_target;
10370 const gfc_symbol* old_target;
10371 unsigned proc_pass_arg, old_pass_arg, argpos;
10372 gfc_formal_arglist* proc_formal;
10373 gfc_formal_arglist* old_formal;
10375 /* This procedure should only be called for non-GENERIC proc. */
10376 gcc_assert (!proc->n.tb->is_generic);
10378 /* If the overwritten procedure is GENERIC, this is an error. */
10379 if (old->n.tb->is_generic)
10381 gfc_error ("Can't overwrite GENERIC '%s' at %L",
10382 old->name, &proc->n.tb->where);
10386 where = proc->n.tb->where;
10387 proc_target = proc->n.tb->u.specific->n.sym;
10388 old_target = old->n.tb->u.specific->n.sym;
10390 /* Check that overridden binding is not NON_OVERRIDABLE. */
10391 if (old->n.tb->non_overridable)
10393 gfc_error ("'%s' at %L overrides a procedure binding declared"
10394 " NON_OVERRIDABLE", proc->name, &where);
10398 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
10399 if (!old->n.tb->deferred && proc->n.tb->deferred)
10401 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
10402 " non-DEFERRED binding", proc->name, &where);
10406 /* If the overridden binding is PURE, the overriding must be, too. */
10407 if (old_target->attr.pure && !proc_target->attr.pure)
10409 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
10410 proc->name, &where);
10414 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
10415 is not, the overriding must not be either. */
10416 if (old_target->attr.elemental && !proc_target->attr.elemental)
10418 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
10419 " ELEMENTAL", proc->name, &where);
10422 if (!old_target->attr.elemental && proc_target->attr.elemental)
10424 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
10425 " be ELEMENTAL, either", proc->name, &where);
10429 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
10431 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
10433 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
10434 " SUBROUTINE", proc->name, &where);
10438 /* If the overridden binding is a FUNCTION, the overriding must also be a
10439 FUNCTION and have the same characteristics. */
10440 if (old_target->attr.function)
10442 if (!proc_target->attr.function)
10444 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
10445 " FUNCTION", proc->name, &where);
10449 /* FIXME: Do more comprehensive checking (including, for instance, the
10450 rank and array-shape). */
10451 gcc_assert (proc_target->result && old_target->result);
10452 if (!gfc_compare_types (&proc_target->result->ts,
10453 &old_target->result->ts))
10455 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
10456 " matching result types", proc->name, &where);
10461 /* If the overridden binding is PUBLIC, the overriding one must not be
10463 if (old->n.tb->access == ACCESS_PUBLIC
10464 && proc->n.tb->access == ACCESS_PRIVATE)
10466 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
10467 " PRIVATE", proc->name, &where);
10471 /* Compare the formal argument lists of both procedures. This is also abused
10472 to find the position of the passed-object dummy arguments of both
10473 bindings as at least the overridden one might not yet be resolved and we
10474 need those positions in the check below. */
10475 proc_pass_arg = old_pass_arg = 0;
10476 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
10478 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
10481 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
10482 proc_formal && old_formal;
10483 proc_formal = proc_formal->next, old_formal = old_formal->next)
10485 if (proc->n.tb->pass_arg
10486 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
10487 proc_pass_arg = argpos;
10488 if (old->n.tb->pass_arg
10489 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
10490 old_pass_arg = argpos;
10492 /* Check that the names correspond. */
10493 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
10495 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
10496 " to match the corresponding argument of the overridden"
10497 " procedure", proc_formal->sym->name, proc->name, &where,
10498 old_formal->sym->name);
10502 /* Check that the types correspond if neither is the passed-object
10504 /* FIXME: Do more comprehensive testing here. */
10505 if (proc_pass_arg != argpos && old_pass_arg != argpos
10506 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
10508 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
10509 "in respect to the overridden procedure",
10510 proc_formal->sym->name, proc->name, &where);
10516 if (proc_formal || old_formal)
10518 gfc_error ("'%s' at %L must have the same number of formal arguments as"
10519 " the overridden procedure", proc->name, &where);
10523 /* If the overridden binding is NOPASS, the overriding one must also be
10525 if (old->n.tb->nopass && !proc->n.tb->nopass)
10527 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
10528 " NOPASS", proc->name, &where);
10532 /* If the overridden binding is PASS(x), the overriding one must also be
10533 PASS and the passed-object dummy arguments must correspond. */
10534 if (!old->n.tb->nopass)
10536 if (proc->n.tb->nopass)
10538 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
10539 " PASS", proc->name, &where);
10543 if (proc_pass_arg != old_pass_arg)
10545 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
10546 " the same position as the passed-object dummy argument of"
10547 " the overridden procedure", proc->name, &where);
10556 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10559 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10560 const char* generic_name, locus where)
10565 gcc_assert (t1->specific && t2->specific);
10566 gcc_assert (!t1->specific->is_generic);
10567 gcc_assert (!t2->specific->is_generic);
10569 sym1 = t1->specific->u.specific->n.sym;
10570 sym2 = t2->specific->u.specific->n.sym;
10575 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10576 if (sym1->attr.subroutine != sym2->attr.subroutine
10577 || sym1->attr.function != sym2->attr.function)
10579 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10580 " GENERIC '%s' at %L",
10581 sym1->name, sym2->name, generic_name, &where);
10585 /* Compare the interfaces. */
10586 if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
10588 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10589 sym1->name, sym2->name, generic_name, &where);
10597 /* Worker function for resolving a generic procedure binding; this is used to
10598 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10600 The difference between those cases is finding possible inherited bindings
10601 that are overridden, as one has to look for them in tb_sym_root,
10602 tb_uop_root or tb_op, respectively. Thus the caller must already find
10603 the super-type and set p->overridden correctly. */
10606 resolve_tb_generic_targets (gfc_symbol* super_type,
10607 gfc_typebound_proc* p, const char* name)
10609 gfc_tbp_generic* target;
10610 gfc_symtree* first_target;
10611 gfc_symtree* inherited;
10613 gcc_assert (p && p->is_generic);
10615 /* Try to find the specific bindings for the symtrees in our target-list. */
10616 gcc_assert (p->u.generic);
10617 for (target = p->u.generic; target; target = target->next)
10618 if (!target->specific)
10620 gfc_typebound_proc* overridden_tbp;
10621 gfc_tbp_generic* g;
10622 const char* target_name;
10624 target_name = target->specific_st->name;
10626 /* Defined for this type directly. */
10627 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
10629 target->specific = target->specific_st->n.tb;
10630 goto specific_found;
10633 /* Look for an inherited specific binding. */
10636 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
10641 gcc_assert (inherited->n.tb);
10642 target->specific = inherited->n.tb;
10643 goto specific_found;
10647 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
10648 " at %L", target_name, name, &p->where);
10651 /* Once we've found the specific binding, check it is not ambiguous with
10652 other specifics already found or inherited for the same GENERIC. */
10654 gcc_assert (target->specific);
10656 /* This must really be a specific binding! */
10657 if (target->specific->is_generic)
10659 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
10660 " '%s' is GENERIC, too", name, &p->where, target_name);
10664 /* Check those already resolved on this type directly. */
10665 for (g = p->u.generic; g; g = g->next)
10666 if (g != target && g->specific
10667 && check_generic_tbp_ambiguity (target, g, name, p->where)
10671 /* Check for ambiguity with inherited specific targets. */
10672 for (overridden_tbp = p->overridden; overridden_tbp;
10673 overridden_tbp = overridden_tbp->overridden)
10674 if (overridden_tbp->is_generic)
10676 for (g = overridden_tbp->u.generic; g; g = g->next)
10678 gcc_assert (g->specific);
10679 if (check_generic_tbp_ambiguity (target, g,
10680 name, p->where) == FAILURE)
10686 /* If we attempt to "overwrite" a specific binding, this is an error. */
10687 if (p->overridden && !p->overridden->is_generic)
10689 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
10690 " the same name", name, &p->where);
10694 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
10695 all must have the same attributes here. */
10696 first_target = p->u.generic->specific->u.specific;
10697 gcc_assert (first_target);
10698 p->subroutine = first_target->n.sym->attr.subroutine;
10699 p->function = first_target->n.sym->attr.function;
10705 /* Resolve a GENERIC procedure binding for a derived type. */
10708 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
10710 gfc_symbol* super_type;
10712 /* Find the overridden binding if any. */
10713 st->n.tb->overridden = NULL;
10714 super_type = gfc_get_derived_super_type (derived);
10717 gfc_symtree* overridden;
10718 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
10721 if (overridden && overridden->n.tb)
10722 st->n.tb->overridden = overridden->n.tb;
10725 /* Resolve using worker function. */
10726 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
10730 /* Retrieve the target-procedure of an operator binding and do some checks in
10731 common for intrinsic and user-defined type-bound operators. */
10734 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
10736 gfc_symbol* target_proc;
10738 gcc_assert (target->specific && !target->specific->is_generic);
10739 target_proc = target->specific->u.specific->n.sym;
10740 gcc_assert (target_proc);
10742 /* All operator bindings must have a passed-object dummy argument. */
10743 if (target->specific->nopass)
10745 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
10749 return target_proc;
10753 /* Resolve a type-bound intrinsic operator. */
10756 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
10757 gfc_typebound_proc* p)
10759 gfc_symbol* super_type;
10760 gfc_tbp_generic* target;
10762 /* If there's already an error here, do nothing (but don't fail again). */
10766 /* Operators should always be GENERIC bindings. */
10767 gcc_assert (p->is_generic);
10769 /* Look for an overridden binding. */
10770 super_type = gfc_get_derived_super_type (derived);
10771 if (super_type && super_type->f2k_derived)
10772 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
10775 p->overridden = NULL;
10777 /* Resolve general GENERIC properties using worker function. */
10778 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
10781 /* Check the targets to be procedures of correct interface. */
10782 for (target = p->u.generic; target; target = target->next)
10784 gfc_symbol* target_proc;
10786 target_proc = get_checked_tb_operator_target (target, p->where);
10790 if (!gfc_check_operator_interface (target_proc, op, p->where))
10802 /* Resolve a type-bound user operator (tree-walker callback). */
10804 static gfc_symbol* resolve_bindings_derived;
10805 static gfc_try resolve_bindings_result;
10807 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
10810 resolve_typebound_user_op (gfc_symtree* stree)
10812 gfc_symbol* super_type;
10813 gfc_tbp_generic* target;
10815 gcc_assert (stree && stree->n.tb);
10817 if (stree->n.tb->error)
10820 /* Operators should always be GENERIC bindings. */
10821 gcc_assert (stree->n.tb->is_generic);
10823 /* Find overridden procedure, if any. */
10824 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10825 if (super_type && super_type->f2k_derived)
10827 gfc_symtree* overridden;
10828 overridden = gfc_find_typebound_user_op (super_type, NULL,
10829 stree->name, true, NULL);
10831 if (overridden && overridden->n.tb)
10832 stree->n.tb->overridden = overridden->n.tb;
10835 stree->n.tb->overridden = NULL;
10837 /* Resolve basically using worker function. */
10838 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
10842 /* Check the targets to be functions of correct interface. */
10843 for (target = stree->n.tb->u.generic; target; target = target->next)
10845 gfc_symbol* target_proc;
10847 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
10851 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
10858 resolve_bindings_result = FAILURE;
10859 stree->n.tb->error = 1;
10863 /* Resolve the type-bound procedures for a derived type. */
10866 resolve_typebound_procedure (gfc_symtree* stree)
10870 gfc_symbol* me_arg;
10871 gfc_symbol* super_type;
10872 gfc_component* comp;
10874 gcc_assert (stree);
10876 /* Undefined specific symbol from GENERIC target definition. */
10880 if (stree->n.tb->error)
10883 /* If this is a GENERIC binding, use that routine. */
10884 if (stree->n.tb->is_generic)
10886 if (resolve_typebound_generic (resolve_bindings_derived, stree)
10892 /* Get the target-procedure to check it. */
10893 gcc_assert (!stree->n.tb->is_generic);
10894 gcc_assert (stree->n.tb->u.specific);
10895 proc = stree->n.tb->u.specific->n.sym;
10896 where = stree->n.tb->where;
10898 /* Default access should already be resolved from the parser. */
10899 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
10901 /* It should be a module procedure or an external procedure with explicit
10902 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
10903 if ((!proc->attr.subroutine && !proc->attr.function)
10904 || (proc->attr.proc != PROC_MODULE
10905 && proc->attr.if_source != IFSRC_IFBODY)
10906 || (proc->attr.abstract && !stree->n.tb->deferred))
10908 gfc_error ("'%s' must be a module procedure or an external procedure with"
10909 " an explicit interface at %L", proc->name, &where);
10912 stree->n.tb->subroutine = proc->attr.subroutine;
10913 stree->n.tb->function = proc->attr.function;
10915 /* Find the super-type of the current derived type. We could do this once and
10916 store in a global if speed is needed, but as long as not I believe this is
10917 more readable and clearer. */
10918 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10920 /* If PASS, resolve and check arguments if not already resolved / loaded
10921 from a .mod file. */
10922 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
10924 if (stree->n.tb->pass_arg)
10926 gfc_formal_arglist* i;
10928 /* If an explicit passing argument name is given, walk the arg-list
10929 and look for it. */
10932 stree->n.tb->pass_arg_num = 1;
10933 for (i = proc->formal; i; i = i->next)
10935 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
10940 ++stree->n.tb->pass_arg_num;
10945 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
10947 proc->name, stree->n.tb->pass_arg, &where,
10948 stree->n.tb->pass_arg);
10954 /* Otherwise, take the first one; there should in fact be at least
10956 stree->n.tb->pass_arg_num = 1;
10959 gfc_error ("Procedure '%s' with PASS at %L must have at"
10960 " least one argument", proc->name, &where);
10963 me_arg = proc->formal->sym;
10966 /* Now check that the argument-type matches and the passed-object
10967 dummy argument is generally fine. */
10969 gcc_assert (me_arg);
10971 if (me_arg->ts.type != BT_CLASS)
10973 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
10974 " at %L", proc->name, &where);
10978 if (CLASS_DATA (me_arg)->ts.u.derived
10979 != resolve_bindings_derived)
10981 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
10982 " the derived-type '%s'", me_arg->name, proc->name,
10983 me_arg->name, &where, resolve_bindings_derived->name);
10987 gcc_assert (me_arg->ts.type == BT_CLASS);
10988 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
10990 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
10991 " scalar", proc->name, &where);
10994 if (CLASS_DATA (me_arg)->attr.allocatable)
10996 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
10997 " be ALLOCATABLE", proc->name, &where);
11000 if (CLASS_DATA (me_arg)->attr.class_pointer)
11002 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11003 " be POINTER", proc->name, &where);
11008 /* If we are extending some type, check that we don't override a procedure
11009 flagged NON_OVERRIDABLE. */
11010 stree->n.tb->overridden = NULL;
11013 gfc_symtree* overridden;
11014 overridden = gfc_find_typebound_proc (super_type, NULL,
11015 stree->name, true, NULL);
11017 if (overridden && overridden->n.tb)
11018 stree->n.tb->overridden = overridden->n.tb;
11020 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
11024 /* See if there's a name collision with a component directly in this type. */
11025 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11026 if (!strcmp (comp->name, stree->name))
11028 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11030 stree->name, &where, resolve_bindings_derived->name);
11034 /* Try to find a name collision with an inherited component. */
11035 if (super_type && gfc_find_component (super_type, stree->name, true, true))
11037 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11038 " component of '%s'",
11039 stree->name, &where, resolve_bindings_derived->name);
11043 stree->n.tb->error = 0;
11047 resolve_bindings_result = FAILURE;
11048 stree->n.tb->error = 1;
11053 resolve_typebound_procedures (gfc_symbol* derived)
11057 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11060 resolve_bindings_derived = derived;
11061 resolve_bindings_result = SUCCESS;
11063 /* Make sure the vtab has been generated. */
11064 gfc_find_derived_vtab (derived);
11066 if (derived->f2k_derived->tb_sym_root)
11067 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11068 &resolve_typebound_procedure);
11070 if (derived->f2k_derived->tb_uop_root)
11071 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11072 &resolve_typebound_user_op);
11074 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11076 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11077 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11079 resolve_bindings_result = FAILURE;
11082 return resolve_bindings_result;
11086 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11087 to give all identical derived types the same backend_decl. */
11089 add_dt_to_dt_list (gfc_symbol *derived)
11091 gfc_dt_list *dt_list;
11093 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11094 if (derived == dt_list->derived)
11097 if (dt_list == NULL)
11099 dt_list = gfc_get_dt_list ();
11100 dt_list->next = gfc_derived_types;
11101 dt_list->derived = derived;
11102 gfc_derived_types = dt_list;
11107 /* Ensure that a derived-type is really not abstract, meaning that every
11108 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11111 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11116 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11118 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11121 if (st->n.tb && st->n.tb->deferred)
11123 gfc_symtree* overriding;
11124 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11127 gcc_assert (overriding->n.tb);
11128 if (overriding->n.tb->deferred)
11130 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11131 " '%s' is DEFERRED and not overridden",
11132 sub->name, &sub->declared_at, st->name);
11141 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11143 /* The algorithm used here is to recursively travel up the ancestry of sub
11144 and for each ancestor-type, check all bindings. If any of them is
11145 DEFERRED, look it up starting from sub and see if the found (overriding)
11146 binding is not DEFERRED.
11147 This is not the most efficient way to do this, but it should be ok and is
11148 clearer than something sophisticated. */
11150 gcc_assert (ancestor && !sub->attr.abstract);
11152 if (!ancestor->attr.abstract)
11155 /* Walk bindings of this ancestor. */
11156 if (ancestor->f2k_derived)
11159 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11164 /* Find next ancestor type and recurse on it. */
11165 ancestor = gfc_get_derived_super_type (ancestor);
11167 return ensure_not_abstract (sub, ancestor);
11173 /* Resolve the components of a derived type. */
11176 resolve_fl_derived (gfc_symbol *sym)
11178 gfc_symbol* super_type;
11181 super_type = gfc_get_derived_super_type (sym);
11183 if (sym->attr.is_class && sym->ts.u.derived == NULL)
11185 /* Fix up incomplete CLASS symbols. */
11186 gfc_component *data = gfc_find_component (sym, "$data", true, true);
11187 gfc_component *vptr = gfc_find_component (sym, "$vptr", true, true);
11188 if (vptr->ts.u.derived == NULL)
11190 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
11192 vptr->ts.u.derived = vtab->ts.u.derived;
11197 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11199 gfc_error ("As extending type '%s' at %L has a coarray component, "
11200 "parent type '%s' shall also have one", sym->name,
11201 &sym->declared_at, super_type->name);
11205 /* Ensure the extended type gets resolved before we do. */
11206 if (super_type && resolve_fl_derived (super_type) == FAILURE)
11209 /* An ABSTRACT type must be extensible. */
11210 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11212 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11213 sym->name, &sym->declared_at);
11217 for (c = sym->components; c != NULL; c = c->next)
11220 if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */
11221 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11223 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11224 "deferred shape", c->name, &c->loc);
11229 if (c->attr.codimension && c->ts.type == BT_DERIVED
11230 && c->ts.u.derived->ts.is_iso_c)
11232 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11233 "shall not be a coarray", c->name, &c->loc);
11238 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11239 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11240 || c->attr.allocatable))
11242 gfc_error ("Component '%s' at %L with coarray component "
11243 "shall be a nonpointer, nonallocatable scalar",
11249 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11251 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11252 "is not an array pointer", c->name, &c->loc);
11256 if (c->attr.proc_pointer && c->ts.interface)
11258 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11259 gfc_error ("Interface '%s', used by procedure pointer component "
11260 "'%s' at %L, is declared in a later PROCEDURE statement",
11261 c->ts.interface->name, c->name, &c->loc);
11263 /* Get the attributes from the interface (now resolved). */
11264 if (c->ts.interface->attr.if_source
11265 || c->ts.interface->attr.intrinsic)
11267 gfc_symbol *ifc = c->ts.interface;
11269 if (ifc->formal && !ifc->formal_ns)
11270 resolve_symbol (ifc);
11272 if (ifc->attr.intrinsic)
11273 resolve_intrinsic (ifc, &ifc->declared_at);
11277 c->ts = ifc->result->ts;
11278 c->attr.allocatable = ifc->result->attr.allocatable;
11279 c->attr.pointer = ifc->result->attr.pointer;
11280 c->attr.dimension = ifc->result->attr.dimension;
11281 c->as = gfc_copy_array_spec (ifc->result->as);
11286 c->attr.allocatable = ifc->attr.allocatable;
11287 c->attr.pointer = ifc->attr.pointer;
11288 c->attr.dimension = ifc->attr.dimension;
11289 c->as = gfc_copy_array_spec (ifc->as);
11291 c->ts.interface = ifc;
11292 c->attr.function = ifc->attr.function;
11293 c->attr.subroutine = ifc->attr.subroutine;
11294 gfc_copy_formal_args_ppc (c, ifc);
11296 c->attr.pure = ifc->attr.pure;
11297 c->attr.elemental = ifc->attr.elemental;
11298 c->attr.recursive = ifc->attr.recursive;
11299 c->attr.always_explicit = ifc->attr.always_explicit;
11300 c->attr.ext_attr |= ifc->attr.ext_attr;
11301 /* Replace symbols in array spec. */
11305 for (i = 0; i < c->as->rank; i++)
11307 gfc_expr_replace_comp (c->as->lower[i], c);
11308 gfc_expr_replace_comp (c->as->upper[i], c);
11311 /* Copy char length. */
11312 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11314 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11315 gfc_expr_replace_comp (cl->length, c);
11316 if (cl->length && !cl->resolved
11317 && gfc_resolve_expr (cl->length) == FAILURE)
11322 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11324 gfc_error ("Interface '%s' of procedure pointer component "
11325 "'%s' at %L must be explicit", c->ts.interface->name,
11330 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11332 /* Since PPCs are not implicitly typed, a PPC without an explicit
11333 interface must be a subroutine. */
11334 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11337 /* Procedure pointer components: Check PASS arg. */
11338 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11339 && !sym->attr.vtype)
11341 gfc_symbol* me_arg;
11343 if (c->tb->pass_arg)
11345 gfc_formal_arglist* i;
11347 /* If an explicit passing argument name is given, walk the arg-list
11348 and look for it. */
11351 c->tb->pass_arg_num = 1;
11352 for (i = c->formal; i; i = i->next)
11354 if (!strcmp (i->sym->name, c->tb->pass_arg))
11359 c->tb->pass_arg_num++;
11364 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11365 "at %L has no argument '%s'", c->name,
11366 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11373 /* Otherwise, take the first one; there should in fact be at least
11375 c->tb->pass_arg_num = 1;
11378 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11379 "must have at least one argument",
11384 me_arg = c->formal->sym;
11387 /* Now check that the argument-type matches. */
11388 gcc_assert (me_arg);
11389 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11390 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11391 || (me_arg->ts.type == BT_CLASS
11392 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11394 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11395 " the derived type '%s'", me_arg->name, c->name,
11396 me_arg->name, &c->loc, sym->name);
11401 /* Check for C453. */
11402 if (me_arg->attr.dimension)
11404 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11405 "must be scalar", me_arg->name, c->name, me_arg->name,
11411 if (me_arg->attr.pointer)
11413 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11414 "may not have the POINTER attribute", me_arg->name,
11415 c->name, me_arg->name, &c->loc);
11420 if (me_arg->attr.allocatable)
11422 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11423 "may not be ALLOCATABLE", me_arg->name, c->name,
11424 me_arg->name, &c->loc);
11429 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11430 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11431 " at %L", c->name, &c->loc);
11435 /* Check type-spec if this is not the parent-type component. */
11436 if ((!sym->attr.extension || c != sym->components) && !sym->attr.vtype
11437 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11440 /* If this type is an extension, set the accessibility of the parent
11442 if (super_type && c == sym->components
11443 && strcmp (super_type->name, c->name) == 0)
11444 c->attr.access = super_type->attr.access;
11446 /* If this type is an extension, see if this component has the same name
11447 as an inherited type-bound procedure. */
11448 if (super_type && !sym->attr.is_class
11449 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11451 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11452 " inherited type-bound procedure",
11453 c->name, sym->name, &c->loc);
11457 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
11459 if (c->ts.u.cl->length == NULL
11460 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11461 || !gfc_is_constant_expr (c->ts.u.cl->length))
11463 gfc_error ("Character length of component '%s' needs to "
11464 "be a constant specification expression at %L",
11466 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11471 if (c->ts.type == BT_DERIVED
11472 && sym->component_access != ACCESS_PRIVATE
11473 && gfc_check_access (sym->attr.access, sym->ns->default_access)
11474 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11475 && !c->ts.u.derived->attr.use_assoc
11476 && !gfc_check_access (c->ts.u.derived->attr.access,
11477 c->ts.u.derived->ns->default_access)
11478 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11479 "is a PRIVATE type and cannot be a component of "
11480 "'%s', which is PUBLIC at %L", c->name,
11481 sym->name, &sym->declared_at) == FAILURE)
11484 if (sym->attr.sequence)
11486 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11488 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11489 "not have the SEQUENCE attribute",
11490 c->ts.u.derived->name, &sym->declared_at);
11495 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
11496 && c->attr.pointer && c->ts.u.derived->components == NULL
11497 && !c->ts.u.derived->attr.zero_comp)
11499 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11500 "that has not been declared", c->name, sym->name,
11505 if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer
11506 && CLASS_DATA (c)->ts.u.derived->components == NULL
11507 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11509 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11510 "that has not been declared", c->name, sym->name,
11516 if (c->ts.type == BT_CLASS
11517 && !(CLASS_DATA (c)->attr.class_pointer
11518 || CLASS_DATA (c)->attr.allocatable))
11520 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11521 "or pointer", c->name, &c->loc);
11525 /* Ensure that all the derived type components are put on the
11526 derived type list; even in formal namespaces, where derived type
11527 pointer components might not have been declared. */
11528 if (c->ts.type == BT_DERIVED
11530 && c->ts.u.derived->components
11532 && sym != c->ts.u.derived)
11533 add_dt_to_dt_list (c->ts.u.derived);
11535 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11536 || c->attr.proc_pointer
11537 || c->attr.allocatable)) == FAILURE)
11541 /* Resolve the type-bound procedures. */
11542 if (resolve_typebound_procedures (sym) == FAILURE)
11545 /* Resolve the finalizer procedures. */
11546 if (gfc_resolve_finalizers (sym) == FAILURE)
11549 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11550 all DEFERRED bindings are overridden. */
11551 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11552 && !sym->attr.is_class
11553 && ensure_not_abstract (sym, super_type) == FAILURE)
11556 /* Add derived type to the derived type list. */
11557 add_dt_to_dt_list (sym);
11564 resolve_fl_namelist (gfc_symbol *sym)
11569 for (nl = sym->namelist; nl; nl = nl->next)
11571 /* Reject namelist arrays of assumed shape. */
11572 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
11573 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
11574 "must not have assumed shape in namelist "
11575 "'%s' at %L", nl->sym->name, sym->name,
11576 &sym->declared_at) == FAILURE)
11579 /* Reject namelist arrays that are not constant shape. */
11580 if (is_non_constant_shape_array (nl->sym))
11582 gfc_error ("NAMELIST array object '%s' must have constant "
11583 "shape in namelist '%s' at %L", nl->sym->name,
11584 sym->name, &sym->declared_at);
11588 /* Namelist objects cannot have allocatable or pointer components. */
11589 if (nl->sym->ts.type != BT_DERIVED)
11592 if (nl->sym->ts.u.derived->attr.alloc_comp)
11594 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11595 "have ALLOCATABLE components",
11596 nl->sym->name, sym->name, &sym->declared_at);
11600 if (nl->sym->ts.u.derived->attr.pointer_comp)
11602 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11603 "have POINTER components",
11604 nl->sym->name, sym->name, &sym->declared_at);
11609 /* Reject PRIVATE objects in a PUBLIC namelist. */
11610 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
11612 for (nl = sym->namelist; nl; nl = nl->next)
11614 if (!nl->sym->attr.use_assoc
11615 && !is_sym_host_assoc (nl->sym, sym->ns)
11616 && !gfc_check_access(nl->sym->attr.access,
11617 nl->sym->ns->default_access))
11619 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
11620 "cannot be member of PUBLIC namelist '%s' at %L",
11621 nl->sym->name, sym->name, &sym->declared_at);
11625 /* Types with private components that came here by USE-association. */
11626 if (nl->sym->ts.type == BT_DERIVED
11627 && derived_inaccessible (nl->sym->ts.u.derived))
11629 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
11630 "components and cannot be member of namelist '%s' at %L",
11631 nl->sym->name, sym->name, &sym->declared_at);
11635 /* Types with private components that are defined in the same module. */
11636 if (nl->sym->ts.type == BT_DERIVED
11637 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
11638 && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
11639 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
11640 nl->sym->ns->default_access))
11642 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
11643 "cannot be a member of PUBLIC namelist '%s' at %L",
11644 nl->sym->name, sym->name, &sym->declared_at);
11651 /* 14.1.2 A module or internal procedure represent local entities
11652 of the same type as a namelist member and so are not allowed. */
11653 for (nl = sym->namelist; nl; nl = nl->next)
11655 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
11658 if (nl->sym->attr.function && nl->sym == nl->sym->result)
11659 if ((nl->sym == sym->ns->proc_name)
11661 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
11665 if (nl->sym && nl->sym->name)
11666 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
11667 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
11669 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
11670 "attribute in '%s' at %L", nlsym->name,
11671 &sym->declared_at);
11681 resolve_fl_parameter (gfc_symbol *sym)
11683 /* A parameter array's shape needs to be constant. */
11684 if (sym->as != NULL
11685 && (sym->as->type == AS_DEFERRED
11686 || is_non_constant_shape_array (sym)))
11688 gfc_error ("Parameter array '%s' at %L cannot be automatic "
11689 "or of deferred shape", sym->name, &sym->declared_at);
11693 /* Make sure a parameter that has been implicitly typed still
11694 matches the implicit type, since PARAMETER statements can precede
11695 IMPLICIT statements. */
11696 if (sym->attr.implicit_type
11697 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
11700 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
11701 "later IMPLICIT type", sym->name, &sym->declared_at);
11705 /* Make sure the types of derived parameters are consistent. This
11706 type checking is deferred until resolution because the type may
11707 refer to a derived type from the host. */
11708 if (sym->ts.type == BT_DERIVED
11709 && !gfc_compare_types (&sym->ts, &sym->value->ts))
11711 gfc_error ("Incompatible derived type in PARAMETER at %L",
11712 &sym->value->where);
11719 /* Do anything necessary to resolve a symbol. Right now, we just
11720 assume that an otherwise unknown symbol is a variable. This sort
11721 of thing commonly happens for symbols in module. */
11724 resolve_symbol (gfc_symbol *sym)
11726 int check_constant, mp_flag;
11727 gfc_symtree *symtree;
11728 gfc_symtree *this_symtree;
11732 /* Avoid double resolution of function result symbols. */
11733 if ((sym->result || sym->attr.result) && !sym->attr.dummy
11734 && (sym->ns != gfc_current_ns))
11737 if (sym->attr.flavor == FL_UNKNOWN)
11740 /* If we find that a flavorless symbol is an interface in one of the
11741 parent namespaces, find its symtree in this namespace, free the
11742 symbol and set the symtree to point to the interface symbol. */
11743 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
11745 symtree = gfc_find_symtree (ns->sym_root, sym->name);
11746 if (symtree && symtree->n.sym->generic)
11748 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
11750 gfc_release_symbol (sym);
11751 symtree->n.sym->refs++;
11752 this_symtree->n.sym = symtree->n.sym;
11757 /* Otherwise give it a flavor according to such attributes as
11759 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
11760 sym->attr.flavor = FL_VARIABLE;
11763 sym->attr.flavor = FL_PROCEDURE;
11764 if (sym->attr.dimension)
11765 sym->attr.function = 1;
11769 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
11770 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
11772 if (sym->attr.procedure && sym->ts.interface
11773 && sym->attr.if_source != IFSRC_DECL
11774 && resolve_procedure_interface (sym) == FAILURE)
11777 if (sym->attr.is_protected && !sym->attr.proc_pointer
11778 && (sym->attr.procedure || sym->attr.external))
11780 if (sym->attr.external)
11781 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
11782 "at %L", &sym->declared_at);
11784 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
11785 "at %L", &sym->declared_at);
11792 if (sym->attr.contiguous
11793 && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE
11794 && !sym->attr.pointer)))
11796 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
11797 "array pointer or an assumed-shape array", sym->name,
11798 &sym->declared_at);
11802 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
11805 /* Symbols that are module procedures with results (functions) have
11806 the types and array specification copied for type checking in
11807 procedures that call them, as well as for saving to a module
11808 file. These symbols can't stand the scrutiny that their results
11810 mp_flag = (sym->result != NULL && sym->result != sym);
11812 /* Make sure that the intrinsic is consistent with its internal
11813 representation. This needs to be done before assigning a default
11814 type to avoid spurious warnings. */
11815 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
11816 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
11819 /* Resolve associate names. */
11821 resolve_assoc_var (sym, true);
11823 /* Assign default type to symbols that need one and don't have one. */
11824 if (sym->ts.type == BT_UNKNOWN)
11826 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
11827 gfc_set_default_type (sym, 1, NULL);
11829 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
11830 && !sym->attr.function && !sym->attr.subroutine
11831 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
11832 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
11834 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
11836 /* The specific case of an external procedure should emit an error
11837 in the case that there is no implicit type. */
11839 gfc_set_default_type (sym, sym->attr.external, NULL);
11842 /* Result may be in another namespace. */
11843 resolve_symbol (sym->result);
11845 if (!sym->result->attr.proc_pointer)
11847 sym->ts = sym->result->ts;
11848 sym->as = gfc_copy_array_spec (sym->result->as);
11849 sym->attr.dimension = sym->result->attr.dimension;
11850 sym->attr.pointer = sym->result->attr.pointer;
11851 sym->attr.allocatable = sym->result->attr.allocatable;
11852 sym->attr.contiguous = sym->result->attr.contiguous;
11858 /* Assumed size arrays and assumed shape arrays must be dummy
11859 arguments. Array-spec's of implied-shape should have been resolved to
11860 AS_EXPLICIT already. */
11864 gcc_assert (sym->as->type != AS_IMPLIED_SHAPE);
11865 if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
11866 || sym->as->type == AS_ASSUMED_SHAPE)
11867 && sym->attr.dummy == 0)
11869 if (sym->as->type == AS_ASSUMED_SIZE)
11870 gfc_error ("Assumed size array at %L must be a dummy argument",
11871 &sym->declared_at);
11873 gfc_error ("Assumed shape array at %L must be a dummy argument",
11874 &sym->declared_at);
11879 /* Make sure symbols with known intent or optional are really dummy
11880 variable. Because of ENTRY statement, this has to be deferred
11881 until resolution time. */
11883 if (!sym->attr.dummy
11884 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
11886 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
11890 if (sym->attr.value && !sym->attr.dummy)
11892 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
11893 "it is not a dummy argument", sym->name, &sym->declared_at);
11897 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
11899 gfc_charlen *cl = sym->ts.u.cl;
11900 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
11902 gfc_error ("Character dummy variable '%s' at %L with VALUE "
11903 "attribute must have constant length",
11904 sym->name, &sym->declared_at);
11908 if (sym->ts.is_c_interop
11909 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
11911 gfc_error ("C interoperable character dummy variable '%s' at %L "
11912 "with VALUE attribute must have length one",
11913 sym->name, &sym->declared_at);
11918 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
11919 do this for something that was implicitly typed because that is handled
11920 in gfc_set_default_type. Handle dummy arguments and procedure
11921 definitions separately. Also, anything that is use associated is not
11922 handled here but instead is handled in the module it is declared in.
11923 Finally, derived type definitions are allowed to be BIND(C) since that
11924 only implies that they're interoperable, and they are checked fully for
11925 interoperability when a variable is declared of that type. */
11926 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
11927 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
11928 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
11930 gfc_try t = SUCCESS;
11932 /* First, make sure the variable is declared at the
11933 module-level scope (J3/04-007, Section 15.3). */
11934 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
11935 sym->attr.in_common == 0)
11937 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
11938 "is neither a COMMON block nor declared at the "
11939 "module level scope", sym->name, &(sym->declared_at));
11942 else if (sym->common_head != NULL)
11944 t = verify_com_block_vars_c_interop (sym->common_head);
11948 /* If type() declaration, we need to verify that the components
11949 of the given type are all C interoperable, etc. */
11950 if (sym->ts.type == BT_DERIVED &&
11951 sym->ts.u.derived->attr.is_c_interop != 1)
11953 /* Make sure the user marked the derived type as BIND(C). If
11954 not, call the verify routine. This could print an error
11955 for the derived type more than once if multiple variables
11956 of that type are declared. */
11957 if (sym->ts.u.derived->attr.is_bind_c != 1)
11958 verify_bind_c_derived_type (sym->ts.u.derived);
11962 /* Verify the variable itself as C interoperable if it
11963 is BIND(C). It is not possible for this to succeed if
11964 the verify_bind_c_derived_type failed, so don't have to handle
11965 any error returned by verify_bind_c_derived_type. */
11966 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
11967 sym->common_block);
11972 /* clear the is_bind_c flag to prevent reporting errors more than
11973 once if something failed. */
11974 sym->attr.is_bind_c = 0;
11979 /* If a derived type symbol has reached this point, without its
11980 type being declared, we have an error. Notice that most
11981 conditions that produce undefined derived types have already
11982 been dealt with. However, the likes of:
11983 implicit type(t) (t) ..... call foo (t) will get us here if
11984 the type is not declared in the scope of the implicit
11985 statement. Change the type to BT_UNKNOWN, both because it is so
11986 and to prevent an ICE. */
11987 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
11988 && !sym->ts.u.derived->attr.zero_comp)
11990 gfc_error ("The derived type '%s' at %L is of type '%s', "
11991 "which has not been defined", sym->name,
11992 &sym->declared_at, sym->ts.u.derived->name);
11993 sym->ts.type = BT_UNKNOWN;
11997 /* Make sure that the derived type has been resolved and that the
11998 derived type is visible in the symbol's namespace, if it is a
11999 module function and is not PRIVATE. */
12000 if (sym->ts.type == BT_DERIVED
12001 && sym->ts.u.derived->attr.use_assoc
12002 && sym->ns->proc_name
12003 && sym->ns->proc_name->attr.flavor == FL_MODULE)
12007 if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
12010 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
12011 if (!ds && sym->attr.function
12012 && gfc_check_access (sym->attr.access, sym->ns->default_access))
12014 symtree = gfc_new_symtree (&sym->ns->sym_root,
12015 sym->ts.u.derived->name);
12016 symtree->n.sym = sym->ts.u.derived;
12017 sym->ts.u.derived->refs++;
12021 /* Unless the derived-type declaration is use associated, Fortran 95
12022 does not allow public entries of private derived types.
12023 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12024 161 in 95-006r3. */
12025 if (sym->ts.type == BT_DERIVED
12026 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12027 && !sym->ts.u.derived->attr.use_assoc
12028 && gfc_check_access (sym->attr.access, sym->ns->default_access)
12029 && !gfc_check_access (sym->ts.u.derived->attr.access,
12030 sym->ts.u.derived->ns->default_access)
12031 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12032 "of PRIVATE derived type '%s'",
12033 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12034 : "variable", sym->name, &sym->declared_at,
12035 sym->ts.u.derived->name) == FAILURE)
12038 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12039 default initialization is defined (5.1.2.4.4). */
12040 if (sym->ts.type == BT_DERIVED
12042 && sym->attr.intent == INTENT_OUT
12044 && sym->as->type == AS_ASSUMED_SIZE)
12046 for (c = sym->ts.u.derived->components; c; c = c->next)
12048 if (c->initializer)
12050 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12051 "ASSUMED SIZE and so cannot have a default initializer",
12052 sym->name, &sym->declared_at);
12059 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12060 || sym->attr.codimension)
12061 && sym->attr.result)
12062 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12063 "a coarray component", sym->name, &sym->declared_at);
12066 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12067 && sym->ts.u.derived->ts.is_iso_c)
12068 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12069 "shall not be a coarray", sym->name, &sym->declared_at);
12072 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
12073 && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
12074 || sym->attr.allocatable))
12075 gfc_error ("Variable '%s' at %L with coarray component "
12076 "shall be a nonpointer, nonallocatable scalar",
12077 sym->name, &sym->declared_at);
12079 /* F2008, C526. The function-result case was handled above. */
12080 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12081 || sym->attr.codimension)
12082 && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
12083 || sym->ns->proc_name->attr.flavor == FL_MODULE
12084 || sym->ns->proc_name->attr.is_main_program
12085 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12086 gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
12087 "component and is not ALLOCATABLE, SAVE nor a "
12088 "dummy argument", sym->name, &sym->declared_at);
12089 /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
12090 else if (sym->attr.codimension && !sym->attr.allocatable
12091 && sym->as && sym->as->cotype == AS_DEFERRED)
12092 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12093 "deferred shape", sym->name, &sym->declared_at);
12094 else if (sym->attr.codimension && sym->attr.allocatable
12095 && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
12096 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12097 "deferred shape", sym->name, &sym->declared_at);
12101 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12102 || (sym->attr.codimension && sym->attr.allocatable))
12103 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12104 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12105 "allocatable coarray or have coarray components",
12106 sym->name, &sym->declared_at);
12108 if (sym->attr.codimension && sym->attr.dummy
12109 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12110 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12111 "procedure '%s'", sym->name, &sym->declared_at,
12112 sym->ns->proc_name->name);
12114 switch (sym->attr.flavor)
12117 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12122 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12127 if (resolve_fl_namelist (sym) == FAILURE)
12132 if (resolve_fl_parameter (sym) == FAILURE)
12140 /* Resolve array specifier. Check as well some constraints
12141 on COMMON blocks. */
12143 check_constant = sym->attr.in_common && !sym->attr.pointer;
12145 /* Set the formal_arg_flag so that check_conflict will not throw
12146 an error for host associated variables in the specification
12147 expression for an array_valued function. */
12148 if (sym->attr.function && sym->as)
12149 formal_arg_flag = 1;
12151 gfc_resolve_array_spec (sym->as, check_constant);
12153 formal_arg_flag = 0;
12155 /* Resolve formal namespaces. */
12156 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12157 && !sym->attr.contained && !sym->attr.intrinsic)
12158 gfc_resolve (sym->formal_ns);
12160 /* Make sure the formal namespace is present. */
12161 if (sym->formal && !sym->formal_ns)
12163 gfc_formal_arglist *formal = sym->formal;
12164 while (formal && !formal->sym)
12165 formal = formal->next;
12169 sym->formal_ns = formal->sym->ns;
12170 sym->formal_ns->refs++;
12174 /* Check threadprivate restrictions. */
12175 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12176 && (!sym->attr.in_common
12177 && sym->module == NULL
12178 && (sym->ns->proc_name == NULL
12179 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12180 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12182 /* If we have come this far we can apply default-initializers, as
12183 described in 14.7.5, to those variables that have not already
12184 been assigned one. */
12185 if (sym->ts.type == BT_DERIVED
12186 && sym->ns == gfc_current_ns
12188 && !sym->attr.allocatable
12189 && !sym->attr.alloc_comp)
12191 symbol_attribute *a = &sym->attr;
12193 if ((!a->save && !a->dummy && !a->pointer
12194 && !a->in_common && !a->use_assoc
12195 && (a->referenced || a->result)
12196 && !(a->function && sym != sym->result))
12197 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12198 apply_default_init (sym);
12201 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
12202 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
12203 && !CLASS_DATA (sym)->attr.class_pointer
12204 && !CLASS_DATA (sym)->attr.allocatable)
12205 apply_default_init (sym);
12207 /* If this symbol has a type-spec, check it. */
12208 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12209 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12210 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12216 /************* Resolve DATA statements *************/
12220 gfc_data_value *vnode;
12226 /* Advance the values structure to point to the next value in the data list. */
12229 next_data_value (void)
12231 while (mpz_cmp_ui (values.left, 0) == 0)
12234 if (values.vnode->next == NULL)
12237 values.vnode = values.vnode->next;
12238 mpz_set (values.left, values.vnode->repeat);
12246 check_data_variable (gfc_data_variable *var, locus *where)
12252 ar_type mark = AR_UNKNOWN;
12254 mpz_t section_index[GFC_MAX_DIMENSIONS];
12260 if (gfc_resolve_expr (var->expr) == FAILURE)
12264 mpz_init_set_si (offset, 0);
12267 if (e->expr_type != EXPR_VARIABLE)
12268 gfc_internal_error ("check_data_variable(): Bad expression");
12270 sym = e->symtree->n.sym;
12272 if (sym->ns->is_block_data && !sym->attr.in_common)
12274 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12275 sym->name, &sym->declared_at);
12278 if (e->ref == NULL && sym->as)
12280 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12281 " declaration", sym->name, where);
12285 has_pointer = sym->attr.pointer;
12287 for (ref = e->ref; ref; ref = ref->next)
12289 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12292 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
12294 gfc_error ("DATA element '%s' at %L cannot have a coindex",
12300 && ref->type == REF_ARRAY
12301 && ref->u.ar.type != AR_FULL)
12303 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12304 "be a full array", sym->name, where);
12309 if (e->rank == 0 || has_pointer)
12311 mpz_init_set_ui (size, 1);
12318 /* Find the array section reference. */
12319 for (ref = e->ref; ref; ref = ref->next)
12321 if (ref->type != REF_ARRAY)
12323 if (ref->u.ar.type == AR_ELEMENT)
12329 /* Set marks according to the reference pattern. */
12330 switch (ref->u.ar.type)
12338 /* Get the start position of array section. */
12339 gfc_get_section_index (ar, section_index, &offset);
12344 gcc_unreachable ();
12347 if (gfc_array_size (e, &size) == FAILURE)
12349 gfc_error ("Nonconstant array section at %L in DATA statement",
12351 mpz_clear (offset);
12358 while (mpz_cmp_ui (size, 0) > 0)
12360 if (next_data_value () == FAILURE)
12362 gfc_error ("DATA statement at %L has more variables than values",
12368 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12372 /* If we have more than one element left in the repeat count,
12373 and we have more than one element left in the target variable,
12374 then create a range assignment. */
12375 /* FIXME: Only done for full arrays for now, since array sections
12377 if (mark == AR_FULL && ref && ref->next == NULL
12378 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12382 if (mpz_cmp (size, values.left) >= 0)
12384 mpz_init_set (range, values.left);
12385 mpz_sub (size, size, values.left);
12386 mpz_set_ui (values.left, 0);
12390 mpz_init_set (range, size);
12391 mpz_sub (values.left, values.left, size);
12392 mpz_set_ui (size, 0);
12395 t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
12398 mpz_add (offset, offset, range);
12405 /* Assign initial value to symbol. */
12408 mpz_sub_ui (values.left, values.left, 1);
12409 mpz_sub_ui (size, size, 1);
12411 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
12415 if (mark == AR_FULL)
12416 mpz_add_ui (offset, offset, 1);
12418 /* Modify the array section indexes and recalculate the offset
12419 for next element. */
12420 else if (mark == AR_SECTION)
12421 gfc_advance_section (section_index, ar, &offset);
12425 if (mark == AR_SECTION)
12427 for (i = 0; i < ar->dimen; i++)
12428 mpz_clear (section_index[i]);
12432 mpz_clear (offset);
12438 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
12440 /* Iterate over a list of elements in a DATA statement. */
12443 traverse_data_list (gfc_data_variable *var, locus *where)
12446 iterator_stack frame;
12447 gfc_expr *e, *start, *end, *step;
12448 gfc_try retval = SUCCESS;
12450 mpz_init (frame.value);
12453 start = gfc_copy_expr (var->iter.start);
12454 end = gfc_copy_expr (var->iter.end);
12455 step = gfc_copy_expr (var->iter.step);
12457 if (gfc_simplify_expr (start, 1) == FAILURE
12458 || start->expr_type != EXPR_CONSTANT)
12460 gfc_error ("start of implied-do loop at %L could not be "
12461 "simplified to a constant value", &start->where);
12465 if (gfc_simplify_expr (end, 1) == FAILURE
12466 || end->expr_type != EXPR_CONSTANT)
12468 gfc_error ("end of implied-do loop at %L could not be "
12469 "simplified to a constant value", &start->where);
12473 if (gfc_simplify_expr (step, 1) == FAILURE
12474 || step->expr_type != EXPR_CONSTANT)
12476 gfc_error ("step of implied-do loop at %L could not be "
12477 "simplified to a constant value", &start->where);
12482 mpz_set (trip, end->value.integer);
12483 mpz_sub (trip, trip, start->value.integer);
12484 mpz_add (trip, trip, step->value.integer);
12486 mpz_div (trip, trip, step->value.integer);
12488 mpz_set (frame.value, start->value.integer);
12490 frame.prev = iter_stack;
12491 frame.variable = var->iter.var->symtree;
12492 iter_stack = &frame;
12494 while (mpz_cmp_ui (trip, 0) > 0)
12496 if (traverse_data_var (var->list, where) == FAILURE)
12502 e = gfc_copy_expr (var->expr);
12503 if (gfc_simplify_expr (e, 1) == FAILURE)
12510 mpz_add (frame.value, frame.value, step->value.integer);
12512 mpz_sub_ui (trip, trip, 1);
12516 mpz_clear (frame.value);
12519 gfc_free_expr (start);
12520 gfc_free_expr (end);
12521 gfc_free_expr (step);
12523 iter_stack = frame.prev;
12528 /* Type resolve variables in the variable list of a DATA statement. */
12531 traverse_data_var (gfc_data_variable *var, locus *where)
12535 for (; var; var = var->next)
12537 if (var->expr == NULL)
12538 t = traverse_data_list (var, where);
12540 t = check_data_variable (var, where);
12550 /* Resolve the expressions and iterators associated with a data statement.
12551 This is separate from the assignment checking because data lists should
12552 only be resolved once. */
12555 resolve_data_variables (gfc_data_variable *d)
12557 for (; d; d = d->next)
12559 if (d->list == NULL)
12561 if (gfc_resolve_expr (d->expr) == FAILURE)
12566 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
12569 if (resolve_data_variables (d->list) == FAILURE)
12578 /* Resolve a single DATA statement. We implement this by storing a pointer to
12579 the value list into static variables, and then recursively traversing the
12580 variables list, expanding iterators and such. */
12583 resolve_data (gfc_data *d)
12586 if (resolve_data_variables (d->var) == FAILURE)
12589 values.vnode = d->value;
12590 if (d->value == NULL)
12591 mpz_set_ui (values.left, 0);
12593 mpz_set (values.left, d->value->repeat);
12595 if (traverse_data_var (d->var, &d->where) == FAILURE)
12598 /* At this point, we better not have any values left. */
12600 if (next_data_value () == SUCCESS)
12601 gfc_error ("DATA statement at %L has more values than variables",
12606 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
12607 accessed by host or use association, is a dummy argument to a pure function,
12608 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
12609 is storage associated with any such variable, shall not be used in the
12610 following contexts: (clients of this function). */
12612 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
12613 procedure. Returns zero if assignment is OK, nonzero if there is a
12616 gfc_impure_variable (gfc_symbol *sym)
12621 if (sym->attr.use_assoc || sym->attr.in_common)
12624 /* Check if the symbol's ns is inside the pure procedure. */
12625 for (ns = gfc_current_ns; ns; ns = ns->parent)
12629 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
12633 proc = sym->ns->proc_name;
12634 if (sym->attr.dummy && gfc_pure (proc)
12635 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
12637 proc->attr.function))
12640 /* TODO: Sort out what can be storage associated, if anything, and include
12641 it here. In principle equivalences should be scanned but it does not
12642 seem to be possible to storage associate an impure variable this way. */
12647 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
12648 current namespace is inside a pure procedure. */
12651 gfc_pure (gfc_symbol *sym)
12653 symbol_attribute attr;
12658 /* Check if the current namespace or one of its parents
12659 belongs to a pure procedure. */
12660 for (ns = gfc_current_ns; ns; ns = ns->parent)
12662 sym = ns->proc_name;
12666 if (attr.flavor == FL_PROCEDURE && attr.pure)
12674 return attr.flavor == FL_PROCEDURE && attr.pure;
12678 /* Test whether the current procedure is elemental or not. */
12681 gfc_elemental (gfc_symbol *sym)
12683 symbol_attribute attr;
12686 sym = gfc_current_ns->proc_name;
12691 return attr.flavor == FL_PROCEDURE && attr.elemental;
12695 /* Warn about unused labels. */
12698 warn_unused_fortran_label (gfc_st_label *label)
12703 warn_unused_fortran_label (label->left);
12705 if (label->defined == ST_LABEL_UNKNOWN)
12708 switch (label->referenced)
12710 case ST_LABEL_UNKNOWN:
12711 gfc_warning ("Label %d at %L defined but not used", label->value,
12715 case ST_LABEL_BAD_TARGET:
12716 gfc_warning ("Label %d at %L defined but cannot be used",
12717 label->value, &label->where);
12724 warn_unused_fortran_label (label->right);
12728 /* Returns the sequence type of a symbol or sequence. */
12731 sequence_type (gfc_typespec ts)
12740 if (ts.u.derived->components == NULL)
12741 return SEQ_NONDEFAULT;
12743 result = sequence_type (ts.u.derived->components->ts);
12744 for (c = ts.u.derived->components->next; c; c = c->next)
12745 if (sequence_type (c->ts) != result)
12751 if (ts.kind != gfc_default_character_kind)
12752 return SEQ_NONDEFAULT;
12754 return SEQ_CHARACTER;
12757 if (ts.kind != gfc_default_integer_kind)
12758 return SEQ_NONDEFAULT;
12760 return SEQ_NUMERIC;
12763 if (!(ts.kind == gfc_default_real_kind
12764 || ts.kind == gfc_default_double_kind))
12765 return SEQ_NONDEFAULT;
12767 return SEQ_NUMERIC;
12770 if (ts.kind != gfc_default_complex_kind)
12771 return SEQ_NONDEFAULT;
12773 return SEQ_NUMERIC;
12776 if (ts.kind != gfc_default_logical_kind)
12777 return SEQ_NONDEFAULT;
12779 return SEQ_NUMERIC;
12782 return SEQ_NONDEFAULT;
12787 /* Resolve derived type EQUIVALENCE object. */
12790 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
12792 gfc_component *c = derived->components;
12797 /* Shall not be an object of nonsequence derived type. */
12798 if (!derived->attr.sequence)
12800 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
12801 "attribute to be an EQUIVALENCE object", sym->name,
12806 /* Shall not have allocatable components. */
12807 if (derived->attr.alloc_comp)
12809 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
12810 "components to be an EQUIVALENCE object",sym->name,
12815 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
12817 gfc_error ("Derived type variable '%s' at %L with default "
12818 "initialization cannot be in EQUIVALENCE with a variable "
12819 "in COMMON", sym->name, &e->where);
12823 for (; c ; c = c->next)
12825 if (c->ts.type == BT_DERIVED
12826 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
12829 /* Shall not be an object of sequence derived type containing a pointer
12830 in the structure. */
12831 if (c->attr.pointer)
12833 gfc_error ("Derived type variable '%s' at %L with pointer "
12834 "component(s) cannot be an EQUIVALENCE object",
12835 sym->name, &e->where);
12843 /* Resolve equivalence object.
12844 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
12845 an allocatable array, an object of nonsequence derived type, an object of
12846 sequence derived type containing a pointer at any level of component
12847 selection, an automatic object, a function name, an entry name, a result
12848 name, a named constant, a structure component, or a subobject of any of
12849 the preceding objects. A substring shall not have length zero. A
12850 derived type shall not have components with default initialization nor
12851 shall two objects of an equivalence group be initialized.
12852 Either all or none of the objects shall have an protected attribute.
12853 The simple constraints are done in symbol.c(check_conflict) and the rest
12854 are implemented here. */
12857 resolve_equivalence (gfc_equiv *eq)
12860 gfc_symbol *first_sym;
12863 locus *last_where = NULL;
12864 seq_type eq_type, last_eq_type;
12865 gfc_typespec *last_ts;
12866 int object, cnt_protected;
12869 last_ts = &eq->expr->symtree->n.sym->ts;
12871 first_sym = eq->expr->symtree->n.sym;
12875 for (object = 1; eq; eq = eq->eq, object++)
12879 e->ts = e->symtree->n.sym->ts;
12880 /* match_varspec might not know yet if it is seeing
12881 array reference or substring reference, as it doesn't
12883 if (e->ref && e->ref->type == REF_ARRAY)
12885 gfc_ref *ref = e->ref;
12886 sym = e->symtree->n.sym;
12888 if (sym->attr.dimension)
12890 ref->u.ar.as = sym->as;
12894 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
12895 if (e->ts.type == BT_CHARACTER
12897 && ref->type == REF_ARRAY
12898 && ref->u.ar.dimen == 1
12899 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
12900 && ref->u.ar.stride[0] == NULL)
12902 gfc_expr *start = ref->u.ar.start[0];
12903 gfc_expr *end = ref->u.ar.end[0];
12906 /* Optimize away the (:) reference. */
12907 if (start == NULL && end == NULL)
12910 e->ref = ref->next;
12912 e->ref->next = ref->next;
12917 ref->type = REF_SUBSTRING;
12919 start = gfc_get_int_expr (gfc_default_integer_kind,
12921 ref->u.ss.start = start;
12922 if (end == NULL && e->ts.u.cl)
12923 end = gfc_copy_expr (e->ts.u.cl->length);
12924 ref->u.ss.end = end;
12925 ref->u.ss.length = e->ts.u.cl;
12932 /* Any further ref is an error. */
12935 gcc_assert (ref->type == REF_ARRAY);
12936 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
12942 if (gfc_resolve_expr (e) == FAILURE)
12945 sym = e->symtree->n.sym;
12947 if (sym->attr.is_protected)
12949 if (cnt_protected > 0 && cnt_protected != object)
12951 gfc_error ("Either all or none of the objects in the "
12952 "EQUIVALENCE set at %L shall have the "
12953 "PROTECTED attribute",
12958 /* Shall not equivalence common block variables in a PURE procedure. */
12959 if (sym->ns->proc_name
12960 && sym->ns->proc_name->attr.pure
12961 && sym->attr.in_common)
12963 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
12964 "object in the pure procedure '%s'",
12965 sym->name, &e->where, sym->ns->proc_name->name);
12969 /* Shall not be a named constant. */
12970 if (e->expr_type == EXPR_CONSTANT)
12972 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
12973 "object", sym->name, &e->where);
12977 if (e->ts.type == BT_DERIVED
12978 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
12981 /* Check that the types correspond correctly:
12983 A numeric sequence structure may be equivalenced to another sequence
12984 structure, an object of default integer type, default real type, double
12985 precision real type, default logical type such that components of the
12986 structure ultimately only become associated to objects of the same
12987 kind. A character sequence structure may be equivalenced to an object
12988 of default character kind or another character sequence structure.
12989 Other objects may be equivalenced only to objects of the same type and
12990 kind parameters. */
12992 /* Identical types are unconditionally OK. */
12993 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
12994 goto identical_types;
12996 last_eq_type = sequence_type (*last_ts);
12997 eq_type = sequence_type (sym->ts);
12999 /* Since the pair of objects is not of the same type, mixed or
13000 non-default sequences can be rejected. */
13002 msg = "Sequence %s with mixed components in EQUIVALENCE "
13003 "statement at %L with different type objects";
13005 && last_eq_type == SEQ_MIXED
13006 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
13008 || (eq_type == SEQ_MIXED
13009 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13010 &e->where) == FAILURE))
13013 msg = "Non-default type object or sequence %s in EQUIVALENCE "
13014 "statement at %L with objects of different type";
13016 && last_eq_type == SEQ_NONDEFAULT
13017 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
13018 last_where) == FAILURE)
13019 || (eq_type == SEQ_NONDEFAULT
13020 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13021 &e->where) == FAILURE))
13024 msg ="Non-CHARACTER object '%s' in default CHARACTER "
13025 "EQUIVALENCE statement at %L";
13026 if (last_eq_type == SEQ_CHARACTER
13027 && eq_type != SEQ_CHARACTER
13028 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13029 &e->where) == FAILURE)
13032 msg ="Non-NUMERIC object '%s' in default NUMERIC "
13033 "EQUIVALENCE statement at %L";
13034 if (last_eq_type == SEQ_NUMERIC
13035 && eq_type != SEQ_NUMERIC
13036 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13037 &e->where) == FAILURE)
13042 last_where = &e->where;
13047 /* Shall not be an automatic array. */
13048 if (e->ref->type == REF_ARRAY
13049 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
13051 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13052 "an EQUIVALENCE object", sym->name, &e->where);
13059 /* Shall not be a structure component. */
13060 if (r->type == REF_COMPONENT)
13062 gfc_error ("Structure component '%s' at %L cannot be an "
13063 "EQUIVALENCE object",
13064 r->u.c.component->name, &e->where);
13068 /* A substring shall not have length zero. */
13069 if (r->type == REF_SUBSTRING)
13071 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13073 gfc_error ("Substring at %L has length zero",
13074 &r->u.ss.start->where);
13084 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13087 resolve_fntype (gfc_namespace *ns)
13089 gfc_entry_list *el;
13092 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13095 /* If there are any entries, ns->proc_name is the entry master
13096 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13098 sym = ns->entries->sym;
13100 sym = ns->proc_name;
13101 if (sym->result == sym
13102 && sym->ts.type == BT_UNKNOWN
13103 && gfc_set_default_type (sym, 0, NULL) == FAILURE
13104 && !sym->attr.untyped)
13106 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13107 sym->name, &sym->declared_at);
13108 sym->attr.untyped = 1;
13111 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13112 && !sym->attr.contained
13113 && !gfc_check_access (sym->ts.u.derived->attr.access,
13114 sym->ts.u.derived->ns->default_access)
13115 && gfc_check_access (sym->attr.access, sym->ns->default_access))
13117 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13118 "%L of PRIVATE type '%s'", sym->name,
13119 &sym->declared_at, sym->ts.u.derived->name);
13123 for (el = ns->entries->next; el; el = el->next)
13125 if (el->sym->result == el->sym
13126 && el->sym->ts.type == BT_UNKNOWN
13127 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13128 && !el->sym->attr.untyped)
13130 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13131 el->sym->name, &el->sym->declared_at);
13132 el->sym->attr.untyped = 1;
13138 /* 12.3.2.1.1 Defined operators. */
13141 check_uop_procedure (gfc_symbol *sym, locus where)
13143 gfc_formal_arglist *formal;
13145 if (!sym->attr.function)
13147 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13148 sym->name, &where);
13152 if (sym->ts.type == BT_CHARACTER
13153 && !(sym->ts.u.cl && sym->ts.u.cl->length)
13154 && !(sym->result && sym->result->ts.u.cl
13155 && sym->result->ts.u.cl->length))
13157 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13158 "character length", sym->name, &where);
13162 formal = sym->formal;
13163 if (!formal || !formal->sym)
13165 gfc_error ("User operator procedure '%s' at %L must have at least "
13166 "one argument", sym->name, &where);
13170 if (formal->sym->attr.intent != INTENT_IN)
13172 gfc_error ("First argument of operator interface at %L must be "
13173 "INTENT(IN)", &where);
13177 if (formal->sym->attr.optional)
13179 gfc_error ("First argument of operator interface at %L cannot be "
13180 "optional", &where);
13184 formal = formal->next;
13185 if (!formal || !formal->sym)
13188 if (formal->sym->attr.intent != INTENT_IN)
13190 gfc_error ("Second argument of operator interface at %L must be "
13191 "INTENT(IN)", &where);
13195 if (formal->sym->attr.optional)
13197 gfc_error ("Second argument of operator interface at %L cannot be "
13198 "optional", &where);
13204 gfc_error ("Operator interface at %L must have, at most, two "
13205 "arguments", &where);
13213 gfc_resolve_uops (gfc_symtree *symtree)
13215 gfc_interface *itr;
13217 if (symtree == NULL)
13220 gfc_resolve_uops (symtree->left);
13221 gfc_resolve_uops (symtree->right);
13223 for (itr = symtree->n.uop->op; itr; itr = itr->next)
13224 check_uop_procedure (itr->sym, itr->sym->declared_at);
13228 /* Examine all of the expressions associated with a program unit,
13229 assign types to all intermediate expressions, make sure that all
13230 assignments are to compatible types and figure out which names
13231 refer to which functions or subroutines. It doesn't check code
13232 block, which is handled by resolve_code. */
13235 resolve_types (gfc_namespace *ns)
13241 gfc_namespace* old_ns = gfc_current_ns;
13243 /* Check that all IMPLICIT types are ok. */
13244 if (!ns->seen_implicit_none)
13247 for (letter = 0; letter != GFC_LETTERS; ++letter)
13248 if (ns->set_flag[letter]
13249 && resolve_typespec_used (&ns->default_type[letter],
13250 &ns->implicit_loc[letter],
13255 gfc_current_ns = ns;
13257 resolve_entries (ns);
13259 resolve_common_vars (ns->blank_common.head, false);
13260 resolve_common_blocks (ns->common_root);
13262 resolve_contained_functions (ns);
13264 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13266 for (cl = ns->cl_list; cl; cl = cl->next)
13267 resolve_charlen (cl);
13269 gfc_traverse_ns (ns, resolve_symbol);
13271 resolve_fntype (ns);
13273 for (n = ns->contained; n; n = n->sibling)
13275 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13276 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13277 "also be PURE", n->proc_name->name,
13278 &n->proc_name->declared_at);
13284 gfc_check_interfaces (ns);
13286 gfc_traverse_ns (ns, resolve_values);
13292 for (d = ns->data; d; d = d->next)
13296 gfc_traverse_ns (ns, gfc_formalize_init_value);
13298 gfc_traverse_ns (ns, gfc_verify_binding_labels);
13300 if (ns->common_root != NULL)
13301 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13303 for (eq = ns->equiv; eq; eq = eq->next)
13304 resolve_equivalence (eq);
13306 /* Warn about unused labels. */
13307 if (warn_unused_label)
13308 warn_unused_fortran_label (ns->st_labels);
13310 gfc_resolve_uops (ns->uop_root);
13312 gfc_current_ns = old_ns;
13316 /* Call resolve_code recursively. */
13319 resolve_codes (gfc_namespace *ns)
13322 bitmap_obstack old_obstack;
13324 for (n = ns->contained; n; n = n->sibling)
13327 gfc_current_ns = ns;
13329 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13330 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13333 /* Set to an out of range value. */
13334 current_entry_id = -1;
13336 old_obstack = labels_obstack;
13337 bitmap_obstack_initialize (&labels_obstack);
13339 resolve_code (ns->code, ns);
13341 bitmap_obstack_release (&labels_obstack);
13342 labels_obstack = old_obstack;
13346 /* This function is called after a complete program unit has been compiled.
13347 Its purpose is to examine all of the expressions associated with a program
13348 unit, assign types to all intermediate expressions, make sure that all
13349 assignments are to compatible types and figure out which names refer to
13350 which functions or subroutines. */
13353 gfc_resolve (gfc_namespace *ns)
13355 gfc_namespace *old_ns;
13356 code_stack *old_cs_base;
13362 old_ns = gfc_current_ns;
13363 old_cs_base = cs_base;
13365 resolve_types (ns);
13366 resolve_codes (ns);
13368 gfc_current_ns = old_ns;
13369 cs_base = old_cs_base;
13372 gfc_run_passes (ns);