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 sym->attr.is_bind_c = ifc->attr.is_bind_c;
180 /* Copy array spec. */
181 sym->as = gfc_copy_array_spec (ifc->as);
185 for (i = 0; i < sym->as->rank; i++)
187 gfc_expr_replace_symbols (sym->as->lower[i], sym);
188 gfc_expr_replace_symbols (sym->as->upper[i], sym);
191 /* Copy char length. */
192 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
194 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
195 gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
196 if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
197 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
201 else if (sym->ts.interface->name[0] != '\0')
203 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
204 sym->ts.interface->name, sym->name, &sym->declared_at);
212 /* Resolve types of formal argument lists. These have to be done early so that
213 the formal argument lists of module procedures can be copied to the
214 containing module before the individual procedures are resolved
215 individually. We also resolve argument lists of procedures in interface
216 blocks because they are self-contained scoping units.
218 Since a dummy argument cannot be a non-dummy procedure, the only
219 resort left for untyped names are the IMPLICIT types. */
222 resolve_formal_arglist (gfc_symbol *proc)
224 gfc_formal_arglist *f;
228 if (proc->result != NULL)
233 if (gfc_elemental (proc)
234 || sym->attr.pointer || sym->attr.allocatable
235 || (sym->as && sym->as->rank > 0))
237 proc->attr.always_explicit = 1;
238 sym->attr.always_explicit = 1;
243 for (f = proc->formal; f; f = f->next)
249 /* Alternate return placeholder. */
250 if (gfc_elemental (proc))
251 gfc_error ("Alternate return specifier in elemental subroutine "
252 "'%s' at %L is not allowed", proc->name,
254 if (proc->attr.function)
255 gfc_error ("Alternate return specifier in function "
256 "'%s' at %L is not allowed", proc->name,
260 else if (sym->attr.procedure && sym->ts.interface
261 && sym->attr.if_source != IFSRC_DECL)
262 resolve_procedure_interface (sym);
264 if (sym->attr.if_source != IFSRC_UNKNOWN)
265 resolve_formal_arglist (sym);
267 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
269 if (gfc_pure (proc) && !gfc_pure (sym))
271 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
272 "also be PURE", sym->name, &sym->declared_at);
276 if (gfc_elemental (proc))
278 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
279 "procedure", &sym->declared_at);
283 if (sym->attr.function
284 && sym->ts.type == BT_UNKNOWN
285 && sym->attr.intrinsic)
287 gfc_intrinsic_sym *isym;
288 isym = gfc_find_function (sym->name);
289 if (isym == NULL || !isym->specific)
291 gfc_error ("Unable to find a specific INTRINSIC procedure "
292 "for the reference '%s' at %L", sym->name,
301 if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
302 && (!sym->attr.function || sym->result == sym))
303 gfc_set_default_type (sym, 1, sym->ns);
305 gfc_resolve_array_spec (sym->as, 0);
307 /* We can't tell if an array with dimension (:) is assumed or deferred
308 shape until we know if it has the pointer or allocatable attributes.
310 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
311 && !(sym->attr.pointer || sym->attr.allocatable))
313 sym->as->type = AS_ASSUMED_SHAPE;
314 for (i = 0; i < sym->as->rank; i++)
315 sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
319 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
320 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
321 || sym->attr.optional)
323 proc->attr.always_explicit = 1;
325 proc->result->attr.always_explicit = 1;
328 /* If the flavor is unknown at this point, it has to be a variable.
329 A procedure specification would have already set the type. */
331 if (sym->attr.flavor == FL_UNKNOWN)
332 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
334 if (gfc_pure (proc) && !sym->attr.pointer
335 && sym->attr.flavor != FL_PROCEDURE)
337 if (proc->attr.function && sym->attr.intent != INTENT_IN)
338 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
339 "INTENT(IN)", sym->name, proc->name,
342 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
343 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
344 "have its INTENT specified", sym->name, proc->name,
348 if (gfc_elemental (proc))
351 if (sym->attr.codimension)
353 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
354 "procedure", sym->name, &sym->declared_at);
360 gfc_error ("Argument '%s' of elemental procedure at %L must "
361 "be scalar", sym->name, &sym->declared_at);
365 if (sym->attr.allocatable)
367 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
368 "have the ALLOCATABLE attribute", sym->name,
373 if (sym->attr.pointer)
375 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
376 "have the POINTER attribute", sym->name,
381 if (sym->attr.flavor == FL_PROCEDURE)
383 gfc_error ("Dummy procedure '%s' not allowed in elemental "
384 "procedure '%s' at %L", sym->name, proc->name,
389 if (sym->attr.intent == INTENT_UNKNOWN)
391 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
392 "have its INTENT specified", sym->name, proc->name,
398 /* Each dummy shall be specified to be scalar. */
399 if (proc->attr.proc == PROC_ST_FUNCTION)
403 gfc_error ("Argument '%s' of statement function at %L must "
404 "be scalar", sym->name, &sym->declared_at);
408 if (sym->ts.type == BT_CHARACTER)
410 gfc_charlen *cl = sym->ts.u.cl;
411 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
413 gfc_error ("Character-valued argument '%s' of statement "
414 "function at %L must have constant length",
415 sym->name, &sym->declared_at);
425 /* Work function called when searching for symbols that have argument lists
426 associated with them. */
429 find_arglists (gfc_symbol *sym)
431 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
434 resolve_formal_arglist (sym);
438 /* Given a namespace, resolve all formal argument lists within the namespace.
442 resolve_formal_arglists (gfc_namespace *ns)
447 gfc_traverse_ns (ns, find_arglists);
452 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
456 /* If this namespace is not a function or an entry master function,
458 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
459 || sym->attr.entry_master)
462 /* Try to find out of what the return type is. */
463 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
465 t = gfc_set_default_type (sym->result, 0, ns);
467 if (t == FAILURE && !sym->result->attr.untyped)
469 if (sym->result == sym)
470 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
471 sym->name, &sym->declared_at);
472 else if (!sym->result->attr.proc_pointer)
473 gfc_error ("Result '%s' of contained function '%s' at %L has "
474 "no IMPLICIT type", sym->result->name, sym->name,
475 &sym->result->declared_at);
476 sym->result->attr.untyped = 1;
480 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
481 type, lists the only ways a character length value of * can be used:
482 dummy arguments of procedures, named constants, and function results
483 in external functions. Internal function results and results of module
484 procedures are not on this list, ergo, not permitted. */
486 if (sym->result->ts.type == BT_CHARACTER)
488 gfc_charlen *cl = sym->result->ts.u.cl;
489 if (!cl || !cl->length)
491 /* See if this is a module-procedure and adapt error message
494 gcc_assert (ns->parent && ns->parent->proc_name);
495 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
497 gfc_error ("Character-valued %s '%s' at %L must not be"
499 module_proc ? _("module procedure")
500 : _("internal function"),
501 sym->name, &sym->declared_at);
507 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
508 introduce duplicates. */
511 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
513 gfc_formal_arglist *f, *new_arglist;
516 for (; new_args != NULL; new_args = new_args->next)
518 new_sym = new_args->sym;
519 /* See if this arg is already in the formal argument list. */
520 for (f = proc->formal; f; f = f->next)
522 if (new_sym == f->sym)
529 /* Add a new argument. Argument order is not important. */
530 new_arglist = gfc_get_formal_arglist ();
531 new_arglist->sym = new_sym;
532 new_arglist->next = proc->formal;
533 proc->formal = new_arglist;
538 /* Flag the arguments that are not present in all entries. */
541 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
543 gfc_formal_arglist *f, *head;
546 for (f = proc->formal; f; f = f->next)
551 for (new_args = head; new_args; new_args = new_args->next)
553 if (new_args->sym == f->sym)
560 f->sym->attr.not_always_present = 1;
565 /* Resolve alternate entry points. If a symbol has multiple entry points we
566 create a new master symbol for the main routine, and turn the existing
567 symbol into an entry point. */
570 resolve_entries (gfc_namespace *ns)
572 gfc_namespace *old_ns;
576 char name[GFC_MAX_SYMBOL_LEN + 1];
577 static int master_count = 0;
579 if (ns->proc_name == NULL)
582 /* No need to do anything if this procedure doesn't have alternate entry
587 /* We may already have resolved alternate entry points. */
588 if (ns->proc_name->attr.entry_master)
591 /* If this isn't a procedure something has gone horribly wrong. */
592 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
594 /* Remember the current namespace. */
595 old_ns = gfc_current_ns;
599 /* Add the main entry point to the list of entry points. */
600 el = gfc_get_entry_list ();
601 el->sym = ns->proc_name;
603 el->next = ns->entries;
605 ns->proc_name->attr.entry = 1;
607 /* If it is a module function, it needs to be in the right namespace
608 so that gfc_get_fake_result_decl can gather up the results. The
609 need for this arose in get_proc_name, where these beasts were
610 left in their own namespace, to keep prior references linked to
611 the entry declaration.*/
612 if (ns->proc_name->attr.function
613 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
616 /* Do the same for entries where the master is not a module
617 procedure. These are retained in the module namespace because
618 of the module procedure declaration. */
619 for (el = el->next; el; el = el->next)
620 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
621 && el->sym->attr.mod_proc)
625 /* Add an entry statement for it. */
632 /* Create a new symbol for the master function. */
633 /* Give the internal function a unique name (within this file).
634 Also include the function name so the user has some hope of figuring
635 out what is going on. */
636 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
637 master_count++, ns->proc_name->name);
638 gfc_get_ha_symbol (name, &proc);
639 gcc_assert (proc != NULL);
641 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
642 if (ns->proc_name->attr.subroutine)
643 gfc_add_subroutine (&proc->attr, proc->name, NULL);
647 gfc_typespec *ts, *fts;
648 gfc_array_spec *as, *fas;
649 gfc_add_function (&proc->attr, proc->name, NULL);
651 fas = ns->entries->sym->as;
652 fas = fas ? fas : ns->entries->sym->result->as;
653 fts = &ns->entries->sym->result->ts;
654 if (fts->type == BT_UNKNOWN)
655 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
656 for (el = ns->entries->next; el; el = el->next)
658 ts = &el->sym->result->ts;
660 as = as ? as : el->sym->result->as;
661 if (ts->type == BT_UNKNOWN)
662 ts = gfc_get_default_type (el->sym->result->name, NULL);
664 if (! gfc_compare_types (ts, fts)
665 || (el->sym->result->attr.dimension
666 != ns->entries->sym->result->attr.dimension)
667 || (el->sym->result->attr.pointer
668 != ns->entries->sym->result->attr.pointer))
670 else if (as && fas && ns->entries->sym->result != el->sym->result
671 && gfc_compare_array_spec (as, fas) == 0)
672 gfc_error ("Function %s at %L has entries with mismatched "
673 "array specifications", ns->entries->sym->name,
674 &ns->entries->sym->declared_at);
675 /* The characteristics need to match and thus both need to have
676 the same string length, i.e. both len=*, or both len=4.
677 Having both len=<variable> is also possible, but difficult to
678 check at compile time. */
679 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
680 && (((ts->u.cl->length && !fts->u.cl->length)
681 ||(!ts->u.cl->length && fts->u.cl->length))
683 && ts->u.cl->length->expr_type
684 != fts->u.cl->length->expr_type)
686 && ts->u.cl->length->expr_type == EXPR_CONSTANT
687 && mpz_cmp (ts->u.cl->length->value.integer,
688 fts->u.cl->length->value.integer) != 0)))
689 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
690 "entries returning variables of different "
691 "string lengths", ns->entries->sym->name,
692 &ns->entries->sym->declared_at);
697 sym = ns->entries->sym->result;
698 /* All result types the same. */
700 if (sym->attr.dimension)
701 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
702 if (sym->attr.pointer)
703 gfc_add_pointer (&proc->attr, NULL);
707 /* Otherwise the result will be passed through a union by
709 proc->attr.mixed_entry_master = 1;
710 for (el = ns->entries; el; el = el->next)
712 sym = el->sym->result;
713 if (sym->attr.dimension)
715 if (el == ns->entries)
716 gfc_error ("FUNCTION result %s can't be an array in "
717 "FUNCTION %s at %L", sym->name,
718 ns->entries->sym->name, &sym->declared_at);
720 gfc_error ("ENTRY result %s can't be an array in "
721 "FUNCTION %s at %L", sym->name,
722 ns->entries->sym->name, &sym->declared_at);
724 else if (sym->attr.pointer)
726 if (el == ns->entries)
727 gfc_error ("FUNCTION result %s can't be a POINTER in "
728 "FUNCTION %s at %L", sym->name,
729 ns->entries->sym->name, &sym->declared_at);
731 gfc_error ("ENTRY result %s can't be a POINTER in "
732 "FUNCTION %s at %L", sym->name,
733 ns->entries->sym->name, &sym->declared_at);
738 if (ts->type == BT_UNKNOWN)
739 ts = gfc_get_default_type (sym->name, NULL);
743 if (ts->kind == gfc_default_integer_kind)
747 if (ts->kind == gfc_default_real_kind
748 || ts->kind == gfc_default_double_kind)
752 if (ts->kind == gfc_default_complex_kind)
756 if (ts->kind == gfc_default_logical_kind)
760 /* We will issue error elsewhere. */
768 if (el == ns->entries)
769 gfc_error ("FUNCTION result %s can't be of type %s "
770 "in FUNCTION %s at %L", sym->name,
771 gfc_typename (ts), ns->entries->sym->name,
774 gfc_error ("ENTRY result %s can't be of type %s "
775 "in FUNCTION %s at %L", sym->name,
776 gfc_typename (ts), ns->entries->sym->name,
783 proc->attr.access = ACCESS_PRIVATE;
784 proc->attr.entry_master = 1;
786 /* Merge all the entry point arguments. */
787 for (el = ns->entries; el; el = el->next)
788 merge_argument_lists (proc, el->sym->formal);
790 /* Check the master formal arguments for any that are not
791 present in all entry points. */
792 for (el = ns->entries; el; el = el->next)
793 check_argument_lists (proc, el->sym->formal);
795 /* Use the master function for the function body. */
796 ns->proc_name = proc;
798 /* Finalize the new symbols. */
799 gfc_commit_symbols ();
801 /* Restore the original namespace. */
802 gfc_current_ns = old_ns;
806 /* Resolve common variables. */
808 resolve_common_vars (gfc_symbol *sym, bool named_common)
810 gfc_symbol *csym = sym;
812 for (; csym; csym = csym->common_next)
814 if (csym->value || csym->attr.data)
816 if (!csym->ns->is_block_data)
817 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
818 "but only in BLOCK DATA initialization is "
819 "allowed", csym->name, &csym->declared_at);
820 else if (!named_common)
821 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
822 "in a blank COMMON but initialization is only "
823 "allowed in named common blocks", csym->name,
827 if (csym->ts.type != BT_DERIVED)
830 if (!(csym->ts.u.derived->attr.sequence
831 || csym->ts.u.derived->attr.is_bind_c))
832 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
833 "has neither the SEQUENCE nor the BIND(C) "
834 "attribute", csym->name, &csym->declared_at);
835 if (csym->ts.u.derived->attr.alloc_comp)
836 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
837 "has an ultimate component that is "
838 "allocatable", csym->name, &csym->declared_at);
839 if (gfc_has_default_initializer (csym->ts.u.derived))
840 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
841 "may not have default initializer", csym->name,
844 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
845 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
849 /* Resolve common blocks. */
851 resolve_common_blocks (gfc_symtree *common_root)
855 if (common_root == NULL)
858 if (common_root->left)
859 resolve_common_blocks (common_root->left);
860 if (common_root->right)
861 resolve_common_blocks (common_root->right);
863 resolve_common_vars (common_root->n.common->head, true);
865 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
869 if (sym->attr.flavor == FL_PARAMETER)
870 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
871 sym->name, &common_root->n.common->where, &sym->declared_at);
873 if (sym->attr.intrinsic)
874 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
875 sym->name, &common_root->n.common->where);
876 else if (sym->attr.result
877 || gfc_is_function_return_value (sym, gfc_current_ns))
878 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
879 "that is also a function result", sym->name,
880 &common_root->n.common->where);
881 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
882 && sym->attr.proc != PROC_ST_FUNCTION)
883 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
884 "that is also a global procedure", sym->name,
885 &common_root->n.common->where);
889 /* Resolve contained function types. Because contained functions can call one
890 another, they have to be worked out before any of the contained procedures
893 The good news is that if a function doesn't already have a type, the only
894 way it can get one is through an IMPLICIT type or a RESULT variable, because
895 by definition contained functions are contained namespace they're contained
896 in, not in a sibling or parent namespace. */
899 resolve_contained_functions (gfc_namespace *ns)
901 gfc_namespace *child;
904 resolve_formal_arglists (ns);
906 for (child = ns->contained; child; child = child->sibling)
908 /* Resolve alternate entry points first. */
909 resolve_entries (child);
911 /* Then check function return types. */
912 resolve_contained_fntype (child->proc_name, child);
913 for (el = child->entries; el; el = el->next)
914 resolve_contained_fntype (el->sym, child);
919 /* Resolve all of the elements of a structure constructor and make sure that
920 the types are correct. The 'init' flag indicates that the given
921 constructor is an initializer. */
924 resolve_structure_cons (gfc_expr *expr, int init)
926 gfc_constructor *cons;
933 if (expr->ts.type == BT_DERIVED)
934 resolve_symbol (expr->ts.u.derived);
936 cons = gfc_constructor_first (expr->value.constructor);
937 /* A constructor may have references if it is the result of substituting a
938 parameter variable. In this case we just pull out the component we
941 comp = expr->ref->u.c.sym->components;
943 comp = expr->ts.u.derived->components;
945 /* See if the user is trying to invoke a structure constructor for one of
946 the iso_c_binding derived types. */
947 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
948 && expr->ts.u.derived->ts.is_iso_c && cons
949 && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
951 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
952 expr->ts.u.derived->name, &(expr->where));
956 /* Return if structure constructor is c_null_(fun)prt. */
957 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
958 && expr->ts.u.derived->ts.is_iso_c && cons
959 && cons->expr && cons->expr->expr_type == EXPR_NULL)
962 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
969 if (gfc_resolve_expr (cons->expr) == FAILURE)
975 rank = comp->as ? comp->as->rank : 0;
976 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
977 && (comp->attr.allocatable || cons->expr->rank))
979 gfc_error ("The rank of the element in the derived type "
980 "constructor at %L does not match that of the "
981 "component (%d/%d)", &cons->expr->where,
982 cons->expr->rank, rank);
986 /* If we don't have the right type, try to convert it. */
988 if (!comp->attr.proc_pointer &&
989 !gfc_compare_types (&cons->expr->ts, &comp->ts))
992 if (strcmp (comp->name, "_extends") == 0)
994 /* Can afford to be brutal with the _extends initializer.
995 The derived type can get lost because it is PRIVATE
996 but it is not usage constrained by the standard. */
997 cons->expr->ts = comp->ts;
1000 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1001 gfc_error ("The element in the derived type constructor at %L, "
1002 "for pointer component '%s', is %s but should be %s",
1003 &cons->expr->where, comp->name,
1004 gfc_basic_typename (cons->expr->ts.type),
1005 gfc_basic_typename (comp->ts.type));
1007 t = gfc_convert_type (cons->expr, &comp->ts, 1);
1010 /* For strings, the length of the constructor should be the same as
1011 the one of the structure, ensure this if the lengths are known at
1012 compile time and when we are dealing with PARAMETER or structure
1014 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1015 && comp->ts.u.cl->length
1016 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1017 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1018 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1019 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1020 comp->ts.u.cl->length->value.integer) != 0)
1022 if (cons->expr->expr_type == EXPR_VARIABLE
1023 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1025 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1026 to make use of the gfc_resolve_character_array_constructor
1027 machinery. The expression is later simplified away to
1028 an array of string literals. */
1029 gfc_expr *para = cons->expr;
1030 cons->expr = gfc_get_expr ();
1031 cons->expr->ts = para->ts;
1032 cons->expr->where = para->where;
1033 cons->expr->expr_type = EXPR_ARRAY;
1034 cons->expr->rank = para->rank;
1035 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1036 gfc_constructor_append_expr (&cons->expr->value.constructor,
1037 para, &cons->expr->where);
1039 if (cons->expr->expr_type == EXPR_ARRAY)
1042 p = gfc_constructor_first (cons->expr->value.constructor);
1043 if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
1045 gfc_charlen *cl, *cl2;
1048 for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
1050 if (cl == cons->expr->ts.u.cl)
1058 cl2->next = cl->next;
1060 gfc_free_expr (cl->length);
1064 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1065 cons->expr->ts.u.cl->length_from_typespec = true;
1066 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1067 gfc_resolve_character_array_constructor (cons->expr);
1071 if (cons->expr->expr_type == EXPR_NULL
1072 && !(comp->attr.pointer || comp->attr.allocatable
1073 || comp->attr.proc_pointer
1074 || (comp->ts.type == BT_CLASS
1075 && (CLASS_DATA (comp)->attr.class_pointer
1076 || CLASS_DATA (comp)->attr.allocatable))))
1079 gfc_error ("The NULL in the derived type constructor at %L is "
1080 "being applied to component '%s', which is neither "
1081 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1085 if (!comp->attr.pointer || comp->attr.proc_pointer
1086 || cons->expr->expr_type == EXPR_NULL)
1089 a = gfc_expr_attr (cons->expr);
1091 if (!a.pointer && !a.target)
1094 gfc_error ("The element in the derived type constructor at %L, "
1095 "for pointer component '%s' should be a POINTER or "
1096 "a TARGET", &cons->expr->where, comp->name);
1101 /* F08:C461. Additional checks for pointer initialization. */
1105 gfc_error ("Pointer initialization target at %L "
1106 "must not be ALLOCATABLE ", &cons->expr->where);
1111 gfc_error ("Pointer initialization target at %L "
1112 "must have the SAVE attribute", &cons->expr->where);
1116 /* F2003, C1272 (3). */
1117 if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
1118 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1119 || gfc_is_coindexed (cons->expr)))
1122 gfc_error ("Invalid expression in the derived type constructor for "
1123 "pointer component '%s' at %L in PURE procedure",
1124 comp->name, &cons->expr->where);
1133 /****************** Expression name resolution ******************/
1135 /* Returns 0 if a symbol was not declared with a type or
1136 attribute declaration statement, nonzero otherwise. */
1139 was_declared (gfc_symbol *sym)
1145 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1148 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1149 || a.optional || a.pointer || a.save || a.target || a.volatile_
1150 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1151 || a.asynchronous || a.codimension)
1158 /* Determine if a symbol is generic or not. */
1161 generic_sym (gfc_symbol *sym)
1165 if (sym->attr.generic ||
1166 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1169 if (was_declared (sym) || sym->ns->parent == NULL)
1172 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1179 return generic_sym (s);
1186 /* Determine if a symbol is specific or not. */
1189 specific_sym (gfc_symbol *sym)
1193 if (sym->attr.if_source == IFSRC_IFBODY
1194 || sym->attr.proc == PROC_MODULE
1195 || sym->attr.proc == PROC_INTERNAL
1196 || sym->attr.proc == PROC_ST_FUNCTION
1197 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1198 || sym->attr.external)
1201 if (was_declared (sym) || sym->ns->parent == NULL)
1204 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1206 return (s == NULL) ? 0 : specific_sym (s);
1210 /* Figure out if the procedure is specific, generic or unknown. */
1213 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1217 procedure_kind (gfc_symbol *sym)
1219 if (generic_sym (sym))
1220 return PTYPE_GENERIC;
1222 if (specific_sym (sym))
1223 return PTYPE_SPECIFIC;
1225 return PTYPE_UNKNOWN;
1228 /* Check references to assumed size arrays. The flag need_full_assumed_size
1229 is nonzero when matching actual arguments. */
1231 static int need_full_assumed_size = 0;
1234 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1236 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1239 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1240 What should it be? */
1241 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1242 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1243 && (e->ref->u.ar.type == AR_FULL))
1245 gfc_error ("The upper bound in the last dimension must "
1246 "appear in the reference to the assumed size "
1247 "array '%s' at %L", sym->name, &e->where);
1254 /* Look for bad assumed size array references in argument expressions
1255 of elemental and array valued intrinsic procedures. Since this is
1256 called from procedure resolution functions, it only recurses at
1260 resolve_assumed_size_actual (gfc_expr *e)
1265 switch (e->expr_type)
1268 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1273 if (resolve_assumed_size_actual (e->value.op.op1)
1274 || resolve_assumed_size_actual (e->value.op.op2))
1285 /* Check a generic procedure, passed as an actual argument, to see if
1286 there is a matching specific name. If none, it is an error, and if
1287 more than one, the reference is ambiguous. */
1289 count_specific_procs (gfc_expr *e)
1296 sym = e->symtree->n.sym;
1298 for (p = sym->generic; p; p = p->next)
1299 if (strcmp (sym->name, p->sym->name) == 0)
1301 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1307 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1311 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1312 "argument at %L", sym->name, &e->where);
1318 /* See if a call to sym could possibly be a not allowed RECURSION because of
1319 a missing RECURIVE declaration. This means that either sym is the current
1320 context itself, or sym is the parent of a contained procedure calling its
1321 non-RECURSIVE containing procedure.
1322 This also works if sym is an ENTRY. */
1325 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1327 gfc_symbol* proc_sym;
1328 gfc_symbol* context_proc;
1329 gfc_namespace* real_context;
1331 if (sym->attr.flavor == FL_PROGRAM)
1334 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1336 /* If we've got an ENTRY, find real procedure. */
1337 if (sym->attr.entry && sym->ns->entries)
1338 proc_sym = sym->ns->entries->sym;
1342 /* If sym is RECURSIVE, all is well of course. */
1343 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1346 /* Find the context procedure's "real" symbol if it has entries.
1347 We look for a procedure symbol, so recurse on the parents if we don't
1348 find one (like in case of a BLOCK construct). */
1349 for (real_context = context; ; real_context = real_context->parent)
1351 /* We should find something, eventually! */
1352 gcc_assert (real_context);
1354 context_proc = (real_context->entries ? real_context->entries->sym
1355 : real_context->proc_name);
1357 /* In some special cases, there may not be a proc_name, like for this
1359 real(bad_kind()) function foo () ...
1360 when checking the call to bad_kind ().
1361 In these cases, we simply return here and assume that the
1366 if (context_proc->attr.flavor != FL_LABEL)
1370 /* A call from sym's body to itself is recursion, of course. */
1371 if (context_proc == proc_sym)
1374 /* The same is true if context is a contained procedure and sym the
1376 if (context_proc->attr.contained)
1378 gfc_symbol* parent_proc;
1380 gcc_assert (context->parent);
1381 parent_proc = (context->parent->entries ? context->parent->entries->sym
1382 : context->parent->proc_name);
1384 if (parent_proc == proc_sym)
1392 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1393 its typespec and formal argument list. */
1396 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1398 gfc_intrinsic_sym* isym = NULL;
1404 /* We already know this one is an intrinsic, so we don't call
1405 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1406 gfc_find_subroutine directly to check whether it is a function or
1409 if (sym->intmod_sym_id)
1410 isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
1412 isym = gfc_find_function (sym->name);
1416 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1417 && !sym->attr.implicit_type)
1418 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1419 " ignored", sym->name, &sym->declared_at);
1421 if (!sym->attr.function &&
1422 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1427 else if ((isym = gfc_find_subroutine (sym->name)))
1429 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1431 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1432 " specifier", sym->name, &sym->declared_at);
1436 if (!sym->attr.subroutine &&
1437 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1442 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1447 gfc_copy_formal_args_intr (sym, isym);
1449 /* Check it is actually available in the standard settings. */
1450 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1453 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1454 " available in the current standard settings but %s. Use"
1455 " an appropriate -std=* option or enable -fall-intrinsics"
1456 " in order to use it.",
1457 sym->name, &sym->declared_at, symstd);
1465 /* Resolve a procedure expression, like passing it to a called procedure or as
1466 RHS for a procedure pointer assignment. */
1469 resolve_procedure_expression (gfc_expr* expr)
1473 if (expr->expr_type != EXPR_VARIABLE)
1475 gcc_assert (expr->symtree);
1477 sym = expr->symtree->n.sym;
1479 if (sym->attr.intrinsic)
1480 resolve_intrinsic (sym, &expr->where);
1482 if (sym->attr.flavor != FL_PROCEDURE
1483 || (sym->attr.function && sym->result == sym))
1486 /* A non-RECURSIVE procedure that is used as procedure expression within its
1487 own body is in danger of being called recursively. */
1488 if (is_illegal_recursion (sym, gfc_current_ns))
1489 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1490 " itself recursively. Declare it RECURSIVE or use"
1491 " -frecursive", sym->name, &expr->where);
1497 /* Resolve an actual argument list. Most of the time, this is just
1498 resolving the expressions in the list.
1499 The exception is that we sometimes have to decide whether arguments
1500 that look like procedure arguments are really simple variable
1504 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1505 bool no_formal_args)
1508 gfc_symtree *parent_st;
1510 int save_need_full_assumed_size;
1511 gfc_component *comp;
1513 for (; arg; arg = arg->next)
1518 /* Check the label is a valid branching target. */
1521 if (arg->label->defined == ST_LABEL_UNKNOWN)
1523 gfc_error ("Label %d referenced at %L is never defined",
1524 arg->label->value, &arg->label->where);
1531 if (gfc_is_proc_ptr_comp (e, &comp))
1534 if (e->expr_type == EXPR_PPC)
1536 if (comp->as != NULL)
1537 e->rank = comp->as->rank;
1538 e->expr_type = EXPR_FUNCTION;
1540 if (gfc_resolve_expr (e) == FAILURE)
1545 if (e->expr_type == EXPR_VARIABLE
1546 && e->symtree->n.sym->attr.generic
1548 && count_specific_procs (e) != 1)
1551 if (e->ts.type != BT_PROCEDURE)
1553 save_need_full_assumed_size = need_full_assumed_size;
1554 if (e->expr_type != EXPR_VARIABLE)
1555 need_full_assumed_size = 0;
1556 if (gfc_resolve_expr (e) != SUCCESS)
1558 need_full_assumed_size = save_need_full_assumed_size;
1562 /* See if the expression node should really be a variable reference. */
1564 sym = e->symtree->n.sym;
1566 if (sym->attr.flavor == FL_PROCEDURE
1567 || sym->attr.intrinsic
1568 || sym->attr.external)
1572 /* If a procedure is not already determined to be something else
1573 check if it is intrinsic. */
1574 if (!sym->attr.intrinsic
1575 && !(sym->attr.external || sym->attr.use_assoc
1576 || sym->attr.if_source == IFSRC_IFBODY)
1577 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1578 sym->attr.intrinsic = 1;
1580 if (sym->attr.proc == PROC_ST_FUNCTION)
1582 gfc_error ("Statement function '%s' at %L is not allowed as an "
1583 "actual argument", sym->name, &e->where);
1586 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1587 sym->attr.subroutine);
1588 if (sym->attr.intrinsic && actual_ok == 0)
1590 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1591 "actual argument", sym->name, &e->where);
1594 if (sym->attr.contained && !sym->attr.use_assoc
1595 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1597 if (gfc_notify_std (GFC_STD_F2008,
1598 "Fortran 2008: Internal procedure '%s' is"
1599 " used as actual argument at %L",
1600 sym->name, &e->where) == FAILURE)
1604 if (sym->attr.elemental && !sym->attr.intrinsic)
1606 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1607 "allowed as an actual argument at %L", sym->name,
1611 /* Check if a generic interface has a specific procedure
1612 with the same name before emitting an error. */
1613 if (sym->attr.generic && count_specific_procs (e) != 1)
1616 /* Just in case a specific was found for the expression. */
1617 sym = e->symtree->n.sym;
1619 /* If the symbol is the function that names the current (or
1620 parent) scope, then we really have a variable reference. */
1622 if (gfc_is_function_return_value (sym, sym->ns))
1625 /* If all else fails, see if we have a specific intrinsic. */
1626 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1628 gfc_intrinsic_sym *isym;
1630 isym = gfc_find_function (sym->name);
1631 if (isym == NULL || !isym->specific)
1633 gfc_error ("Unable to find a specific INTRINSIC procedure "
1634 "for the reference '%s' at %L", sym->name,
1639 sym->attr.intrinsic = 1;
1640 sym->attr.function = 1;
1643 if (gfc_resolve_expr (e) == FAILURE)
1648 /* See if the name is a module procedure in a parent unit. */
1650 if (was_declared (sym) || sym->ns->parent == NULL)
1653 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1655 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1659 if (parent_st == NULL)
1662 sym = parent_st->n.sym;
1663 e->symtree = parent_st; /* Point to the right thing. */
1665 if (sym->attr.flavor == FL_PROCEDURE
1666 || sym->attr.intrinsic
1667 || sym->attr.external)
1669 if (gfc_resolve_expr (e) == FAILURE)
1675 e->expr_type = EXPR_VARIABLE;
1677 if (sym->as != NULL)
1679 e->rank = sym->as->rank;
1680 e->ref = gfc_get_ref ();
1681 e->ref->type = REF_ARRAY;
1682 e->ref->u.ar.type = AR_FULL;
1683 e->ref->u.ar.as = sym->as;
1686 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1687 primary.c (match_actual_arg). If above code determines that it
1688 is a variable instead, it needs to be resolved as it was not
1689 done at the beginning of this function. */
1690 save_need_full_assumed_size = need_full_assumed_size;
1691 if (e->expr_type != EXPR_VARIABLE)
1692 need_full_assumed_size = 0;
1693 if (gfc_resolve_expr (e) != SUCCESS)
1695 need_full_assumed_size = save_need_full_assumed_size;
1698 /* Check argument list functions %VAL, %LOC and %REF. There is
1699 nothing to do for %REF. */
1700 if (arg->name && arg->name[0] == '%')
1702 if (strncmp ("%VAL", arg->name, 4) == 0)
1704 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1706 gfc_error ("By-value argument at %L is not of numeric "
1713 gfc_error ("By-value argument at %L cannot be an array or "
1714 "an array section", &e->where);
1718 /* Intrinsics are still PROC_UNKNOWN here. However,
1719 since same file external procedures are not resolvable
1720 in gfortran, it is a good deal easier to leave them to
1722 if (ptype != PROC_UNKNOWN
1723 && ptype != PROC_DUMMY
1724 && ptype != PROC_EXTERNAL
1725 && ptype != PROC_MODULE)
1727 gfc_error ("By-value argument at %L is not allowed "
1728 "in this context", &e->where);
1733 /* Statement functions have already been excluded above. */
1734 else if (strncmp ("%LOC", arg->name, 4) == 0
1735 && e->ts.type == BT_PROCEDURE)
1737 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1739 gfc_error ("Passing internal procedure at %L by location "
1740 "not allowed", &e->where);
1746 /* Fortran 2008, C1237. */
1747 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1748 && gfc_has_ultimate_pointer (e))
1750 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1751 "component", &e->where);
1760 /* Do the checks of the actual argument list that are specific to elemental
1761 procedures. If called with c == NULL, we have a function, otherwise if
1762 expr == NULL, we have a subroutine. */
1765 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1767 gfc_actual_arglist *arg0;
1768 gfc_actual_arglist *arg;
1769 gfc_symbol *esym = NULL;
1770 gfc_intrinsic_sym *isym = NULL;
1772 gfc_intrinsic_arg *iformal = NULL;
1773 gfc_formal_arglist *eformal = NULL;
1774 bool formal_optional = false;
1775 bool set_by_optional = false;
1779 /* Is this an elemental procedure? */
1780 if (expr && expr->value.function.actual != NULL)
1782 if (expr->value.function.esym != NULL
1783 && expr->value.function.esym->attr.elemental)
1785 arg0 = expr->value.function.actual;
1786 esym = expr->value.function.esym;
1788 else if (expr->value.function.isym != NULL
1789 && expr->value.function.isym->elemental)
1791 arg0 = expr->value.function.actual;
1792 isym = expr->value.function.isym;
1797 else if (c && c->ext.actual != NULL)
1799 arg0 = c->ext.actual;
1801 if (c->resolved_sym)
1802 esym = c->resolved_sym;
1804 esym = c->symtree->n.sym;
1807 if (!esym->attr.elemental)
1813 /* The rank of an elemental is the rank of its array argument(s). */
1814 for (arg = arg0; arg; arg = arg->next)
1816 if (arg->expr != NULL && arg->expr->rank > 0)
1818 rank = arg->expr->rank;
1819 if (arg->expr->expr_type == EXPR_VARIABLE
1820 && arg->expr->symtree->n.sym->attr.optional)
1821 set_by_optional = true;
1823 /* Function specific; set the result rank and shape. */
1827 if (!expr->shape && arg->expr->shape)
1829 expr->shape = gfc_get_shape (rank);
1830 for (i = 0; i < rank; i++)
1831 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1838 /* If it is an array, it shall not be supplied as an actual argument
1839 to an elemental procedure unless an array of the same rank is supplied
1840 as an actual argument corresponding to a nonoptional dummy argument of
1841 that elemental procedure(12.4.1.5). */
1842 formal_optional = false;
1844 iformal = isym->formal;
1846 eformal = esym->formal;
1848 for (arg = arg0; arg; arg = arg->next)
1852 if (eformal->sym && eformal->sym->attr.optional)
1853 formal_optional = true;
1854 eformal = eformal->next;
1856 else if (isym && iformal)
1858 if (iformal->optional)
1859 formal_optional = true;
1860 iformal = iformal->next;
1863 formal_optional = true;
1865 if (pedantic && arg->expr != NULL
1866 && arg->expr->expr_type == EXPR_VARIABLE
1867 && arg->expr->symtree->n.sym->attr.optional
1870 && (set_by_optional || arg->expr->rank != rank)
1871 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1873 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1874 "MISSING, it cannot be the actual argument of an "
1875 "ELEMENTAL procedure unless there is a non-optional "
1876 "argument with the same rank (12.4.1.5)",
1877 arg->expr->symtree->n.sym->name, &arg->expr->where);
1882 for (arg = arg0; arg; arg = arg->next)
1884 if (arg->expr == NULL || arg->expr->rank == 0)
1887 /* Being elemental, the last upper bound of an assumed size array
1888 argument must be present. */
1889 if (resolve_assumed_size_actual (arg->expr))
1892 /* Elemental procedure's array actual arguments must conform. */
1895 if (gfc_check_conformance (arg->expr, e,
1896 "elemental procedure") == FAILURE)
1903 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1904 is an array, the intent inout/out variable needs to be also an array. */
1905 if (rank > 0 && esym && expr == NULL)
1906 for (eformal = esym->formal, arg = arg0; arg && eformal;
1907 arg = arg->next, eformal = eformal->next)
1908 if ((eformal->sym->attr.intent == INTENT_OUT
1909 || eformal->sym->attr.intent == INTENT_INOUT)
1910 && arg->expr && arg->expr->rank == 0)
1912 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1913 "ELEMENTAL subroutine '%s' is a scalar, but another "
1914 "actual argument is an array", &arg->expr->where,
1915 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1916 : "INOUT", eformal->sym->name, esym->name);
1923 /* This function does the checking of references to global procedures
1924 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1925 77 and 95 standards. It checks for a gsymbol for the name, making
1926 one if it does not already exist. If it already exists, then the
1927 reference being resolved must correspond to the type of gsymbol.
1928 Otherwise, the new symbol is equipped with the attributes of the
1929 reference. The corresponding code that is called in creating
1930 global entities is parse.c.
1932 In addition, for all but -std=legacy, the gsymbols are used to
1933 check the interfaces of external procedures from the same file.
1934 The namespace of the gsymbol is resolved and then, once this is
1935 done the interface is checked. */
1939 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
1941 if (!gsym_ns->proc_name->attr.recursive)
1944 if (sym->ns == gsym_ns)
1947 if (sym->ns->parent && sym->ns->parent == gsym_ns)
1954 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
1956 if (gsym_ns->entries)
1958 gfc_entry_list *entry = gsym_ns->entries;
1960 for (; entry; entry = entry->next)
1962 if (strcmp (sym->name, entry->sym->name) == 0)
1964 if (strcmp (gsym_ns->proc_name->name,
1965 sym->ns->proc_name->name) == 0)
1969 && strcmp (gsym_ns->proc_name->name,
1970 sym->ns->parent->proc_name->name) == 0)
1979 resolve_global_procedure (gfc_symbol *sym, locus *where,
1980 gfc_actual_arglist **actual, int sub)
1984 enum gfc_symbol_type type;
1986 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1988 gsym = gfc_get_gsymbol (sym->name);
1990 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1991 gfc_global_used (gsym, where);
1993 if (gfc_option.flag_whole_file
1994 && (sym->attr.if_source == IFSRC_UNKNOWN
1995 || sym->attr.if_source == IFSRC_IFBODY)
1996 && gsym->type != GSYM_UNKNOWN
1998 && gsym->ns->resolved != -1
1999 && gsym->ns->proc_name
2000 && not_in_recursive (sym, gsym->ns)
2001 && not_entry_self_reference (sym, gsym->ns))
2003 gfc_symbol *def_sym;
2005 /* Resolve the gsymbol namespace if needed. */
2006 if (!gsym->ns->resolved)
2008 gfc_dt_list *old_dt_list;
2010 /* Stash away derived types so that the backend_decls do not
2012 old_dt_list = gfc_derived_types;
2013 gfc_derived_types = NULL;
2015 gfc_resolve (gsym->ns);
2017 /* Store the new derived types with the global namespace. */
2018 if (gfc_derived_types)
2019 gsym->ns->derived_types = gfc_derived_types;
2021 /* Restore the derived types of this namespace. */
2022 gfc_derived_types = old_dt_list;
2025 /* Make sure that translation for the gsymbol occurs before
2026 the procedure currently being resolved. */
2027 ns = gfc_global_ns_list;
2028 for (; ns && ns != gsym->ns; ns = ns->sibling)
2030 if (ns->sibling == gsym->ns)
2032 ns->sibling = gsym->ns->sibling;
2033 gsym->ns->sibling = gfc_global_ns_list;
2034 gfc_global_ns_list = gsym->ns;
2039 def_sym = gsym->ns->proc_name;
2040 if (def_sym->attr.entry_master)
2042 gfc_entry_list *entry;
2043 for (entry = gsym->ns->entries; entry; entry = entry->next)
2044 if (strcmp (entry->sym->name, sym->name) == 0)
2046 def_sym = entry->sym;
2051 /* Differences in constant character lengths. */
2052 if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2054 long int l1 = 0, l2 = 0;
2055 gfc_charlen *cl1 = sym->ts.u.cl;
2056 gfc_charlen *cl2 = def_sym->ts.u.cl;
2059 && cl1->length != NULL
2060 && cl1->length->expr_type == EXPR_CONSTANT)
2061 l1 = mpz_get_si (cl1->length->value.integer);
2064 && cl2->length != NULL
2065 && cl2->length->expr_type == EXPR_CONSTANT)
2066 l2 = mpz_get_si (cl2->length->value.integer);
2068 if (l1 && l2 && l1 != l2)
2069 gfc_error ("Character length mismatch in return type of "
2070 "function '%s' at %L (%ld/%ld)", sym->name,
2071 &sym->declared_at, l1, l2);
2074 /* Type mismatch of function return type and expected type. */
2075 if (sym->attr.function
2076 && !gfc_compare_types (&sym->ts, &def_sym->ts))
2077 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2078 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2079 gfc_typename (&def_sym->ts));
2081 if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2083 gfc_formal_arglist *arg = def_sym->formal;
2084 for ( ; arg; arg = arg->next)
2087 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2088 else if (arg->sym->attr.allocatable
2089 || arg->sym->attr.asynchronous
2090 || arg->sym->attr.optional
2091 || arg->sym->attr.pointer
2092 || arg->sym->attr.target
2093 || arg->sym->attr.value
2094 || arg->sym->attr.volatile_)
2096 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2097 "has an attribute that requires an explicit "
2098 "interface for this procedure", arg->sym->name,
2099 sym->name, &sym->declared_at);
2102 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2103 else if (arg->sym && arg->sym->as
2104 && arg->sym->as->type == AS_ASSUMED_SHAPE)
2106 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2107 "argument '%s' must have an explicit interface",
2108 sym->name, &sym->declared_at, arg->sym->name);
2111 /* F2008, 12.4.2.2 (2c) */
2112 else if (arg->sym->attr.codimension)
2114 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2115 "'%s' must have an explicit interface",
2116 sym->name, &sym->declared_at, arg->sym->name);
2119 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2120 else if (false) /* TODO: is a parametrized derived type */
2122 gfc_error ("Procedure '%s' at %L with parametrized derived "
2123 "type argument '%s' must have an explicit "
2124 "interface", sym->name, &sym->declared_at,
2128 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2129 else if (arg->sym->ts.type == BT_CLASS)
2131 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2132 "argument '%s' must have an explicit interface",
2133 sym->name, &sym->declared_at, arg->sym->name);
2138 if (def_sym->attr.function)
2140 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2141 if (def_sym->as && def_sym->as->rank
2142 && (!sym->as || sym->as->rank != def_sym->as->rank))
2143 gfc_error ("The reference to function '%s' at %L either needs an "
2144 "explicit INTERFACE or the rank is incorrect", sym->name,
2147 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2148 if ((def_sym->result->attr.pointer
2149 || def_sym->result->attr.allocatable)
2150 && (sym->attr.if_source != IFSRC_IFBODY
2151 || def_sym->result->attr.pointer
2152 != sym->result->attr.pointer
2153 || def_sym->result->attr.allocatable
2154 != sym->result->attr.allocatable))
2155 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2156 "result must have an explicit interface", sym->name,
2159 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2160 if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2161 && def_sym->ts.u.cl->length != NULL)
2163 gfc_charlen *cl = sym->ts.u.cl;
2165 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2166 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2168 gfc_error ("Nonconstant character-length function '%s' at %L "
2169 "must have an explicit interface", sym->name,
2175 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2176 if (def_sym->attr.elemental && !sym->attr.elemental)
2178 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2179 "interface", sym->name, &sym->declared_at);
2182 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2183 if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2185 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2186 "an explicit interface", sym->name, &sym->declared_at);
2189 if (gfc_option.flag_whole_file == 1
2190 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2191 && !(gfc_option.warn_std & GFC_STD_GNU)))
2192 gfc_errors_to_warnings (1);
2194 if (sym->attr.if_source != IFSRC_IFBODY)
2195 gfc_procedure_use (def_sym, actual, where);
2197 gfc_errors_to_warnings (0);
2200 if (gsym->type == GSYM_UNKNOWN)
2203 gsym->where = *where;
2210 /************* Function resolution *************/
2212 /* Resolve a function call known to be generic.
2213 Section 14.1.2.4.1. */
2216 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2220 if (sym->attr.generic)
2222 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2225 expr->value.function.name = s->name;
2226 expr->value.function.esym = s;
2228 if (s->ts.type != BT_UNKNOWN)
2230 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2231 expr->ts = s->result->ts;
2234 expr->rank = s->as->rank;
2235 else if (s->result != NULL && s->result->as != NULL)
2236 expr->rank = s->result->as->rank;
2238 gfc_set_sym_referenced (expr->value.function.esym);
2243 /* TODO: Need to search for elemental references in generic
2247 if (sym->attr.intrinsic)
2248 return gfc_intrinsic_func_interface (expr, 0);
2255 resolve_generic_f (gfc_expr *expr)
2260 sym = expr->symtree->n.sym;
2264 m = resolve_generic_f0 (expr, sym);
2267 else if (m == MATCH_ERROR)
2271 if (sym->ns->parent == NULL)
2273 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2277 if (!generic_sym (sym))
2281 /* Last ditch attempt. See if the reference is to an intrinsic
2282 that possesses a matching interface. 14.1.2.4 */
2283 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
2285 gfc_error ("There is no specific function for the generic '%s' at %L",
2286 expr->symtree->n.sym->name, &expr->where);
2290 m = gfc_intrinsic_func_interface (expr, 0);
2294 gfc_error ("Generic function '%s' at %L is not consistent with a "
2295 "specific intrinsic interface", expr->symtree->n.sym->name,
2302 /* Resolve a function call known to be specific. */
2305 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2309 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2311 if (sym->attr.dummy)
2313 sym->attr.proc = PROC_DUMMY;
2317 sym->attr.proc = PROC_EXTERNAL;
2321 if (sym->attr.proc == PROC_MODULE
2322 || sym->attr.proc == PROC_ST_FUNCTION
2323 || sym->attr.proc == PROC_INTERNAL)
2326 if (sym->attr.intrinsic)
2328 m = gfc_intrinsic_func_interface (expr, 1);
2332 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2333 "with an intrinsic", sym->name, &expr->where);
2341 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2344 expr->ts = sym->result->ts;
2347 expr->value.function.name = sym->name;
2348 expr->value.function.esym = sym;
2349 if (sym->as != NULL)
2350 expr->rank = sym->as->rank;
2357 resolve_specific_f (gfc_expr *expr)
2362 sym = expr->symtree->n.sym;
2366 m = resolve_specific_f0 (sym, expr);
2369 if (m == MATCH_ERROR)
2372 if (sym->ns->parent == NULL)
2375 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2381 gfc_error ("Unable to resolve the specific function '%s' at %L",
2382 expr->symtree->n.sym->name, &expr->where);
2388 /* Resolve a procedure call not known to be generic nor specific. */
2391 resolve_unknown_f (gfc_expr *expr)
2396 sym = expr->symtree->n.sym;
2398 if (sym->attr.dummy)
2400 sym->attr.proc = PROC_DUMMY;
2401 expr->value.function.name = sym->name;
2405 /* See if we have an intrinsic function reference. */
2407 if (gfc_is_intrinsic (sym, 0, expr->where))
2409 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2414 /* The reference is to an external name. */
2416 sym->attr.proc = PROC_EXTERNAL;
2417 expr->value.function.name = sym->name;
2418 expr->value.function.esym = expr->symtree->n.sym;
2420 if (sym->as != NULL)
2421 expr->rank = sym->as->rank;
2423 /* Type of the expression is either the type of the symbol or the
2424 default type of the symbol. */
2427 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2429 if (sym->ts.type != BT_UNKNOWN)
2433 ts = gfc_get_default_type (sym->name, sym->ns);
2435 if (ts->type == BT_UNKNOWN)
2437 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2438 sym->name, &expr->where);
2449 /* Return true, if the symbol is an external procedure. */
2451 is_external_proc (gfc_symbol *sym)
2453 if (!sym->attr.dummy && !sym->attr.contained
2454 && !(sym->attr.intrinsic
2455 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2456 && sym->attr.proc != PROC_ST_FUNCTION
2457 && !sym->attr.proc_pointer
2458 && !sym->attr.use_assoc
2466 /* Figure out if a function reference is pure or not. Also set the name
2467 of the function for a potential error message. Return nonzero if the
2468 function is PURE, zero if not. */
2470 pure_stmt_function (gfc_expr *, gfc_symbol *);
2473 pure_function (gfc_expr *e, const char **name)
2479 if (e->symtree != NULL
2480 && e->symtree->n.sym != NULL
2481 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2482 return pure_stmt_function (e, e->symtree->n.sym);
2484 if (e->value.function.esym)
2486 pure = gfc_pure (e->value.function.esym);
2487 *name = e->value.function.esym->name;
2489 else if (e->value.function.isym)
2491 pure = e->value.function.isym->pure
2492 || e->value.function.isym->elemental;
2493 *name = e->value.function.isym->name;
2497 /* Implicit functions are not pure. */
2499 *name = e->value.function.name;
2507 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2508 int *f ATTRIBUTE_UNUSED)
2512 /* Don't bother recursing into other statement functions
2513 since they will be checked individually for purity. */
2514 if (e->expr_type != EXPR_FUNCTION
2516 || e->symtree->n.sym == sym
2517 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2520 return pure_function (e, &name) ? false : true;
2525 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2527 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2532 is_scalar_expr_ptr (gfc_expr *expr)
2534 gfc_try retval = SUCCESS;
2539 /* See if we have a gfc_ref, which means we have a substring, array
2540 reference, or a component. */
2541 if (expr->ref != NULL)
2544 while (ref->next != NULL)
2550 if (ref->u.ss.length != NULL
2551 && ref->u.ss.length->length != NULL
2553 && ref->u.ss.start->expr_type == EXPR_CONSTANT
2555 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
2557 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
2558 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
2559 if (end - start + 1 != 1)
2566 if (ref->u.ar.type == AR_ELEMENT)
2568 else if (ref->u.ar.type == AR_FULL)
2570 /* The user can give a full array if the array is of size 1. */
2571 if (ref->u.ar.as != NULL
2572 && ref->u.ar.as->rank == 1
2573 && ref->u.ar.as->type == AS_EXPLICIT
2574 && ref->u.ar.as->lower[0] != NULL
2575 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2576 && ref->u.ar.as->upper[0] != NULL
2577 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2579 /* If we have a character string, we need to check if
2580 its length is one. */
2581 if (expr->ts.type == BT_CHARACTER)
2583 if (expr->ts.u.cl == NULL
2584 || expr->ts.u.cl->length == NULL
2585 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2591 /* We have constant lower and upper bounds. If the
2592 difference between is 1, it can be considered a
2594 start = (int) mpz_get_si
2595 (ref->u.ar.as->lower[0]->value.integer);
2596 end = (int) mpz_get_si
2597 (ref->u.ar.as->upper[0]->value.integer);
2598 if (end - start + 1 != 1)
2613 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2615 /* Character string. Make sure it's of length 1. */
2616 if (expr->ts.u.cl == NULL
2617 || expr->ts.u.cl->length == NULL
2618 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2621 else if (expr->rank != 0)
2628 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2629 and, in the case of c_associated, set the binding label based on
2633 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2634 gfc_symbol **new_sym)
2636 char name[GFC_MAX_SYMBOL_LEN + 1];
2637 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2638 int optional_arg = 0;
2639 gfc_try retval = SUCCESS;
2640 gfc_symbol *args_sym;
2641 gfc_typespec *arg_ts;
2642 symbol_attribute arg_attr;
2644 if (args->expr->expr_type == EXPR_CONSTANT
2645 || args->expr->expr_type == EXPR_OP
2646 || args->expr->expr_type == EXPR_NULL)
2648 gfc_error ("Argument to '%s' at %L is not a variable",
2649 sym->name, &(args->expr->where));
2653 args_sym = args->expr->symtree->n.sym;
2655 /* The typespec for the actual arg should be that stored in the expr
2656 and not necessarily that of the expr symbol (args_sym), because
2657 the actual expression could be a part-ref of the expr symbol. */
2658 arg_ts = &(args->expr->ts);
2659 arg_attr = gfc_expr_attr (args->expr);
2661 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2663 /* If the user gave two args then they are providing something for
2664 the optional arg (the second cptr). Therefore, set the name and
2665 binding label to the c_associated for two cptrs. Otherwise,
2666 set c_associated to expect one cptr. */
2670 sprintf (name, "%s_2", sym->name);
2671 sprintf (binding_label, "%s_2", sym->binding_label);
2677 sprintf (name, "%s_1", sym->name);
2678 sprintf (binding_label, "%s_1", sym->binding_label);
2682 /* Get a new symbol for the version of c_associated that
2684 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2686 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2687 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2689 sprintf (name, "%s", sym->name);
2690 sprintf (binding_label, "%s", sym->binding_label);
2692 /* Error check the call. */
2693 if (args->next != NULL)
2695 gfc_error_now ("More actual than formal arguments in '%s' "
2696 "call at %L", name, &(args->expr->where));
2699 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2701 /* Make sure we have either the target or pointer attribute. */
2702 if (!arg_attr.target && !arg_attr.pointer)
2704 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2705 "a TARGET or an associated pointer",
2707 sym->name, &(args->expr->where));
2711 /* See if we have interoperable type and type param. */
2712 if (verify_c_interop (arg_ts) == SUCCESS
2713 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2715 if (args_sym->attr.target == 1)
2717 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2718 has the target attribute and is interoperable. */
2719 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2720 allocatable variable that has the TARGET attribute and
2721 is not an array of zero size. */
2722 if (args_sym->attr.allocatable == 1)
2724 if (args_sym->attr.dimension != 0
2725 && (args_sym->as && args_sym->as->rank == 0))
2727 gfc_error_now ("Allocatable variable '%s' used as a "
2728 "parameter to '%s' at %L must not be "
2729 "an array of zero size",
2730 args_sym->name, sym->name,
2731 &(args->expr->where));
2737 /* A non-allocatable target variable with C
2738 interoperable type and type parameters must be
2740 if (args_sym && args_sym->attr.dimension)
2742 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2744 gfc_error ("Assumed-shape array '%s' at %L "
2745 "cannot be an argument to the "
2746 "procedure '%s' because "
2747 "it is not C interoperable",
2749 &(args->expr->where), sym->name);
2752 else if (args_sym->as->type == AS_DEFERRED)
2754 gfc_error ("Deferred-shape array '%s' at %L "
2755 "cannot be an argument to the "
2756 "procedure '%s' because "
2757 "it is not C interoperable",
2759 &(args->expr->where), sym->name);
2764 /* Make sure it's not a character string. Arrays of
2765 any type should be ok if the variable is of a C
2766 interoperable type. */
2767 if (arg_ts->type == BT_CHARACTER)
2768 if (arg_ts->u.cl != NULL
2769 && (arg_ts->u.cl->length == NULL
2770 || arg_ts->u.cl->length->expr_type
2773 (arg_ts->u.cl->length->value.integer, 1)
2775 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2777 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2778 "at %L must have a length of 1",
2779 args_sym->name, sym->name,
2780 &(args->expr->where));
2785 else if (arg_attr.pointer
2786 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2788 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2790 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2791 "associated scalar POINTER", args_sym->name,
2792 sym->name, &(args->expr->where));
2798 /* The parameter is not required to be C interoperable. If it
2799 is not C interoperable, it must be a nonpolymorphic scalar
2800 with no length type parameters. It still must have either
2801 the pointer or target attribute, and it can be
2802 allocatable (but must be allocated when c_loc is called). */
2803 if (args->expr->rank != 0
2804 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2806 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2807 "scalar", args_sym->name, sym->name,
2808 &(args->expr->where));
2811 else if (arg_ts->type == BT_CHARACTER
2812 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2814 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2815 "%L must have a length of 1",
2816 args_sym->name, sym->name,
2817 &(args->expr->where));
2820 else if (arg_ts->type == BT_CLASS)
2822 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2823 "polymorphic", args_sym->name, sym->name,
2824 &(args->expr->where));
2829 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2831 if (args_sym->attr.flavor != FL_PROCEDURE)
2833 /* TODO: Update this error message to allow for procedure
2834 pointers once they are implemented. */
2835 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2837 args_sym->name, sym->name,
2838 &(args->expr->where));
2841 else if (args_sym->attr.is_bind_c != 1)
2843 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2845 args_sym->name, sym->name,
2846 &(args->expr->where));
2851 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2856 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2857 "iso_c_binding function: '%s'!\n", sym->name);
2864 /* Resolve a function call, which means resolving the arguments, then figuring
2865 out which entity the name refers to. */
2868 resolve_function (gfc_expr *expr)
2870 gfc_actual_arglist *arg;
2875 procedure_type p = PROC_INTRINSIC;
2876 bool no_formal_args;
2880 sym = expr->symtree->n.sym;
2882 /* If this is a procedure pointer component, it has already been resolved. */
2883 if (gfc_is_proc_ptr_comp (expr, NULL))
2886 if (sym && sym->attr.intrinsic
2887 && resolve_intrinsic (sym, &expr->where) == FAILURE)
2890 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2892 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2896 /* If this ia a deferred TBP with an abstract interface (which may
2897 of course be referenced), expr->value.function.esym will be set. */
2898 if (sym && sym->attr.abstract && !expr->value.function.esym)
2900 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2901 sym->name, &expr->where);
2905 /* Switch off assumed size checking and do this again for certain kinds
2906 of procedure, once the procedure itself is resolved. */
2907 need_full_assumed_size++;
2909 if (expr->symtree && expr->symtree->n.sym)
2910 p = expr->symtree->n.sym->attr.proc;
2912 if (expr->value.function.isym && expr->value.function.isym->inquiry)
2913 inquiry_argument = true;
2914 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2916 if (resolve_actual_arglist (expr->value.function.actual,
2917 p, no_formal_args) == FAILURE)
2919 inquiry_argument = false;
2923 inquiry_argument = false;
2925 /* Need to setup the call to the correct c_associated, depending on
2926 the number of cptrs to user gives to compare. */
2927 if (sym && sym->attr.is_iso_c == 1)
2929 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2933 /* Get the symtree for the new symbol (resolved func).
2934 the old one will be freed later, when it's no longer used. */
2935 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2938 /* Resume assumed_size checking. */
2939 need_full_assumed_size--;
2941 /* If the procedure is external, check for usage. */
2942 if (sym && is_external_proc (sym))
2943 resolve_global_procedure (sym, &expr->where,
2944 &expr->value.function.actual, 0);
2946 if (sym && sym->ts.type == BT_CHARACTER
2948 && sym->ts.u.cl->length == NULL
2950 && expr->value.function.esym == NULL
2951 && !sym->attr.contained)
2953 /* Internal procedures are taken care of in resolve_contained_fntype. */
2954 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2955 "be used at %L since it is not a dummy argument",
2956 sym->name, &expr->where);
2960 /* See if function is already resolved. */
2962 if (expr->value.function.name != NULL)
2964 if (expr->ts.type == BT_UNKNOWN)
2970 /* Apply the rules of section 14.1.2. */
2972 switch (procedure_kind (sym))
2975 t = resolve_generic_f (expr);
2978 case PTYPE_SPECIFIC:
2979 t = resolve_specific_f (expr);
2983 t = resolve_unknown_f (expr);
2987 gfc_internal_error ("resolve_function(): bad function type");
2991 /* If the expression is still a function (it might have simplified),
2992 then we check to see if we are calling an elemental function. */
2994 if (expr->expr_type != EXPR_FUNCTION)
2997 temp = need_full_assumed_size;
2998 need_full_assumed_size = 0;
3000 if (resolve_elemental_actual (expr, NULL) == FAILURE)
3003 if (omp_workshare_flag
3004 && expr->value.function.esym
3005 && ! gfc_elemental (expr->value.function.esym))
3007 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3008 "in WORKSHARE construct", expr->value.function.esym->name,
3013 #define GENERIC_ID expr->value.function.isym->id
3014 else if (expr->value.function.actual != NULL
3015 && expr->value.function.isym != NULL
3016 && GENERIC_ID != GFC_ISYM_LBOUND
3017 && GENERIC_ID != GFC_ISYM_LEN
3018 && GENERIC_ID != GFC_ISYM_LOC
3019 && GENERIC_ID != GFC_ISYM_PRESENT)
3021 /* Array intrinsics must also have the last upper bound of an
3022 assumed size array argument. UBOUND and SIZE have to be
3023 excluded from the check if the second argument is anything
3026 for (arg = expr->value.function.actual; arg; arg = arg->next)
3028 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3029 && arg->next != NULL && arg->next->expr)
3031 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3034 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3037 if ((int)mpz_get_si (arg->next->expr->value.integer)
3042 if (arg->expr != NULL
3043 && arg->expr->rank > 0
3044 && resolve_assumed_size_actual (arg->expr))
3050 need_full_assumed_size = temp;
3053 if (!pure_function (expr, &name) && name)
3057 gfc_error ("reference to non-PURE function '%s' at %L inside a "
3058 "FORALL %s", name, &expr->where,
3059 forall_flag == 2 ? "mask" : "block");
3062 else if (gfc_pure (NULL))
3064 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3065 "procedure within a PURE procedure", name, &expr->where);
3070 /* Functions without the RECURSIVE attribution are not allowed to
3071 * call themselves. */
3072 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3075 esym = expr->value.function.esym;
3077 if (is_illegal_recursion (esym, gfc_current_ns))
3079 if (esym->attr.entry && esym->ns->entries)
3080 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3081 " function '%s' is not RECURSIVE",
3082 esym->name, &expr->where, esym->ns->entries->sym->name);
3084 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3085 " is not RECURSIVE", esym->name, &expr->where);
3091 /* Character lengths of use associated functions may contains references to
3092 symbols not referenced from the current program unit otherwise. Make sure
3093 those symbols are marked as referenced. */
3095 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3096 && expr->value.function.esym->attr.use_assoc)
3098 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3101 /* Make sure that the expression has a typespec that works. */
3102 if (expr->ts.type == BT_UNKNOWN)
3104 if (expr->symtree->n.sym->result
3105 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3106 && !expr->symtree->n.sym->result->attr.proc_pointer)
3107 expr->ts = expr->symtree->n.sym->result->ts;
3114 /************* Subroutine resolution *************/
3117 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3123 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3124 sym->name, &c->loc);
3125 else if (gfc_pure (NULL))
3126 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3132 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3136 if (sym->attr.generic)
3138 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3141 c->resolved_sym = s;
3142 pure_subroutine (c, s);
3146 /* TODO: Need to search for elemental references in generic interface. */
3149 if (sym->attr.intrinsic)
3150 return gfc_intrinsic_sub_interface (c, 0);
3157 resolve_generic_s (gfc_code *c)
3162 sym = c->symtree->n.sym;
3166 m = resolve_generic_s0 (c, sym);
3169 else if (m == MATCH_ERROR)
3173 if (sym->ns->parent == NULL)
3175 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3179 if (!generic_sym (sym))
3183 /* Last ditch attempt. See if the reference is to an intrinsic
3184 that possesses a matching interface. 14.1.2.4 */
3185 sym = c->symtree->n.sym;
3187 if (!gfc_is_intrinsic (sym, 1, c->loc))
3189 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3190 sym->name, &c->loc);
3194 m = gfc_intrinsic_sub_interface (c, 0);
3198 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3199 "intrinsic subroutine interface", sym->name, &c->loc);
3205 /* Set the name and binding label of the subroutine symbol in the call
3206 expression represented by 'c' to include the type and kind of the
3207 second parameter. This function is for resolving the appropriate
3208 version of c_f_pointer() and c_f_procpointer(). For example, a
3209 call to c_f_pointer() for a default integer pointer could have a
3210 name of c_f_pointer_i4. If no second arg exists, which is an error
3211 for these two functions, it defaults to the generic symbol's name
3212 and binding label. */
3215 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3216 char *name, char *binding_label)
3218 gfc_expr *arg = NULL;
3222 /* The second arg of c_f_pointer and c_f_procpointer determines
3223 the type and kind for the procedure name. */
3224 arg = c->ext.actual->next->expr;
3228 /* Set up the name to have the given symbol's name,
3229 plus the type and kind. */
3230 /* a derived type is marked with the type letter 'u' */
3231 if (arg->ts.type == BT_DERIVED)
3234 kind = 0; /* set the kind as 0 for now */
3238 type = gfc_type_letter (arg->ts.type);
3239 kind = arg->ts.kind;
3242 if (arg->ts.type == BT_CHARACTER)
3243 /* Kind info for character strings not needed. */
3246 sprintf (name, "%s_%c%d", sym->name, type, kind);
3247 /* Set up the binding label as the given symbol's label plus
3248 the type and kind. */
3249 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
3253 /* If the second arg is missing, set the name and label as
3254 was, cause it should at least be found, and the missing
3255 arg error will be caught by compare_parameters(). */
3256 sprintf (name, "%s", sym->name);
3257 sprintf (binding_label, "%s", sym->binding_label);
3264 /* Resolve a generic version of the iso_c_binding procedure given
3265 (sym) to the specific one based on the type and kind of the
3266 argument(s). Currently, this function resolves c_f_pointer() and
3267 c_f_procpointer based on the type and kind of the second argument
3268 (FPTR). Other iso_c_binding procedures aren't specially handled.
3269 Upon successfully exiting, c->resolved_sym will hold the resolved
3270 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3274 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3276 gfc_symbol *new_sym;
3277 /* this is fine, since we know the names won't use the max */
3278 char name[GFC_MAX_SYMBOL_LEN + 1];
3279 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
3280 /* default to success; will override if find error */
3281 match m = MATCH_YES;
3283 /* Make sure the actual arguments are in the necessary order (based on the
3284 formal args) before resolving. */
3285 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3287 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3288 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3290 set_name_and_label (c, sym, name, binding_label);
3292 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3294 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3296 /* Make sure we got a third arg if the second arg has non-zero
3297 rank. We must also check that the type and rank are
3298 correct since we short-circuit this check in
3299 gfc_procedure_use() (called above to sort actual args). */
3300 if (c->ext.actual->next->expr->rank != 0)
3302 if(c->ext.actual->next->next == NULL
3303 || c->ext.actual->next->next->expr == NULL)
3306 gfc_error ("Missing SHAPE parameter for call to %s "
3307 "at %L", sym->name, &(c->loc));
3309 else if (c->ext.actual->next->next->expr->ts.type
3311 || c->ext.actual->next->next->expr->rank != 1)
3314 gfc_error ("SHAPE parameter for call to %s at %L must "
3315 "be a rank 1 INTEGER array", sym->name,
3322 if (m != MATCH_ERROR)
3324 /* the 1 means to add the optional arg to formal list */
3325 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3327 /* for error reporting, say it's declared where the original was */
3328 new_sym->declared_at = sym->declared_at;
3333 /* no differences for c_loc or c_funloc */
3337 /* set the resolved symbol */
3338 if (m != MATCH_ERROR)
3339 c->resolved_sym = new_sym;
3341 c->resolved_sym = sym;
3347 /* Resolve a subroutine call known to be specific. */
3350 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3354 if(sym->attr.is_iso_c)
3356 m = gfc_iso_c_sub_interface (c,sym);
3360 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3362 if (sym->attr.dummy)
3364 sym->attr.proc = PROC_DUMMY;
3368 sym->attr.proc = PROC_EXTERNAL;
3372 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3375 if (sym->attr.intrinsic)
3377 m = gfc_intrinsic_sub_interface (c, 1);
3381 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3382 "with an intrinsic", sym->name, &c->loc);
3390 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3392 c->resolved_sym = sym;
3393 pure_subroutine (c, sym);
3400 resolve_specific_s (gfc_code *c)
3405 sym = c->symtree->n.sym;
3409 m = resolve_specific_s0 (c, sym);
3412 if (m == MATCH_ERROR)
3415 if (sym->ns->parent == NULL)
3418 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3424 sym = c->symtree->n.sym;
3425 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3426 sym->name, &c->loc);
3432 /* Resolve a subroutine call not known to be generic nor specific. */
3435 resolve_unknown_s (gfc_code *c)
3439 sym = c->symtree->n.sym;
3441 if (sym->attr.dummy)
3443 sym->attr.proc = PROC_DUMMY;
3447 /* See if we have an intrinsic function reference. */
3449 if (gfc_is_intrinsic (sym, 1, c->loc))
3451 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3456 /* The reference is to an external name. */
3459 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3461 c->resolved_sym = sym;
3463 pure_subroutine (c, sym);
3469 /* Resolve a subroutine call. Although it was tempting to use the same code
3470 for functions, subroutines and functions are stored differently and this
3471 makes things awkward. */
3474 resolve_call (gfc_code *c)
3477 procedure_type ptype = PROC_INTRINSIC;
3478 gfc_symbol *csym, *sym;
3479 bool no_formal_args;
3481 csym = c->symtree ? c->symtree->n.sym : NULL;
3483 if (csym && csym->ts.type != BT_UNKNOWN)
3485 gfc_error ("'%s' at %L has a type, which is not consistent with "
3486 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3490 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3493 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3494 sym = st ? st->n.sym : NULL;
3495 if (sym && csym != sym
3496 && sym->ns == gfc_current_ns
3497 && sym->attr.flavor == FL_PROCEDURE
3498 && sym->attr.contained)
3501 if (csym->attr.generic)
3502 c->symtree->n.sym = sym;
3505 csym = c->symtree->n.sym;
3509 /* If this ia a deferred TBP with an abstract interface
3510 (which may of course be referenced), c->expr1 will be set. */
3511 if (csym && csym->attr.abstract && !c->expr1)
3513 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3514 csym->name, &c->loc);
3518 /* Subroutines without the RECURSIVE attribution are not allowed to
3519 * call themselves. */
3520 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3522 if (csym->attr.entry && csym->ns->entries)
3523 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3524 " subroutine '%s' is not RECURSIVE",
3525 csym->name, &c->loc, csym->ns->entries->sym->name);
3527 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3528 " is not RECURSIVE", csym->name, &c->loc);
3533 /* Switch off assumed size checking and do this again for certain kinds
3534 of procedure, once the procedure itself is resolved. */
3535 need_full_assumed_size++;
3538 ptype = csym->attr.proc;
3540 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3541 if (resolve_actual_arglist (c->ext.actual, ptype,
3542 no_formal_args) == FAILURE)
3545 /* Resume assumed_size checking. */
3546 need_full_assumed_size--;
3548 /* If external, check for usage. */
3549 if (csym && is_external_proc (csym))
3550 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3553 if (c->resolved_sym == NULL)
3555 c->resolved_isym = NULL;
3556 switch (procedure_kind (csym))
3559 t = resolve_generic_s (c);
3562 case PTYPE_SPECIFIC:
3563 t = resolve_specific_s (c);
3567 t = resolve_unknown_s (c);
3571 gfc_internal_error ("resolve_subroutine(): bad function type");
3575 /* Some checks of elemental subroutine actual arguments. */
3576 if (resolve_elemental_actual (NULL, c) == FAILURE)
3583 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3584 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3585 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3586 if their shapes do not match. If either op1->shape or op2->shape is
3587 NULL, return SUCCESS. */
3590 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3597 if (op1->shape != NULL && op2->shape != NULL)
3599 for (i = 0; i < op1->rank; i++)
3601 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3603 gfc_error ("Shapes for operands at %L and %L are not conformable",
3604 &op1->where, &op2->where);
3615 /* Resolve an operator expression node. This can involve replacing the
3616 operation with a user defined function call. */
3619 resolve_operator (gfc_expr *e)
3621 gfc_expr *op1, *op2;
3623 bool dual_locus_error;
3626 /* Resolve all subnodes-- give them types. */
3628 switch (e->value.op.op)
3631 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3634 /* Fall through... */
3637 case INTRINSIC_UPLUS:
3638 case INTRINSIC_UMINUS:
3639 case INTRINSIC_PARENTHESES:
3640 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3645 /* Typecheck the new node. */
3647 op1 = e->value.op.op1;
3648 op2 = e->value.op.op2;
3649 dual_locus_error = false;
3651 if ((op1 && op1->expr_type == EXPR_NULL)
3652 || (op2 && op2->expr_type == EXPR_NULL))
3654 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3658 switch (e->value.op.op)
3660 case INTRINSIC_UPLUS:
3661 case INTRINSIC_UMINUS:
3662 if (op1->ts.type == BT_INTEGER
3663 || op1->ts.type == BT_REAL
3664 || op1->ts.type == BT_COMPLEX)
3670 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3671 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3674 case INTRINSIC_PLUS:
3675 case INTRINSIC_MINUS:
3676 case INTRINSIC_TIMES:
3677 case INTRINSIC_DIVIDE:
3678 case INTRINSIC_POWER:
3679 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3681 gfc_type_convert_binary (e, 1);
3686 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3687 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3688 gfc_typename (&op2->ts));
3691 case INTRINSIC_CONCAT:
3692 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3693 && op1->ts.kind == op2->ts.kind)
3695 e->ts.type = BT_CHARACTER;
3696 e->ts.kind = op1->ts.kind;
3701 _("Operands of string concatenation operator at %%L are %s/%s"),
3702 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3708 case INTRINSIC_NEQV:
3709 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3711 e->ts.type = BT_LOGICAL;
3712 e->ts.kind = gfc_kind_max (op1, op2);
3713 if (op1->ts.kind < e->ts.kind)
3714 gfc_convert_type (op1, &e->ts, 2);
3715 else if (op2->ts.kind < e->ts.kind)
3716 gfc_convert_type (op2, &e->ts, 2);
3720 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3721 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3722 gfc_typename (&op2->ts));
3727 if (op1->ts.type == BT_LOGICAL)
3729 e->ts.type = BT_LOGICAL;
3730 e->ts.kind = op1->ts.kind;
3734 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3735 gfc_typename (&op1->ts));
3739 case INTRINSIC_GT_OS:
3741 case INTRINSIC_GE_OS:
3743 case INTRINSIC_LT_OS:
3745 case INTRINSIC_LE_OS:
3746 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3748 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3752 /* Fall through... */
3755 case INTRINSIC_EQ_OS:
3757 case INTRINSIC_NE_OS:
3758 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3759 && op1->ts.kind == op2->ts.kind)
3761 e->ts.type = BT_LOGICAL;
3762 e->ts.kind = gfc_default_logical_kind;
3766 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3768 gfc_type_convert_binary (e, 1);
3770 e->ts.type = BT_LOGICAL;
3771 e->ts.kind = gfc_default_logical_kind;
3775 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3777 _("Logicals at %%L must be compared with %s instead of %s"),
3778 (e->value.op.op == INTRINSIC_EQ
3779 || e->value.op.op == INTRINSIC_EQ_OS)
3780 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3783 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3784 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3785 gfc_typename (&op2->ts));
3789 case INTRINSIC_USER:
3790 if (e->value.op.uop->op == NULL)
3791 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3792 else if (op2 == NULL)
3793 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3794 e->value.op.uop->name, gfc_typename (&op1->ts));
3796 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3797 e->value.op.uop->name, gfc_typename (&op1->ts),
3798 gfc_typename (&op2->ts));
3802 case INTRINSIC_PARENTHESES:
3804 if (e->ts.type == BT_CHARACTER)
3805 e->ts.u.cl = op1->ts.u.cl;
3809 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3812 /* Deal with arrayness of an operand through an operator. */
3816 switch (e->value.op.op)
3818 case INTRINSIC_PLUS:
3819 case INTRINSIC_MINUS:
3820 case INTRINSIC_TIMES:
3821 case INTRINSIC_DIVIDE:
3822 case INTRINSIC_POWER:
3823 case INTRINSIC_CONCAT:
3827 case INTRINSIC_NEQV:
3829 case INTRINSIC_EQ_OS:
3831 case INTRINSIC_NE_OS:
3833 case INTRINSIC_GT_OS:
3835 case INTRINSIC_GE_OS:
3837 case INTRINSIC_LT_OS:
3839 case INTRINSIC_LE_OS:
3841 if (op1->rank == 0 && op2->rank == 0)
3844 if (op1->rank == 0 && op2->rank != 0)
3846 e->rank = op2->rank;
3848 if (e->shape == NULL)
3849 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3852 if (op1->rank != 0 && op2->rank == 0)
3854 e->rank = op1->rank;
3856 if (e->shape == NULL)
3857 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3860 if (op1->rank != 0 && op2->rank != 0)
3862 if (op1->rank == op2->rank)
3864 e->rank = op1->rank;
3865 if (e->shape == NULL)
3867 t = compare_shapes (op1, op2);
3871 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3876 /* Allow higher level expressions to work. */
3879 /* Try user-defined operators, and otherwise throw an error. */
3880 dual_locus_error = true;
3882 _("Inconsistent ranks for operator at %%L and %%L"));
3889 case INTRINSIC_PARENTHESES:
3891 case INTRINSIC_UPLUS:
3892 case INTRINSIC_UMINUS:
3893 /* Simply copy arrayness attribute */
3894 e->rank = op1->rank;
3896 if (e->shape == NULL)
3897 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3905 /* Attempt to simplify the expression. */
3908 t = gfc_simplify_expr (e, 0);
3909 /* Some calls do not succeed in simplification and return FAILURE
3910 even though there is no error; e.g. variable references to
3911 PARAMETER arrays. */
3912 if (!gfc_is_constant_expr (e))
3921 if (gfc_extend_expr (e, &real_error) == SUCCESS)
3928 if (dual_locus_error)
3929 gfc_error (msg, &op1->where, &op2->where);
3931 gfc_error (msg, &e->where);
3937 /************** Array resolution subroutines **************/
3940 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3943 /* Compare two integer expressions. */
3946 compare_bound (gfc_expr *a, gfc_expr *b)
3950 if (a == NULL || a->expr_type != EXPR_CONSTANT
3951 || b == NULL || b->expr_type != EXPR_CONSTANT)
3954 /* If either of the types isn't INTEGER, we must have
3955 raised an error earlier. */
3957 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3960 i = mpz_cmp (a->value.integer, b->value.integer);
3970 /* Compare an integer expression with an integer. */
3973 compare_bound_int (gfc_expr *a, int b)
3977 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3980 if (a->ts.type != BT_INTEGER)
3981 gfc_internal_error ("compare_bound_int(): Bad expression");
3983 i = mpz_cmp_si (a->value.integer, b);
3993 /* Compare an integer expression with a mpz_t. */
3996 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4000 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4003 if (a->ts.type != BT_INTEGER)
4004 gfc_internal_error ("compare_bound_int(): Bad expression");
4006 i = mpz_cmp (a->value.integer, b);
4016 /* Compute the last value of a sequence given by a triplet.
4017 Return 0 if it wasn't able to compute the last value, or if the
4018 sequence if empty, and 1 otherwise. */
4021 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4022 gfc_expr *stride, mpz_t last)
4026 if (start == NULL || start->expr_type != EXPR_CONSTANT
4027 || end == NULL || end->expr_type != EXPR_CONSTANT
4028 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4031 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4032 || (stride != NULL && stride->ts.type != BT_INTEGER))
4035 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
4037 if (compare_bound (start, end) == CMP_GT)
4039 mpz_set (last, end->value.integer);
4043 if (compare_bound_int (stride, 0) == CMP_GT)
4045 /* Stride is positive */
4046 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4051 /* Stride is negative */
4052 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4057 mpz_sub (rem, end->value.integer, start->value.integer);
4058 mpz_tdiv_r (rem, rem, stride->value.integer);
4059 mpz_sub (last, end->value.integer, rem);
4066 /* Compare a single dimension of an array reference to the array
4070 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4074 if (ar->dimen_type[i] == DIMEN_STAR)
4076 gcc_assert (ar->stride[i] == NULL);
4077 /* This implies [*] as [*:] and [*:3] are not possible. */
4078 if (ar->start[i] == NULL)
4080 gcc_assert (ar->end[i] == NULL);
4085 /* Given start, end and stride values, calculate the minimum and
4086 maximum referenced indexes. */
4088 switch (ar->dimen_type[i])
4095 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4098 gfc_warning ("Array reference at %L is out of bounds "
4099 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4100 mpz_get_si (ar->start[i]->value.integer),
4101 mpz_get_si (as->lower[i]->value.integer), i+1);
4103 gfc_warning ("Array reference at %L is out of bounds "
4104 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4105 mpz_get_si (ar->start[i]->value.integer),
4106 mpz_get_si (as->lower[i]->value.integer),
4110 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4113 gfc_warning ("Array reference at %L is out of bounds "
4114 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4115 mpz_get_si (ar->start[i]->value.integer),
4116 mpz_get_si (as->upper[i]->value.integer), i+1);
4118 gfc_warning ("Array reference at %L is out of bounds "
4119 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4120 mpz_get_si (ar->start[i]->value.integer),
4121 mpz_get_si (as->upper[i]->value.integer),
4130 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4131 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4133 comparison comp_start_end = compare_bound (AR_START, AR_END);
4135 /* Check for zero stride, which is not allowed. */
4136 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4138 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4142 /* if start == len || (stride > 0 && start < len)
4143 || (stride < 0 && start > len),
4144 then the array section contains at least one element. In this
4145 case, there is an out-of-bounds access if
4146 (start < lower || start > upper). */
4147 if (compare_bound (AR_START, AR_END) == CMP_EQ
4148 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4149 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4150 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4151 && comp_start_end == CMP_GT))
4153 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4155 gfc_warning ("Lower array reference at %L is out of bounds "
4156 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4157 mpz_get_si (AR_START->value.integer),
4158 mpz_get_si (as->lower[i]->value.integer), i+1);
4161 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4163 gfc_warning ("Lower array reference at %L is out of bounds "
4164 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4165 mpz_get_si (AR_START->value.integer),
4166 mpz_get_si (as->upper[i]->value.integer), i+1);
4171 /* If we can compute the highest index of the array section,
4172 then it also has to be between lower and upper. */
4173 mpz_init (last_value);
4174 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4177 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4179 gfc_warning ("Upper array reference at %L is out of bounds "
4180 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4181 mpz_get_si (last_value),
4182 mpz_get_si (as->lower[i]->value.integer), i+1);
4183 mpz_clear (last_value);
4186 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4188 gfc_warning ("Upper array reference at %L is out of bounds "
4189 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4190 mpz_get_si (last_value),
4191 mpz_get_si (as->upper[i]->value.integer), i+1);
4192 mpz_clear (last_value);
4196 mpz_clear (last_value);
4204 gfc_internal_error ("check_dimension(): Bad array reference");
4211 /* Compare an array reference with an array specification. */
4214 compare_spec_to_ref (gfc_array_ref *ar)
4221 /* TODO: Full array sections are only allowed as actual parameters. */
4222 if (as->type == AS_ASSUMED_SIZE
4223 && (/*ar->type == AR_FULL
4224 ||*/ (ar->type == AR_SECTION
4225 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4227 gfc_error ("Rightmost upper bound of assumed size array section "
4228 "not specified at %L", &ar->where);
4232 if (ar->type == AR_FULL)
4235 if (as->rank != ar->dimen)
4237 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4238 &ar->where, ar->dimen, as->rank);
4242 /* ar->codimen == 0 is a local array. */
4243 if (as->corank != ar->codimen && ar->codimen != 0)
4245 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4246 &ar->where, ar->codimen, as->corank);
4250 for (i = 0; i < as->rank; i++)
4251 if (check_dimension (i, ar, as) == FAILURE)
4254 /* Local access has no coarray spec. */
4255 if (ar->codimen != 0)
4256 for (i = as->rank; i < as->rank + as->corank; i++)
4258 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
4260 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4261 i + 1 - as->rank, &ar->where);
4264 if (check_dimension (i, ar, as) == FAILURE)
4272 /* Resolve one part of an array index. */
4275 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4276 int force_index_integer_kind)
4283 if (gfc_resolve_expr (index) == FAILURE)
4286 if (check_scalar && index->rank != 0)
4288 gfc_error ("Array index at %L must be scalar", &index->where);
4292 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4294 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4295 &index->where, gfc_basic_typename (index->ts.type));
4299 if (index->ts.type == BT_REAL)
4300 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
4301 &index->where) == FAILURE)
4304 if ((index->ts.kind != gfc_index_integer_kind
4305 && force_index_integer_kind)
4306 || index->ts.type != BT_INTEGER)
4309 ts.type = BT_INTEGER;
4310 ts.kind = gfc_index_integer_kind;
4312 gfc_convert_type_warn (index, &ts, 2, 0);
4318 /* Resolve one part of an array index. */
4321 gfc_resolve_index (gfc_expr *index, int check_scalar)
4323 return gfc_resolve_index_1 (index, check_scalar, 1);
4326 /* Resolve a dim argument to an intrinsic function. */
4329 gfc_resolve_dim_arg (gfc_expr *dim)
4334 if (gfc_resolve_expr (dim) == FAILURE)
4339 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4344 if (dim->ts.type != BT_INTEGER)
4346 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4350 if (dim->ts.kind != gfc_index_integer_kind)
4355 ts.type = BT_INTEGER;
4356 ts.kind = gfc_index_integer_kind;
4358 gfc_convert_type_warn (dim, &ts, 2, 0);
4364 /* Given an expression that contains array references, update those array
4365 references to point to the right array specifications. While this is
4366 filled in during matching, this information is difficult to save and load
4367 in a module, so we take care of it here.
4369 The idea here is that the original array reference comes from the
4370 base symbol. We traverse the list of reference structures, setting
4371 the stored reference to references. Component references can
4372 provide an additional array specification. */
4375 find_array_spec (gfc_expr *e)
4379 gfc_symbol *derived;
4382 if (e->symtree->n.sym->ts.type == BT_CLASS)
4383 as = CLASS_DATA (e->symtree->n.sym)->as;
4385 as = e->symtree->n.sym->as;
4388 for (ref = e->ref; ref; ref = ref->next)
4393 gfc_internal_error ("find_array_spec(): Missing spec");
4400 if (derived == NULL)
4401 derived = e->symtree->n.sym->ts.u.derived;
4403 if (derived->attr.is_class)
4404 derived = derived->components->ts.u.derived;
4406 c = derived->components;
4408 for (; c; c = c->next)
4409 if (c == ref->u.c.component)
4411 /* Track the sequence of component references. */
4412 if (c->ts.type == BT_DERIVED)
4413 derived = c->ts.u.derived;
4418 gfc_internal_error ("find_array_spec(): Component not found");
4420 if (c->attr.dimension)
4423 gfc_internal_error ("find_array_spec(): unused as(1)");
4434 gfc_internal_error ("find_array_spec(): unused as(2)");
4438 /* Resolve an array reference. */
4441 resolve_array_ref (gfc_array_ref *ar)
4443 int i, check_scalar;
4446 for (i = 0; i < ar->dimen + ar->codimen; i++)
4448 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4450 /* Do not force gfc_index_integer_kind for the start. We can
4451 do fine with any integer kind. This avoids temporary arrays
4452 created for indexing with a vector. */
4453 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4455 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4457 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4462 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4466 ar->dimen_type[i] = DIMEN_ELEMENT;
4470 ar->dimen_type[i] = DIMEN_VECTOR;
4471 if (e->expr_type == EXPR_VARIABLE
4472 && e->symtree->n.sym->ts.type == BT_DERIVED)
4473 ar->start[i] = gfc_get_parentheses (e);
4477 gfc_error ("Array index at %L is an array of rank %d",
4478 &ar->c_where[i], e->rank);
4482 /* Fill in the upper bound, which may be lower than the
4483 specified one for something like a(2:10:5), which is
4484 identical to a(2:7:5). Only relevant for strides not equal
4486 if (ar->dimen_type[i] == DIMEN_RANGE
4487 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4488 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0)
4492 if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4494 if (ar->end[i] == NULL)
4497 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4499 mpz_set (ar->end[i]->value.integer, end);
4501 else if (ar->end[i]->ts.type == BT_INTEGER
4502 && ar->end[i]->expr_type == EXPR_CONSTANT)
4504 mpz_set (ar->end[i]->value.integer, end);
4515 if (ar->type == AR_FULL && ar->as->rank == 0)
4516 ar->type = AR_ELEMENT;
4518 /* If the reference type is unknown, figure out what kind it is. */
4520 if (ar->type == AR_UNKNOWN)
4522 ar->type = AR_ELEMENT;
4523 for (i = 0; i < ar->dimen; i++)
4524 if (ar->dimen_type[i] == DIMEN_RANGE
4525 || ar->dimen_type[i] == DIMEN_VECTOR)
4527 ar->type = AR_SECTION;
4532 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4540 resolve_substring (gfc_ref *ref)
4542 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4544 if (ref->u.ss.start != NULL)
4546 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4549 if (ref->u.ss.start->ts.type != BT_INTEGER)
4551 gfc_error ("Substring start index at %L must be of type INTEGER",
4552 &ref->u.ss.start->where);
4556 if (ref->u.ss.start->rank != 0)
4558 gfc_error ("Substring start index at %L must be scalar",
4559 &ref->u.ss.start->where);
4563 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4564 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4565 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4567 gfc_error ("Substring start index at %L is less than one",
4568 &ref->u.ss.start->where);
4573 if (ref->u.ss.end != NULL)
4575 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4578 if (ref->u.ss.end->ts.type != BT_INTEGER)
4580 gfc_error ("Substring end index at %L must be of type INTEGER",
4581 &ref->u.ss.end->where);
4585 if (ref->u.ss.end->rank != 0)
4587 gfc_error ("Substring end index at %L must be scalar",
4588 &ref->u.ss.end->where);
4592 if (ref->u.ss.length != NULL
4593 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4594 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4595 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4597 gfc_error ("Substring end index at %L exceeds the string length",
4598 &ref->u.ss.start->where);
4602 if (compare_bound_mpz_t (ref->u.ss.end,
4603 gfc_integer_kinds[k].huge) == CMP_GT
4604 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4605 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4607 gfc_error ("Substring end index at %L is too large",
4608 &ref->u.ss.end->where);
4617 /* This function supplies missing substring charlens. */
4620 gfc_resolve_substring_charlen (gfc_expr *e)
4623 gfc_expr *start, *end;
4625 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4626 if (char_ref->type == REF_SUBSTRING)
4632 gcc_assert (char_ref->next == NULL);
4636 if (e->ts.u.cl->length)
4637 gfc_free_expr (e->ts.u.cl->length);
4638 else if (e->expr_type == EXPR_VARIABLE
4639 && e->symtree->n.sym->attr.dummy)
4643 e->ts.type = BT_CHARACTER;
4644 e->ts.kind = gfc_default_character_kind;
4647 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4649 if (char_ref->u.ss.start)
4650 start = gfc_copy_expr (char_ref->u.ss.start);
4652 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4654 if (char_ref->u.ss.end)
4655 end = gfc_copy_expr (char_ref->u.ss.end);
4656 else if (e->expr_type == EXPR_VARIABLE)
4657 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4664 /* Length = (end - start +1). */
4665 e->ts.u.cl->length = gfc_subtract (end, start);
4666 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4667 gfc_get_int_expr (gfc_default_integer_kind,
4670 e->ts.u.cl->length->ts.type = BT_INTEGER;
4671 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4673 /* Make sure that the length is simplified. */
4674 gfc_simplify_expr (e->ts.u.cl->length, 1);
4675 gfc_resolve_expr (e->ts.u.cl->length);
4679 /* Resolve subtype references. */
4682 resolve_ref (gfc_expr *expr)
4684 int current_part_dimension, n_components, seen_part_dimension;
4687 for (ref = expr->ref; ref; ref = ref->next)
4688 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4690 find_array_spec (expr);
4694 for (ref = expr->ref; ref; ref = ref->next)
4698 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4706 resolve_substring (ref);
4710 /* Check constraints on part references. */
4712 current_part_dimension = 0;
4713 seen_part_dimension = 0;
4716 for (ref = expr->ref; ref; ref = ref->next)
4721 switch (ref->u.ar.type)
4724 /* Coarray scalar. */
4725 if (ref->u.ar.as->rank == 0)
4727 current_part_dimension = 0;
4732 current_part_dimension = 1;
4736 current_part_dimension = 0;
4740 gfc_internal_error ("resolve_ref(): Bad array reference");
4746 if (current_part_dimension || seen_part_dimension)
4749 if (ref->u.c.component->attr.pointer
4750 || ref->u.c.component->attr.proc_pointer)
4752 gfc_error ("Component to the right of a part reference "
4753 "with nonzero rank must not have the POINTER "
4754 "attribute at %L", &expr->where);
4757 else if (ref->u.c.component->attr.allocatable)
4759 gfc_error ("Component to the right of a part reference "
4760 "with nonzero rank must not have the ALLOCATABLE "
4761 "attribute at %L", &expr->where);
4773 if (((ref->type == REF_COMPONENT && n_components > 1)
4774 || ref->next == NULL)
4775 && current_part_dimension
4776 && seen_part_dimension)
4778 gfc_error ("Two or more part references with nonzero rank must "
4779 "not be specified at %L", &expr->where);
4783 if (ref->type == REF_COMPONENT)
4785 if (current_part_dimension)
4786 seen_part_dimension = 1;
4788 /* reset to make sure */
4789 current_part_dimension = 0;
4797 /* Given an expression, determine its shape. This is easier than it sounds.
4798 Leaves the shape array NULL if it is not possible to determine the shape. */
4801 expression_shape (gfc_expr *e)
4803 mpz_t array[GFC_MAX_DIMENSIONS];
4806 if (e->rank == 0 || e->shape != NULL)
4809 for (i = 0; i < e->rank; i++)
4810 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4813 e->shape = gfc_get_shape (e->rank);
4815 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4820 for (i--; i >= 0; i--)
4821 mpz_clear (array[i]);
4825 /* Given a variable expression node, compute the rank of the expression by
4826 examining the base symbol and any reference structures it may have. */
4829 expression_rank (gfc_expr *e)
4834 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4835 could lead to serious confusion... */
4836 gcc_assert (e->expr_type != EXPR_COMPCALL);
4840 if (e->expr_type == EXPR_ARRAY)
4842 /* Constructors can have a rank different from one via RESHAPE(). */
4844 if (e->symtree == NULL)
4850 e->rank = (e->symtree->n.sym->as == NULL)
4851 ? 0 : e->symtree->n.sym->as->rank;
4857 for (ref = e->ref; ref; ref = ref->next)
4859 if (ref->type != REF_ARRAY)
4862 if (ref->u.ar.type == AR_FULL)
4864 rank = ref->u.ar.as->rank;
4868 if (ref->u.ar.type == AR_SECTION)
4870 /* Figure out the rank of the section. */
4872 gfc_internal_error ("expression_rank(): Two array specs");
4874 for (i = 0; i < ref->u.ar.dimen; i++)
4875 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4876 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4886 expression_shape (e);
4890 /* Resolve a variable expression. */
4893 resolve_variable (gfc_expr *e)
4900 if (e->symtree == NULL)
4902 sym = e->symtree->n.sym;
4904 /* If this is an associate-name, it may be parsed with an array reference
4905 in error even though the target is scalar. Fail directly in this case. */
4906 if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
4909 /* On the other hand, the parser may not have known this is an array;
4910 in this case, we have to add a FULL reference. */
4911 if (sym->assoc && sym->attr.dimension && !e->ref)
4913 e->ref = gfc_get_ref ();
4914 e->ref->type = REF_ARRAY;
4915 e->ref->u.ar.type = AR_FULL;
4916 e->ref->u.ar.dimen = 0;
4919 if (e->ref && resolve_ref (e) == FAILURE)
4922 if (sym->attr.flavor == FL_PROCEDURE
4923 && (!sym->attr.function
4924 || (sym->attr.function && sym->result
4925 && sym->result->attr.proc_pointer
4926 && !sym->result->attr.function)))
4928 e->ts.type = BT_PROCEDURE;
4929 goto resolve_procedure;
4932 if (sym->ts.type != BT_UNKNOWN)
4933 gfc_variable_attr (e, &e->ts);
4936 /* Must be a simple variable reference. */
4937 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4942 if (check_assumed_size_reference (sym, e))
4945 /* Deal with forward references to entries during resolve_code, to
4946 satisfy, at least partially, 12.5.2.5. */
4947 if (gfc_current_ns->entries
4948 && current_entry_id == sym->entry_id
4951 && cs_base->current->op != EXEC_ENTRY)
4953 gfc_entry_list *entry;
4954 gfc_formal_arglist *formal;
4958 /* If the symbol is a dummy... */
4959 if (sym->attr.dummy && sym->ns == gfc_current_ns)
4961 entry = gfc_current_ns->entries;
4964 /* ...test if the symbol is a parameter of previous entries. */
4965 for (; entry && entry->id <= current_entry_id; entry = entry->next)
4966 for (formal = entry->sym->formal; formal; formal = formal->next)
4968 if (formal->sym && sym->name == formal->sym->name)
4972 /* If it has not been seen as a dummy, this is an error. */
4975 if (specification_expr)
4976 gfc_error ("Variable '%s', used in a specification expression"
4977 ", is referenced at %L before the ENTRY statement "
4978 "in which it is a parameter",
4979 sym->name, &cs_base->current->loc);
4981 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4982 "statement in which it is a parameter",
4983 sym->name, &cs_base->current->loc);
4988 /* Now do the same check on the specification expressions. */
4989 specification_expr = 1;
4990 if (sym->ts.type == BT_CHARACTER
4991 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
4995 for (n = 0; n < sym->as->rank; n++)
4997 specification_expr = 1;
4998 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
5000 specification_expr = 1;
5001 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
5004 specification_expr = 0;
5007 /* Update the symbol's entry level. */
5008 sym->entry_id = current_entry_id + 1;
5011 /* If a symbol has been host_associated mark it. This is used latter,
5012 to identify if aliasing is possible via host association. */
5013 if (sym->attr.flavor == FL_VARIABLE
5014 && gfc_current_ns->parent
5015 && (gfc_current_ns->parent == sym->ns
5016 || (gfc_current_ns->parent->parent
5017 && gfc_current_ns->parent->parent == sym->ns)))
5018 sym->attr.host_assoc = 1;
5021 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
5024 /* F2008, C617 and C1229. */
5025 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5026 && gfc_is_coindexed (e))
5028 gfc_ref *ref, *ref2 = NULL;
5030 if (e->ts.type == BT_CLASS)
5032 gfc_error ("Polymorphic subobject of coindexed object at %L",
5037 for (ref = e->ref; ref; ref = ref->next)
5039 if (ref->type == REF_COMPONENT)
5041 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5045 for ( ; ref; ref = ref->next)
5046 if (ref->type == REF_COMPONENT)
5049 /* Expression itself is coindexed object. */
5053 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5054 for ( ; c; c = c->next)
5055 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5057 gfc_error ("Coindexed object with polymorphic allocatable "
5058 "subcomponent at %L", &e->where);
5069 /* Checks to see that the correct symbol has been host associated.
5070 The only situation where this arises is that in which a twice
5071 contained function is parsed after the host association is made.
5072 Therefore, on detecting this, change the symbol in the expression
5073 and convert the array reference into an actual arglist if the old
5074 symbol is a variable. */
5076 check_host_association (gfc_expr *e)
5078 gfc_symbol *sym, *old_sym;
5082 gfc_actual_arglist *arg, *tail = NULL;
5083 bool retval = e->expr_type == EXPR_FUNCTION;
5085 /* If the expression is the result of substitution in
5086 interface.c(gfc_extend_expr) because there is no way in
5087 which the host association can be wrong. */
5088 if (e->symtree == NULL
5089 || e->symtree->n.sym == NULL
5090 || e->user_operator)
5093 old_sym = e->symtree->n.sym;
5095 if (gfc_current_ns->parent
5096 && old_sym->ns != gfc_current_ns)
5098 /* Use the 'USE' name so that renamed module symbols are
5099 correctly handled. */
5100 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5102 if (sym && old_sym != sym
5103 && sym->ts.type == old_sym->ts.type
5104 && sym->attr.flavor == FL_PROCEDURE
5105 && sym->attr.contained)
5107 /* Clear the shape, since it might not be valid. */
5108 if (e->shape != NULL)
5110 for (n = 0; n < e->rank; n++)
5111 mpz_clear (e->shape[n]);
5113 gfc_free (e->shape);
5116 /* Give the expression the right symtree! */
5117 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5118 gcc_assert (st != NULL);
5120 if (old_sym->attr.flavor == FL_PROCEDURE
5121 || e->expr_type == EXPR_FUNCTION)
5123 /* Original was function so point to the new symbol, since
5124 the actual argument list is already attached to the
5126 e->value.function.esym = NULL;
5131 /* Original was variable so convert array references into
5132 an actual arglist. This does not need any checking now
5133 since gfc_resolve_function will take care of it. */
5134 e->value.function.actual = NULL;
5135 e->expr_type = EXPR_FUNCTION;
5138 /* Ambiguity will not arise if the array reference is not
5139 the last reference. */
5140 for (ref = e->ref; ref; ref = ref->next)
5141 if (ref->type == REF_ARRAY && ref->next == NULL)
5144 gcc_assert (ref->type == REF_ARRAY);
5146 /* Grab the start expressions from the array ref and
5147 copy them into actual arguments. */
5148 for (n = 0; n < ref->u.ar.dimen; n++)
5150 arg = gfc_get_actual_arglist ();
5151 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5152 if (e->value.function.actual == NULL)
5153 tail = e->value.function.actual = arg;
5161 /* Dump the reference list and set the rank. */
5162 gfc_free_ref_list (e->ref);
5164 e->rank = sym->as ? sym->as->rank : 0;
5167 gfc_resolve_expr (e);
5171 /* This might have changed! */
5172 return e->expr_type == EXPR_FUNCTION;
5177 gfc_resolve_character_operator (gfc_expr *e)
5179 gfc_expr *op1 = e->value.op.op1;
5180 gfc_expr *op2 = e->value.op.op2;
5181 gfc_expr *e1 = NULL;
5182 gfc_expr *e2 = NULL;
5184 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5186 if (op1->ts.u.cl && op1->ts.u.cl->length)
5187 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5188 else if (op1->expr_type == EXPR_CONSTANT)
5189 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5190 op1->value.character.length);
5192 if (op2->ts.u.cl && op2->ts.u.cl->length)
5193 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5194 else if (op2->expr_type == EXPR_CONSTANT)
5195 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5196 op2->value.character.length);
5198 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5203 e->ts.u.cl->length = gfc_add (e1, e2);
5204 e->ts.u.cl->length->ts.type = BT_INTEGER;
5205 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5206 gfc_simplify_expr (e->ts.u.cl->length, 0);
5207 gfc_resolve_expr (e->ts.u.cl->length);
5213 /* Ensure that an character expression has a charlen and, if possible, a
5214 length expression. */
5217 fixup_charlen (gfc_expr *e)
5219 /* The cases fall through so that changes in expression type and the need
5220 for multiple fixes are picked up. In all circumstances, a charlen should
5221 be available for the middle end to hang a backend_decl on. */
5222 switch (e->expr_type)
5225 gfc_resolve_character_operator (e);
5228 if (e->expr_type == EXPR_ARRAY)
5229 gfc_resolve_character_array_constructor (e);
5231 case EXPR_SUBSTRING:
5232 if (!e->ts.u.cl && e->ref)
5233 gfc_resolve_substring_charlen (e);
5237 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5244 /* Update an actual argument to include the passed-object for type-bound
5245 procedures at the right position. */
5247 static gfc_actual_arglist*
5248 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5251 gcc_assert (argpos > 0);
5255 gfc_actual_arglist* result;
5257 result = gfc_get_actual_arglist ();
5261 result->name = name;
5267 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5269 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5274 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5277 extract_compcall_passed_object (gfc_expr* e)
5281 gcc_assert (e->expr_type == EXPR_COMPCALL);
5283 if (e->value.compcall.base_object)
5284 po = gfc_copy_expr (e->value.compcall.base_object);
5287 po = gfc_get_expr ();
5288 po->expr_type = EXPR_VARIABLE;
5289 po->symtree = e->symtree;
5290 po->ref = gfc_copy_ref (e->ref);
5291 po->where = e->where;
5294 if (gfc_resolve_expr (po) == FAILURE)
5301 /* Update the arglist of an EXPR_COMPCALL expression to include the
5305 update_compcall_arglist (gfc_expr* e)
5308 gfc_typebound_proc* tbp;
5310 tbp = e->value.compcall.tbp;
5315 po = extract_compcall_passed_object (e);
5319 if (tbp->nopass || e->value.compcall.ignore_pass)
5325 gcc_assert (tbp->pass_arg_num > 0);
5326 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5334 /* Extract the passed object from a PPC call (a copy of it). */
5337 extract_ppc_passed_object (gfc_expr *e)
5342 po = gfc_get_expr ();
5343 po->expr_type = EXPR_VARIABLE;
5344 po->symtree = e->symtree;
5345 po->ref = gfc_copy_ref (e->ref);
5346 po->where = e->where;
5348 /* Remove PPC reference. */
5350 while ((*ref)->next)
5351 ref = &(*ref)->next;
5352 gfc_free_ref_list (*ref);
5355 if (gfc_resolve_expr (po) == FAILURE)
5362 /* Update the actual arglist of a procedure pointer component to include the
5366 update_ppc_arglist (gfc_expr* e)
5370 gfc_typebound_proc* tb;
5372 if (!gfc_is_proc_ptr_comp (e, &ppc))
5379 else if (tb->nopass)
5382 po = extract_ppc_passed_object (e);
5389 gfc_error ("Passed-object at %L must be scalar", &e->where);
5394 if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
5396 gfc_error ("Base object for procedure-pointer component call at %L is of"
5397 " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name);
5401 gcc_assert (tb->pass_arg_num > 0);
5402 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5410 /* Check that the object a TBP is called on is valid, i.e. it must not be
5411 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5414 check_typebound_baseobject (gfc_expr* e)
5417 gfc_try return_value = FAILURE;
5419 base = extract_compcall_passed_object (e);
5423 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5426 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5428 gfc_error ("Base object for type-bound procedure call at %L is of"
5429 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5433 /* F08:C1230. If the procedure called is NOPASS,
5434 the base object must be scalar. */
5435 if (e->value.compcall.tbp->nopass && base->rank > 0)
5437 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5438 " be scalar", &e->where);
5442 /* FIXME: Remove once PR 43214 is fixed (TBP with non-scalar PASS). */
5445 gfc_error ("Non-scalar base object at %L currently not implemented",
5450 return_value = SUCCESS;
5453 gfc_free_expr (base);
5454 return return_value;
5458 /* Resolve a call to a type-bound procedure, either function or subroutine,
5459 statically from the data in an EXPR_COMPCALL expression. The adapted
5460 arglist and the target-procedure symtree are returned. */
5463 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5464 gfc_actual_arglist** actual)
5466 gcc_assert (e->expr_type == EXPR_COMPCALL);
5467 gcc_assert (!e->value.compcall.tbp->is_generic);
5469 /* Update the actual arglist for PASS. */
5470 if (update_compcall_arglist (e) == FAILURE)
5473 *actual = e->value.compcall.actual;
5474 *target = e->value.compcall.tbp->u.specific;
5476 gfc_free_ref_list (e->ref);
5478 e->value.compcall.actual = NULL;
5484 /* Get the ultimate declared type from an expression. In addition,
5485 return the last class/derived type reference and the copy of the
5488 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5491 gfc_symbol *declared;
5498 *new_ref = gfc_copy_ref (e->ref);
5500 for (ref = e->ref; ref; ref = ref->next)
5502 if (ref->type != REF_COMPONENT)
5505 if (ref->u.c.component->ts.type == BT_CLASS
5506 || ref->u.c.component->ts.type == BT_DERIVED)
5508 declared = ref->u.c.component->ts.u.derived;
5514 if (declared == NULL)
5515 declared = e->symtree->n.sym->ts.u.derived;
5521 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5522 which of the specific bindings (if any) matches the arglist and transform
5523 the expression into a call of that binding. */
5526 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5528 gfc_typebound_proc* genproc;
5529 const char* genname;
5531 gfc_symbol *derived;
5533 gcc_assert (e->expr_type == EXPR_COMPCALL);
5534 genname = e->value.compcall.name;
5535 genproc = e->value.compcall.tbp;
5537 if (!genproc->is_generic)
5540 /* Try the bindings on this type and in the inheritance hierarchy. */
5541 for (; genproc; genproc = genproc->overridden)
5545 gcc_assert (genproc->is_generic);
5546 for (g = genproc->u.generic; g; g = g->next)
5549 gfc_actual_arglist* args;
5552 gcc_assert (g->specific);
5554 if (g->specific->error)
5557 target = g->specific->u.specific->n.sym;
5559 /* Get the right arglist by handling PASS/NOPASS. */
5560 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5561 if (!g->specific->nopass)
5564 po = extract_compcall_passed_object (e);
5568 gcc_assert (g->specific->pass_arg_num > 0);
5569 gcc_assert (!g->specific->error);
5570 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5571 g->specific->pass_arg);
5573 resolve_actual_arglist (args, target->attr.proc,
5574 is_external_proc (target) && !target->formal);
5576 /* Check if this arglist matches the formal. */
5577 matches = gfc_arglist_matches_symbol (&args, target);
5579 /* Clean up and break out of the loop if we've found it. */
5580 gfc_free_actual_arglist (args);
5583 e->value.compcall.tbp = g->specific;
5584 genname = g->specific_st->name;
5585 /* Pass along the name for CLASS methods, where the vtab
5586 procedure pointer component has to be referenced. */
5594 /* Nothing matching found! */
5595 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5596 " '%s' at %L", genname, &e->where);
5600 /* Make sure that we have the right specific instance for the name. */
5601 derived = get_declared_from_expr (NULL, NULL, e);
5603 st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where);
5605 e->value.compcall.tbp = st->n.tb;
5611 /* Resolve a call to a type-bound subroutine. */
5614 resolve_typebound_call (gfc_code* c, const char **name)
5616 gfc_actual_arglist* newactual;
5617 gfc_symtree* target;
5619 /* Check that's really a SUBROUTINE. */
5620 if (!c->expr1->value.compcall.tbp->subroutine)
5622 gfc_error ("'%s' at %L should be a SUBROUTINE",
5623 c->expr1->value.compcall.name, &c->loc);
5627 if (check_typebound_baseobject (c->expr1) == FAILURE)
5630 /* Pass along the name for CLASS methods, where the vtab
5631 procedure pointer component has to be referenced. */
5633 *name = c->expr1->value.compcall.name;
5635 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5638 /* Transform into an ordinary EXEC_CALL for now. */
5640 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5643 c->ext.actual = newactual;
5644 c->symtree = target;
5645 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5647 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5649 gfc_free_expr (c->expr1);
5650 c->expr1 = gfc_get_expr ();
5651 c->expr1->expr_type = EXPR_FUNCTION;
5652 c->expr1->symtree = target;
5653 c->expr1->where = c->loc;
5655 return resolve_call (c);
5659 /* Resolve a component-call expression. */
5661 resolve_compcall (gfc_expr* e, const char **name)
5663 gfc_actual_arglist* newactual;
5664 gfc_symtree* target;
5666 /* Check that's really a FUNCTION. */
5667 if (!e->value.compcall.tbp->function)
5669 gfc_error ("'%s' at %L should be a FUNCTION",
5670 e->value.compcall.name, &e->where);
5674 /* These must not be assign-calls! */
5675 gcc_assert (!e->value.compcall.assign);
5677 if (check_typebound_baseobject (e) == FAILURE)
5680 /* Pass along the name for CLASS methods, where the vtab
5681 procedure pointer component has to be referenced. */
5683 *name = e->value.compcall.name;
5685 if (resolve_typebound_generic_call (e, name) == FAILURE)
5687 gcc_assert (!e->value.compcall.tbp->is_generic);
5689 /* Take the rank from the function's symbol. */
5690 if (e->value.compcall.tbp->u.specific->n.sym->as)
5691 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5693 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5694 arglist to the TBP's binding target. */
5696 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5699 e->value.function.actual = newactual;
5700 e->value.function.name = NULL;
5701 e->value.function.esym = target->n.sym;
5702 e->value.function.isym = NULL;
5703 e->symtree = target;
5704 e->ts = target->n.sym->ts;
5705 e->expr_type = EXPR_FUNCTION;
5707 /* Resolution is not necessary if this is a class subroutine; this
5708 function only has to identify the specific proc. Resolution of
5709 the call will be done next in resolve_typebound_call. */
5710 return gfc_resolve_expr (e);
5715 /* Resolve a typebound function, or 'method'. First separate all
5716 the non-CLASS references by calling resolve_compcall directly. */
5719 resolve_typebound_function (gfc_expr* e)
5721 gfc_symbol *declared;
5732 /* Deal with typebound operators for CLASS objects. */
5733 expr = e->value.compcall.base_object;
5734 if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
5736 /* Since the typebound operators are generic, we have to ensure
5737 that any delays in resolution are corrected and that the vtab
5740 declared = ts.u.derived;
5741 c = gfc_find_component (declared, "_vptr", true, true);
5742 if (c->ts.u.derived == NULL)
5743 c->ts.u.derived = gfc_find_derived_vtab (declared);
5745 if (resolve_compcall (e, &name) == FAILURE)
5748 /* Use the generic name if it is there. */
5749 name = name ? name : e->value.function.esym->name;
5750 e->symtree = expr->symtree;
5751 e->ref = gfc_copy_ref (expr->ref);
5752 gfc_add_vptr_component (e);
5753 gfc_add_component_ref (e, name);
5754 e->value.function.esym = NULL;
5759 return resolve_compcall (e, NULL);
5761 if (resolve_ref (e) == FAILURE)
5764 /* Get the CLASS declared type. */
5765 declared = get_declared_from_expr (&class_ref, &new_ref, e);
5767 /* Weed out cases of the ultimate component being a derived type. */
5768 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5769 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5771 gfc_free_ref_list (new_ref);
5772 return resolve_compcall (e, NULL);
5775 c = gfc_find_component (declared, "_data", true, true);
5776 declared = c->ts.u.derived;
5778 /* Treat the call as if it is a typebound procedure, in order to roll
5779 out the correct name for the specific function. */
5780 if (resolve_compcall (e, &name) == FAILURE)
5784 /* Then convert the expression to a procedure pointer component call. */
5785 e->value.function.esym = NULL;
5791 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5792 gfc_add_vptr_component (e);
5793 gfc_add_component_ref (e, name);
5795 /* Recover the typespec for the expression. This is really only
5796 necessary for generic procedures, where the additional call
5797 to gfc_add_component_ref seems to throw the collection of the
5798 correct typespec. */
5803 /* Resolve a typebound subroutine, or 'method'. First separate all
5804 the non-CLASS references by calling resolve_typebound_call
5808 resolve_typebound_subroutine (gfc_code *code)
5810 gfc_symbol *declared;
5819 st = code->expr1->symtree;
5821 /* Deal with typebound operators for CLASS objects. */
5822 expr = code->expr1->value.compcall.base_object;
5823 if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
5824 && code->expr1->value.compcall.name)
5826 /* Since the typebound operators are generic, we have to ensure
5827 that any delays in resolution are corrected and that the vtab
5829 ts = expr->symtree->n.sym->ts;
5830 declared = ts.u.derived;
5831 c = gfc_find_component (declared, "_vptr", true, true);
5832 if (c->ts.u.derived == NULL)
5833 c->ts.u.derived = gfc_find_derived_vtab (declared);
5835 if (resolve_typebound_call (code, &name) == FAILURE)
5838 /* Use the generic name if it is there. */
5839 name = name ? name : code->expr1->value.function.esym->name;
5840 code->expr1->symtree = expr->symtree;
5841 expr->symtree->n.sym->ts.u.derived = declared;
5842 gfc_add_vptr_component (code->expr1);
5843 gfc_add_component_ref (code->expr1, name);
5844 code->expr1->value.function.esym = NULL;
5849 return resolve_typebound_call (code, NULL);
5851 if (resolve_ref (code->expr1) == FAILURE)
5854 /* Get the CLASS declared type. */
5855 get_declared_from_expr (&class_ref, &new_ref, code->expr1);
5857 /* Weed out cases of the ultimate component being a derived type. */
5858 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5859 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5861 gfc_free_ref_list (new_ref);
5862 return resolve_typebound_call (code, NULL);
5865 if (resolve_typebound_call (code, &name) == FAILURE)
5867 ts = code->expr1->ts;
5869 /* Then convert the expression to a procedure pointer component call. */
5870 code->expr1->value.function.esym = NULL;
5871 code->expr1->symtree = st;
5874 code->expr1->ref = new_ref;
5876 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5877 gfc_add_vptr_component (code->expr1);
5878 gfc_add_component_ref (code->expr1, name);
5880 /* Recover the typespec for the expression. This is really only
5881 necessary for generic procedures, where the additional call
5882 to gfc_add_component_ref seems to throw the collection of the
5883 correct typespec. */
5884 code->expr1->ts = ts;
5889 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5892 resolve_ppc_call (gfc_code* c)
5894 gfc_component *comp;
5897 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
5900 c->resolved_sym = c->expr1->symtree->n.sym;
5901 c->expr1->expr_type = EXPR_VARIABLE;
5903 if (!comp->attr.subroutine)
5904 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
5906 if (resolve_ref (c->expr1) == FAILURE)
5909 if (update_ppc_arglist (c->expr1) == FAILURE)
5912 c->ext.actual = c->expr1->value.compcall.actual;
5914 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
5915 comp->formal == NULL) == FAILURE)
5918 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
5924 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5927 resolve_expr_ppc (gfc_expr* e)
5929 gfc_component *comp;
5932 b = gfc_is_proc_ptr_comp (e, &comp);
5935 /* Convert to EXPR_FUNCTION. */
5936 e->expr_type = EXPR_FUNCTION;
5937 e->value.function.isym = NULL;
5938 e->value.function.actual = e->value.compcall.actual;
5940 if (comp->as != NULL)
5941 e->rank = comp->as->rank;
5943 if (!comp->attr.function)
5944 gfc_add_function (&comp->attr, comp->name, &e->where);
5946 if (resolve_ref (e) == FAILURE)
5949 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
5950 comp->formal == NULL) == FAILURE)
5953 if (update_ppc_arglist (e) == FAILURE)
5956 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
5963 gfc_is_expandable_expr (gfc_expr *e)
5965 gfc_constructor *con;
5967 if (e->expr_type == EXPR_ARRAY)
5969 /* Traverse the constructor looking for variables that are flavor
5970 parameter. Parameters must be expanded since they are fully used at
5972 con = gfc_constructor_first (e->value.constructor);
5973 for (; con; con = gfc_constructor_next (con))
5975 if (con->expr->expr_type == EXPR_VARIABLE
5976 && con->expr->symtree
5977 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
5978 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
5980 if (con->expr->expr_type == EXPR_ARRAY
5981 && gfc_is_expandable_expr (con->expr))
5989 /* Resolve an expression. That is, make sure that types of operands agree
5990 with their operators, intrinsic operators are converted to function calls
5991 for overloaded types and unresolved function references are resolved. */
5994 gfc_resolve_expr (gfc_expr *e)
6002 /* inquiry_argument only applies to variables. */
6003 inquiry_save = inquiry_argument;
6004 if (e->expr_type != EXPR_VARIABLE)
6005 inquiry_argument = false;
6007 switch (e->expr_type)
6010 t = resolve_operator (e);
6016 if (check_host_association (e))
6017 t = resolve_function (e);
6020 t = resolve_variable (e);
6022 expression_rank (e);
6025 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6026 && e->ref->type != REF_SUBSTRING)
6027 gfc_resolve_substring_charlen (e);
6032 t = resolve_typebound_function (e);
6035 case EXPR_SUBSTRING:
6036 t = resolve_ref (e);
6045 t = resolve_expr_ppc (e);
6050 if (resolve_ref (e) == FAILURE)
6053 t = gfc_resolve_array_constructor (e);
6054 /* Also try to expand a constructor. */
6057 expression_rank (e);
6058 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6059 gfc_expand_constructor (e, false);
6062 /* This provides the opportunity for the length of constructors with
6063 character valued function elements to propagate the string length
6064 to the expression. */
6065 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6067 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6068 here rather then add a duplicate test for it above. */
6069 gfc_expand_constructor (e, false);
6070 t = gfc_resolve_character_array_constructor (e);
6075 case EXPR_STRUCTURE:
6076 t = resolve_ref (e);
6080 t = resolve_structure_cons (e, 0);
6084 t = gfc_simplify_expr (e, 0);
6088 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6091 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6094 inquiry_argument = inquiry_save;
6100 /* Resolve an expression from an iterator. They must be scalar and have
6101 INTEGER or (optionally) REAL type. */
6104 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6105 const char *name_msgid)
6107 if (gfc_resolve_expr (expr) == FAILURE)
6110 if (expr->rank != 0)
6112 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6116 if (expr->ts.type != BT_INTEGER)
6118 if (expr->ts.type == BT_REAL)
6121 return gfc_notify_std (GFC_STD_F95_DEL,
6122 "Deleted feature: %s at %L must be integer",
6123 _(name_msgid), &expr->where);
6126 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6133 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6141 /* Resolve the expressions in an iterator structure. If REAL_OK is
6142 false allow only INTEGER type iterators, otherwise allow REAL types. */
6145 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6147 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6151 if (gfc_check_vardef_context (iter->var, false, _("iterator variable"))
6155 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6156 "Start expression in DO loop") == FAILURE)
6159 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6160 "End expression in DO loop") == FAILURE)
6163 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6164 "Step expression in DO loop") == FAILURE)
6167 if (iter->step->expr_type == EXPR_CONSTANT)
6169 if ((iter->step->ts.type == BT_INTEGER
6170 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6171 || (iter->step->ts.type == BT_REAL
6172 && mpfr_sgn (iter->step->value.real) == 0))
6174 gfc_error ("Step expression in DO loop at %L cannot be zero",
6175 &iter->step->where);
6180 /* Convert start, end, and step to the same type as var. */
6181 if (iter->start->ts.kind != iter->var->ts.kind
6182 || iter->start->ts.type != iter->var->ts.type)
6183 gfc_convert_type (iter->start, &iter->var->ts, 2);
6185 if (iter->end->ts.kind != iter->var->ts.kind
6186 || iter->end->ts.type != iter->var->ts.type)
6187 gfc_convert_type (iter->end, &iter->var->ts, 2);
6189 if (iter->step->ts.kind != iter->var->ts.kind
6190 || iter->step->ts.type != iter->var->ts.type)
6191 gfc_convert_type (iter->step, &iter->var->ts, 2);
6193 if (iter->start->expr_type == EXPR_CONSTANT
6194 && iter->end->expr_type == EXPR_CONSTANT
6195 && iter->step->expr_type == EXPR_CONSTANT)
6198 if (iter->start->ts.type == BT_INTEGER)
6200 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6201 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6205 sgn = mpfr_sgn (iter->step->value.real);
6206 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6208 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6209 gfc_warning ("DO loop at %L will be executed zero times",
6210 &iter->step->where);
6217 /* Traversal function for find_forall_index. f == 2 signals that
6218 that variable itself is not to be checked - only the references. */
6221 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6223 if (expr->expr_type != EXPR_VARIABLE)
6226 /* A scalar assignment */
6227 if (!expr->ref || *f == 1)
6229 if (expr->symtree->n.sym == sym)
6241 /* Check whether the FORALL index appears in the expression or not.
6242 Returns SUCCESS if SYM is found in EXPR. */
6245 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6247 if (gfc_traverse_expr (expr, sym, forall_index, f))
6254 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6255 to be a scalar INTEGER variable. The subscripts and stride are scalar
6256 INTEGERs, and if stride is a constant it must be nonzero.
6257 Furthermore "A subscript or stride in a forall-triplet-spec shall
6258 not contain a reference to any index-name in the
6259 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6262 resolve_forall_iterators (gfc_forall_iterator *it)
6264 gfc_forall_iterator *iter, *iter2;
6266 for (iter = it; iter; iter = iter->next)
6268 if (gfc_resolve_expr (iter->var) == SUCCESS
6269 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6270 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6273 if (gfc_resolve_expr (iter->start) == SUCCESS
6274 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6275 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6276 &iter->start->where);
6277 if (iter->var->ts.kind != iter->start->ts.kind)
6278 gfc_convert_type (iter->start, &iter->var->ts, 2);
6280 if (gfc_resolve_expr (iter->end) == SUCCESS
6281 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6282 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6284 if (iter->var->ts.kind != iter->end->ts.kind)
6285 gfc_convert_type (iter->end, &iter->var->ts, 2);
6287 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6289 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6290 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6291 &iter->stride->where, "INTEGER");
6293 if (iter->stride->expr_type == EXPR_CONSTANT
6294 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6295 gfc_error ("FORALL stride expression at %L cannot be zero",
6296 &iter->stride->where);
6298 if (iter->var->ts.kind != iter->stride->ts.kind)
6299 gfc_convert_type (iter->stride, &iter->var->ts, 2);
6302 for (iter = it; iter; iter = iter->next)
6303 for (iter2 = iter; iter2; iter2 = iter2->next)
6305 if (find_forall_index (iter2->start,
6306 iter->var->symtree->n.sym, 0) == SUCCESS
6307 || find_forall_index (iter2->end,
6308 iter->var->symtree->n.sym, 0) == SUCCESS
6309 || find_forall_index (iter2->stride,
6310 iter->var->symtree->n.sym, 0) == SUCCESS)
6311 gfc_error ("FORALL index '%s' may not appear in triplet "
6312 "specification at %L", iter->var->symtree->name,
6313 &iter2->start->where);
6318 /* Given a pointer to a symbol that is a derived type, see if it's
6319 inaccessible, i.e. if it's defined in another module and the components are
6320 PRIVATE. The search is recursive if necessary. Returns zero if no
6321 inaccessible components are found, nonzero otherwise. */
6324 derived_inaccessible (gfc_symbol *sym)
6328 if (sym->attr.use_assoc && sym->attr.private_comp)
6331 for (c = sym->components; c; c = c->next)
6333 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6341 /* Resolve the argument of a deallocate expression. The expression must be
6342 a pointer or a full array. */
6345 resolve_deallocate_expr (gfc_expr *e)
6347 symbol_attribute attr;
6348 int allocatable, pointer;
6353 if (gfc_resolve_expr (e) == FAILURE)
6356 if (e->expr_type != EXPR_VARIABLE)
6359 sym = e->symtree->n.sym;
6361 if (sym->ts.type == BT_CLASS)
6363 allocatable = CLASS_DATA (sym)->attr.allocatable;
6364 pointer = CLASS_DATA (sym)->attr.class_pointer;
6368 allocatable = sym->attr.allocatable;
6369 pointer = sym->attr.pointer;
6371 for (ref = e->ref; ref; ref = ref->next)
6376 if (ref->u.ar.type != AR_FULL)
6381 c = ref->u.c.component;
6382 if (c->ts.type == BT_CLASS)
6384 allocatable = CLASS_DATA (c)->attr.allocatable;
6385 pointer = CLASS_DATA (c)->attr.class_pointer;
6389 allocatable = c->attr.allocatable;
6390 pointer = c->attr.pointer;
6400 attr = gfc_expr_attr (e);
6402 if (allocatable == 0 && attr.pointer == 0)
6405 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6411 && gfc_check_vardef_context (e, true, _("DEALLOCATE object")) == FAILURE)
6413 if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE)
6416 if (e->ts.type == BT_CLASS)
6418 /* Only deallocate the DATA component. */
6419 gfc_add_data_component (e);
6426 /* Returns true if the expression e contains a reference to the symbol sym. */
6428 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6430 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6437 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6439 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6443 /* Given the expression node e for an allocatable/pointer of derived type to be
6444 allocated, get the expression node to be initialized afterwards (needed for
6445 derived types with default initializers, and derived types with allocatable
6446 components that need nullification.) */
6449 gfc_expr_to_initialize (gfc_expr *e)
6455 result = gfc_copy_expr (e);
6457 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6458 for (ref = result->ref; ref; ref = ref->next)
6459 if (ref->type == REF_ARRAY && ref->next == NULL)
6461 ref->u.ar.type = AR_FULL;
6463 for (i = 0; i < ref->u.ar.dimen; i++)
6464 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6466 result->rank = ref->u.ar.dimen;
6474 /* If the last ref of an expression is an array ref, return a copy of the
6475 expression with that one removed. Otherwise, a copy of the original
6476 expression. This is used for allocate-expressions and pointer assignment
6477 LHS, where there may be an array specification that needs to be stripped
6478 off when using gfc_check_vardef_context. */
6481 remove_last_array_ref (gfc_expr* e)
6486 e2 = gfc_copy_expr (e);
6487 for (r = &e2->ref; *r; r = &(*r)->next)
6488 if ((*r)->type == REF_ARRAY && !(*r)->next)
6490 gfc_free_ref_list (*r);
6499 /* Used in resolve_allocate_expr to check that a allocation-object and
6500 a source-expr are conformable. This does not catch all possible
6501 cases; in particular a runtime checking is needed. */
6504 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6507 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6509 /* First compare rank. */
6510 if (tail && e1->rank != tail->u.ar.as->rank)
6512 gfc_error ("Source-expr at %L must be scalar or have the "
6513 "same rank as the allocate-object at %L",
6514 &e1->where, &e2->where);
6525 for (i = 0; i < e1->rank; i++)
6527 if (tail->u.ar.end[i])
6529 mpz_set (s, tail->u.ar.end[i]->value.integer);
6530 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6531 mpz_add_ui (s, s, 1);
6535 mpz_set (s, tail->u.ar.start[i]->value.integer);
6538 if (mpz_cmp (e1->shape[i], s) != 0)
6540 gfc_error ("Source-expr at %L and allocate-object at %L must "
6541 "have the same shape", &e1->where, &e2->where);
6554 /* Resolve the expression in an ALLOCATE statement, doing the additional
6555 checks to see whether the expression is OK or not. The expression must
6556 have a trailing array reference that gives the size of the array. */
6559 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6561 int i, pointer, allocatable, dimension, is_abstract;
6563 symbol_attribute attr;
6564 gfc_ref *ref, *ref2;
6567 gfc_symbol *sym = NULL;
6572 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6573 checking of coarrays. */
6574 for (ref = e->ref; ref; ref = ref->next)
6575 if (ref->next == NULL)
6578 if (ref && ref->type == REF_ARRAY)
6579 ref->u.ar.in_allocate = true;
6581 if (gfc_resolve_expr (e) == FAILURE)
6584 /* Make sure the expression is allocatable or a pointer. If it is
6585 pointer, the next-to-last reference must be a pointer. */
6589 sym = e->symtree->n.sym;
6591 /* Check whether ultimate component is abstract and CLASS. */
6594 if (e->expr_type != EXPR_VARIABLE)
6597 attr = gfc_expr_attr (e);
6598 pointer = attr.pointer;
6599 dimension = attr.dimension;
6600 codimension = attr.codimension;
6604 if (sym->ts.type == BT_CLASS)
6606 allocatable = CLASS_DATA (sym)->attr.allocatable;
6607 pointer = CLASS_DATA (sym)->attr.class_pointer;
6608 dimension = CLASS_DATA (sym)->attr.dimension;
6609 codimension = CLASS_DATA (sym)->attr.codimension;
6610 is_abstract = CLASS_DATA (sym)->attr.abstract;
6614 allocatable = sym->attr.allocatable;
6615 pointer = sym->attr.pointer;
6616 dimension = sym->attr.dimension;
6617 codimension = sym->attr.codimension;
6620 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6625 if (ref->next != NULL)
6631 if (gfc_is_coindexed (e))
6633 gfc_error ("Coindexed allocatable object at %L",
6638 c = ref->u.c.component;
6639 if (c->ts.type == BT_CLASS)
6641 allocatable = CLASS_DATA (c)->attr.allocatable;
6642 pointer = CLASS_DATA (c)->attr.class_pointer;
6643 dimension = CLASS_DATA (c)->attr.dimension;
6644 codimension = CLASS_DATA (c)->attr.codimension;
6645 is_abstract = CLASS_DATA (c)->attr.abstract;
6649 allocatable = c->attr.allocatable;
6650 pointer = c->attr.pointer;
6651 dimension = c->attr.dimension;
6652 codimension = c->attr.codimension;
6653 is_abstract = c->attr.abstract;
6665 if (allocatable == 0 && pointer == 0)
6667 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6672 /* Some checks for the SOURCE tag. */
6675 /* Check F03:C631. */
6676 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6678 gfc_error ("Type of entity at %L is type incompatible with "
6679 "source-expr at %L", &e->where, &code->expr3->where);
6683 /* Check F03:C632 and restriction following Note 6.18. */
6684 if (code->expr3->rank > 0
6685 && conformable_arrays (code->expr3, e) == FAILURE)
6688 /* Check F03:C633. */
6689 if (code->expr3->ts.kind != e->ts.kind)
6691 gfc_error ("The allocate-object at %L and the source-expr at %L "
6692 "shall have the same kind type parameter",
6693 &e->where, &code->expr3->where);
6698 /* Check F08:C629. */
6699 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
6702 gcc_assert (e->ts.type == BT_CLASS);
6703 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6704 "type-spec or source-expr", sym->name, &e->where);
6708 /* In the variable definition context checks, gfc_expr_attr is used
6709 on the expression. This is fooled by the array specification
6710 present in e, thus we have to eliminate that one temporarily. */
6711 e2 = remove_last_array_ref (e);
6713 if (t == SUCCESS && pointer)
6714 t = gfc_check_vardef_context (e2, true, _("ALLOCATE object"));
6716 t = gfc_check_vardef_context (e2, false, _("ALLOCATE object"));
6723 /* Set up default initializer if needed. */
6727 if (code->ext.alloc.ts.type == BT_DERIVED)
6728 ts = code->ext.alloc.ts;
6732 if (ts.type == BT_CLASS)
6733 ts = ts.u.derived->components->ts;
6735 if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
6737 gfc_code *init_st = gfc_get_code ();
6738 init_st->loc = code->loc;
6739 init_st->op = EXEC_INIT_ASSIGN;
6740 init_st->expr1 = gfc_expr_to_initialize (e);
6741 init_st->expr2 = init_e;
6742 init_st->next = code->next;
6743 code->next = init_st;
6746 else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
6748 /* Default initialization via MOLD (non-polymorphic). */
6749 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
6750 gfc_resolve_expr (rhs);
6751 gfc_free_expr (code->expr3);
6755 if (e->ts.type == BT_CLASS)
6757 /* Make sure the vtab symbol is present when
6758 the module variables are generated. */
6759 gfc_typespec ts = e->ts;
6761 ts = code->expr3->ts;
6762 else if (code->ext.alloc.ts.type == BT_DERIVED)
6763 ts = code->ext.alloc.ts;
6764 gfc_find_derived_vtab (ts.u.derived);
6767 if (pointer || (dimension == 0 && codimension == 0))
6770 /* Make sure the last reference node is an array specifiction. */
6772 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
6773 || (dimension && ref2->u.ar.dimen == 0))
6775 gfc_error ("Array specification required in ALLOCATE statement "
6776 "at %L", &e->where);
6780 /* Make sure that the array section reference makes sense in the
6781 context of an ALLOCATE specification. */
6785 if (codimension && ar->codimen == 0)
6787 gfc_error ("Coarray specification required in ALLOCATE statement "
6788 "at %L", &e->where);
6792 for (i = 0; i < ar->dimen; i++)
6794 if (ref2->u.ar.type == AR_ELEMENT)
6797 switch (ar->dimen_type[i])
6803 if (ar->start[i] != NULL
6804 && ar->end[i] != NULL
6805 && ar->stride[i] == NULL)
6808 /* Fall Through... */
6813 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6819 for (a = code->ext.alloc.list; a; a = a->next)
6821 sym = a->expr->symtree->n.sym;
6823 /* TODO - check derived type components. */
6824 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6827 if ((ar->start[i] != NULL
6828 && gfc_find_sym_in_expr (sym, ar->start[i]))
6829 || (ar->end[i] != NULL
6830 && gfc_find_sym_in_expr (sym, ar->end[i])))
6832 gfc_error ("'%s' must not appear in the array specification at "
6833 "%L in the same ALLOCATE statement where it is "
6834 "itself allocated", sym->name, &ar->where);
6840 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
6842 if (ar->dimen_type[i] == DIMEN_ELEMENT
6843 || ar->dimen_type[i] == DIMEN_RANGE)
6845 if (i == (ar->dimen + ar->codimen - 1))
6847 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
6848 "statement at %L", &e->where);
6854 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
6855 && ar->stride[i] == NULL)
6858 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
6863 if (codimension && ar->as->rank == 0)
6865 gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
6866 "at %L", &e->where);
6873 gfc_error ("Support for entity at %L with deferred type parameter "
6874 "not yet implemented", &e->where);
6884 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
6886 gfc_expr *stat, *errmsg, *pe, *qe;
6887 gfc_alloc *a, *p, *q;
6890 errmsg = code->expr2;
6892 /* Check the stat variable. */
6895 gfc_check_vardef_context (stat, false, _("STAT variable"));
6897 if ((stat->ts.type != BT_INTEGER
6898 && !(stat->ref && (stat->ref->type == REF_ARRAY
6899 || stat->ref->type == REF_COMPONENT)))
6901 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
6902 "variable", &stat->where);
6904 for (p = code->ext.alloc.list; p; p = p->next)
6905 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
6907 gfc_ref *ref1, *ref2;
6910 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
6911 ref1 = ref1->next, ref2 = ref2->next)
6913 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6915 if (ref1->u.c.component->name != ref2->u.c.component->name)
6924 gfc_error ("Stat-variable at %L shall not be %sd within "
6925 "the same %s statement", &stat->where, fcn, fcn);
6931 /* Check the errmsg variable. */
6935 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
6938 gfc_check_vardef_context (errmsg, false, _("ERRMSG variable"));
6940 if ((errmsg->ts.type != BT_CHARACTER
6942 && (errmsg->ref->type == REF_ARRAY
6943 || errmsg->ref->type == REF_COMPONENT)))
6944 || errmsg->rank > 0 )
6945 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
6946 "variable", &errmsg->where);
6948 for (p = code->ext.alloc.list; p; p = p->next)
6949 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
6951 gfc_ref *ref1, *ref2;
6954 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
6955 ref1 = ref1->next, ref2 = ref2->next)
6957 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6959 if (ref1->u.c.component->name != ref2->u.c.component->name)
6968 gfc_error ("Errmsg-variable at %L shall not be %sd within "
6969 "the same %s statement", &errmsg->where, fcn, fcn);
6975 /* Check that an allocate-object appears only once in the statement.
6976 FIXME: Checking derived types is disabled. */
6977 for (p = code->ext.alloc.list; p; p = p->next)
6980 if ((pe->ref && pe->ref->type != REF_COMPONENT)
6981 && (pe->symtree->n.sym->ts.type != BT_DERIVED))
6983 for (q = p->next; q; q = q->next)
6986 if ((qe->ref && qe->ref->type != REF_COMPONENT)
6987 && (qe->symtree->n.sym->ts.type != BT_DERIVED)
6988 && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
6989 gfc_error ("Allocate-object at %L also appears at %L",
6990 &pe->where, &qe->where);
6995 if (strcmp (fcn, "ALLOCATE") == 0)
6997 for (a = code->ext.alloc.list; a; a = a->next)
6998 resolve_allocate_expr (a->expr, code);
7002 for (a = code->ext.alloc.list; a; a = a->next)
7003 resolve_deallocate_expr (a->expr);
7008 /************ SELECT CASE resolution subroutines ************/
7010 /* Callback function for our mergesort variant. Determines interval
7011 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7012 op1 > op2. Assumes we're not dealing with the default case.
7013 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7014 There are nine situations to check. */
7017 compare_cases (const gfc_case *op1, const gfc_case *op2)
7021 if (op1->low == NULL) /* op1 = (:L) */
7023 /* op2 = (:N), so overlap. */
7025 /* op2 = (M:) or (M:N), L < M */
7026 if (op2->low != NULL
7027 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7030 else if (op1->high == NULL) /* op1 = (K:) */
7032 /* op2 = (M:), so overlap. */
7034 /* op2 = (:N) or (M:N), K > N */
7035 if (op2->high != NULL
7036 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7039 else /* op1 = (K:L) */
7041 if (op2->low == NULL) /* op2 = (:N), K > N */
7042 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7044 else if (op2->high == NULL) /* op2 = (M:), L < M */
7045 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7047 else /* op2 = (M:N) */
7051 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7054 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7063 /* Merge-sort a double linked case list, detecting overlap in the
7064 process. LIST is the head of the double linked case list before it
7065 is sorted. Returns the head of the sorted list if we don't see any
7066 overlap, or NULL otherwise. */
7069 check_case_overlap (gfc_case *list)
7071 gfc_case *p, *q, *e, *tail;
7072 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7074 /* If the passed list was empty, return immediately. */
7081 /* Loop unconditionally. The only exit from this loop is a return
7082 statement, when we've finished sorting the case list. */
7089 /* Count the number of merges we do in this pass. */
7092 /* Loop while there exists a merge to be done. */
7097 /* Count this merge. */
7100 /* Cut the list in two pieces by stepping INSIZE places
7101 forward in the list, starting from P. */
7104 for (i = 0; i < insize; i++)
7113 /* Now we have two lists. Merge them! */
7114 while (psize > 0 || (qsize > 0 && q != NULL))
7116 /* See from which the next case to merge comes from. */
7119 /* P is empty so the next case must come from Q. */
7124 else if (qsize == 0 || q == NULL)
7133 cmp = compare_cases (p, q);
7136 /* The whole case range for P is less than the
7144 /* The whole case range for Q is greater than
7145 the case range for P. */
7152 /* The cases overlap, or they are the same
7153 element in the list. Either way, we must
7154 issue an error and get the next case from P. */
7155 /* FIXME: Sort P and Q by line number. */
7156 gfc_error ("CASE label at %L overlaps with CASE "
7157 "label at %L", &p->where, &q->where);
7165 /* Add the next element to the merged list. */
7174 /* P has now stepped INSIZE places along, and so has Q. So
7175 they're the same. */
7180 /* If we have done only one merge or none at all, we've
7181 finished sorting the cases. */
7190 /* Otherwise repeat, merging lists twice the size. */
7196 /* Check to see if an expression is suitable for use in a CASE statement.
7197 Makes sure that all case expressions are scalar constants of the same
7198 type. Return FAILURE if anything is wrong. */
7201 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7203 if (e == NULL) return SUCCESS;
7205 if (e->ts.type != case_expr->ts.type)
7207 gfc_error ("Expression in CASE statement at %L must be of type %s",
7208 &e->where, gfc_basic_typename (case_expr->ts.type));
7212 /* C805 (R808) For a given case-construct, each case-value shall be of
7213 the same type as case-expr. For character type, length differences
7214 are allowed, but the kind type parameters shall be the same. */
7216 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7218 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7219 &e->where, case_expr->ts.kind);
7223 /* Convert the case value kind to that of case expression kind,
7226 if (e->ts.kind != case_expr->ts.kind)
7227 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7231 gfc_error ("Expression in CASE statement at %L must be scalar",
7240 /* Given a completely parsed select statement, we:
7242 - Validate all expressions and code within the SELECT.
7243 - Make sure that the selection expression is not of the wrong type.
7244 - Make sure that no case ranges overlap.
7245 - Eliminate unreachable cases and unreachable code resulting from
7246 removing case labels.
7248 The standard does allow unreachable cases, e.g. CASE (5:3). But
7249 they are a hassle for code generation, and to prevent that, we just
7250 cut them out here. This is not necessary for overlapping cases
7251 because they are illegal and we never even try to generate code.
7253 We have the additional caveat that a SELECT construct could have
7254 been a computed GOTO in the source code. Fortunately we can fairly
7255 easily work around that here: The case_expr for a "real" SELECT CASE
7256 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7257 we have to do is make sure that the case_expr is a scalar integer
7261 resolve_select (gfc_code *code)
7264 gfc_expr *case_expr;
7265 gfc_case *cp, *default_case, *tail, *head;
7266 int seen_unreachable;
7272 if (code->expr1 == NULL)
7274 /* This was actually a computed GOTO statement. */
7275 case_expr = code->expr2;
7276 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7277 gfc_error ("Selection expression in computed GOTO statement "
7278 "at %L must be a scalar integer expression",
7281 /* Further checking is not necessary because this SELECT was built
7282 by the compiler, so it should always be OK. Just move the
7283 case_expr from expr2 to expr so that we can handle computed
7284 GOTOs as normal SELECTs from here on. */
7285 code->expr1 = code->expr2;
7290 case_expr = code->expr1;
7292 type = case_expr->ts.type;
7293 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7295 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7296 &case_expr->where, gfc_typename (&case_expr->ts));
7298 /* Punt. Going on here just produce more garbage error messages. */
7302 if (case_expr->rank != 0)
7304 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7305 "expression", &case_expr->where);
7312 /* Raise a warning if an INTEGER case value exceeds the range of
7313 the case-expr. Later, all expressions will be promoted to the
7314 largest kind of all case-labels. */
7316 if (type == BT_INTEGER)
7317 for (body = code->block; body; body = body->block)
7318 for (cp = body->ext.case_list; cp; cp = cp->next)
7321 && gfc_check_integer_range (cp->low->value.integer,
7322 case_expr->ts.kind) != ARITH_OK)
7323 gfc_warning ("Expression in CASE statement at %L is "
7324 "not in the range of %s", &cp->low->where,
7325 gfc_typename (&case_expr->ts));
7328 && cp->low != cp->high
7329 && gfc_check_integer_range (cp->high->value.integer,
7330 case_expr->ts.kind) != ARITH_OK)
7331 gfc_warning ("Expression in CASE statement at %L is "
7332 "not in the range of %s", &cp->high->where,
7333 gfc_typename (&case_expr->ts));
7336 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7337 of the SELECT CASE expression and its CASE values. Walk the lists
7338 of case values, and if we find a mismatch, promote case_expr to
7339 the appropriate kind. */
7341 if (type == BT_LOGICAL || type == BT_INTEGER)
7343 for (body = code->block; body; body = body->block)
7345 /* Walk the case label list. */
7346 for (cp = body->ext.case_list; cp; cp = cp->next)
7348 /* Intercept the DEFAULT case. It does not have a kind. */
7349 if (cp->low == NULL && cp->high == NULL)
7352 /* Unreachable case ranges are discarded, so ignore. */
7353 if (cp->low != NULL && cp->high != NULL
7354 && cp->low != cp->high
7355 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7359 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7360 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7362 if (cp->high != NULL
7363 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7364 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7369 /* Assume there is no DEFAULT case. */
7370 default_case = NULL;
7375 for (body = code->block; body; body = body->block)
7377 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7379 seen_unreachable = 0;
7381 /* Walk the case label list, making sure that all case labels
7383 for (cp = body->ext.case_list; cp; cp = cp->next)
7385 /* Count the number of cases in the whole construct. */
7388 /* Intercept the DEFAULT case. */
7389 if (cp->low == NULL && cp->high == NULL)
7391 if (default_case != NULL)
7393 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7394 "by a second DEFAULT CASE at %L",
7395 &default_case->where, &cp->where);
7406 /* Deal with single value cases and case ranges. Errors are
7407 issued from the validation function. */
7408 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7409 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7415 if (type == BT_LOGICAL
7416 && ((cp->low == NULL || cp->high == NULL)
7417 || cp->low != cp->high))
7419 gfc_error ("Logical range in CASE statement at %L is not "
7420 "allowed", &cp->low->where);
7425 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7428 value = cp->low->value.logical == 0 ? 2 : 1;
7429 if (value & seen_logical)
7431 gfc_error ("Constant logical value in CASE statement "
7432 "is repeated at %L",
7437 seen_logical |= value;
7440 if (cp->low != NULL && cp->high != NULL
7441 && cp->low != cp->high
7442 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7444 if (gfc_option.warn_surprising)
7445 gfc_warning ("Range specification at %L can never "
7446 "be matched", &cp->where);
7448 cp->unreachable = 1;
7449 seen_unreachable = 1;
7453 /* If the case range can be matched, it can also overlap with
7454 other cases. To make sure it does not, we put it in a
7455 double linked list here. We sort that with a merge sort
7456 later on to detect any overlapping cases. */
7460 head->right = head->left = NULL;
7465 tail->right->left = tail;
7472 /* It there was a failure in the previous case label, give up
7473 for this case label list. Continue with the next block. */
7477 /* See if any case labels that are unreachable have been seen.
7478 If so, we eliminate them. This is a bit of a kludge because
7479 the case lists for a single case statement (label) is a
7480 single forward linked lists. */
7481 if (seen_unreachable)
7483 /* Advance until the first case in the list is reachable. */
7484 while (body->ext.case_list != NULL
7485 && body->ext.case_list->unreachable)
7487 gfc_case *n = body->ext.case_list;
7488 body->ext.case_list = body->ext.case_list->next;
7490 gfc_free_case_list (n);
7493 /* Strip all other unreachable cases. */
7494 if (body->ext.case_list)
7496 for (cp = body->ext.case_list; cp->next; cp = cp->next)
7498 if (cp->next->unreachable)
7500 gfc_case *n = cp->next;
7501 cp->next = cp->next->next;
7503 gfc_free_case_list (n);
7510 /* See if there were overlapping cases. If the check returns NULL,
7511 there was overlap. In that case we don't do anything. If head
7512 is non-NULL, we prepend the DEFAULT case. The sorted list can
7513 then used during code generation for SELECT CASE constructs with
7514 a case expression of a CHARACTER type. */
7517 head = check_case_overlap (head);
7519 /* Prepend the default_case if it is there. */
7520 if (head != NULL && default_case)
7522 default_case->left = NULL;
7523 default_case->right = head;
7524 head->left = default_case;
7528 /* Eliminate dead blocks that may be the result if we've seen
7529 unreachable case labels for a block. */
7530 for (body = code; body && body->block; body = body->block)
7532 if (body->block->ext.case_list == NULL)
7534 /* Cut the unreachable block from the code chain. */
7535 gfc_code *c = body->block;
7536 body->block = c->block;
7538 /* Kill the dead block, but not the blocks below it. */
7540 gfc_free_statements (c);
7544 /* More than two cases is legal but insane for logical selects.
7545 Issue a warning for it. */
7546 if (gfc_option.warn_surprising && type == BT_LOGICAL
7548 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7553 /* Check if a derived type is extensible. */
7556 gfc_type_is_extensible (gfc_symbol *sym)
7558 return !(sym->attr.is_bind_c || sym->attr.sequence);
7562 /* Resolve an associate name: Resolve target and ensure the type-spec is
7563 correct as well as possibly the array-spec. */
7566 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
7570 gcc_assert (sym->assoc);
7571 gcc_assert (sym->attr.flavor == FL_VARIABLE);
7573 /* If this is for SELECT TYPE, the target may not yet be set. In that
7574 case, return. Resolution will be called later manually again when
7576 target = sym->assoc->target;
7579 gcc_assert (!sym->assoc->dangling);
7581 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
7584 /* For variable targets, we get some attributes from the target. */
7585 if (target->expr_type == EXPR_VARIABLE)
7589 gcc_assert (target->symtree);
7590 tsym = target->symtree->n.sym;
7592 sym->attr.asynchronous = tsym->attr.asynchronous;
7593 sym->attr.volatile_ = tsym->attr.volatile_;
7595 sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
7598 /* Get type if this was not already set. Note that it can be
7599 some other type than the target in case this is a SELECT TYPE
7600 selector! So we must not update when the type is already there. */
7601 if (sym->ts.type == BT_UNKNOWN)
7602 sym->ts = target->ts;
7603 gcc_assert (sym->ts.type != BT_UNKNOWN);
7605 /* See if this is a valid association-to-variable. */
7606 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
7607 && !gfc_has_vector_subscript (target));
7609 /* Finally resolve if this is an array or not. */
7610 if (sym->attr.dimension && target->rank == 0)
7612 gfc_error ("Associate-name '%s' at %L is used as array",
7613 sym->name, &sym->declared_at);
7614 sym->attr.dimension = 0;
7617 if (target->rank > 0)
7618 sym->attr.dimension = 1;
7620 if (sym->attr.dimension)
7622 sym->as = gfc_get_array_spec ();
7623 sym->as->rank = target->rank;
7624 sym->as->type = AS_DEFERRED;
7626 /* Target must not be coindexed, thus the associate-variable
7628 sym->as->corank = 0;
7633 /* Resolve a SELECT TYPE statement. */
7636 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
7638 gfc_symbol *selector_type;
7639 gfc_code *body, *new_st, *if_st, *tail;
7640 gfc_code *class_is = NULL, *default_case = NULL;
7643 char name[GFC_MAX_SYMBOL_LEN];
7647 ns = code->ext.block.ns;
7650 /* Check for F03:C813. */
7651 if (code->expr1->ts.type != BT_CLASS
7652 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
7654 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7655 "at %L", &code->loc);
7661 if (code->expr1->symtree->n.sym->attr.untyped)
7662 code->expr1->symtree->n.sym->ts = code->expr2->ts;
7663 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
7666 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
7668 /* Loop over TYPE IS / CLASS IS cases. */
7669 for (body = code->block; body; body = body->block)
7671 c = body->ext.case_list;
7673 /* Check F03:C815. */
7674 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7675 && !gfc_type_is_extensible (c->ts.u.derived))
7677 gfc_error ("Derived type '%s' at %L must be extensible",
7678 c->ts.u.derived->name, &c->where);
7683 /* Check F03:C816. */
7684 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7685 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
7687 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7688 c->ts.u.derived->name, &c->where, selector_type->name);
7693 /* Intercept the DEFAULT case. */
7694 if (c->ts.type == BT_UNKNOWN)
7696 /* Check F03:C818. */
7699 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7700 "by a second DEFAULT CASE at %L",
7701 &default_case->ext.case_list->where, &c->where);
7706 default_case = body;
7713 /* Transform SELECT TYPE statement to BLOCK and associate selector to
7714 target if present. If there are any EXIT statements referring to the
7715 SELECT TYPE construct, this is no problem because the gfc_code
7716 reference stays the same and EXIT is equally possible from the BLOCK
7717 it is changed to. */
7718 code->op = EXEC_BLOCK;
7721 gfc_association_list* assoc;
7723 assoc = gfc_get_association_list ();
7724 assoc->st = code->expr1->symtree;
7725 assoc->target = gfc_copy_expr (code->expr2);
7726 /* assoc->variable will be set by resolve_assoc_var. */
7728 code->ext.block.assoc = assoc;
7729 code->expr1->symtree->n.sym->assoc = assoc;
7731 resolve_assoc_var (code->expr1->symtree->n.sym, false);
7734 code->ext.block.assoc = NULL;
7736 /* Add EXEC_SELECT to switch on type. */
7737 new_st = gfc_get_code ();
7738 new_st->op = code->op;
7739 new_st->expr1 = code->expr1;
7740 new_st->expr2 = code->expr2;
7741 new_st->block = code->block;
7742 code->expr1 = code->expr2 = NULL;
7747 ns->code->next = new_st;
7749 code->op = EXEC_SELECT;
7750 gfc_add_vptr_component (code->expr1);
7751 gfc_add_hash_component (code->expr1);
7753 /* Loop over TYPE IS / CLASS IS cases. */
7754 for (body = code->block; body; body = body->block)
7756 c = body->ext.case_list;
7758 if (c->ts.type == BT_DERIVED)
7759 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7760 c->ts.u.derived->hash_value);
7762 else if (c->ts.type == BT_UNKNOWN)
7765 /* Associate temporary to selector. This should only be done
7766 when this case is actually true, so build a new ASSOCIATE
7767 that does precisely this here (instead of using the
7770 if (c->ts.type == BT_CLASS)
7771 sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
7773 sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
7774 st = gfc_find_symtree (ns->sym_root, name);
7775 gcc_assert (st->n.sym->assoc);
7776 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
7777 if (c->ts.type == BT_DERIVED)
7778 gfc_add_data_component (st->n.sym->assoc->target);
7780 new_st = gfc_get_code ();
7781 new_st->op = EXEC_BLOCK;
7782 new_st->ext.block.ns = gfc_build_block_ns (ns);
7783 new_st->ext.block.ns->code = body->next;
7784 body->next = new_st;
7786 /* Chain in the new list only if it is marked as dangling. Otherwise
7787 there is a CASE label overlap and this is already used. Just ignore,
7788 the error is diagonsed elsewhere. */
7789 if (st->n.sym->assoc->dangling)
7791 new_st->ext.block.assoc = st->n.sym->assoc;
7792 st->n.sym->assoc->dangling = 0;
7795 resolve_assoc_var (st->n.sym, false);
7798 /* Take out CLASS IS cases for separate treatment. */
7800 while (body && body->block)
7802 if (body->block->ext.case_list->ts.type == BT_CLASS)
7804 /* Add to class_is list. */
7805 if (class_is == NULL)
7807 class_is = body->block;
7812 for (tail = class_is; tail->block; tail = tail->block) ;
7813 tail->block = body->block;
7816 /* Remove from EXEC_SELECT list. */
7817 body->block = body->block->block;
7830 /* Add a default case to hold the CLASS IS cases. */
7831 for (tail = code; tail->block; tail = tail->block) ;
7832 tail->block = gfc_get_code ();
7834 tail->op = EXEC_SELECT_TYPE;
7835 tail->ext.case_list = gfc_get_case ();
7836 tail->ext.case_list->ts.type = BT_UNKNOWN;
7838 default_case = tail;
7841 /* More than one CLASS IS block? */
7842 if (class_is->block)
7846 /* Sort CLASS IS blocks by extension level. */
7850 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
7853 /* F03:C817 (check for doubles). */
7854 if ((*c1)->ext.case_list->ts.u.derived->hash_value
7855 == c2->ext.case_list->ts.u.derived->hash_value)
7857 gfc_error ("Double CLASS IS block in SELECT TYPE "
7858 "statement at %L", &c2->ext.case_list->where);
7861 if ((*c1)->ext.case_list->ts.u.derived->attr.extension
7862 < c2->ext.case_list->ts.u.derived->attr.extension)
7865 (*c1)->block = c2->block;
7875 /* Generate IF chain. */
7876 if_st = gfc_get_code ();
7877 if_st->op = EXEC_IF;
7879 for (body = class_is; body; body = body->block)
7881 new_st->block = gfc_get_code ();
7882 new_st = new_st->block;
7883 new_st->op = EXEC_IF;
7884 /* Set up IF condition: Call _gfortran_is_extension_of. */
7885 new_st->expr1 = gfc_get_expr ();
7886 new_st->expr1->expr_type = EXPR_FUNCTION;
7887 new_st->expr1->ts.type = BT_LOGICAL;
7888 new_st->expr1->ts.kind = 4;
7889 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
7890 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
7891 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
7892 /* Set up arguments. */
7893 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
7894 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
7895 gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
7896 vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
7897 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
7898 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
7899 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
7900 new_st->next = body->next;
7902 if (default_case->next)
7904 new_st->block = gfc_get_code ();
7905 new_st = new_st->block;
7906 new_st->op = EXEC_IF;
7907 new_st->next = default_case->next;
7910 /* Replace CLASS DEFAULT code by the IF chain. */
7911 default_case->next = if_st;
7914 /* Resolve the internal code. This can not be done earlier because
7915 it requires that the sym->assoc of selectors is set already. */
7916 gfc_current_ns = ns;
7917 gfc_resolve_blocks (code->block, gfc_current_ns);
7918 gfc_current_ns = old_ns;
7920 resolve_select (code);
7924 /* Resolve a transfer statement. This is making sure that:
7925 -- a derived type being transferred has only non-pointer components
7926 -- a derived type being transferred doesn't have private components, unless
7927 it's being transferred from the module where the type was defined
7928 -- we're not trying to transfer a whole assumed size array. */
7931 resolve_transfer (gfc_code *code)
7940 while (exp != NULL && exp->expr_type == EXPR_OP
7941 && exp->value.op.op == INTRINSIC_PARENTHESES)
7942 exp = exp->value.op.op1;
7944 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
7945 && exp->expr_type != EXPR_FUNCTION))
7948 /* If we are reading, the variable will be changed. Note that
7949 code->ext.dt may be NULL if the TRANSFER is related to
7950 an INQUIRE statement -- but in this case, we are not reading, either. */
7951 if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
7952 && gfc_check_vardef_context (exp, false, _("item in READ")) == FAILURE)
7955 sym = exp->symtree->n.sym;
7958 /* Go to actual component transferred. */
7959 for (ref = exp->ref; ref; ref = ref->next)
7960 if (ref->type == REF_COMPONENT)
7961 ts = &ref->u.c.component->ts;
7963 if (ts->type == BT_CLASS)
7965 /* FIXME: Test for defined input/output. */
7966 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
7967 "it is processed by a defined input/output procedure",
7972 if (ts->type == BT_DERIVED)
7974 /* Check that transferred derived type doesn't contain POINTER
7976 if (ts->u.derived->attr.pointer_comp)
7978 gfc_error ("Data transfer element at %L cannot have "
7979 "POINTER components", &code->loc);
7983 if (ts->u.derived->attr.alloc_comp)
7985 gfc_error ("Data transfer element at %L cannot have "
7986 "ALLOCATABLE components", &code->loc);
7990 if (derived_inaccessible (ts->u.derived))
7992 gfc_error ("Data transfer element at %L cannot have "
7993 "PRIVATE components",&code->loc);
7998 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
7999 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
8001 gfc_error ("Data transfer element at %L cannot be a full reference to "
8002 "an assumed-size array", &code->loc);
8008 /*********** Toplevel code resolution subroutines ***********/
8010 /* Find the set of labels that are reachable from this block. We also
8011 record the last statement in each block. */
8014 find_reachable_labels (gfc_code *block)
8021 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
8023 /* Collect labels in this block. We don't keep those corresponding
8024 to END {IF|SELECT}, these are checked in resolve_branch by going
8025 up through the code_stack. */
8026 for (c = block; c; c = c->next)
8028 if (c->here && c->op != EXEC_END_BLOCK)
8029 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8032 /* Merge with labels from parent block. */
8035 gcc_assert (cs_base->prev->reachable_labels);
8036 bitmap_ior_into (cs_base->reachable_labels,
8037 cs_base->prev->reachable_labels);
8043 resolve_sync (gfc_code *code)
8045 /* Check imageset. The * case matches expr1 == NULL. */
8048 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8049 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8050 "INTEGER expression", &code->expr1->where);
8051 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8052 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8053 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8054 &code->expr1->where);
8055 else if (code->expr1->expr_type == EXPR_ARRAY
8056 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8058 gfc_constructor *cons;
8059 cons = gfc_constructor_first (code->expr1->value.constructor);
8060 for (; cons; cons = gfc_constructor_next (cons))
8061 if (cons->expr->expr_type == EXPR_CONSTANT
8062 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8063 gfc_error ("Imageset argument at %L must between 1 and "
8064 "num_images()", &cons->expr->where);
8070 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8071 || code->expr2->expr_type != EXPR_VARIABLE))
8072 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8073 &code->expr2->where);
8077 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8078 || code->expr3->expr_type != EXPR_VARIABLE))
8079 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8080 &code->expr3->where);
8084 /* Given a branch to a label, see if the branch is conforming.
8085 The code node describes where the branch is located. */
8088 resolve_branch (gfc_st_label *label, gfc_code *code)
8095 /* Step one: is this a valid branching target? */
8097 if (label->defined == ST_LABEL_UNKNOWN)
8099 gfc_error ("Label %d referenced at %L is never defined", label->value,
8104 if (label->defined != ST_LABEL_TARGET)
8106 gfc_error ("Statement at %L is not a valid branch target statement "
8107 "for the branch statement at %L", &label->where, &code->loc);
8111 /* Step two: make sure this branch is not a branch to itself ;-) */
8113 if (code->here == label)
8115 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8119 /* Step three: See if the label is in the same block as the
8120 branching statement. The hard work has been done by setting up
8121 the bitmap reachable_labels. */
8123 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8125 /* Check now whether there is a CRITICAL construct; if so, check
8126 whether the label is still visible outside of the CRITICAL block,
8127 which is invalid. */
8128 for (stack = cs_base; stack; stack = stack->prev)
8129 if (stack->current->op == EXEC_CRITICAL
8130 && bitmap_bit_p (stack->reachable_labels, label->value))
8131 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8132 " at %L", &code->loc, &label->where);
8137 /* Step four: If we haven't found the label in the bitmap, it may
8138 still be the label of the END of the enclosing block, in which
8139 case we find it by going up the code_stack. */
8141 for (stack = cs_base; stack; stack = stack->prev)
8143 if (stack->current->next && stack->current->next->here == label)
8145 if (stack->current->op == EXEC_CRITICAL)
8147 /* Note: A label at END CRITICAL does not leave the CRITICAL
8148 construct as END CRITICAL is still part of it. */
8149 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8150 " at %L", &code->loc, &label->where);
8157 gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
8161 /* The label is not in an enclosing block, so illegal. This was
8162 allowed in Fortran 66, so we allow it as extension. No
8163 further checks are necessary in this case. */
8164 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
8165 "as the GOTO statement at %L", &label->where,
8171 /* Check whether EXPR1 has the same shape as EXPR2. */
8174 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
8176 mpz_t shape[GFC_MAX_DIMENSIONS];
8177 mpz_t shape2[GFC_MAX_DIMENSIONS];
8178 gfc_try result = FAILURE;
8181 /* Compare the rank. */
8182 if (expr1->rank != expr2->rank)
8185 /* Compare the size of each dimension. */
8186 for (i=0; i<expr1->rank; i++)
8188 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
8191 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
8194 if (mpz_cmp (shape[i], shape2[i]))
8198 /* When either of the two expression is an assumed size array, we
8199 ignore the comparison of dimension sizes. */
8204 for (i--; i >= 0; i--)
8206 mpz_clear (shape[i]);
8207 mpz_clear (shape2[i]);
8213 /* Check whether a WHERE assignment target or a WHERE mask expression
8214 has the same shape as the outmost WHERE mask expression. */
8217 resolve_where (gfc_code *code, gfc_expr *mask)
8223 cblock = code->block;
8225 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8226 In case of nested WHERE, only the outmost one is stored. */
8227 if (mask == NULL) /* outmost WHERE */
8229 else /* inner WHERE */
8236 /* Check if the mask-expr has a consistent shape with the
8237 outmost WHERE mask-expr. */
8238 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8239 gfc_error ("WHERE mask at %L has inconsistent shape",
8240 &cblock->expr1->where);
8243 /* the assignment statement of a WHERE statement, or the first
8244 statement in where-body-construct of a WHERE construct */
8245 cnext = cblock->next;
8250 /* WHERE assignment statement */
8253 /* Check shape consistent for WHERE assignment target. */
8254 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8255 gfc_error ("WHERE assignment target at %L has "
8256 "inconsistent shape", &cnext->expr1->where);
8260 case EXEC_ASSIGN_CALL:
8261 resolve_call (cnext);
8262 if (!cnext->resolved_sym->attr.elemental)
8263 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8264 &cnext->ext.actual->expr->where);
8267 /* WHERE or WHERE construct is part of a where-body-construct */
8269 resolve_where (cnext, e);
8273 gfc_error ("Unsupported statement inside WHERE at %L",
8276 /* the next statement within the same where-body-construct */
8277 cnext = cnext->next;
8279 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8280 cblock = cblock->block;
8285 /* Resolve assignment in FORALL construct.
8286 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8287 FORALL index variables. */
8290 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8294 for (n = 0; n < nvar; n++)
8296 gfc_symbol *forall_index;
8298 forall_index = var_expr[n]->symtree->n.sym;
8300 /* Check whether the assignment target is one of the FORALL index
8302 if ((code->expr1->expr_type == EXPR_VARIABLE)
8303 && (code->expr1->symtree->n.sym == forall_index))
8304 gfc_error ("Assignment to a FORALL index variable at %L",
8305 &code->expr1->where);
8308 /* If one of the FORALL index variables doesn't appear in the
8309 assignment variable, then there could be a many-to-one
8310 assignment. Emit a warning rather than an error because the
8311 mask could be resolving this problem. */
8312 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8313 gfc_warning ("The FORALL with index '%s' is not used on the "
8314 "left side of the assignment at %L and so might "
8315 "cause multiple assignment to this object",
8316 var_expr[n]->symtree->name, &code->expr1->where);
8322 /* Resolve WHERE statement in FORALL construct. */
8325 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8326 gfc_expr **var_expr)
8331 cblock = code->block;
8334 /* the assignment statement of a WHERE statement, or the first
8335 statement in where-body-construct of a WHERE construct */
8336 cnext = cblock->next;
8341 /* WHERE assignment statement */
8343 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8346 /* WHERE operator assignment statement */
8347 case EXEC_ASSIGN_CALL:
8348 resolve_call (cnext);
8349 if (!cnext->resolved_sym->attr.elemental)
8350 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8351 &cnext->ext.actual->expr->where);
8354 /* WHERE or WHERE construct is part of a where-body-construct */
8356 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8360 gfc_error ("Unsupported statement inside WHERE at %L",
8363 /* the next statement within the same where-body-construct */
8364 cnext = cnext->next;
8366 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8367 cblock = cblock->block;
8372 /* Traverse the FORALL body to check whether the following errors exist:
8373 1. For assignment, check if a many-to-one assignment happens.
8374 2. For WHERE statement, check the WHERE body to see if there is any
8375 many-to-one assignment. */
8378 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8382 c = code->block->next;
8388 case EXEC_POINTER_ASSIGN:
8389 gfc_resolve_assign_in_forall (c, nvar, var_expr);
8392 case EXEC_ASSIGN_CALL:
8396 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8397 there is no need to handle it here. */
8401 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8406 /* The next statement in the FORALL body. */
8412 /* Counts the number of iterators needed inside a forall construct, including
8413 nested forall constructs. This is used to allocate the needed memory
8414 in gfc_resolve_forall. */
8417 gfc_count_forall_iterators (gfc_code *code)
8419 int max_iters, sub_iters, current_iters;
8420 gfc_forall_iterator *fa;
8422 gcc_assert(code->op == EXEC_FORALL);
8426 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8429 code = code->block->next;
8433 if (code->op == EXEC_FORALL)
8435 sub_iters = gfc_count_forall_iterators (code);
8436 if (sub_iters > max_iters)
8437 max_iters = sub_iters;
8442 return current_iters + max_iters;
8446 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8447 gfc_resolve_forall_body to resolve the FORALL body. */
8450 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8452 static gfc_expr **var_expr;
8453 static int total_var = 0;
8454 static int nvar = 0;
8456 gfc_forall_iterator *fa;
8461 /* Start to resolve a FORALL construct */
8462 if (forall_save == 0)
8464 /* Count the total number of FORALL index in the nested FORALL
8465 construct in order to allocate the VAR_EXPR with proper size. */
8466 total_var = gfc_count_forall_iterators (code);
8468 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8469 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
8472 /* The information about FORALL iterator, including FORALL index start, end
8473 and stride. The FORALL index can not appear in start, end or stride. */
8474 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8476 /* Check if any outer FORALL index name is the same as the current
8478 for (i = 0; i < nvar; i++)
8480 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8482 gfc_error ("An outer FORALL construct already has an index "
8483 "with this name %L", &fa->var->where);
8487 /* Record the current FORALL index. */
8488 var_expr[nvar] = gfc_copy_expr (fa->var);
8492 /* No memory leak. */
8493 gcc_assert (nvar <= total_var);
8496 /* Resolve the FORALL body. */
8497 gfc_resolve_forall_body (code, nvar, var_expr);
8499 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8500 gfc_resolve_blocks (code->block, ns);
8504 /* Free only the VAR_EXPRs allocated in this frame. */
8505 for (i = nvar; i < tmp; i++)
8506 gfc_free_expr (var_expr[i]);
8510 /* We are in the outermost FORALL construct. */
8511 gcc_assert (forall_save == 0);
8513 /* VAR_EXPR is not needed any more. */
8514 gfc_free (var_expr);
8520 /* Resolve a BLOCK construct statement. */
8523 resolve_block_construct (gfc_code* code)
8525 /* Resolve the BLOCK's namespace. */
8526 gfc_resolve (code->ext.block.ns);
8528 /* For an ASSOCIATE block, the associations (and their targets) are already
8529 resolved during resolve_symbol. */
8533 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8536 static void resolve_code (gfc_code *, gfc_namespace *);
8539 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8543 for (; b; b = b->block)
8545 t = gfc_resolve_expr (b->expr1);
8546 if (gfc_resolve_expr (b->expr2) == FAILURE)
8552 if (t == SUCCESS && b->expr1 != NULL
8553 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
8554 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8561 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
8562 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8567 resolve_branch (b->label1, b);
8571 resolve_block_construct (b);
8575 case EXEC_SELECT_TYPE:
8586 case EXEC_OMP_ATOMIC:
8587 case EXEC_OMP_CRITICAL:
8589 case EXEC_OMP_MASTER:
8590 case EXEC_OMP_ORDERED:
8591 case EXEC_OMP_PARALLEL:
8592 case EXEC_OMP_PARALLEL_DO:
8593 case EXEC_OMP_PARALLEL_SECTIONS:
8594 case EXEC_OMP_PARALLEL_WORKSHARE:
8595 case EXEC_OMP_SECTIONS:
8596 case EXEC_OMP_SINGLE:
8598 case EXEC_OMP_TASKWAIT:
8599 case EXEC_OMP_WORKSHARE:
8603 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
8606 resolve_code (b->next, ns);
8611 /* Does everything to resolve an ordinary assignment. Returns true
8612 if this is an interface assignment. */
8614 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
8624 if (gfc_extend_assign (code, ns) == SUCCESS)
8628 if (code->op == EXEC_ASSIGN_CALL)
8630 lhs = code->ext.actual->expr;
8631 rhsptr = &code->ext.actual->next->expr;
8635 gfc_actual_arglist* args;
8636 gfc_typebound_proc* tbp;
8638 gcc_assert (code->op == EXEC_COMPCALL);
8640 args = code->expr1->value.compcall.actual;
8642 rhsptr = &args->next->expr;
8644 tbp = code->expr1->value.compcall.tbp;
8645 gcc_assert (!tbp->is_generic);
8648 /* Make a temporary rhs when there is a default initializer
8649 and rhs is the same symbol as the lhs. */
8650 if ((*rhsptr)->expr_type == EXPR_VARIABLE
8651 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
8652 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
8653 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
8654 *rhsptr = gfc_get_parentheses (*rhsptr);
8663 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
8664 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
8665 &code->loc) == FAILURE)
8668 /* Handle the case of a BOZ literal on the RHS. */
8669 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
8672 if (gfc_option.warn_surprising)
8673 gfc_warning ("BOZ literal at %L is bitwise transferred "
8674 "non-integer symbol '%s'", &code->loc,
8675 lhs->symtree->n.sym->name);
8677 if (!gfc_convert_boz (rhs, &lhs->ts))
8679 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
8681 if (rc == ARITH_UNDERFLOW)
8682 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
8683 ". This check can be disabled with the option "
8684 "-fno-range-check", &rhs->where);
8685 else if (rc == ARITH_OVERFLOW)
8686 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
8687 ". This check can be disabled with the option "
8688 "-fno-range-check", &rhs->where);
8689 else if (rc == ARITH_NAN)
8690 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
8691 ". This check can be disabled with the option "
8692 "-fno-range-check", &rhs->where);
8697 if (lhs->ts.type == BT_CHARACTER
8698 && gfc_option.warn_character_truncation)
8700 if (lhs->ts.u.cl != NULL
8701 && lhs->ts.u.cl->length != NULL
8702 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8703 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
8705 if (rhs->expr_type == EXPR_CONSTANT)
8706 rlen = rhs->value.character.length;
8708 else if (rhs->ts.u.cl != NULL
8709 && rhs->ts.u.cl->length != NULL
8710 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8711 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
8713 if (rlen && llen && rlen > llen)
8714 gfc_warning_now ("CHARACTER expression will be truncated "
8715 "in assignment (%d/%d) at %L",
8716 llen, rlen, &code->loc);
8719 /* Ensure that a vector index expression for the lvalue is evaluated
8720 to a temporary if the lvalue symbol is referenced in it. */
8723 for (ref = lhs->ref; ref; ref= ref->next)
8724 if (ref->type == REF_ARRAY)
8726 for (n = 0; n < ref->u.ar.dimen; n++)
8727 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
8728 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
8729 ref->u.ar.start[n]))
8731 = gfc_get_parentheses (ref->u.ar.start[n]);
8735 if (gfc_pure (NULL))
8737 if (lhs->ts.type == BT_DERIVED
8738 && lhs->expr_type == EXPR_VARIABLE
8739 && lhs->ts.u.derived->attr.pointer_comp
8740 && rhs->expr_type == EXPR_VARIABLE
8741 && (gfc_impure_variable (rhs->symtree->n.sym)
8742 || gfc_is_coindexed (rhs)))
8745 if (gfc_is_coindexed (rhs))
8746 gfc_error ("Coindexed expression at %L is assigned to "
8747 "a derived type variable with a POINTER "
8748 "component in a PURE procedure",
8751 gfc_error ("The impure variable at %L is assigned to "
8752 "a derived type variable with a POINTER "
8753 "component in a PURE procedure (12.6)",
8758 /* Fortran 2008, C1283. */
8759 if (gfc_is_coindexed (lhs))
8761 gfc_error ("Assignment to coindexed variable at %L in a PURE "
8762 "procedure", &rhs->where);
8768 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
8769 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
8770 if (lhs->ts.type == BT_CLASS)
8772 gfc_error ("Variable must not be polymorphic in assignment at %L",
8777 /* F2008, Section 7.2.1.2. */
8778 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
8780 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
8781 "component in assignment at %L", &lhs->where);
8785 gfc_check_assign (lhs, rhs, 1);
8790 /* Given a block of code, recursively resolve everything pointed to by this
8794 resolve_code (gfc_code *code, gfc_namespace *ns)
8796 int omp_workshare_save;
8801 frame.prev = cs_base;
8805 find_reachable_labels (code);
8807 for (; code; code = code->next)
8809 frame.current = code;
8810 forall_save = forall_flag;
8812 if (code->op == EXEC_FORALL)
8815 gfc_resolve_forall (code, ns, forall_save);
8818 else if (code->block)
8820 omp_workshare_save = -1;
8823 case EXEC_OMP_PARALLEL_WORKSHARE:
8824 omp_workshare_save = omp_workshare_flag;
8825 omp_workshare_flag = 1;
8826 gfc_resolve_omp_parallel_blocks (code, ns);
8828 case EXEC_OMP_PARALLEL:
8829 case EXEC_OMP_PARALLEL_DO:
8830 case EXEC_OMP_PARALLEL_SECTIONS:
8832 omp_workshare_save = omp_workshare_flag;
8833 omp_workshare_flag = 0;
8834 gfc_resolve_omp_parallel_blocks (code, ns);
8837 gfc_resolve_omp_do_blocks (code, ns);
8839 case EXEC_SELECT_TYPE:
8840 /* Blocks are handled in resolve_select_type because we have
8841 to transform the SELECT TYPE into ASSOCIATE first. */
8843 case EXEC_OMP_WORKSHARE:
8844 omp_workshare_save = omp_workshare_flag;
8845 omp_workshare_flag = 1;
8848 gfc_resolve_blocks (code->block, ns);
8852 if (omp_workshare_save != -1)
8853 omp_workshare_flag = omp_workshare_save;
8857 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
8858 t = gfc_resolve_expr (code->expr1);
8859 forall_flag = forall_save;
8861 if (gfc_resolve_expr (code->expr2) == FAILURE)
8864 if (code->op == EXEC_ALLOCATE
8865 && gfc_resolve_expr (code->expr3) == FAILURE)
8871 case EXEC_END_BLOCK:
8875 case EXEC_ERROR_STOP:
8879 case EXEC_ASSIGN_CALL:
8884 case EXEC_SYNC_IMAGES:
8885 case EXEC_SYNC_MEMORY:
8886 resolve_sync (code);
8890 /* Keep track of which entry we are up to. */
8891 current_entry_id = code->ext.entry->id;
8895 resolve_where (code, NULL);
8899 if (code->expr1 != NULL)
8901 if (code->expr1->ts.type != BT_INTEGER)
8902 gfc_error ("ASSIGNED GOTO statement at %L requires an "
8903 "INTEGER variable", &code->expr1->where);
8904 else if (code->expr1->symtree->n.sym->attr.assign != 1)
8905 gfc_error ("Variable '%s' has not been assigned a target "
8906 "label at %L", code->expr1->symtree->n.sym->name,
8907 &code->expr1->where);
8910 resolve_branch (code->label1, code);
8914 if (code->expr1 != NULL
8915 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
8916 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
8917 "INTEGER return specifier", &code->expr1->where);
8920 case EXEC_INIT_ASSIGN:
8921 case EXEC_END_PROCEDURE:
8928 if (gfc_check_vardef_context (code->expr1, false, _("assignment"))
8932 if (resolve_ordinary_assign (code, ns))
8934 if (code->op == EXEC_COMPCALL)
8941 case EXEC_LABEL_ASSIGN:
8942 if (code->label1->defined == ST_LABEL_UNKNOWN)
8943 gfc_error ("Label %d referenced at %L is never defined",
8944 code->label1->value, &code->label1->where);
8946 && (code->expr1->expr_type != EXPR_VARIABLE
8947 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
8948 || code->expr1->symtree->n.sym->ts.kind
8949 != gfc_default_integer_kind
8950 || code->expr1->symtree->n.sym->as != NULL))
8951 gfc_error ("ASSIGN statement at %L requires a scalar "
8952 "default INTEGER variable", &code->expr1->where);
8955 case EXEC_POINTER_ASSIGN:
8962 /* This is both a variable definition and pointer assignment
8963 context, so check both of them. For rank remapping, a final
8964 array ref may be present on the LHS and fool gfc_expr_attr
8965 used in gfc_check_vardef_context. Remove it. */
8966 e = remove_last_array_ref (code->expr1);
8967 t = gfc_check_vardef_context (e, true, _("pointer assignment"));
8969 t = gfc_check_vardef_context (e, false, _("pointer assignment"));
8974 gfc_check_pointer_assign (code->expr1, code->expr2);
8978 case EXEC_ARITHMETIC_IF:
8980 && code->expr1->ts.type != BT_INTEGER
8981 && code->expr1->ts.type != BT_REAL)
8982 gfc_error ("Arithmetic IF statement at %L requires a numeric "
8983 "expression", &code->expr1->where);
8985 resolve_branch (code->label1, code);
8986 resolve_branch (code->label2, code);
8987 resolve_branch (code->label3, code);
8991 if (t == SUCCESS && code->expr1 != NULL
8992 && (code->expr1->ts.type != BT_LOGICAL
8993 || code->expr1->rank != 0))
8994 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8995 &code->expr1->where);
9000 resolve_call (code);
9005 resolve_typebound_subroutine (code);
9009 resolve_ppc_call (code);
9013 /* Select is complicated. Also, a SELECT construct could be
9014 a transformed computed GOTO. */
9015 resolve_select (code);
9018 case EXEC_SELECT_TYPE:
9019 resolve_select_type (code, ns);
9023 resolve_block_construct (code);
9027 if (code->ext.iterator != NULL)
9029 gfc_iterator *iter = code->ext.iterator;
9030 if (gfc_resolve_iterator (iter, true) != FAILURE)
9031 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
9036 if (code->expr1 == NULL)
9037 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9039 && (code->expr1->rank != 0
9040 || code->expr1->ts.type != BT_LOGICAL))
9041 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9042 "a scalar LOGICAL expression", &code->expr1->where);
9047 resolve_allocate_deallocate (code, "ALLOCATE");
9051 case EXEC_DEALLOCATE:
9053 resolve_allocate_deallocate (code, "DEALLOCATE");
9058 if (gfc_resolve_open (code->ext.open) == FAILURE)
9061 resolve_branch (code->ext.open->err, code);
9065 if (gfc_resolve_close (code->ext.close) == FAILURE)
9068 resolve_branch (code->ext.close->err, code);
9071 case EXEC_BACKSPACE:
9075 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
9078 resolve_branch (code->ext.filepos->err, code);
9082 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9085 resolve_branch (code->ext.inquire->err, code);
9089 gcc_assert (code->ext.inquire != NULL);
9090 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9093 resolve_branch (code->ext.inquire->err, code);
9097 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
9100 resolve_branch (code->ext.wait->err, code);
9101 resolve_branch (code->ext.wait->end, code);
9102 resolve_branch (code->ext.wait->eor, code);
9107 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
9110 resolve_branch (code->ext.dt->err, code);
9111 resolve_branch (code->ext.dt->end, code);
9112 resolve_branch (code->ext.dt->eor, code);
9116 resolve_transfer (code);
9120 resolve_forall_iterators (code->ext.forall_iterator);
9122 if (code->expr1 != NULL
9123 && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
9124 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9125 "expression", &code->expr1->where);
9128 case EXEC_OMP_ATOMIC:
9129 case EXEC_OMP_BARRIER:
9130 case EXEC_OMP_CRITICAL:
9131 case EXEC_OMP_FLUSH:
9133 case EXEC_OMP_MASTER:
9134 case EXEC_OMP_ORDERED:
9135 case EXEC_OMP_SECTIONS:
9136 case EXEC_OMP_SINGLE:
9137 case EXEC_OMP_TASKWAIT:
9138 case EXEC_OMP_WORKSHARE:
9139 gfc_resolve_omp_directive (code, ns);
9142 case EXEC_OMP_PARALLEL:
9143 case EXEC_OMP_PARALLEL_DO:
9144 case EXEC_OMP_PARALLEL_SECTIONS:
9145 case EXEC_OMP_PARALLEL_WORKSHARE:
9147 omp_workshare_save = omp_workshare_flag;
9148 omp_workshare_flag = 0;
9149 gfc_resolve_omp_directive (code, ns);
9150 omp_workshare_flag = omp_workshare_save;
9154 gfc_internal_error ("resolve_code(): Bad statement code");
9158 cs_base = frame.prev;
9162 /* Resolve initial values and make sure they are compatible with
9166 resolve_values (gfc_symbol *sym)
9170 if (sym->value == NULL)
9173 if (sym->value->expr_type == EXPR_STRUCTURE)
9174 t= resolve_structure_cons (sym->value, 1);
9176 t = gfc_resolve_expr (sym->value);
9181 gfc_check_assign_symbol (sym, sym->value);
9185 /* Verify the binding labels for common blocks that are BIND(C). The label
9186 for a BIND(C) common block must be identical in all scoping units in which
9187 the common block is declared. Further, the binding label can not collide
9188 with any other global entity in the program. */
9191 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
9193 if (comm_block_tree->n.common->is_bind_c == 1)
9195 gfc_gsymbol *binding_label_gsym;
9196 gfc_gsymbol *comm_name_gsym;
9198 /* See if a global symbol exists by the common block's name. It may
9199 be NULL if the common block is use-associated. */
9200 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
9201 comm_block_tree->n.common->name);
9202 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
9203 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9204 "with the global entity '%s' at %L",
9205 comm_block_tree->n.common->binding_label,
9206 comm_block_tree->n.common->name,
9207 &(comm_block_tree->n.common->where),
9208 comm_name_gsym->name, &(comm_name_gsym->where));
9209 else if (comm_name_gsym != NULL
9210 && strcmp (comm_name_gsym->name,
9211 comm_block_tree->n.common->name) == 0)
9213 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9215 if (comm_name_gsym->binding_label == NULL)
9216 /* No binding label for common block stored yet; save this one. */
9217 comm_name_gsym->binding_label =
9218 comm_block_tree->n.common->binding_label;
9220 if (strcmp (comm_name_gsym->binding_label,
9221 comm_block_tree->n.common->binding_label) != 0)
9223 /* Common block names match but binding labels do not. */
9224 gfc_error ("Binding label '%s' for common block '%s' at %L "
9225 "does not match the binding label '%s' for common "
9227 comm_block_tree->n.common->binding_label,
9228 comm_block_tree->n.common->name,
9229 &(comm_block_tree->n.common->where),
9230 comm_name_gsym->binding_label,
9231 comm_name_gsym->name,
9232 &(comm_name_gsym->where));
9237 /* There is no binding label (NAME="") so we have nothing further to
9238 check and nothing to add as a global symbol for the label. */
9239 if (comm_block_tree->n.common->binding_label[0] == '\0' )
9242 binding_label_gsym =
9243 gfc_find_gsymbol (gfc_gsym_root,
9244 comm_block_tree->n.common->binding_label);
9245 if (binding_label_gsym == NULL)
9247 /* Need to make a global symbol for the binding label to prevent
9248 it from colliding with another. */
9249 binding_label_gsym =
9250 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9251 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9252 binding_label_gsym->type = GSYM_COMMON;
9256 /* If comm_name_gsym is NULL, the name common block is use
9257 associated and the name could be colliding. */
9258 if (binding_label_gsym->type != GSYM_COMMON)
9259 gfc_error ("Binding label '%s' for common block '%s' at %L "
9260 "collides with the global entity '%s' at %L",
9261 comm_block_tree->n.common->binding_label,
9262 comm_block_tree->n.common->name,
9263 &(comm_block_tree->n.common->where),
9264 binding_label_gsym->name,
9265 &(binding_label_gsym->where));
9266 else if (comm_name_gsym != NULL
9267 && (strcmp (binding_label_gsym->name,
9268 comm_name_gsym->binding_label) != 0)
9269 && (strcmp (binding_label_gsym->sym_name,
9270 comm_name_gsym->name) != 0))
9271 gfc_error ("Binding label '%s' for common block '%s' at %L "
9272 "collides with global entity '%s' at %L",
9273 binding_label_gsym->name, binding_label_gsym->sym_name,
9274 &(comm_block_tree->n.common->where),
9275 comm_name_gsym->name, &(comm_name_gsym->where));
9283 /* Verify any BIND(C) derived types in the namespace so we can report errors
9284 for them once, rather than for each variable declared of that type. */
9287 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9289 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9290 && derived_sym->attr.is_bind_c == 1)
9291 verify_bind_c_derived_type (derived_sym);
9297 /* Verify that any binding labels used in a given namespace do not collide
9298 with the names or binding labels of any global symbols. */
9301 gfc_verify_binding_labels (gfc_symbol *sym)
9305 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9306 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
9308 gfc_gsymbol *bind_c_sym;
9310 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9311 if (bind_c_sym != NULL
9312 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9314 if (sym->attr.if_source == IFSRC_DECL
9315 && (bind_c_sym->type != GSYM_SUBROUTINE
9316 && bind_c_sym->type != GSYM_FUNCTION)
9317 && ((sym->attr.contained == 1
9318 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9319 || (sym->attr.use_assoc == 1
9320 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9322 /* Make sure global procedures don't collide with anything. */
9323 gfc_error ("Binding label '%s' at %L collides with the global "
9324 "entity '%s' at %L", sym->binding_label,
9325 &(sym->declared_at), bind_c_sym->name,
9326 &(bind_c_sym->where));
9329 else if (sym->attr.contained == 0
9330 && (sym->attr.if_source == IFSRC_IFBODY
9331 && sym->attr.flavor == FL_PROCEDURE)
9332 && (bind_c_sym->sym_name != NULL
9333 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9335 /* Make sure procedures in interface bodies don't collide. */
9336 gfc_error ("Binding label '%s' in interface body at %L collides "
9337 "with the global entity '%s' at %L",
9339 &(sym->declared_at), bind_c_sym->name,
9340 &(bind_c_sym->where));
9343 else if (sym->attr.contained == 0
9344 && sym->attr.if_source == IFSRC_UNKNOWN)
9345 if ((sym->attr.use_assoc && bind_c_sym->mod_name
9346 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9347 || sym->attr.use_assoc == 0)
9349 gfc_error ("Binding label '%s' at %L collides with global "
9350 "entity '%s' at %L", sym->binding_label,
9351 &(sym->declared_at), bind_c_sym->name,
9352 &(bind_c_sym->where));
9357 /* Clear the binding label to prevent checking multiple times. */
9358 sym->binding_label[0] = '\0';
9360 else if (bind_c_sym == NULL)
9362 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9363 bind_c_sym->where = sym->declared_at;
9364 bind_c_sym->sym_name = sym->name;
9366 if (sym->attr.use_assoc == 1)
9367 bind_c_sym->mod_name = sym->module;
9369 if (sym->ns->proc_name != NULL)
9370 bind_c_sym->mod_name = sym->ns->proc_name->name;
9372 if (sym->attr.contained == 0)
9374 if (sym->attr.subroutine)
9375 bind_c_sym->type = GSYM_SUBROUTINE;
9376 else if (sym->attr.function)
9377 bind_c_sym->type = GSYM_FUNCTION;
9385 /* Resolve an index expression. */
9388 resolve_index_expr (gfc_expr *e)
9390 if (gfc_resolve_expr (e) == FAILURE)
9393 if (gfc_simplify_expr (e, 0) == FAILURE)
9396 if (gfc_specification_expr (e) == FAILURE)
9403 /* Resolve a charlen structure. */
9406 resolve_charlen (gfc_charlen *cl)
9415 specification_expr = 1;
9417 if (resolve_index_expr (cl->length) == FAILURE)
9419 specification_expr = 0;
9423 /* "If the character length parameter value evaluates to a negative
9424 value, the length of character entities declared is zero." */
9425 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9427 if (gfc_option.warn_surprising)
9428 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9429 " the length has been set to zero",
9430 &cl->length->where, i);
9431 gfc_replace_expr (cl->length,
9432 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9435 /* Check that the character length is not too large. */
9436 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9437 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9438 && cl->length->ts.type == BT_INTEGER
9439 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9441 gfc_error ("String length at %L is too large", &cl->length->where);
9449 /* Test for non-constant shape arrays. */
9452 is_non_constant_shape_array (gfc_symbol *sym)
9458 not_constant = false;
9459 if (sym->as != NULL)
9461 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9462 has not been simplified; parameter array references. Do the
9463 simplification now. */
9464 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9466 e = sym->as->lower[i];
9467 if (e && (resolve_index_expr (e) == FAILURE
9468 || !gfc_is_constant_expr (e)))
9469 not_constant = true;
9470 e = sym->as->upper[i];
9471 if (e && (resolve_index_expr (e) == FAILURE
9472 || !gfc_is_constant_expr (e)))
9473 not_constant = true;
9476 return not_constant;
9479 /* Given a symbol and an initialization expression, add code to initialize
9480 the symbol to the function entry. */
9482 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9486 gfc_namespace *ns = sym->ns;
9488 /* Search for the function namespace if this is a contained
9489 function without an explicit result. */
9490 if (sym->attr.function && sym == sym->result
9491 && sym->name != sym->ns->proc_name->name)
9494 for (;ns; ns = ns->sibling)
9495 if (strcmp (ns->proc_name->name, sym->name) == 0)
9501 gfc_free_expr (init);
9505 /* Build an l-value expression for the result. */
9506 lval = gfc_lval_expr_from_sym (sym);
9508 /* Add the code at scope entry. */
9509 init_st = gfc_get_code ();
9510 init_st->next = ns->code;
9513 /* Assign the default initializer to the l-value. */
9514 init_st->loc = sym->declared_at;
9515 init_st->op = EXEC_INIT_ASSIGN;
9516 init_st->expr1 = lval;
9517 init_st->expr2 = init;
9520 /* Assign the default initializer to a derived type variable or result. */
9523 apply_default_init (gfc_symbol *sym)
9525 gfc_expr *init = NULL;
9527 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9530 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
9531 init = gfc_default_initializer (&sym->ts);
9533 if (init == NULL && sym->ts.type != BT_CLASS)
9536 build_init_assign (sym, init);
9537 sym->attr.referenced = 1;
9540 /* Build an initializer for a local integer, real, complex, logical, or
9541 character variable, based on the command line flags finit-local-zero,
9542 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
9543 null if the symbol should not have a default initialization. */
9545 build_default_init_expr (gfc_symbol *sym)
9548 gfc_expr *init_expr;
9551 /* These symbols should never have a default initialization. */
9552 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
9553 || sym->attr.external
9555 || sym->attr.pointer
9556 || sym->attr.in_equivalence
9557 || sym->attr.in_common
9560 || sym->attr.cray_pointee
9561 || sym->attr.cray_pointer)
9564 /* Now we'll try to build an initializer expression. */
9565 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
9568 /* We will only initialize integers, reals, complex, logicals, and
9569 characters, and only if the corresponding command-line flags
9570 were set. Otherwise, we free init_expr and return null. */
9571 switch (sym->ts.type)
9574 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
9575 mpz_set_si (init_expr->value.integer,
9576 gfc_option.flag_init_integer_value);
9579 gfc_free_expr (init_expr);
9585 switch (gfc_option.flag_init_real)
9587 case GFC_INIT_REAL_SNAN:
9588 init_expr->is_snan = 1;
9590 case GFC_INIT_REAL_NAN:
9591 mpfr_set_nan (init_expr->value.real);
9594 case GFC_INIT_REAL_INF:
9595 mpfr_set_inf (init_expr->value.real, 1);
9598 case GFC_INIT_REAL_NEG_INF:
9599 mpfr_set_inf (init_expr->value.real, -1);
9602 case GFC_INIT_REAL_ZERO:
9603 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
9607 gfc_free_expr (init_expr);
9614 switch (gfc_option.flag_init_real)
9616 case GFC_INIT_REAL_SNAN:
9617 init_expr->is_snan = 1;
9619 case GFC_INIT_REAL_NAN:
9620 mpfr_set_nan (mpc_realref (init_expr->value.complex));
9621 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
9624 case GFC_INIT_REAL_INF:
9625 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
9626 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
9629 case GFC_INIT_REAL_NEG_INF:
9630 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
9631 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
9634 case GFC_INIT_REAL_ZERO:
9635 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
9639 gfc_free_expr (init_expr);
9646 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
9647 init_expr->value.logical = 0;
9648 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
9649 init_expr->value.logical = 1;
9652 gfc_free_expr (init_expr);
9658 /* For characters, the length must be constant in order to
9659 create a default initializer. */
9660 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
9661 && sym->ts.u.cl->length
9662 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9664 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
9665 init_expr->value.character.length = char_len;
9666 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
9667 for (i = 0; i < char_len; i++)
9668 init_expr->value.character.string[i]
9669 = (unsigned char) gfc_option.flag_init_character_value;
9673 gfc_free_expr (init_expr);
9679 gfc_free_expr (init_expr);
9685 /* Add an initialization expression to a local variable. */
9687 apply_default_init_local (gfc_symbol *sym)
9689 gfc_expr *init = NULL;
9691 /* The symbol should be a variable or a function return value. */
9692 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9693 || (sym->attr.function && sym->result != sym))
9696 /* Try to build the initializer expression. If we can't initialize
9697 this symbol, then init will be NULL. */
9698 init = build_default_init_expr (sym);
9702 /* For saved variables, we don't want to add an initializer at
9703 function entry, so we just add a static initializer. */
9704 if (sym->attr.save || sym->ns->save_all
9705 || gfc_option.flag_max_stack_var_size == 0)
9707 /* Don't clobber an existing initializer! */
9708 gcc_assert (sym->value == NULL);
9713 build_init_assign (sym, init);
9717 /* Resolution of common features of flavors variable and procedure. */
9720 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
9722 /* Constraints on deferred shape variable. */
9723 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
9725 if (sym->attr.allocatable)
9727 if (sym->attr.dimension)
9729 gfc_error ("Allocatable array '%s' at %L must have "
9730 "a deferred shape", sym->name, &sym->declared_at);
9733 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
9734 "may not be ALLOCATABLE", sym->name,
9735 &sym->declared_at) == FAILURE)
9739 if (sym->attr.pointer && sym->attr.dimension)
9741 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
9742 sym->name, &sym->declared_at);
9748 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
9749 && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc)
9751 gfc_error ("Array '%s' at %L cannot have a deferred shape",
9752 sym->name, &sym->declared_at);
9757 /* Constraints on polymorphic variables. */
9758 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
9761 if (sym->attr.class_ok
9762 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
9764 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
9765 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
9771 /* Assume that use associated symbols were checked in the module ns.
9772 Class-variables that are associate-names are also something special
9773 and excepted from the test. */
9774 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
9776 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
9777 "or pointer", sym->name, &sym->declared_at);
9786 /* Additional checks for symbols with flavor variable and derived
9787 type. To be called from resolve_fl_variable. */
9790 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
9792 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
9794 /* Check to see if a derived type is blocked from being host
9795 associated by the presence of another class I symbol in the same
9796 namespace. 14.6.1.3 of the standard and the discussion on
9797 comp.lang.fortran. */
9798 if (sym->ns != sym->ts.u.derived->ns
9799 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
9802 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
9803 if (s && s->attr.flavor != FL_DERIVED)
9805 gfc_error ("The type '%s' cannot be host associated at %L "
9806 "because it is blocked by an incompatible object "
9807 "of the same name declared at %L",
9808 sym->ts.u.derived->name, &sym->declared_at,
9814 /* 4th constraint in section 11.3: "If an object of a type for which
9815 component-initialization is specified (R429) appears in the
9816 specification-part of a module and does not have the ALLOCATABLE
9817 or POINTER attribute, the object shall have the SAVE attribute."
9819 The check for initializers is performed with
9820 gfc_has_default_initializer because gfc_default_initializer generates
9821 a hidden default for allocatable components. */
9822 if (!(sym->value || no_init_flag) && sym->ns->proc_name
9823 && sym->ns->proc_name->attr.flavor == FL_MODULE
9824 && !sym->ns->save_all && !sym->attr.save
9825 && !sym->attr.pointer && !sym->attr.allocatable
9826 && gfc_has_default_initializer (sym->ts.u.derived)
9827 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
9828 "module variable '%s' at %L, needed due to "
9829 "the default initialization", sym->name,
9830 &sym->declared_at) == FAILURE)
9833 /* Assign default initializer. */
9834 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
9835 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
9837 sym->value = gfc_default_initializer (&sym->ts);
9844 /* Resolve symbols with flavor variable. */
9847 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
9849 int no_init_flag, automatic_flag;
9851 const char *auto_save_msg;
9853 auto_save_msg = "Automatic object '%s' at %L cannot have the "
9856 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9859 /* Set this flag to check that variables are parameters of all entries.
9860 This check is effected by the call to gfc_resolve_expr through
9861 is_non_constant_shape_array. */
9862 specification_expr = 1;
9864 if (sym->ns->proc_name
9865 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9866 || sym->ns->proc_name->attr.is_main_program)
9867 && !sym->attr.use_assoc
9868 && !sym->attr.allocatable
9869 && !sym->attr.pointer
9870 && is_non_constant_shape_array (sym))
9872 /* The shape of a main program or module array needs to be
9874 gfc_error ("The module or main program array '%s' at %L must "
9875 "have constant shape", sym->name, &sym->declared_at);
9876 specification_expr = 0;
9880 /* Constraints on deferred type parameter. */
9881 if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
9883 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
9884 "requires either the pointer or allocatable attribute",
9885 sym->name, &sym->declared_at);
9889 if (sym->ts.type == BT_CHARACTER)
9891 /* Make sure that character string variables with assumed length are
9893 e = sym->ts.u.cl->length;
9894 if (e == NULL && !sym->attr.dummy && !sym->attr.result
9895 && !sym->ts.deferred)
9897 gfc_error ("Entity with assumed character length at %L must be a "
9898 "dummy argument or a PARAMETER", &sym->declared_at);
9902 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
9904 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9908 if (!gfc_is_constant_expr (e)
9909 && !(e->expr_type == EXPR_VARIABLE
9910 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
9911 && sym->ns->proc_name
9912 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9913 || sym->ns->proc_name->attr.is_main_program)
9914 && !sym->attr.use_assoc)
9916 gfc_error ("'%s' at %L must have constant character length "
9917 "in this context", sym->name, &sym->declared_at);
9922 if (sym->value == NULL && sym->attr.referenced)
9923 apply_default_init_local (sym); /* Try to apply a default initialization. */
9925 /* Determine if the symbol may not have an initializer. */
9926 no_init_flag = automatic_flag = 0;
9927 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
9928 || sym->attr.intrinsic || sym->attr.result)
9930 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
9931 && is_non_constant_shape_array (sym))
9933 no_init_flag = automatic_flag = 1;
9935 /* Also, they must not have the SAVE attribute.
9936 SAVE_IMPLICIT is checked below. */
9937 if (sym->attr.save == SAVE_EXPLICIT)
9939 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9944 /* Ensure that any initializer is simplified. */
9946 gfc_simplify_expr (sym->value, 1);
9948 /* Reject illegal initializers. */
9949 if (!sym->mark && sym->value)
9951 if (sym->attr.allocatable)
9952 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
9953 sym->name, &sym->declared_at);
9954 else if (sym->attr.external)
9955 gfc_error ("External '%s' at %L cannot have an initializer",
9956 sym->name, &sym->declared_at);
9957 else if (sym->attr.dummy
9958 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
9959 gfc_error ("Dummy '%s' at %L cannot have an initializer",
9960 sym->name, &sym->declared_at);
9961 else if (sym->attr.intrinsic)
9962 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
9963 sym->name, &sym->declared_at);
9964 else if (sym->attr.result)
9965 gfc_error ("Function result '%s' at %L cannot have an initializer",
9966 sym->name, &sym->declared_at);
9967 else if (automatic_flag)
9968 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
9969 sym->name, &sym->declared_at);
9976 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
9977 return resolve_fl_variable_derived (sym, no_init_flag);
9983 /* Resolve a procedure. */
9986 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
9988 gfc_formal_arglist *arg;
9990 if (sym->attr.function
9991 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9994 if (sym->ts.type == BT_CHARACTER)
9996 gfc_charlen *cl = sym->ts.u.cl;
9998 if (cl && cl->length && gfc_is_constant_expr (cl->length)
9999 && resolve_charlen (cl) == FAILURE)
10002 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
10003 && sym->attr.proc == PROC_ST_FUNCTION)
10005 gfc_error ("Character-valued statement function '%s' at %L must "
10006 "have constant length", sym->name, &sym->declared_at);
10011 /* Ensure that derived type for are not of a private type. Internal
10012 module procedures are excluded by 2.2.3.3 - i.e., they are not
10013 externally accessible and can access all the objects accessible in
10015 if (!(sym->ns->parent
10016 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
10017 && gfc_check_access(sym->attr.access, sym->ns->default_access))
10019 gfc_interface *iface;
10021 for (arg = sym->formal; arg; arg = arg->next)
10024 && arg->sym->ts.type == BT_DERIVED
10025 && !arg->sym->ts.u.derived->attr.use_assoc
10026 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10027 arg->sym->ts.u.derived->ns->default_access)
10028 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
10029 "PRIVATE type and cannot be a dummy argument"
10030 " of '%s', which is PUBLIC at %L",
10031 arg->sym->name, sym->name, &sym->declared_at)
10034 /* Stop this message from recurring. */
10035 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10040 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10041 PRIVATE to the containing module. */
10042 for (iface = sym->generic; iface; iface = iface->next)
10044 for (arg = iface->sym->formal; arg; arg = arg->next)
10047 && arg->sym->ts.type == BT_DERIVED
10048 && !arg->sym->ts.u.derived->attr.use_assoc
10049 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10050 arg->sym->ts.u.derived->ns->default_access)
10051 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10052 "'%s' in PUBLIC interface '%s' at %L "
10053 "takes dummy arguments of '%s' which is "
10054 "PRIVATE", iface->sym->name, sym->name,
10055 &iface->sym->declared_at,
10056 gfc_typename (&arg->sym->ts)) == FAILURE)
10058 /* Stop this message from recurring. */
10059 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10065 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10066 PRIVATE to the containing module. */
10067 for (iface = sym->generic; iface; iface = iface->next)
10069 for (arg = iface->sym->formal; arg; arg = arg->next)
10072 && arg->sym->ts.type == BT_DERIVED
10073 && !arg->sym->ts.u.derived->attr.use_assoc
10074 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10075 arg->sym->ts.u.derived->ns->default_access)
10076 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10077 "'%s' in PUBLIC interface '%s' at %L "
10078 "takes dummy arguments of '%s' which is "
10079 "PRIVATE", iface->sym->name, sym->name,
10080 &iface->sym->declared_at,
10081 gfc_typename (&arg->sym->ts)) == FAILURE)
10083 /* Stop this message from recurring. */
10084 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10091 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10092 && !sym->attr.proc_pointer)
10094 gfc_error ("Function '%s' at %L cannot have an initializer",
10095 sym->name, &sym->declared_at);
10099 /* An external symbol may not have an initializer because it is taken to be
10100 a procedure. Exception: Procedure Pointers. */
10101 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10103 gfc_error ("External object '%s' at %L may not have an initializer",
10104 sym->name, &sym->declared_at);
10108 /* An elemental function is required to return a scalar 12.7.1 */
10109 if (sym->attr.elemental && sym->attr.function && sym->as)
10111 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10112 "result", sym->name, &sym->declared_at);
10113 /* Reset so that the error only occurs once. */
10114 sym->attr.elemental = 0;
10118 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10119 char-len-param shall not be array-valued, pointer-valued, recursive
10120 or pure. ....snip... A character value of * may only be used in the
10121 following ways: (i) Dummy arg of procedure - dummy associates with
10122 actual length; (ii) To declare a named constant; or (iii) External
10123 function - but length must be declared in calling scoping unit. */
10124 if (sym->attr.function
10125 && sym->ts.type == BT_CHARACTER
10126 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10128 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10129 || (sym->attr.recursive) || (sym->attr.pure))
10131 if (sym->as && sym->as->rank)
10132 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10133 "array-valued", sym->name, &sym->declared_at);
10135 if (sym->attr.pointer)
10136 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10137 "pointer-valued", sym->name, &sym->declared_at);
10139 if (sym->attr.pure)
10140 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10141 "pure", sym->name, &sym->declared_at);
10143 if (sym->attr.recursive)
10144 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10145 "recursive", sym->name, &sym->declared_at);
10150 /* Appendix B.2 of the standard. Contained functions give an
10151 error anyway. Fixed-form is likely to be F77/legacy. */
10152 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
10153 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10154 "CHARACTER(*) function '%s' at %L",
10155 sym->name, &sym->declared_at);
10158 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10160 gfc_formal_arglist *curr_arg;
10161 int has_non_interop_arg = 0;
10163 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10164 sym->common_block) == FAILURE)
10166 /* Clear these to prevent looking at them again if there was an
10168 sym->attr.is_bind_c = 0;
10169 sym->attr.is_c_interop = 0;
10170 sym->ts.is_c_interop = 0;
10174 /* So far, no errors have been found. */
10175 sym->attr.is_c_interop = 1;
10176 sym->ts.is_c_interop = 1;
10179 curr_arg = sym->formal;
10180 while (curr_arg != NULL)
10182 /* Skip implicitly typed dummy args here. */
10183 if (curr_arg->sym->attr.implicit_type == 0)
10184 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
10185 /* If something is found to fail, record the fact so we
10186 can mark the symbol for the procedure as not being
10187 BIND(C) to try and prevent multiple errors being
10189 has_non_interop_arg = 1;
10191 curr_arg = curr_arg->next;
10194 /* See if any of the arguments were not interoperable and if so, clear
10195 the procedure symbol to prevent duplicate error messages. */
10196 if (has_non_interop_arg != 0)
10198 sym->attr.is_c_interop = 0;
10199 sym->ts.is_c_interop = 0;
10200 sym->attr.is_bind_c = 0;
10204 if (!sym->attr.proc_pointer)
10206 if (sym->attr.save == SAVE_EXPLICIT)
10208 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10209 "in '%s' at %L", sym->name, &sym->declared_at);
10212 if (sym->attr.intent)
10214 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10215 "in '%s' at %L", sym->name, &sym->declared_at);
10218 if (sym->attr.subroutine && sym->attr.result)
10220 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10221 "in '%s' at %L", sym->name, &sym->declared_at);
10224 if (sym->attr.external && sym->attr.function
10225 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10226 || sym->attr.contained))
10228 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10229 "in '%s' at %L", sym->name, &sym->declared_at);
10232 if (strcmp ("ppr@", sym->name) == 0)
10234 gfc_error ("Procedure pointer result '%s' at %L "
10235 "is missing the pointer attribute",
10236 sym->ns->proc_name->name, &sym->declared_at);
10245 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10246 been defined and we now know their defined arguments, check that they fulfill
10247 the requirements of the standard for procedures used as finalizers. */
10250 gfc_resolve_finalizers (gfc_symbol* derived)
10252 gfc_finalizer* list;
10253 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10254 gfc_try result = SUCCESS;
10255 bool seen_scalar = false;
10257 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10260 /* Walk over the list of finalizer-procedures, check them, and if any one
10261 does not fit in with the standard's definition, print an error and remove
10262 it from the list. */
10263 prev_link = &derived->f2k_derived->finalizers;
10264 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10270 /* Skip this finalizer if we already resolved it. */
10271 if (list->proc_tree)
10273 prev_link = &(list->next);
10277 /* Check this exists and is a SUBROUTINE. */
10278 if (!list->proc_sym->attr.subroutine)
10280 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10281 list->proc_sym->name, &list->where);
10285 /* We should have exactly one argument. */
10286 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10288 gfc_error ("FINAL procedure at %L must have exactly one argument",
10292 arg = list->proc_sym->formal->sym;
10294 /* This argument must be of our type. */
10295 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10297 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10298 &arg->declared_at, derived->name);
10302 /* It must neither be a pointer nor allocatable nor optional. */
10303 if (arg->attr.pointer)
10305 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10306 &arg->declared_at);
10309 if (arg->attr.allocatable)
10311 gfc_error ("Argument of FINAL procedure at %L must not be"
10312 " ALLOCATABLE", &arg->declared_at);
10315 if (arg->attr.optional)
10317 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10318 &arg->declared_at);
10322 /* It must not be INTENT(OUT). */
10323 if (arg->attr.intent == INTENT_OUT)
10325 gfc_error ("Argument of FINAL procedure at %L must not be"
10326 " INTENT(OUT)", &arg->declared_at);
10330 /* Warn if the procedure is non-scalar and not assumed shape. */
10331 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10332 && arg->as->type != AS_ASSUMED_SHAPE)
10333 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10334 " shape argument", &arg->declared_at);
10336 /* Check that it does not match in kind and rank with a FINAL procedure
10337 defined earlier. To really loop over the *earlier* declarations,
10338 we need to walk the tail of the list as new ones were pushed at the
10340 /* TODO: Handle kind parameters once they are implemented. */
10341 my_rank = (arg->as ? arg->as->rank : 0);
10342 for (i = list->next; i; i = i->next)
10344 /* Argument list might be empty; that is an error signalled earlier,
10345 but we nevertheless continued resolving. */
10346 if (i->proc_sym->formal)
10348 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10349 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10350 if (i_rank == my_rank)
10352 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10353 " rank (%d) as '%s'",
10354 list->proc_sym->name, &list->where, my_rank,
10355 i->proc_sym->name);
10361 /* Is this the/a scalar finalizer procedure? */
10362 if (!arg->as || arg->as->rank == 0)
10363 seen_scalar = true;
10365 /* Find the symtree for this procedure. */
10366 gcc_assert (!list->proc_tree);
10367 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10369 prev_link = &list->next;
10372 /* Remove wrong nodes immediately from the list so we don't risk any
10373 troubles in the future when they might fail later expectations. */
10377 *prev_link = list->next;
10378 gfc_free_finalizer (i);
10381 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10382 were nodes in the list, must have been for arrays. It is surely a good
10383 idea to have a scalar version there if there's something to finalize. */
10384 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10385 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10386 " defined at %L, suggest also scalar one",
10387 derived->name, &derived->declared_at);
10389 /* TODO: Remove this error when finalization is finished. */
10390 gfc_error ("Finalization at %L is not yet implemented",
10391 &derived->declared_at);
10397 /* Check that it is ok for the typebound procedure proc to override the
10401 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
10404 const gfc_symbol* proc_target;
10405 const gfc_symbol* old_target;
10406 unsigned proc_pass_arg, old_pass_arg, argpos;
10407 gfc_formal_arglist* proc_formal;
10408 gfc_formal_arglist* old_formal;
10410 /* This procedure should only be called for non-GENERIC proc. */
10411 gcc_assert (!proc->n.tb->is_generic);
10413 /* If the overwritten procedure is GENERIC, this is an error. */
10414 if (old->n.tb->is_generic)
10416 gfc_error ("Can't overwrite GENERIC '%s' at %L",
10417 old->name, &proc->n.tb->where);
10421 where = proc->n.tb->where;
10422 proc_target = proc->n.tb->u.specific->n.sym;
10423 old_target = old->n.tb->u.specific->n.sym;
10425 /* Check that overridden binding is not NON_OVERRIDABLE. */
10426 if (old->n.tb->non_overridable)
10428 gfc_error ("'%s' at %L overrides a procedure binding declared"
10429 " NON_OVERRIDABLE", proc->name, &where);
10433 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
10434 if (!old->n.tb->deferred && proc->n.tb->deferred)
10436 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
10437 " non-DEFERRED binding", proc->name, &where);
10441 /* If the overridden binding is PURE, the overriding must be, too. */
10442 if (old_target->attr.pure && !proc_target->attr.pure)
10444 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
10445 proc->name, &where);
10449 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
10450 is not, the overriding must not be either. */
10451 if (old_target->attr.elemental && !proc_target->attr.elemental)
10453 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
10454 " ELEMENTAL", proc->name, &where);
10457 if (!old_target->attr.elemental && proc_target->attr.elemental)
10459 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
10460 " be ELEMENTAL, either", proc->name, &where);
10464 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
10466 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
10468 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
10469 " SUBROUTINE", proc->name, &where);
10473 /* If the overridden binding is a FUNCTION, the overriding must also be a
10474 FUNCTION and have the same characteristics. */
10475 if (old_target->attr.function)
10477 if (!proc_target->attr.function)
10479 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
10480 " FUNCTION", proc->name, &where);
10484 /* FIXME: Do more comprehensive checking (including, for instance, the
10485 rank and array-shape). */
10486 gcc_assert (proc_target->result && old_target->result);
10487 if (!gfc_compare_types (&proc_target->result->ts,
10488 &old_target->result->ts))
10490 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
10491 " matching result types", proc->name, &where);
10496 /* If the overridden binding is PUBLIC, the overriding one must not be
10498 if (old->n.tb->access == ACCESS_PUBLIC
10499 && proc->n.tb->access == ACCESS_PRIVATE)
10501 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
10502 " PRIVATE", proc->name, &where);
10506 /* Compare the formal argument lists of both procedures. This is also abused
10507 to find the position of the passed-object dummy arguments of both
10508 bindings as at least the overridden one might not yet be resolved and we
10509 need those positions in the check below. */
10510 proc_pass_arg = old_pass_arg = 0;
10511 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
10513 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
10516 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
10517 proc_formal && old_formal;
10518 proc_formal = proc_formal->next, old_formal = old_formal->next)
10520 if (proc->n.tb->pass_arg
10521 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
10522 proc_pass_arg = argpos;
10523 if (old->n.tb->pass_arg
10524 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
10525 old_pass_arg = argpos;
10527 /* Check that the names correspond. */
10528 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
10530 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
10531 " to match the corresponding argument of the overridden"
10532 " procedure", proc_formal->sym->name, proc->name, &where,
10533 old_formal->sym->name);
10537 /* Check that the types correspond if neither is the passed-object
10539 /* FIXME: Do more comprehensive testing here. */
10540 if (proc_pass_arg != argpos && old_pass_arg != argpos
10541 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
10543 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
10544 "in respect to the overridden procedure",
10545 proc_formal->sym->name, proc->name, &where);
10551 if (proc_formal || old_formal)
10553 gfc_error ("'%s' at %L must have the same number of formal arguments as"
10554 " the overridden procedure", proc->name, &where);
10558 /* If the overridden binding is NOPASS, the overriding one must also be
10560 if (old->n.tb->nopass && !proc->n.tb->nopass)
10562 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
10563 " NOPASS", proc->name, &where);
10567 /* If the overridden binding is PASS(x), the overriding one must also be
10568 PASS and the passed-object dummy arguments must correspond. */
10569 if (!old->n.tb->nopass)
10571 if (proc->n.tb->nopass)
10573 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
10574 " PASS", proc->name, &where);
10578 if (proc_pass_arg != old_pass_arg)
10580 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
10581 " the same position as the passed-object dummy argument of"
10582 " the overridden procedure", proc->name, &where);
10591 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10594 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10595 const char* generic_name, locus where)
10600 gcc_assert (t1->specific && t2->specific);
10601 gcc_assert (!t1->specific->is_generic);
10602 gcc_assert (!t2->specific->is_generic);
10604 sym1 = t1->specific->u.specific->n.sym;
10605 sym2 = t2->specific->u.specific->n.sym;
10610 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10611 if (sym1->attr.subroutine != sym2->attr.subroutine
10612 || sym1->attr.function != sym2->attr.function)
10614 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10615 " GENERIC '%s' at %L",
10616 sym1->name, sym2->name, generic_name, &where);
10620 /* Compare the interfaces. */
10621 if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
10623 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10624 sym1->name, sym2->name, generic_name, &where);
10632 /* Worker function for resolving a generic procedure binding; this is used to
10633 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10635 The difference between those cases is finding possible inherited bindings
10636 that are overridden, as one has to look for them in tb_sym_root,
10637 tb_uop_root or tb_op, respectively. Thus the caller must already find
10638 the super-type and set p->overridden correctly. */
10641 resolve_tb_generic_targets (gfc_symbol* super_type,
10642 gfc_typebound_proc* p, const char* name)
10644 gfc_tbp_generic* target;
10645 gfc_symtree* first_target;
10646 gfc_symtree* inherited;
10648 gcc_assert (p && p->is_generic);
10650 /* Try to find the specific bindings for the symtrees in our target-list. */
10651 gcc_assert (p->u.generic);
10652 for (target = p->u.generic; target; target = target->next)
10653 if (!target->specific)
10655 gfc_typebound_proc* overridden_tbp;
10656 gfc_tbp_generic* g;
10657 const char* target_name;
10659 target_name = target->specific_st->name;
10661 /* Defined for this type directly. */
10662 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
10664 target->specific = target->specific_st->n.tb;
10665 goto specific_found;
10668 /* Look for an inherited specific binding. */
10671 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
10676 gcc_assert (inherited->n.tb);
10677 target->specific = inherited->n.tb;
10678 goto specific_found;
10682 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
10683 " at %L", target_name, name, &p->where);
10686 /* Once we've found the specific binding, check it is not ambiguous with
10687 other specifics already found or inherited for the same GENERIC. */
10689 gcc_assert (target->specific);
10691 /* This must really be a specific binding! */
10692 if (target->specific->is_generic)
10694 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
10695 " '%s' is GENERIC, too", name, &p->where, target_name);
10699 /* Check those already resolved on this type directly. */
10700 for (g = p->u.generic; g; g = g->next)
10701 if (g != target && g->specific
10702 && check_generic_tbp_ambiguity (target, g, name, p->where)
10706 /* Check for ambiguity with inherited specific targets. */
10707 for (overridden_tbp = p->overridden; overridden_tbp;
10708 overridden_tbp = overridden_tbp->overridden)
10709 if (overridden_tbp->is_generic)
10711 for (g = overridden_tbp->u.generic; g; g = g->next)
10713 gcc_assert (g->specific);
10714 if (check_generic_tbp_ambiguity (target, g,
10715 name, p->where) == FAILURE)
10721 /* If we attempt to "overwrite" a specific binding, this is an error. */
10722 if (p->overridden && !p->overridden->is_generic)
10724 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
10725 " the same name", name, &p->where);
10729 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
10730 all must have the same attributes here. */
10731 first_target = p->u.generic->specific->u.specific;
10732 gcc_assert (first_target);
10733 p->subroutine = first_target->n.sym->attr.subroutine;
10734 p->function = first_target->n.sym->attr.function;
10740 /* Resolve a GENERIC procedure binding for a derived type. */
10743 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
10745 gfc_symbol* super_type;
10747 /* Find the overridden binding if any. */
10748 st->n.tb->overridden = NULL;
10749 super_type = gfc_get_derived_super_type (derived);
10752 gfc_symtree* overridden;
10753 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
10756 if (overridden && overridden->n.tb)
10757 st->n.tb->overridden = overridden->n.tb;
10760 /* Resolve using worker function. */
10761 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
10765 /* Retrieve the target-procedure of an operator binding and do some checks in
10766 common for intrinsic and user-defined type-bound operators. */
10769 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
10771 gfc_symbol* target_proc;
10773 gcc_assert (target->specific && !target->specific->is_generic);
10774 target_proc = target->specific->u.specific->n.sym;
10775 gcc_assert (target_proc);
10777 /* All operator bindings must have a passed-object dummy argument. */
10778 if (target->specific->nopass)
10780 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
10784 return target_proc;
10788 /* Resolve a type-bound intrinsic operator. */
10791 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
10792 gfc_typebound_proc* p)
10794 gfc_symbol* super_type;
10795 gfc_tbp_generic* target;
10797 /* If there's already an error here, do nothing (but don't fail again). */
10801 /* Operators should always be GENERIC bindings. */
10802 gcc_assert (p->is_generic);
10804 /* Look for an overridden binding. */
10805 super_type = gfc_get_derived_super_type (derived);
10806 if (super_type && super_type->f2k_derived)
10807 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
10810 p->overridden = NULL;
10812 /* Resolve general GENERIC properties using worker function. */
10813 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
10816 /* Check the targets to be procedures of correct interface. */
10817 for (target = p->u.generic; target; target = target->next)
10819 gfc_symbol* target_proc;
10821 target_proc = get_checked_tb_operator_target (target, p->where);
10825 if (!gfc_check_operator_interface (target_proc, op, p->where))
10837 /* Resolve a type-bound user operator (tree-walker callback). */
10839 static gfc_symbol* resolve_bindings_derived;
10840 static gfc_try resolve_bindings_result;
10842 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
10845 resolve_typebound_user_op (gfc_symtree* stree)
10847 gfc_symbol* super_type;
10848 gfc_tbp_generic* target;
10850 gcc_assert (stree && stree->n.tb);
10852 if (stree->n.tb->error)
10855 /* Operators should always be GENERIC bindings. */
10856 gcc_assert (stree->n.tb->is_generic);
10858 /* Find overridden procedure, if any. */
10859 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10860 if (super_type && super_type->f2k_derived)
10862 gfc_symtree* overridden;
10863 overridden = gfc_find_typebound_user_op (super_type, NULL,
10864 stree->name, true, NULL);
10866 if (overridden && overridden->n.tb)
10867 stree->n.tb->overridden = overridden->n.tb;
10870 stree->n.tb->overridden = NULL;
10872 /* Resolve basically using worker function. */
10873 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
10877 /* Check the targets to be functions of correct interface. */
10878 for (target = stree->n.tb->u.generic; target; target = target->next)
10880 gfc_symbol* target_proc;
10882 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
10886 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
10893 resolve_bindings_result = FAILURE;
10894 stree->n.tb->error = 1;
10898 /* Resolve the type-bound procedures for a derived type. */
10901 resolve_typebound_procedure (gfc_symtree* stree)
10905 gfc_symbol* me_arg;
10906 gfc_symbol* super_type;
10907 gfc_component* comp;
10909 gcc_assert (stree);
10911 /* Undefined specific symbol from GENERIC target definition. */
10915 if (stree->n.tb->error)
10918 /* If this is a GENERIC binding, use that routine. */
10919 if (stree->n.tb->is_generic)
10921 if (resolve_typebound_generic (resolve_bindings_derived, stree)
10927 /* Get the target-procedure to check it. */
10928 gcc_assert (!stree->n.tb->is_generic);
10929 gcc_assert (stree->n.tb->u.specific);
10930 proc = stree->n.tb->u.specific->n.sym;
10931 where = stree->n.tb->where;
10933 /* Default access should already be resolved from the parser. */
10934 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
10936 /* It should be a module procedure or an external procedure with explicit
10937 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
10938 if ((!proc->attr.subroutine && !proc->attr.function)
10939 || (proc->attr.proc != PROC_MODULE
10940 && proc->attr.if_source != IFSRC_IFBODY)
10941 || (proc->attr.abstract && !stree->n.tb->deferred))
10943 gfc_error ("'%s' must be a module procedure or an external procedure with"
10944 " an explicit interface at %L", proc->name, &where);
10947 stree->n.tb->subroutine = proc->attr.subroutine;
10948 stree->n.tb->function = proc->attr.function;
10950 /* Find the super-type of the current derived type. We could do this once and
10951 store in a global if speed is needed, but as long as not I believe this is
10952 more readable and clearer. */
10953 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10955 /* If PASS, resolve and check arguments if not already resolved / loaded
10956 from a .mod file. */
10957 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
10959 if (stree->n.tb->pass_arg)
10961 gfc_formal_arglist* i;
10963 /* If an explicit passing argument name is given, walk the arg-list
10964 and look for it. */
10967 stree->n.tb->pass_arg_num = 1;
10968 for (i = proc->formal; i; i = i->next)
10970 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
10975 ++stree->n.tb->pass_arg_num;
10980 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
10982 proc->name, stree->n.tb->pass_arg, &where,
10983 stree->n.tb->pass_arg);
10989 /* Otherwise, take the first one; there should in fact be at least
10991 stree->n.tb->pass_arg_num = 1;
10994 gfc_error ("Procedure '%s' with PASS at %L must have at"
10995 " least one argument", proc->name, &where);
10998 me_arg = proc->formal->sym;
11001 /* Now check that the argument-type matches and the passed-object
11002 dummy argument is generally fine. */
11004 gcc_assert (me_arg);
11006 if (me_arg->ts.type != BT_CLASS)
11008 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11009 " at %L", proc->name, &where);
11013 if (CLASS_DATA (me_arg)->ts.u.derived
11014 != resolve_bindings_derived)
11016 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11017 " the derived-type '%s'", me_arg->name, proc->name,
11018 me_arg->name, &where, resolve_bindings_derived->name);
11022 gcc_assert (me_arg->ts.type == BT_CLASS);
11023 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
11025 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11026 " scalar", proc->name, &where);
11029 if (CLASS_DATA (me_arg)->attr.allocatable)
11031 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11032 " be ALLOCATABLE", proc->name, &where);
11035 if (CLASS_DATA (me_arg)->attr.class_pointer)
11037 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11038 " be POINTER", proc->name, &where);
11043 /* If we are extending some type, check that we don't override a procedure
11044 flagged NON_OVERRIDABLE. */
11045 stree->n.tb->overridden = NULL;
11048 gfc_symtree* overridden;
11049 overridden = gfc_find_typebound_proc (super_type, NULL,
11050 stree->name, true, NULL);
11052 if (overridden && overridden->n.tb)
11053 stree->n.tb->overridden = overridden->n.tb;
11055 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
11059 /* See if there's a name collision with a component directly in this type. */
11060 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11061 if (!strcmp (comp->name, stree->name))
11063 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11065 stree->name, &where, resolve_bindings_derived->name);
11069 /* Try to find a name collision with an inherited component. */
11070 if (super_type && gfc_find_component (super_type, stree->name, true, true))
11072 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11073 " component of '%s'",
11074 stree->name, &where, resolve_bindings_derived->name);
11078 stree->n.tb->error = 0;
11082 resolve_bindings_result = FAILURE;
11083 stree->n.tb->error = 1;
11088 resolve_typebound_procedures (gfc_symbol* derived)
11092 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11095 resolve_bindings_derived = derived;
11096 resolve_bindings_result = SUCCESS;
11098 /* Make sure the vtab has been generated. */
11099 gfc_find_derived_vtab (derived);
11101 if (derived->f2k_derived->tb_sym_root)
11102 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11103 &resolve_typebound_procedure);
11105 if (derived->f2k_derived->tb_uop_root)
11106 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11107 &resolve_typebound_user_op);
11109 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11111 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11112 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11114 resolve_bindings_result = FAILURE;
11117 return resolve_bindings_result;
11121 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11122 to give all identical derived types the same backend_decl. */
11124 add_dt_to_dt_list (gfc_symbol *derived)
11126 gfc_dt_list *dt_list;
11128 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11129 if (derived == dt_list->derived)
11132 dt_list = gfc_get_dt_list ();
11133 dt_list->next = gfc_derived_types;
11134 dt_list->derived = derived;
11135 gfc_derived_types = dt_list;
11139 /* Ensure that a derived-type is really not abstract, meaning that every
11140 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11143 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11148 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11150 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11153 if (st->n.tb && st->n.tb->deferred)
11155 gfc_symtree* overriding;
11156 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11159 gcc_assert (overriding->n.tb);
11160 if (overriding->n.tb->deferred)
11162 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11163 " '%s' is DEFERRED and not overridden",
11164 sub->name, &sub->declared_at, st->name);
11173 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11175 /* The algorithm used here is to recursively travel up the ancestry of sub
11176 and for each ancestor-type, check all bindings. If any of them is
11177 DEFERRED, look it up starting from sub and see if the found (overriding)
11178 binding is not DEFERRED.
11179 This is not the most efficient way to do this, but it should be ok and is
11180 clearer than something sophisticated. */
11182 gcc_assert (ancestor && !sub->attr.abstract);
11184 if (!ancestor->attr.abstract)
11187 /* Walk bindings of this ancestor. */
11188 if (ancestor->f2k_derived)
11191 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11196 /* Find next ancestor type and recurse on it. */
11197 ancestor = gfc_get_derived_super_type (ancestor);
11199 return ensure_not_abstract (sub, ancestor);
11205 /* Resolve the components of a derived type. */
11208 resolve_fl_derived (gfc_symbol *sym)
11210 gfc_symbol* super_type;
11213 super_type = gfc_get_derived_super_type (sym);
11215 if (sym->attr.is_class && sym->ts.u.derived == NULL)
11217 /* Fix up incomplete CLASS symbols. */
11218 gfc_component *data = gfc_find_component (sym, "_data", true, true);
11219 gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
11220 if (vptr->ts.u.derived == NULL)
11222 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
11224 vptr->ts.u.derived = vtab->ts.u.derived;
11229 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11231 gfc_error ("As extending type '%s' at %L has a coarray component, "
11232 "parent type '%s' shall also have one", sym->name,
11233 &sym->declared_at, super_type->name);
11237 /* Ensure the extended type gets resolved before we do. */
11238 if (super_type && resolve_fl_derived (super_type) == FAILURE)
11241 /* An ABSTRACT type must be extensible. */
11242 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11244 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11245 sym->name, &sym->declared_at);
11249 for (c = sym->components; c != NULL; c = c->next)
11252 if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */
11253 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11255 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11256 "deferred shape", c->name, &c->loc);
11261 if (c->attr.codimension && c->ts.type == BT_DERIVED
11262 && c->ts.u.derived->ts.is_iso_c)
11264 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11265 "shall not be a coarray", c->name, &c->loc);
11270 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11271 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11272 || c->attr.allocatable))
11274 gfc_error ("Component '%s' at %L with coarray component "
11275 "shall be a nonpointer, nonallocatable scalar",
11281 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11283 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11284 "is not an array pointer", c->name, &c->loc);
11288 if (c->attr.proc_pointer && c->ts.interface)
11290 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11291 gfc_error ("Interface '%s', used by procedure pointer component "
11292 "'%s' at %L, is declared in a later PROCEDURE statement",
11293 c->ts.interface->name, c->name, &c->loc);
11295 /* Get the attributes from the interface (now resolved). */
11296 if (c->ts.interface->attr.if_source
11297 || c->ts.interface->attr.intrinsic)
11299 gfc_symbol *ifc = c->ts.interface;
11301 if (ifc->formal && !ifc->formal_ns)
11302 resolve_symbol (ifc);
11304 if (ifc->attr.intrinsic)
11305 resolve_intrinsic (ifc, &ifc->declared_at);
11309 c->ts = ifc->result->ts;
11310 c->attr.allocatable = ifc->result->attr.allocatable;
11311 c->attr.pointer = ifc->result->attr.pointer;
11312 c->attr.dimension = ifc->result->attr.dimension;
11313 c->as = gfc_copy_array_spec (ifc->result->as);
11318 c->attr.allocatable = ifc->attr.allocatable;
11319 c->attr.pointer = ifc->attr.pointer;
11320 c->attr.dimension = ifc->attr.dimension;
11321 c->as = gfc_copy_array_spec (ifc->as);
11323 c->ts.interface = ifc;
11324 c->attr.function = ifc->attr.function;
11325 c->attr.subroutine = ifc->attr.subroutine;
11326 gfc_copy_formal_args_ppc (c, ifc);
11328 c->attr.pure = ifc->attr.pure;
11329 c->attr.elemental = ifc->attr.elemental;
11330 c->attr.recursive = ifc->attr.recursive;
11331 c->attr.always_explicit = ifc->attr.always_explicit;
11332 c->attr.ext_attr |= ifc->attr.ext_attr;
11333 /* Replace symbols in array spec. */
11337 for (i = 0; i < c->as->rank; i++)
11339 gfc_expr_replace_comp (c->as->lower[i], c);
11340 gfc_expr_replace_comp (c->as->upper[i], c);
11343 /* Copy char length. */
11344 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11346 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11347 gfc_expr_replace_comp (cl->length, c);
11348 if (cl->length && !cl->resolved
11349 && gfc_resolve_expr (cl->length) == FAILURE)
11354 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11356 gfc_error ("Interface '%s' of procedure pointer component "
11357 "'%s' at %L must be explicit", c->ts.interface->name,
11362 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11364 /* Since PPCs are not implicitly typed, a PPC without an explicit
11365 interface must be a subroutine. */
11366 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11369 /* Procedure pointer components: Check PASS arg. */
11370 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11371 && !sym->attr.vtype)
11373 gfc_symbol* me_arg;
11375 if (c->tb->pass_arg)
11377 gfc_formal_arglist* i;
11379 /* If an explicit passing argument name is given, walk the arg-list
11380 and look for it. */
11383 c->tb->pass_arg_num = 1;
11384 for (i = c->formal; i; i = i->next)
11386 if (!strcmp (i->sym->name, c->tb->pass_arg))
11391 c->tb->pass_arg_num++;
11396 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11397 "at %L has no argument '%s'", c->name,
11398 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11405 /* Otherwise, take the first one; there should in fact be at least
11407 c->tb->pass_arg_num = 1;
11410 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11411 "must have at least one argument",
11416 me_arg = c->formal->sym;
11419 /* Now check that the argument-type matches. */
11420 gcc_assert (me_arg);
11421 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11422 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11423 || (me_arg->ts.type == BT_CLASS
11424 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11426 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11427 " the derived type '%s'", me_arg->name, c->name,
11428 me_arg->name, &c->loc, sym->name);
11433 /* Check for C453. */
11434 if (me_arg->attr.dimension)
11436 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11437 "must be scalar", me_arg->name, c->name, me_arg->name,
11443 if (me_arg->attr.pointer)
11445 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11446 "may not have the POINTER attribute", me_arg->name,
11447 c->name, me_arg->name, &c->loc);
11452 if (me_arg->attr.allocatable)
11454 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11455 "may not be ALLOCATABLE", me_arg->name, c->name,
11456 me_arg->name, &c->loc);
11461 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11462 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11463 " at %L", c->name, &c->loc);
11467 /* Check type-spec if this is not the parent-type component. */
11468 if ((!sym->attr.extension || c != sym->components) && !sym->attr.vtype
11469 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11472 /* If this type is an extension, set the accessibility of the parent
11474 if (super_type && c == sym->components
11475 && strcmp (super_type->name, c->name) == 0)
11476 c->attr.access = super_type->attr.access;
11478 /* If this type is an extension, see if this component has the same name
11479 as an inherited type-bound procedure. */
11480 if (super_type && !sym->attr.is_class
11481 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11483 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11484 " inherited type-bound procedure",
11485 c->name, sym->name, &c->loc);
11489 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
11491 if (c->ts.u.cl->length == NULL
11492 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11493 || !gfc_is_constant_expr (c->ts.u.cl->length))
11495 gfc_error ("Character length of component '%s' needs to "
11496 "be a constant specification expression at %L",
11498 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11503 if (c->ts.type == BT_DERIVED
11504 && sym->component_access != ACCESS_PRIVATE
11505 && gfc_check_access (sym->attr.access, sym->ns->default_access)
11506 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11507 && !c->ts.u.derived->attr.use_assoc
11508 && !gfc_check_access (c->ts.u.derived->attr.access,
11509 c->ts.u.derived->ns->default_access)
11510 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11511 "is a PRIVATE type and cannot be a component of "
11512 "'%s', which is PUBLIC at %L", c->name,
11513 sym->name, &sym->declared_at) == FAILURE)
11516 if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
11518 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11519 "type %s", c->name, &c->loc, sym->name);
11523 if (sym->attr.sequence)
11525 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11527 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11528 "not have the SEQUENCE attribute",
11529 c->ts.u.derived->name, &sym->declared_at);
11534 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
11535 && c->attr.pointer && c->ts.u.derived->components == NULL
11536 && !c->ts.u.derived->attr.zero_comp)
11538 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11539 "that has not been declared", c->name, sym->name,
11544 if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer
11545 && CLASS_DATA (c)->ts.u.derived->components == NULL
11546 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11548 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11549 "that has not been declared", c->name, sym->name,
11555 if (c->ts.type == BT_CLASS
11556 && !(CLASS_DATA (c)->attr.class_pointer
11557 || CLASS_DATA (c)->attr.allocatable))
11559 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11560 "or pointer", c->name, &c->loc);
11564 /* Ensure that all the derived type components are put on the
11565 derived type list; even in formal namespaces, where derived type
11566 pointer components might not have been declared. */
11567 if (c->ts.type == BT_DERIVED
11569 && c->ts.u.derived->components
11571 && sym != c->ts.u.derived)
11572 add_dt_to_dt_list (c->ts.u.derived);
11574 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11575 || c->attr.proc_pointer
11576 || c->attr.allocatable)) == FAILURE)
11580 /* Resolve the type-bound procedures. */
11581 if (resolve_typebound_procedures (sym) == FAILURE)
11584 /* Resolve the finalizer procedures. */
11585 if (gfc_resolve_finalizers (sym) == FAILURE)
11588 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11589 all DEFERRED bindings are overridden. */
11590 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11591 && !sym->attr.is_class
11592 && ensure_not_abstract (sym, super_type) == FAILURE)
11595 /* Add derived type to the derived type list. */
11596 add_dt_to_dt_list (sym);
11603 resolve_fl_namelist (gfc_symbol *sym)
11608 for (nl = sym->namelist; nl; nl = nl->next)
11610 /* Reject namelist arrays of assumed shape. */
11611 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
11612 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
11613 "must not have assumed shape in namelist "
11614 "'%s' at %L", nl->sym->name, sym->name,
11615 &sym->declared_at) == FAILURE)
11618 /* Reject namelist arrays that are not constant shape. */
11619 if (is_non_constant_shape_array (nl->sym))
11621 gfc_error ("NAMELIST array object '%s' must have constant "
11622 "shape in namelist '%s' at %L", nl->sym->name,
11623 sym->name, &sym->declared_at);
11627 /* Namelist objects cannot have allocatable or pointer components. */
11628 if (nl->sym->ts.type != BT_DERIVED)
11631 if (nl->sym->ts.u.derived->attr.alloc_comp)
11633 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11634 "have ALLOCATABLE components",
11635 nl->sym->name, sym->name, &sym->declared_at);
11639 if (nl->sym->ts.u.derived->attr.pointer_comp)
11641 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11642 "have POINTER components",
11643 nl->sym->name, sym->name, &sym->declared_at);
11648 /* Reject PRIVATE objects in a PUBLIC namelist. */
11649 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
11651 for (nl = sym->namelist; nl; nl = nl->next)
11653 if (!nl->sym->attr.use_assoc
11654 && !is_sym_host_assoc (nl->sym, sym->ns)
11655 && !gfc_check_access(nl->sym->attr.access,
11656 nl->sym->ns->default_access))
11658 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
11659 "cannot be member of PUBLIC namelist '%s' at %L",
11660 nl->sym->name, sym->name, &sym->declared_at);
11664 /* Types with private components that came here by USE-association. */
11665 if (nl->sym->ts.type == BT_DERIVED
11666 && derived_inaccessible (nl->sym->ts.u.derived))
11668 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
11669 "components and cannot be member of namelist '%s' at %L",
11670 nl->sym->name, sym->name, &sym->declared_at);
11674 /* Types with private components that are defined in the same module. */
11675 if (nl->sym->ts.type == BT_DERIVED
11676 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
11677 && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
11678 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
11679 nl->sym->ns->default_access))
11681 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
11682 "cannot be a member of PUBLIC namelist '%s' at %L",
11683 nl->sym->name, sym->name, &sym->declared_at);
11690 /* 14.1.2 A module or internal procedure represent local entities
11691 of the same type as a namelist member and so are not allowed. */
11692 for (nl = sym->namelist; nl; nl = nl->next)
11694 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
11697 if (nl->sym->attr.function && nl->sym == nl->sym->result)
11698 if ((nl->sym == sym->ns->proc_name)
11700 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
11704 if (nl->sym && nl->sym->name)
11705 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
11706 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
11708 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
11709 "attribute in '%s' at %L", nlsym->name,
11710 &sym->declared_at);
11720 resolve_fl_parameter (gfc_symbol *sym)
11722 /* A parameter array's shape needs to be constant. */
11723 if (sym->as != NULL
11724 && (sym->as->type == AS_DEFERRED
11725 || is_non_constant_shape_array (sym)))
11727 gfc_error ("Parameter array '%s' at %L cannot be automatic "
11728 "or of deferred shape", sym->name, &sym->declared_at);
11732 /* Make sure a parameter that has been implicitly typed still
11733 matches the implicit type, since PARAMETER statements can precede
11734 IMPLICIT statements. */
11735 if (sym->attr.implicit_type
11736 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
11739 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
11740 "later IMPLICIT type", sym->name, &sym->declared_at);
11744 /* Make sure the types of derived parameters are consistent. This
11745 type checking is deferred until resolution because the type may
11746 refer to a derived type from the host. */
11747 if (sym->ts.type == BT_DERIVED
11748 && !gfc_compare_types (&sym->ts, &sym->value->ts))
11750 gfc_error ("Incompatible derived type in PARAMETER at %L",
11751 &sym->value->where);
11758 /* Do anything necessary to resolve a symbol. Right now, we just
11759 assume that an otherwise unknown symbol is a variable. This sort
11760 of thing commonly happens for symbols in module. */
11763 resolve_symbol (gfc_symbol *sym)
11765 int check_constant, mp_flag;
11766 gfc_symtree *symtree;
11767 gfc_symtree *this_symtree;
11771 /* Avoid double resolution of function result symbols. */
11772 if ((sym->result || sym->attr.result) && !sym->attr.dummy
11773 && (sym->ns != gfc_current_ns))
11776 if (sym->attr.flavor == FL_UNKNOWN)
11779 /* If we find that a flavorless symbol is an interface in one of the
11780 parent namespaces, find its symtree in this namespace, free the
11781 symbol and set the symtree to point to the interface symbol. */
11782 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
11784 symtree = gfc_find_symtree (ns->sym_root, sym->name);
11785 if (symtree && symtree->n.sym->generic)
11787 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
11789 gfc_release_symbol (sym);
11790 symtree->n.sym->refs++;
11791 this_symtree->n.sym = symtree->n.sym;
11796 /* Otherwise give it a flavor according to such attributes as
11798 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
11799 sym->attr.flavor = FL_VARIABLE;
11802 sym->attr.flavor = FL_PROCEDURE;
11803 if (sym->attr.dimension)
11804 sym->attr.function = 1;
11808 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
11809 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
11811 if (sym->attr.procedure && sym->ts.interface
11812 && sym->attr.if_source != IFSRC_DECL
11813 && resolve_procedure_interface (sym) == FAILURE)
11816 if (sym->attr.is_protected && !sym->attr.proc_pointer
11817 && (sym->attr.procedure || sym->attr.external))
11819 if (sym->attr.external)
11820 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
11821 "at %L", &sym->declared_at);
11823 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
11824 "at %L", &sym->declared_at);
11831 if (sym->attr.contiguous
11832 && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE
11833 && !sym->attr.pointer)))
11835 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
11836 "array pointer or an assumed-shape array", sym->name,
11837 &sym->declared_at);
11841 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
11844 /* Symbols that are module procedures with results (functions) have
11845 the types and array specification copied for type checking in
11846 procedures that call them, as well as for saving to a module
11847 file. These symbols can't stand the scrutiny that their results
11849 mp_flag = (sym->result != NULL && sym->result != sym);
11851 /* Make sure that the intrinsic is consistent with its internal
11852 representation. This needs to be done before assigning a default
11853 type to avoid spurious warnings. */
11854 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
11855 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
11858 /* Resolve associate names. */
11860 resolve_assoc_var (sym, true);
11862 /* Assign default type to symbols that need one and don't have one. */
11863 if (sym->ts.type == BT_UNKNOWN)
11865 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
11866 gfc_set_default_type (sym, 1, NULL);
11868 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
11869 && !sym->attr.function && !sym->attr.subroutine
11870 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
11871 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
11873 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
11875 /* The specific case of an external procedure should emit an error
11876 in the case that there is no implicit type. */
11878 gfc_set_default_type (sym, sym->attr.external, NULL);
11881 /* Result may be in another namespace. */
11882 resolve_symbol (sym->result);
11884 if (!sym->result->attr.proc_pointer)
11886 sym->ts = sym->result->ts;
11887 sym->as = gfc_copy_array_spec (sym->result->as);
11888 sym->attr.dimension = sym->result->attr.dimension;
11889 sym->attr.pointer = sym->result->attr.pointer;
11890 sym->attr.allocatable = sym->result->attr.allocatable;
11891 sym->attr.contiguous = sym->result->attr.contiguous;
11897 /* Assumed size arrays and assumed shape arrays must be dummy
11898 arguments. Array-spec's of implied-shape should have been resolved to
11899 AS_EXPLICIT already. */
11903 gcc_assert (sym->as->type != AS_IMPLIED_SHAPE);
11904 if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
11905 || sym->as->type == AS_ASSUMED_SHAPE)
11906 && sym->attr.dummy == 0)
11908 if (sym->as->type == AS_ASSUMED_SIZE)
11909 gfc_error ("Assumed size array at %L must be a dummy argument",
11910 &sym->declared_at);
11912 gfc_error ("Assumed shape array at %L must be a dummy argument",
11913 &sym->declared_at);
11918 /* Make sure symbols with known intent or optional are really dummy
11919 variable. Because of ENTRY statement, this has to be deferred
11920 until resolution time. */
11922 if (!sym->attr.dummy
11923 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
11925 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
11929 if (sym->attr.value && !sym->attr.dummy)
11931 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
11932 "it is not a dummy argument", sym->name, &sym->declared_at);
11936 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
11938 gfc_charlen *cl = sym->ts.u.cl;
11939 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
11941 gfc_error ("Character dummy variable '%s' at %L with VALUE "
11942 "attribute must have constant length",
11943 sym->name, &sym->declared_at);
11947 if (sym->ts.is_c_interop
11948 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
11950 gfc_error ("C interoperable character dummy variable '%s' at %L "
11951 "with VALUE attribute must have length one",
11952 sym->name, &sym->declared_at);
11957 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
11958 do this for something that was implicitly typed because that is handled
11959 in gfc_set_default_type. Handle dummy arguments and procedure
11960 definitions separately. Also, anything that is use associated is not
11961 handled here but instead is handled in the module it is declared in.
11962 Finally, derived type definitions are allowed to be BIND(C) since that
11963 only implies that they're interoperable, and they are checked fully for
11964 interoperability when a variable is declared of that type. */
11965 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
11966 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
11967 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
11969 gfc_try t = SUCCESS;
11971 /* First, make sure the variable is declared at the
11972 module-level scope (J3/04-007, Section 15.3). */
11973 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
11974 sym->attr.in_common == 0)
11976 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
11977 "is neither a COMMON block nor declared at the "
11978 "module level scope", sym->name, &(sym->declared_at));
11981 else if (sym->common_head != NULL)
11983 t = verify_com_block_vars_c_interop (sym->common_head);
11987 /* If type() declaration, we need to verify that the components
11988 of the given type are all C interoperable, etc. */
11989 if (sym->ts.type == BT_DERIVED &&
11990 sym->ts.u.derived->attr.is_c_interop != 1)
11992 /* Make sure the user marked the derived type as BIND(C). If
11993 not, call the verify routine. This could print an error
11994 for the derived type more than once if multiple variables
11995 of that type are declared. */
11996 if (sym->ts.u.derived->attr.is_bind_c != 1)
11997 verify_bind_c_derived_type (sym->ts.u.derived);
12001 /* Verify the variable itself as C interoperable if it
12002 is BIND(C). It is not possible for this to succeed if
12003 the verify_bind_c_derived_type failed, so don't have to handle
12004 any error returned by verify_bind_c_derived_type. */
12005 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
12006 sym->common_block);
12011 /* clear the is_bind_c flag to prevent reporting errors more than
12012 once if something failed. */
12013 sym->attr.is_bind_c = 0;
12018 /* If a derived type symbol has reached this point, without its
12019 type being declared, we have an error. Notice that most
12020 conditions that produce undefined derived types have already
12021 been dealt with. However, the likes of:
12022 implicit type(t) (t) ..... call foo (t) will get us here if
12023 the type is not declared in the scope of the implicit
12024 statement. Change the type to BT_UNKNOWN, both because it is so
12025 and to prevent an ICE. */
12026 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
12027 && !sym->ts.u.derived->attr.zero_comp)
12029 gfc_error ("The derived type '%s' at %L is of type '%s', "
12030 "which has not been defined", sym->name,
12031 &sym->declared_at, sym->ts.u.derived->name);
12032 sym->ts.type = BT_UNKNOWN;
12036 /* Make sure that the derived type has been resolved and that the
12037 derived type is visible in the symbol's namespace, if it is a
12038 module function and is not PRIVATE. */
12039 if (sym->ts.type == BT_DERIVED
12040 && sym->ts.u.derived->attr.use_assoc
12041 && sym->ns->proc_name
12042 && sym->ns->proc_name->attr.flavor == FL_MODULE)
12046 if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
12049 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
12050 if (!ds && sym->attr.function
12051 && gfc_check_access (sym->attr.access, sym->ns->default_access))
12053 symtree = gfc_new_symtree (&sym->ns->sym_root,
12054 sym->ts.u.derived->name);
12055 symtree->n.sym = sym->ts.u.derived;
12056 sym->ts.u.derived->refs++;
12060 /* Unless the derived-type declaration is use associated, Fortran 95
12061 does not allow public entries of private derived types.
12062 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12063 161 in 95-006r3. */
12064 if (sym->ts.type == BT_DERIVED
12065 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12066 && !sym->ts.u.derived->attr.use_assoc
12067 && gfc_check_access (sym->attr.access, sym->ns->default_access)
12068 && !gfc_check_access (sym->ts.u.derived->attr.access,
12069 sym->ts.u.derived->ns->default_access)
12070 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12071 "of PRIVATE derived type '%s'",
12072 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12073 : "variable", sym->name, &sym->declared_at,
12074 sym->ts.u.derived->name) == FAILURE)
12077 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12078 default initialization is defined (5.1.2.4.4). */
12079 if (sym->ts.type == BT_DERIVED
12081 && sym->attr.intent == INTENT_OUT
12083 && sym->as->type == AS_ASSUMED_SIZE)
12085 for (c = sym->ts.u.derived->components; c; c = c->next)
12087 if (c->initializer)
12089 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12090 "ASSUMED SIZE and so cannot have a default initializer",
12091 sym->name, &sym->declared_at);
12098 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12099 || sym->attr.codimension)
12100 && sym->attr.result)
12101 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12102 "a coarray component", sym->name, &sym->declared_at);
12105 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12106 && sym->ts.u.derived->ts.is_iso_c)
12107 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12108 "shall not be a coarray", sym->name, &sym->declared_at);
12111 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
12112 && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
12113 || sym->attr.allocatable))
12114 gfc_error ("Variable '%s' at %L with coarray component "
12115 "shall be a nonpointer, nonallocatable scalar",
12116 sym->name, &sym->declared_at);
12118 /* F2008, C526. The function-result case was handled above. */
12119 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12120 || sym->attr.codimension)
12121 && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
12122 || sym->ns->proc_name->attr.flavor == FL_MODULE
12123 || sym->ns->proc_name->attr.is_main_program
12124 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12125 gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
12126 "component and is not ALLOCATABLE, SAVE nor a "
12127 "dummy argument", sym->name, &sym->declared_at);
12128 /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
12129 else if (sym->attr.codimension && !sym->attr.allocatable
12130 && sym->as && sym->as->cotype == AS_DEFERRED)
12131 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12132 "deferred shape", sym->name, &sym->declared_at);
12133 else if (sym->attr.codimension && sym->attr.allocatable
12134 && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
12135 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12136 "deferred shape", sym->name, &sym->declared_at);
12140 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12141 || (sym->attr.codimension && sym->attr.allocatable))
12142 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12143 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12144 "allocatable coarray or have coarray components",
12145 sym->name, &sym->declared_at);
12147 if (sym->attr.codimension && sym->attr.dummy
12148 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12149 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12150 "procedure '%s'", sym->name, &sym->declared_at,
12151 sym->ns->proc_name->name);
12153 switch (sym->attr.flavor)
12156 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12161 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12166 if (resolve_fl_namelist (sym) == FAILURE)
12171 if (resolve_fl_parameter (sym) == FAILURE)
12179 /* Resolve array specifier. Check as well some constraints
12180 on COMMON blocks. */
12182 check_constant = sym->attr.in_common && !sym->attr.pointer;
12184 /* Set the formal_arg_flag so that check_conflict will not throw
12185 an error for host associated variables in the specification
12186 expression for an array_valued function. */
12187 if (sym->attr.function && sym->as)
12188 formal_arg_flag = 1;
12190 gfc_resolve_array_spec (sym->as, check_constant);
12192 formal_arg_flag = 0;
12194 /* Resolve formal namespaces. */
12195 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12196 && !sym->attr.contained && !sym->attr.intrinsic)
12197 gfc_resolve (sym->formal_ns);
12199 /* Make sure the formal namespace is present. */
12200 if (sym->formal && !sym->formal_ns)
12202 gfc_formal_arglist *formal = sym->formal;
12203 while (formal && !formal->sym)
12204 formal = formal->next;
12208 sym->formal_ns = formal->sym->ns;
12209 sym->formal_ns->refs++;
12213 /* Check threadprivate restrictions. */
12214 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12215 && (!sym->attr.in_common
12216 && sym->module == NULL
12217 && (sym->ns->proc_name == NULL
12218 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12219 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12221 /* If we have come this far we can apply default-initializers, as
12222 described in 14.7.5, to those variables that have not already
12223 been assigned one. */
12224 if (sym->ts.type == BT_DERIVED
12225 && sym->ns == gfc_current_ns
12227 && !sym->attr.allocatable
12228 && !sym->attr.alloc_comp)
12230 symbol_attribute *a = &sym->attr;
12232 if ((!a->save && !a->dummy && !a->pointer
12233 && !a->in_common && !a->use_assoc
12234 && (a->referenced || a->result)
12235 && !(a->function && sym != sym->result))
12236 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12237 apply_default_init (sym);
12240 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
12241 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
12242 && !CLASS_DATA (sym)->attr.class_pointer
12243 && !CLASS_DATA (sym)->attr.allocatable)
12244 apply_default_init (sym);
12246 /* If this symbol has a type-spec, check it. */
12247 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12248 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12249 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12255 /************* Resolve DATA statements *************/
12259 gfc_data_value *vnode;
12265 /* Advance the values structure to point to the next value in the data list. */
12268 next_data_value (void)
12270 while (mpz_cmp_ui (values.left, 0) == 0)
12273 if (values.vnode->next == NULL)
12276 values.vnode = values.vnode->next;
12277 mpz_set (values.left, values.vnode->repeat);
12285 check_data_variable (gfc_data_variable *var, locus *where)
12291 ar_type mark = AR_UNKNOWN;
12293 mpz_t section_index[GFC_MAX_DIMENSIONS];
12299 if (gfc_resolve_expr (var->expr) == FAILURE)
12303 mpz_init_set_si (offset, 0);
12306 if (e->expr_type != EXPR_VARIABLE)
12307 gfc_internal_error ("check_data_variable(): Bad expression");
12309 sym = e->symtree->n.sym;
12311 if (sym->ns->is_block_data && !sym->attr.in_common)
12313 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12314 sym->name, &sym->declared_at);
12317 if (e->ref == NULL && sym->as)
12319 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12320 " declaration", sym->name, where);
12324 has_pointer = sym->attr.pointer;
12326 for (ref = e->ref; ref; ref = ref->next)
12328 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12331 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
12333 gfc_error ("DATA element '%s' at %L cannot have a coindex",
12339 && ref->type == REF_ARRAY
12340 && ref->u.ar.type != AR_FULL)
12342 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12343 "be a full array", sym->name, where);
12348 if (e->rank == 0 || has_pointer)
12350 mpz_init_set_ui (size, 1);
12357 /* Find the array section reference. */
12358 for (ref = e->ref; ref; ref = ref->next)
12360 if (ref->type != REF_ARRAY)
12362 if (ref->u.ar.type == AR_ELEMENT)
12368 /* Set marks according to the reference pattern. */
12369 switch (ref->u.ar.type)
12377 /* Get the start position of array section. */
12378 gfc_get_section_index (ar, section_index, &offset);
12383 gcc_unreachable ();
12386 if (gfc_array_size (e, &size) == FAILURE)
12388 gfc_error ("Nonconstant array section at %L in DATA statement",
12390 mpz_clear (offset);
12397 while (mpz_cmp_ui (size, 0) > 0)
12399 if (next_data_value () == FAILURE)
12401 gfc_error ("DATA statement at %L has more variables than values",
12407 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12411 /* If we have more than one element left in the repeat count,
12412 and we have more than one element left in the target variable,
12413 then create a range assignment. */
12414 /* FIXME: Only done for full arrays for now, since array sections
12416 if (mark == AR_FULL && ref && ref->next == NULL
12417 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12421 if (mpz_cmp (size, values.left) >= 0)
12423 mpz_init_set (range, values.left);
12424 mpz_sub (size, size, values.left);
12425 mpz_set_ui (values.left, 0);
12429 mpz_init_set (range, size);
12430 mpz_sub (values.left, values.left, size);
12431 mpz_set_ui (size, 0);
12434 t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
12437 mpz_add (offset, offset, range);
12444 /* Assign initial value to symbol. */
12447 mpz_sub_ui (values.left, values.left, 1);
12448 mpz_sub_ui (size, size, 1);
12450 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
12454 if (mark == AR_FULL)
12455 mpz_add_ui (offset, offset, 1);
12457 /* Modify the array section indexes and recalculate the offset
12458 for next element. */
12459 else if (mark == AR_SECTION)
12460 gfc_advance_section (section_index, ar, &offset);
12464 if (mark == AR_SECTION)
12466 for (i = 0; i < ar->dimen; i++)
12467 mpz_clear (section_index[i]);
12471 mpz_clear (offset);
12477 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
12479 /* Iterate over a list of elements in a DATA statement. */
12482 traverse_data_list (gfc_data_variable *var, locus *where)
12485 iterator_stack frame;
12486 gfc_expr *e, *start, *end, *step;
12487 gfc_try retval = SUCCESS;
12489 mpz_init (frame.value);
12492 start = gfc_copy_expr (var->iter.start);
12493 end = gfc_copy_expr (var->iter.end);
12494 step = gfc_copy_expr (var->iter.step);
12496 if (gfc_simplify_expr (start, 1) == FAILURE
12497 || start->expr_type != EXPR_CONSTANT)
12499 gfc_error ("start of implied-do loop at %L could not be "
12500 "simplified to a constant value", &start->where);
12504 if (gfc_simplify_expr (end, 1) == FAILURE
12505 || end->expr_type != EXPR_CONSTANT)
12507 gfc_error ("end of implied-do loop at %L could not be "
12508 "simplified to a constant value", &start->where);
12512 if (gfc_simplify_expr (step, 1) == FAILURE
12513 || step->expr_type != EXPR_CONSTANT)
12515 gfc_error ("step of implied-do loop at %L could not be "
12516 "simplified to a constant value", &start->where);
12521 mpz_set (trip, end->value.integer);
12522 mpz_sub (trip, trip, start->value.integer);
12523 mpz_add (trip, trip, step->value.integer);
12525 mpz_div (trip, trip, step->value.integer);
12527 mpz_set (frame.value, start->value.integer);
12529 frame.prev = iter_stack;
12530 frame.variable = var->iter.var->symtree;
12531 iter_stack = &frame;
12533 while (mpz_cmp_ui (trip, 0) > 0)
12535 if (traverse_data_var (var->list, where) == FAILURE)
12541 e = gfc_copy_expr (var->expr);
12542 if (gfc_simplify_expr (e, 1) == FAILURE)
12549 mpz_add (frame.value, frame.value, step->value.integer);
12551 mpz_sub_ui (trip, trip, 1);
12555 mpz_clear (frame.value);
12558 gfc_free_expr (start);
12559 gfc_free_expr (end);
12560 gfc_free_expr (step);
12562 iter_stack = frame.prev;
12567 /* Type resolve variables in the variable list of a DATA statement. */
12570 traverse_data_var (gfc_data_variable *var, locus *where)
12574 for (; var; var = var->next)
12576 if (var->expr == NULL)
12577 t = traverse_data_list (var, where);
12579 t = check_data_variable (var, where);
12589 /* Resolve the expressions and iterators associated with a data statement.
12590 This is separate from the assignment checking because data lists should
12591 only be resolved once. */
12594 resolve_data_variables (gfc_data_variable *d)
12596 for (; d; d = d->next)
12598 if (d->list == NULL)
12600 if (gfc_resolve_expr (d->expr) == FAILURE)
12605 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
12608 if (resolve_data_variables (d->list) == FAILURE)
12617 /* Resolve a single DATA statement. We implement this by storing a pointer to
12618 the value list into static variables, and then recursively traversing the
12619 variables list, expanding iterators and such. */
12622 resolve_data (gfc_data *d)
12625 if (resolve_data_variables (d->var) == FAILURE)
12628 values.vnode = d->value;
12629 if (d->value == NULL)
12630 mpz_set_ui (values.left, 0);
12632 mpz_set (values.left, d->value->repeat);
12634 if (traverse_data_var (d->var, &d->where) == FAILURE)
12637 /* At this point, we better not have any values left. */
12639 if (next_data_value () == SUCCESS)
12640 gfc_error ("DATA statement at %L has more values than variables",
12645 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
12646 accessed by host or use association, is a dummy argument to a pure function,
12647 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
12648 is storage associated with any such variable, shall not be used in the
12649 following contexts: (clients of this function). */
12651 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
12652 procedure. Returns zero if assignment is OK, nonzero if there is a
12655 gfc_impure_variable (gfc_symbol *sym)
12660 if (sym->attr.use_assoc || sym->attr.in_common)
12663 /* Check if the symbol's ns is inside the pure procedure. */
12664 for (ns = gfc_current_ns; ns; ns = ns->parent)
12668 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
12672 proc = sym->ns->proc_name;
12673 if (sym->attr.dummy && gfc_pure (proc)
12674 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
12676 proc->attr.function))
12679 /* TODO: Sort out what can be storage associated, if anything, and include
12680 it here. In principle equivalences should be scanned but it does not
12681 seem to be possible to storage associate an impure variable this way. */
12686 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
12687 current namespace is inside a pure procedure. */
12690 gfc_pure (gfc_symbol *sym)
12692 symbol_attribute attr;
12697 /* Check if the current namespace or one of its parents
12698 belongs to a pure procedure. */
12699 for (ns = gfc_current_ns; ns; ns = ns->parent)
12701 sym = ns->proc_name;
12705 if (attr.flavor == FL_PROCEDURE && attr.pure)
12713 return attr.flavor == FL_PROCEDURE && attr.pure;
12717 /* Test whether the current procedure is elemental or not. */
12720 gfc_elemental (gfc_symbol *sym)
12722 symbol_attribute attr;
12725 sym = gfc_current_ns->proc_name;
12730 return attr.flavor == FL_PROCEDURE && attr.elemental;
12734 /* Warn about unused labels. */
12737 warn_unused_fortran_label (gfc_st_label *label)
12742 warn_unused_fortran_label (label->left);
12744 if (label->defined == ST_LABEL_UNKNOWN)
12747 switch (label->referenced)
12749 case ST_LABEL_UNKNOWN:
12750 gfc_warning ("Label %d at %L defined but not used", label->value,
12754 case ST_LABEL_BAD_TARGET:
12755 gfc_warning ("Label %d at %L defined but cannot be used",
12756 label->value, &label->where);
12763 warn_unused_fortran_label (label->right);
12767 /* Returns the sequence type of a symbol or sequence. */
12770 sequence_type (gfc_typespec ts)
12779 if (ts.u.derived->components == NULL)
12780 return SEQ_NONDEFAULT;
12782 result = sequence_type (ts.u.derived->components->ts);
12783 for (c = ts.u.derived->components->next; c; c = c->next)
12784 if (sequence_type (c->ts) != result)
12790 if (ts.kind != gfc_default_character_kind)
12791 return SEQ_NONDEFAULT;
12793 return SEQ_CHARACTER;
12796 if (ts.kind != gfc_default_integer_kind)
12797 return SEQ_NONDEFAULT;
12799 return SEQ_NUMERIC;
12802 if (!(ts.kind == gfc_default_real_kind
12803 || ts.kind == gfc_default_double_kind))
12804 return SEQ_NONDEFAULT;
12806 return SEQ_NUMERIC;
12809 if (ts.kind != gfc_default_complex_kind)
12810 return SEQ_NONDEFAULT;
12812 return SEQ_NUMERIC;
12815 if (ts.kind != gfc_default_logical_kind)
12816 return SEQ_NONDEFAULT;
12818 return SEQ_NUMERIC;
12821 return SEQ_NONDEFAULT;
12826 /* Resolve derived type EQUIVALENCE object. */
12829 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
12831 gfc_component *c = derived->components;
12836 /* Shall not be an object of nonsequence derived type. */
12837 if (!derived->attr.sequence)
12839 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
12840 "attribute to be an EQUIVALENCE object", sym->name,
12845 /* Shall not have allocatable components. */
12846 if (derived->attr.alloc_comp)
12848 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
12849 "components to be an EQUIVALENCE object",sym->name,
12854 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
12856 gfc_error ("Derived type variable '%s' at %L with default "
12857 "initialization cannot be in EQUIVALENCE with a variable "
12858 "in COMMON", sym->name, &e->where);
12862 for (; c ; c = c->next)
12864 if (c->ts.type == BT_DERIVED
12865 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
12868 /* Shall not be an object of sequence derived type containing a pointer
12869 in the structure. */
12870 if (c->attr.pointer)
12872 gfc_error ("Derived type variable '%s' at %L with pointer "
12873 "component(s) cannot be an EQUIVALENCE object",
12874 sym->name, &e->where);
12882 /* Resolve equivalence object.
12883 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
12884 an allocatable array, an object of nonsequence derived type, an object of
12885 sequence derived type containing a pointer at any level of component
12886 selection, an automatic object, a function name, an entry name, a result
12887 name, a named constant, a structure component, or a subobject of any of
12888 the preceding objects. A substring shall not have length zero. A
12889 derived type shall not have components with default initialization nor
12890 shall two objects of an equivalence group be initialized.
12891 Either all or none of the objects shall have an protected attribute.
12892 The simple constraints are done in symbol.c(check_conflict) and the rest
12893 are implemented here. */
12896 resolve_equivalence (gfc_equiv *eq)
12899 gfc_symbol *first_sym;
12902 locus *last_where = NULL;
12903 seq_type eq_type, last_eq_type;
12904 gfc_typespec *last_ts;
12905 int object, cnt_protected;
12908 last_ts = &eq->expr->symtree->n.sym->ts;
12910 first_sym = eq->expr->symtree->n.sym;
12914 for (object = 1; eq; eq = eq->eq, object++)
12918 e->ts = e->symtree->n.sym->ts;
12919 /* match_varspec might not know yet if it is seeing
12920 array reference or substring reference, as it doesn't
12922 if (e->ref && e->ref->type == REF_ARRAY)
12924 gfc_ref *ref = e->ref;
12925 sym = e->symtree->n.sym;
12927 if (sym->attr.dimension)
12929 ref->u.ar.as = sym->as;
12933 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
12934 if (e->ts.type == BT_CHARACTER
12936 && ref->type == REF_ARRAY
12937 && ref->u.ar.dimen == 1
12938 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
12939 && ref->u.ar.stride[0] == NULL)
12941 gfc_expr *start = ref->u.ar.start[0];
12942 gfc_expr *end = ref->u.ar.end[0];
12945 /* Optimize away the (:) reference. */
12946 if (start == NULL && end == NULL)
12949 e->ref = ref->next;
12951 e->ref->next = ref->next;
12956 ref->type = REF_SUBSTRING;
12958 start = gfc_get_int_expr (gfc_default_integer_kind,
12960 ref->u.ss.start = start;
12961 if (end == NULL && e->ts.u.cl)
12962 end = gfc_copy_expr (e->ts.u.cl->length);
12963 ref->u.ss.end = end;
12964 ref->u.ss.length = e->ts.u.cl;
12971 /* Any further ref is an error. */
12974 gcc_assert (ref->type == REF_ARRAY);
12975 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
12981 if (gfc_resolve_expr (e) == FAILURE)
12984 sym = e->symtree->n.sym;
12986 if (sym->attr.is_protected)
12988 if (cnt_protected > 0 && cnt_protected != object)
12990 gfc_error ("Either all or none of the objects in the "
12991 "EQUIVALENCE set at %L shall have the "
12992 "PROTECTED attribute",
12997 /* Shall not equivalence common block variables in a PURE procedure. */
12998 if (sym->ns->proc_name
12999 && sym->ns->proc_name->attr.pure
13000 && sym->attr.in_common)
13002 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13003 "object in the pure procedure '%s'",
13004 sym->name, &e->where, sym->ns->proc_name->name);
13008 /* Shall not be a named constant. */
13009 if (e->expr_type == EXPR_CONSTANT)
13011 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13012 "object", sym->name, &e->where);
13016 if (e->ts.type == BT_DERIVED
13017 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
13020 /* Check that the types correspond correctly:
13022 A numeric sequence structure may be equivalenced to another sequence
13023 structure, an object of default integer type, default real type, double
13024 precision real type, default logical type such that components of the
13025 structure ultimately only become associated to objects of the same
13026 kind. A character sequence structure may be equivalenced to an object
13027 of default character kind or another character sequence structure.
13028 Other objects may be equivalenced only to objects of the same type and
13029 kind parameters. */
13031 /* Identical types are unconditionally OK. */
13032 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
13033 goto identical_types;
13035 last_eq_type = sequence_type (*last_ts);
13036 eq_type = sequence_type (sym->ts);
13038 /* Since the pair of objects is not of the same type, mixed or
13039 non-default sequences can be rejected. */
13041 msg = "Sequence %s with mixed components in EQUIVALENCE "
13042 "statement at %L with different type objects";
13044 && last_eq_type == SEQ_MIXED
13045 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
13047 || (eq_type == SEQ_MIXED
13048 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13049 &e->where) == FAILURE))
13052 msg = "Non-default type object or sequence %s in EQUIVALENCE "
13053 "statement at %L with objects of different type";
13055 && last_eq_type == SEQ_NONDEFAULT
13056 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
13057 last_where) == FAILURE)
13058 || (eq_type == SEQ_NONDEFAULT
13059 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13060 &e->where) == FAILURE))
13063 msg ="Non-CHARACTER object '%s' in default CHARACTER "
13064 "EQUIVALENCE statement at %L";
13065 if (last_eq_type == SEQ_CHARACTER
13066 && eq_type != SEQ_CHARACTER
13067 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13068 &e->where) == FAILURE)
13071 msg ="Non-NUMERIC object '%s' in default NUMERIC "
13072 "EQUIVALENCE statement at %L";
13073 if (last_eq_type == SEQ_NUMERIC
13074 && eq_type != SEQ_NUMERIC
13075 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13076 &e->where) == FAILURE)
13081 last_where = &e->where;
13086 /* Shall not be an automatic array. */
13087 if (e->ref->type == REF_ARRAY
13088 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
13090 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13091 "an EQUIVALENCE object", sym->name, &e->where);
13098 /* Shall not be a structure component. */
13099 if (r->type == REF_COMPONENT)
13101 gfc_error ("Structure component '%s' at %L cannot be an "
13102 "EQUIVALENCE object",
13103 r->u.c.component->name, &e->where);
13107 /* A substring shall not have length zero. */
13108 if (r->type == REF_SUBSTRING)
13110 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13112 gfc_error ("Substring at %L has length zero",
13113 &r->u.ss.start->where);
13123 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13126 resolve_fntype (gfc_namespace *ns)
13128 gfc_entry_list *el;
13131 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13134 /* If there are any entries, ns->proc_name is the entry master
13135 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13137 sym = ns->entries->sym;
13139 sym = ns->proc_name;
13140 if (sym->result == sym
13141 && sym->ts.type == BT_UNKNOWN
13142 && gfc_set_default_type (sym, 0, NULL) == FAILURE
13143 && !sym->attr.untyped)
13145 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13146 sym->name, &sym->declared_at);
13147 sym->attr.untyped = 1;
13150 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13151 && !sym->attr.contained
13152 && !gfc_check_access (sym->ts.u.derived->attr.access,
13153 sym->ts.u.derived->ns->default_access)
13154 && gfc_check_access (sym->attr.access, sym->ns->default_access))
13156 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13157 "%L of PRIVATE type '%s'", sym->name,
13158 &sym->declared_at, sym->ts.u.derived->name);
13162 for (el = ns->entries->next; el; el = el->next)
13164 if (el->sym->result == el->sym
13165 && el->sym->ts.type == BT_UNKNOWN
13166 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13167 && !el->sym->attr.untyped)
13169 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13170 el->sym->name, &el->sym->declared_at);
13171 el->sym->attr.untyped = 1;
13177 /* 12.3.2.1.1 Defined operators. */
13180 check_uop_procedure (gfc_symbol *sym, locus where)
13182 gfc_formal_arglist *formal;
13184 if (!sym->attr.function)
13186 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13187 sym->name, &where);
13191 if (sym->ts.type == BT_CHARACTER
13192 && !(sym->ts.u.cl && sym->ts.u.cl->length)
13193 && !(sym->result && sym->result->ts.u.cl
13194 && sym->result->ts.u.cl->length))
13196 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13197 "character length", sym->name, &where);
13201 formal = sym->formal;
13202 if (!formal || !formal->sym)
13204 gfc_error ("User operator procedure '%s' at %L must have at least "
13205 "one argument", sym->name, &where);
13209 if (formal->sym->attr.intent != INTENT_IN)
13211 gfc_error ("First argument of operator interface at %L must be "
13212 "INTENT(IN)", &where);
13216 if (formal->sym->attr.optional)
13218 gfc_error ("First argument of operator interface at %L cannot be "
13219 "optional", &where);
13223 formal = formal->next;
13224 if (!formal || !formal->sym)
13227 if (formal->sym->attr.intent != INTENT_IN)
13229 gfc_error ("Second argument of operator interface at %L must be "
13230 "INTENT(IN)", &where);
13234 if (formal->sym->attr.optional)
13236 gfc_error ("Second argument of operator interface at %L cannot be "
13237 "optional", &where);
13243 gfc_error ("Operator interface at %L must have, at most, two "
13244 "arguments", &where);
13252 gfc_resolve_uops (gfc_symtree *symtree)
13254 gfc_interface *itr;
13256 if (symtree == NULL)
13259 gfc_resolve_uops (symtree->left);
13260 gfc_resolve_uops (symtree->right);
13262 for (itr = symtree->n.uop->op; itr; itr = itr->next)
13263 check_uop_procedure (itr->sym, itr->sym->declared_at);
13267 /* Examine all of the expressions associated with a program unit,
13268 assign types to all intermediate expressions, make sure that all
13269 assignments are to compatible types and figure out which names
13270 refer to which functions or subroutines. It doesn't check code
13271 block, which is handled by resolve_code. */
13274 resolve_types (gfc_namespace *ns)
13280 gfc_namespace* old_ns = gfc_current_ns;
13282 /* Check that all IMPLICIT types are ok. */
13283 if (!ns->seen_implicit_none)
13286 for (letter = 0; letter != GFC_LETTERS; ++letter)
13287 if (ns->set_flag[letter]
13288 && resolve_typespec_used (&ns->default_type[letter],
13289 &ns->implicit_loc[letter],
13294 gfc_current_ns = ns;
13296 resolve_entries (ns);
13298 resolve_common_vars (ns->blank_common.head, false);
13299 resolve_common_blocks (ns->common_root);
13301 resolve_contained_functions (ns);
13303 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13305 for (cl = ns->cl_list; cl; cl = cl->next)
13306 resolve_charlen (cl);
13308 gfc_traverse_ns (ns, resolve_symbol);
13310 resolve_fntype (ns);
13312 for (n = ns->contained; n; n = n->sibling)
13314 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13315 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13316 "also be PURE", n->proc_name->name,
13317 &n->proc_name->declared_at);
13323 gfc_check_interfaces (ns);
13325 gfc_traverse_ns (ns, resolve_values);
13331 for (d = ns->data; d; d = d->next)
13335 gfc_traverse_ns (ns, gfc_formalize_init_value);
13337 gfc_traverse_ns (ns, gfc_verify_binding_labels);
13339 if (ns->common_root != NULL)
13340 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13342 for (eq = ns->equiv; eq; eq = eq->next)
13343 resolve_equivalence (eq);
13345 /* Warn about unused labels. */
13346 if (warn_unused_label)
13347 warn_unused_fortran_label (ns->st_labels);
13349 gfc_resolve_uops (ns->uop_root);
13351 gfc_current_ns = old_ns;
13355 /* Call resolve_code recursively. */
13358 resolve_codes (gfc_namespace *ns)
13361 bitmap_obstack old_obstack;
13363 if (ns->resolved == 1)
13366 for (n = ns->contained; n; n = n->sibling)
13369 gfc_current_ns = ns;
13371 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13372 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13375 /* Set to an out of range value. */
13376 current_entry_id = -1;
13378 old_obstack = labels_obstack;
13379 bitmap_obstack_initialize (&labels_obstack);
13381 resolve_code (ns->code, ns);
13383 bitmap_obstack_release (&labels_obstack);
13384 labels_obstack = old_obstack;
13388 /* This function is called after a complete program unit has been compiled.
13389 Its purpose is to examine all of the expressions associated with a program
13390 unit, assign types to all intermediate expressions, make sure that all
13391 assignments are to compatible types and figure out which names refer to
13392 which functions or subroutines. */
13395 gfc_resolve (gfc_namespace *ns)
13397 gfc_namespace *old_ns;
13398 code_stack *old_cs_base;
13404 old_ns = gfc_current_ns;
13405 old_cs_base = cs_base;
13407 resolve_types (ns);
13408 resolve_codes (ns);
13410 gfc_current_ns = old_ns;
13411 cs_base = old_cs_base;
13414 gfc_run_passes (ns);