1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
29 #include "arith.h" /* For gfc_compare_expr(). */
30 #include "dependency.h"
32 #include "target-memory.h" /* for gfc_simplify_transfer */
33 #include "constructor.h"
35 /* Types used in equivalence statements. */
39 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
43 /* Stack to keep track of the nesting of blocks as we move through the
44 code. See resolve_branch() and resolve_code(). */
46 typedef struct code_stack
48 struct gfc_code *head, *current;
49 struct code_stack *prev;
51 /* This bitmap keeps track of the targets valid for a branch from
52 inside this block except for END {IF|SELECT}s of enclosing
54 bitmap reachable_labels;
58 static code_stack *cs_base = NULL;
61 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
63 static int forall_flag;
64 static int do_concurrent_flag;
66 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
68 static int omp_workshare_flag;
70 /* Nonzero if we are processing a formal arglist. The corresponding function
71 resets the flag each time that it is read. */
72 static int formal_arg_flag = 0;
74 /* True if we are resolving a specification expression. */
75 static int specification_expr = 0;
77 /* The id of the last entry seen. */
78 static int current_entry_id;
80 /* We use bitmaps to determine if a branch target is valid. */
81 static bitmap_obstack labels_obstack;
83 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
84 static bool inquiry_argument = false;
87 gfc_is_formal_arg (void)
89 return formal_arg_flag;
92 /* Is the symbol host associated? */
94 is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
96 for (ns = ns->parent; ns; ns = ns->parent)
105 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
106 an ABSTRACT derived-type. If where is not NULL, an error message with that
107 locus is printed, optionally using name. */
110 resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
112 if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
117 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
118 name, where, ts->u.derived->name);
120 gfc_error ("ABSTRACT type '%s' used at %L",
121 ts->u.derived->name, where);
131 static void resolve_symbol (gfc_symbol *sym);
132 static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc);
135 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
138 resolve_procedure_interface (gfc_symbol *sym)
140 if (sym->ts.interface == sym)
142 gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
143 sym->name, &sym->declared_at);
146 if (sym->ts.interface->attr.procedure)
148 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
149 "in a later PROCEDURE statement", sym->ts.interface->name,
150 sym->name, &sym->declared_at);
154 /* Get the attributes from the interface (now resolved). */
155 if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
157 gfc_symbol *ifc = sym->ts.interface;
158 resolve_symbol (ifc);
160 if (ifc->attr.intrinsic)
161 resolve_intrinsic (ifc, &ifc->declared_at);
165 sym->ts = ifc->result->ts;
170 sym->ts.interface = ifc;
171 sym->attr.function = ifc->attr.function;
172 sym->attr.subroutine = ifc->attr.subroutine;
173 gfc_copy_formal_args (sym, ifc);
175 sym->attr.allocatable = ifc->attr.allocatable;
176 sym->attr.pointer = ifc->attr.pointer;
177 sym->attr.pure = ifc->attr.pure;
178 sym->attr.elemental = ifc->attr.elemental;
179 sym->attr.dimension = ifc->attr.dimension;
180 sym->attr.contiguous = ifc->attr.contiguous;
181 sym->attr.recursive = ifc->attr.recursive;
182 sym->attr.always_explicit = ifc->attr.always_explicit;
183 sym->attr.ext_attr |= ifc->attr.ext_attr;
184 sym->attr.is_bind_c = ifc->attr.is_bind_c;
185 /* Copy array spec. */
186 sym->as = gfc_copy_array_spec (ifc->as);
190 for (i = 0; i < sym->as->rank; i++)
192 gfc_expr_replace_symbols (sym->as->lower[i], sym);
193 gfc_expr_replace_symbols (sym->as->upper[i], sym);
196 /* Copy char length. */
197 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
199 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
200 gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
201 if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
202 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
206 else if (sym->ts.interface->name[0] != '\0')
208 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
209 sym->ts.interface->name, sym->name, &sym->declared_at);
217 /* Resolve types of formal argument lists. These have to be done early so that
218 the formal argument lists of module procedures can be copied to the
219 containing module before the individual procedures are resolved
220 individually. We also resolve argument lists of procedures in interface
221 blocks because they are self-contained scoping units.
223 Since a dummy argument cannot be a non-dummy procedure, the only
224 resort left for untyped names are the IMPLICIT types. */
227 resolve_formal_arglist (gfc_symbol *proc)
229 gfc_formal_arglist *f;
233 if (proc->result != NULL)
238 if (gfc_elemental (proc)
239 || sym->attr.pointer || sym->attr.allocatable
240 || (sym->as && sym->as->rank > 0))
242 proc->attr.always_explicit = 1;
243 sym->attr.always_explicit = 1;
248 for (f = proc->formal; f; f = f->next)
254 /* Alternate return placeholder. */
255 if (gfc_elemental (proc))
256 gfc_error ("Alternate return specifier in elemental subroutine "
257 "'%s' at %L is not allowed", proc->name,
259 if (proc->attr.function)
260 gfc_error ("Alternate return specifier in function "
261 "'%s' at %L is not allowed", proc->name,
265 else if (sym->attr.procedure && sym->ts.interface
266 && sym->attr.if_source != IFSRC_DECL)
267 resolve_procedure_interface (sym);
269 if (sym->attr.if_source != IFSRC_UNKNOWN)
270 resolve_formal_arglist (sym);
272 if (sym->attr.subroutine || sym->attr.external)
274 if (sym->attr.flavor == FL_UNKNOWN)
275 gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
279 if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
280 && (!sym->attr.function || sym->result == sym))
281 gfc_set_default_type (sym, 1, sym->ns);
284 gfc_resolve_array_spec (sym->as, 0);
286 /* We can't tell if an array with dimension (:) is assumed or deferred
287 shape until we know if it has the pointer or allocatable attributes.
289 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
290 && !(sym->attr.pointer || sym->attr.allocatable)
291 && sym->attr.flavor != FL_PROCEDURE)
293 sym->as->type = AS_ASSUMED_SHAPE;
294 for (i = 0; i < sym->as->rank; i++)
295 sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
299 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
300 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
301 || sym->attr.optional)
303 proc->attr.always_explicit = 1;
305 proc->result->attr.always_explicit = 1;
308 /* If the flavor is unknown at this point, it has to be a variable.
309 A procedure specification would have already set the type. */
311 if (sym->attr.flavor == FL_UNKNOWN)
312 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
316 if (sym->attr.flavor == FL_PROCEDURE)
321 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
322 "also be PURE", sym->name, &sym->declared_at);
326 else if (!sym->attr.pointer)
328 if (proc->attr.function && sym->attr.intent != INTENT_IN)
331 gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s'"
332 " of pure function '%s' at %L with VALUE "
333 "attribute but without INTENT(IN)",
334 sym->name, proc->name, &sym->declared_at);
336 gfc_error ("Argument '%s' of pure function '%s' at %L must "
337 "be INTENT(IN) or VALUE", sym->name, proc->name,
341 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
344 gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s'"
345 " of pure subroutine '%s' at %L with VALUE "
346 "attribute but without INTENT", sym->name,
347 proc->name, &sym->declared_at);
349 gfc_error ("Argument '%s' of pure subroutine '%s' at %L "
350 "must have its INTENT specified or have the "
351 "VALUE attribute", sym->name, proc->name,
357 if (proc->attr.implicit_pure)
359 if (sym->attr.flavor == FL_PROCEDURE)
362 proc->attr.implicit_pure = 0;
364 else if (!sym->attr.pointer)
366 if (proc->attr.function && sym->attr.intent != INTENT_IN
368 proc->attr.implicit_pure = 0;
370 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
372 proc->attr.implicit_pure = 0;
376 if (gfc_elemental (proc))
379 if (sym->attr.codimension
380 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
381 && CLASS_DATA (sym)->attr.codimension))
383 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
384 "procedure", sym->name, &sym->declared_at);
388 if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
389 && CLASS_DATA (sym)->as))
391 gfc_error ("Argument '%s' of elemental procedure at %L must "
392 "be scalar", sym->name, &sym->declared_at);
396 if (sym->attr.allocatable
397 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
398 && CLASS_DATA (sym)->attr.allocatable))
400 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
401 "have the ALLOCATABLE attribute", sym->name,
406 if (sym->attr.pointer
407 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
408 && CLASS_DATA (sym)->attr.class_pointer))
410 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
411 "have the POINTER attribute", sym->name,
416 if (sym->attr.flavor == FL_PROCEDURE)
418 gfc_error ("Dummy procedure '%s' not allowed in elemental "
419 "procedure '%s' at %L", sym->name, proc->name,
424 if (sym->attr.intent == INTENT_UNKNOWN)
426 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
427 "have its INTENT specified", sym->name, proc->name,
433 /* Each dummy shall be specified to be scalar. */
434 if (proc->attr.proc == PROC_ST_FUNCTION)
438 gfc_error ("Argument '%s' of statement function at %L must "
439 "be scalar", sym->name, &sym->declared_at);
443 if (sym->ts.type == BT_CHARACTER)
445 gfc_charlen *cl = sym->ts.u.cl;
446 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
448 gfc_error ("Character-valued argument '%s' of statement "
449 "function at %L must have constant length",
450 sym->name, &sym->declared_at);
460 /* Work function called when searching for symbols that have argument lists
461 associated with them. */
464 find_arglists (gfc_symbol *sym)
466 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
467 || sym->attr.flavor == FL_DERIVED)
470 resolve_formal_arglist (sym);
474 /* Given a namespace, resolve all formal argument lists within the namespace.
478 resolve_formal_arglists (gfc_namespace *ns)
483 gfc_traverse_ns (ns, find_arglists);
488 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
492 /* If this namespace is not a function or an entry master function,
494 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
495 || sym->attr.entry_master)
498 /* Try to find out of what the return type is. */
499 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
501 t = gfc_set_default_type (sym->result, 0, ns);
503 if (t == FAILURE && !sym->result->attr.untyped)
505 if (sym->result == sym)
506 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
507 sym->name, &sym->declared_at);
508 else if (!sym->result->attr.proc_pointer)
509 gfc_error ("Result '%s' of contained function '%s' at %L has "
510 "no IMPLICIT type", sym->result->name, sym->name,
511 &sym->result->declared_at);
512 sym->result->attr.untyped = 1;
516 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
517 type, lists the only ways a character length value of * can be used:
518 dummy arguments of procedures, named constants, and function results
519 in external functions. Internal function results and results of module
520 procedures are not on this list, ergo, not permitted. */
522 if (sym->result->ts.type == BT_CHARACTER)
524 gfc_charlen *cl = sym->result->ts.u.cl;
525 if ((!cl || !cl->length) && !sym->result->ts.deferred)
527 /* See if this is a module-procedure and adapt error message
530 gcc_assert (ns->parent && ns->parent->proc_name);
531 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
533 gfc_error ("Character-valued %s '%s' at %L must not be"
535 module_proc ? _("module procedure")
536 : _("internal function"),
537 sym->name, &sym->declared_at);
543 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
544 introduce duplicates. */
547 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
549 gfc_formal_arglist *f, *new_arglist;
552 for (; new_args != NULL; new_args = new_args->next)
554 new_sym = new_args->sym;
555 /* See if this arg is already in the formal argument list. */
556 for (f = proc->formal; f; f = f->next)
558 if (new_sym == f->sym)
565 /* Add a new argument. Argument order is not important. */
566 new_arglist = gfc_get_formal_arglist ();
567 new_arglist->sym = new_sym;
568 new_arglist->next = proc->formal;
569 proc->formal = new_arglist;
574 /* Flag the arguments that are not present in all entries. */
577 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
579 gfc_formal_arglist *f, *head;
582 for (f = proc->formal; f; f = f->next)
587 for (new_args = head; new_args; new_args = new_args->next)
589 if (new_args->sym == f->sym)
596 f->sym->attr.not_always_present = 1;
601 /* Resolve alternate entry points. If a symbol has multiple entry points we
602 create a new master symbol for the main routine, and turn the existing
603 symbol into an entry point. */
606 resolve_entries (gfc_namespace *ns)
608 gfc_namespace *old_ns;
612 char name[GFC_MAX_SYMBOL_LEN + 1];
613 static int master_count = 0;
615 if (ns->proc_name == NULL)
618 /* No need to do anything if this procedure doesn't have alternate entry
623 /* We may already have resolved alternate entry points. */
624 if (ns->proc_name->attr.entry_master)
627 /* If this isn't a procedure something has gone horribly wrong. */
628 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
630 /* Remember the current namespace. */
631 old_ns = gfc_current_ns;
635 /* Add the main entry point to the list of entry points. */
636 el = gfc_get_entry_list ();
637 el->sym = ns->proc_name;
639 el->next = ns->entries;
641 ns->proc_name->attr.entry = 1;
643 /* If it is a module function, it needs to be in the right namespace
644 so that gfc_get_fake_result_decl can gather up the results. The
645 need for this arose in get_proc_name, where these beasts were
646 left in their own namespace, to keep prior references linked to
647 the entry declaration.*/
648 if (ns->proc_name->attr.function
649 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
652 /* Do the same for entries where the master is not a module
653 procedure. These are retained in the module namespace because
654 of the module procedure declaration. */
655 for (el = el->next; el; el = el->next)
656 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
657 && el->sym->attr.mod_proc)
661 /* Add an entry statement for it. */
668 /* Create a new symbol for the master function. */
669 /* Give the internal function a unique name (within this file).
670 Also include the function name so the user has some hope of figuring
671 out what is going on. */
672 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
673 master_count++, ns->proc_name->name);
674 gfc_get_ha_symbol (name, &proc);
675 gcc_assert (proc != NULL);
677 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
678 if (ns->proc_name->attr.subroutine)
679 gfc_add_subroutine (&proc->attr, proc->name, NULL);
683 gfc_typespec *ts, *fts;
684 gfc_array_spec *as, *fas;
685 gfc_add_function (&proc->attr, proc->name, NULL);
687 fas = ns->entries->sym->as;
688 fas = fas ? fas : ns->entries->sym->result->as;
689 fts = &ns->entries->sym->result->ts;
690 if (fts->type == BT_UNKNOWN)
691 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
692 for (el = ns->entries->next; el; el = el->next)
694 ts = &el->sym->result->ts;
696 as = as ? as : el->sym->result->as;
697 if (ts->type == BT_UNKNOWN)
698 ts = gfc_get_default_type (el->sym->result->name, NULL);
700 if (! gfc_compare_types (ts, fts)
701 || (el->sym->result->attr.dimension
702 != ns->entries->sym->result->attr.dimension)
703 || (el->sym->result->attr.pointer
704 != ns->entries->sym->result->attr.pointer))
706 else if (as && fas && ns->entries->sym->result != el->sym->result
707 && gfc_compare_array_spec (as, fas) == 0)
708 gfc_error ("Function %s at %L has entries with mismatched "
709 "array specifications", ns->entries->sym->name,
710 &ns->entries->sym->declared_at);
711 /* The characteristics need to match and thus both need to have
712 the same string length, i.e. both len=*, or both len=4.
713 Having both len=<variable> is also possible, but difficult to
714 check at compile time. */
715 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
716 && (((ts->u.cl->length && !fts->u.cl->length)
717 ||(!ts->u.cl->length && fts->u.cl->length))
719 && ts->u.cl->length->expr_type
720 != fts->u.cl->length->expr_type)
722 && ts->u.cl->length->expr_type == EXPR_CONSTANT
723 && mpz_cmp (ts->u.cl->length->value.integer,
724 fts->u.cl->length->value.integer) != 0)))
725 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
726 "entries returning variables of different "
727 "string lengths", ns->entries->sym->name,
728 &ns->entries->sym->declared_at);
733 sym = ns->entries->sym->result;
734 /* All result types the same. */
736 if (sym->attr.dimension)
737 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
738 if (sym->attr.pointer)
739 gfc_add_pointer (&proc->attr, NULL);
743 /* Otherwise the result will be passed through a union by
745 proc->attr.mixed_entry_master = 1;
746 for (el = ns->entries; el; el = el->next)
748 sym = el->sym->result;
749 if (sym->attr.dimension)
751 if (el == ns->entries)
752 gfc_error ("FUNCTION result %s can't be an array in "
753 "FUNCTION %s at %L", sym->name,
754 ns->entries->sym->name, &sym->declared_at);
756 gfc_error ("ENTRY result %s can't be an array in "
757 "FUNCTION %s at %L", sym->name,
758 ns->entries->sym->name, &sym->declared_at);
760 else if (sym->attr.pointer)
762 if (el == ns->entries)
763 gfc_error ("FUNCTION result %s can't be a POINTER in "
764 "FUNCTION %s at %L", sym->name,
765 ns->entries->sym->name, &sym->declared_at);
767 gfc_error ("ENTRY result %s can't be a POINTER in "
768 "FUNCTION %s at %L", sym->name,
769 ns->entries->sym->name, &sym->declared_at);
774 if (ts->type == BT_UNKNOWN)
775 ts = gfc_get_default_type (sym->name, NULL);
779 if (ts->kind == gfc_default_integer_kind)
783 if (ts->kind == gfc_default_real_kind
784 || ts->kind == gfc_default_double_kind)
788 if (ts->kind == gfc_default_complex_kind)
792 if (ts->kind == gfc_default_logical_kind)
796 /* We will issue error elsewhere. */
804 if (el == ns->entries)
805 gfc_error ("FUNCTION result %s can't be of type %s "
806 "in FUNCTION %s at %L", sym->name,
807 gfc_typename (ts), ns->entries->sym->name,
810 gfc_error ("ENTRY result %s can't be of type %s "
811 "in FUNCTION %s at %L", sym->name,
812 gfc_typename (ts), ns->entries->sym->name,
819 proc->attr.access = ACCESS_PRIVATE;
820 proc->attr.entry_master = 1;
822 /* Merge all the entry point arguments. */
823 for (el = ns->entries; el; el = el->next)
824 merge_argument_lists (proc, el->sym->formal);
826 /* Check the master formal arguments for any that are not
827 present in all entry points. */
828 for (el = ns->entries; el; el = el->next)
829 check_argument_lists (proc, el->sym->formal);
831 /* Use the master function for the function body. */
832 ns->proc_name = proc;
834 /* Finalize the new symbols. */
835 gfc_commit_symbols ();
837 /* Restore the original namespace. */
838 gfc_current_ns = old_ns;
842 /* Resolve common variables. */
844 resolve_common_vars (gfc_symbol *sym, bool named_common)
846 gfc_symbol *csym = sym;
848 for (; csym; csym = csym->common_next)
850 if (csym->value || csym->attr.data)
852 if (!csym->ns->is_block_data)
853 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
854 "but only in BLOCK DATA initialization is "
855 "allowed", csym->name, &csym->declared_at);
856 else if (!named_common)
857 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
858 "in a blank COMMON but initialization is only "
859 "allowed in named common blocks", csym->name,
863 if (csym->ts.type != BT_DERIVED)
866 if (!(csym->ts.u.derived->attr.sequence
867 || csym->ts.u.derived->attr.is_bind_c))
868 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
869 "has neither the SEQUENCE nor the BIND(C) "
870 "attribute", csym->name, &csym->declared_at);
871 if (csym->ts.u.derived->attr.alloc_comp)
872 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
873 "has an ultimate component that is "
874 "allocatable", csym->name, &csym->declared_at);
875 if (gfc_has_default_initializer (csym->ts.u.derived))
876 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
877 "may not have default initializer", csym->name,
880 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
881 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
885 /* Resolve common blocks. */
887 resolve_common_blocks (gfc_symtree *common_root)
891 if (common_root == NULL)
894 if (common_root->left)
895 resolve_common_blocks (common_root->left);
896 if (common_root->right)
897 resolve_common_blocks (common_root->right);
899 resolve_common_vars (common_root->n.common->head, true);
901 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
905 if (sym->attr.flavor == FL_PARAMETER)
906 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
907 sym->name, &common_root->n.common->where, &sym->declared_at);
909 if (sym->attr.external)
910 gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
911 sym->name, &common_root->n.common->where);
913 if (sym->attr.intrinsic)
914 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
915 sym->name, &common_root->n.common->where);
916 else if (sym->attr.result
917 || gfc_is_function_return_value (sym, gfc_current_ns))
918 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
919 "that is also a function result", sym->name,
920 &common_root->n.common->where);
921 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
922 && sym->attr.proc != PROC_ST_FUNCTION)
923 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
924 "that is also a global procedure", sym->name,
925 &common_root->n.common->where);
929 /* Resolve contained function types. Because contained functions can call one
930 another, they have to be worked out before any of the contained procedures
933 The good news is that if a function doesn't already have a type, the only
934 way it can get one is through an IMPLICIT type or a RESULT variable, because
935 by definition contained functions are contained namespace they're contained
936 in, not in a sibling or parent namespace. */
939 resolve_contained_functions (gfc_namespace *ns)
941 gfc_namespace *child;
944 resolve_formal_arglists (ns);
946 for (child = ns->contained; child; child = child->sibling)
948 /* Resolve alternate entry points first. */
949 resolve_entries (child);
951 /* Then check function return types. */
952 resolve_contained_fntype (child->proc_name, child);
953 for (el = child->entries; el; el = el->next)
954 resolve_contained_fntype (el->sym, child);
959 static gfc_try resolve_fl_derived0 (gfc_symbol *sym);
962 /* Resolve all of the elements of a structure constructor and make sure that
963 the types are correct. The 'init' flag indicates that the given
964 constructor is an initializer. */
967 resolve_structure_cons (gfc_expr *expr, int init)
969 gfc_constructor *cons;
976 if (expr->ts.type == BT_DERIVED)
977 resolve_fl_derived0 (expr->ts.u.derived);
979 cons = gfc_constructor_first (expr->value.constructor);
981 /* See if the user is trying to invoke a structure constructor for one of
982 the iso_c_binding derived types. */
983 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
984 && expr->ts.u.derived->ts.is_iso_c && cons
985 && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
987 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
988 expr->ts.u.derived->name, &(expr->where));
992 /* Return if structure constructor is c_null_(fun)prt. */
993 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
994 && expr->ts.u.derived->ts.is_iso_c && cons
995 && cons->expr && cons->expr->expr_type == EXPR_NULL)
998 /* A constructor may have references if it is the result of substituting a
999 parameter variable. In this case we just pull out the component we
1002 comp = expr->ref->u.c.sym->components;
1004 comp = expr->ts.u.derived->components;
1006 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1013 if (gfc_resolve_expr (cons->expr) == FAILURE)
1019 rank = comp->as ? comp->as->rank : 0;
1020 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
1021 && (comp->attr.allocatable || cons->expr->rank))
1023 gfc_error ("The rank of the element in the structure "
1024 "constructor at %L does not match that of the "
1025 "component (%d/%d)", &cons->expr->where,
1026 cons->expr->rank, rank);
1030 /* If we don't have the right type, try to convert it. */
1032 if (!comp->attr.proc_pointer &&
1033 !gfc_compare_types (&cons->expr->ts, &comp->ts))
1036 if (strcmp (comp->name, "_extends") == 0)
1038 /* Can afford to be brutal with the _extends initializer.
1039 The derived type can get lost because it is PRIVATE
1040 but it is not usage constrained by the standard. */
1041 cons->expr->ts = comp->ts;
1044 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1045 gfc_error ("The element in the structure constructor at %L, "
1046 "for pointer component '%s', is %s but should be %s",
1047 &cons->expr->where, comp->name,
1048 gfc_basic_typename (cons->expr->ts.type),
1049 gfc_basic_typename (comp->ts.type));
1051 t = gfc_convert_type (cons->expr, &comp->ts, 1);
1054 /* For strings, the length of the constructor should be the same as
1055 the one of the structure, ensure this if the lengths are known at
1056 compile time and when we are dealing with PARAMETER or structure
1058 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1059 && comp->ts.u.cl->length
1060 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1061 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1062 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1063 && cons->expr->rank != 0
1064 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1065 comp->ts.u.cl->length->value.integer) != 0)
1067 if (cons->expr->expr_type == EXPR_VARIABLE
1068 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1070 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1071 to make use of the gfc_resolve_character_array_constructor
1072 machinery. The expression is later simplified away to
1073 an array of string literals. */
1074 gfc_expr *para = cons->expr;
1075 cons->expr = gfc_get_expr ();
1076 cons->expr->ts = para->ts;
1077 cons->expr->where = para->where;
1078 cons->expr->expr_type = EXPR_ARRAY;
1079 cons->expr->rank = para->rank;
1080 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1081 gfc_constructor_append_expr (&cons->expr->value.constructor,
1082 para, &cons->expr->where);
1084 if (cons->expr->expr_type == EXPR_ARRAY)
1087 p = gfc_constructor_first (cons->expr->value.constructor);
1088 if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
1090 gfc_charlen *cl, *cl2;
1093 for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
1095 if (cl == cons->expr->ts.u.cl)
1103 cl2->next = cl->next;
1105 gfc_free_expr (cl->length);
1109 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1110 cons->expr->ts.u.cl->length_from_typespec = true;
1111 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1112 gfc_resolve_character_array_constructor (cons->expr);
1116 if (cons->expr->expr_type == EXPR_NULL
1117 && !(comp->attr.pointer || comp->attr.allocatable
1118 || comp->attr.proc_pointer
1119 || (comp->ts.type == BT_CLASS
1120 && (CLASS_DATA (comp)->attr.class_pointer
1121 || CLASS_DATA (comp)->attr.allocatable))))
1124 gfc_error ("The NULL in the structure constructor at %L is "
1125 "being applied to component '%s', which is neither "
1126 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1130 if (comp->attr.proc_pointer && comp->ts.interface)
1132 /* Check procedure pointer interface. */
1133 gfc_symbol *s2 = NULL;
1138 if (gfc_is_proc_ptr_comp (cons->expr, &c2))
1140 s2 = c2->ts.interface;
1143 else if (cons->expr->expr_type == EXPR_FUNCTION)
1145 s2 = cons->expr->symtree->n.sym->result;
1146 name = cons->expr->symtree->n.sym->result->name;
1148 else if (cons->expr->expr_type != EXPR_NULL)
1150 s2 = cons->expr->symtree->n.sym;
1151 name = cons->expr->symtree->n.sym->name;
1154 if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
1157 gfc_error ("Interface mismatch for procedure-pointer component "
1158 "'%s' in structure constructor at %L: %s",
1159 comp->name, &cons->expr->where, err);
1164 if (!comp->attr.pointer || comp->attr.proc_pointer
1165 || cons->expr->expr_type == EXPR_NULL)
1168 a = gfc_expr_attr (cons->expr);
1170 if (!a.pointer && !a.target)
1173 gfc_error ("The element in the structure constructor at %L, "
1174 "for pointer component '%s' should be a POINTER or "
1175 "a TARGET", &cons->expr->where, comp->name);
1180 /* F08:C461. Additional checks for pointer initialization. */
1184 gfc_error ("Pointer initialization target at %L "
1185 "must not be ALLOCATABLE ", &cons->expr->where);
1190 gfc_error ("Pointer initialization target at %L "
1191 "must have the SAVE attribute", &cons->expr->where);
1195 /* F2003, C1272 (3). */
1196 if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
1197 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1198 || gfc_is_coindexed (cons->expr)))
1201 gfc_error ("Invalid expression in the structure constructor for "
1202 "pointer component '%s' at %L in PURE procedure",
1203 comp->name, &cons->expr->where);
1206 if (gfc_implicit_pure (NULL)
1207 && cons->expr->expr_type == EXPR_VARIABLE
1208 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1209 || gfc_is_coindexed (cons->expr)))
1210 gfc_current_ns->proc_name->attr.implicit_pure = 0;
1218 /****************** Expression name resolution ******************/
1220 /* Returns 0 if a symbol was not declared with a type or
1221 attribute declaration statement, nonzero otherwise. */
1224 was_declared (gfc_symbol *sym)
1230 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1233 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1234 || a.optional || a.pointer || a.save || a.target || a.volatile_
1235 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1236 || a.asynchronous || a.codimension)
1243 /* Determine if a symbol is generic or not. */
1246 generic_sym (gfc_symbol *sym)
1250 if (sym->attr.generic ||
1251 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1254 if (was_declared (sym) || sym->ns->parent == NULL)
1257 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1264 return generic_sym (s);
1271 /* Determine if a symbol is specific or not. */
1274 specific_sym (gfc_symbol *sym)
1278 if (sym->attr.if_source == IFSRC_IFBODY
1279 || sym->attr.proc == PROC_MODULE
1280 || sym->attr.proc == PROC_INTERNAL
1281 || sym->attr.proc == PROC_ST_FUNCTION
1282 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1283 || sym->attr.external)
1286 if (was_declared (sym) || sym->ns->parent == NULL)
1289 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1291 return (s == NULL) ? 0 : specific_sym (s);
1295 /* Figure out if the procedure is specific, generic or unknown. */
1298 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1302 procedure_kind (gfc_symbol *sym)
1304 if (generic_sym (sym))
1305 return PTYPE_GENERIC;
1307 if (specific_sym (sym))
1308 return PTYPE_SPECIFIC;
1310 return PTYPE_UNKNOWN;
1313 /* Check references to assumed size arrays. The flag need_full_assumed_size
1314 is nonzero when matching actual arguments. */
1316 static int need_full_assumed_size = 0;
1319 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1321 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1324 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1325 What should it be? */
1326 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1327 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1328 && (e->ref->u.ar.type == AR_FULL))
1330 gfc_error ("The upper bound in the last dimension must "
1331 "appear in the reference to the assumed size "
1332 "array '%s' at %L", sym->name, &e->where);
1339 /* Look for bad assumed size array references in argument expressions
1340 of elemental and array valued intrinsic procedures. Since this is
1341 called from procedure resolution functions, it only recurses at
1345 resolve_assumed_size_actual (gfc_expr *e)
1350 switch (e->expr_type)
1353 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1358 if (resolve_assumed_size_actual (e->value.op.op1)
1359 || resolve_assumed_size_actual (e->value.op.op2))
1370 /* Check a generic procedure, passed as an actual argument, to see if
1371 there is a matching specific name. If none, it is an error, and if
1372 more than one, the reference is ambiguous. */
1374 count_specific_procs (gfc_expr *e)
1381 sym = e->symtree->n.sym;
1383 for (p = sym->generic; p; p = p->next)
1384 if (strcmp (sym->name, p->sym->name) == 0)
1386 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1392 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1396 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1397 "argument at %L", sym->name, &e->where);
1403 /* See if a call to sym could possibly be a not allowed RECURSION because of
1404 a missing RECURIVE declaration. This means that either sym is the current
1405 context itself, or sym is the parent of a contained procedure calling its
1406 non-RECURSIVE containing procedure.
1407 This also works if sym is an ENTRY. */
1410 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1412 gfc_symbol* proc_sym;
1413 gfc_symbol* context_proc;
1414 gfc_namespace* real_context;
1416 if (sym->attr.flavor == FL_PROGRAM
1417 || sym->attr.flavor == FL_DERIVED)
1420 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1422 /* If we've got an ENTRY, find real procedure. */
1423 if (sym->attr.entry && sym->ns->entries)
1424 proc_sym = sym->ns->entries->sym;
1428 /* If sym is RECURSIVE, all is well of course. */
1429 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1432 /* Find the context procedure's "real" symbol if it has entries.
1433 We look for a procedure symbol, so recurse on the parents if we don't
1434 find one (like in case of a BLOCK construct). */
1435 for (real_context = context; ; real_context = real_context->parent)
1437 /* We should find something, eventually! */
1438 gcc_assert (real_context);
1440 context_proc = (real_context->entries ? real_context->entries->sym
1441 : real_context->proc_name);
1443 /* In some special cases, there may not be a proc_name, like for this
1445 real(bad_kind()) function foo () ...
1446 when checking the call to bad_kind ().
1447 In these cases, we simply return here and assume that the
1452 if (context_proc->attr.flavor != FL_LABEL)
1456 /* A call from sym's body to itself is recursion, of course. */
1457 if (context_proc == proc_sym)
1460 /* The same is true if context is a contained procedure and sym the
1462 if (context_proc->attr.contained)
1464 gfc_symbol* parent_proc;
1466 gcc_assert (context->parent);
1467 parent_proc = (context->parent->entries ? context->parent->entries->sym
1468 : context->parent->proc_name);
1470 if (parent_proc == proc_sym)
1478 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1479 its typespec and formal argument list. */
1482 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1484 gfc_intrinsic_sym* isym = NULL;
1490 /* Already resolved. */
1491 if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
1494 /* We already know this one is an intrinsic, so we don't call
1495 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1496 gfc_find_subroutine directly to check whether it is a function or
1499 if (sym->intmod_sym_id)
1500 isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
1501 else if (!sym->attr.subroutine)
1502 isym = gfc_find_function (sym->name);
1506 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1507 && !sym->attr.implicit_type)
1508 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1509 " ignored", sym->name, &sym->declared_at);
1511 if (!sym->attr.function &&
1512 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1517 else if ((isym = gfc_find_subroutine (sym->name)))
1519 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1521 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1522 " specifier", sym->name, &sym->declared_at);
1526 if (!sym->attr.subroutine &&
1527 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1532 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1537 gfc_copy_formal_args_intr (sym, isym);
1539 /* Check it is actually available in the standard settings. */
1540 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1543 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1544 " available in the current standard settings but %s. Use"
1545 " an appropriate -std=* option or enable -fall-intrinsics"
1546 " in order to use it.",
1547 sym->name, &sym->declared_at, symstd);
1555 /* Resolve a procedure expression, like passing it to a called procedure or as
1556 RHS for a procedure pointer assignment. */
1559 resolve_procedure_expression (gfc_expr* expr)
1563 if (expr->expr_type != EXPR_VARIABLE)
1565 gcc_assert (expr->symtree);
1567 sym = expr->symtree->n.sym;
1569 if (sym->attr.intrinsic)
1570 resolve_intrinsic (sym, &expr->where);
1572 if (sym->attr.flavor != FL_PROCEDURE
1573 || (sym->attr.function && sym->result == sym))
1576 /* A non-RECURSIVE procedure that is used as procedure expression within its
1577 own body is in danger of being called recursively. */
1578 if (is_illegal_recursion (sym, gfc_current_ns))
1579 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1580 " itself recursively. Declare it RECURSIVE or use"
1581 " -frecursive", sym->name, &expr->where);
1587 /* Resolve an actual argument list. Most of the time, this is just
1588 resolving the expressions in the list.
1589 The exception is that we sometimes have to decide whether arguments
1590 that look like procedure arguments are really simple variable
1594 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1595 bool no_formal_args)
1598 gfc_symtree *parent_st;
1600 int save_need_full_assumed_size;
1602 for (; arg; arg = arg->next)
1607 /* Check the label is a valid branching target. */
1610 if (arg->label->defined == ST_LABEL_UNKNOWN)
1612 gfc_error ("Label %d referenced at %L is never defined",
1613 arg->label->value, &arg->label->where);
1620 if (e->expr_type == EXPR_VARIABLE
1621 && e->symtree->n.sym->attr.generic
1623 && count_specific_procs (e) != 1)
1626 if (e->ts.type != BT_PROCEDURE)
1628 save_need_full_assumed_size = need_full_assumed_size;
1629 if (e->expr_type != EXPR_VARIABLE)
1630 need_full_assumed_size = 0;
1631 if (gfc_resolve_expr (e) != SUCCESS)
1633 need_full_assumed_size = save_need_full_assumed_size;
1637 /* See if the expression node should really be a variable reference. */
1639 sym = e->symtree->n.sym;
1641 if (sym->attr.flavor == FL_PROCEDURE
1642 || sym->attr.intrinsic
1643 || sym->attr.external)
1647 /* If a procedure is not already determined to be something else
1648 check if it is intrinsic. */
1649 if (!sym->attr.intrinsic
1650 && !(sym->attr.external || sym->attr.use_assoc
1651 || sym->attr.if_source == IFSRC_IFBODY)
1652 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1653 sym->attr.intrinsic = 1;
1655 if (sym->attr.proc == PROC_ST_FUNCTION)
1657 gfc_error ("Statement function '%s' at %L is not allowed as an "
1658 "actual argument", sym->name, &e->where);
1661 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1662 sym->attr.subroutine);
1663 if (sym->attr.intrinsic && actual_ok == 0)
1665 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1666 "actual argument", sym->name, &e->where);
1669 if (sym->attr.contained && !sym->attr.use_assoc
1670 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1672 if (gfc_notify_std (GFC_STD_F2008,
1673 "Fortran 2008: Internal procedure '%s' is"
1674 " used as actual argument at %L",
1675 sym->name, &e->where) == FAILURE)
1679 if (sym->attr.elemental && !sym->attr.intrinsic)
1681 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1682 "allowed as an actual argument at %L", sym->name,
1686 /* Check if a generic interface has a specific procedure
1687 with the same name before emitting an error. */
1688 if (sym->attr.generic && count_specific_procs (e) != 1)
1691 /* Just in case a specific was found for the expression. */
1692 sym = e->symtree->n.sym;
1694 /* If the symbol is the function that names the current (or
1695 parent) scope, then we really have a variable reference. */
1697 if (gfc_is_function_return_value (sym, sym->ns))
1700 /* If all else fails, see if we have a specific intrinsic. */
1701 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1703 gfc_intrinsic_sym *isym;
1705 isym = gfc_find_function (sym->name);
1706 if (isym == NULL || !isym->specific)
1708 gfc_error ("Unable to find a specific INTRINSIC procedure "
1709 "for the reference '%s' at %L", sym->name,
1714 sym->attr.intrinsic = 1;
1715 sym->attr.function = 1;
1718 if (gfc_resolve_expr (e) == FAILURE)
1723 /* See if the name is a module procedure in a parent unit. */
1725 if (was_declared (sym) || sym->ns->parent == NULL)
1728 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1730 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1734 if (parent_st == NULL)
1737 sym = parent_st->n.sym;
1738 e->symtree = parent_st; /* Point to the right thing. */
1740 if (sym->attr.flavor == FL_PROCEDURE
1741 || sym->attr.intrinsic
1742 || sym->attr.external)
1744 if (gfc_resolve_expr (e) == FAILURE)
1750 e->expr_type = EXPR_VARIABLE;
1752 if ((sym->as != NULL && sym->ts.type != BT_CLASS)
1753 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
1754 && CLASS_DATA (sym)->as))
1756 e->rank = sym->ts.type == BT_CLASS
1757 ? CLASS_DATA (sym)->as->rank : sym->as->rank;
1758 e->ref = gfc_get_ref ();
1759 e->ref->type = REF_ARRAY;
1760 e->ref->u.ar.type = AR_FULL;
1761 e->ref->u.ar.as = sym->ts.type == BT_CLASS
1762 ? CLASS_DATA (sym)->as : sym->as;
1765 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1766 primary.c (match_actual_arg). If above code determines that it
1767 is a variable instead, it needs to be resolved as it was not
1768 done at the beginning of this function. */
1769 save_need_full_assumed_size = need_full_assumed_size;
1770 if (e->expr_type != EXPR_VARIABLE)
1771 need_full_assumed_size = 0;
1772 if (gfc_resolve_expr (e) != SUCCESS)
1774 need_full_assumed_size = save_need_full_assumed_size;
1777 /* Check argument list functions %VAL, %LOC and %REF. There is
1778 nothing to do for %REF. */
1779 if (arg->name && arg->name[0] == '%')
1781 if (strncmp ("%VAL", arg->name, 4) == 0)
1783 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1785 gfc_error ("By-value argument at %L is not of numeric "
1792 gfc_error ("By-value argument at %L cannot be an array or "
1793 "an array section", &e->where);
1797 /* Intrinsics are still PROC_UNKNOWN here. However,
1798 since same file external procedures are not resolvable
1799 in gfortran, it is a good deal easier to leave them to
1801 if (ptype != PROC_UNKNOWN
1802 && ptype != PROC_DUMMY
1803 && ptype != PROC_EXTERNAL
1804 && ptype != PROC_MODULE)
1806 gfc_error ("By-value argument at %L is not allowed "
1807 "in this context", &e->where);
1812 /* Statement functions have already been excluded above. */
1813 else if (strncmp ("%LOC", arg->name, 4) == 0
1814 && e->ts.type == BT_PROCEDURE)
1816 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1818 gfc_error ("Passing internal procedure at %L by location "
1819 "not allowed", &e->where);
1825 /* Fortran 2008, C1237. */
1826 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1827 && gfc_has_ultimate_pointer (e))
1829 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1830 "component", &e->where);
1839 /* Do the checks of the actual argument list that are specific to elemental
1840 procedures. If called with c == NULL, we have a function, otherwise if
1841 expr == NULL, we have a subroutine. */
1844 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1846 gfc_actual_arglist *arg0;
1847 gfc_actual_arglist *arg;
1848 gfc_symbol *esym = NULL;
1849 gfc_intrinsic_sym *isym = NULL;
1851 gfc_intrinsic_arg *iformal = NULL;
1852 gfc_formal_arglist *eformal = NULL;
1853 bool formal_optional = false;
1854 bool set_by_optional = false;
1858 /* Is this an elemental procedure? */
1859 if (expr && expr->value.function.actual != NULL)
1861 if (expr->value.function.esym != NULL
1862 && expr->value.function.esym->attr.elemental)
1864 arg0 = expr->value.function.actual;
1865 esym = expr->value.function.esym;
1867 else if (expr->value.function.isym != NULL
1868 && expr->value.function.isym->elemental)
1870 arg0 = expr->value.function.actual;
1871 isym = expr->value.function.isym;
1876 else if (c && c->ext.actual != NULL)
1878 arg0 = c->ext.actual;
1880 if (c->resolved_sym)
1881 esym = c->resolved_sym;
1883 esym = c->symtree->n.sym;
1886 if (!esym->attr.elemental)
1892 /* The rank of an elemental is the rank of its array argument(s). */
1893 for (arg = arg0; arg; arg = arg->next)
1895 if (arg->expr != NULL && arg->expr->rank > 0)
1897 rank = arg->expr->rank;
1898 if (arg->expr->expr_type == EXPR_VARIABLE
1899 && arg->expr->symtree->n.sym->attr.optional)
1900 set_by_optional = true;
1902 /* Function specific; set the result rank and shape. */
1906 if (!expr->shape && arg->expr->shape)
1908 expr->shape = gfc_get_shape (rank);
1909 for (i = 0; i < rank; i++)
1910 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1917 /* If it is an array, it shall not be supplied as an actual argument
1918 to an elemental procedure unless an array of the same rank is supplied
1919 as an actual argument corresponding to a nonoptional dummy argument of
1920 that elemental procedure(12.4.1.5). */
1921 formal_optional = false;
1923 iformal = isym->formal;
1925 eformal = esym->formal;
1927 for (arg = arg0; arg; arg = arg->next)
1931 if (eformal->sym && eformal->sym->attr.optional)
1932 formal_optional = true;
1933 eformal = eformal->next;
1935 else if (isym && iformal)
1937 if (iformal->optional)
1938 formal_optional = true;
1939 iformal = iformal->next;
1942 formal_optional = true;
1944 if (pedantic && arg->expr != NULL
1945 && arg->expr->expr_type == EXPR_VARIABLE
1946 && arg->expr->symtree->n.sym->attr.optional
1949 && (set_by_optional || arg->expr->rank != rank)
1950 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1952 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1953 "MISSING, it cannot be the actual argument of an "
1954 "ELEMENTAL procedure unless there is a non-optional "
1955 "argument with the same rank (12.4.1.5)",
1956 arg->expr->symtree->n.sym->name, &arg->expr->where);
1961 for (arg = arg0; arg; arg = arg->next)
1963 if (arg->expr == NULL || arg->expr->rank == 0)
1966 /* Being elemental, the last upper bound of an assumed size array
1967 argument must be present. */
1968 if (resolve_assumed_size_actual (arg->expr))
1971 /* Elemental procedure's array actual arguments must conform. */
1974 if (gfc_check_conformance (arg->expr, e,
1975 "elemental procedure") == FAILURE)
1982 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1983 is an array, the intent inout/out variable needs to be also an array. */
1984 if (rank > 0 && esym && expr == NULL)
1985 for (eformal = esym->formal, arg = arg0; arg && eformal;
1986 arg = arg->next, eformal = eformal->next)
1987 if ((eformal->sym->attr.intent == INTENT_OUT
1988 || eformal->sym->attr.intent == INTENT_INOUT)
1989 && arg->expr && arg->expr->rank == 0)
1991 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1992 "ELEMENTAL subroutine '%s' is a scalar, but another "
1993 "actual argument is an array", &arg->expr->where,
1994 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1995 : "INOUT", eformal->sym->name, esym->name);
2002 /* This function does the checking of references to global procedures
2003 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2004 77 and 95 standards. It checks for a gsymbol for the name, making
2005 one if it does not already exist. If it already exists, then the
2006 reference being resolved must correspond to the type of gsymbol.
2007 Otherwise, the new symbol is equipped with the attributes of the
2008 reference. The corresponding code that is called in creating
2009 global entities is parse.c.
2011 In addition, for all but -std=legacy, the gsymbols are used to
2012 check the interfaces of external procedures from the same file.
2013 The namespace of the gsymbol is resolved and then, once this is
2014 done the interface is checked. */
2018 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2020 if (!gsym_ns->proc_name->attr.recursive)
2023 if (sym->ns == gsym_ns)
2026 if (sym->ns->parent && sym->ns->parent == gsym_ns)
2033 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
2035 if (gsym_ns->entries)
2037 gfc_entry_list *entry = gsym_ns->entries;
2039 for (; entry; entry = entry->next)
2041 if (strcmp (sym->name, entry->sym->name) == 0)
2043 if (strcmp (gsym_ns->proc_name->name,
2044 sym->ns->proc_name->name) == 0)
2048 && strcmp (gsym_ns->proc_name->name,
2049 sym->ns->parent->proc_name->name) == 0)
2058 resolve_global_procedure (gfc_symbol *sym, locus *where,
2059 gfc_actual_arglist **actual, int sub)
2063 enum gfc_symbol_type type;
2065 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2067 gsym = gfc_get_gsymbol (sym->name);
2069 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2070 gfc_global_used (gsym, where);
2072 if (gfc_option.flag_whole_file
2073 && (sym->attr.if_source == IFSRC_UNKNOWN
2074 || sym->attr.if_source == IFSRC_IFBODY)
2075 && gsym->type != GSYM_UNKNOWN
2077 && gsym->ns->resolved != -1
2078 && gsym->ns->proc_name
2079 && not_in_recursive (sym, gsym->ns)
2080 && not_entry_self_reference (sym, gsym->ns))
2082 gfc_symbol *def_sym;
2084 /* Resolve the gsymbol namespace if needed. */
2085 if (!gsym->ns->resolved)
2087 gfc_dt_list *old_dt_list;
2088 struct gfc_omp_saved_state old_omp_state;
2090 /* Stash away derived types so that the backend_decls do not
2092 old_dt_list = gfc_derived_types;
2093 gfc_derived_types = NULL;
2094 /* And stash away openmp state. */
2095 gfc_omp_save_and_clear_state (&old_omp_state);
2097 gfc_resolve (gsym->ns);
2099 /* Store the new derived types with the global namespace. */
2100 if (gfc_derived_types)
2101 gsym->ns->derived_types = gfc_derived_types;
2103 /* Restore the derived types of this namespace. */
2104 gfc_derived_types = old_dt_list;
2105 /* And openmp state. */
2106 gfc_omp_restore_state (&old_omp_state);
2109 /* Make sure that translation for the gsymbol occurs before
2110 the procedure currently being resolved. */
2111 ns = gfc_global_ns_list;
2112 for (; ns && ns != gsym->ns; ns = ns->sibling)
2114 if (ns->sibling == gsym->ns)
2116 ns->sibling = gsym->ns->sibling;
2117 gsym->ns->sibling = gfc_global_ns_list;
2118 gfc_global_ns_list = gsym->ns;
2123 def_sym = gsym->ns->proc_name;
2124 if (def_sym->attr.entry_master)
2126 gfc_entry_list *entry;
2127 for (entry = gsym->ns->entries; entry; entry = entry->next)
2128 if (strcmp (entry->sym->name, sym->name) == 0)
2130 def_sym = entry->sym;
2135 /* Differences in constant character lengths. */
2136 if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2138 long int l1 = 0, l2 = 0;
2139 gfc_charlen *cl1 = sym->ts.u.cl;
2140 gfc_charlen *cl2 = def_sym->ts.u.cl;
2143 && cl1->length != NULL
2144 && cl1->length->expr_type == EXPR_CONSTANT)
2145 l1 = mpz_get_si (cl1->length->value.integer);
2148 && cl2->length != NULL
2149 && cl2->length->expr_type == EXPR_CONSTANT)
2150 l2 = mpz_get_si (cl2->length->value.integer);
2152 if (l1 && l2 && l1 != l2)
2153 gfc_error ("Character length mismatch in return type of "
2154 "function '%s' at %L (%ld/%ld)", sym->name,
2155 &sym->declared_at, l1, l2);
2158 /* Type mismatch of function return type and expected type. */
2159 if (sym->attr.function
2160 && !gfc_compare_types (&sym->ts, &def_sym->ts))
2161 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2162 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2163 gfc_typename (&def_sym->ts));
2165 if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2167 gfc_formal_arglist *arg = def_sym->formal;
2168 for ( ; arg; arg = arg->next)
2171 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2172 else if (arg->sym->attr.allocatable
2173 || arg->sym->attr.asynchronous
2174 || arg->sym->attr.optional
2175 || arg->sym->attr.pointer
2176 || arg->sym->attr.target
2177 || arg->sym->attr.value
2178 || arg->sym->attr.volatile_)
2180 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2181 "has an attribute that requires an explicit "
2182 "interface for this procedure", arg->sym->name,
2183 sym->name, &sym->declared_at);
2186 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2187 else if (arg->sym && arg->sym->as
2188 && arg->sym->as->type == AS_ASSUMED_SHAPE)
2190 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2191 "argument '%s' must have an explicit interface",
2192 sym->name, &sym->declared_at, arg->sym->name);
2195 /* F2008, 12.4.2.2 (2c) */
2196 else if (arg->sym->attr.codimension)
2198 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2199 "'%s' must have an explicit interface",
2200 sym->name, &sym->declared_at, arg->sym->name);
2203 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2204 else if (false) /* TODO: is a parametrized derived type */
2206 gfc_error ("Procedure '%s' at %L with parametrized derived "
2207 "type argument '%s' must have an explicit "
2208 "interface", sym->name, &sym->declared_at,
2212 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2213 else if (arg->sym->ts.type == BT_CLASS)
2215 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2216 "argument '%s' must have an explicit interface",
2217 sym->name, &sym->declared_at, arg->sym->name);
2222 if (def_sym->attr.function)
2224 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2225 if (def_sym->as && def_sym->as->rank
2226 && (!sym->as || sym->as->rank != def_sym->as->rank))
2227 gfc_error ("The reference to function '%s' at %L either needs an "
2228 "explicit INTERFACE or the rank is incorrect", sym->name,
2231 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2232 if ((def_sym->result->attr.pointer
2233 || def_sym->result->attr.allocatable)
2234 && (sym->attr.if_source != IFSRC_IFBODY
2235 || def_sym->result->attr.pointer
2236 != sym->result->attr.pointer
2237 || def_sym->result->attr.allocatable
2238 != sym->result->attr.allocatable))
2239 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2240 "result must have an explicit interface", sym->name,
2243 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2244 if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2245 && def_sym->ts.type == BT_CHARACTER && def_sym->ts.u.cl->length != NULL)
2247 gfc_charlen *cl = sym->ts.u.cl;
2249 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2250 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2252 gfc_error ("Nonconstant character-length function '%s' at %L "
2253 "must have an explicit interface", sym->name,
2259 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2260 if (def_sym->attr.elemental && !sym->attr.elemental)
2262 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2263 "interface", sym->name, &sym->declared_at);
2266 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2267 if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2269 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2270 "an explicit interface", sym->name, &sym->declared_at);
2273 if (gfc_option.flag_whole_file == 1
2274 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2275 && !(gfc_option.warn_std & GFC_STD_GNU)))
2276 gfc_errors_to_warnings (1);
2278 if (sym->attr.if_source != IFSRC_IFBODY)
2279 gfc_procedure_use (def_sym, actual, where);
2281 gfc_errors_to_warnings (0);
2284 if (gsym->type == GSYM_UNKNOWN)
2287 gsym->where = *where;
2294 /************* Function resolution *************/
2296 /* Resolve a function call known to be generic.
2297 Section 14.1.2.4.1. */
2300 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2304 if (sym->attr.generic)
2306 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2309 expr->value.function.name = s->name;
2310 expr->value.function.esym = s;
2312 if (s->ts.type != BT_UNKNOWN)
2314 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2315 expr->ts = s->result->ts;
2318 expr->rank = s->as->rank;
2319 else if (s->result != NULL && s->result->as != NULL)
2320 expr->rank = s->result->as->rank;
2322 gfc_set_sym_referenced (expr->value.function.esym);
2327 /* TODO: Need to search for elemental references in generic
2331 if (sym->attr.intrinsic)
2332 return gfc_intrinsic_func_interface (expr, 0);
2339 resolve_generic_f (gfc_expr *expr)
2343 gfc_interface *intr = NULL;
2345 sym = expr->symtree->n.sym;
2349 m = resolve_generic_f0 (expr, sym);
2352 else if (m == MATCH_ERROR)
2357 for (intr = sym->generic; intr; intr = intr->next)
2358 if (intr->sym->attr.flavor == FL_DERIVED)
2361 if (sym->ns->parent == NULL)
2363 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2367 if (!generic_sym (sym))
2371 /* Last ditch attempt. See if the reference is to an intrinsic
2372 that possesses a matching interface. 14.1.2.4 */
2373 if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
2375 gfc_error ("There is no specific function for the generic '%s' "
2376 "at %L", expr->symtree->n.sym->name, &expr->where);
2382 if (gfc_convert_to_structure_constructor (expr, intr->sym, NULL, NULL,
2385 return resolve_structure_cons (expr, 0);
2388 m = gfc_intrinsic_func_interface (expr, 0);
2393 gfc_error ("Generic function '%s' at %L is not consistent with a "
2394 "specific intrinsic interface", expr->symtree->n.sym->name,
2401 /* Resolve a function call known to be specific. */
2404 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2408 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2410 if (sym->attr.dummy)
2412 sym->attr.proc = PROC_DUMMY;
2416 sym->attr.proc = PROC_EXTERNAL;
2420 if (sym->attr.proc == PROC_MODULE
2421 || sym->attr.proc == PROC_ST_FUNCTION
2422 || sym->attr.proc == PROC_INTERNAL)
2425 if (sym->attr.intrinsic)
2427 m = gfc_intrinsic_func_interface (expr, 1);
2431 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2432 "with an intrinsic", sym->name, &expr->where);
2440 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2443 expr->ts = sym->result->ts;
2446 expr->value.function.name = sym->name;
2447 expr->value.function.esym = sym;
2448 if (sym->as != NULL)
2449 expr->rank = sym->as->rank;
2456 resolve_specific_f (gfc_expr *expr)
2461 sym = expr->symtree->n.sym;
2465 m = resolve_specific_f0 (sym, expr);
2468 if (m == MATCH_ERROR)
2471 if (sym->ns->parent == NULL)
2474 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2480 gfc_error ("Unable to resolve the specific function '%s' at %L",
2481 expr->symtree->n.sym->name, &expr->where);
2487 /* Resolve a procedure call not known to be generic nor specific. */
2490 resolve_unknown_f (gfc_expr *expr)
2495 sym = expr->symtree->n.sym;
2497 if (sym->attr.dummy)
2499 sym->attr.proc = PROC_DUMMY;
2500 expr->value.function.name = sym->name;
2504 /* See if we have an intrinsic function reference. */
2506 if (gfc_is_intrinsic (sym, 0, expr->where))
2508 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2513 /* The reference is to an external name. */
2515 sym->attr.proc = PROC_EXTERNAL;
2516 expr->value.function.name = sym->name;
2517 expr->value.function.esym = expr->symtree->n.sym;
2519 if (sym->as != NULL)
2520 expr->rank = sym->as->rank;
2522 /* Type of the expression is either the type of the symbol or the
2523 default type of the symbol. */
2526 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2528 if (sym->ts.type != BT_UNKNOWN)
2532 ts = gfc_get_default_type (sym->name, sym->ns);
2534 if (ts->type == BT_UNKNOWN)
2536 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2537 sym->name, &expr->where);
2548 /* Return true, if the symbol is an external procedure. */
2550 is_external_proc (gfc_symbol *sym)
2552 if (!sym->attr.dummy && !sym->attr.contained
2553 && !(sym->attr.intrinsic
2554 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2555 && sym->attr.proc != PROC_ST_FUNCTION
2556 && !sym->attr.proc_pointer
2557 && !sym->attr.use_assoc
2565 /* Figure out if a function reference is pure or not. Also set the name
2566 of the function for a potential error message. Return nonzero if the
2567 function is PURE, zero if not. */
2569 pure_stmt_function (gfc_expr *, gfc_symbol *);
2572 pure_function (gfc_expr *e, const char **name)
2578 if (e->symtree != NULL
2579 && e->symtree->n.sym != NULL
2580 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2581 return pure_stmt_function (e, e->symtree->n.sym);
2583 if (e->value.function.esym)
2585 pure = gfc_pure (e->value.function.esym);
2586 *name = e->value.function.esym->name;
2588 else if (e->value.function.isym)
2590 pure = e->value.function.isym->pure
2591 || e->value.function.isym->elemental;
2592 *name = e->value.function.isym->name;
2596 /* Implicit functions are not pure. */
2598 *name = e->value.function.name;
2606 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2607 int *f ATTRIBUTE_UNUSED)
2611 /* Don't bother recursing into other statement functions
2612 since they will be checked individually for purity. */
2613 if (e->expr_type != EXPR_FUNCTION
2615 || e->symtree->n.sym == sym
2616 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2619 return pure_function (e, &name) ? false : true;
2624 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2626 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2631 is_scalar_expr_ptr (gfc_expr *expr)
2633 gfc_try retval = SUCCESS;
2638 /* See if we have a gfc_ref, which means we have a substring, array
2639 reference, or a component. */
2640 if (expr->ref != NULL)
2643 while (ref->next != NULL)
2649 if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
2650 || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
2655 if (ref->u.ar.type == AR_ELEMENT)
2657 else if (ref->u.ar.type == AR_FULL)
2659 /* The user can give a full array if the array is of size 1. */
2660 if (ref->u.ar.as != NULL
2661 && ref->u.ar.as->rank == 1
2662 && ref->u.ar.as->type == AS_EXPLICIT
2663 && ref->u.ar.as->lower[0] != NULL
2664 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2665 && ref->u.ar.as->upper[0] != NULL
2666 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2668 /* If we have a character string, we need to check if
2669 its length is one. */
2670 if (expr->ts.type == BT_CHARACTER)
2672 if (expr->ts.u.cl == NULL
2673 || expr->ts.u.cl->length == NULL
2674 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2680 /* We have constant lower and upper bounds. If the
2681 difference between is 1, it can be considered a
2683 FIXME: Use gfc_dep_compare_expr instead. */
2684 start = (int) mpz_get_si
2685 (ref->u.ar.as->lower[0]->value.integer);
2686 end = (int) mpz_get_si
2687 (ref->u.ar.as->upper[0]->value.integer);
2688 if (end - start + 1 != 1)
2703 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2705 /* Character string. Make sure it's of length 1. */
2706 if (expr->ts.u.cl == NULL
2707 || expr->ts.u.cl->length == NULL
2708 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2711 else if (expr->rank != 0)
2718 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2719 and, in the case of c_associated, set the binding label based on
2723 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2724 gfc_symbol **new_sym)
2726 char name[GFC_MAX_SYMBOL_LEN + 1];
2727 int optional_arg = 0;
2728 gfc_try retval = SUCCESS;
2729 gfc_symbol *args_sym;
2730 gfc_typespec *arg_ts;
2731 symbol_attribute arg_attr;
2733 if (args->expr->expr_type == EXPR_CONSTANT
2734 || args->expr->expr_type == EXPR_OP
2735 || args->expr->expr_type == EXPR_NULL)
2737 gfc_error ("Argument to '%s' at %L is not a variable",
2738 sym->name, &(args->expr->where));
2742 args_sym = args->expr->symtree->n.sym;
2744 /* The typespec for the actual arg should be that stored in the expr
2745 and not necessarily that of the expr symbol (args_sym), because
2746 the actual expression could be a part-ref of the expr symbol. */
2747 arg_ts = &(args->expr->ts);
2748 arg_attr = gfc_expr_attr (args->expr);
2750 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2752 /* If the user gave two args then they are providing something for
2753 the optional arg (the second cptr). Therefore, set the name and
2754 binding label to the c_associated for two cptrs. Otherwise,
2755 set c_associated to expect one cptr. */
2759 sprintf (name, "%s_2", sym->name);
2765 sprintf (name, "%s_1", sym->name);
2769 /* Get a new symbol for the version of c_associated that
2771 *new_sym = get_iso_c_sym (sym, name, NULL, optional_arg);
2773 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2774 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2776 sprintf (name, "%s", sym->name);
2778 /* Error check the call. */
2779 if (args->next != NULL)
2781 gfc_error_now ("More actual than formal arguments in '%s' "
2782 "call at %L", name, &(args->expr->where));
2785 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2790 /* Make sure we have either the target or pointer attribute. */
2791 if (!arg_attr.target && !arg_attr.pointer)
2793 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2794 "a TARGET or an associated pointer",
2796 sym->name, &(args->expr->where));
2800 if (gfc_is_coindexed (args->expr))
2802 gfc_error_now ("Coindexed argument not permitted"
2803 " in '%s' call at %L", name,
2804 &(args->expr->where));
2808 /* Follow references to make sure there are no array
2810 seen_section = false;
2812 for (ref=args->expr->ref; ref; ref = ref->next)
2814 if (ref->type == REF_ARRAY)
2816 if (ref->u.ar.type == AR_SECTION)
2817 seen_section = true;
2819 if (ref->u.ar.type != AR_ELEMENT)
2822 for (r = ref->next; r; r=r->next)
2823 if (r->type == REF_COMPONENT)
2825 gfc_error_now ("Array section not permitted"
2826 " in '%s' call at %L", name,
2827 &(args->expr->where));
2835 if (seen_section && retval == SUCCESS)
2836 gfc_warning ("Array section in '%s' call at %L", name,
2837 &(args->expr->where));
2839 /* See if we have interoperable type and type param. */
2840 if (gfc_verify_c_interop (arg_ts) == SUCCESS
2841 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2843 if (args_sym->attr.target == 1)
2845 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2846 has the target attribute and is interoperable. */
2847 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2848 allocatable variable that has the TARGET attribute and
2849 is not an array of zero size. */
2850 if (args_sym->attr.allocatable == 1)
2852 if (args_sym->attr.dimension != 0
2853 && (args_sym->as && args_sym->as->rank == 0))
2855 gfc_error_now ("Allocatable variable '%s' used as a "
2856 "parameter to '%s' at %L must not be "
2857 "an array of zero size",
2858 args_sym->name, sym->name,
2859 &(args->expr->where));
2865 /* A non-allocatable target variable with C
2866 interoperable type and type parameters must be
2868 if (args_sym && args_sym->attr.dimension)
2870 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2872 gfc_error ("Assumed-shape array '%s' at %L "
2873 "cannot be an argument to the "
2874 "procedure '%s' because "
2875 "it is not C interoperable",
2877 &(args->expr->where), sym->name);
2880 else if (args_sym->as->type == AS_DEFERRED)
2882 gfc_error ("Deferred-shape array '%s' at %L "
2883 "cannot be an argument to the "
2884 "procedure '%s' because "
2885 "it is not C interoperable",
2887 &(args->expr->where), sym->name);
2892 /* Make sure it's not a character string. Arrays of
2893 any type should be ok if the variable is of a C
2894 interoperable type. */
2895 if (arg_ts->type == BT_CHARACTER)
2896 if (arg_ts->u.cl != NULL
2897 && (arg_ts->u.cl->length == NULL
2898 || arg_ts->u.cl->length->expr_type
2901 (arg_ts->u.cl->length->value.integer, 1)
2903 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2905 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2906 "at %L must have a length of 1",
2907 args_sym->name, sym->name,
2908 &(args->expr->where));
2913 else if (arg_attr.pointer
2914 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2916 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2918 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2919 "associated scalar POINTER", args_sym->name,
2920 sym->name, &(args->expr->where));
2926 /* The parameter is not required to be C interoperable. If it
2927 is not C interoperable, it must be a nonpolymorphic scalar
2928 with no length type parameters. It still must have either
2929 the pointer or target attribute, and it can be
2930 allocatable (but must be allocated when c_loc is called). */
2931 if (args->expr->rank != 0
2932 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2934 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2935 "scalar", args_sym->name, sym->name,
2936 &(args->expr->where));
2939 else if (arg_ts->type == BT_CHARACTER
2940 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2942 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2943 "%L must have a length of 1",
2944 args_sym->name, sym->name,
2945 &(args->expr->where));
2948 else if (arg_ts->type == BT_CLASS)
2950 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2951 "polymorphic", args_sym->name, sym->name,
2952 &(args->expr->where));
2957 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2959 if (args_sym->attr.flavor != FL_PROCEDURE)
2961 /* TODO: Update this error message to allow for procedure
2962 pointers once they are implemented. */
2963 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2965 args_sym->name, sym->name,
2966 &(args->expr->where));
2969 else if (args_sym->attr.is_bind_c != 1)
2971 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2973 args_sym->name, sym->name,
2974 &(args->expr->where));
2979 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2984 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2985 "iso_c_binding function: '%s'!\n", sym->name);
2992 /* Resolve a function call, which means resolving the arguments, then figuring
2993 out which entity the name refers to. */
2996 resolve_function (gfc_expr *expr)
2998 gfc_actual_arglist *arg;
3003 procedure_type p = PROC_INTRINSIC;
3004 bool no_formal_args;
3008 sym = expr->symtree->n.sym;
3010 /* If this is a procedure pointer component, it has already been resolved. */
3011 if (gfc_is_proc_ptr_comp (expr, NULL))
3014 if (sym && sym->attr.intrinsic
3015 && resolve_intrinsic (sym, &expr->where) == FAILURE)
3018 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
3020 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
3024 /* If this ia a deferred TBP with an abstract interface (which may
3025 of course be referenced), expr->value.function.esym will be set. */
3026 if (sym && sym->attr.abstract && !expr->value.function.esym)
3028 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3029 sym->name, &expr->where);
3033 /* Switch off assumed size checking and do this again for certain kinds
3034 of procedure, once the procedure itself is resolved. */
3035 need_full_assumed_size++;
3037 if (expr->symtree && expr->symtree->n.sym)
3038 p = expr->symtree->n.sym->attr.proc;
3040 if (expr->value.function.isym && expr->value.function.isym->inquiry)
3041 inquiry_argument = true;
3042 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
3044 if (resolve_actual_arglist (expr->value.function.actual,
3045 p, no_formal_args) == FAILURE)
3047 inquiry_argument = false;
3051 inquiry_argument = false;
3053 /* Need to setup the call to the correct c_associated, depending on
3054 the number of cptrs to user gives to compare. */
3055 if (sym && sym->attr.is_iso_c == 1)
3057 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
3061 /* Get the symtree for the new symbol (resolved func).
3062 the old one will be freed later, when it's no longer used. */
3063 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
3066 /* Resume assumed_size checking. */
3067 need_full_assumed_size--;
3069 /* If the procedure is external, check for usage. */
3070 if (sym && is_external_proc (sym))
3071 resolve_global_procedure (sym, &expr->where,
3072 &expr->value.function.actual, 0);
3074 if (sym && sym->ts.type == BT_CHARACTER
3076 && sym->ts.u.cl->length == NULL
3078 && !sym->ts.deferred
3079 && expr->value.function.esym == NULL
3080 && !sym->attr.contained)
3082 /* Internal procedures are taken care of in resolve_contained_fntype. */
3083 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
3084 "be used at %L since it is not a dummy argument",
3085 sym->name, &expr->where);
3089 /* See if function is already resolved. */
3091 if (expr->value.function.name != NULL)
3093 if (expr->ts.type == BT_UNKNOWN)
3099 /* Apply the rules of section 14.1.2. */
3101 switch (procedure_kind (sym))
3104 t = resolve_generic_f (expr);
3107 case PTYPE_SPECIFIC:
3108 t = resolve_specific_f (expr);
3112 t = resolve_unknown_f (expr);
3116 gfc_internal_error ("resolve_function(): bad function type");
3120 /* If the expression is still a function (it might have simplified),
3121 then we check to see if we are calling an elemental function. */
3123 if (expr->expr_type != EXPR_FUNCTION)
3126 temp = need_full_assumed_size;
3127 need_full_assumed_size = 0;
3129 if (resolve_elemental_actual (expr, NULL) == FAILURE)
3132 if (omp_workshare_flag
3133 && expr->value.function.esym
3134 && ! gfc_elemental (expr->value.function.esym))
3136 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3137 "in WORKSHARE construct", expr->value.function.esym->name,
3142 #define GENERIC_ID expr->value.function.isym->id
3143 else if (expr->value.function.actual != NULL
3144 && expr->value.function.isym != NULL
3145 && GENERIC_ID != GFC_ISYM_LBOUND
3146 && GENERIC_ID != GFC_ISYM_LEN
3147 && GENERIC_ID != GFC_ISYM_LOC
3148 && GENERIC_ID != GFC_ISYM_PRESENT)
3150 /* Array intrinsics must also have the last upper bound of an
3151 assumed size array argument. UBOUND and SIZE have to be
3152 excluded from the check if the second argument is anything
3155 for (arg = expr->value.function.actual; arg; arg = arg->next)
3157 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3158 && arg == expr->value.function.actual
3159 && arg->next != NULL && arg->next->expr)
3161 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3164 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3167 if ((int)mpz_get_si (arg->next->expr->value.integer)
3172 if (arg->expr != NULL
3173 && arg->expr->rank > 0
3174 && resolve_assumed_size_actual (arg->expr))
3180 need_full_assumed_size = temp;
3183 if (!pure_function (expr, &name) && name)
3187 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3188 "FORALL %s", name, &expr->where,
3189 forall_flag == 2 ? "mask" : "block");
3192 else if (do_concurrent_flag)
3194 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3195 "DO CONCURRENT %s", name, &expr->where,
3196 do_concurrent_flag == 2 ? "mask" : "block");
3199 else if (gfc_pure (NULL))
3201 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3202 "procedure within a PURE procedure", name, &expr->where);
3206 if (gfc_implicit_pure (NULL))
3207 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3210 /* Functions without the RECURSIVE attribution are not allowed to
3211 * call themselves. */
3212 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3215 esym = expr->value.function.esym;
3217 if (is_illegal_recursion (esym, gfc_current_ns))
3219 if (esym->attr.entry && esym->ns->entries)
3220 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3221 " function '%s' is not RECURSIVE",
3222 esym->name, &expr->where, esym->ns->entries->sym->name);
3224 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3225 " is not RECURSIVE", esym->name, &expr->where);
3231 /* Character lengths of use associated functions may contains references to
3232 symbols not referenced from the current program unit otherwise. Make sure
3233 those symbols are marked as referenced. */
3235 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3236 && expr->value.function.esym->attr.use_assoc)
3238 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3241 /* Make sure that the expression has a typespec that works. */
3242 if (expr->ts.type == BT_UNKNOWN)
3244 if (expr->symtree->n.sym->result
3245 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3246 && !expr->symtree->n.sym->result->attr.proc_pointer)
3247 expr->ts = expr->symtree->n.sym->result->ts;
3254 /************* Subroutine resolution *************/
3257 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3263 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3264 sym->name, &c->loc);
3265 else if (do_concurrent_flag)
3266 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3267 "PURE", sym->name, &c->loc);
3268 else if (gfc_pure (NULL))
3269 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3272 if (gfc_implicit_pure (NULL))
3273 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3278 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3282 if (sym->attr.generic)
3284 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3287 c->resolved_sym = s;
3288 pure_subroutine (c, s);
3292 /* TODO: Need to search for elemental references in generic interface. */
3295 if (sym->attr.intrinsic)
3296 return gfc_intrinsic_sub_interface (c, 0);
3303 resolve_generic_s (gfc_code *c)
3308 sym = c->symtree->n.sym;
3312 m = resolve_generic_s0 (c, sym);
3315 else if (m == MATCH_ERROR)
3319 if (sym->ns->parent == NULL)
3321 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3325 if (!generic_sym (sym))
3329 /* Last ditch attempt. See if the reference is to an intrinsic
3330 that possesses a matching interface. 14.1.2.4 */
3331 sym = c->symtree->n.sym;
3333 if (!gfc_is_intrinsic (sym, 1, c->loc))
3335 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3336 sym->name, &c->loc);
3340 m = gfc_intrinsic_sub_interface (c, 0);
3344 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3345 "intrinsic subroutine interface", sym->name, &c->loc);
3351 /* Set the name and binding label of the subroutine symbol in the call
3352 expression represented by 'c' to include the type and kind of the
3353 second parameter. This function is for resolving the appropriate
3354 version of c_f_pointer() and c_f_procpointer(). For example, a
3355 call to c_f_pointer() for a default integer pointer could have a
3356 name of c_f_pointer_i4. If no second arg exists, which is an error
3357 for these two functions, it defaults to the generic symbol's name
3358 and binding label. */
3361 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3362 char *name, const char **binding_label)
3364 gfc_expr *arg = NULL;
3368 /* The second arg of c_f_pointer and c_f_procpointer determines
3369 the type and kind for the procedure name. */
3370 arg = c->ext.actual->next->expr;
3374 /* Set up the name to have the given symbol's name,
3375 plus the type and kind. */
3376 /* a derived type is marked with the type letter 'u' */
3377 if (arg->ts.type == BT_DERIVED)
3380 kind = 0; /* set the kind as 0 for now */
3384 type = gfc_type_letter (arg->ts.type);
3385 kind = arg->ts.kind;
3388 if (arg->ts.type == BT_CHARACTER)
3389 /* Kind info for character strings not needed. */
3392 sprintf (name, "%s_%c%d", sym->name, type, kind);
3393 /* Set up the binding label as the given symbol's label plus
3394 the type and kind. */
3395 *binding_label = gfc_get_string ("%s_%c%d", sym->binding_label, type,
3400 /* If the second arg is missing, set the name and label as
3401 was, cause it should at least be found, and the missing
3402 arg error will be caught by compare_parameters(). */
3403 sprintf (name, "%s", sym->name);
3404 *binding_label = sym->binding_label;
3411 /* Resolve a generic version of the iso_c_binding procedure given
3412 (sym) to the specific one based on the type and kind of the
3413 argument(s). Currently, this function resolves c_f_pointer() and
3414 c_f_procpointer based on the type and kind of the second argument
3415 (FPTR). Other iso_c_binding procedures aren't specially handled.
3416 Upon successfully exiting, c->resolved_sym will hold the resolved
3417 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3421 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3423 gfc_symbol *new_sym;
3424 /* this is fine, since we know the names won't use the max */
3425 char name[GFC_MAX_SYMBOL_LEN + 1];
3426 const char* binding_label;
3427 /* default to success; will override if find error */
3428 match m = MATCH_YES;
3430 /* Make sure the actual arguments are in the necessary order (based on the
3431 formal args) before resolving. */
3432 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3434 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3435 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3437 set_name_and_label (c, sym, name, &binding_label);
3439 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3441 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3443 /* Make sure we got a third arg if the second arg has non-zero
3444 rank. We must also check that the type and rank are
3445 correct since we short-circuit this check in
3446 gfc_procedure_use() (called above to sort actual args). */
3447 if (c->ext.actual->next->expr->rank != 0)
3449 if(c->ext.actual->next->next == NULL
3450 || c->ext.actual->next->next->expr == NULL)
3453 gfc_error ("Missing SHAPE parameter for call to %s "
3454 "at %L", sym->name, &(c->loc));
3456 else if (c->ext.actual->next->next->expr->ts.type
3458 || c->ext.actual->next->next->expr->rank != 1)
3461 gfc_error ("SHAPE parameter for call to %s at %L must "
3462 "be a rank 1 INTEGER array", sym->name,
3469 if (m != MATCH_ERROR)
3471 /* the 1 means to add the optional arg to formal list */
3472 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3474 /* for error reporting, say it's declared where the original was */
3475 new_sym->declared_at = sym->declared_at;
3480 /* no differences for c_loc or c_funloc */
3484 /* set the resolved symbol */
3485 if (m != MATCH_ERROR)
3486 c->resolved_sym = new_sym;
3488 c->resolved_sym = sym;
3494 /* Resolve a subroutine call known to be specific. */
3497 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3501 if(sym->attr.is_iso_c)
3503 m = gfc_iso_c_sub_interface (c,sym);
3507 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3509 if (sym->attr.dummy)
3511 sym->attr.proc = PROC_DUMMY;
3515 sym->attr.proc = PROC_EXTERNAL;
3519 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3522 if (sym->attr.intrinsic)
3524 m = gfc_intrinsic_sub_interface (c, 1);
3528 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3529 "with an intrinsic", sym->name, &c->loc);
3537 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3539 c->resolved_sym = sym;
3540 pure_subroutine (c, sym);
3547 resolve_specific_s (gfc_code *c)
3552 sym = c->symtree->n.sym;
3556 m = resolve_specific_s0 (c, sym);
3559 if (m == MATCH_ERROR)
3562 if (sym->ns->parent == NULL)
3565 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3571 sym = c->symtree->n.sym;
3572 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3573 sym->name, &c->loc);
3579 /* Resolve a subroutine call not known to be generic nor specific. */
3582 resolve_unknown_s (gfc_code *c)
3586 sym = c->symtree->n.sym;
3588 if (sym->attr.dummy)
3590 sym->attr.proc = PROC_DUMMY;
3594 /* See if we have an intrinsic function reference. */
3596 if (gfc_is_intrinsic (sym, 1, c->loc))
3598 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3603 /* The reference is to an external name. */
3606 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3608 c->resolved_sym = sym;
3610 pure_subroutine (c, sym);
3616 /* Resolve a subroutine call. Although it was tempting to use the same code
3617 for functions, subroutines and functions are stored differently and this
3618 makes things awkward. */
3621 resolve_call (gfc_code *c)
3624 procedure_type ptype = PROC_INTRINSIC;
3625 gfc_symbol *csym, *sym;
3626 bool no_formal_args;
3628 csym = c->symtree ? c->symtree->n.sym : NULL;
3630 if (csym && csym->ts.type != BT_UNKNOWN)
3632 gfc_error ("'%s' at %L has a type, which is not consistent with "
3633 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3637 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3640 gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st);
3641 sym = st ? st->n.sym : NULL;
3642 if (sym && csym != sym
3643 && sym->ns == gfc_current_ns
3644 && sym->attr.flavor == FL_PROCEDURE
3645 && sym->attr.contained)
3648 if (csym->attr.generic)
3649 c->symtree->n.sym = sym;
3652 csym = c->symtree->n.sym;
3656 /* If this ia a deferred TBP with an abstract interface
3657 (which may of course be referenced), c->expr1 will be set. */
3658 if (csym && csym->attr.abstract && !c->expr1)
3660 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3661 csym->name, &c->loc);
3665 /* Subroutines without the RECURSIVE attribution are not allowed to
3666 * call themselves. */
3667 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3669 if (csym->attr.entry && csym->ns->entries)
3670 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3671 " subroutine '%s' is not RECURSIVE",
3672 csym->name, &c->loc, csym->ns->entries->sym->name);
3674 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3675 " is not RECURSIVE", csym->name, &c->loc);
3680 /* Switch off assumed size checking and do this again for certain kinds
3681 of procedure, once the procedure itself is resolved. */
3682 need_full_assumed_size++;
3685 ptype = csym->attr.proc;
3687 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3688 if (resolve_actual_arglist (c->ext.actual, ptype,
3689 no_formal_args) == FAILURE)
3692 /* Resume assumed_size checking. */
3693 need_full_assumed_size--;
3695 /* If external, check for usage. */
3696 if (csym && is_external_proc (csym))
3697 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3700 if (c->resolved_sym == NULL)
3702 c->resolved_isym = NULL;
3703 switch (procedure_kind (csym))
3706 t = resolve_generic_s (c);
3709 case PTYPE_SPECIFIC:
3710 t = resolve_specific_s (c);
3714 t = resolve_unknown_s (c);
3718 gfc_internal_error ("resolve_subroutine(): bad function type");
3722 /* Some checks of elemental subroutine actual arguments. */
3723 if (resolve_elemental_actual (NULL, c) == FAILURE)
3730 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3731 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3732 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3733 if their shapes do not match. If either op1->shape or op2->shape is
3734 NULL, return SUCCESS. */
3737 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3744 if (op1->shape != NULL && op2->shape != NULL)
3746 for (i = 0; i < op1->rank; i++)
3748 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3750 gfc_error ("Shapes for operands at %L and %L are not conformable",
3751 &op1->where, &op2->where);
3762 /* Resolve an operator expression node. This can involve replacing the
3763 operation with a user defined function call. */
3766 resolve_operator (gfc_expr *e)
3768 gfc_expr *op1, *op2;
3770 bool dual_locus_error;
3773 /* Resolve all subnodes-- give them types. */
3775 switch (e->value.op.op)
3778 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3781 /* Fall through... */
3784 case INTRINSIC_UPLUS:
3785 case INTRINSIC_UMINUS:
3786 case INTRINSIC_PARENTHESES:
3787 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3792 /* Typecheck the new node. */
3794 op1 = e->value.op.op1;
3795 op2 = e->value.op.op2;
3796 dual_locus_error = false;
3798 if ((op1 && op1->expr_type == EXPR_NULL)
3799 || (op2 && op2->expr_type == EXPR_NULL))
3801 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3805 switch (e->value.op.op)
3807 case INTRINSIC_UPLUS:
3808 case INTRINSIC_UMINUS:
3809 if (op1->ts.type == BT_INTEGER
3810 || op1->ts.type == BT_REAL
3811 || op1->ts.type == BT_COMPLEX)
3817 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3818 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3821 case INTRINSIC_PLUS:
3822 case INTRINSIC_MINUS:
3823 case INTRINSIC_TIMES:
3824 case INTRINSIC_DIVIDE:
3825 case INTRINSIC_POWER:
3826 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3828 gfc_type_convert_binary (e, 1);
3833 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3834 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3835 gfc_typename (&op2->ts));
3838 case INTRINSIC_CONCAT:
3839 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3840 && op1->ts.kind == op2->ts.kind)
3842 e->ts.type = BT_CHARACTER;
3843 e->ts.kind = op1->ts.kind;
3848 _("Operands of string concatenation operator at %%L are %s/%s"),
3849 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3855 case INTRINSIC_NEQV:
3856 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3858 e->ts.type = BT_LOGICAL;
3859 e->ts.kind = gfc_kind_max (op1, op2);
3860 if (op1->ts.kind < e->ts.kind)
3861 gfc_convert_type (op1, &e->ts, 2);
3862 else if (op2->ts.kind < e->ts.kind)
3863 gfc_convert_type (op2, &e->ts, 2);
3867 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3868 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3869 gfc_typename (&op2->ts));
3874 if (op1->ts.type == BT_LOGICAL)
3876 e->ts.type = BT_LOGICAL;
3877 e->ts.kind = op1->ts.kind;
3881 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3882 gfc_typename (&op1->ts));
3886 case INTRINSIC_GT_OS:
3888 case INTRINSIC_GE_OS:
3890 case INTRINSIC_LT_OS:
3892 case INTRINSIC_LE_OS:
3893 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3895 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3899 /* Fall through... */
3902 case INTRINSIC_EQ_OS:
3904 case INTRINSIC_NE_OS:
3905 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3906 && op1->ts.kind == op2->ts.kind)
3908 e->ts.type = BT_LOGICAL;
3909 e->ts.kind = gfc_default_logical_kind;
3913 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3915 gfc_type_convert_binary (e, 1);
3917 e->ts.type = BT_LOGICAL;
3918 e->ts.kind = gfc_default_logical_kind;
3922 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3924 _("Logicals at %%L must be compared with %s instead of %s"),
3925 (e->value.op.op == INTRINSIC_EQ
3926 || e->value.op.op == INTRINSIC_EQ_OS)
3927 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3930 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3931 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3932 gfc_typename (&op2->ts));
3936 case INTRINSIC_USER:
3937 if (e->value.op.uop->op == NULL)
3938 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3939 else if (op2 == NULL)
3940 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3941 e->value.op.uop->name, gfc_typename (&op1->ts));
3944 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3945 e->value.op.uop->name, gfc_typename (&op1->ts),
3946 gfc_typename (&op2->ts));
3947 e->value.op.uop->op->sym->attr.referenced = 1;
3952 case INTRINSIC_PARENTHESES:
3954 if (e->ts.type == BT_CHARACTER)
3955 e->ts.u.cl = op1->ts.u.cl;
3959 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3962 /* Deal with arrayness of an operand through an operator. */
3966 switch (e->value.op.op)
3968 case INTRINSIC_PLUS:
3969 case INTRINSIC_MINUS:
3970 case INTRINSIC_TIMES:
3971 case INTRINSIC_DIVIDE:
3972 case INTRINSIC_POWER:
3973 case INTRINSIC_CONCAT:
3977 case INTRINSIC_NEQV:
3979 case INTRINSIC_EQ_OS:
3981 case INTRINSIC_NE_OS:
3983 case INTRINSIC_GT_OS:
3985 case INTRINSIC_GE_OS:
3987 case INTRINSIC_LT_OS:
3989 case INTRINSIC_LE_OS:
3991 if (op1->rank == 0 && op2->rank == 0)
3994 if (op1->rank == 0 && op2->rank != 0)
3996 e->rank = op2->rank;
3998 if (e->shape == NULL)
3999 e->shape = gfc_copy_shape (op2->shape, op2->rank);
4002 if (op1->rank != 0 && op2->rank == 0)
4004 e->rank = op1->rank;
4006 if (e->shape == NULL)
4007 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4010 if (op1->rank != 0 && op2->rank != 0)
4012 if (op1->rank == op2->rank)
4014 e->rank = op1->rank;
4015 if (e->shape == NULL)
4017 t = compare_shapes (op1, op2);
4021 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4026 /* Allow higher level expressions to work. */
4029 /* Try user-defined operators, and otherwise throw an error. */
4030 dual_locus_error = true;
4032 _("Inconsistent ranks for operator at %%L and %%L"));
4039 case INTRINSIC_PARENTHESES:
4041 case INTRINSIC_UPLUS:
4042 case INTRINSIC_UMINUS:
4043 /* Simply copy arrayness attribute */
4044 e->rank = op1->rank;
4046 if (e->shape == NULL)
4047 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4055 /* Attempt to simplify the expression. */
4058 t = gfc_simplify_expr (e, 0);
4059 /* Some calls do not succeed in simplification and return FAILURE
4060 even though there is no error; e.g. variable references to
4061 PARAMETER arrays. */
4062 if (!gfc_is_constant_expr (e))
4070 match m = gfc_extend_expr (e);
4073 if (m == MATCH_ERROR)
4077 if (dual_locus_error)
4078 gfc_error (msg, &op1->where, &op2->where);
4080 gfc_error (msg, &e->where);
4086 /************** Array resolution subroutines **************/
4089 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
4092 /* Compare two integer expressions. */
4095 compare_bound (gfc_expr *a, gfc_expr *b)
4099 if (a == NULL || a->expr_type != EXPR_CONSTANT
4100 || b == NULL || b->expr_type != EXPR_CONSTANT)
4103 /* If either of the types isn't INTEGER, we must have
4104 raised an error earlier. */
4106 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
4109 i = mpz_cmp (a->value.integer, b->value.integer);
4119 /* Compare an integer expression with an integer. */
4122 compare_bound_int (gfc_expr *a, int b)
4126 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4129 if (a->ts.type != BT_INTEGER)
4130 gfc_internal_error ("compare_bound_int(): Bad expression");
4132 i = mpz_cmp_si (a->value.integer, b);
4142 /* Compare an integer expression with a mpz_t. */
4145 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4149 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4152 if (a->ts.type != BT_INTEGER)
4153 gfc_internal_error ("compare_bound_int(): Bad expression");
4155 i = mpz_cmp (a->value.integer, b);
4165 /* Compute the last value of a sequence given by a triplet.
4166 Return 0 if it wasn't able to compute the last value, or if the
4167 sequence if empty, and 1 otherwise. */
4170 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4171 gfc_expr *stride, mpz_t last)
4175 if (start == NULL || start->expr_type != EXPR_CONSTANT
4176 || end == NULL || end->expr_type != EXPR_CONSTANT
4177 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4180 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4181 || (stride != NULL && stride->ts.type != BT_INTEGER))
4184 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
4186 if (compare_bound (start, end) == CMP_GT)
4188 mpz_set (last, end->value.integer);
4192 if (compare_bound_int (stride, 0) == CMP_GT)
4194 /* Stride is positive */
4195 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4200 /* Stride is negative */
4201 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4206 mpz_sub (rem, end->value.integer, start->value.integer);
4207 mpz_tdiv_r (rem, rem, stride->value.integer);
4208 mpz_sub (last, end->value.integer, rem);
4215 /* Compare a single dimension of an array reference to the array
4219 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4223 if (ar->dimen_type[i] == DIMEN_STAR)
4225 gcc_assert (ar->stride[i] == NULL);
4226 /* This implies [*] as [*:] and [*:3] are not possible. */
4227 if (ar->start[i] == NULL)
4229 gcc_assert (ar->end[i] == NULL);
4234 /* Given start, end and stride values, calculate the minimum and
4235 maximum referenced indexes. */
4237 switch (ar->dimen_type[i])
4240 case DIMEN_THIS_IMAGE:
4245 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4248 gfc_warning ("Array reference at %L is out of bounds "
4249 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4250 mpz_get_si (ar->start[i]->value.integer),
4251 mpz_get_si (as->lower[i]->value.integer), i+1);
4253 gfc_warning ("Array reference at %L is out of bounds "
4254 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4255 mpz_get_si (ar->start[i]->value.integer),
4256 mpz_get_si (as->lower[i]->value.integer),
4260 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4263 gfc_warning ("Array reference at %L is out of bounds "
4264 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4265 mpz_get_si (ar->start[i]->value.integer),
4266 mpz_get_si (as->upper[i]->value.integer), i+1);
4268 gfc_warning ("Array reference at %L is out of bounds "
4269 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4270 mpz_get_si (ar->start[i]->value.integer),
4271 mpz_get_si (as->upper[i]->value.integer),
4280 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4281 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4283 comparison comp_start_end = compare_bound (AR_START, AR_END);
4285 /* Check for zero stride, which is not allowed. */
4286 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4288 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4292 /* if start == len || (stride > 0 && start < len)
4293 || (stride < 0 && start > len),
4294 then the array section contains at least one element. In this
4295 case, there is an out-of-bounds access if
4296 (start < lower || start > upper). */
4297 if (compare_bound (AR_START, AR_END) == CMP_EQ
4298 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4299 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4300 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4301 && comp_start_end == CMP_GT))
4303 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4305 gfc_warning ("Lower array reference at %L is out of bounds "
4306 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4307 mpz_get_si (AR_START->value.integer),
4308 mpz_get_si (as->lower[i]->value.integer), i+1);
4311 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4313 gfc_warning ("Lower array reference at %L is out of bounds "
4314 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4315 mpz_get_si (AR_START->value.integer),
4316 mpz_get_si (as->upper[i]->value.integer), i+1);
4321 /* If we can compute the highest index of the array section,
4322 then it also has to be between lower and upper. */
4323 mpz_init (last_value);
4324 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4327 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4329 gfc_warning ("Upper array reference at %L is out of bounds "
4330 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4331 mpz_get_si (last_value),
4332 mpz_get_si (as->lower[i]->value.integer), i+1);
4333 mpz_clear (last_value);
4336 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4338 gfc_warning ("Upper array reference at %L is out of bounds "
4339 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4340 mpz_get_si (last_value),
4341 mpz_get_si (as->upper[i]->value.integer), i+1);
4342 mpz_clear (last_value);
4346 mpz_clear (last_value);
4354 gfc_internal_error ("check_dimension(): Bad array reference");
4361 /* Compare an array reference with an array specification. */
4364 compare_spec_to_ref (gfc_array_ref *ar)
4371 /* TODO: Full array sections are only allowed as actual parameters. */
4372 if (as->type == AS_ASSUMED_SIZE
4373 && (/*ar->type == AR_FULL
4374 ||*/ (ar->type == AR_SECTION
4375 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4377 gfc_error ("Rightmost upper bound of assumed size array section "
4378 "not specified at %L", &ar->where);
4382 if (ar->type == AR_FULL)
4385 if (as->rank != ar->dimen)
4387 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4388 &ar->where, ar->dimen, as->rank);
4392 /* ar->codimen == 0 is a local array. */
4393 if (as->corank != ar->codimen && ar->codimen != 0)
4395 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4396 &ar->where, ar->codimen, as->corank);
4400 for (i = 0; i < as->rank; i++)
4401 if (check_dimension (i, ar, as) == FAILURE)
4404 /* Local access has no coarray spec. */
4405 if (ar->codimen != 0)
4406 for (i = as->rank; i < as->rank + as->corank; i++)
4408 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
4409 && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
4411 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4412 i + 1 - as->rank, &ar->where);
4415 if (check_dimension (i, ar, as) == FAILURE)
4423 /* Resolve one part of an array index. */
4426 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4427 int force_index_integer_kind)
4434 if (gfc_resolve_expr (index) == FAILURE)
4437 if (check_scalar && index->rank != 0)
4439 gfc_error ("Array index at %L must be scalar", &index->where);
4443 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4445 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4446 &index->where, gfc_basic_typename (index->ts.type));
4450 if (index->ts.type == BT_REAL)
4451 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
4452 &index->where) == FAILURE)
4455 if ((index->ts.kind != gfc_index_integer_kind
4456 && force_index_integer_kind)
4457 || index->ts.type != BT_INTEGER)
4460 ts.type = BT_INTEGER;
4461 ts.kind = gfc_index_integer_kind;
4463 gfc_convert_type_warn (index, &ts, 2, 0);
4469 /* Resolve one part of an array index. */
4472 gfc_resolve_index (gfc_expr *index, int check_scalar)
4474 return gfc_resolve_index_1 (index, check_scalar, 1);
4477 /* Resolve a dim argument to an intrinsic function. */
4480 gfc_resolve_dim_arg (gfc_expr *dim)
4485 if (gfc_resolve_expr (dim) == FAILURE)
4490 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4495 if (dim->ts.type != BT_INTEGER)
4497 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4501 if (dim->ts.kind != gfc_index_integer_kind)
4506 ts.type = BT_INTEGER;
4507 ts.kind = gfc_index_integer_kind;
4509 gfc_convert_type_warn (dim, &ts, 2, 0);
4515 /* Given an expression that contains array references, update those array
4516 references to point to the right array specifications. While this is
4517 filled in during matching, this information is difficult to save and load
4518 in a module, so we take care of it here.
4520 The idea here is that the original array reference comes from the
4521 base symbol. We traverse the list of reference structures, setting
4522 the stored reference to references. Component references can
4523 provide an additional array specification. */
4526 find_array_spec (gfc_expr *e)
4532 if (e->symtree->n.sym->ts.type == BT_CLASS)
4533 as = CLASS_DATA (e->symtree->n.sym)->as;
4535 as = e->symtree->n.sym->as;
4537 for (ref = e->ref; ref; ref = ref->next)
4542 gfc_internal_error ("find_array_spec(): Missing spec");
4549 c = ref->u.c.component;
4550 if (c->attr.dimension)
4553 gfc_internal_error ("find_array_spec(): unused as(1)");
4564 gfc_internal_error ("find_array_spec(): unused as(2)");
4568 /* Resolve an array reference. */
4571 resolve_array_ref (gfc_array_ref *ar)
4573 int i, check_scalar;
4576 for (i = 0; i < ar->dimen + ar->codimen; i++)
4578 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4580 /* Do not force gfc_index_integer_kind for the start. We can
4581 do fine with any integer kind. This avoids temporary arrays
4582 created for indexing with a vector. */
4583 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4585 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4587 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4592 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4596 ar->dimen_type[i] = DIMEN_ELEMENT;
4600 ar->dimen_type[i] = DIMEN_VECTOR;
4601 if (e->expr_type == EXPR_VARIABLE
4602 && e->symtree->n.sym->ts.type == BT_DERIVED)
4603 ar->start[i] = gfc_get_parentheses (e);
4607 gfc_error ("Array index at %L is an array of rank %d",
4608 &ar->c_where[i], e->rank);
4612 /* Fill in the upper bound, which may be lower than the
4613 specified one for something like a(2:10:5), which is
4614 identical to a(2:7:5). Only relevant for strides not equal
4615 to one. Don't try a division by zero. */
4616 if (ar->dimen_type[i] == DIMEN_RANGE
4617 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4618 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
4619 && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
4623 if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4625 if (ar->end[i] == NULL)
4628 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4630 mpz_set (ar->end[i]->value.integer, end);
4632 else if (ar->end[i]->ts.type == BT_INTEGER
4633 && ar->end[i]->expr_type == EXPR_CONSTANT)
4635 mpz_set (ar->end[i]->value.integer, end);
4646 if (ar->type == AR_FULL)
4648 if (ar->as->rank == 0)
4649 ar->type = AR_ELEMENT;
4651 /* Make sure array is the same as array(:,:), this way
4652 we don't need to special case all the time. */
4653 ar->dimen = ar->as->rank;
4654 for (i = 0; i < ar->dimen; i++)
4656 ar->dimen_type[i] = DIMEN_RANGE;
4658 gcc_assert (ar->start[i] == NULL);
4659 gcc_assert (ar->end[i] == NULL);
4660 gcc_assert (ar->stride[i] == NULL);
4664 /* If the reference type is unknown, figure out what kind it is. */
4666 if (ar->type == AR_UNKNOWN)
4668 ar->type = AR_ELEMENT;
4669 for (i = 0; i < ar->dimen; i++)
4670 if (ar->dimen_type[i] == DIMEN_RANGE
4671 || ar->dimen_type[i] == DIMEN_VECTOR)
4673 ar->type = AR_SECTION;
4678 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4681 if (ar->as->corank && ar->codimen == 0)
4684 ar->codimen = ar->as->corank;
4685 for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
4686 ar->dimen_type[n] = DIMEN_THIS_IMAGE;
4694 resolve_substring (gfc_ref *ref)
4696 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4698 if (ref->u.ss.start != NULL)
4700 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4703 if (ref->u.ss.start->ts.type != BT_INTEGER)
4705 gfc_error ("Substring start index at %L must be of type INTEGER",
4706 &ref->u.ss.start->where);
4710 if (ref->u.ss.start->rank != 0)
4712 gfc_error ("Substring start index at %L must be scalar",
4713 &ref->u.ss.start->where);
4717 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4718 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4719 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4721 gfc_error ("Substring start index at %L is less than one",
4722 &ref->u.ss.start->where);
4727 if (ref->u.ss.end != NULL)
4729 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4732 if (ref->u.ss.end->ts.type != BT_INTEGER)
4734 gfc_error ("Substring end index at %L must be of type INTEGER",
4735 &ref->u.ss.end->where);
4739 if (ref->u.ss.end->rank != 0)
4741 gfc_error ("Substring end index at %L must be scalar",
4742 &ref->u.ss.end->where);
4746 if (ref->u.ss.length != NULL
4747 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4748 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4749 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4751 gfc_error ("Substring end index at %L exceeds the string length",
4752 &ref->u.ss.start->where);
4756 if (compare_bound_mpz_t (ref->u.ss.end,
4757 gfc_integer_kinds[k].huge) == CMP_GT
4758 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4759 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4761 gfc_error ("Substring end index at %L is too large",
4762 &ref->u.ss.end->where);
4771 /* This function supplies missing substring charlens. */
4774 gfc_resolve_substring_charlen (gfc_expr *e)
4777 gfc_expr *start, *end;
4779 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4780 if (char_ref->type == REF_SUBSTRING)
4786 gcc_assert (char_ref->next == NULL);
4790 if (e->ts.u.cl->length)
4791 gfc_free_expr (e->ts.u.cl->length);
4792 else if (e->expr_type == EXPR_VARIABLE
4793 && e->symtree->n.sym->attr.dummy)
4797 e->ts.type = BT_CHARACTER;
4798 e->ts.kind = gfc_default_character_kind;
4801 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4803 if (char_ref->u.ss.start)
4804 start = gfc_copy_expr (char_ref->u.ss.start);
4806 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4808 if (char_ref->u.ss.end)
4809 end = gfc_copy_expr (char_ref->u.ss.end);
4810 else if (e->expr_type == EXPR_VARIABLE)
4811 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4818 /* Length = (end - start +1). */
4819 e->ts.u.cl->length = gfc_subtract (end, start);
4820 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4821 gfc_get_int_expr (gfc_default_integer_kind,
4824 e->ts.u.cl->length->ts.type = BT_INTEGER;
4825 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4827 /* Make sure that the length is simplified. */
4828 gfc_simplify_expr (e->ts.u.cl->length, 1);
4829 gfc_resolve_expr (e->ts.u.cl->length);
4833 /* Resolve subtype references. */
4836 resolve_ref (gfc_expr *expr)
4838 int current_part_dimension, n_components, seen_part_dimension;
4841 for (ref = expr->ref; ref; ref = ref->next)
4842 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4844 find_array_spec (expr);
4848 for (ref = expr->ref; ref; ref = ref->next)
4852 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4860 if (resolve_substring (ref) == FAILURE)
4865 /* Check constraints on part references. */
4867 current_part_dimension = 0;
4868 seen_part_dimension = 0;
4871 for (ref = expr->ref; ref; ref = ref->next)
4876 switch (ref->u.ar.type)
4879 /* Coarray scalar. */
4880 if (ref->u.ar.as->rank == 0)
4882 current_part_dimension = 0;
4887 current_part_dimension = 1;
4891 current_part_dimension = 0;
4895 gfc_internal_error ("resolve_ref(): Bad array reference");
4901 if (current_part_dimension || seen_part_dimension)
4904 if (ref->u.c.component->attr.pointer
4905 || ref->u.c.component->attr.proc_pointer)
4907 gfc_error ("Component to the right of a part reference "
4908 "with nonzero rank must not have the POINTER "
4909 "attribute at %L", &expr->where);
4912 else if (ref->u.c.component->attr.allocatable)
4914 gfc_error ("Component to the right of a part reference "
4915 "with nonzero rank must not have the ALLOCATABLE "
4916 "attribute at %L", &expr->where);
4928 if (((ref->type == REF_COMPONENT && n_components > 1)
4929 || ref->next == NULL)
4930 && current_part_dimension
4931 && seen_part_dimension)
4933 gfc_error ("Two or more part references with nonzero rank must "
4934 "not be specified at %L", &expr->where);
4938 if (ref->type == REF_COMPONENT)
4940 if (current_part_dimension)
4941 seen_part_dimension = 1;
4943 /* reset to make sure */
4944 current_part_dimension = 0;
4952 /* Given an expression, determine its shape. This is easier than it sounds.
4953 Leaves the shape array NULL if it is not possible to determine the shape. */
4956 expression_shape (gfc_expr *e)
4958 mpz_t array[GFC_MAX_DIMENSIONS];
4961 if (e->rank == 0 || e->shape != NULL)
4964 for (i = 0; i < e->rank; i++)
4965 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4968 e->shape = gfc_get_shape (e->rank);
4970 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4975 for (i--; i >= 0; i--)
4976 mpz_clear (array[i]);
4980 /* Given a variable expression node, compute the rank of the expression by
4981 examining the base symbol and any reference structures it may have. */
4984 expression_rank (gfc_expr *e)
4989 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4990 could lead to serious confusion... */
4991 gcc_assert (e->expr_type != EXPR_COMPCALL);
4995 if (e->expr_type == EXPR_ARRAY)
4997 /* Constructors can have a rank different from one via RESHAPE(). */
4999 if (e->symtree == NULL)
5005 e->rank = (e->symtree->n.sym->as == NULL)
5006 ? 0 : e->symtree->n.sym->as->rank;
5012 for (ref = e->ref; ref; ref = ref->next)
5014 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
5015 && ref->u.c.component->attr.function && !ref->next)
5016 rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
5018 if (ref->type != REF_ARRAY)
5021 if (ref->u.ar.type == AR_FULL)
5023 rank = ref->u.ar.as->rank;
5027 if (ref->u.ar.type == AR_SECTION)
5029 /* Figure out the rank of the section. */
5031 gfc_internal_error ("expression_rank(): Two array specs");
5033 for (i = 0; i < ref->u.ar.dimen; i++)
5034 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
5035 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
5045 expression_shape (e);
5049 /* Resolve a variable expression. */
5052 resolve_variable (gfc_expr *e)
5059 if (e->symtree == NULL)
5061 sym = e->symtree->n.sym;
5063 /* If this is an associate-name, it may be parsed with an array reference
5064 in error even though the target is scalar. Fail directly in this case. */
5065 if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
5068 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
5069 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
5071 /* On the other hand, the parser may not have known this is an array;
5072 in this case, we have to add a FULL reference. */
5073 if (sym->assoc && sym->attr.dimension && !e->ref)
5075 e->ref = gfc_get_ref ();
5076 e->ref->type = REF_ARRAY;
5077 e->ref->u.ar.type = AR_FULL;
5078 e->ref->u.ar.dimen = 0;
5081 if (e->ref && resolve_ref (e) == FAILURE)
5084 if (sym->attr.flavor == FL_PROCEDURE
5085 && (!sym->attr.function
5086 || (sym->attr.function && sym->result
5087 && sym->result->attr.proc_pointer
5088 && !sym->result->attr.function)))
5090 e->ts.type = BT_PROCEDURE;
5091 goto resolve_procedure;
5094 if (sym->ts.type != BT_UNKNOWN)
5095 gfc_variable_attr (e, &e->ts);
5098 /* Must be a simple variable reference. */
5099 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
5104 if (check_assumed_size_reference (sym, e))
5107 /* Deal with forward references to entries during resolve_code, to
5108 satisfy, at least partially, 12.5.2.5. */
5109 if (gfc_current_ns->entries
5110 && current_entry_id == sym->entry_id
5113 && cs_base->current->op != EXEC_ENTRY)
5115 gfc_entry_list *entry;
5116 gfc_formal_arglist *formal;
5120 /* If the symbol is a dummy... */
5121 if (sym->attr.dummy && sym->ns == gfc_current_ns)
5123 entry = gfc_current_ns->entries;
5126 /* ...test if the symbol is a parameter of previous entries. */
5127 for (; entry && entry->id <= current_entry_id; entry = entry->next)
5128 for (formal = entry->sym->formal; formal; formal = formal->next)
5130 if (formal->sym && sym->name == formal->sym->name)
5134 /* If it has not been seen as a dummy, this is an error. */
5137 if (specification_expr)
5138 gfc_error ("Variable '%s', used in a specification expression"
5139 ", is referenced at %L before the ENTRY statement "
5140 "in which it is a parameter",
5141 sym->name, &cs_base->current->loc);
5143 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5144 "statement in which it is a parameter",
5145 sym->name, &cs_base->current->loc);
5150 /* Now do the same check on the specification expressions. */
5151 specification_expr = 1;
5152 if (sym->ts.type == BT_CHARACTER
5153 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
5157 for (n = 0; n < sym->as->rank; n++)
5159 specification_expr = 1;
5160 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
5162 specification_expr = 1;
5163 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
5166 specification_expr = 0;
5169 /* Update the symbol's entry level. */
5170 sym->entry_id = current_entry_id + 1;
5173 /* If a symbol has been host_associated mark it. This is used latter,
5174 to identify if aliasing is possible via host association. */
5175 if (sym->attr.flavor == FL_VARIABLE
5176 && gfc_current_ns->parent
5177 && (gfc_current_ns->parent == sym->ns
5178 || (gfc_current_ns->parent->parent
5179 && gfc_current_ns->parent->parent == sym->ns)))
5180 sym->attr.host_assoc = 1;
5183 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
5186 /* F2008, C617 and C1229. */
5187 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5188 && gfc_is_coindexed (e))
5190 gfc_ref *ref, *ref2 = NULL;
5192 for (ref = e->ref; ref; ref = ref->next)
5194 if (ref->type == REF_COMPONENT)
5196 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5200 for ( ; ref; ref = ref->next)
5201 if (ref->type == REF_COMPONENT)
5204 /* Expression itself is not coindexed object. */
5205 if (ref && e->ts.type == BT_CLASS)
5207 gfc_error ("Polymorphic subobject of coindexed object at %L",
5212 /* Expression itself is coindexed object. */
5216 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5217 for ( ; c; c = c->next)
5218 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5220 gfc_error ("Coindexed object with polymorphic allocatable "
5221 "subcomponent at %L", &e->where);
5232 /* Checks to see that the correct symbol has been host associated.
5233 The only situation where this arises is that in which a twice
5234 contained function is parsed after the host association is made.
5235 Therefore, on detecting this, change the symbol in the expression
5236 and convert the array reference into an actual arglist if the old
5237 symbol is a variable. */
5239 check_host_association (gfc_expr *e)
5241 gfc_symbol *sym, *old_sym;
5245 gfc_actual_arglist *arg, *tail = NULL;
5246 bool retval = e->expr_type == EXPR_FUNCTION;
5248 /* If the expression is the result of substitution in
5249 interface.c(gfc_extend_expr) because there is no way in
5250 which the host association can be wrong. */
5251 if (e->symtree == NULL
5252 || e->symtree->n.sym == NULL
5253 || e->user_operator)
5256 old_sym = e->symtree->n.sym;
5258 if (gfc_current_ns->parent
5259 && old_sym->ns != gfc_current_ns)
5261 /* Use the 'USE' name so that renamed module symbols are
5262 correctly handled. */
5263 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5265 if (sym && old_sym != sym
5266 && sym->ts.type == old_sym->ts.type
5267 && sym->attr.flavor == FL_PROCEDURE
5268 && sym->attr.contained)
5270 /* Clear the shape, since it might not be valid. */
5271 gfc_free_shape (&e->shape, e->rank);
5273 /* Give the expression the right symtree! */
5274 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5275 gcc_assert (st != NULL);
5277 if (old_sym->attr.flavor == FL_PROCEDURE
5278 || e->expr_type == EXPR_FUNCTION)
5280 /* Original was function so point to the new symbol, since
5281 the actual argument list is already attached to the
5283 e->value.function.esym = NULL;
5288 /* Original was variable so convert array references into
5289 an actual arglist. This does not need any checking now
5290 since resolve_function will take care of it. */
5291 e->value.function.actual = NULL;
5292 e->expr_type = EXPR_FUNCTION;
5295 /* Ambiguity will not arise if the array reference is not
5296 the last reference. */
5297 for (ref = e->ref; ref; ref = ref->next)
5298 if (ref->type == REF_ARRAY && ref->next == NULL)
5301 gcc_assert (ref->type == REF_ARRAY);
5303 /* Grab the start expressions from the array ref and
5304 copy them into actual arguments. */
5305 for (n = 0; n < ref->u.ar.dimen; n++)
5307 arg = gfc_get_actual_arglist ();
5308 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5309 if (e->value.function.actual == NULL)
5310 tail = e->value.function.actual = arg;
5318 /* Dump the reference list and set the rank. */
5319 gfc_free_ref_list (e->ref);
5321 e->rank = sym->as ? sym->as->rank : 0;
5324 gfc_resolve_expr (e);
5328 /* This might have changed! */
5329 return e->expr_type == EXPR_FUNCTION;
5334 gfc_resolve_character_operator (gfc_expr *e)
5336 gfc_expr *op1 = e->value.op.op1;
5337 gfc_expr *op2 = e->value.op.op2;
5338 gfc_expr *e1 = NULL;
5339 gfc_expr *e2 = NULL;
5341 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5343 if (op1->ts.u.cl && op1->ts.u.cl->length)
5344 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5345 else if (op1->expr_type == EXPR_CONSTANT)
5346 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5347 op1->value.character.length);
5349 if (op2->ts.u.cl && op2->ts.u.cl->length)
5350 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5351 else if (op2->expr_type == EXPR_CONSTANT)
5352 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5353 op2->value.character.length);
5355 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5360 e->ts.u.cl->length = gfc_add (e1, e2);
5361 e->ts.u.cl->length->ts.type = BT_INTEGER;
5362 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5363 gfc_simplify_expr (e->ts.u.cl->length, 0);
5364 gfc_resolve_expr (e->ts.u.cl->length);
5370 /* Ensure that an character expression has a charlen and, if possible, a
5371 length expression. */
5374 fixup_charlen (gfc_expr *e)
5376 /* The cases fall through so that changes in expression type and the need
5377 for multiple fixes are picked up. In all circumstances, a charlen should
5378 be available for the middle end to hang a backend_decl on. */
5379 switch (e->expr_type)
5382 gfc_resolve_character_operator (e);
5385 if (e->expr_type == EXPR_ARRAY)
5386 gfc_resolve_character_array_constructor (e);
5388 case EXPR_SUBSTRING:
5389 if (!e->ts.u.cl && e->ref)
5390 gfc_resolve_substring_charlen (e);
5394 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5401 /* Update an actual argument to include the passed-object for type-bound
5402 procedures at the right position. */
5404 static gfc_actual_arglist*
5405 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5408 gcc_assert (argpos > 0);
5412 gfc_actual_arglist* result;
5414 result = gfc_get_actual_arglist ();
5418 result->name = name;
5424 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5426 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5431 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5434 extract_compcall_passed_object (gfc_expr* e)
5438 gcc_assert (e->expr_type == EXPR_COMPCALL);
5440 if (e->value.compcall.base_object)
5441 po = gfc_copy_expr (e->value.compcall.base_object);
5444 po = gfc_get_expr ();
5445 po->expr_type = EXPR_VARIABLE;
5446 po->symtree = e->symtree;
5447 po->ref = gfc_copy_ref (e->ref);
5448 po->where = e->where;
5451 if (gfc_resolve_expr (po) == FAILURE)
5458 /* Update the arglist of an EXPR_COMPCALL expression to include the
5462 update_compcall_arglist (gfc_expr* e)
5465 gfc_typebound_proc* tbp;
5467 tbp = e->value.compcall.tbp;
5472 po = extract_compcall_passed_object (e);
5476 if (tbp->nopass || e->value.compcall.ignore_pass)
5482 gcc_assert (tbp->pass_arg_num > 0);
5483 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5491 /* Extract the passed object from a PPC call (a copy of it). */
5494 extract_ppc_passed_object (gfc_expr *e)
5499 po = gfc_get_expr ();
5500 po->expr_type = EXPR_VARIABLE;
5501 po->symtree = e->symtree;
5502 po->ref = gfc_copy_ref (e->ref);
5503 po->where = e->where;
5505 /* Remove PPC reference. */
5507 while ((*ref)->next)
5508 ref = &(*ref)->next;
5509 gfc_free_ref_list (*ref);
5512 if (gfc_resolve_expr (po) == FAILURE)
5519 /* Update the actual arglist of a procedure pointer component to include the
5523 update_ppc_arglist (gfc_expr* e)
5527 gfc_typebound_proc* tb;
5529 if (!gfc_is_proc_ptr_comp (e, &ppc))
5536 else if (tb->nopass)
5539 po = extract_ppc_passed_object (e);
5546 gfc_error ("Passed-object at %L must be scalar", &e->where);
5551 if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
5553 gfc_error ("Base object for procedure-pointer component call at %L is of"
5554 " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name);
5558 gcc_assert (tb->pass_arg_num > 0);
5559 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5567 /* Check that the object a TBP is called on is valid, i.e. it must not be
5568 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5571 check_typebound_baseobject (gfc_expr* e)
5574 gfc_try return_value = FAILURE;
5576 base = extract_compcall_passed_object (e);
5580 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5583 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5585 gfc_error ("Base object for type-bound procedure call at %L is of"
5586 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5590 /* F08:C1230. If the procedure called is NOPASS,
5591 the base object must be scalar. */
5592 if (e->value.compcall.tbp->nopass && base->rank > 0)
5594 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5595 " be scalar", &e->where);
5599 return_value = SUCCESS;
5602 gfc_free_expr (base);
5603 return return_value;
5607 /* Resolve a call to a type-bound procedure, either function or subroutine,
5608 statically from the data in an EXPR_COMPCALL expression. The adapted
5609 arglist and the target-procedure symtree are returned. */
5612 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5613 gfc_actual_arglist** actual)
5615 gcc_assert (e->expr_type == EXPR_COMPCALL);
5616 gcc_assert (!e->value.compcall.tbp->is_generic);
5618 /* Update the actual arglist for PASS. */
5619 if (update_compcall_arglist (e) == FAILURE)
5622 *actual = e->value.compcall.actual;
5623 *target = e->value.compcall.tbp->u.specific;
5625 gfc_free_ref_list (e->ref);
5627 e->value.compcall.actual = NULL;
5629 /* If we find a deferred typebound procedure, check for derived types
5630 that an overriding typebound procedure has not been missed. */
5631 if (e->value.compcall.name
5632 && !e->value.compcall.tbp->non_overridable
5633 && e->value.compcall.base_object
5634 && e->value.compcall.base_object->ts.type == BT_DERIVED)
5637 gfc_symbol *derived;
5639 /* Use the derived type of the base_object. */
5640 derived = e->value.compcall.base_object->ts.u.derived;
5643 /* If necessary, go throught the inheritance chain. */
5644 while (!st && derived)
5646 /* Look for the typebound procedure 'name'. */
5647 if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
5648 st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
5649 e->value.compcall.name);
5651 derived = gfc_get_derived_super_type (derived);
5654 /* Now find the specific name in the derived type namespace. */
5655 if (st && st->n.tb && st->n.tb->u.specific)
5656 gfc_find_sym_tree (st->n.tb->u.specific->name,
5657 derived->ns, 1, &st);
5665 /* Get the ultimate declared type from an expression. In addition,
5666 return the last class/derived type reference and the copy of the
5667 reference list. If check_types is set true, derived types are
5668 identified as well as class references. */
5670 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5671 gfc_expr *e, bool check_types)
5673 gfc_symbol *declared;
5680 *new_ref = gfc_copy_ref (e->ref);
5682 for (ref = e->ref; ref; ref = ref->next)
5684 if (ref->type != REF_COMPONENT)
5687 if ((ref->u.c.component->ts.type == BT_CLASS
5688 || (check_types && ref->u.c.component->ts.type == BT_DERIVED))
5689 && ref->u.c.component->attr.flavor != FL_PROCEDURE)
5691 declared = ref->u.c.component->ts.u.derived;
5697 if (declared == NULL)
5698 declared = e->symtree->n.sym->ts.u.derived;
5704 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5705 which of the specific bindings (if any) matches the arglist and transform
5706 the expression into a call of that binding. */
5709 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5711 gfc_typebound_proc* genproc;
5712 const char* genname;
5714 gfc_symbol *derived;
5716 gcc_assert (e->expr_type == EXPR_COMPCALL);
5717 genname = e->value.compcall.name;
5718 genproc = e->value.compcall.tbp;
5720 if (!genproc->is_generic)
5723 /* Try the bindings on this type and in the inheritance hierarchy. */
5724 for (; genproc; genproc = genproc->overridden)
5728 gcc_assert (genproc->is_generic);
5729 for (g = genproc->u.generic; g; g = g->next)
5732 gfc_actual_arglist* args;
5735 gcc_assert (g->specific);
5737 if (g->specific->error)
5740 target = g->specific->u.specific->n.sym;
5742 /* Get the right arglist by handling PASS/NOPASS. */
5743 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5744 if (!g->specific->nopass)
5747 po = extract_compcall_passed_object (e);
5751 gcc_assert (g->specific->pass_arg_num > 0);
5752 gcc_assert (!g->specific->error);
5753 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5754 g->specific->pass_arg);
5756 resolve_actual_arglist (args, target->attr.proc,
5757 is_external_proc (target) && !target->formal);
5759 /* Check if this arglist matches the formal. */
5760 matches = gfc_arglist_matches_symbol (&args, target);
5762 /* Clean up and break out of the loop if we've found it. */
5763 gfc_free_actual_arglist (args);
5766 e->value.compcall.tbp = g->specific;
5767 genname = g->specific_st->name;
5768 /* Pass along the name for CLASS methods, where the vtab
5769 procedure pointer component has to be referenced. */
5777 /* Nothing matching found! */
5778 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5779 " '%s' at %L", genname, &e->where);
5783 /* Make sure that we have the right specific instance for the name. */
5784 derived = get_declared_from_expr (NULL, NULL, e, true);
5786 st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
5788 e->value.compcall.tbp = st->n.tb;
5794 /* Resolve a call to a type-bound subroutine. */
5797 resolve_typebound_call (gfc_code* c, const char **name)
5799 gfc_actual_arglist* newactual;
5800 gfc_symtree* target;
5802 /* Check that's really a SUBROUTINE. */
5803 if (!c->expr1->value.compcall.tbp->subroutine)
5805 gfc_error ("'%s' at %L should be a SUBROUTINE",
5806 c->expr1->value.compcall.name, &c->loc);
5810 if (check_typebound_baseobject (c->expr1) == FAILURE)
5813 /* Pass along the name for CLASS methods, where the vtab
5814 procedure pointer component has to be referenced. */
5816 *name = c->expr1->value.compcall.name;
5818 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5821 /* Transform into an ordinary EXEC_CALL for now. */
5823 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5826 c->ext.actual = newactual;
5827 c->symtree = target;
5828 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5830 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5832 gfc_free_expr (c->expr1);
5833 c->expr1 = gfc_get_expr ();
5834 c->expr1->expr_type = EXPR_FUNCTION;
5835 c->expr1->symtree = target;
5836 c->expr1->where = c->loc;
5838 return resolve_call (c);
5842 /* Resolve a component-call expression. */
5844 resolve_compcall (gfc_expr* e, const char **name)
5846 gfc_actual_arglist* newactual;
5847 gfc_symtree* target;
5849 /* Check that's really a FUNCTION. */
5850 if (!e->value.compcall.tbp->function)
5852 gfc_error ("'%s' at %L should be a FUNCTION",
5853 e->value.compcall.name, &e->where);
5857 /* These must not be assign-calls! */
5858 gcc_assert (!e->value.compcall.assign);
5860 if (check_typebound_baseobject (e) == FAILURE)
5863 /* Pass along the name for CLASS methods, where the vtab
5864 procedure pointer component has to be referenced. */
5866 *name = e->value.compcall.name;
5868 if (resolve_typebound_generic_call (e, name) == FAILURE)
5870 gcc_assert (!e->value.compcall.tbp->is_generic);
5872 /* Take the rank from the function's symbol. */
5873 if (e->value.compcall.tbp->u.specific->n.sym->as)
5874 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5876 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5877 arglist to the TBP's binding target. */
5879 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5882 e->value.function.actual = newactual;
5883 e->value.function.name = NULL;
5884 e->value.function.esym = target->n.sym;
5885 e->value.function.isym = NULL;
5886 e->symtree = target;
5887 e->ts = target->n.sym->ts;
5888 e->expr_type = EXPR_FUNCTION;
5890 /* Resolution is not necessary if this is a class subroutine; this
5891 function only has to identify the specific proc. Resolution of
5892 the call will be done next in resolve_typebound_call. */
5893 return gfc_resolve_expr (e);
5898 /* Resolve a typebound function, or 'method'. First separate all
5899 the non-CLASS references by calling resolve_compcall directly. */
5902 resolve_typebound_function (gfc_expr* e)
5904 gfc_symbol *declared;
5916 /* Deal with typebound operators for CLASS objects. */
5917 expr = e->value.compcall.base_object;
5918 overridable = !e->value.compcall.tbp->non_overridable;
5919 if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
5921 /* If the base_object is not a variable, the corresponding actual
5922 argument expression must be stored in e->base_expression so
5923 that the corresponding tree temporary can be used as the base
5924 object in gfc_conv_procedure_call. */
5925 if (expr->expr_type != EXPR_VARIABLE)
5927 gfc_actual_arglist *args;
5929 for (args= e->value.function.actual; args; args = args->next)
5931 if (expr == args->expr)
5936 /* Since the typebound operators are generic, we have to ensure
5937 that any delays in resolution are corrected and that the vtab
5940 declared = ts.u.derived;
5941 c = gfc_find_component (declared, "_vptr", true, true);
5942 if (c->ts.u.derived == NULL)
5943 c->ts.u.derived = gfc_find_derived_vtab (declared);
5945 if (resolve_compcall (e, &name) == FAILURE)
5948 /* Use the generic name if it is there. */
5949 name = name ? name : e->value.function.esym->name;
5950 e->symtree = expr->symtree;
5951 e->ref = gfc_copy_ref (expr->ref);
5952 get_declared_from_expr (&class_ref, NULL, e, false);
5954 /* Trim away the extraneous references that emerge from nested
5955 use of interface.c (extend_expr). */
5956 if (class_ref && class_ref->next)
5958 gfc_free_ref_list (class_ref->next);
5959 class_ref->next = NULL;
5961 else if (e->ref && !class_ref)
5963 gfc_free_ref_list (e->ref);
5967 gfc_add_vptr_component (e);
5968 gfc_add_component_ref (e, name);
5969 e->value.function.esym = NULL;
5970 if (expr->expr_type != EXPR_VARIABLE)
5971 e->base_expr = expr;
5976 return resolve_compcall (e, NULL);
5978 if (resolve_ref (e) == FAILURE)
5981 /* Get the CLASS declared type. */
5982 declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
5984 /* Weed out cases of the ultimate component being a derived type. */
5985 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5986 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5988 gfc_free_ref_list (new_ref);
5989 return resolve_compcall (e, NULL);
5992 c = gfc_find_component (declared, "_data", true, true);
5993 declared = c->ts.u.derived;
5995 /* Treat the call as if it is a typebound procedure, in order to roll
5996 out the correct name for the specific function. */
5997 if (resolve_compcall (e, &name) == FAILURE)
6003 /* Convert the expression to a procedure pointer component call. */
6004 e->value.function.esym = NULL;
6010 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6011 gfc_add_vptr_component (e);
6012 gfc_add_component_ref (e, name);
6014 /* Recover the typespec for the expression. This is really only
6015 necessary for generic procedures, where the additional call
6016 to gfc_add_component_ref seems to throw the collection of the
6017 correct typespec. */
6024 /* Resolve a typebound subroutine, or 'method'. First separate all
6025 the non-CLASS references by calling resolve_typebound_call
6029 resolve_typebound_subroutine (gfc_code *code)
6031 gfc_symbol *declared;
6041 st = code->expr1->symtree;
6043 /* Deal with typebound operators for CLASS objects. */
6044 expr = code->expr1->value.compcall.base_object;
6045 overridable = !code->expr1->value.compcall.tbp->non_overridable;
6046 if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
6048 /* If the base_object is not a variable, the corresponding actual
6049 argument expression must be stored in e->base_expression so
6050 that the corresponding tree temporary can be used as the base
6051 object in gfc_conv_procedure_call. */
6052 if (expr->expr_type != EXPR_VARIABLE)
6054 gfc_actual_arglist *args;
6056 args= code->expr1->value.function.actual;
6057 for (; args; args = args->next)
6058 if (expr == args->expr)
6062 /* Since the typebound operators are generic, we have to ensure
6063 that any delays in resolution are corrected and that the vtab
6065 declared = expr->ts.u.derived;
6066 c = gfc_find_component (declared, "_vptr", true, true);
6067 if (c->ts.u.derived == NULL)
6068 c->ts.u.derived = gfc_find_derived_vtab (declared);
6070 if (resolve_typebound_call (code, &name) == FAILURE)
6073 /* Use the generic name if it is there. */
6074 name = name ? name : code->expr1->value.function.esym->name;
6075 code->expr1->symtree = expr->symtree;
6076 code->expr1->ref = gfc_copy_ref (expr->ref);
6078 /* Trim away the extraneous references that emerge from nested
6079 use of interface.c (extend_expr). */
6080 get_declared_from_expr (&class_ref, NULL, code->expr1, false);
6081 if (class_ref && class_ref->next)
6083 gfc_free_ref_list (class_ref->next);
6084 class_ref->next = NULL;
6086 else if (code->expr1->ref && !class_ref)
6088 gfc_free_ref_list (code->expr1->ref);
6089 code->expr1->ref = NULL;
6092 /* Now use the procedure in the vtable. */
6093 gfc_add_vptr_component (code->expr1);
6094 gfc_add_component_ref (code->expr1, name);
6095 code->expr1->value.function.esym = NULL;
6096 if (expr->expr_type != EXPR_VARIABLE)
6097 code->expr1->base_expr = expr;
6102 return resolve_typebound_call (code, NULL);
6104 if (resolve_ref (code->expr1) == FAILURE)
6107 /* Get the CLASS declared type. */
6108 get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
6110 /* Weed out cases of the ultimate component being a derived type. */
6111 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
6112 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
6114 gfc_free_ref_list (new_ref);
6115 return resolve_typebound_call (code, NULL);
6118 if (resolve_typebound_call (code, &name) == FAILURE)
6120 ts = code->expr1->ts;
6124 /* Convert the expression to a procedure pointer component call. */
6125 code->expr1->value.function.esym = NULL;
6126 code->expr1->symtree = st;
6129 code->expr1->ref = new_ref;
6131 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6132 gfc_add_vptr_component (code->expr1);
6133 gfc_add_component_ref (code->expr1, name);
6135 /* Recover the typespec for the expression. This is really only
6136 necessary for generic procedures, where the additional call
6137 to gfc_add_component_ref seems to throw the collection of the
6138 correct typespec. */
6139 code->expr1->ts = ts;
6146 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6149 resolve_ppc_call (gfc_code* c)
6151 gfc_component *comp;
6154 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
6157 c->resolved_sym = c->expr1->symtree->n.sym;
6158 c->expr1->expr_type = EXPR_VARIABLE;
6160 if (!comp->attr.subroutine)
6161 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
6163 if (resolve_ref (c->expr1) == FAILURE)
6166 if (update_ppc_arglist (c->expr1) == FAILURE)
6169 c->ext.actual = c->expr1->value.compcall.actual;
6171 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
6172 comp->formal == NULL) == FAILURE)
6175 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
6181 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6184 resolve_expr_ppc (gfc_expr* e)
6186 gfc_component *comp;
6189 b = gfc_is_proc_ptr_comp (e, &comp);
6192 /* Convert to EXPR_FUNCTION. */
6193 e->expr_type = EXPR_FUNCTION;
6194 e->value.function.isym = NULL;
6195 e->value.function.actual = e->value.compcall.actual;
6197 if (comp->as != NULL)
6198 e->rank = comp->as->rank;
6200 if (!comp->attr.function)
6201 gfc_add_function (&comp->attr, comp->name, &e->where);
6203 if (resolve_ref (e) == FAILURE)
6206 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
6207 comp->formal == NULL) == FAILURE)
6210 if (update_ppc_arglist (e) == FAILURE)
6213 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
6220 gfc_is_expandable_expr (gfc_expr *e)
6222 gfc_constructor *con;
6224 if (e->expr_type == EXPR_ARRAY)
6226 /* Traverse the constructor looking for variables that are flavor
6227 parameter. Parameters must be expanded since they are fully used at
6229 con = gfc_constructor_first (e->value.constructor);
6230 for (; con; con = gfc_constructor_next (con))
6232 if (con->expr->expr_type == EXPR_VARIABLE
6233 && con->expr->symtree
6234 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6235 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
6237 if (con->expr->expr_type == EXPR_ARRAY
6238 && gfc_is_expandable_expr (con->expr))
6246 /* Resolve an expression. That is, make sure that types of operands agree
6247 with their operators, intrinsic operators are converted to function calls
6248 for overloaded types and unresolved function references are resolved. */
6251 gfc_resolve_expr (gfc_expr *e)
6259 /* inquiry_argument only applies to variables. */
6260 inquiry_save = inquiry_argument;
6261 if (e->expr_type != EXPR_VARIABLE)
6262 inquiry_argument = false;
6264 switch (e->expr_type)
6267 t = resolve_operator (e);
6273 if (check_host_association (e))
6274 t = resolve_function (e);
6277 t = resolve_variable (e);
6279 expression_rank (e);
6282 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6283 && e->ref->type != REF_SUBSTRING)
6284 gfc_resolve_substring_charlen (e);
6289 t = resolve_typebound_function (e);
6292 case EXPR_SUBSTRING:
6293 t = resolve_ref (e);
6302 t = resolve_expr_ppc (e);
6307 if (resolve_ref (e) == FAILURE)
6310 t = gfc_resolve_array_constructor (e);
6311 /* Also try to expand a constructor. */
6314 expression_rank (e);
6315 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6316 gfc_expand_constructor (e, false);
6319 /* This provides the opportunity for the length of constructors with
6320 character valued function elements to propagate the string length
6321 to the expression. */
6322 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6324 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6325 here rather then add a duplicate test for it above. */
6326 gfc_expand_constructor (e, false);
6327 t = gfc_resolve_character_array_constructor (e);
6332 case EXPR_STRUCTURE:
6333 t = resolve_ref (e);
6337 t = resolve_structure_cons (e, 0);
6341 t = gfc_simplify_expr (e, 0);
6345 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6348 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6351 inquiry_argument = inquiry_save;
6357 /* Resolve an expression from an iterator. They must be scalar and have
6358 INTEGER or (optionally) REAL type. */
6361 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6362 const char *name_msgid)
6364 if (gfc_resolve_expr (expr) == FAILURE)
6367 if (expr->rank != 0)
6369 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6373 if (expr->ts.type != BT_INTEGER)
6375 if (expr->ts.type == BT_REAL)
6378 return gfc_notify_std (GFC_STD_F95_DEL,
6379 "Deleted feature: %s at %L must be integer",
6380 _(name_msgid), &expr->where);
6383 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6390 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6398 /* Resolve the expressions in an iterator structure. If REAL_OK is
6399 false allow only INTEGER type iterators, otherwise allow REAL types. */
6402 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6404 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6408 if (gfc_check_vardef_context (iter->var, false, false, _("iterator variable"))
6412 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6413 "Start expression in DO loop") == FAILURE)
6416 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6417 "End expression in DO loop") == FAILURE)
6420 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6421 "Step expression in DO loop") == FAILURE)
6424 if (iter->step->expr_type == EXPR_CONSTANT)
6426 if ((iter->step->ts.type == BT_INTEGER
6427 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6428 || (iter->step->ts.type == BT_REAL
6429 && mpfr_sgn (iter->step->value.real) == 0))
6431 gfc_error ("Step expression in DO loop at %L cannot be zero",
6432 &iter->step->where);
6437 /* Convert start, end, and step to the same type as var. */
6438 if (iter->start->ts.kind != iter->var->ts.kind
6439 || iter->start->ts.type != iter->var->ts.type)
6440 gfc_convert_type (iter->start, &iter->var->ts, 2);
6442 if (iter->end->ts.kind != iter->var->ts.kind
6443 || iter->end->ts.type != iter->var->ts.type)
6444 gfc_convert_type (iter->end, &iter->var->ts, 2);
6446 if (iter->step->ts.kind != iter->var->ts.kind
6447 || iter->step->ts.type != iter->var->ts.type)
6448 gfc_convert_type (iter->step, &iter->var->ts, 2);
6450 if (iter->start->expr_type == EXPR_CONSTANT
6451 && iter->end->expr_type == EXPR_CONSTANT
6452 && iter->step->expr_type == EXPR_CONSTANT)
6455 if (iter->start->ts.type == BT_INTEGER)
6457 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6458 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6462 sgn = mpfr_sgn (iter->step->value.real);
6463 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6465 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6466 gfc_warning ("DO loop at %L will be executed zero times",
6467 &iter->step->where);
6474 /* Traversal function for find_forall_index. f == 2 signals that
6475 that variable itself is not to be checked - only the references. */
6478 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6480 if (expr->expr_type != EXPR_VARIABLE)
6483 /* A scalar assignment */
6484 if (!expr->ref || *f == 1)
6486 if (expr->symtree->n.sym == sym)
6498 /* Check whether the FORALL index appears in the expression or not.
6499 Returns SUCCESS if SYM is found in EXPR. */
6502 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6504 if (gfc_traverse_expr (expr, sym, forall_index, f))
6511 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6512 to be a scalar INTEGER variable. The subscripts and stride are scalar
6513 INTEGERs, and if stride is a constant it must be nonzero.
6514 Furthermore "A subscript or stride in a forall-triplet-spec shall
6515 not contain a reference to any index-name in the
6516 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6519 resolve_forall_iterators (gfc_forall_iterator *it)
6521 gfc_forall_iterator *iter, *iter2;
6523 for (iter = it; iter; iter = iter->next)
6525 if (gfc_resolve_expr (iter->var) == SUCCESS
6526 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6527 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6530 if (gfc_resolve_expr (iter->start) == SUCCESS
6531 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6532 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6533 &iter->start->where);
6534 if (iter->var->ts.kind != iter->start->ts.kind)
6535 gfc_convert_type (iter->start, &iter->var->ts, 1);
6537 if (gfc_resolve_expr (iter->end) == SUCCESS
6538 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6539 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6541 if (iter->var->ts.kind != iter->end->ts.kind)
6542 gfc_convert_type (iter->end, &iter->var->ts, 1);
6544 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6546 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6547 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6548 &iter->stride->where, "INTEGER");
6550 if (iter->stride->expr_type == EXPR_CONSTANT
6551 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6552 gfc_error ("FORALL stride expression at %L cannot be zero",
6553 &iter->stride->where);
6555 if (iter->var->ts.kind != iter->stride->ts.kind)
6556 gfc_convert_type (iter->stride, &iter->var->ts, 1);
6559 for (iter = it; iter; iter = iter->next)
6560 for (iter2 = iter; iter2; iter2 = iter2->next)
6562 if (find_forall_index (iter2->start,
6563 iter->var->symtree->n.sym, 0) == SUCCESS
6564 || find_forall_index (iter2->end,
6565 iter->var->symtree->n.sym, 0) == SUCCESS
6566 || find_forall_index (iter2->stride,
6567 iter->var->symtree->n.sym, 0) == SUCCESS)
6568 gfc_error ("FORALL index '%s' may not appear in triplet "
6569 "specification at %L", iter->var->symtree->name,
6570 &iter2->start->where);
6575 /* Given a pointer to a symbol that is a derived type, see if it's
6576 inaccessible, i.e. if it's defined in another module and the components are
6577 PRIVATE. The search is recursive if necessary. Returns zero if no
6578 inaccessible components are found, nonzero otherwise. */
6581 derived_inaccessible (gfc_symbol *sym)
6585 if (sym->attr.use_assoc && sym->attr.private_comp)
6588 for (c = sym->components; c; c = c->next)
6590 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6598 /* Resolve the argument of a deallocate expression. The expression must be
6599 a pointer or a full array. */
6602 resolve_deallocate_expr (gfc_expr *e)
6604 symbol_attribute attr;
6605 int allocatable, pointer;
6610 if (gfc_resolve_expr (e) == FAILURE)
6613 if (e->expr_type != EXPR_VARIABLE)
6616 sym = e->symtree->n.sym;
6618 if (sym->ts.type == BT_CLASS)
6620 allocatable = CLASS_DATA (sym)->attr.allocatable;
6621 pointer = CLASS_DATA (sym)->attr.class_pointer;
6625 allocatable = sym->attr.allocatable;
6626 pointer = sym->attr.pointer;
6628 for (ref = e->ref; ref; ref = ref->next)
6633 if (ref->u.ar.type != AR_FULL
6634 && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
6635 && ref->u.ar.codimen && gfc_ref_this_image (ref)))
6640 c = ref->u.c.component;
6641 if (c->ts.type == BT_CLASS)
6643 allocatable = CLASS_DATA (c)->attr.allocatable;
6644 pointer = CLASS_DATA (c)->attr.class_pointer;
6648 allocatable = c->attr.allocatable;
6649 pointer = c->attr.pointer;
6659 attr = gfc_expr_attr (e);
6661 if (allocatable == 0 && attr.pointer == 0)
6664 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6670 if (gfc_is_coindexed (e))
6672 gfc_error ("Coindexed allocatable object at %L", &e->where);
6677 && gfc_check_vardef_context (e, true, true, _("DEALLOCATE object"))
6680 if (gfc_check_vardef_context (e, false, true, _("DEALLOCATE object"))
6688 /* Returns true if the expression e contains a reference to the symbol sym. */
6690 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6692 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6699 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6701 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6705 /* Given the expression node e for an allocatable/pointer of derived type to be
6706 allocated, get the expression node to be initialized afterwards (needed for
6707 derived types with default initializers, and derived types with allocatable
6708 components that need nullification.) */
6711 gfc_expr_to_initialize (gfc_expr *e)
6717 result = gfc_copy_expr (e);
6719 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6720 for (ref = result->ref; ref; ref = ref->next)
6721 if (ref->type == REF_ARRAY && ref->next == NULL)
6723 ref->u.ar.type = AR_FULL;
6725 for (i = 0; i < ref->u.ar.dimen; i++)
6726 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6731 gfc_free_shape (&result->shape, result->rank);
6733 /* Recalculate rank, shape, etc. */
6734 gfc_resolve_expr (result);
6739 /* If the last ref of an expression is an array ref, return a copy of the
6740 expression with that one removed. Otherwise, a copy of the original
6741 expression. This is used for allocate-expressions and pointer assignment
6742 LHS, where there may be an array specification that needs to be stripped
6743 off when using gfc_check_vardef_context. */
6746 remove_last_array_ref (gfc_expr* e)
6751 e2 = gfc_copy_expr (e);
6752 for (r = &e2->ref; *r; r = &(*r)->next)
6753 if ((*r)->type == REF_ARRAY && !(*r)->next)
6755 gfc_free_ref_list (*r);
6764 /* Used in resolve_allocate_expr to check that a allocation-object and
6765 a source-expr are conformable. This does not catch all possible
6766 cases; in particular a runtime checking is needed. */
6769 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6772 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6774 /* First compare rank. */
6775 if (tail && e1->rank != tail->u.ar.as->rank)
6777 gfc_error ("Source-expr at %L must be scalar or have the "
6778 "same rank as the allocate-object at %L",
6779 &e1->where, &e2->where);
6790 for (i = 0; i < e1->rank; i++)
6792 if (tail->u.ar.end[i])
6794 mpz_set (s, tail->u.ar.end[i]->value.integer);
6795 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6796 mpz_add_ui (s, s, 1);
6800 mpz_set (s, tail->u.ar.start[i]->value.integer);
6803 if (mpz_cmp (e1->shape[i], s) != 0)
6805 gfc_error ("Source-expr at %L and allocate-object at %L must "
6806 "have the same shape", &e1->where, &e2->where);
6819 /* Resolve the expression in an ALLOCATE statement, doing the additional
6820 checks to see whether the expression is OK or not. The expression must
6821 have a trailing array reference that gives the size of the array. */
6824 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6826 int i, pointer, allocatable, dimension, is_abstract;
6829 symbol_attribute attr;
6830 gfc_ref *ref, *ref2;
6833 gfc_symbol *sym = NULL;
6838 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6839 checking of coarrays. */
6840 for (ref = e->ref; ref; ref = ref->next)
6841 if (ref->next == NULL)
6844 if (ref && ref->type == REF_ARRAY)
6845 ref->u.ar.in_allocate = true;
6847 if (gfc_resolve_expr (e) == FAILURE)
6850 /* Make sure the expression is allocatable or a pointer. If it is
6851 pointer, the next-to-last reference must be a pointer. */
6855 sym = e->symtree->n.sym;
6857 /* Check whether ultimate component is abstract and CLASS. */
6860 if (e->expr_type != EXPR_VARIABLE)
6863 attr = gfc_expr_attr (e);
6864 pointer = attr.pointer;
6865 dimension = attr.dimension;
6866 codimension = attr.codimension;
6870 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
6872 allocatable = CLASS_DATA (sym)->attr.allocatable;
6873 pointer = CLASS_DATA (sym)->attr.class_pointer;
6874 dimension = CLASS_DATA (sym)->attr.dimension;
6875 codimension = CLASS_DATA (sym)->attr.codimension;
6876 is_abstract = CLASS_DATA (sym)->attr.abstract;
6880 allocatable = sym->attr.allocatable;
6881 pointer = sym->attr.pointer;
6882 dimension = sym->attr.dimension;
6883 codimension = sym->attr.codimension;
6888 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6893 if (ref->u.ar.codimen > 0)
6896 for (n = ref->u.ar.dimen;
6897 n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
6898 if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
6905 if (ref->next != NULL)
6913 gfc_error ("Coindexed allocatable object at %L",
6918 c = ref->u.c.component;
6919 if (c->ts.type == BT_CLASS)
6921 allocatable = CLASS_DATA (c)->attr.allocatable;
6922 pointer = CLASS_DATA (c)->attr.class_pointer;
6923 dimension = CLASS_DATA (c)->attr.dimension;
6924 codimension = CLASS_DATA (c)->attr.codimension;
6925 is_abstract = CLASS_DATA (c)->attr.abstract;
6929 allocatable = c->attr.allocatable;
6930 pointer = c->attr.pointer;
6931 dimension = c->attr.dimension;
6932 codimension = c->attr.codimension;
6933 is_abstract = c->attr.abstract;
6945 if (allocatable == 0 && pointer == 0)
6947 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6952 /* Some checks for the SOURCE tag. */
6955 /* Check F03:C631. */
6956 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6958 gfc_error ("Type of entity at %L is type incompatible with "
6959 "source-expr at %L", &e->where, &code->expr3->where);
6963 /* Check F03:C632 and restriction following Note 6.18. */
6964 if (code->expr3->rank > 0
6965 && conformable_arrays (code->expr3, e) == FAILURE)
6968 /* Check F03:C633. */
6969 if (code->expr3->ts.kind != e->ts.kind)
6971 gfc_error ("The allocate-object at %L and the source-expr at %L "
6972 "shall have the same kind type parameter",
6973 &e->where, &code->expr3->where);
6977 /* Check F2008, C642. */
6978 if (code->expr3->ts.type == BT_DERIVED
6979 && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
6980 || (code->expr3->ts.u.derived->from_intmod
6981 == INTMOD_ISO_FORTRAN_ENV
6982 && code->expr3->ts.u.derived->intmod_sym_id
6983 == ISOFORTRAN_LOCK_TYPE)))
6985 gfc_error ("The source-expr at %L shall neither be of type "
6986 "LOCK_TYPE nor have a LOCK_TYPE component if "
6987 "allocate-object at %L is a coarray",
6988 &code->expr3->where, &e->where);
6993 /* Check F08:C629. */
6994 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
6997 gcc_assert (e->ts.type == BT_CLASS);
6998 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6999 "type-spec or source-expr", sym->name, &e->where);
7003 if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred)
7005 int cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
7006 code->ext.alloc.ts.u.cl->length);
7007 if (cmp == 1 || cmp == -1 || cmp == -3)
7009 gfc_error ("Allocating %s at %L with type-spec requires the same "
7010 "character-length parameter as in the declaration",
7011 sym->name, &e->where);
7016 /* In the variable definition context checks, gfc_expr_attr is used
7017 on the expression. This is fooled by the array specification
7018 present in e, thus we have to eliminate that one temporarily. */
7019 e2 = remove_last_array_ref (e);
7021 if (t == SUCCESS && pointer)
7022 t = gfc_check_vardef_context (e2, true, true, _("ALLOCATE object"));
7024 t = gfc_check_vardef_context (e2, false, true, _("ALLOCATE object"));
7029 if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
7030 && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
7032 /* For class arrays, the initialization with SOURCE is done
7033 using _copy and trans_call. It is convenient to exploit that
7034 when the allocated type is different from the declared type but
7035 no SOURCE exists by setting expr3. */
7036 code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
7038 else if (!code->expr3)
7040 /* Set up default initializer if needed. */
7044 if (code->ext.alloc.ts.type == BT_DERIVED)
7045 ts = code->ext.alloc.ts;
7049 if (ts.type == BT_CLASS)
7050 ts = ts.u.derived->components->ts;
7052 if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
7054 gfc_code *init_st = gfc_get_code ();
7055 init_st->loc = code->loc;
7056 init_st->op = EXEC_INIT_ASSIGN;
7057 init_st->expr1 = gfc_expr_to_initialize (e);
7058 init_st->expr2 = init_e;
7059 init_st->next = code->next;
7060 code->next = init_st;
7063 else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
7065 /* Default initialization via MOLD (non-polymorphic). */
7066 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
7067 gfc_resolve_expr (rhs);
7068 gfc_free_expr (code->expr3);
7072 if (e->ts.type == BT_CLASS)
7074 /* Make sure the vtab symbol is present when
7075 the module variables are generated. */
7076 gfc_typespec ts = e->ts;
7078 ts = code->expr3->ts;
7079 else if (code->ext.alloc.ts.type == BT_DERIVED)
7080 ts = code->ext.alloc.ts;
7081 gfc_find_derived_vtab (ts.u.derived);
7083 e = gfc_expr_to_initialize (e);
7086 if (dimension == 0 && codimension == 0)
7089 /* Make sure the last reference node is an array specifiction. */
7091 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
7092 || (dimension && ref2->u.ar.dimen == 0))
7094 gfc_error ("Array specification required in ALLOCATE statement "
7095 "at %L", &e->where);
7099 /* Make sure that the array section reference makes sense in the
7100 context of an ALLOCATE specification. */
7105 for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
7106 if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
7108 gfc_error ("Coarray specification required in ALLOCATE statement "
7109 "at %L", &e->where);
7113 for (i = 0; i < ar->dimen; i++)
7115 if (ref2->u.ar.type == AR_ELEMENT)
7118 switch (ar->dimen_type[i])
7124 if (ar->start[i] != NULL
7125 && ar->end[i] != NULL
7126 && ar->stride[i] == NULL)
7129 /* Fall Through... */
7134 case DIMEN_THIS_IMAGE:
7135 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7141 for (a = code->ext.alloc.list; a; a = a->next)
7143 sym = a->expr->symtree->n.sym;
7145 /* TODO - check derived type components. */
7146 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
7149 if ((ar->start[i] != NULL
7150 && gfc_find_sym_in_expr (sym, ar->start[i]))
7151 || (ar->end[i] != NULL
7152 && gfc_find_sym_in_expr (sym, ar->end[i])))
7154 gfc_error ("'%s' must not appear in the array specification at "
7155 "%L in the same ALLOCATE statement where it is "
7156 "itself allocated", sym->name, &ar->where);
7162 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
7164 if (ar->dimen_type[i] == DIMEN_ELEMENT
7165 || ar->dimen_type[i] == DIMEN_RANGE)
7167 if (i == (ar->dimen + ar->codimen - 1))
7169 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7170 "statement at %L", &e->where);
7176 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
7177 && ar->stride[i] == NULL)
7180 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7193 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
7195 gfc_expr *stat, *errmsg, *pe, *qe;
7196 gfc_alloc *a, *p, *q;
7199 errmsg = code->expr2;
7201 /* Check the stat variable. */
7204 gfc_check_vardef_context (stat, false, false, _("STAT variable"));
7206 if ((stat->ts.type != BT_INTEGER
7207 && !(stat->ref && (stat->ref->type == REF_ARRAY
7208 || stat->ref->type == REF_COMPONENT)))
7210 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7211 "variable", &stat->where);
7213 for (p = code->ext.alloc.list; p; p = p->next)
7214 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
7216 gfc_ref *ref1, *ref2;
7219 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
7220 ref1 = ref1->next, ref2 = ref2->next)
7222 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7224 if (ref1->u.c.component->name != ref2->u.c.component->name)
7233 gfc_error ("Stat-variable at %L shall not be %sd within "
7234 "the same %s statement", &stat->where, fcn, fcn);
7240 /* Check the errmsg variable. */
7244 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7247 gfc_check_vardef_context (errmsg, false, false, _("ERRMSG variable"));
7249 if ((errmsg->ts.type != BT_CHARACTER
7251 && (errmsg->ref->type == REF_ARRAY
7252 || errmsg->ref->type == REF_COMPONENT)))
7253 || errmsg->rank > 0 )
7254 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7255 "variable", &errmsg->where);
7257 for (p = code->ext.alloc.list; p; p = p->next)
7258 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
7260 gfc_ref *ref1, *ref2;
7263 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
7264 ref1 = ref1->next, ref2 = ref2->next)
7266 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7268 if (ref1->u.c.component->name != ref2->u.c.component->name)
7277 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7278 "the same %s statement", &errmsg->where, fcn, fcn);
7284 /* Check that an allocate-object appears only once in the statement. */
7286 for (p = code->ext.alloc.list; p; p = p->next)
7289 for (q = p->next; q; q = q->next)
7292 if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
7294 /* This is a potential collision. */
7295 gfc_ref *pr = pe->ref;
7296 gfc_ref *qr = qe->ref;
7298 /* Follow the references until
7299 a) They start to differ, in which case there is no error;
7300 you can deallocate a%b and a%c in a single statement
7301 b) Both of them stop, which is an error
7302 c) One of them stops, which is also an error. */
7305 if (pr == NULL && qr == NULL)
7307 gfc_error ("Allocate-object at %L also appears at %L",
7308 &pe->where, &qe->where);
7311 else if (pr != NULL && qr == NULL)
7313 gfc_error ("Allocate-object at %L is subobject of"
7314 " object at %L", &pe->where, &qe->where);
7317 else if (pr == NULL && qr != NULL)
7319 gfc_error ("Allocate-object at %L is subobject of"
7320 " object at %L", &qe->where, &pe->where);
7323 /* Here, pr != NULL && qr != NULL */
7324 gcc_assert(pr->type == qr->type);
7325 if (pr->type == REF_ARRAY)
7327 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7329 gcc_assert (qr->type == REF_ARRAY);
7331 if (pr->next && qr->next)
7334 gfc_array_ref *par = &(pr->u.ar);
7335 gfc_array_ref *qar = &(qr->u.ar);
7337 for (i=0; i<par->dimen; i++)
7339 if ((par->start[i] != NULL
7340 || qar->start[i] != NULL)
7341 && gfc_dep_compare_expr (par->start[i],
7342 qar->start[i]) != 0)
7349 if (pr->u.c.component->name != qr->u.c.component->name)
7362 if (strcmp (fcn, "ALLOCATE") == 0)
7364 for (a = code->ext.alloc.list; a; a = a->next)
7365 resolve_allocate_expr (a->expr, code);
7369 for (a = code->ext.alloc.list; a; a = a->next)
7370 resolve_deallocate_expr (a->expr);
7375 /************ SELECT CASE resolution subroutines ************/
7377 /* Callback function for our mergesort variant. Determines interval
7378 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7379 op1 > op2. Assumes we're not dealing with the default case.
7380 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7381 There are nine situations to check. */
7384 compare_cases (const gfc_case *op1, const gfc_case *op2)
7388 if (op1->low == NULL) /* op1 = (:L) */
7390 /* op2 = (:N), so overlap. */
7392 /* op2 = (M:) or (M:N), L < M */
7393 if (op2->low != NULL
7394 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7397 else if (op1->high == NULL) /* op1 = (K:) */
7399 /* op2 = (M:), so overlap. */
7401 /* op2 = (:N) or (M:N), K > N */
7402 if (op2->high != NULL
7403 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7406 else /* op1 = (K:L) */
7408 if (op2->low == NULL) /* op2 = (:N), K > N */
7409 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7411 else if (op2->high == NULL) /* op2 = (M:), L < M */
7412 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7414 else /* op2 = (M:N) */
7418 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7421 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7430 /* Merge-sort a double linked case list, detecting overlap in the
7431 process. LIST is the head of the double linked case list before it
7432 is sorted. Returns the head of the sorted list if we don't see any
7433 overlap, or NULL otherwise. */
7436 check_case_overlap (gfc_case *list)
7438 gfc_case *p, *q, *e, *tail;
7439 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7441 /* If the passed list was empty, return immediately. */
7448 /* Loop unconditionally. The only exit from this loop is a return
7449 statement, when we've finished sorting the case list. */
7456 /* Count the number of merges we do in this pass. */
7459 /* Loop while there exists a merge to be done. */
7464 /* Count this merge. */
7467 /* Cut the list in two pieces by stepping INSIZE places
7468 forward in the list, starting from P. */
7471 for (i = 0; i < insize; i++)
7480 /* Now we have two lists. Merge them! */
7481 while (psize > 0 || (qsize > 0 && q != NULL))
7483 /* See from which the next case to merge comes from. */
7486 /* P is empty so the next case must come from Q. */
7491 else if (qsize == 0 || q == NULL)
7500 cmp = compare_cases (p, q);
7503 /* The whole case range for P is less than the
7511 /* The whole case range for Q is greater than
7512 the case range for P. */
7519 /* The cases overlap, or they are the same
7520 element in the list. Either way, we must
7521 issue an error and get the next case from P. */
7522 /* FIXME: Sort P and Q by line number. */
7523 gfc_error ("CASE label at %L overlaps with CASE "
7524 "label at %L", &p->where, &q->where);
7532 /* Add the next element to the merged list. */
7541 /* P has now stepped INSIZE places along, and so has Q. So
7542 they're the same. */
7547 /* If we have done only one merge or none at all, we've
7548 finished sorting the cases. */
7557 /* Otherwise repeat, merging lists twice the size. */
7563 /* Check to see if an expression is suitable for use in a CASE statement.
7564 Makes sure that all case expressions are scalar constants of the same
7565 type. Return FAILURE if anything is wrong. */
7568 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7570 if (e == NULL) return SUCCESS;
7572 if (e->ts.type != case_expr->ts.type)
7574 gfc_error ("Expression in CASE statement at %L must be of type %s",
7575 &e->where, gfc_basic_typename (case_expr->ts.type));
7579 /* C805 (R808) For a given case-construct, each case-value shall be of
7580 the same type as case-expr. For character type, length differences
7581 are allowed, but the kind type parameters shall be the same. */
7583 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7585 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7586 &e->where, case_expr->ts.kind);
7590 /* Convert the case value kind to that of case expression kind,
7593 if (e->ts.kind != case_expr->ts.kind)
7594 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7598 gfc_error ("Expression in CASE statement at %L must be scalar",
7607 /* Given a completely parsed select statement, we:
7609 - Validate all expressions and code within the SELECT.
7610 - Make sure that the selection expression is not of the wrong type.
7611 - Make sure that no case ranges overlap.
7612 - Eliminate unreachable cases and unreachable code resulting from
7613 removing case labels.
7615 The standard does allow unreachable cases, e.g. CASE (5:3). But
7616 they are a hassle for code generation, and to prevent that, we just
7617 cut them out here. This is not necessary for overlapping cases
7618 because they are illegal and we never even try to generate code.
7620 We have the additional caveat that a SELECT construct could have
7621 been a computed GOTO in the source code. Fortunately we can fairly
7622 easily work around that here: The case_expr for a "real" SELECT CASE
7623 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7624 we have to do is make sure that the case_expr is a scalar integer
7628 resolve_select (gfc_code *code, bool select_type)
7631 gfc_expr *case_expr;
7632 gfc_case *cp, *default_case, *tail, *head;
7633 int seen_unreachable;
7639 if (code->expr1 == NULL)
7641 /* This was actually a computed GOTO statement. */
7642 case_expr = code->expr2;
7643 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7644 gfc_error ("Selection expression in computed GOTO statement "
7645 "at %L must be a scalar integer expression",
7648 /* Further checking is not necessary because this SELECT was built
7649 by the compiler, so it should always be OK. Just move the
7650 case_expr from expr2 to expr so that we can handle computed
7651 GOTOs as normal SELECTs from here on. */
7652 code->expr1 = code->expr2;
7657 case_expr = code->expr1;
7658 type = case_expr->ts.type;
7661 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7663 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7664 &case_expr->where, gfc_typename (&case_expr->ts));
7666 /* Punt. Going on here just produce more garbage error messages. */
7671 if (!select_type && case_expr->rank != 0)
7673 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7674 "expression", &case_expr->where);
7680 /* Raise a warning if an INTEGER case value exceeds the range of
7681 the case-expr. Later, all expressions will be promoted to the
7682 largest kind of all case-labels. */
7684 if (type == BT_INTEGER)
7685 for (body = code->block; body; body = body->block)
7686 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7689 && gfc_check_integer_range (cp->low->value.integer,
7690 case_expr->ts.kind) != ARITH_OK)
7691 gfc_warning ("Expression in CASE statement at %L is "
7692 "not in the range of %s", &cp->low->where,
7693 gfc_typename (&case_expr->ts));
7696 && cp->low != cp->high
7697 && gfc_check_integer_range (cp->high->value.integer,
7698 case_expr->ts.kind) != ARITH_OK)
7699 gfc_warning ("Expression in CASE statement at %L is "
7700 "not in the range of %s", &cp->high->where,
7701 gfc_typename (&case_expr->ts));
7704 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7705 of the SELECT CASE expression and its CASE values. Walk the lists
7706 of case values, and if we find a mismatch, promote case_expr to
7707 the appropriate kind. */
7709 if (type == BT_LOGICAL || type == BT_INTEGER)
7711 for (body = code->block; body; body = body->block)
7713 /* Walk the case label list. */
7714 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7716 /* Intercept the DEFAULT case. It does not have a kind. */
7717 if (cp->low == NULL && cp->high == NULL)
7720 /* Unreachable case ranges are discarded, so ignore. */
7721 if (cp->low != NULL && cp->high != NULL
7722 && cp->low != cp->high
7723 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7727 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7728 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7730 if (cp->high != NULL
7731 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7732 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7737 /* Assume there is no DEFAULT case. */
7738 default_case = NULL;
7743 for (body = code->block; body; body = body->block)
7745 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7747 seen_unreachable = 0;
7749 /* Walk the case label list, making sure that all case labels
7751 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7753 /* Count the number of cases in the whole construct. */
7756 /* Intercept the DEFAULT case. */
7757 if (cp->low == NULL && cp->high == NULL)
7759 if (default_case != NULL)
7761 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7762 "by a second DEFAULT CASE at %L",
7763 &default_case->where, &cp->where);
7774 /* Deal with single value cases and case ranges. Errors are
7775 issued from the validation function. */
7776 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7777 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7783 if (type == BT_LOGICAL
7784 && ((cp->low == NULL || cp->high == NULL)
7785 || cp->low != cp->high))
7787 gfc_error ("Logical range in CASE statement at %L is not "
7788 "allowed", &cp->low->where);
7793 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7796 value = cp->low->value.logical == 0 ? 2 : 1;
7797 if (value & seen_logical)
7799 gfc_error ("Constant logical value in CASE statement "
7800 "is repeated at %L",
7805 seen_logical |= value;
7808 if (cp->low != NULL && cp->high != NULL
7809 && cp->low != cp->high
7810 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7812 if (gfc_option.warn_surprising)
7813 gfc_warning ("Range specification at %L can never "
7814 "be matched", &cp->where);
7816 cp->unreachable = 1;
7817 seen_unreachable = 1;
7821 /* If the case range can be matched, it can also overlap with
7822 other cases. To make sure it does not, we put it in a
7823 double linked list here. We sort that with a merge sort
7824 later on to detect any overlapping cases. */
7828 head->right = head->left = NULL;
7833 tail->right->left = tail;
7840 /* It there was a failure in the previous case label, give up
7841 for this case label list. Continue with the next block. */
7845 /* See if any case labels that are unreachable have been seen.
7846 If so, we eliminate them. This is a bit of a kludge because
7847 the case lists for a single case statement (label) is a
7848 single forward linked lists. */
7849 if (seen_unreachable)
7851 /* Advance until the first case in the list is reachable. */
7852 while (body->ext.block.case_list != NULL
7853 && body->ext.block.case_list->unreachable)
7855 gfc_case *n = body->ext.block.case_list;
7856 body->ext.block.case_list = body->ext.block.case_list->next;
7858 gfc_free_case_list (n);
7861 /* Strip all other unreachable cases. */
7862 if (body->ext.block.case_list)
7864 for (cp = body->ext.block.case_list; cp->next; cp = cp->next)
7866 if (cp->next->unreachable)
7868 gfc_case *n = cp->next;
7869 cp->next = cp->next->next;
7871 gfc_free_case_list (n);
7878 /* See if there were overlapping cases. If the check returns NULL,
7879 there was overlap. In that case we don't do anything. If head
7880 is non-NULL, we prepend the DEFAULT case. The sorted list can
7881 then used during code generation for SELECT CASE constructs with
7882 a case expression of a CHARACTER type. */
7885 head = check_case_overlap (head);
7887 /* Prepend the default_case if it is there. */
7888 if (head != NULL && default_case)
7890 default_case->left = NULL;
7891 default_case->right = head;
7892 head->left = default_case;
7896 /* Eliminate dead blocks that may be the result if we've seen
7897 unreachable case labels for a block. */
7898 for (body = code; body && body->block; body = body->block)
7900 if (body->block->ext.block.case_list == NULL)
7902 /* Cut the unreachable block from the code chain. */
7903 gfc_code *c = body->block;
7904 body->block = c->block;
7906 /* Kill the dead block, but not the blocks below it. */
7908 gfc_free_statements (c);
7912 /* More than two cases is legal but insane for logical selects.
7913 Issue a warning for it. */
7914 if (gfc_option.warn_surprising && type == BT_LOGICAL
7916 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7921 /* Check if a derived type is extensible. */
7924 gfc_type_is_extensible (gfc_symbol *sym)
7926 return !(sym->attr.is_bind_c || sym->attr.sequence);
7930 /* Resolve an associate name: Resolve target and ensure the type-spec is
7931 correct as well as possibly the array-spec. */
7934 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
7938 gcc_assert (sym->assoc);
7939 gcc_assert (sym->attr.flavor == FL_VARIABLE);
7941 /* If this is for SELECT TYPE, the target may not yet be set. In that
7942 case, return. Resolution will be called later manually again when
7944 target = sym->assoc->target;
7947 gcc_assert (!sym->assoc->dangling);
7949 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
7952 /* For variable targets, we get some attributes from the target. */
7953 if (target->expr_type == EXPR_VARIABLE)
7957 gcc_assert (target->symtree);
7958 tsym = target->symtree->n.sym;
7960 sym->attr.asynchronous = tsym->attr.asynchronous;
7961 sym->attr.volatile_ = tsym->attr.volatile_;
7963 sym->attr.target = tsym->attr.target
7964 || gfc_expr_attr (target).pointer;
7967 /* Get type if this was not already set. Note that it can be
7968 some other type than the target in case this is a SELECT TYPE
7969 selector! So we must not update when the type is already there. */
7970 if (sym->ts.type == BT_UNKNOWN)
7971 sym->ts = target->ts;
7972 gcc_assert (sym->ts.type != BT_UNKNOWN);
7974 /* See if this is a valid association-to-variable. */
7975 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
7976 && !gfc_has_vector_subscript (target));
7978 /* Finally resolve if this is an array or not. */
7979 if (sym->attr.dimension && target->rank == 0)
7981 gfc_error ("Associate-name '%s' at %L is used as array",
7982 sym->name, &sym->declared_at);
7983 sym->attr.dimension = 0;
7986 if (target->rank > 0)
7987 sym->attr.dimension = 1;
7989 if (sym->attr.dimension)
7991 sym->as = gfc_get_array_spec ();
7992 sym->as->rank = target->rank;
7993 sym->as->type = AS_DEFERRED;
7995 /* Target must not be coindexed, thus the associate-variable
7997 sym->as->corank = 0;
8002 /* Resolve a SELECT TYPE statement. */
8005 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
8007 gfc_symbol *selector_type;
8008 gfc_code *body, *new_st, *if_st, *tail;
8009 gfc_code *class_is = NULL, *default_case = NULL;
8012 char name[GFC_MAX_SYMBOL_LEN];
8016 ns = code->ext.block.ns;
8019 /* Check for F03:C813. */
8020 if (code->expr1->ts.type != BT_CLASS
8021 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
8023 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8024 "at %L", &code->loc);
8028 if (!code->expr1->symtree->n.sym->attr.class_ok)
8033 if (code->expr1->symtree->n.sym->attr.untyped)
8034 code->expr1->symtree->n.sym->ts = code->expr2->ts;
8035 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
8038 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
8040 /* Loop over TYPE IS / CLASS IS cases. */
8041 for (body = code->block; body; body = body->block)
8043 c = body->ext.block.case_list;
8045 /* Check F03:C815. */
8046 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8047 && !gfc_type_is_extensible (c->ts.u.derived))
8049 gfc_error ("Derived type '%s' at %L must be extensible",
8050 c->ts.u.derived->name, &c->where);
8055 /* Check F03:C816. */
8056 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8057 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
8059 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
8060 c->ts.u.derived->name, &c->where, selector_type->name);
8065 /* Intercept the DEFAULT case. */
8066 if (c->ts.type == BT_UNKNOWN)
8068 /* Check F03:C818. */
8071 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8072 "by a second DEFAULT CASE at %L",
8073 &default_case->ext.block.case_list->where, &c->where);
8078 default_case = body;
8085 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8086 target if present. If there are any EXIT statements referring to the
8087 SELECT TYPE construct, this is no problem because the gfc_code
8088 reference stays the same and EXIT is equally possible from the BLOCK
8089 it is changed to. */
8090 code->op = EXEC_BLOCK;
8093 gfc_association_list* assoc;
8095 assoc = gfc_get_association_list ();
8096 assoc->st = code->expr1->symtree;
8097 assoc->target = gfc_copy_expr (code->expr2);
8098 assoc->target->where = code->expr2->where;
8099 /* assoc->variable will be set by resolve_assoc_var. */
8101 code->ext.block.assoc = assoc;
8102 code->expr1->symtree->n.sym->assoc = assoc;
8104 resolve_assoc_var (code->expr1->symtree->n.sym, false);
8107 code->ext.block.assoc = NULL;
8109 /* Add EXEC_SELECT to switch on type. */
8110 new_st = gfc_get_code ();
8111 new_st->op = code->op;
8112 new_st->expr1 = code->expr1;
8113 new_st->expr2 = code->expr2;
8114 new_st->block = code->block;
8115 code->expr1 = code->expr2 = NULL;
8120 ns->code->next = new_st;
8122 code->op = EXEC_SELECT;
8123 gfc_add_vptr_component (code->expr1);
8124 gfc_add_hash_component (code->expr1);
8126 /* Loop over TYPE IS / CLASS IS cases. */
8127 for (body = code->block; body; body = body->block)
8129 c = body->ext.block.case_list;
8131 if (c->ts.type == BT_DERIVED)
8132 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
8133 c->ts.u.derived->hash_value);
8135 else if (c->ts.type == BT_UNKNOWN)
8138 /* Associate temporary to selector. This should only be done
8139 when this case is actually true, so build a new ASSOCIATE
8140 that does precisely this here (instead of using the
8143 if (c->ts.type == BT_CLASS)
8144 sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
8146 sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
8147 st = gfc_find_symtree (ns->sym_root, name);
8148 gcc_assert (st->n.sym->assoc);
8149 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
8150 st->n.sym->assoc->target->where = code->expr1->where;
8151 if (c->ts.type == BT_DERIVED)
8152 gfc_add_data_component (st->n.sym->assoc->target);
8154 new_st = gfc_get_code ();
8155 new_st->op = EXEC_BLOCK;
8156 new_st->ext.block.ns = gfc_build_block_ns (ns);
8157 new_st->ext.block.ns->code = body->next;
8158 body->next = new_st;
8160 /* Chain in the new list only if it is marked as dangling. Otherwise
8161 there is a CASE label overlap and this is already used. Just ignore,
8162 the error is diagonsed elsewhere. */
8163 if (st->n.sym->assoc->dangling)
8165 new_st->ext.block.assoc = st->n.sym->assoc;
8166 st->n.sym->assoc->dangling = 0;
8169 resolve_assoc_var (st->n.sym, false);
8172 /* Take out CLASS IS cases for separate treatment. */
8174 while (body && body->block)
8176 if (body->block->ext.block.case_list->ts.type == BT_CLASS)
8178 /* Add to class_is list. */
8179 if (class_is == NULL)
8181 class_is = body->block;
8186 for (tail = class_is; tail->block; tail = tail->block) ;
8187 tail->block = body->block;
8190 /* Remove from EXEC_SELECT list. */
8191 body->block = body->block->block;
8204 /* Add a default case to hold the CLASS IS cases. */
8205 for (tail = code; tail->block; tail = tail->block) ;
8206 tail->block = gfc_get_code ();
8208 tail->op = EXEC_SELECT_TYPE;
8209 tail->ext.block.case_list = gfc_get_case ();
8210 tail->ext.block.case_list->ts.type = BT_UNKNOWN;
8212 default_case = tail;
8215 /* More than one CLASS IS block? */
8216 if (class_is->block)
8220 /* Sort CLASS IS blocks by extension level. */
8224 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
8227 /* F03:C817 (check for doubles). */
8228 if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
8229 == c2->ext.block.case_list->ts.u.derived->hash_value)
8231 gfc_error ("Double CLASS IS block in SELECT TYPE "
8233 &c2->ext.block.case_list->where);
8236 if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
8237 < c2->ext.block.case_list->ts.u.derived->attr.extension)
8240 (*c1)->block = c2->block;
8250 /* Generate IF chain. */
8251 if_st = gfc_get_code ();
8252 if_st->op = EXEC_IF;
8254 for (body = class_is; body; body = body->block)
8256 new_st->block = gfc_get_code ();
8257 new_st = new_st->block;
8258 new_st->op = EXEC_IF;
8259 /* Set up IF condition: Call _gfortran_is_extension_of. */
8260 new_st->expr1 = gfc_get_expr ();
8261 new_st->expr1->expr_type = EXPR_FUNCTION;
8262 new_st->expr1->ts.type = BT_LOGICAL;
8263 new_st->expr1->ts.kind = 4;
8264 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
8265 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
8266 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
8267 /* Set up arguments. */
8268 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
8269 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
8270 new_st->expr1->value.function.actual->expr->where = code->loc;
8271 gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
8272 vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
8273 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
8274 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
8275 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
8276 new_st->next = body->next;
8278 if (default_case->next)
8280 new_st->block = gfc_get_code ();
8281 new_st = new_st->block;
8282 new_st->op = EXEC_IF;
8283 new_st->next = default_case->next;
8286 /* Replace CLASS DEFAULT code by the IF chain. */
8287 default_case->next = if_st;
8290 /* Resolve the internal code. This can not be done earlier because
8291 it requires that the sym->assoc of selectors is set already. */
8292 gfc_current_ns = ns;
8293 gfc_resolve_blocks (code->block, gfc_current_ns);
8294 gfc_current_ns = old_ns;
8296 resolve_select (code, true);
8300 /* Resolve a transfer statement. This is making sure that:
8301 -- a derived type being transferred has only non-pointer components
8302 -- a derived type being transferred doesn't have private components, unless
8303 it's being transferred from the module where the type was defined
8304 -- we're not trying to transfer a whole assumed size array. */
8307 resolve_transfer (gfc_code *code)
8316 while (exp != NULL && exp->expr_type == EXPR_OP
8317 && exp->value.op.op == INTRINSIC_PARENTHESES)
8318 exp = exp->value.op.op1;
8320 if (exp && exp->expr_type == EXPR_NULL && exp->ts.type == BT_UNKNOWN)
8322 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8323 "MOLD=", &exp->where);
8327 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
8328 && exp->expr_type != EXPR_FUNCTION))
8331 /* If we are reading, the variable will be changed. Note that
8332 code->ext.dt may be NULL if the TRANSFER is related to
8333 an INQUIRE statement -- but in this case, we are not reading, either. */
8334 if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
8335 && gfc_check_vardef_context (exp, false, false, _("item in READ"))
8339 sym = exp->symtree->n.sym;
8342 /* Go to actual component transferred. */
8343 for (ref = exp->ref; ref; ref = ref->next)
8344 if (ref->type == REF_COMPONENT)
8345 ts = &ref->u.c.component->ts;
8347 if (ts->type == BT_CLASS)
8349 /* FIXME: Test for defined input/output. */
8350 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8351 "it is processed by a defined input/output procedure",
8356 if (ts->type == BT_DERIVED)
8358 /* Check that transferred derived type doesn't contain POINTER
8360 if (ts->u.derived->attr.pointer_comp)
8362 gfc_error ("Data transfer element at %L cannot have POINTER "
8363 "components unless it is processed by a defined "
8364 "input/output procedure", &code->loc);
8369 if (ts->u.derived->attr.proc_pointer_comp)
8371 gfc_error ("Data transfer element at %L cannot have "
8372 "procedure pointer components", &code->loc);
8376 if (ts->u.derived->attr.alloc_comp)
8378 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8379 "components unless it is processed by a defined "
8380 "input/output procedure", &code->loc);
8384 if (derived_inaccessible (ts->u.derived))
8386 gfc_error ("Data transfer element at %L cannot have "
8387 "PRIVATE components",&code->loc);
8392 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
8393 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
8395 gfc_error ("Data transfer element at %L cannot be a full reference to "
8396 "an assumed-size array", &code->loc);
8402 /*********** Toplevel code resolution subroutines ***********/
8404 /* Find the set of labels that are reachable from this block. We also
8405 record the last statement in each block. */
8408 find_reachable_labels (gfc_code *block)
8415 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
8417 /* Collect labels in this block. We don't keep those corresponding
8418 to END {IF|SELECT}, these are checked in resolve_branch by going
8419 up through the code_stack. */
8420 for (c = block; c; c = c->next)
8422 if (c->here && c->op != EXEC_END_NESTED_BLOCK)
8423 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8426 /* Merge with labels from parent block. */
8429 gcc_assert (cs_base->prev->reachable_labels);
8430 bitmap_ior_into (cs_base->reachable_labels,
8431 cs_base->prev->reachable_labels);
8437 resolve_lock_unlock (gfc_code *code)
8439 if (code->expr1->ts.type != BT_DERIVED
8440 || code->expr1->expr_type != EXPR_VARIABLE
8441 || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
8442 || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
8443 || code->expr1->rank != 0
8444 || (!gfc_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1)))
8445 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8446 &code->expr1->where);
8450 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8451 || code->expr2->expr_type != EXPR_VARIABLE))
8452 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8453 &code->expr2->where);
8456 && gfc_check_vardef_context (code->expr2, false, false,
8457 _("STAT variable")) == FAILURE)
8462 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8463 || code->expr3->expr_type != EXPR_VARIABLE))
8464 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8465 &code->expr3->where);
8468 && gfc_check_vardef_context (code->expr3, false, false,
8469 _("ERRMSG variable")) == FAILURE)
8472 /* Check ACQUIRED_LOCK. */
8474 && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
8475 || code->expr4->expr_type != EXPR_VARIABLE))
8476 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8477 "variable", &code->expr4->where);
8480 && gfc_check_vardef_context (code->expr4, false, false,
8481 _("ACQUIRED_LOCK variable")) == FAILURE)
8487 resolve_sync (gfc_code *code)
8489 /* Check imageset. The * case matches expr1 == NULL. */
8492 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8493 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8494 "INTEGER expression", &code->expr1->where);
8495 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8496 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8497 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8498 &code->expr1->where);
8499 else if (code->expr1->expr_type == EXPR_ARRAY
8500 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8502 gfc_constructor *cons;
8503 cons = gfc_constructor_first (code->expr1->value.constructor);
8504 for (; cons; cons = gfc_constructor_next (cons))
8505 if (cons->expr->expr_type == EXPR_CONSTANT
8506 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8507 gfc_error ("Imageset argument at %L must between 1 and "
8508 "num_images()", &cons->expr->where);
8514 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8515 || code->expr2->expr_type != EXPR_VARIABLE))
8516 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8517 &code->expr2->where);
8521 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8522 || code->expr3->expr_type != EXPR_VARIABLE))
8523 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8524 &code->expr3->where);
8528 /* Given a branch to a label, see if the branch is conforming.
8529 The code node describes where the branch is located. */
8532 resolve_branch (gfc_st_label *label, gfc_code *code)
8539 /* Step one: is this a valid branching target? */
8541 if (label->defined == ST_LABEL_UNKNOWN)
8543 gfc_error ("Label %d referenced at %L is never defined", label->value,
8548 if (label->defined != ST_LABEL_TARGET)
8550 gfc_error ("Statement at %L is not a valid branch target statement "
8551 "for the branch statement at %L", &label->where, &code->loc);
8555 /* Step two: make sure this branch is not a branch to itself ;-) */
8557 if (code->here == label)
8559 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8563 /* Step three: See if the label is in the same block as the
8564 branching statement. The hard work has been done by setting up
8565 the bitmap reachable_labels. */
8567 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8569 /* Check now whether there is a CRITICAL construct; if so, check
8570 whether the label is still visible outside of the CRITICAL block,
8571 which is invalid. */
8572 for (stack = cs_base; stack; stack = stack->prev)
8574 if (stack->current->op == EXEC_CRITICAL
8575 && bitmap_bit_p (stack->reachable_labels, label->value))
8576 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8577 "label at %L", &code->loc, &label->where);
8578 else if (stack->current->op == EXEC_DO_CONCURRENT
8579 && bitmap_bit_p (stack->reachable_labels, label->value))
8580 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8581 "for label at %L", &code->loc, &label->where);
8587 /* Step four: If we haven't found the label in the bitmap, it may
8588 still be the label of the END of the enclosing block, in which
8589 case we find it by going up the code_stack. */
8591 for (stack = cs_base; stack; stack = stack->prev)
8593 if (stack->current->next && stack->current->next->here == label)
8595 if (stack->current->op == EXEC_CRITICAL)
8597 /* Note: A label at END CRITICAL does not leave the CRITICAL
8598 construct as END CRITICAL is still part of it. */
8599 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8600 " at %L", &code->loc, &label->where);
8603 else if (stack->current->op == EXEC_DO_CONCURRENT)
8605 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8606 "label at %L", &code->loc, &label->where);
8613 gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
8617 /* The label is not in an enclosing block, so illegal. This was
8618 allowed in Fortran 66, so we allow it as extension. No
8619 further checks are necessary in this case. */
8620 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
8621 "as the GOTO statement at %L", &label->where,
8627 /* Check whether EXPR1 has the same shape as EXPR2. */
8630 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
8632 mpz_t shape[GFC_MAX_DIMENSIONS];
8633 mpz_t shape2[GFC_MAX_DIMENSIONS];
8634 gfc_try result = FAILURE;
8637 /* Compare the rank. */
8638 if (expr1->rank != expr2->rank)
8641 /* Compare the size of each dimension. */
8642 for (i=0; i<expr1->rank; i++)
8644 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
8647 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
8650 if (mpz_cmp (shape[i], shape2[i]))
8654 /* When either of the two expression is an assumed size array, we
8655 ignore the comparison of dimension sizes. */
8660 gfc_clear_shape (shape, i);
8661 gfc_clear_shape (shape2, i);
8666 /* Check whether a WHERE assignment target or a WHERE mask expression
8667 has the same shape as the outmost WHERE mask expression. */
8670 resolve_where (gfc_code *code, gfc_expr *mask)
8676 cblock = code->block;
8678 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8679 In case of nested WHERE, only the outmost one is stored. */
8680 if (mask == NULL) /* outmost WHERE */
8682 else /* inner WHERE */
8689 /* Check if the mask-expr has a consistent shape with the
8690 outmost WHERE mask-expr. */
8691 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8692 gfc_error ("WHERE mask at %L has inconsistent shape",
8693 &cblock->expr1->where);
8696 /* the assignment statement of a WHERE statement, or the first
8697 statement in where-body-construct of a WHERE construct */
8698 cnext = cblock->next;
8703 /* WHERE assignment statement */
8706 /* Check shape consistent for WHERE assignment target. */
8707 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8708 gfc_error ("WHERE assignment target at %L has "
8709 "inconsistent shape", &cnext->expr1->where);
8713 case EXEC_ASSIGN_CALL:
8714 resolve_call (cnext);
8715 if (!cnext->resolved_sym->attr.elemental)
8716 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8717 &cnext->ext.actual->expr->where);
8720 /* WHERE or WHERE construct is part of a where-body-construct */
8722 resolve_where (cnext, e);
8726 gfc_error ("Unsupported statement inside WHERE at %L",
8729 /* the next statement within the same where-body-construct */
8730 cnext = cnext->next;
8732 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8733 cblock = cblock->block;
8738 /* Resolve assignment in FORALL construct.
8739 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8740 FORALL index variables. */
8743 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8747 for (n = 0; n < nvar; n++)
8749 gfc_symbol *forall_index;
8751 forall_index = var_expr[n]->symtree->n.sym;
8753 /* Check whether the assignment target is one of the FORALL index
8755 if ((code->expr1->expr_type == EXPR_VARIABLE)
8756 && (code->expr1->symtree->n.sym == forall_index))
8757 gfc_error ("Assignment to a FORALL index variable at %L",
8758 &code->expr1->where);
8761 /* If one of the FORALL index variables doesn't appear in the
8762 assignment variable, then there could be a many-to-one
8763 assignment. Emit a warning rather than an error because the
8764 mask could be resolving this problem. */
8765 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8766 gfc_warning ("The FORALL with index '%s' is not used on the "
8767 "left side of the assignment at %L and so might "
8768 "cause multiple assignment to this object",
8769 var_expr[n]->symtree->name, &code->expr1->where);
8775 /* Resolve WHERE statement in FORALL construct. */
8778 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8779 gfc_expr **var_expr)
8784 cblock = code->block;
8787 /* the assignment statement of a WHERE statement, or the first
8788 statement in where-body-construct of a WHERE construct */
8789 cnext = cblock->next;
8794 /* WHERE assignment statement */
8796 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8799 /* WHERE operator assignment statement */
8800 case EXEC_ASSIGN_CALL:
8801 resolve_call (cnext);
8802 if (!cnext->resolved_sym->attr.elemental)
8803 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8804 &cnext->ext.actual->expr->where);
8807 /* WHERE or WHERE construct is part of a where-body-construct */
8809 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8813 gfc_error ("Unsupported statement inside WHERE at %L",
8816 /* the next statement within the same where-body-construct */
8817 cnext = cnext->next;
8819 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8820 cblock = cblock->block;
8825 /* Traverse the FORALL body to check whether the following errors exist:
8826 1. For assignment, check if a many-to-one assignment happens.
8827 2. For WHERE statement, check the WHERE body to see if there is any
8828 many-to-one assignment. */
8831 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8835 c = code->block->next;
8841 case EXEC_POINTER_ASSIGN:
8842 gfc_resolve_assign_in_forall (c, nvar, var_expr);
8845 case EXEC_ASSIGN_CALL:
8849 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8850 there is no need to handle it here. */
8854 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8859 /* The next statement in the FORALL body. */
8865 /* Counts the number of iterators needed inside a forall construct, including
8866 nested forall constructs. This is used to allocate the needed memory
8867 in gfc_resolve_forall. */
8870 gfc_count_forall_iterators (gfc_code *code)
8872 int max_iters, sub_iters, current_iters;
8873 gfc_forall_iterator *fa;
8875 gcc_assert(code->op == EXEC_FORALL);
8879 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8882 code = code->block->next;
8886 if (code->op == EXEC_FORALL)
8888 sub_iters = gfc_count_forall_iterators (code);
8889 if (sub_iters > max_iters)
8890 max_iters = sub_iters;
8895 return current_iters + max_iters;
8899 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8900 gfc_resolve_forall_body to resolve the FORALL body. */
8903 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8905 static gfc_expr **var_expr;
8906 static int total_var = 0;
8907 static int nvar = 0;
8909 gfc_forall_iterator *fa;
8914 /* Start to resolve a FORALL construct */
8915 if (forall_save == 0)
8917 /* Count the total number of FORALL index in the nested FORALL
8918 construct in order to allocate the VAR_EXPR with proper size. */
8919 total_var = gfc_count_forall_iterators (code);
8921 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8922 var_expr = XCNEWVEC (gfc_expr *, total_var);
8925 /* The information about FORALL iterator, including FORALL index start, end
8926 and stride. The FORALL index can not appear in start, end or stride. */
8927 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8929 /* Check if any outer FORALL index name is the same as the current
8931 for (i = 0; i < nvar; i++)
8933 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8935 gfc_error ("An outer FORALL construct already has an index "
8936 "with this name %L", &fa->var->where);
8940 /* Record the current FORALL index. */
8941 var_expr[nvar] = gfc_copy_expr (fa->var);
8945 /* No memory leak. */
8946 gcc_assert (nvar <= total_var);
8949 /* Resolve the FORALL body. */
8950 gfc_resolve_forall_body (code, nvar, var_expr);
8952 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8953 gfc_resolve_blocks (code->block, ns);
8957 /* Free only the VAR_EXPRs allocated in this frame. */
8958 for (i = nvar; i < tmp; i++)
8959 gfc_free_expr (var_expr[i]);
8963 /* We are in the outermost FORALL construct. */
8964 gcc_assert (forall_save == 0);
8966 /* VAR_EXPR is not needed any more. */
8973 /* Resolve a BLOCK construct statement. */
8976 resolve_block_construct (gfc_code* code)
8978 /* Resolve the BLOCK's namespace. */
8979 gfc_resolve (code->ext.block.ns);
8981 /* For an ASSOCIATE block, the associations (and their targets) are already
8982 resolved during resolve_symbol. */
8986 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8989 static void resolve_code (gfc_code *, gfc_namespace *);
8992 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8996 for (; b; b = b->block)
8998 t = gfc_resolve_expr (b->expr1);
8999 if (gfc_resolve_expr (b->expr2) == FAILURE)
9005 if (t == SUCCESS && b->expr1 != NULL
9006 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
9007 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9014 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
9015 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9020 resolve_branch (b->label1, b);
9024 resolve_block_construct (b);
9028 case EXEC_SELECT_TYPE:
9032 case EXEC_DO_CONCURRENT:
9040 case EXEC_OMP_ATOMIC:
9041 case EXEC_OMP_CRITICAL:
9043 case EXEC_OMP_MASTER:
9044 case EXEC_OMP_ORDERED:
9045 case EXEC_OMP_PARALLEL:
9046 case EXEC_OMP_PARALLEL_DO:
9047 case EXEC_OMP_PARALLEL_SECTIONS:
9048 case EXEC_OMP_PARALLEL_WORKSHARE:
9049 case EXEC_OMP_SECTIONS:
9050 case EXEC_OMP_SINGLE:
9052 case EXEC_OMP_TASKWAIT:
9053 case EXEC_OMP_TASKYIELD:
9054 case EXEC_OMP_WORKSHARE:
9058 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9061 resolve_code (b->next, ns);
9066 /* Does everything to resolve an ordinary assignment. Returns true
9067 if this is an interface assignment. */
9069 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
9079 if (gfc_extend_assign (code, ns) == SUCCESS)
9083 if (code->op == EXEC_ASSIGN_CALL)
9085 lhs = code->ext.actual->expr;
9086 rhsptr = &code->ext.actual->next->expr;
9090 gfc_actual_arglist* args;
9091 gfc_typebound_proc* tbp;
9093 gcc_assert (code->op == EXEC_COMPCALL);
9095 args = code->expr1->value.compcall.actual;
9097 rhsptr = &args->next->expr;
9099 tbp = code->expr1->value.compcall.tbp;
9100 gcc_assert (!tbp->is_generic);
9103 /* Make a temporary rhs when there is a default initializer
9104 and rhs is the same symbol as the lhs. */
9105 if ((*rhsptr)->expr_type == EXPR_VARIABLE
9106 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
9107 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
9108 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
9109 *rhsptr = gfc_get_parentheses (*rhsptr);
9118 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
9119 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9120 &code->loc) == FAILURE)
9123 /* Handle the case of a BOZ literal on the RHS. */
9124 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
9127 if (gfc_option.warn_surprising)
9128 gfc_warning ("BOZ literal at %L is bitwise transferred "
9129 "non-integer symbol '%s'", &code->loc,
9130 lhs->symtree->n.sym->name);
9132 if (!gfc_convert_boz (rhs, &lhs->ts))
9134 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
9136 if (rc == ARITH_UNDERFLOW)
9137 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9138 ". This check can be disabled with the option "
9139 "-fno-range-check", &rhs->where);
9140 else if (rc == ARITH_OVERFLOW)
9141 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9142 ". This check can be disabled with the option "
9143 "-fno-range-check", &rhs->where);
9144 else if (rc == ARITH_NAN)
9145 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9146 ". This check can be disabled with the option "
9147 "-fno-range-check", &rhs->where);
9152 if (lhs->ts.type == BT_CHARACTER
9153 && gfc_option.warn_character_truncation)
9155 if (lhs->ts.u.cl != NULL
9156 && lhs->ts.u.cl->length != NULL
9157 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9158 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
9160 if (rhs->expr_type == EXPR_CONSTANT)
9161 rlen = rhs->value.character.length;
9163 else if (rhs->ts.u.cl != NULL
9164 && rhs->ts.u.cl->length != NULL
9165 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9166 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
9168 if (rlen && llen && rlen > llen)
9169 gfc_warning_now ("CHARACTER expression will be truncated "
9170 "in assignment (%d/%d) at %L",
9171 llen, rlen, &code->loc);
9174 /* Ensure that a vector index expression for the lvalue is evaluated
9175 to a temporary if the lvalue symbol is referenced in it. */
9178 for (ref = lhs->ref; ref; ref= ref->next)
9179 if (ref->type == REF_ARRAY)
9181 for (n = 0; n < ref->u.ar.dimen; n++)
9182 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
9183 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
9184 ref->u.ar.start[n]))
9186 = gfc_get_parentheses (ref->u.ar.start[n]);
9190 if (gfc_pure (NULL))
9192 if (lhs->ts.type == BT_DERIVED
9193 && lhs->expr_type == EXPR_VARIABLE
9194 && lhs->ts.u.derived->attr.pointer_comp
9195 && rhs->expr_type == EXPR_VARIABLE
9196 && (gfc_impure_variable (rhs->symtree->n.sym)
9197 || gfc_is_coindexed (rhs)))
9200 if (gfc_is_coindexed (rhs))
9201 gfc_error ("Coindexed expression at %L is assigned to "
9202 "a derived type variable with a POINTER "
9203 "component in a PURE procedure",
9206 gfc_error ("The impure variable at %L is assigned to "
9207 "a derived type variable with a POINTER "
9208 "component in a PURE procedure (12.6)",
9213 /* Fortran 2008, C1283. */
9214 if (gfc_is_coindexed (lhs))
9216 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9217 "procedure", &rhs->where);
9222 if (gfc_implicit_pure (NULL))
9224 if (lhs->expr_type == EXPR_VARIABLE
9225 && lhs->symtree->n.sym != gfc_current_ns->proc_name
9226 && lhs->symtree->n.sym->ns != gfc_current_ns)
9227 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9229 if (lhs->ts.type == BT_DERIVED
9230 && lhs->expr_type == EXPR_VARIABLE
9231 && lhs->ts.u.derived->attr.pointer_comp
9232 && rhs->expr_type == EXPR_VARIABLE
9233 && (gfc_impure_variable (rhs->symtree->n.sym)
9234 || gfc_is_coindexed (rhs)))
9235 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9237 /* Fortran 2008, C1283. */
9238 if (gfc_is_coindexed (lhs))
9239 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9243 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9244 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9245 if (lhs->ts.type == BT_CLASS)
9247 gfc_error ("Variable must not be polymorphic in intrinsic assignment at "
9248 "%L - check that there is a matching specific subroutine "
9249 "for '=' operator", &lhs->where);
9253 /* F2008, Section 7.2.1.2. */
9254 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
9256 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9257 "component in assignment at %L", &lhs->where);
9261 gfc_check_assign (lhs, rhs, 1);
9266 /* Given a block of code, recursively resolve everything pointed to by this
9270 resolve_code (gfc_code *code, gfc_namespace *ns)
9272 int omp_workshare_save;
9273 int forall_save, do_concurrent_save;
9277 frame.prev = cs_base;
9281 find_reachable_labels (code);
9283 for (; code; code = code->next)
9285 frame.current = code;
9286 forall_save = forall_flag;
9287 do_concurrent_save = do_concurrent_flag;
9289 if (code->op == EXEC_FORALL)
9292 gfc_resolve_forall (code, ns, forall_save);
9295 else if (code->block)
9297 omp_workshare_save = -1;
9300 case EXEC_OMP_PARALLEL_WORKSHARE:
9301 omp_workshare_save = omp_workshare_flag;
9302 omp_workshare_flag = 1;
9303 gfc_resolve_omp_parallel_blocks (code, ns);
9305 case EXEC_OMP_PARALLEL:
9306 case EXEC_OMP_PARALLEL_DO:
9307 case EXEC_OMP_PARALLEL_SECTIONS:
9309 omp_workshare_save = omp_workshare_flag;
9310 omp_workshare_flag = 0;
9311 gfc_resolve_omp_parallel_blocks (code, ns);
9314 gfc_resolve_omp_do_blocks (code, ns);
9316 case EXEC_SELECT_TYPE:
9317 /* Blocks are handled in resolve_select_type because we have
9318 to transform the SELECT TYPE into ASSOCIATE first. */
9320 case EXEC_DO_CONCURRENT:
9321 do_concurrent_flag = 1;
9322 gfc_resolve_blocks (code->block, ns);
9323 do_concurrent_flag = 2;
9325 case EXEC_OMP_WORKSHARE:
9326 omp_workshare_save = omp_workshare_flag;
9327 omp_workshare_flag = 1;
9330 gfc_resolve_blocks (code->block, ns);
9334 if (omp_workshare_save != -1)
9335 omp_workshare_flag = omp_workshare_save;
9339 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
9340 t = gfc_resolve_expr (code->expr1);
9341 forall_flag = forall_save;
9342 do_concurrent_flag = do_concurrent_save;
9344 if (gfc_resolve_expr (code->expr2) == FAILURE)
9347 if (code->op == EXEC_ALLOCATE
9348 && gfc_resolve_expr (code->expr3) == FAILURE)
9354 case EXEC_END_BLOCK:
9355 case EXEC_END_NESTED_BLOCK:
9359 case EXEC_ERROR_STOP:
9363 case EXEC_ASSIGN_CALL:
9368 case EXEC_SYNC_IMAGES:
9369 case EXEC_SYNC_MEMORY:
9370 resolve_sync (code);
9375 resolve_lock_unlock (code);
9379 /* Keep track of which entry we are up to. */
9380 current_entry_id = code->ext.entry->id;
9384 resolve_where (code, NULL);
9388 if (code->expr1 != NULL)
9390 if (code->expr1->ts.type != BT_INTEGER)
9391 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9392 "INTEGER variable", &code->expr1->where);
9393 else if (code->expr1->symtree->n.sym->attr.assign != 1)
9394 gfc_error ("Variable '%s' has not been assigned a target "
9395 "label at %L", code->expr1->symtree->n.sym->name,
9396 &code->expr1->where);
9399 resolve_branch (code->label1, code);
9403 if (code->expr1 != NULL
9404 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
9405 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9406 "INTEGER return specifier", &code->expr1->where);
9409 case EXEC_INIT_ASSIGN:
9410 case EXEC_END_PROCEDURE:
9417 if (gfc_check_vardef_context (code->expr1, false, false,
9418 _("assignment")) == FAILURE)
9421 if (resolve_ordinary_assign (code, ns))
9423 if (code->op == EXEC_COMPCALL)
9430 case EXEC_LABEL_ASSIGN:
9431 if (code->label1->defined == ST_LABEL_UNKNOWN)
9432 gfc_error ("Label %d referenced at %L is never defined",
9433 code->label1->value, &code->label1->where);
9435 && (code->expr1->expr_type != EXPR_VARIABLE
9436 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
9437 || code->expr1->symtree->n.sym->ts.kind
9438 != gfc_default_integer_kind
9439 || code->expr1->symtree->n.sym->as != NULL))
9440 gfc_error ("ASSIGN statement at %L requires a scalar "
9441 "default INTEGER variable", &code->expr1->where);
9444 case EXEC_POINTER_ASSIGN:
9451 /* This is both a variable definition and pointer assignment
9452 context, so check both of them. For rank remapping, a final
9453 array ref may be present on the LHS and fool gfc_expr_attr
9454 used in gfc_check_vardef_context. Remove it. */
9455 e = remove_last_array_ref (code->expr1);
9456 t = gfc_check_vardef_context (e, true, false,
9457 _("pointer assignment"));
9459 t = gfc_check_vardef_context (e, false, false,
9460 _("pointer assignment"));
9465 gfc_check_pointer_assign (code->expr1, code->expr2);
9469 case EXEC_ARITHMETIC_IF:
9471 && code->expr1->ts.type != BT_INTEGER
9472 && code->expr1->ts.type != BT_REAL)
9473 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9474 "expression", &code->expr1->where);
9476 resolve_branch (code->label1, code);
9477 resolve_branch (code->label2, code);
9478 resolve_branch (code->label3, code);
9482 if (t == SUCCESS && code->expr1 != NULL
9483 && (code->expr1->ts.type != BT_LOGICAL
9484 || code->expr1->rank != 0))
9485 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9486 &code->expr1->where);
9491 resolve_call (code);
9496 resolve_typebound_subroutine (code);
9500 resolve_ppc_call (code);
9504 /* Select is complicated. Also, a SELECT construct could be
9505 a transformed computed GOTO. */
9506 resolve_select (code, false);
9509 case EXEC_SELECT_TYPE:
9510 resolve_select_type (code, ns);
9514 resolve_block_construct (code);
9518 if (code->ext.iterator != NULL)
9520 gfc_iterator *iter = code->ext.iterator;
9521 if (gfc_resolve_iterator (iter, true) != FAILURE)
9522 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
9527 if (code->expr1 == NULL)
9528 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9530 && (code->expr1->rank != 0
9531 || code->expr1->ts.type != BT_LOGICAL))
9532 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9533 "a scalar LOGICAL expression", &code->expr1->where);
9538 resolve_allocate_deallocate (code, "ALLOCATE");
9542 case EXEC_DEALLOCATE:
9544 resolve_allocate_deallocate (code, "DEALLOCATE");
9549 if (gfc_resolve_open (code->ext.open) == FAILURE)
9552 resolve_branch (code->ext.open->err, code);
9556 if (gfc_resolve_close (code->ext.close) == FAILURE)
9559 resolve_branch (code->ext.close->err, code);
9562 case EXEC_BACKSPACE:
9566 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
9569 resolve_branch (code->ext.filepos->err, code);
9573 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9576 resolve_branch (code->ext.inquire->err, code);
9580 gcc_assert (code->ext.inquire != NULL);
9581 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9584 resolve_branch (code->ext.inquire->err, code);
9588 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
9591 resolve_branch (code->ext.wait->err, code);
9592 resolve_branch (code->ext.wait->end, code);
9593 resolve_branch (code->ext.wait->eor, code);
9598 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
9601 resolve_branch (code->ext.dt->err, code);
9602 resolve_branch (code->ext.dt->end, code);
9603 resolve_branch (code->ext.dt->eor, code);
9607 resolve_transfer (code);
9610 case EXEC_DO_CONCURRENT:
9612 resolve_forall_iterators (code->ext.forall_iterator);
9614 if (code->expr1 != NULL
9615 && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
9616 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9617 "expression", &code->expr1->where);
9620 case EXEC_OMP_ATOMIC:
9621 case EXEC_OMP_BARRIER:
9622 case EXEC_OMP_CRITICAL:
9623 case EXEC_OMP_FLUSH:
9625 case EXEC_OMP_MASTER:
9626 case EXEC_OMP_ORDERED:
9627 case EXEC_OMP_SECTIONS:
9628 case EXEC_OMP_SINGLE:
9629 case EXEC_OMP_TASKWAIT:
9630 case EXEC_OMP_TASKYIELD:
9631 case EXEC_OMP_WORKSHARE:
9632 gfc_resolve_omp_directive (code, ns);
9635 case EXEC_OMP_PARALLEL:
9636 case EXEC_OMP_PARALLEL_DO:
9637 case EXEC_OMP_PARALLEL_SECTIONS:
9638 case EXEC_OMP_PARALLEL_WORKSHARE:
9640 omp_workshare_save = omp_workshare_flag;
9641 omp_workshare_flag = 0;
9642 gfc_resolve_omp_directive (code, ns);
9643 omp_workshare_flag = omp_workshare_save;
9647 gfc_internal_error ("resolve_code(): Bad statement code");
9651 cs_base = frame.prev;
9655 /* Resolve initial values and make sure they are compatible with
9659 resolve_values (gfc_symbol *sym)
9663 if (sym->value == NULL)
9666 if (sym->value->expr_type == EXPR_STRUCTURE)
9667 t= resolve_structure_cons (sym->value, 1);
9669 t = gfc_resolve_expr (sym->value);
9674 gfc_check_assign_symbol (sym, sym->value);
9678 /* Verify the binding labels for common blocks that are BIND(C). The label
9679 for a BIND(C) common block must be identical in all scoping units in which
9680 the common block is declared. Further, the binding label can not collide
9681 with any other global entity in the program. */
9684 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
9686 if (comm_block_tree->n.common->is_bind_c == 1)
9688 gfc_gsymbol *binding_label_gsym;
9689 gfc_gsymbol *comm_name_gsym;
9690 const char * bind_label = comm_block_tree->n.common->binding_label
9691 ? comm_block_tree->n.common->binding_label : "";
9693 /* See if a global symbol exists by the common block's name. It may
9694 be NULL if the common block is use-associated. */
9695 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
9696 comm_block_tree->n.common->name);
9697 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
9698 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9699 "with the global entity '%s' at %L",
9701 comm_block_tree->n.common->name,
9702 &(comm_block_tree->n.common->where),
9703 comm_name_gsym->name, &(comm_name_gsym->where));
9704 else if (comm_name_gsym != NULL
9705 && strcmp (comm_name_gsym->name,
9706 comm_block_tree->n.common->name) == 0)
9708 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9710 if (comm_name_gsym->binding_label == NULL)
9711 /* No binding label for common block stored yet; save this one. */
9712 comm_name_gsym->binding_label = bind_label;
9713 else if (strcmp (comm_name_gsym->binding_label, bind_label) != 0)
9715 /* Common block names match but binding labels do not. */
9716 gfc_error ("Binding label '%s' for common block '%s' at %L "
9717 "does not match the binding label '%s' for common "
9720 comm_block_tree->n.common->name,
9721 &(comm_block_tree->n.common->where),
9722 comm_name_gsym->binding_label,
9723 comm_name_gsym->name,
9724 &(comm_name_gsym->where));
9729 /* There is no binding label (NAME="") so we have nothing further to
9730 check and nothing to add as a global symbol for the label. */
9731 if (!comm_block_tree->n.common->binding_label)
9734 binding_label_gsym =
9735 gfc_find_gsymbol (gfc_gsym_root,
9736 comm_block_tree->n.common->binding_label);
9737 if (binding_label_gsym == NULL)
9739 /* Need to make a global symbol for the binding label to prevent
9740 it from colliding with another. */
9741 binding_label_gsym =
9742 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9743 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9744 binding_label_gsym->type = GSYM_COMMON;
9748 /* If comm_name_gsym is NULL, the name common block is use
9749 associated and the name could be colliding. */
9750 if (binding_label_gsym->type != GSYM_COMMON)
9751 gfc_error ("Binding label '%s' for common block '%s' at %L "
9752 "collides with the global entity '%s' at %L",
9753 comm_block_tree->n.common->binding_label,
9754 comm_block_tree->n.common->name,
9755 &(comm_block_tree->n.common->where),
9756 binding_label_gsym->name,
9757 &(binding_label_gsym->where));
9758 else if (comm_name_gsym != NULL
9759 && (strcmp (binding_label_gsym->name,
9760 comm_name_gsym->binding_label) != 0)
9761 && (strcmp (binding_label_gsym->sym_name,
9762 comm_name_gsym->name) != 0))
9763 gfc_error ("Binding label '%s' for common block '%s' at %L "
9764 "collides with global entity '%s' at %L",
9765 binding_label_gsym->name, binding_label_gsym->sym_name,
9766 &(comm_block_tree->n.common->where),
9767 comm_name_gsym->name, &(comm_name_gsym->where));
9775 /* Verify any BIND(C) derived types in the namespace so we can report errors
9776 for them once, rather than for each variable declared of that type. */
9779 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9781 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9782 && derived_sym->attr.is_bind_c == 1)
9783 verify_bind_c_derived_type (derived_sym);
9789 /* Verify that any binding labels used in a given namespace do not collide
9790 with the names or binding labels of any global symbols. */
9793 gfc_verify_binding_labels (gfc_symbol *sym)
9797 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9798 && sym->attr.flavor != FL_DERIVED && sym->binding_label)
9800 gfc_gsymbol *bind_c_sym;
9802 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9803 if (bind_c_sym != NULL
9804 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9806 if (sym->attr.if_source == IFSRC_DECL
9807 && (bind_c_sym->type != GSYM_SUBROUTINE
9808 && bind_c_sym->type != GSYM_FUNCTION)
9809 && ((sym->attr.contained == 1
9810 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9811 || (sym->attr.use_assoc == 1
9812 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9814 /* Make sure global procedures don't collide with anything. */
9815 gfc_error ("Binding label '%s' at %L collides with the global "
9816 "entity '%s' at %L", sym->binding_label,
9817 &(sym->declared_at), bind_c_sym->name,
9818 &(bind_c_sym->where));
9821 else if (sym->attr.contained == 0
9822 && (sym->attr.if_source == IFSRC_IFBODY
9823 && sym->attr.flavor == FL_PROCEDURE)
9824 && (bind_c_sym->sym_name != NULL
9825 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9827 /* Make sure procedures in interface bodies don't collide. */
9828 gfc_error ("Binding label '%s' in interface body at %L collides "
9829 "with the global entity '%s' at %L",
9831 &(sym->declared_at), bind_c_sym->name,
9832 &(bind_c_sym->where));
9835 else if (sym->attr.contained == 0
9836 && sym->attr.if_source == IFSRC_UNKNOWN)
9837 if ((sym->attr.use_assoc && bind_c_sym->mod_name
9838 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9839 || sym->attr.use_assoc == 0)
9841 gfc_error ("Binding label '%s' at %L collides with global "
9842 "entity '%s' at %L", sym->binding_label,
9843 &(sym->declared_at), bind_c_sym->name,
9844 &(bind_c_sym->where));
9849 /* Clear the binding label to prevent checking multiple times. */
9850 sym->binding_label = NULL;
9852 else if (bind_c_sym == NULL)
9854 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9855 bind_c_sym->where = sym->declared_at;
9856 bind_c_sym->sym_name = sym->name;
9858 if (sym->attr.use_assoc == 1)
9859 bind_c_sym->mod_name = sym->module;
9861 if (sym->ns->proc_name != NULL)
9862 bind_c_sym->mod_name = sym->ns->proc_name->name;
9864 if (sym->attr.contained == 0)
9866 if (sym->attr.subroutine)
9867 bind_c_sym->type = GSYM_SUBROUTINE;
9868 else if (sym->attr.function)
9869 bind_c_sym->type = GSYM_FUNCTION;
9877 /* Resolve an index expression. */
9880 resolve_index_expr (gfc_expr *e)
9882 if (gfc_resolve_expr (e) == FAILURE)
9885 if (gfc_simplify_expr (e, 0) == FAILURE)
9888 if (gfc_specification_expr (e) == FAILURE)
9895 /* Resolve a charlen structure. */
9898 resolve_charlen (gfc_charlen *cl)
9907 specification_expr = 1;
9909 if (resolve_index_expr (cl->length) == FAILURE)
9911 specification_expr = 0;
9915 /* "If the character length parameter value evaluates to a negative
9916 value, the length of character entities declared is zero." */
9917 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9919 if (gfc_option.warn_surprising)
9920 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9921 " the length has been set to zero",
9922 &cl->length->where, i);
9923 gfc_replace_expr (cl->length,
9924 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9927 /* Check that the character length is not too large. */
9928 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9929 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9930 && cl->length->ts.type == BT_INTEGER
9931 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9933 gfc_error ("String length at %L is too large", &cl->length->where);
9941 /* Test for non-constant shape arrays. */
9944 is_non_constant_shape_array (gfc_symbol *sym)
9950 not_constant = false;
9951 if (sym->as != NULL)
9953 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9954 has not been simplified; parameter array references. Do the
9955 simplification now. */
9956 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9958 e = sym->as->lower[i];
9959 if (e && (resolve_index_expr (e) == FAILURE
9960 || !gfc_is_constant_expr (e)))
9961 not_constant = true;
9962 e = sym->as->upper[i];
9963 if (e && (resolve_index_expr (e) == FAILURE
9964 || !gfc_is_constant_expr (e)))
9965 not_constant = true;
9968 return not_constant;
9971 /* Given a symbol and an initialization expression, add code to initialize
9972 the symbol to the function entry. */
9974 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9978 gfc_namespace *ns = sym->ns;
9980 /* Search for the function namespace if this is a contained
9981 function without an explicit result. */
9982 if (sym->attr.function && sym == sym->result
9983 && sym->name != sym->ns->proc_name->name)
9986 for (;ns; ns = ns->sibling)
9987 if (strcmp (ns->proc_name->name, sym->name) == 0)
9993 gfc_free_expr (init);
9997 /* Build an l-value expression for the result. */
9998 lval = gfc_lval_expr_from_sym (sym);
10000 /* Add the code at scope entry. */
10001 init_st = gfc_get_code ();
10002 init_st->next = ns->code;
10003 ns->code = init_st;
10005 /* Assign the default initializer to the l-value. */
10006 init_st->loc = sym->declared_at;
10007 init_st->op = EXEC_INIT_ASSIGN;
10008 init_st->expr1 = lval;
10009 init_st->expr2 = init;
10012 /* Assign the default initializer to a derived type variable or result. */
10015 apply_default_init (gfc_symbol *sym)
10017 gfc_expr *init = NULL;
10019 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
10022 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
10023 init = gfc_default_initializer (&sym->ts);
10025 if (init == NULL && sym->ts.type != BT_CLASS)
10028 build_init_assign (sym, init);
10029 sym->attr.referenced = 1;
10032 /* Build an initializer for a local integer, real, complex, logical, or
10033 character variable, based on the command line flags finit-local-zero,
10034 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10035 null if the symbol should not have a default initialization. */
10037 build_default_init_expr (gfc_symbol *sym)
10040 gfc_expr *init_expr;
10043 /* These symbols should never have a default initialization. */
10044 if (sym->attr.allocatable
10045 || sym->attr.external
10047 || sym->attr.pointer
10048 || sym->attr.in_equivalence
10049 || sym->attr.in_common
10052 || sym->attr.cray_pointee
10053 || sym->attr.cray_pointer
10057 /* Now we'll try to build an initializer expression. */
10058 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
10059 &sym->declared_at);
10061 /* We will only initialize integers, reals, complex, logicals, and
10062 characters, and only if the corresponding command-line flags
10063 were set. Otherwise, we free init_expr and return null. */
10064 switch (sym->ts.type)
10067 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
10068 mpz_set_si (init_expr->value.integer,
10069 gfc_option.flag_init_integer_value);
10072 gfc_free_expr (init_expr);
10078 switch (gfc_option.flag_init_real)
10080 case GFC_INIT_REAL_SNAN:
10081 init_expr->is_snan = 1;
10082 /* Fall through. */
10083 case GFC_INIT_REAL_NAN:
10084 mpfr_set_nan (init_expr->value.real);
10087 case GFC_INIT_REAL_INF:
10088 mpfr_set_inf (init_expr->value.real, 1);
10091 case GFC_INIT_REAL_NEG_INF:
10092 mpfr_set_inf (init_expr->value.real, -1);
10095 case GFC_INIT_REAL_ZERO:
10096 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
10100 gfc_free_expr (init_expr);
10107 switch (gfc_option.flag_init_real)
10109 case GFC_INIT_REAL_SNAN:
10110 init_expr->is_snan = 1;
10111 /* Fall through. */
10112 case GFC_INIT_REAL_NAN:
10113 mpfr_set_nan (mpc_realref (init_expr->value.complex));
10114 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
10117 case GFC_INIT_REAL_INF:
10118 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
10119 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
10122 case GFC_INIT_REAL_NEG_INF:
10123 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
10124 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
10127 case GFC_INIT_REAL_ZERO:
10128 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
10132 gfc_free_expr (init_expr);
10139 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
10140 init_expr->value.logical = 0;
10141 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
10142 init_expr->value.logical = 1;
10145 gfc_free_expr (init_expr);
10151 /* For characters, the length must be constant in order to
10152 create a default initializer. */
10153 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
10154 && sym->ts.u.cl->length
10155 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
10157 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
10158 init_expr->value.character.length = char_len;
10159 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
10160 for (i = 0; i < char_len; i++)
10161 init_expr->value.character.string[i]
10162 = (unsigned char) gfc_option.flag_init_character_value;
10166 gfc_free_expr (init_expr);
10169 if (!init_expr && gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
10170 && sym->ts.u.cl->length)
10172 gfc_actual_arglist *arg;
10173 init_expr = gfc_get_expr ();
10174 init_expr->where = sym->declared_at;
10175 init_expr->ts = sym->ts;
10176 init_expr->expr_type = EXPR_FUNCTION;
10177 init_expr->value.function.isym =
10178 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT);
10179 init_expr->value.function.name = "repeat";
10180 arg = gfc_get_actual_arglist ();
10181 arg->expr = gfc_get_character_expr (sym->ts.kind, &sym->declared_at,
10183 arg->expr->value.character.string[0]
10184 = gfc_option.flag_init_character_value;
10185 arg->next = gfc_get_actual_arglist ();
10186 arg->next->expr = gfc_copy_expr (sym->ts.u.cl->length);
10187 init_expr->value.function.actual = arg;
10192 gfc_free_expr (init_expr);
10198 /* Add an initialization expression to a local variable. */
10200 apply_default_init_local (gfc_symbol *sym)
10202 gfc_expr *init = NULL;
10204 /* The symbol should be a variable or a function return value. */
10205 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
10206 || (sym->attr.function && sym->result != sym))
10209 /* Try to build the initializer expression. If we can't initialize
10210 this symbol, then init will be NULL. */
10211 init = build_default_init_expr (sym);
10215 /* For saved variables, we don't want to add an initializer at function
10216 entry, so we just add a static initializer. Note that automatic variables
10217 are stack allocated even with -fno-automatic. */
10218 if (sym->attr.save || sym->ns->save_all
10219 || (gfc_option.flag_max_stack_var_size == 0
10220 && (!sym->attr.dimension || !is_non_constant_shape_array (sym))))
10222 /* Don't clobber an existing initializer! */
10223 gcc_assert (sym->value == NULL);
10228 build_init_assign (sym, init);
10232 /* Resolution of common features of flavors variable and procedure. */
10235 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
10237 gfc_array_spec *as;
10239 /* Avoid double diagnostics for function result symbols. */
10240 if ((sym->result || sym->attr.result) && !sym->attr.dummy
10241 && (sym->ns != gfc_current_ns))
10244 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
10245 as = CLASS_DATA (sym)->as;
10249 /* Constraints on deferred shape variable. */
10250 if (as == NULL || as->type != AS_DEFERRED)
10252 bool pointer, allocatable, dimension;
10254 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
10256 pointer = CLASS_DATA (sym)->attr.class_pointer;
10257 allocatable = CLASS_DATA (sym)->attr.allocatable;
10258 dimension = CLASS_DATA (sym)->attr.dimension;
10262 pointer = sym->attr.pointer;
10263 allocatable = sym->attr.allocatable;
10264 dimension = sym->attr.dimension;
10271 gfc_error ("Allocatable array '%s' at %L must have "
10272 "a deferred shape", sym->name, &sym->declared_at);
10275 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
10276 "may not be ALLOCATABLE", sym->name,
10277 &sym->declared_at) == FAILURE)
10281 if (pointer && dimension)
10283 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
10284 sym->name, &sym->declared_at);
10290 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
10291 && sym->ts.type != BT_CLASS && !sym->assoc)
10293 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10294 sym->name, &sym->declared_at);
10299 /* Constraints on polymorphic variables. */
10300 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
10303 if (sym->attr.class_ok
10304 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
10306 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10307 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
10308 &sym->declared_at);
10313 /* Assume that use associated symbols were checked in the module ns.
10314 Class-variables that are associate-names are also something special
10315 and excepted from the test. */
10316 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
10318 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10319 "or pointer", sym->name, &sym->declared_at);
10328 /* Additional checks for symbols with flavor variable and derived
10329 type. To be called from resolve_fl_variable. */
10332 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
10334 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
10336 /* Check to see if a derived type is blocked from being host
10337 associated by the presence of another class I symbol in the same
10338 namespace. 14.6.1.3 of the standard and the discussion on
10339 comp.lang.fortran. */
10340 if (sym->ns != sym->ts.u.derived->ns
10341 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
10344 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
10345 if (s && s->attr.generic)
10346 s = gfc_find_dt_in_generic (s);
10347 if (s && s->attr.flavor != FL_DERIVED)
10349 gfc_error ("The type '%s' cannot be host associated at %L "
10350 "because it is blocked by an incompatible object "
10351 "of the same name declared at %L",
10352 sym->ts.u.derived->name, &sym->declared_at,
10358 /* 4th constraint in section 11.3: "If an object of a type for which
10359 component-initialization is specified (R429) appears in the
10360 specification-part of a module and does not have the ALLOCATABLE
10361 or POINTER attribute, the object shall have the SAVE attribute."
10363 The check for initializers is performed with
10364 gfc_has_default_initializer because gfc_default_initializer generates
10365 a hidden default for allocatable components. */
10366 if (!(sym->value || no_init_flag) && sym->ns->proc_name
10367 && sym->ns->proc_name->attr.flavor == FL_MODULE
10368 && !sym->ns->save_all && !sym->attr.save
10369 && !sym->attr.pointer && !sym->attr.allocatable
10370 && gfc_has_default_initializer (sym->ts.u.derived)
10371 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
10372 "module variable '%s' at %L, needed due to "
10373 "the default initialization", sym->name,
10374 &sym->declared_at) == FAILURE)
10377 /* Assign default initializer. */
10378 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
10379 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
10381 sym->value = gfc_default_initializer (&sym->ts);
10388 /* Resolve symbols with flavor variable. */
10391 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
10393 int no_init_flag, automatic_flag;
10395 const char *auto_save_msg;
10397 auto_save_msg = "Automatic object '%s' at %L cannot have the "
10400 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10403 /* Set this flag to check that variables are parameters of all entries.
10404 This check is effected by the call to gfc_resolve_expr through
10405 is_non_constant_shape_array. */
10406 specification_expr = 1;
10408 if (sym->ns->proc_name
10409 && (sym->ns->proc_name->attr.flavor == FL_MODULE
10410 || sym->ns->proc_name->attr.is_main_program)
10411 && !sym->attr.use_assoc
10412 && !sym->attr.allocatable
10413 && !sym->attr.pointer
10414 && is_non_constant_shape_array (sym))
10416 /* The shape of a main program or module array needs to be
10418 gfc_error ("The module or main program array '%s' at %L must "
10419 "have constant shape", sym->name, &sym->declared_at);
10420 specification_expr = 0;
10424 /* Constraints on deferred type parameter. */
10425 if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
10427 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10428 "requires either the pointer or allocatable attribute",
10429 sym->name, &sym->declared_at);
10433 if (sym->ts.type == BT_CHARACTER)
10435 /* Make sure that character string variables with assumed length are
10436 dummy arguments. */
10437 e = sym->ts.u.cl->length;
10438 if (e == NULL && !sym->attr.dummy && !sym->attr.result
10439 && !sym->ts.deferred)
10441 gfc_error ("Entity with assumed character length at %L must be a "
10442 "dummy argument or a PARAMETER", &sym->declared_at);
10446 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
10448 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10452 if (!gfc_is_constant_expr (e)
10453 && !(e->expr_type == EXPR_VARIABLE
10454 && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
10456 if (!sym->attr.use_assoc && sym->ns->proc_name
10457 && (sym->ns->proc_name->attr.flavor == FL_MODULE
10458 || sym->ns->proc_name->attr.is_main_program))
10460 gfc_error ("'%s' at %L must have constant character length "
10461 "in this context", sym->name, &sym->declared_at);
10464 if (sym->attr.in_common)
10466 gfc_error ("COMMON variable '%s' at %L must have constant "
10467 "character length", sym->name, &sym->declared_at);
10473 if (sym->value == NULL && sym->attr.referenced)
10474 apply_default_init_local (sym); /* Try to apply a default initialization. */
10476 /* Determine if the symbol may not have an initializer. */
10477 no_init_flag = automatic_flag = 0;
10478 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
10479 || sym->attr.intrinsic || sym->attr.result)
10481 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
10482 && is_non_constant_shape_array (sym))
10484 no_init_flag = automatic_flag = 1;
10486 /* Also, they must not have the SAVE attribute.
10487 SAVE_IMPLICIT is checked below. */
10488 if (sym->as && sym->attr.codimension)
10490 int corank = sym->as->corank;
10491 sym->as->corank = 0;
10492 no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
10493 sym->as->corank = corank;
10495 if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
10497 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10502 /* Ensure that any initializer is simplified. */
10504 gfc_simplify_expr (sym->value, 1);
10506 /* Reject illegal initializers. */
10507 if (!sym->mark && sym->value)
10509 if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
10510 && CLASS_DATA (sym)->attr.allocatable))
10511 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10512 sym->name, &sym->declared_at);
10513 else if (sym->attr.external)
10514 gfc_error ("External '%s' at %L cannot have an initializer",
10515 sym->name, &sym->declared_at);
10516 else if (sym->attr.dummy
10517 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
10518 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10519 sym->name, &sym->declared_at);
10520 else if (sym->attr.intrinsic)
10521 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10522 sym->name, &sym->declared_at);
10523 else if (sym->attr.result)
10524 gfc_error ("Function result '%s' at %L cannot have an initializer",
10525 sym->name, &sym->declared_at);
10526 else if (automatic_flag)
10527 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10528 sym->name, &sym->declared_at);
10530 goto no_init_error;
10535 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
10536 return resolve_fl_variable_derived (sym, no_init_flag);
10542 /* Resolve a procedure. */
10545 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
10547 gfc_formal_arglist *arg;
10549 if (sym->attr.function
10550 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10553 if (sym->ts.type == BT_CHARACTER)
10555 gfc_charlen *cl = sym->ts.u.cl;
10557 if (cl && cl->length && gfc_is_constant_expr (cl->length)
10558 && resolve_charlen (cl) == FAILURE)
10561 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
10562 && sym->attr.proc == PROC_ST_FUNCTION)
10564 gfc_error ("Character-valued statement function '%s' at %L must "
10565 "have constant length", sym->name, &sym->declared_at);
10570 /* Ensure that derived type for are not of a private type. Internal
10571 module procedures are excluded by 2.2.3.3 - i.e., they are not
10572 externally accessible and can access all the objects accessible in
10574 if (!(sym->ns->parent
10575 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
10576 && gfc_check_symbol_access (sym))
10578 gfc_interface *iface;
10580 for (arg = sym->formal; arg; arg = arg->next)
10583 && arg->sym->ts.type == BT_DERIVED
10584 && !arg->sym->ts.u.derived->attr.use_assoc
10585 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10586 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
10587 "PRIVATE type and cannot be a dummy argument"
10588 " of '%s', which is PUBLIC at %L",
10589 arg->sym->name, sym->name, &sym->declared_at)
10592 /* Stop this message from recurring. */
10593 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10598 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10599 PRIVATE to the containing module. */
10600 for (iface = sym->generic; iface; iface = iface->next)
10602 for (arg = iface->sym->formal; arg; arg = arg->next)
10605 && arg->sym->ts.type == BT_DERIVED
10606 && !arg->sym->ts.u.derived->attr.use_assoc
10607 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10608 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10609 "'%s' in PUBLIC interface '%s' at %L "
10610 "takes dummy arguments of '%s' which is "
10611 "PRIVATE", iface->sym->name, sym->name,
10612 &iface->sym->declared_at,
10613 gfc_typename (&arg->sym->ts)) == FAILURE)
10615 /* Stop this message from recurring. */
10616 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10622 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10623 PRIVATE to the containing module. */
10624 for (iface = sym->generic; iface; iface = iface->next)
10626 for (arg = iface->sym->formal; arg; arg = arg->next)
10629 && arg->sym->ts.type == BT_DERIVED
10630 && !arg->sym->ts.u.derived->attr.use_assoc
10631 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10632 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10633 "'%s' in PUBLIC interface '%s' at %L "
10634 "takes dummy arguments of '%s' which is "
10635 "PRIVATE", iface->sym->name, sym->name,
10636 &iface->sym->declared_at,
10637 gfc_typename (&arg->sym->ts)) == FAILURE)
10639 /* Stop this message from recurring. */
10640 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10647 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10648 && !sym->attr.proc_pointer)
10650 gfc_error ("Function '%s' at %L cannot have an initializer",
10651 sym->name, &sym->declared_at);
10655 /* An external symbol may not have an initializer because it is taken to be
10656 a procedure. Exception: Procedure Pointers. */
10657 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10659 gfc_error ("External object '%s' at %L may not have an initializer",
10660 sym->name, &sym->declared_at);
10664 /* An elemental function is required to return a scalar 12.7.1 */
10665 if (sym->attr.elemental && sym->attr.function && sym->as)
10667 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10668 "result", sym->name, &sym->declared_at);
10669 /* Reset so that the error only occurs once. */
10670 sym->attr.elemental = 0;
10674 if (sym->attr.proc == PROC_ST_FUNCTION
10675 && (sym->attr.allocatable || sym->attr.pointer))
10677 gfc_error ("Statement function '%s' at %L may not have pointer or "
10678 "allocatable attribute", sym->name, &sym->declared_at);
10682 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10683 char-len-param shall not be array-valued, pointer-valued, recursive
10684 or pure. ....snip... A character value of * may only be used in the
10685 following ways: (i) Dummy arg of procedure - dummy associates with
10686 actual length; (ii) To declare a named constant; or (iii) External
10687 function - but length must be declared in calling scoping unit. */
10688 if (sym->attr.function
10689 && sym->ts.type == BT_CHARACTER
10690 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10692 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10693 || (sym->attr.recursive) || (sym->attr.pure))
10695 if (sym->as && sym->as->rank)
10696 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10697 "array-valued", sym->name, &sym->declared_at);
10699 if (sym->attr.pointer)
10700 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10701 "pointer-valued", sym->name, &sym->declared_at);
10703 if (sym->attr.pure)
10704 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10705 "pure", sym->name, &sym->declared_at);
10707 if (sym->attr.recursive)
10708 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10709 "recursive", sym->name, &sym->declared_at);
10714 /* Appendix B.2 of the standard. Contained functions give an
10715 error anyway. Fixed-form is likely to be F77/legacy. Deferred
10716 character length is an F2003 feature. */
10717 if (!sym->attr.contained
10718 && gfc_current_form != FORM_FIXED
10719 && !sym->ts.deferred)
10720 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10721 "CHARACTER(*) function '%s' at %L",
10722 sym->name, &sym->declared_at);
10725 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10727 gfc_formal_arglist *curr_arg;
10728 int has_non_interop_arg = 0;
10730 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10731 sym->common_block) == FAILURE)
10733 /* Clear these to prevent looking at them again if there was an
10735 sym->attr.is_bind_c = 0;
10736 sym->attr.is_c_interop = 0;
10737 sym->ts.is_c_interop = 0;
10741 /* So far, no errors have been found. */
10742 sym->attr.is_c_interop = 1;
10743 sym->ts.is_c_interop = 1;
10746 curr_arg = sym->formal;
10747 while (curr_arg != NULL)
10749 /* Skip implicitly typed dummy args here. */
10750 if (curr_arg->sym->attr.implicit_type == 0)
10751 if (gfc_verify_c_interop_param (curr_arg->sym) == FAILURE)
10752 /* If something is found to fail, record the fact so we
10753 can mark the symbol for the procedure as not being
10754 BIND(C) to try and prevent multiple errors being
10756 has_non_interop_arg = 1;
10758 curr_arg = curr_arg->next;
10761 /* See if any of the arguments were not interoperable and if so, clear
10762 the procedure symbol to prevent duplicate error messages. */
10763 if (has_non_interop_arg != 0)
10765 sym->attr.is_c_interop = 0;
10766 sym->ts.is_c_interop = 0;
10767 sym->attr.is_bind_c = 0;
10771 if (!sym->attr.proc_pointer)
10773 if (sym->attr.save == SAVE_EXPLICIT)
10775 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10776 "in '%s' at %L", sym->name, &sym->declared_at);
10779 if (sym->attr.intent)
10781 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10782 "in '%s' at %L", sym->name, &sym->declared_at);
10785 if (sym->attr.subroutine && sym->attr.result)
10787 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10788 "in '%s' at %L", sym->name, &sym->declared_at);
10791 if (sym->attr.external && sym->attr.function
10792 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10793 || sym->attr.contained))
10795 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10796 "in '%s' at %L", sym->name, &sym->declared_at);
10799 if (strcmp ("ppr@", sym->name) == 0)
10801 gfc_error ("Procedure pointer result '%s' at %L "
10802 "is missing the pointer attribute",
10803 sym->ns->proc_name->name, &sym->declared_at);
10812 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10813 been defined and we now know their defined arguments, check that they fulfill
10814 the requirements of the standard for procedures used as finalizers. */
10817 gfc_resolve_finalizers (gfc_symbol* derived)
10819 gfc_finalizer* list;
10820 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10821 gfc_try result = SUCCESS;
10822 bool seen_scalar = false;
10824 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10827 /* Walk over the list of finalizer-procedures, check them, and if any one
10828 does not fit in with the standard's definition, print an error and remove
10829 it from the list. */
10830 prev_link = &derived->f2k_derived->finalizers;
10831 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10837 /* Skip this finalizer if we already resolved it. */
10838 if (list->proc_tree)
10840 prev_link = &(list->next);
10844 /* Check this exists and is a SUBROUTINE. */
10845 if (!list->proc_sym->attr.subroutine)
10847 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10848 list->proc_sym->name, &list->where);
10852 /* We should have exactly one argument. */
10853 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10855 gfc_error ("FINAL procedure at %L must have exactly one argument",
10859 arg = list->proc_sym->formal->sym;
10861 /* This argument must be of our type. */
10862 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10864 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10865 &arg->declared_at, derived->name);
10869 /* It must neither be a pointer nor allocatable nor optional. */
10870 if (arg->attr.pointer)
10872 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10873 &arg->declared_at);
10876 if (arg->attr.allocatable)
10878 gfc_error ("Argument of FINAL procedure at %L must not be"
10879 " ALLOCATABLE", &arg->declared_at);
10882 if (arg->attr.optional)
10884 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10885 &arg->declared_at);
10889 /* It must not be INTENT(OUT). */
10890 if (arg->attr.intent == INTENT_OUT)
10892 gfc_error ("Argument of FINAL procedure at %L must not be"
10893 " INTENT(OUT)", &arg->declared_at);
10897 /* Warn if the procedure is non-scalar and not assumed shape. */
10898 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10899 && arg->as->type != AS_ASSUMED_SHAPE)
10900 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10901 " shape argument", &arg->declared_at);
10903 /* Check that it does not match in kind and rank with a FINAL procedure
10904 defined earlier. To really loop over the *earlier* declarations,
10905 we need to walk the tail of the list as new ones were pushed at the
10907 /* TODO: Handle kind parameters once they are implemented. */
10908 my_rank = (arg->as ? arg->as->rank : 0);
10909 for (i = list->next; i; i = i->next)
10911 /* Argument list might be empty; that is an error signalled earlier,
10912 but we nevertheless continued resolving. */
10913 if (i->proc_sym->formal)
10915 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10916 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10917 if (i_rank == my_rank)
10919 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10920 " rank (%d) as '%s'",
10921 list->proc_sym->name, &list->where, my_rank,
10922 i->proc_sym->name);
10928 /* Is this the/a scalar finalizer procedure? */
10929 if (!arg->as || arg->as->rank == 0)
10930 seen_scalar = true;
10932 /* Find the symtree for this procedure. */
10933 gcc_assert (!list->proc_tree);
10934 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10936 prev_link = &list->next;
10939 /* Remove wrong nodes immediately from the list so we don't risk any
10940 troubles in the future when they might fail later expectations. */
10944 *prev_link = list->next;
10945 gfc_free_finalizer (i);
10948 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10949 were nodes in the list, must have been for arrays. It is surely a good
10950 idea to have a scalar version there if there's something to finalize. */
10951 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10952 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10953 " defined at %L, suggest also scalar one",
10954 derived->name, &derived->declared_at);
10956 /* TODO: Remove this error when finalization is finished. */
10957 gfc_error ("Finalization at %L is not yet implemented",
10958 &derived->declared_at);
10964 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10967 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10968 const char* generic_name, locus where)
10973 gcc_assert (t1->specific && t2->specific);
10974 gcc_assert (!t1->specific->is_generic);
10975 gcc_assert (!t2->specific->is_generic);
10976 gcc_assert (t1->is_operator == t2->is_operator);
10978 sym1 = t1->specific->u.specific->n.sym;
10979 sym2 = t2->specific->u.specific->n.sym;
10984 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10985 if (sym1->attr.subroutine != sym2->attr.subroutine
10986 || sym1->attr.function != sym2->attr.function)
10988 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10989 " GENERIC '%s' at %L",
10990 sym1->name, sym2->name, generic_name, &where);
10994 /* Compare the interfaces. */
10995 if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
10998 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10999 sym1->name, sym2->name, generic_name, &where);
11007 /* Worker function for resolving a generic procedure binding; this is used to
11008 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11010 The difference between those cases is finding possible inherited bindings
11011 that are overridden, as one has to look for them in tb_sym_root,
11012 tb_uop_root or tb_op, respectively. Thus the caller must already find
11013 the super-type and set p->overridden correctly. */
11016 resolve_tb_generic_targets (gfc_symbol* super_type,
11017 gfc_typebound_proc* p, const char* name)
11019 gfc_tbp_generic* target;
11020 gfc_symtree* first_target;
11021 gfc_symtree* inherited;
11023 gcc_assert (p && p->is_generic);
11025 /* Try to find the specific bindings for the symtrees in our target-list. */
11026 gcc_assert (p->u.generic);
11027 for (target = p->u.generic; target; target = target->next)
11028 if (!target->specific)
11030 gfc_typebound_proc* overridden_tbp;
11031 gfc_tbp_generic* g;
11032 const char* target_name;
11034 target_name = target->specific_st->name;
11036 /* Defined for this type directly. */
11037 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
11039 target->specific = target->specific_st->n.tb;
11040 goto specific_found;
11043 /* Look for an inherited specific binding. */
11046 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
11051 gcc_assert (inherited->n.tb);
11052 target->specific = inherited->n.tb;
11053 goto specific_found;
11057 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11058 " at %L", target_name, name, &p->where);
11061 /* Once we've found the specific binding, check it is not ambiguous with
11062 other specifics already found or inherited for the same GENERIC. */
11064 gcc_assert (target->specific);
11066 /* This must really be a specific binding! */
11067 if (target->specific->is_generic)
11069 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11070 " '%s' is GENERIC, too", name, &p->where, target_name);
11074 /* Check those already resolved on this type directly. */
11075 for (g = p->u.generic; g; g = g->next)
11076 if (g != target && g->specific
11077 && check_generic_tbp_ambiguity (target, g, name, p->where)
11081 /* Check for ambiguity with inherited specific targets. */
11082 for (overridden_tbp = p->overridden; overridden_tbp;
11083 overridden_tbp = overridden_tbp->overridden)
11084 if (overridden_tbp->is_generic)
11086 for (g = overridden_tbp->u.generic; g; g = g->next)
11088 gcc_assert (g->specific);
11089 if (check_generic_tbp_ambiguity (target, g,
11090 name, p->where) == FAILURE)
11096 /* If we attempt to "overwrite" a specific binding, this is an error. */
11097 if (p->overridden && !p->overridden->is_generic)
11099 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11100 " the same name", name, &p->where);
11104 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11105 all must have the same attributes here. */
11106 first_target = p->u.generic->specific->u.specific;
11107 gcc_assert (first_target);
11108 p->subroutine = first_target->n.sym->attr.subroutine;
11109 p->function = first_target->n.sym->attr.function;
11115 /* Resolve a GENERIC procedure binding for a derived type. */
11118 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
11120 gfc_symbol* super_type;
11122 /* Find the overridden binding if any. */
11123 st->n.tb->overridden = NULL;
11124 super_type = gfc_get_derived_super_type (derived);
11127 gfc_symtree* overridden;
11128 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
11131 if (overridden && overridden->n.tb)
11132 st->n.tb->overridden = overridden->n.tb;
11135 /* Resolve using worker function. */
11136 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
11140 /* Retrieve the target-procedure of an operator binding and do some checks in
11141 common for intrinsic and user-defined type-bound operators. */
11144 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
11146 gfc_symbol* target_proc;
11148 gcc_assert (target->specific && !target->specific->is_generic);
11149 target_proc = target->specific->u.specific->n.sym;
11150 gcc_assert (target_proc);
11152 /* All operator bindings must have a passed-object dummy argument. */
11153 if (target->specific->nopass)
11155 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
11159 return target_proc;
11163 /* Resolve a type-bound intrinsic operator. */
11166 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
11167 gfc_typebound_proc* p)
11169 gfc_symbol* super_type;
11170 gfc_tbp_generic* target;
11172 /* If there's already an error here, do nothing (but don't fail again). */
11176 /* Operators should always be GENERIC bindings. */
11177 gcc_assert (p->is_generic);
11179 /* Look for an overridden binding. */
11180 super_type = gfc_get_derived_super_type (derived);
11181 if (super_type && super_type->f2k_derived)
11182 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
11185 p->overridden = NULL;
11187 /* Resolve general GENERIC properties using worker function. */
11188 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
11191 /* Check the targets to be procedures of correct interface. */
11192 for (target = p->u.generic; target; target = target->next)
11194 gfc_symbol* target_proc;
11196 target_proc = get_checked_tb_operator_target (target, p->where);
11200 if (!gfc_check_operator_interface (target_proc, op, p->where))
11212 /* Resolve a type-bound user operator (tree-walker callback). */
11214 static gfc_symbol* resolve_bindings_derived;
11215 static gfc_try resolve_bindings_result;
11217 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
11220 resolve_typebound_user_op (gfc_symtree* stree)
11222 gfc_symbol* super_type;
11223 gfc_tbp_generic* target;
11225 gcc_assert (stree && stree->n.tb);
11227 if (stree->n.tb->error)
11230 /* Operators should always be GENERIC bindings. */
11231 gcc_assert (stree->n.tb->is_generic);
11233 /* Find overridden procedure, if any. */
11234 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11235 if (super_type && super_type->f2k_derived)
11237 gfc_symtree* overridden;
11238 overridden = gfc_find_typebound_user_op (super_type, NULL,
11239 stree->name, true, NULL);
11241 if (overridden && overridden->n.tb)
11242 stree->n.tb->overridden = overridden->n.tb;
11245 stree->n.tb->overridden = NULL;
11247 /* Resolve basically using worker function. */
11248 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
11252 /* Check the targets to be functions of correct interface. */
11253 for (target = stree->n.tb->u.generic; target; target = target->next)
11255 gfc_symbol* target_proc;
11257 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
11261 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
11268 resolve_bindings_result = FAILURE;
11269 stree->n.tb->error = 1;
11273 /* Resolve the type-bound procedures for a derived type. */
11276 resolve_typebound_procedure (gfc_symtree* stree)
11280 gfc_symbol* me_arg;
11281 gfc_symbol* super_type;
11282 gfc_component* comp;
11284 gcc_assert (stree);
11286 /* Undefined specific symbol from GENERIC target definition. */
11290 if (stree->n.tb->error)
11293 /* If this is a GENERIC binding, use that routine. */
11294 if (stree->n.tb->is_generic)
11296 if (resolve_typebound_generic (resolve_bindings_derived, stree)
11302 /* Get the target-procedure to check it. */
11303 gcc_assert (!stree->n.tb->is_generic);
11304 gcc_assert (stree->n.tb->u.specific);
11305 proc = stree->n.tb->u.specific->n.sym;
11306 where = stree->n.tb->where;
11308 /* Default access should already be resolved from the parser. */
11309 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
11311 /* It should be a module procedure or an external procedure with explicit
11312 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
11313 if ((!proc->attr.subroutine && !proc->attr.function)
11314 || (proc->attr.proc != PROC_MODULE
11315 && proc->attr.if_source != IFSRC_IFBODY)
11316 || (proc->attr.abstract && !stree->n.tb->deferred))
11318 gfc_error ("'%s' must be a module procedure or an external procedure with"
11319 " an explicit interface at %L", proc->name, &where);
11322 stree->n.tb->subroutine = proc->attr.subroutine;
11323 stree->n.tb->function = proc->attr.function;
11325 /* Find the super-type of the current derived type. We could do this once and
11326 store in a global if speed is needed, but as long as not I believe this is
11327 more readable and clearer. */
11328 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11330 /* If PASS, resolve and check arguments if not already resolved / loaded
11331 from a .mod file. */
11332 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
11334 if (stree->n.tb->pass_arg)
11336 gfc_formal_arglist* i;
11338 /* If an explicit passing argument name is given, walk the arg-list
11339 and look for it. */
11342 stree->n.tb->pass_arg_num = 1;
11343 for (i = proc->formal; i; i = i->next)
11345 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
11350 ++stree->n.tb->pass_arg_num;
11355 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11357 proc->name, stree->n.tb->pass_arg, &where,
11358 stree->n.tb->pass_arg);
11364 /* Otherwise, take the first one; there should in fact be at least
11366 stree->n.tb->pass_arg_num = 1;
11369 gfc_error ("Procedure '%s' with PASS at %L must have at"
11370 " least one argument", proc->name, &where);
11373 me_arg = proc->formal->sym;
11376 /* Now check that the argument-type matches and the passed-object
11377 dummy argument is generally fine. */
11379 gcc_assert (me_arg);
11381 if (me_arg->ts.type != BT_CLASS)
11383 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11384 " at %L", proc->name, &where);
11388 if (CLASS_DATA (me_arg)->ts.u.derived
11389 != resolve_bindings_derived)
11391 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11392 " the derived-type '%s'", me_arg->name, proc->name,
11393 me_arg->name, &where, resolve_bindings_derived->name);
11397 gcc_assert (me_arg->ts.type == BT_CLASS);
11398 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
11400 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11401 " scalar", proc->name, &where);
11404 if (CLASS_DATA (me_arg)->attr.allocatable)
11406 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11407 " be ALLOCATABLE", proc->name, &where);
11410 if (CLASS_DATA (me_arg)->attr.class_pointer)
11412 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11413 " be POINTER", proc->name, &where);
11418 /* If we are extending some type, check that we don't override a procedure
11419 flagged NON_OVERRIDABLE. */
11420 stree->n.tb->overridden = NULL;
11423 gfc_symtree* overridden;
11424 overridden = gfc_find_typebound_proc (super_type, NULL,
11425 stree->name, true, NULL);
11429 if (overridden->n.tb)
11430 stree->n.tb->overridden = overridden->n.tb;
11432 if (gfc_check_typebound_override (stree, overridden) == FAILURE)
11437 /* See if there's a name collision with a component directly in this type. */
11438 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11439 if (!strcmp (comp->name, stree->name))
11441 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11443 stree->name, &where, resolve_bindings_derived->name);
11447 /* Try to find a name collision with an inherited component. */
11448 if (super_type && gfc_find_component (super_type, stree->name, true, true))
11450 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11451 " component of '%s'",
11452 stree->name, &where, resolve_bindings_derived->name);
11456 stree->n.tb->error = 0;
11460 resolve_bindings_result = FAILURE;
11461 stree->n.tb->error = 1;
11466 resolve_typebound_procedures (gfc_symbol* derived)
11469 gfc_symbol* super_type;
11471 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11474 super_type = gfc_get_derived_super_type (derived);
11476 resolve_typebound_procedures (super_type);
11478 resolve_bindings_derived = derived;
11479 resolve_bindings_result = SUCCESS;
11481 /* Make sure the vtab has been generated. */
11482 gfc_find_derived_vtab (derived);
11484 if (derived->f2k_derived->tb_sym_root)
11485 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11486 &resolve_typebound_procedure);
11488 if (derived->f2k_derived->tb_uop_root)
11489 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11490 &resolve_typebound_user_op);
11492 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11494 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11495 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11497 resolve_bindings_result = FAILURE;
11500 return resolve_bindings_result;
11504 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11505 to give all identical derived types the same backend_decl. */
11507 add_dt_to_dt_list (gfc_symbol *derived)
11509 gfc_dt_list *dt_list;
11511 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11512 if (derived == dt_list->derived)
11515 dt_list = gfc_get_dt_list ();
11516 dt_list->next = gfc_derived_types;
11517 dt_list->derived = derived;
11518 gfc_derived_types = dt_list;
11522 /* Ensure that a derived-type is really not abstract, meaning that every
11523 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11526 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11531 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11533 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11536 if (st->n.tb && st->n.tb->deferred)
11538 gfc_symtree* overriding;
11539 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11542 gcc_assert (overriding->n.tb);
11543 if (overriding->n.tb->deferred)
11545 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11546 " '%s' is DEFERRED and not overridden",
11547 sub->name, &sub->declared_at, st->name);
11556 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11558 /* The algorithm used here is to recursively travel up the ancestry of sub
11559 and for each ancestor-type, check all bindings. If any of them is
11560 DEFERRED, look it up starting from sub and see if the found (overriding)
11561 binding is not DEFERRED.
11562 This is not the most efficient way to do this, but it should be ok and is
11563 clearer than something sophisticated. */
11565 gcc_assert (ancestor && !sub->attr.abstract);
11567 if (!ancestor->attr.abstract)
11570 /* Walk bindings of this ancestor. */
11571 if (ancestor->f2k_derived)
11574 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11579 /* Find next ancestor type and recurse on it. */
11580 ancestor = gfc_get_derived_super_type (ancestor);
11582 return ensure_not_abstract (sub, ancestor);
11588 /* Resolve the components of a derived type. This does not have to wait until
11589 resolution stage, but can be done as soon as the dt declaration has been
11593 resolve_fl_derived0 (gfc_symbol *sym)
11595 gfc_symbol* super_type;
11598 super_type = gfc_get_derived_super_type (sym);
11601 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11603 gfc_error ("As extending type '%s' at %L has a coarray component, "
11604 "parent type '%s' shall also have one", sym->name,
11605 &sym->declared_at, super_type->name);
11609 /* Ensure the extended type gets resolved before we do. */
11610 if (super_type && resolve_fl_derived0 (super_type) == FAILURE)
11613 /* An ABSTRACT type must be extensible. */
11614 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11616 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11617 sym->name, &sym->declared_at);
11621 c = (sym->attr.is_class) ? sym->components->ts.u.derived->components
11624 for ( ; c != NULL; c = c->next)
11626 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
11627 if (c->ts.type == BT_CHARACTER && c->ts.deferred)
11629 gfc_error ("Deferred-length character component '%s' at %L is not "
11630 "yet supported", c->name, &c->loc);
11635 if ((!sym->attr.is_class || c != sym->components)
11636 && c->attr.codimension
11637 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11639 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11640 "deferred shape", c->name, &c->loc);
11645 if (c->attr.codimension && c->ts.type == BT_DERIVED
11646 && c->ts.u.derived->ts.is_iso_c)
11648 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11649 "shall not be a coarray", c->name, &c->loc);
11654 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11655 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11656 || c->attr.allocatable))
11658 gfc_error ("Component '%s' at %L with coarray component "
11659 "shall be a nonpointer, nonallocatable scalar",
11665 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11667 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11668 "is not an array pointer", c->name, &c->loc);
11672 if (c->attr.proc_pointer && c->ts.interface)
11674 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11675 gfc_error ("Interface '%s', used by procedure pointer component "
11676 "'%s' at %L, is declared in a later PROCEDURE statement",
11677 c->ts.interface->name, c->name, &c->loc);
11679 /* Get the attributes from the interface (now resolved). */
11680 if (c->ts.interface->attr.if_source
11681 || c->ts.interface->attr.intrinsic)
11683 gfc_symbol *ifc = c->ts.interface;
11685 if (ifc->formal && !ifc->formal_ns)
11686 resolve_symbol (ifc);
11688 if (ifc->attr.intrinsic)
11689 resolve_intrinsic (ifc, &ifc->declared_at);
11693 c->ts = ifc->result->ts;
11694 c->attr.allocatable = ifc->result->attr.allocatable;
11695 c->attr.pointer = ifc->result->attr.pointer;
11696 c->attr.dimension = ifc->result->attr.dimension;
11697 c->as = gfc_copy_array_spec (ifc->result->as);
11702 c->attr.allocatable = ifc->attr.allocatable;
11703 c->attr.pointer = ifc->attr.pointer;
11704 c->attr.dimension = ifc->attr.dimension;
11705 c->as = gfc_copy_array_spec (ifc->as);
11707 c->ts.interface = ifc;
11708 c->attr.function = ifc->attr.function;
11709 c->attr.subroutine = ifc->attr.subroutine;
11710 gfc_copy_formal_args_ppc (c, ifc);
11712 c->attr.pure = ifc->attr.pure;
11713 c->attr.elemental = ifc->attr.elemental;
11714 c->attr.recursive = ifc->attr.recursive;
11715 c->attr.always_explicit = ifc->attr.always_explicit;
11716 c->attr.ext_attr |= ifc->attr.ext_attr;
11717 /* Replace symbols in array spec. */
11721 for (i = 0; i < c->as->rank; i++)
11723 gfc_expr_replace_comp (c->as->lower[i], c);
11724 gfc_expr_replace_comp (c->as->upper[i], c);
11727 /* Copy char length. */
11728 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11730 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11731 gfc_expr_replace_comp (cl->length, c);
11732 if (cl->length && !cl->resolved
11733 && gfc_resolve_expr (cl->length) == FAILURE)
11738 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11740 gfc_error ("Interface '%s' of procedure pointer component "
11741 "'%s' at %L must be explicit", c->ts.interface->name,
11746 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11748 /* Since PPCs are not implicitly typed, a PPC without an explicit
11749 interface must be a subroutine. */
11750 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11753 /* Procedure pointer components: Check PASS arg. */
11754 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11755 && !sym->attr.vtype)
11757 gfc_symbol* me_arg;
11759 if (c->tb->pass_arg)
11761 gfc_formal_arglist* i;
11763 /* If an explicit passing argument name is given, walk the arg-list
11764 and look for it. */
11767 c->tb->pass_arg_num = 1;
11768 for (i = c->formal; i; i = i->next)
11770 if (!strcmp (i->sym->name, c->tb->pass_arg))
11775 c->tb->pass_arg_num++;
11780 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11781 "at %L has no argument '%s'", c->name,
11782 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11789 /* Otherwise, take the first one; there should in fact be at least
11791 c->tb->pass_arg_num = 1;
11794 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11795 "must have at least one argument",
11800 me_arg = c->formal->sym;
11803 /* Now check that the argument-type matches. */
11804 gcc_assert (me_arg);
11805 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11806 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11807 || (me_arg->ts.type == BT_CLASS
11808 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11810 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11811 " the derived type '%s'", me_arg->name, c->name,
11812 me_arg->name, &c->loc, sym->name);
11817 /* Check for C453. */
11818 if (me_arg->attr.dimension)
11820 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11821 "must be scalar", me_arg->name, c->name, me_arg->name,
11827 if (me_arg->attr.pointer)
11829 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11830 "may not have the POINTER attribute", me_arg->name,
11831 c->name, me_arg->name, &c->loc);
11836 if (me_arg->attr.allocatable)
11838 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11839 "may not be ALLOCATABLE", me_arg->name, c->name,
11840 me_arg->name, &c->loc);
11845 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11846 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11847 " at %L", c->name, &c->loc);
11851 /* Check type-spec if this is not the parent-type component. */
11852 if (((sym->attr.is_class
11853 && (!sym->components->ts.u.derived->attr.extension
11854 || c != sym->components->ts.u.derived->components))
11855 || (!sym->attr.is_class
11856 && (!sym->attr.extension || c != sym->components)))
11857 && !sym->attr.vtype
11858 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11861 /* If this type is an extension, set the accessibility of the parent
11864 && ((sym->attr.is_class
11865 && c == sym->components->ts.u.derived->components)
11866 || (!sym->attr.is_class && c == sym->components))
11867 && strcmp (super_type->name, c->name) == 0)
11868 c->attr.access = super_type->attr.access;
11870 /* If this type is an extension, see if this component has the same name
11871 as an inherited type-bound procedure. */
11872 if (super_type && !sym->attr.is_class
11873 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11875 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11876 " inherited type-bound procedure",
11877 c->name, sym->name, &c->loc);
11881 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
11882 && !c->ts.deferred)
11884 if (c->ts.u.cl->length == NULL
11885 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11886 || !gfc_is_constant_expr (c->ts.u.cl->length))
11888 gfc_error ("Character length of component '%s' needs to "
11889 "be a constant specification expression at %L",
11891 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11896 if (c->ts.type == BT_CHARACTER && c->ts.deferred
11897 && !c->attr.pointer && !c->attr.allocatable)
11899 gfc_error ("Character component '%s' of '%s' at %L with deferred "
11900 "length must be a POINTER or ALLOCATABLE",
11901 c->name, sym->name, &c->loc);
11905 if (c->ts.type == BT_DERIVED
11906 && sym->component_access != ACCESS_PRIVATE
11907 && gfc_check_symbol_access (sym)
11908 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11909 && !c->ts.u.derived->attr.use_assoc
11910 && !gfc_check_symbol_access (c->ts.u.derived)
11911 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11912 "is a PRIVATE type and cannot be a component of "
11913 "'%s', which is PUBLIC at %L", c->name,
11914 sym->name, &sym->declared_at) == FAILURE)
11917 if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
11919 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11920 "type %s", c->name, &c->loc, sym->name);
11924 if (sym->attr.sequence)
11926 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11928 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11929 "not have the SEQUENCE attribute",
11930 c->ts.u.derived->name, &sym->declared_at);
11935 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
11936 c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
11937 else if (c->ts.type == BT_CLASS && c->attr.class_ok
11938 && CLASS_DATA (c)->ts.u.derived->attr.generic)
11939 CLASS_DATA (c)->ts.u.derived
11940 = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
11942 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
11943 && c->attr.pointer && c->ts.u.derived->components == NULL
11944 && !c->ts.u.derived->attr.zero_comp)
11946 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11947 "that has not been declared", c->name, sym->name,
11952 if (c->ts.type == BT_CLASS && c->attr.class_ok
11953 && CLASS_DATA (c)->attr.class_pointer
11954 && CLASS_DATA (c)->ts.u.derived->components == NULL
11955 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11957 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11958 "that has not been declared", c->name, sym->name,
11964 if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE
11965 && (!c->attr.class_ok
11966 || !(CLASS_DATA (c)->attr.class_pointer
11967 || CLASS_DATA (c)->attr.allocatable)))
11969 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11970 "or pointer", c->name, &c->loc);
11971 /* Prevent a recurrence of the error. */
11972 c->ts.type = BT_UNKNOWN;
11976 /* Ensure that all the derived type components are put on the
11977 derived type list; even in formal namespaces, where derived type
11978 pointer components might not have been declared. */
11979 if (c->ts.type == BT_DERIVED
11981 && c->ts.u.derived->components
11983 && sym != c->ts.u.derived)
11984 add_dt_to_dt_list (c->ts.u.derived);
11986 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11987 || c->attr.proc_pointer
11988 || c->attr.allocatable)) == FAILURE)
11992 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11993 all DEFERRED bindings are overridden. */
11994 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11995 && !sym->attr.is_class
11996 && ensure_not_abstract (sym, super_type) == FAILURE)
11999 /* Add derived type to the derived type list. */
12000 add_dt_to_dt_list (sym);
12006 /* The following procedure does the full resolution of a derived type,
12007 including resolution of all type-bound procedures (if present). In contrast
12008 to 'resolve_fl_derived0' this can only be done after the module has been
12009 parsed completely. */
12012 resolve_fl_derived (gfc_symbol *sym)
12014 gfc_symbol *gen_dt = NULL;
12016 if (!sym->attr.is_class)
12017 gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
12018 if (gen_dt && gen_dt->generic && gen_dt->generic->next
12019 && (!gen_dt->generic->sym->attr.use_assoc
12020 || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module)
12021 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Generic name '%s' of "
12022 "function '%s' at %L being the same name as derived "
12023 "type at %L", sym->name,
12024 gen_dt->generic->sym == sym
12025 ? gen_dt->generic->next->sym->name
12026 : gen_dt->generic->sym->name,
12027 gen_dt->generic->sym == sym
12028 ? &gen_dt->generic->next->sym->declared_at
12029 : &gen_dt->generic->sym->declared_at,
12030 &sym->declared_at) == FAILURE)
12033 if (sym->attr.is_class && sym->ts.u.derived == NULL)
12035 /* Fix up incomplete CLASS symbols. */
12036 gfc_component *data = gfc_find_component (sym, "_data", true, true);
12037 gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
12038 if (vptr->ts.u.derived == NULL)
12040 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
12042 vptr->ts.u.derived = vtab->ts.u.derived;
12046 if (resolve_fl_derived0 (sym) == FAILURE)
12049 /* Resolve the type-bound procedures. */
12050 if (resolve_typebound_procedures (sym) == FAILURE)
12053 /* Resolve the finalizer procedures. */
12054 if (gfc_resolve_finalizers (sym) == FAILURE)
12062 resolve_fl_namelist (gfc_symbol *sym)
12067 for (nl = sym->namelist; nl; nl = nl->next)
12069 /* Check again, the check in match only works if NAMELIST comes
12071 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
12073 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12074 "allowed", nl->sym->name, sym->name, &sym->declared_at);
12078 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
12079 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
12080 "object '%s' with assumed shape in namelist "
12081 "'%s' at %L", nl->sym->name, sym->name,
12082 &sym->declared_at) == FAILURE)
12085 if (is_non_constant_shape_array (nl->sym)
12086 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
12087 "object '%s' with nonconstant shape in namelist "
12088 "'%s' at %L", nl->sym->name, sym->name,
12089 &sym->declared_at) == FAILURE)
12092 if (nl->sym->ts.type == BT_CHARACTER
12093 && (nl->sym->ts.u.cl->length == NULL
12094 || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
12095 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
12096 "'%s' with nonconstant character length in "
12097 "namelist '%s' at %L", nl->sym->name, sym->name,
12098 &sym->declared_at) == FAILURE)
12101 /* FIXME: Once UDDTIO is implemented, the following can be
12103 if (nl->sym->ts.type == BT_CLASS)
12105 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12106 "polymorphic and requires a defined input/output "
12107 "procedure", nl->sym->name, sym->name, &sym->declared_at);
12111 if (nl->sym->ts.type == BT_DERIVED
12112 && (nl->sym->ts.u.derived->attr.alloc_comp
12113 || nl->sym->ts.u.derived->attr.pointer_comp))
12115 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
12116 "'%s' in namelist '%s' at %L with ALLOCATABLE "
12117 "or POINTER components", nl->sym->name,
12118 sym->name, &sym->declared_at) == FAILURE)
12121 /* FIXME: Once UDDTIO is implemented, the following can be
12123 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12124 "ALLOCATABLE or POINTER components and thus requires "
12125 "a defined input/output procedure", nl->sym->name,
12126 sym->name, &sym->declared_at);
12131 /* Reject PRIVATE objects in a PUBLIC namelist. */
12132 if (gfc_check_symbol_access (sym))
12134 for (nl = sym->namelist; nl; nl = nl->next)
12136 if (!nl->sym->attr.use_assoc
12137 && !is_sym_host_assoc (nl->sym, sym->ns)
12138 && !gfc_check_symbol_access (nl->sym))
12140 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12141 "cannot be member of PUBLIC namelist '%s' at %L",
12142 nl->sym->name, sym->name, &sym->declared_at);
12146 /* Types with private components that came here by USE-association. */
12147 if (nl->sym->ts.type == BT_DERIVED
12148 && derived_inaccessible (nl->sym->ts.u.derived))
12150 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12151 "components and cannot be member of namelist '%s' at %L",
12152 nl->sym->name, sym->name, &sym->declared_at);
12156 /* Types with private components that are defined in the same module. */
12157 if (nl->sym->ts.type == BT_DERIVED
12158 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
12159 && nl->sym->ts.u.derived->attr.private_comp)
12161 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12162 "cannot be a member of PUBLIC namelist '%s' at %L",
12163 nl->sym->name, sym->name, &sym->declared_at);
12170 /* 14.1.2 A module or internal procedure represent local entities
12171 of the same type as a namelist member and so are not allowed. */
12172 for (nl = sym->namelist; nl; nl = nl->next)
12174 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
12177 if (nl->sym->attr.function && nl->sym == nl->sym->result)
12178 if ((nl->sym == sym->ns->proc_name)
12180 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
12184 if (nl->sym && nl->sym->name)
12185 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
12186 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
12188 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12189 "attribute in '%s' at %L", nlsym->name,
12190 &sym->declared_at);
12200 resolve_fl_parameter (gfc_symbol *sym)
12202 /* A parameter array's shape needs to be constant. */
12203 if (sym->as != NULL
12204 && (sym->as->type == AS_DEFERRED
12205 || is_non_constant_shape_array (sym)))
12207 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12208 "or of deferred shape", sym->name, &sym->declared_at);
12212 /* Make sure a parameter that has been implicitly typed still
12213 matches the implicit type, since PARAMETER statements can precede
12214 IMPLICIT statements. */
12215 if (sym->attr.implicit_type
12216 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
12219 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12220 "later IMPLICIT type", sym->name, &sym->declared_at);
12224 /* Make sure the types of derived parameters are consistent. This
12225 type checking is deferred until resolution because the type may
12226 refer to a derived type from the host. */
12227 if (sym->ts.type == BT_DERIVED
12228 && !gfc_compare_types (&sym->ts, &sym->value->ts))
12230 gfc_error ("Incompatible derived type in PARAMETER at %L",
12231 &sym->value->where);
12238 /* Do anything necessary to resolve a symbol. Right now, we just
12239 assume that an otherwise unknown symbol is a variable. This sort
12240 of thing commonly happens for symbols in module. */
12243 resolve_symbol (gfc_symbol *sym)
12245 int check_constant, mp_flag;
12246 gfc_symtree *symtree;
12247 gfc_symtree *this_symtree;
12250 symbol_attribute class_attr;
12251 gfc_array_spec *as;
12253 if (sym->attr.flavor == FL_UNKNOWN)
12256 /* If we find that a flavorless symbol is an interface in one of the
12257 parent namespaces, find its symtree in this namespace, free the
12258 symbol and set the symtree to point to the interface symbol. */
12259 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
12261 symtree = gfc_find_symtree (ns->sym_root, sym->name);
12262 if (symtree && (symtree->n.sym->generic ||
12263 (symtree->n.sym->attr.flavor == FL_PROCEDURE
12264 && sym->ns->construct_entities)))
12266 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
12268 gfc_release_symbol (sym);
12269 symtree->n.sym->refs++;
12270 this_symtree->n.sym = symtree->n.sym;
12275 /* Otherwise give it a flavor according to such attributes as
12277 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
12278 sym->attr.flavor = FL_VARIABLE;
12281 sym->attr.flavor = FL_PROCEDURE;
12282 if (sym->attr.dimension)
12283 sym->attr.function = 1;
12287 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
12288 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
12290 if (sym->attr.procedure && sym->ts.interface
12291 && sym->attr.if_source != IFSRC_DECL
12292 && resolve_procedure_interface (sym) == FAILURE)
12295 if (sym->attr.is_protected && !sym->attr.proc_pointer
12296 && (sym->attr.procedure || sym->attr.external))
12298 if (sym->attr.external)
12299 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12300 "at %L", &sym->declared_at);
12302 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12303 "at %L", &sym->declared_at);
12308 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
12311 /* Symbols that are module procedures with results (functions) have
12312 the types and array specification copied for type checking in
12313 procedures that call them, as well as for saving to a module
12314 file. These symbols can't stand the scrutiny that their results
12316 mp_flag = (sym->result != NULL && sym->result != sym);
12318 /* Make sure that the intrinsic is consistent with its internal
12319 representation. This needs to be done before assigning a default
12320 type to avoid spurious warnings. */
12321 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
12322 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
12325 /* Resolve associate names. */
12327 resolve_assoc_var (sym, true);
12329 /* Assign default type to symbols that need one and don't have one. */
12330 if (sym->ts.type == BT_UNKNOWN)
12332 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
12334 gfc_set_default_type (sym, 1, NULL);
12337 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
12338 && !sym->attr.function && !sym->attr.subroutine
12339 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
12340 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
12342 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
12344 /* The specific case of an external procedure should emit an error
12345 in the case that there is no implicit type. */
12347 gfc_set_default_type (sym, sym->attr.external, NULL);
12350 /* Result may be in another namespace. */
12351 resolve_symbol (sym->result);
12353 if (!sym->result->attr.proc_pointer)
12355 sym->ts = sym->result->ts;
12356 sym->as = gfc_copy_array_spec (sym->result->as);
12357 sym->attr.dimension = sym->result->attr.dimension;
12358 sym->attr.pointer = sym->result->attr.pointer;
12359 sym->attr.allocatable = sym->result->attr.allocatable;
12360 sym->attr.contiguous = sym->result->attr.contiguous;
12365 else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
12366 gfc_resolve_array_spec (sym->result->as, false);
12368 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
12370 as = CLASS_DATA (sym)->as;
12371 class_attr = CLASS_DATA (sym)->attr;
12372 class_attr.pointer = class_attr.class_pointer;
12376 class_attr = sym->attr;
12381 if (sym->attr.contiguous
12382 && (!class_attr.dimension
12383 || (as->type != AS_ASSUMED_SHAPE && !class_attr.pointer)))
12385 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12386 "array pointer or an assumed-shape array", sym->name,
12387 &sym->declared_at);
12391 /* Assumed size arrays and assumed shape arrays must be dummy
12392 arguments. Array-spec's of implied-shape should have been resolved to
12393 AS_EXPLICIT already. */
12397 gcc_assert (as->type != AS_IMPLIED_SHAPE);
12398 if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
12399 || as->type == AS_ASSUMED_SHAPE)
12400 && sym->attr.dummy == 0)
12402 if (as->type == AS_ASSUMED_SIZE)
12403 gfc_error ("Assumed size array at %L must be a dummy argument",
12404 &sym->declared_at);
12406 gfc_error ("Assumed shape array at %L must be a dummy argument",
12407 &sym->declared_at);
12412 /* Make sure symbols with known intent or optional are really dummy
12413 variable. Because of ENTRY statement, this has to be deferred
12414 until resolution time. */
12416 if (!sym->attr.dummy
12417 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
12419 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
12423 if (sym->attr.value && !sym->attr.dummy)
12425 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12426 "it is not a dummy argument", sym->name, &sym->declared_at);
12430 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
12432 gfc_charlen *cl = sym->ts.u.cl;
12433 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
12435 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12436 "attribute must have constant length",
12437 sym->name, &sym->declared_at);
12441 if (sym->ts.is_c_interop
12442 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
12444 gfc_error ("C interoperable character dummy variable '%s' at %L "
12445 "with VALUE attribute must have length one",
12446 sym->name, &sym->declared_at);
12451 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
12452 && sym->ts.u.derived->attr.generic)
12454 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
12455 if (!sym->ts.u.derived)
12457 gfc_error ("The derived type '%s' at %L is of type '%s', "
12458 "which has not been defined", sym->name,
12459 &sym->declared_at, sym->ts.u.derived->name);
12460 sym->ts.type = BT_UNKNOWN;
12465 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12466 do this for something that was implicitly typed because that is handled
12467 in gfc_set_default_type. Handle dummy arguments and procedure
12468 definitions separately. Also, anything that is use associated is not
12469 handled here but instead is handled in the module it is declared in.
12470 Finally, derived type definitions are allowed to be BIND(C) since that
12471 only implies that they're interoperable, and they are checked fully for
12472 interoperability when a variable is declared of that type. */
12473 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
12474 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
12475 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
12477 gfc_try t = SUCCESS;
12479 /* First, make sure the variable is declared at the
12480 module-level scope (J3/04-007, Section 15.3). */
12481 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
12482 sym->attr.in_common == 0)
12484 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12485 "is neither a COMMON block nor declared at the "
12486 "module level scope", sym->name, &(sym->declared_at));
12489 else if (sym->common_head != NULL)
12491 t = verify_com_block_vars_c_interop (sym->common_head);
12495 /* If type() declaration, we need to verify that the components
12496 of the given type are all C interoperable, etc. */
12497 if (sym->ts.type == BT_DERIVED &&
12498 sym->ts.u.derived->attr.is_c_interop != 1)
12500 /* Make sure the user marked the derived type as BIND(C). If
12501 not, call the verify routine. This could print an error
12502 for the derived type more than once if multiple variables
12503 of that type are declared. */
12504 if (sym->ts.u.derived->attr.is_bind_c != 1)
12505 verify_bind_c_derived_type (sym->ts.u.derived);
12509 /* Verify the variable itself as C interoperable if it
12510 is BIND(C). It is not possible for this to succeed if
12511 the verify_bind_c_derived_type failed, so don't have to handle
12512 any error returned by verify_bind_c_derived_type. */
12513 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
12514 sym->common_block);
12519 /* clear the is_bind_c flag to prevent reporting errors more than
12520 once if something failed. */
12521 sym->attr.is_bind_c = 0;
12526 /* If a derived type symbol has reached this point, without its
12527 type being declared, we have an error. Notice that most
12528 conditions that produce undefined derived types have already
12529 been dealt with. However, the likes of:
12530 implicit type(t) (t) ..... call foo (t) will get us here if
12531 the type is not declared in the scope of the implicit
12532 statement. Change the type to BT_UNKNOWN, both because it is so
12533 and to prevent an ICE. */
12534 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
12535 && sym->ts.u.derived->components == NULL
12536 && !sym->ts.u.derived->attr.zero_comp)
12538 gfc_error ("The derived type '%s' at %L is of type '%s', "
12539 "which has not been defined", sym->name,
12540 &sym->declared_at, sym->ts.u.derived->name);
12541 sym->ts.type = BT_UNKNOWN;
12545 /* Make sure that the derived type has been resolved and that the
12546 derived type is visible in the symbol's namespace, if it is a
12547 module function and is not PRIVATE. */
12548 if (sym->ts.type == BT_DERIVED
12549 && sym->ts.u.derived->attr.use_assoc
12550 && sym->ns->proc_name
12551 && sym->ns->proc_name->attr.flavor == FL_MODULE
12552 && resolve_fl_derived (sym->ts.u.derived) == FAILURE)
12555 /* Unless the derived-type declaration is use associated, Fortran 95
12556 does not allow public entries of private derived types.
12557 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12558 161 in 95-006r3. */
12559 if (sym->ts.type == BT_DERIVED
12560 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12561 && !sym->ts.u.derived->attr.use_assoc
12562 && gfc_check_symbol_access (sym)
12563 && !gfc_check_symbol_access (sym->ts.u.derived)
12564 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12565 "of PRIVATE derived type '%s'",
12566 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12567 : "variable", sym->name, &sym->declared_at,
12568 sym->ts.u.derived->name) == FAILURE)
12571 /* F2008, C1302. */
12572 if (sym->ts.type == BT_DERIVED
12573 && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
12574 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
12575 || sym->ts.u.derived->attr.lock_comp)
12576 && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
12578 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
12579 "type LOCK_TYPE must be a coarray", sym->name,
12580 &sym->declared_at);
12584 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12585 default initialization is defined (5.1.2.4.4). */
12586 if (sym->ts.type == BT_DERIVED
12588 && sym->attr.intent == INTENT_OUT
12590 && sym->as->type == AS_ASSUMED_SIZE)
12592 for (c = sym->ts.u.derived->components; c; c = c->next)
12594 if (c->initializer)
12596 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12597 "ASSUMED SIZE and so cannot have a default initializer",
12598 sym->name, &sym->declared_at);
12605 if (sym->ts.type == BT_DERIVED && sym->attr.dummy
12606 && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
12608 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
12609 "INTENT(OUT)", sym->name, &sym->declared_at);
12614 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12615 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12616 && CLASS_DATA (sym)->attr.coarray_comp))
12617 || class_attr.codimension)
12618 && (sym->attr.result || sym->result == sym))
12620 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12621 "a coarray component", sym->name, &sym->declared_at);
12626 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12627 && sym->ts.u.derived->ts.is_iso_c)
12629 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12630 "shall not be a coarray", sym->name, &sym->declared_at);
12635 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12636 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12637 && CLASS_DATA (sym)->attr.coarray_comp))
12638 && (class_attr.codimension || class_attr.pointer || class_attr.dimension
12639 || class_attr.allocatable))
12641 gfc_error ("Variable '%s' at %L with coarray component "
12642 "shall be a nonpointer, nonallocatable scalar",
12643 sym->name, &sym->declared_at);
12647 /* F2008, C526. The function-result case was handled above. */
12648 if (class_attr.codimension
12649 && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
12650 || sym->attr.select_type_temporary
12651 || sym->ns->save_all
12652 || sym->ns->proc_name->attr.flavor == FL_MODULE
12653 || sym->ns->proc_name->attr.is_main_program
12654 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12656 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
12657 "nor a dummy argument", sym->name, &sym->declared_at);
12661 else if (class_attr.codimension && !sym->attr.select_type_temporary
12662 && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
12664 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12665 "deferred shape", sym->name, &sym->declared_at);
12668 else if (class_attr.codimension && class_attr.allocatable && as
12669 && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
12671 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12672 "deferred shape", sym->name, &sym->declared_at);
12677 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12678 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12679 && CLASS_DATA (sym)->attr.coarray_comp))
12680 || (class_attr.codimension && class_attr.allocatable))
12681 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12683 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12684 "allocatable coarray or have coarray components",
12685 sym->name, &sym->declared_at);
12689 if (class_attr.codimension && sym->attr.dummy
12690 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12692 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12693 "procedure '%s'", sym->name, &sym->declared_at,
12694 sym->ns->proc_name->name);
12698 switch (sym->attr.flavor)
12701 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12706 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12711 if (resolve_fl_namelist (sym) == FAILURE)
12716 if (resolve_fl_parameter (sym) == FAILURE)
12724 /* Resolve array specifier. Check as well some constraints
12725 on COMMON blocks. */
12727 check_constant = sym->attr.in_common && !sym->attr.pointer;
12729 /* Set the formal_arg_flag so that check_conflict will not throw
12730 an error for host associated variables in the specification
12731 expression for an array_valued function. */
12732 if (sym->attr.function && sym->as)
12733 formal_arg_flag = 1;
12735 gfc_resolve_array_spec (sym->as, check_constant);
12737 formal_arg_flag = 0;
12739 /* Resolve formal namespaces. */
12740 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12741 && !sym->attr.contained && !sym->attr.intrinsic)
12742 gfc_resolve (sym->formal_ns);
12744 /* Make sure the formal namespace is present. */
12745 if (sym->formal && !sym->formal_ns)
12747 gfc_formal_arglist *formal = sym->formal;
12748 while (formal && !formal->sym)
12749 formal = formal->next;
12753 sym->formal_ns = formal->sym->ns;
12754 sym->formal_ns->refs++;
12758 /* Check threadprivate restrictions. */
12759 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12760 && (!sym->attr.in_common
12761 && sym->module == NULL
12762 && (sym->ns->proc_name == NULL
12763 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12764 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12766 /* If we have come this far we can apply default-initializers, as
12767 described in 14.7.5, to those variables that have not already
12768 been assigned one. */
12769 if (sym->ts.type == BT_DERIVED
12770 && sym->ns == gfc_current_ns
12772 && !sym->attr.allocatable
12773 && !sym->attr.alloc_comp)
12775 symbol_attribute *a = &sym->attr;
12777 if ((!a->save && !a->dummy && !a->pointer
12778 && !a->in_common && !a->use_assoc
12779 && (a->referenced || a->result)
12780 && !(a->function && sym != sym->result))
12781 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12782 apply_default_init (sym);
12785 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
12786 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
12787 && !CLASS_DATA (sym)->attr.class_pointer
12788 && !CLASS_DATA (sym)->attr.allocatable)
12789 apply_default_init (sym);
12791 /* If this symbol has a type-spec, check it. */
12792 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12793 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12794 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12800 /************* Resolve DATA statements *************/
12804 gfc_data_value *vnode;
12810 /* Advance the values structure to point to the next value in the data list. */
12813 next_data_value (void)
12815 while (mpz_cmp_ui (values.left, 0) == 0)
12818 if (values.vnode->next == NULL)
12821 values.vnode = values.vnode->next;
12822 mpz_set (values.left, values.vnode->repeat);
12830 check_data_variable (gfc_data_variable *var, locus *where)
12836 ar_type mark = AR_UNKNOWN;
12838 mpz_t section_index[GFC_MAX_DIMENSIONS];
12844 if (gfc_resolve_expr (var->expr) == FAILURE)
12848 mpz_init_set_si (offset, 0);
12851 if (e->expr_type != EXPR_VARIABLE)
12852 gfc_internal_error ("check_data_variable(): Bad expression");
12854 sym = e->symtree->n.sym;
12856 if (sym->ns->is_block_data && !sym->attr.in_common)
12858 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12859 sym->name, &sym->declared_at);
12862 if (e->ref == NULL && sym->as)
12864 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12865 " declaration", sym->name, where);
12869 has_pointer = sym->attr.pointer;
12871 if (gfc_is_coindexed (e))
12873 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name,
12878 for (ref = e->ref; ref; ref = ref->next)
12880 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12884 && ref->type == REF_ARRAY
12885 && ref->u.ar.type != AR_FULL)
12887 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12888 "be a full array", sym->name, where);
12893 if (e->rank == 0 || has_pointer)
12895 mpz_init_set_ui (size, 1);
12902 /* Find the array section reference. */
12903 for (ref = e->ref; ref; ref = ref->next)
12905 if (ref->type != REF_ARRAY)
12907 if (ref->u.ar.type == AR_ELEMENT)
12913 /* Set marks according to the reference pattern. */
12914 switch (ref->u.ar.type)
12922 /* Get the start position of array section. */
12923 gfc_get_section_index (ar, section_index, &offset);
12928 gcc_unreachable ();
12931 if (gfc_array_size (e, &size) == FAILURE)
12933 gfc_error ("Nonconstant array section at %L in DATA statement",
12935 mpz_clear (offset);
12942 while (mpz_cmp_ui (size, 0) > 0)
12944 if (next_data_value () == FAILURE)
12946 gfc_error ("DATA statement at %L has more variables than values",
12952 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12956 /* If we have more than one element left in the repeat count,
12957 and we have more than one element left in the target variable,
12958 then create a range assignment. */
12959 /* FIXME: Only done for full arrays for now, since array sections
12961 if (mark == AR_FULL && ref && ref->next == NULL
12962 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12966 if (mpz_cmp (size, values.left) >= 0)
12968 mpz_init_set (range, values.left);
12969 mpz_sub (size, size, values.left);
12970 mpz_set_ui (values.left, 0);
12974 mpz_init_set (range, size);
12975 mpz_sub (values.left, values.left, size);
12976 mpz_set_ui (size, 0);
12979 t = gfc_assign_data_value (var->expr, values.vnode->expr,
12982 mpz_add (offset, offset, range);
12989 /* Assign initial value to symbol. */
12992 mpz_sub_ui (values.left, values.left, 1);
12993 mpz_sub_ui (size, size, 1);
12995 t = gfc_assign_data_value (var->expr, values.vnode->expr,
13000 if (mark == AR_FULL)
13001 mpz_add_ui (offset, offset, 1);
13003 /* Modify the array section indexes and recalculate the offset
13004 for next element. */
13005 else if (mark == AR_SECTION)
13006 gfc_advance_section (section_index, ar, &offset);
13010 if (mark == AR_SECTION)
13012 for (i = 0; i < ar->dimen; i++)
13013 mpz_clear (section_index[i]);
13017 mpz_clear (offset);
13023 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
13025 /* Iterate over a list of elements in a DATA statement. */
13028 traverse_data_list (gfc_data_variable *var, locus *where)
13031 iterator_stack frame;
13032 gfc_expr *e, *start, *end, *step;
13033 gfc_try retval = SUCCESS;
13035 mpz_init (frame.value);
13038 start = gfc_copy_expr (var->iter.start);
13039 end = gfc_copy_expr (var->iter.end);
13040 step = gfc_copy_expr (var->iter.step);
13042 if (gfc_simplify_expr (start, 1) == FAILURE
13043 || start->expr_type != EXPR_CONSTANT)
13045 gfc_error ("start of implied-do loop at %L could not be "
13046 "simplified to a constant value", &start->where);
13050 if (gfc_simplify_expr (end, 1) == FAILURE
13051 || end->expr_type != EXPR_CONSTANT)
13053 gfc_error ("end of implied-do loop at %L could not be "
13054 "simplified to a constant value", &start->where);
13058 if (gfc_simplify_expr (step, 1) == FAILURE
13059 || step->expr_type != EXPR_CONSTANT)
13061 gfc_error ("step of implied-do loop at %L could not be "
13062 "simplified to a constant value", &start->where);
13067 mpz_set (trip, end->value.integer);
13068 mpz_sub (trip, trip, start->value.integer);
13069 mpz_add (trip, trip, step->value.integer);
13071 mpz_div (trip, trip, step->value.integer);
13073 mpz_set (frame.value, start->value.integer);
13075 frame.prev = iter_stack;
13076 frame.variable = var->iter.var->symtree;
13077 iter_stack = &frame;
13079 while (mpz_cmp_ui (trip, 0) > 0)
13081 if (traverse_data_var (var->list, where) == FAILURE)
13087 e = gfc_copy_expr (var->expr);
13088 if (gfc_simplify_expr (e, 1) == FAILURE)
13095 mpz_add (frame.value, frame.value, step->value.integer);
13097 mpz_sub_ui (trip, trip, 1);
13101 mpz_clear (frame.value);
13104 gfc_free_expr (start);
13105 gfc_free_expr (end);
13106 gfc_free_expr (step);
13108 iter_stack = frame.prev;
13113 /* Type resolve variables in the variable list of a DATA statement. */
13116 traverse_data_var (gfc_data_variable *var, locus *where)
13120 for (; var; var = var->next)
13122 if (var->expr == NULL)
13123 t = traverse_data_list (var, where);
13125 t = check_data_variable (var, where);
13135 /* Resolve the expressions and iterators associated with a data statement.
13136 This is separate from the assignment checking because data lists should
13137 only be resolved once. */
13140 resolve_data_variables (gfc_data_variable *d)
13142 for (; d; d = d->next)
13144 if (d->list == NULL)
13146 if (gfc_resolve_expr (d->expr) == FAILURE)
13151 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
13154 if (resolve_data_variables (d->list) == FAILURE)
13163 /* Resolve a single DATA statement. We implement this by storing a pointer to
13164 the value list into static variables, and then recursively traversing the
13165 variables list, expanding iterators and such. */
13168 resolve_data (gfc_data *d)
13171 if (resolve_data_variables (d->var) == FAILURE)
13174 values.vnode = d->value;
13175 if (d->value == NULL)
13176 mpz_set_ui (values.left, 0);
13178 mpz_set (values.left, d->value->repeat);
13180 if (traverse_data_var (d->var, &d->where) == FAILURE)
13183 /* At this point, we better not have any values left. */
13185 if (next_data_value () == SUCCESS)
13186 gfc_error ("DATA statement at %L has more values than variables",
13191 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13192 accessed by host or use association, is a dummy argument to a pure function,
13193 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13194 is storage associated with any such variable, shall not be used in the
13195 following contexts: (clients of this function). */
13197 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13198 procedure. Returns zero if assignment is OK, nonzero if there is a
13201 gfc_impure_variable (gfc_symbol *sym)
13206 if (sym->attr.use_assoc || sym->attr.in_common)
13209 /* Check if the symbol's ns is inside the pure procedure. */
13210 for (ns = gfc_current_ns; ns; ns = ns->parent)
13214 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
13218 proc = sym->ns->proc_name;
13219 if (sym->attr.dummy
13220 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
13221 || proc->attr.function))
13224 /* TODO: Sort out what can be storage associated, if anything, and include
13225 it here. In principle equivalences should be scanned but it does not
13226 seem to be possible to storage associate an impure variable this way. */
13231 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13232 current namespace is inside a pure procedure. */
13235 gfc_pure (gfc_symbol *sym)
13237 symbol_attribute attr;
13242 /* Check if the current namespace or one of its parents
13243 belongs to a pure procedure. */
13244 for (ns = gfc_current_ns; ns; ns = ns->parent)
13246 sym = ns->proc_name;
13250 if (attr.flavor == FL_PROCEDURE && attr.pure)
13258 return attr.flavor == FL_PROCEDURE && attr.pure;
13262 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13263 checks if the current namespace is implicitly pure. Note that this
13264 function returns false for a PURE procedure. */
13267 gfc_implicit_pure (gfc_symbol *sym)
13273 /* Check if the current procedure is implicit_pure. Walk up
13274 the procedure list until we find a procedure. */
13275 for (ns = gfc_current_ns; ns; ns = ns->parent)
13277 sym = ns->proc_name;
13281 if (sym->attr.flavor == FL_PROCEDURE)
13286 return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
13287 && !sym->attr.pure;
13291 /* Test whether the current procedure is elemental or not. */
13294 gfc_elemental (gfc_symbol *sym)
13296 symbol_attribute attr;
13299 sym = gfc_current_ns->proc_name;
13304 return attr.flavor == FL_PROCEDURE && attr.elemental;
13308 /* Warn about unused labels. */
13311 warn_unused_fortran_label (gfc_st_label *label)
13316 warn_unused_fortran_label (label->left);
13318 if (label->defined == ST_LABEL_UNKNOWN)
13321 switch (label->referenced)
13323 case ST_LABEL_UNKNOWN:
13324 gfc_warning ("Label %d at %L defined but not used", label->value,
13328 case ST_LABEL_BAD_TARGET:
13329 gfc_warning ("Label %d at %L defined but cannot be used",
13330 label->value, &label->where);
13337 warn_unused_fortran_label (label->right);
13341 /* Returns the sequence type of a symbol or sequence. */
13344 sequence_type (gfc_typespec ts)
13353 if (ts.u.derived->components == NULL)
13354 return SEQ_NONDEFAULT;
13356 result = sequence_type (ts.u.derived->components->ts);
13357 for (c = ts.u.derived->components->next; c; c = c->next)
13358 if (sequence_type (c->ts) != result)
13364 if (ts.kind != gfc_default_character_kind)
13365 return SEQ_NONDEFAULT;
13367 return SEQ_CHARACTER;
13370 if (ts.kind != gfc_default_integer_kind)
13371 return SEQ_NONDEFAULT;
13373 return SEQ_NUMERIC;
13376 if (!(ts.kind == gfc_default_real_kind
13377 || ts.kind == gfc_default_double_kind))
13378 return SEQ_NONDEFAULT;
13380 return SEQ_NUMERIC;
13383 if (ts.kind != gfc_default_complex_kind)
13384 return SEQ_NONDEFAULT;
13386 return SEQ_NUMERIC;
13389 if (ts.kind != gfc_default_logical_kind)
13390 return SEQ_NONDEFAULT;
13392 return SEQ_NUMERIC;
13395 return SEQ_NONDEFAULT;
13400 /* Resolve derived type EQUIVALENCE object. */
13403 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
13405 gfc_component *c = derived->components;
13410 /* Shall not be an object of nonsequence derived type. */
13411 if (!derived->attr.sequence)
13413 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13414 "attribute to be an EQUIVALENCE object", sym->name,
13419 /* Shall not have allocatable components. */
13420 if (derived->attr.alloc_comp)
13422 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13423 "components to be an EQUIVALENCE object",sym->name,
13428 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
13430 gfc_error ("Derived type variable '%s' at %L with default "
13431 "initialization cannot be in EQUIVALENCE with a variable "
13432 "in COMMON", sym->name, &e->where);
13436 for (; c ; c = c->next)
13438 if (c->ts.type == BT_DERIVED
13439 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
13442 /* Shall not be an object of sequence derived type containing a pointer
13443 in the structure. */
13444 if (c->attr.pointer)
13446 gfc_error ("Derived type variable '%s' at %L with pointer "
13447 "component(s) cannot be an EQUIVALENCE object",
13448 sym->name, &e->where);
13456 /* Resolve equivalence object.
13457 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13458 an allocatable array, an object of nonsequence derived type, an object of
13459 sequence derived type containing a pointer at any level of component
13460 selection, an automatic object, a function name, an entry name, a result
13461 name, a named constant, a structure component, or a subobject of any of
13462 the preceding objects. A substring shall not have length zero. A
13463 derived type shall not have components with default initialization nor
13464 shall two objects of an equivalence group be initialized.
13465 Either all or none of the objects shall have an protected attribute.
13466 The simple constraints are done in symbol.c(check_conflict) and the rest
13467 are implemented here. */
13470 resolve_equivalence (gfc_equiv *eq)
13473 gfc_symbol *first_sym;
13476 locus *last_where = NULL;
13477 seq_type eq_type, last_eq_type;
13478 gfc_typespec *last_ts;
13479 int object, cnt_protected;
13482 last_ts = &eq->expr->symtree->n.sym->ts;
13484 first_sym = eq->expr->symtree->n.sym;
13488 for (object = 1; eq; eq = eq->eq, object++)
13492 e->ts = e->symtree->n.sym->ts;
13493 /* match_varspec might not know yet if it is seeing
13494 array reference or substring reference, as it doesn't
13496 if (e->ref && e->ref->type == REF_ARRAY)
13498 gfc_ref *ref = e->ref;
13499 sym = e->symtree->n.sym;
13501 if (sym->attr.dimension)
13503 ref->u.ar.as = sym->as;
13507 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13508 if (e->ts.type == BT_CHARACTER
13510 && ref->type == REF_ARRAY
13511 && ref->u.ar.dimen == 1
13512 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
13513 && ref->u.ar.stride[0] == NULL)
13515 gfc_expr *start = ref->u.ar.start[0];
13516 gfc_expr *end = ref->u.ar.end[0];
13519 /* Optimize away the (:) reference. */
13520 if (start == NULL && end == NULL)
13523 e->ref = ref->next;
13525 e->ref->next = ref->next;
13530 ref->type = REF_SUBSTRING;
13532 start = gfc_get_int_expr (gfc_default_integer_kind,
13534 ref->u.ss.start = start;
13535 if (end == NULL && e->ts.u.cl)
13536 end = gfc_copy_expr (e->ts.u.cl->length);
13537 ref->u.ss.end = end;
13538 ref->u.ss.length = e->ts.u.cl;
13545 /* Any further ref is an error. */
13548 gcc_assert (ref->type == REF_ARRAY);
13549 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13555 if (gfc_resolve_expr (e) == FAILURE)
13558 sym = e->symtree->n.sym;
13560 if (sym->attr.is_protected)
13562 if (cnt_protected > 0 && cnt_protected != object)
13564 gfc_error ("Either all or none of the objects in the "
13565 "EQUIVALENCE set at %L shall have the "
13566 "PROTECTED attribute",
13571 /* Shall not equivalence common block variables in a PURE procedure. */
13572 if (sym->ns->proc_name
13573 && sym->ns->proc_name->attr.pure
13574 && sym->attr.in_common)
13576 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13577 "object in the pure procedure '%s'",
13578 sym->name, &e->where, sym->ns->proc_name->name);
13582 /* Shall not be a named constant. */
13583 if (e->expr_type == EXPR_CONSTANT)
13585 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13586 "object", sym->name, &e->where);
13590 if (e->ts.type == BT_DERIVED
13591 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
13594 /* Check that the types correspond correctly:
13596 A numeric sequence structure may be equivalenced to another sequence
13597 structure, an object of default integer type, default real type, double
13598 precision real type, default logical type such that components of the
13599 structure ultimately only become associated to objects of the same
13600 kind. A character sequence structure may be equivalenced to an object
13601 of default character kind or another character sequence structure.
13602 Other objects may be equivalenced only to objects of the same type and
13603 kind parameters. */
13605 /* Identical types are unconditionally OK. */
13606 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
13607 goto identical_types;
13609 last_eq_type = sequence_type (*last_ts);
13610 eq_type = sequence_type (sym->ts);
13612 /* Since the pair of objects is not of the same type, mixed or
13613 non-default sequences can be rejected. */
13615 msg = "Sequence %s with mixed components in EQUIVALENCE "
13616 "statement at %L with different type objects";
13618 && last_eq_type == SEQ_MIXED
13619 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
13621 || (eq_type == SEQ_MIXED
13622 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13623 &e->where) == FAILURE))
13626 msg = "Non-default type object or sequence %s in EQUIVALENCE "
13627 "statement at %L with objects of different type";
13629 && last_eq_type == SEQ_NONDEFAULT
13630 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
13631 last_where) == FAILURE)
13632 || (eq_type == SEQ_NONDEFAULT
13633 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13634 &e->where) == FAILURE))
13637 msg ="Non-CHARACTER object '%s' in default CHARACTER "
13638 "EQUIVALENCE statement at %L";
13639 if (last_eq_type == SEQ_CHARACTER
13640 && eq_type != SEQ_CHARACTER
13641 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13642 &e->where) == FAILURE)
13645 msg ="Non-NUMERIC object '%s' in default NUMERIC "
13646 "EQUIVALENCE statement at %L";
13647 if (last_eq_type == SEQ_NUMERIC
13648 && eq_type != SEQ_NUMERIC
13649 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13650 &e->where) == FAILURE)
13655 last_where = &e->where;
13660 /* Shall not be an automatic array. */
13661 if (e->ref->type == REF_ARRAY
13662 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
13664 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13665 "an EQUIVALENCE object", sym->name, &e->where);
13672 /* Shall not be a structure component. */
13673 if (r->type == REF_COMPONENT)
13675 gfc_error ("Structure component '%s' at %L cannot be an "
13676 "EQUIVALENCE object",
13677 r->u.c.component->name, &e->where);
13681 /* A substring shall not have length zero. */
13682 if (r->type == REF_SUBSTRING)
13684 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13686 gfc_error ("Substring at %L has length zero",
13687 &r->u.ss.start->where);
13697 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13700 resolve_fntype (gfc_namespace *ns)
13702 gfc_entry_list *el;
13705 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13708 /* If there are any entries, ns->proc_name is the entry master
13709 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13711 sym = ns->entries->sym;
13713 sym = ns->proc_name;
13714 if (sym->result == sym
13715 && sym->ts.type == BT_UNKNOWN
13716 && gfc_set_default_type (sym, 0, NULL) == FAILURE
13717 && !sym->attr.untyped)
13719 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13720 sym->name, &sym->declared_at);
13721 sym->attr.untyped = 1;
13724 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13725 && !sym->attr.contained
13726 && !gfc_check_symbol_access (sym->ts.u.derived)
13727 && gfc_check_symbol_access (sym))
13729 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13730 "%L of PRIVATE type '%s'", sym->name,
13731 &sym->declared_at, sym->ts.u.derived->name);
13735 for (el = ns->entries->next; el; el = el->next)
13737 if (el->sym->result == el->sym
13738 && el->sym->ts.type == BT_UNKNOWN
13739 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13740 && !el->sym->attr.untyped)
13742 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13743 el->sym->name, &el->sym->declared_at);
13744 el->sym->attr.untyped = 1;
13750 /* 12.3.2.1.1 Defined operators. */
13753 check_uop_procedure (gfc_symbol *sym, locus where)
13755 gfc_formal_arglist *formal;
13757 if (!sym->attr.function)
13759 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13760 sym->name, &where);
13764 if (sym->ts.type == BT_CHARACTER
13765 && !(sym->ts.u.cl && sym->ts.u.cl->length)
13766 && !(sym->result && sym->result->ts.u.cl
13767 && sym->result->ts.u.cl->length))
13769 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13770 "character length", sym->name, &where);
13774 formal = sym->formal;
13775 if (!formal || !formal->sym)
13777 gfc_error ("User operator procedure '%s' at %L must have at least "
13778 "one argument", sym->name, &where);
13782 if (formal->sym->attr.intent != INTENT_IN)
13784 gfc_error ("First argument of operator interface at %L must be "
13785 "INTENT(IN)", &where);
13789 if (formal->sym->attr.optional)
13791 gfc_error ("First argument of operator interface at %L cannot be "
13792 "optional", &where);
13796 formal = formal->next;
13797 if (!formal || !formal->sym)
13800 if (formal->sym->attr.intent != INTENT_IN)
13802 gfc_error ("Second argument of operator interface at %L must be "
13803 "INTENT(IN)", &where);
13807 if (formal->sym->attr.optional)
13809 gfc_error ("Second argument of operator interface at %L cannot be "
13810 "optional", &where);
13816 gfc_error ("Operator interface at %L must have, at most, two "
13817 "arguments", &where);
13825 gfc_resolve_uops (gfc_symtree *symtree)
13827 gfc_interface *itr;
13829 if (symtree == NULL)
13832 gfc_resolve_uops (symtree->left);
13833 gfc_resolve_uops (symtree->right);
13835 for (itr = symtree->n.uop->op; itr; itr = itr->next)
13836 check_uop_procedure (itr->sym, itr->sym->declared_at);
13840 /* Examine all of the expressions associated with a program unit,
13841 assign types to all intermediate expressions, make sure that all
13842 assignments are to compatible types and figure out which names
13843 refer to which functions or subroutines. It doesn't check code
13844 block, which is handled by resolve_code. */
13847 resolve_types (gfc_namespace *ns)
13853 gfc_namespace* old_ns = gfc_current_ns;
13855 /* Check that all IMPLICIT types are ok. */
13856 if (!ns->seen_implicit_none)
13859 for (letter = 0; letter != GFC_LETTERS; ++letter)
13860 if (ns->set_flag[letter]
13861 && resolve_typespec_used (&ns->default_type[letter],
13862 &ns->implicit_loc[letter],
13867 gfc_current_ns = ns;
13869 resolve_entries (ns);
13871 resolve_common_vars (ns->blank_common.head, false);
13872 resolve_common_blocks (ns->common_root);
13874 resolve_contained_functions (ns);
13876 if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
13877 && ns->proc_name->attr.if_source == IFSRC_IFBODY)
13878 resolve_formal_arglist (ns->proc_name);
13880 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13882 for (cl = ns->cl_list; cl; cl = cl->next)
13883 resolve_charlen (cl);
13885 gfc_traverse_ns (ns, resolve_symbol);
13887 resolve_fntype (ns);
13889 for (n = ns->contained; n; n = n->sibling)
13891 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13892 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13893 "also be PURE", n->proc_name->name,
13894 &n->proc_name->declared_at);
13900 do_concurrent_flag = 0;
13901 gfc_check_interfaces (ns);
13903 gfc_traverse_ns (ns, resolve_values);
13909 for (d = ns->data; d; d = d->next)
13913 gfc_traverse_ns (ns, gfc_formalize_init_value);
13915 gfc_traverse_ns (ns, gfc_verify_binding_labels);
13917 if (ns->common_root != NULL)
13918 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13920 for (eq = ns->equiv; eq; eq = eq->next)
13921 resolve_equivalence (eq);
13923 /* Warn about unused labels. */
13924 if (warn_unused_label)
13925 warn_unused_fortran_label (ns->st_labels);
13927 gfc_resolve_uops (ns->uop_root);
13929 gfc_current_ns = old_ns;
13933 /* Call resolve_code recursively. */
13936 resolve_codes (gfc_namespace *ns)
13939 bitmap_obstack old_obstack;
13941 if (ns->resolved == 1)
13944 for (n = ns->contained; n; n = n->sibling)
13947 gfc_current_ns = ns;
13949 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13950 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13953 /* Set to an out of range value. */
13954 current_entry_id = -1;
13956 old_obstack = labels_obstack;
13957 bitmap_obstack_initialize (&labels_obstack);
13959 resolve_code (ns->code, ns);
13961 bitmap_obstack_release (&labels_obstack);
13962 labels_obstack = old_obstack;
13966 /* This function is called after a complete program unit has been compiled.
13967 Its purpose is to examine all of the expressions associated with a program
13968 unit, assign types to all intermediate expressions, make sure that all
13969 assignments are to compatible types and figure out which names refer to
13970 which functions or subroutines. */
13973 gfc_resolve (gfc_namespace *ns)
13975 gfc_namespace *old_ns;
13976 code_stack *old_cs_base;
13982 old_ns = gfc_current_ns;
13983 old_cs_base = cs_base;
13985 resolve_types (ns);
13986 resolve_codes (ns);
13988 gfc_current_ns = old_ns;
13989 cs_base = old_cs_base;
13992 gfc_run_passes (ns);