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->next != NULL && arg->next->expr)
3160 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3163 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3166 if ((int)mpz_get_si (arg->next->expr->value.integer)
3171 if (arg->expr != NULL
3172 && arg->expr->rank > 0
3173 && resolve_assumed_size_actual (arg->expr))
3179 need_full_assumed_size = temp;
3182 if (!pure_function (expr, &name) && name)
3186 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3187 "FORALL %s", name, &expr->where,
3188 forall_flag == 2 ? "mask" : "block");
3191 else if (do_concurrent_flag)
3193 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3194 "DO CONCURRENT %s", name, &expr->where,
3195 do_concurrent_flag == 2 ? "mask" : "block");
3198 else if (gfc_pure (NULL))
3200 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3201 "procedure within a PURE procedure", name, &expr->where);
3205 if (gfc_implicit_pure (NULL))
3206 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3209 /* Functions without the RECURSIVE attribution are not allowed to
3210 * call themselves. */
3211 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3214 esym = expr->value.function.esym;
3216 if (is_illegal_recursion (esym, gfc_current_ns))
3218 if (esym->attr.entry && esym->ns->entries)
3219 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3220 " function '%s' is not RECURSIVE",
3221 esym->name, &expr->where, esym->ns->entries->sym->name);
3223 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3224 " is not RECURSIVE", esym->name, &expr->where);
3230 /* Character lengths of use associated functions may contains references to
3231 symbols not referenced from the current program unit otherwise. Make sure
3232 those symbols are marked as referenced. */
3234 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3235 && expr->value.function.esym->attr.use_assoc)
3237 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3240 /* Make sure that the expression has a typespec that works. */
3241 if (expr->ts.type == BT_UNKNOWN)
3243 if (expr->symtree->n.sym->result
3244 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3245 && !expr->symtree->n.sym->result->attr.proc_pointer)
3246 expr->ts = expr->symtree->n.sym->result->ts;
3253 /************* Subroutine resolution *************/
3256 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3262 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3263 sym->name, &c->loc);
3264 else if (do_concurrent_flag)
3265 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3266 "PURE", sym->name, &c->loc);
3267 else if (gfc_pure (NULL))
3268 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3271 if (gfc_implicit_pure (NULL))
3272 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3277 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3281 if (sym->attr.generic)
3283 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3286 c->resolved_sym = s;
3287 pure_subroutine (c, s);
3291 /* TODO: Need to search for elemental references in generic interface. */
3294 if (sym->attr.intrinsic)
3295 return gfc_intrinsic_sub_interface (c, 0);
3302 resolve_generic_s (gfc_code *c)
3307 sym = c->symtree->n.sym;
3311 m = resolve_generic_s0 (c, sym);
3314 else if (m == MATCH_ERROR)
3318 if (sym->ns->parent == NULL)
3320 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3324 if (!generic_sym (sym))
3328 /* Last ditch attempt. See if the reference is to an intrinsic
3329 that possesses a matching interface. 14.1.2.4 */
3330 sym = c->symtree->n.sym;
3332 if (!gfc_is_intrinsic (sym, 1, c->loc))
3334 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3335 sym->name, &c->loc);
3339 m = gfc_intrinsic_sub_interface (c, 0);
3343 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3344 "intrinsic subroutine interface", sym->name, &c->loc);
3350 /* Set the name and binding label of the subroutine symbol in the call
3351 expression represented by 'c' to include the type and kind of the
3352 second parameter. This function is for resolving the appropriate
3353 version of c_f_pointer() and c_f_procpointer(). For example, a
3354 call to c_f_pointer() for a default integer pointer could have a
3355 name of c_f_pointer_i4. If no second arg exists, which is an error
3356 for these two functions, it defaults to the generic symbol's name
3357 and binding label. */
3360 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3361 char *name, const char **binding_label)
3363 gfc_expr *arg = NULL;
3367 /* The second arg of c_f_pointer and c_f_procpointer determines
3368 the type and kind for the procedure name. */
3369 arg = c->ext.actual->next->expr;
3373 /* Set up the name to have the given symbol's name,
3374 plus the type and kind. */
3375 /* a derived type is marked with the type letter 'u' */
3376 if (arg->ts.type == BT_DERIVED)
3379 kind = 0; /* set the kind as 0 for now */
3383 type = gfc_type_letter (arg->ts.type);
3384 kind = arg->ts.kind;
3387 if (arg->ts.type == BT_CHARACTER)
3388 /* Kind info for character strings not needed. */
3391 sprintf (name, "%s_%c%d", sym->name, type, kind);
3392 /* Set up the binding label as the given symbol's label plus
3393 the type and kind. */
3394 *binding_label = gfc_get_string ("%s_%c%d", sym->binding_label, type,
3399 /* If the second arg is missing, set the name and label as
3400 was, cause it should at least be found, and the missing
3401 arg error will be caught by compare_parameters(). */
3402 sprintf (name, "%s", sym->name);
3403 *binding_label = sym->binding_label;
3410 /* Resolve a generic version of the iso_c_binding procedure given
3411 (sym) to the specific one based on the type and kind of the
3412 argument(s). Currently, this function resolves c_f_pointer() and
3413 c_f_procpointer based on the type and kind of the second argument
3414 (FPTR). Other iso_c_binding procedures aren't specially handled.
3415 Upon successfully exiting, c->resolved_sym will hold the resolved
3416 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3420 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3422 gfc_symbol *new_sym;
3423 /* this is fine, since we know the names won't use the max */
3424 char name[GFC_MAX_SYMBOL_LEN + 1];
3425 const char* binding_label;
3426 /* default to success; will override if find error */
3427 match m = MATCH_YES;
3429 /* Make sure the actual arguments are in the necessary order (based on the
3430 formal args) before resolving. */
3431 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3433 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3434 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3436 set_name_and_label (c, sym, name, &binding_label);
3438 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3440 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3442 /* Make sure we got a third arg if the second arg has non-zero
3443 rank. We must also check that the type and rank are
3444 correct since we short-circuit this check in
3445 gfc_procedure_use() (called above to sort actual args). */
3446 if (c->ext.actual->next->expr->rank != 0)
3448 if(c->ext.actual->next->next == NULL
3449 || c->ext.actual->next->next->expr == NULL)
3452 gfc_error ("Missing SHAPE parameter for call to %s "
3453 "at %L", sym->name, &(c->loc));
3455 else if (c->ext.actual->next->next->expr->ts.type
3457 || c->ext.actual->next->next->expr->rank != 1)
3460 gfc_error ("SHAPE parameter for call to %s at %L must "
3461 "be a rank 1 INTEGER array", sym->name,
3468 if (m != MATCH_ERROR)
3470 /* the 1 means to add the optional arg to formal list */
3471 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3473 /* for error reporting, say it's declared where the original was */
3474 new_sym->declared_at = sym->declared_at;
3479 /* no differences for c_loc or c_funloc */
3483 /* set the resolved symbol */
3484 if (m != MATCH_ERROR)
3485 c->resolved_sym = new_sym;
3487 c->resolved_sym = sym;
3493 /* Resolve a subroutine call known to be specific. */
3496 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3500 if(sym->attr.is_iso_c)
3502 m = gfc_iso_c_sub_interface (c,sym);
3506 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3508 if (sym->attr.dummy)
3510 sym->attr.proc = PROC_DUMMY;
3514 sym->attr.proc = PROC_EXTERNAL;
3518 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3521 if (sym->attr.intrinsic)
3523 m = gfc_intrinsic_sub_interface (c, 1);
3527 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3528 "with an intrinsic", sym->name, &c->loc);
3536 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3538 c->resolved_sym = sym;
3539 pure_subroutine (c, sym);
3546 resolve_specific_s (gfc_code *c)
3551 sym = c->symtree->n.sym;
3555 m = resolve_specific_s0 (c, sym);
3558 if (m == MATCH_ERROR)
3561 if (sym->ns->parent == NULL)
3564 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3570 sym = c->symtree->n.sym;
3571 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3572 sym->name, &c->loc);
3578 /* Resolve a subroutine call not known to be generic nor specific. */
3581 resolve_unknown_s (gfc_code *c)
3585 sym = c->symtree->n.sym;
3587 if (sym->attr.dummy)
3589 sym->attr.proc = PROC_DUMMY;
3593 /* See if we have an intrinsic function reference. */
3595 if (gfc_is_intrinsic (sym, 1, c->loc))
3597 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3602 /* The reference is to an external name. */
3605 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3607 c->resolved_sym = sym;
3609 pure_subroutine (c, sym);
3615 /* Resolve a subroutine call. Although it was tempting to use the same code
3616 for functions, subroutines and functions are stored differently and this
3617 makes things awkward. */
3620 resolve_call (gfc_code *c)
3623 procedure_type ptype = PROC_INTRINSIC;
3624 gfc_symbol *csym, *sym;
3625 bool no_formal_args;
3627 csym = c->symtree ? c->symtree->n.sym : NULL;
3629 if (csym && csym->ts.type != BT_UNKNOWN)
3631 gfc_error ("'%s' at %L has a type, which is not consistent with "
3632 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3636 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3639 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3640 sym = st ? st->n.sym : NULL;
3641 if (sym && csym != sym
3642 && sym->ns == gfc_current_ns
3643 && sym->attr.flavor == FL_PROCEDURE
3644 && sym->attr.contained)
3647 if (csym->attr.generic)
3648 c->symtree->n.sym = sym;
3651 csym = c->symtree->n.sym;
3655 /* If this ia a deferred TBP with an abstract interface
3656 (which may of course be referenced), c->expr1 will be set. */
3657 if (csym && csym->attr.abstract && !c->expr1)
3659 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3660 csym->name, &c->loc);
3664 /* Subroutines without the RECURSIVE attribution are not allowed to
3665 * call themselves. */
3666 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3668 if (csym->attr.entry && csym->ns->entries)
3669 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3670 " subroutine '%s' is not RECURSIVE",
3671 csym->name, &c->loc, csym->ns->entries->sym->name);
3673 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3674 " is not RECURSIVE", csym->name, &c->loc);
3679 /* Switch off assumed size checking and do this again for certain kinds
3680 of procedure, once the procedure itself is resolved. */
3681 need_full_assumed_size++;
3684 ptype = csym->attr.proc;
3686 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3687 if (resolve_actual_arglist (c->ext.actual, ptype,
3688 no_formal_args) == FAILURE)
3691 /* Resume assumed_size checking. */
3692 need_full_assumed_size--;
3694 /* If external, check for usage. */
3695 if (csym && is_external_proc (csym))
3696 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3699 if (c->resolved_sym == NULL)
3701 c->resolved_isym = NULL;
3702 switch (procedure_kind (csym))
3705 t = resolve_generic_s (c);
3708 case PTYPE_SPECIFIC:
3709 t = resolve_specific_s (c);
3713 t = resolve_unknown_s (c);
3717 gfc_internal_error ("resolve_subroutine(): bad function type");
3721 /* Some checks of elemental subroutine actual arguments. */
3722 if (resolve_elemental_actual (NULL, c) == FAILURE)
3729 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3730 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3731 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3732 if their shapes do not match. If either op1->shape or op2->shape is
3733 NULL, return SUCCESS. */
3736 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3743 if (op1->shape != NULL && op2->shape != NULL)
3745 for (i = 0; i < op1->rank; i++)
3747 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3749 gfc_error ("Shapes for operands at %L and %L are not conformable",
3750 &op1->where, &op2->where);
3761 /* Resolve an operator expression node. This can involve replacing the
3762 operation with a user defined function call. */
3765 resolve_operator (gfc_expr *e)
3767 gfc_expr *op1, *op2;
3769 bool dual_locus_error;
3772 /* Resolve all subnodes-- give them types. */
3774 switch (e->value.op.op)
3777 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3780 /* Fall through... */
3783 case INTRINSIC_UPLUS:
3784 case INTRINSIC_UMINUS:
3785 case INTRINSIC_PARENTHESES:
3786 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3791 /* Typecheck the new node. */
3793 op1 = e->value.op.op1;
3794 op2 = e->value.op.op2;
3795 dual_locus_error = false;
3797 if ((op1 && op1->expr_type == EXPR_NULL)
3798 || (op2 && op2->expr_type == EXPR_NULL))
3800 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3804 switch (e->value.op.op)
3806 case INTRINSIC_UPLUS:
3807 case INTRINSIC_UMINUS:
3808 if (op1->ts.type == BT_INTEGER
3809 || op1->ts.type == BT_REAL
3810 || op1->ts.type == BT_COMPLEX)
3816 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3817 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3820 case INTRINSIC_PLUS:
3821 case INTRINSIC_MINUS:
3822 case INTRINSIC_TIMES:
3823 case INTRINSIC_DIVIDE:
3824 case INTRINSIC_POWER:
3825 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3827 gfc_type_convert_binary (e, 1);
3832 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3833 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3834 gfc_typename (&op2->ts));
3837 case INTRINSIC_CONCAT:
3838 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3839 && op1->ts.kind == op2->ts.kind)
3841 e->ts.type = BT_CHARACTER;
3842 e->ts.kind = op1->ts.kind;
3847 _("Operands of string concatenation operator at %%L are %s/%s"),
3848 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3854 case INTRINSIC_NEQV:
3855 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3857 e->ts.type = BT_LOGICAL;
3858 e->ts.kind = gfc_kind_max (op1, op2);
3859 if (op1->ts.kind < e->ts.kind)
3860 gfc_convert_type (op1, &e->ts, 2);
3861 else if (op2->ts.kind < e->ts.kind)
3862 gfc_convert_type (op2, &e->ts, 2);
3866 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3867 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3868 gfc_typename (&op2->ts));
3873 if (op1->ts.type == BT_LOGICAL)
3875 e->ts.type = BT_LOGICAL;
3876 e->ts.kind = op1->ts.kind;
3880 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3881 gfc_typename (&op1->ts));
3885 case INTRINSIC_GT_OS:
3887 case INTRINSIC_GE_OS:
3889 case INTRINSIC_LT_OS:
3891 case INTRINSIC_LE_OS:
3892 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3894 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3898 /* Fall through... */
3901 case INTRINSIC_EQ_OS:
3903 case INTRINSIC_NE_OS:
3904 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3905 && op1->ts.kind == op2->ts.kind)
3907 e->ts.type = BT_LOGICAL;
3908 e->ts.kind = gfc_default_logical_kind;
3912 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3914 gfc_type_convert_binary (e, 1);
3916 e->ts.type = BT_LOGICAL;
3917 e->ts.kind = gfc_default_logical_kind;
3921 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3923 _("Logicals at %%L must be compared with %s instead of %s"),
3924 (e->value.op.op == INTRINSIC_EQ
3925 || e->value.op.op == INTRINSIC_EQ_OS)
3926 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3929 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3930 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3931 gfc_typename (&op2->ts));
3935 case INTRINSIC_USER:
3936 if (e->value.op.uop->op == NULL)
3937 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3938 else if (op2 == NULL)
3939 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3940 e->value.op.uop->name, gfc_typename (&op1->ts));
3943 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3944 e->value.op.uop->name, gfc_typename (&op1->ts),
3945 gfc_typename (&op2->ts));
3946 e->value.op.uop->op->sym->attr.referenced = 1;
3951 case INTRINSIC_PARENTHESES:
3953 if (e->ts.type == BT_CHARACTER)
3954 e->ts.u.cl = op1->ts.u.cl;
3958 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3961 /* Deal with arrayness of an operand through an operator. */
3965 switch (e->value.op.op)
3967 case INTRINSIC_PLUS:
3968 case INTRINSIC_MINUS:
3969 case INTRINSIC_TIMES:
3970 case INTRINSIC_DIVIDE:
3971 case INTRINSIC_POWER:
3972 case INTRINSIC_CONCAT:
3976 case INTRINSIC_NEQV:
3978 case INTRINSIC_EQ_OS:
3980 case INTRINSIC_NE_OS:
3982 case INTRINSIC_GT_OS:
3984 case INTRINSIC_GE_OS:
3986 case INTRINSIC_LT_OS:
3988 case INTRINSIC_LE_OS:
3990 if (op1->rank == 0 && op2->rank == 0)
3993 if (op1->rank == 0 && op2->rank != 0)
3995 e->rank = op2->rank;
3997 if (e->shape == NULL)
3998 e->shape = gfc_copy_shape (op2->shape, op2->rank);
4001 if (op1->rank != 0 && op2->rank == 0)
4003 e->rank = op1->rank;
4005 if (e->shape == NULL)
4006 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4009 if (op1->rank != 0 && op2->rank != 0)
4011 if (op1->rank == op2->rank)
4013 e->rank = op1->rank;
4014 if (e->shape == NULL)
4016 t = compare_shapes (op1, op2);
4020 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4025 /* Allow higher level expressions to work. */
4028 /* Try user-defined operators, and otherwise throw an error. */
4029 dual_locus_error = true;
4031 _("Inconsistent ranks for operator at %%L and %%L"));
4038 case INTRINSIC_PARENTHESES:
4040 case INTRINSIC_UPLUS:
4041 case INTRINSIC_UMINUS:
4042 /* Simply copy arrayness attribute */
4043 e->rank = op1->rank;
4045 if (e->shape == NULL)
4046 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4054 /* Attempt to simplify the expression. */
4057 t = gfc_simplify_expr (e, 0);
4058 /* Some calls do not succeed in simplification and return FAILURE
4059 even though there is no error; e.g. variable references to
4060 PARAMETER arrays. */
4061 if (!gfc_is_constant_expr (e))
4069 match m = gfc_extend_expr (e);
4072 if (m == MATCH_ERROR)
4076 if (dual_locus_error)
4077 gfc_error (msg, &op1->where, &op2->where);
4079 gfc_error (msg, &e->where);
4085 /************** Array resolution subroutines **************/
4088 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
4091 /* Compare two integer expressions. */
4094 compare_bound (gfc_expr *a, gfc_expr *b)
4098 if (a == NULL || a->expr_type != EXPR_CONSTANT
4099 || b == NULL || b->expr_type != EXPR_CONSTANT)
4102 /* If either of the types isn't INTEGER, we must have
4103 raised an error earlier. */
4105 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
4108 i = mpz_cmp (a->value.integer, b->value.integer);
4118 /* Compare an integer expression with an integer. */
4121 compare_bound_int (gfc_expr *a, int b)
4125 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4128 if (a->ts.type != BT_INTEGER)
4129 gfc_internal_error ("compare_bound_int(): Bad expression");
4131 i = mpz_cmp_si (a->value.integer, b);
4141 /* Compare an integer expression with a mpz_t. */
4144 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4148 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4151 if (a->ts.type != BT_INTEGER)
4152 gfc_internal_error ("compare_bound_int(): Bad expression");
4154 i = mpz_cmp (a->value.integer, b);
4164 /* Compute the last value of a sequence given by a triplet.
4165 Return 0 if it wasn't able to compute the last value, or if the
4166 sequence if empty, and 1 otherwise. */
4169 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4170 gfc_expr *stride, mpz_t last)
4174 if (start == NULL || start->expr_type != EXPR_CONSTANT
4175 || end == NULL || end->expr_type != EXPR_CONSTANT
4176 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4179 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4180 || (stride != NULL && stride->ts.type != BT_INTEGER))
4183 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
4185 if (compare_bound (start, end) == CMP_GT)
4187 mpz_set (last, end->value.integer);
4191 if (compare_bound_int (stride, 0) == CMP_GT)
4193 /* Stride is positive */
4194 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4199 /* Stride is negative */
4200 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4205 mpz_sub (rem, end->value.integer, start->value.integer);
4206 mpz_tdiv_r (rem, rem, stride->value.integer);
4207 mpz_sub (last, end->value.integer, rem);
4214 /* Compare a single dimension of an array reference to the array
4218 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4222 if (ar->dimen_type[i] == DIMEN_STAR)
4224 gcc_assert (ar->stride[i] == NULL);
4225 /* This implies [*] as [*:] and [*:3] are not possible. */
4226 if (ar->start[i] == NULL)
4228 gcc_assert (ar->end[i] == NULL);
4233 /* Given start, end and stride values, calculate the minimum and
4234 maximum referenced indexes. */
4236 switch (ar->dimen_type[i])
4239 case DIMEN_THIS_IMAGE:
4244 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4247 gfc_warning ("Array reference at %L is out of bounds "
4248 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4249 mpz_get_si (ar->start[i]->value.integer),
4250 mpz_get_si (as->lower[i]->value.integer), i+1);
4252 gfc_warning ("Array reference at %L is out of bounds "
4253 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4254 mpz_get_si (ar->start[i]->value.integer),
4255 mpz_get_si (as->lower[i]->value.integer),
4259 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4262 gfc_warning ("Array reference at %L is out of bounds "
4263 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4264 mpz_get_si (ar->start[i]->value.integer),
4265 mpz_get_si (as->upper[i]->value.integer), i+1);
4267 gfc_warning ("Array reference at %L is out of bounds "
4268 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4269 mpz_get_si (ar->start[i]->value.integer),
4270 mpz_get_si (as->upper[i]->value.integer),
4279 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4280 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4282 comparison comp_start_end = compare_bound (AR_START, AR_END);
4284 /* Check for zero stride, which is not allowed. */
4285 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4287 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4291 /* if start == len || (stride > 0 && start < len)
4292 || (stride < 0 && start > len),
4293 then the array section contains at least one element. In this
4294 case, there is an out-of-bounds access if
4295 (start < lower || start > upper). */
4296 if (compare_bound (AR_START, AR_END) == CMP_EQ
4297 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4298 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4299 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4300 && comp_start_end == CMP_GT))
4302 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4304 gfc_warning ("Lower array reference at %L is out of bounds "
4305 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4306 mpz_get_si (AR_START->value.integer),
4307 mpz_get_si (as->lower[i]->value.integer), i+1);
4310 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4312 gfc_warning ("Lower array reference at %L is out of bounds "
4313 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4314 mpz_get_si (AR_START->value.integer),
4315 mpz_get_si (as->upper[i]->value.integer), i+1);
4320 /* If we can compute the highest index of the array section,
4321 then it also has to be between lower and upper. */
4322 mpz_init (last_value);
4323 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4326 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4328 gfc_warning ("Upper array reference at %L is out of bounds "
4329 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4330 mpz_get_si (last_value),
4331 mpz_get_si (as->lower[i]->value.integer), i+1);
4332 mpz_clear (last_value);
4335 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4337 gfc_warning ("Upper array reference at %L is out of bounds "
4338 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4339 mpz_get_si (last_value),
4340 mpz_get_si (as->upper[i]->value.integer), i+1);
4341 mpz_clear (last_value);
4345 mpz_clear (last_value);
4353 gfc_internal_error ("check_dimension(): Bad array reference");
4360 /* Compare an array reference with an array specification. */
4363 compare_spec_to_ref (gfc_array_ref *ar)
4370 /* TODO: Full array sections are only allowed as actual parameters. */
4371 if (as->type == AS_ASSUMED_SIZE
4372 && (/*ar->type == AR_FULL
4373 ||*/ (ar->type == AR_SECTION
4374 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4376 gfc_error ("Rightmost upper bound of assumed size array section "
4377 "not specified at %L", &ar->where);
4381 if (ar->type == AR_FULL)
4384 if (as->rank != ar->dimen)
4386 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4387 &ar->where, ar->dimen, as->rank);
4391 /* ar->codimen == 0 is a local array. */
4392 if (as->corank != ar->codimen && ar->codimen != 0)
4394 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4395 &ar->where, ar->codimen, as->corank);
4399 for (i = 0; i < as->rank; i++)
4400 if (check_dimension (i, ar, as) == FAILURE)
4403 /* Local access has no coarray spec. */
4404 if (ar->codimen != 0)
4405 for (i = as->rank; i < as->rank + as->corank; i++)
4407 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
4408 && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
4410 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4411 i + 1 - as->rank, &ar->where);
4414 if (check_dimension (i, ar, as) == FAILURE)
4422 /* Resolve one part of an array index. */
4425 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4426 int force_index_integer_kind)
4433 if (gfc_resolve_expr (index) == FAILURE)
4436 if (check_scalar && index->rank != 0)
4438 gfc_error ("Array index at %L must be scalar", &index->where);
4442 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4444 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4445 &index->where, gfc_basic_typename (index->ts.type));
4449 if (index->ts.type == BT_REAL)
4450 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
4451 &index->where) == FAILURE)
4454 if ((index->ts.kind != gfc_index_integer_kind
4455 && force_index_integer_kind)
4456 || index->ts.type != BT_INTEGER)
4459 ts.type = BT_INTEGER;
4460 ts.kind = gfc_index_integer_kind;
4462 gfc_convert_type_warn (index, &ts, 2, 0);
4468 /* Resolve one part of an array index. */
4471 gfc_resolve_index (gfc_expr *index, int check_scalar)
4473 return gfc_resolve_index_1 (index, check_scalar, 1);
4476 /* Resolve a dim argument to an intrinsic function. */
4479 gfc_resolve_dim_arg (gfc_expr *dim)
4484 if (gfc_resolve_expr (dim) == FAILURE)
4489 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4494 if (dim->ts.type != BT_INTEGER)
4496 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4500 if (dim->ts.kind != gfc_index_integer_kind)
4505 ts.type = BT_INTEGER;
4506 ts.kind = gfc_index_integer_kind;
4508 gfc_convert_type_warn (dim, &ts, 2, 0);
4514 /* Given an expression that contains array references, update those array
4515 references to point to the right array specifications. While this is
4516 filled in during matching, this information is difficult to save and load
4517 in a module, so we take care of it here.
4519 The idea here is that the original array reference comes from the
4520 base symbol. We traverse the list of reference structures, setting
4521 the stored reference to references. Component references can
4522 provide an additional array specification. */
4525 find_array_spec (gfc_expr *e)
4531 if (e->symtree->n.sym->ts.type == BT_CLASS)
4532 as = CLASS_DATA (e->symtree->n.sym)->as;
4534 as = e->symtree->n.sym->as;
4536 for (ref = e->ref; ref; ref = ref->next)
4541 gfc_internal_error ("find_array_spec(): Missing spec");
4548 c = ref->u.c.component;
4549 if (c->attr.dimension)
4552 gfc_internal_error ("find_array_spec(): unused as(1)");
4563 gfc_internal_error ("find_array_spec(): unused as(2)");
4567 /* Resolve an array reference. */
4570 resolve_array_ref (gfc_array_ref *ar)
4572 int i, check_scalar;
4575 for (i = 0; i < ar->dimen + ar->codimen; i++)
4577 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4579 /* Do not force gfc_index_integer_kind for the start. We can
4580 do fine with any integer kind. This avoids temporary arrays
4581 created for indexing with a vector. */
4582 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4584 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4586 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4591 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4595 ar->dimen_type[i] = DIMEN_ELEMENT;
4599 ar->dimen_type[i] = DIMEN_VECTOR;
4600 if (e->expr_type == EXPR_VARIABLE
4601 && e->symtree->n.sym->ts.type == BT_DERIVED)
4602 ar->start[i] = gfc_get_parentheses (e);
4606 gfc_error ("Array index at %L is an array of rank %d",
4607 &ar->c_where[i], e->rank);
4611 /* Fill in the upper bound, which may be lower than the
4612 specified one for something like a(2:10:5), which is
4613 identical to a(2:7:5). Only relevant for strides not equal
4614 to one. Don't try a division by zero. */
4615 if (ar->dimen_type[i] == DIMEN_RANGE
4616 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4617 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
4618 && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
4622 if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4624 if (ar->end[i] == NULL)
4627 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4629 mpz_set (ar->end[i]->value.integer, end);
4631 else if (ar->end[i]->ts.type == BT_INTEGER
4632 && ar->end[i]->expr_type == EXPR_CONSTANT)
4634 mpz_set (ar->end[i]->value.integer, end);
4645 if (ar->type == AR_FULL)
4647 if (ar->as->rank == 0)
4648 ar->type = AR_ELEMENT;
4650 /* Make sure array is the same as array(:,:), this way
4651 we don't need to special case all the time. */
4652 ar->dimen = ar->as->rank;
4653 for (i = 0; i < ar->dimen; i++)
4655 ar->dimen_type[i] = DIMEN_RANGE;
4657 gcc_assert (ar->start[i] == NULL);
4658 gcc_assert (ar->end[i] == NULL);
4659 gcc_assert (ar->stride[i] == NULL);
4663 /* If the reference type is unknown, figure out what kind it is. */
4665 if (ar->type == AR_UNKNOWN)
4667 ar->type = AR_ELEMENT;
4668 for (i = 0; i < ar->dimen; i++)
4669 if (ar->dimen_type[i] == DIMEN_RANGE
4670 || ar->dimen_type[i] == DIMEN_VECTOR)
4672 ar->type = AR_SECTION;
4677 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4680 if (ar->as->corank && ar->codimen == 0)
4683 ar->codimen = ar->as->corank;
4684 for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
4685 ar->dimen_type[n] = DIMEN_THIS_IMAGE;
4693 resolve_substring (gfc_ref *ref)
4695 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4697 if (ref->u.ss.start != NULL)
4699 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4702 if (ref->u.ss.start->ts.type != BT_INTEGER)
4704 gfc_error ("Substring start index at %L must be of type INTEGER",
4705 &ref->u.ss.start->where);
4709 if (ref->u.ss.start->rank != 0)
4711 gfc_error ("Substring start index at %L must be scalar",
4712 &ref->u.ss.start->where);
4716 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4717 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4718 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4720 gfc_error ("Substring start index at %L is less than one",
4721 &ref->u.ss.start->where);
4726 if (ref->u.ss.end != NULL)
4728 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4731 if (ref->u.ss.end->ts.type != BT_INTEGER)
4733 gfc_error ("Substring end index at %L must be of type INTEGER",
4734 &ref->u.ss.end->where);
4738 if (ref->u.ss.end->rank != 0)
4740 gfc_error ("Substring end index at %L must be scalar",
4741 &ref->u.ss.end->where);
4745 if (ref->u.ss.length != NULL
4746 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4747 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4748 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4750 gfc_error ("Substring end index at %L exceeds the string length",
4751 &ref->u.ss.start->where);
4755 if (compare_bound_mpz_t (ref->u.ss.end,
4756 gfc_integer_kinds[k].huge) == CMP_GT
4757 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4758 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4760 gfc_error ("Substring end index at %L is too large",
4761 &ref->u.ss.end->where);
4770 /* This function supplies missing substring charlens. */
4773 gfc_resolve_substring_charlen (gfc_expr *e)
4776 gfc_expr *start, *end;
4778 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4779 if (char_ref->type == REF_SUBSTRING)
4785 gcc_assert (char_ref->next == NULL);
4789 if (e->ts.u.cl->length)
4790 gfc_free_expr (e->ts.u.cl->length);
4791 else if (e->expr_type == EXPR_VARIABLE
4792 && e->symtree->n.sym->attr.dummy)
4796 e->ts.type = BT_CHARACTER;
4797 e->ts.kind = gfc_default_character_kind;
4800 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4802 if (char_ref->u.ss.start)
4803 start = gfc_copy_expr (char_ref->u.ss.start);
4805 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4807 if (char_ref->u.ss.end)
4808 end = gfc_copy_expr (char_ref->u.ss.end);
4809 else if (e->expr_type == EXPR_VARIABLE)
4810 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4817 /* Length = (end - start +1). */
4818 e->ts.u.cl->length = gfc_subtract (end, start);
4819 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4820 gfc_get_int_expr (gfc_default_integer_kind,
4823 e->ts.u.cl->length->ts.type = BT_INTEGER;
4824 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4826 /* Make sure that the length is simplified. */
4827 gfc_simplify_expr (e->ts.u.cl->length, 1);
4828 gfc_resolve_expr (e->ts.u.cl->length);
4832 /* Resolve subtype references. */
4835 resolve_ref (gfc_expr *expr)
4837 int current_part_dimension, n_components, seen_part_dimension;
4840 for (ref = expr->ref; ref; ref = ref->next)
4841 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4843 find_array_spec (expr);
4847 for (ref = expr->ref; ref; ref = ref->next)
4851 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4859 if (resolve_substring (ref) == FAILURE)
4864 /* Check constraints on part references. */
4866 current_part_dimension = 0;
4867 seen_part_dimension = 0;
4870 for (ref = expr->ref; ref; ref = ref->next)
4875 switch (ref->u.ar.type)
4878 /* Coarray scalar. */
4879 if (ref->u.ar.as->rank == 0)
4881 current_part_dimension = 0;
4886 current_part_dimension = 1;
4890 current_part_dimension = 0;
4894 gfc_internal_error ("resolve_ref(): Bad array reference");
4900 if (current_part_dimension || seen_part_dimension)
4903 if (ref->u.c.component->attr.pointer
4904 || ref->u.c.component->attr.proc_pointer)
4906 gfc_error ("Component to the right of a part reference "
4907 "with nonzero rank must not have the POINTER "
4908 "attribute at %L", &expr->where);
4911 else if (ref->u.c.component->attr.allocatable)
4913 gfc_error ("Component to the right of a part reference "
4914 "with nonzero rank must not have the ALLOCATABLE "
4915 "attribute at %L", &expr->where);
4927 if (((ref->type == REF_COMPONENT && n_components > 1)
4928 || ref->next == NULL)
4929 && current_part_dimension
4930 && seen_part_dimension)
4932 gfc_error ("Two or more part references with nonzero rank must "
4933 "not be specified at %L", &expr->where);
4937 if (ref->type == REF_COMPONENT)
4939 if (current_part_dimension)
4940 seen_part_dimension = 1;
4942 /* reset to make sure */
4943 current_part_dimension = 0;
4951 /* Given an expression, determine its shape. This is easier than it sounds.
4952 Leaves the shape array NULL if it is not possible to determine the shape. */
4955 expression_shape (gfc_expr *e)
4957 mpz_t array[GFC_MAX_DIMENSIONS];
4960 if (e->rank == 0 || e->shape != NULL)
4963 for (i = 0; i < e->rank; i++)
4964 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4967 e->shape = gfc_get_shape (e->rank);
4969 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4974 for (i--; i >= 0; i--)
4975 mpz_clear (array[i]);
4979 /* Given a variable expression node, compute the rank of the expression by
4980 examining the base symbol and any reference structures it may have. */
4983 expression_rank (gfc_expr *e)
4988 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4989 could lead to serious confusion... */
4990 gcc_assert (e->expr_type != EXPR_COMPCALL);
4994 if (e->expr_type == EXPR_ARRAY)
4996 /* Constructors can have a rank different from one via RESHAPE(). */
4998 if (e->symtree == NULL)
5004 e->rank = (e->symtree->n.sym->as == NULL)
5005 ? 0 : e->symtree->n.sym->as->rank;
5011 for (ref = e->ref; ref; ref = ref->next)
5013 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
5014 && ref->u.c.component->attr.function && !ref->next)
5015 rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
5017 if (ref->type != REF_ARRAY)
5020 if (ref->u.ar.type == AR_FULL)
5022 rank = ref->u.ar.as->rank;
5026 if (ref->u.ar.type == AR_SECTION)
5028 /* Figure out the rank of the section. */
5030 gfc_internal_error ("expression_rank(): Two array specs");
5032 for (i = 0; i < ref->u.ar.dimen; i++)
5033 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
5034 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
5044 expression_shape (e);
5048 /* Resolve a variable expression. */
5051 resolve_variable (gfc_expr *e)
5058 if (e->symtree == NULL)
5060 sym = e->symtree->n.sym;
5062 /* If this is an associate-name, it may be parsed with an array reference
5063 in error even though the target is scalar. Fail directly in this case. */
5064 if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
5067 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
5068 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
5070 /* On the other hand, the parser may not have known this is an array;
5071 in this case, we have to add a FULL reference. */
5072 if (sym->assoc && sym->attr.dimension && !e->ref)
5074 e->ref = gfc_get_ref ();
5075 e->ref->type = REF_ARRAY;
5076 e->ref->u.ar.type = AR_FULL;
5077 e->ref->u.ar.dimen = 0;
5080 if (e->ref && resolve_ref (e) == FAILURE)
5083 if (sym->attr.flavor == FL_PROCEDURE
5084 && (!sym->attr.function
5085 || (sym->attr.function && sym->result
5086 && sym->result->attr.proc_pointer
5087 && !sym->result->attr.function)))
5089 e->ts.type = BT_PROCEDURE;
5090 goto resolve_procedure;
5093 if (sym->ts.type != BT_UNKNOWN)
5094 gfc_variable_attr (e, &e->ts);
5097 /* Must be a simple variable reference. */
5098 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
5103 if (check_assumed_size_reference (sym, e))
5106 /* Deal with forward references to entries during resolve_code, to
5107 satisfy, at least partially, 12.5.2.5. */
5108 if (gfc_current_ns->entries
5109 && current_entry_id == sym->entry_id
5112 && cs_base->current->op != EXEC_ENTRY)
5114 gfc_entry_list *entry;
5115 gfc_formal_arglist *formal;
5119 /* If the symbol is a dummy... */
5120 if (sym->attr.dummy && sym->ns == gfc_current_ns)
5122 entry = gfc_current_ns->entries;
5125 /* ...test if the symbol is a parameter of previous entries. */
5126 for (; entry && entry->id <= current_entry_id; entry = entry->next)
5127 for (formal = entry->sym->formal; formal; formal = formal->next)
5129 if (formal->sym && sym->name == formal->sym->name)
5133 /* If it has not been seen as a dummy, this is an error. */
5136 if (specification_expr)
5137 gfc_error ("Variable '%s', used in a specification expression"
5138 ", is referenced at %L before the ENTRY statement "
5139 "in which it is a parameter",
5140 sym->name, &cs_base->current->loc);
5142 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5143 "statement in which it is a parameter",
5144 sym->name, &cs_base->current->loc);
5149 /* Now do the same check on the specification expressions. */
5150 specification_expr = 1;
5151 if (sym->ts.type == BT_CHARACTER
5152 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
5156 for (n = 0; n < sym->as->rank; n++)
5158 specification_expr = 1;
5159 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
5161 specification_expr = 1;
5162 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
5165 specification_expr = 0;
5168 /* Update the symbol's entry level. */
5169 sym->entry_id = current_entry_id + 1;
5172 /* If a symbol has been host_associated mark it. This is used latter,
5173 to identify if aliasing is possible via host association. */
5174 if (sym->attr.flavor == FL_VARIABLE
5175 && gfc_current_ns->parent
5176 && (gfc_current_ns->parent == sym->ns
5177 || (gfc_current_ns->parent->parent
5178 && gfc_current_ns->parent->parent == sym->ns)))
5179 sym->attr.host_assoc = 1;
5182 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
5185 /* F2008, C617 and C1229. */
5186 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5187 && gfc_is_coindexed (e))
5189 gfc_ref *ref, *ref2 = NULL;
5191 for (ref = e->ref; ref; ref = ref->next)
5193 if (ref->type == REF_COMPONENT)
5195 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5199 for ( ; ref; ref = ref->next)
5200 if (ref->type == REF_COMPONENT)
5203 /* Expression itself is not coindexed object. */
5204 if (ref && e->ts.type == BT_CLASS)
5206 gfc_error ("Polymorphic subobject of coindexed object at %L",
5211 /* Expression itself is coindexed object. */
5215 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5216 for ( ; c; c = c->next)
5217 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5219 gfc_error ("Coindexed object with polymorphic allocatable "
5220 "subcomponent at %L", &e->where);
5231 /* Checks to see that the correct symbol has been host associated.
5232 The only situation where this arises is that in which a twice
5233 contained function is parsed after the host association is made.
5234 Therefore, on detecting this, change the symbol in the expression
5235 and convert the array reference into an actual arglist if the old
5236 symbol is a variable. */
5238 check_host_association (gfc_expr *e)
5240 gfc_symbol *sym, *old_sym;
5244 gfc_actual_arglist *arg, *tail = NULL;
5245 bool retval = e->expr_type == EXPR_FUNCTION;
5247 /* If the expression is the result of substitution in
5248 interface.c(gfc_extend_expr) because there is no way in
5249 which the host association can be wrong. */
5250 if (e->symtree == NULL
5251 || e->symtree->n.sym == NULL
5252 || e->user_operator)
5255 old_sym = e->symtree->n.sym;
5257 if (gfc_current_ns->parent
5258 && old_sym->ns != gfc_current_ns)
5260 /* Use the 'USE' name so that renamed module symbols are
5261 correctly handled. */
5262 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5264 if (sym && old_sym != sym
5265 && sym->ts.type == old_sym->ts.type
5266 && sym->attr.flavor == FL_PROCEDURE
5267 && sym->attr.contained)
5269 /* Clear the shape, since it might not be valid. */
5270 gfc_free_shape (&e->shape, e->rank);
5272 /* Give the expression the right symtree! */
5273 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5274 gcc_assert (st != NULL);
5276 if (old_sym->attr.flavor == FL_PROCEDURE
5277 || e->expr_type == EXPR_FUNCTION)
5279 /* Original was function so point to the new symbol, since
5280 the actual argument list is already attached to the
5282 e->value.function.esym = NULL;
5287 /* Original was variable so convert array references into
5288 an actual arglist. This does not need any checking now
5289 since resolve_function will take care of it. */
5290 e->value.function.actual = NULL;
5291 e->expr_type = EXPR_FUNCTION;
5294 /* Ambiguity will not arise if the array reference is not
5295 the last reference. */
5296 for (ref = e->ref; ref; ref = ref->next)
5297 if (ref->type == REF_ARRAY && ref->next == NULL)
5300 gcc_assert (ref->type == REF_ARRAY);
5302 /* Grab the start expressions from the array ref and
5303 copy them into actual arguments. */
5304 for (n = 0; n < ref->u.ar.dimen; n++)
5306 arg = gfc_get_actual_arglist ();
5307 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5308 if (e->value.function.actual == NULL)
5309 tail = e->value.function.actual = arg;
5317 /* Dump the reference list and set the rank. */
5318 gfc_free_ref_list (e->ref);
5320 e->rank = sym->as ? sym->as->rank : 0;
5323 gfc_resolve_expr (e);
5327 /* This might have changed! */
5328 return e->expr_type == EXPR_FUNCTION;
5333 gfc_resolve_character_operator (gfc_expr *e)
5335 gfc_expr *op1 = e->value.op.op1;
5336 gfc_expr *op2 = e->value.op.op2;
5337 gfc_expr *e1 = NULL;
5338 gfc_expr *e2 = NULL;
5340 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5342 if (op1->ts.u.cl && op1->ts.u.cl->length)
5343 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5344 else if (op1->expr_type == EXPR_CONSTANT)
5345 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5346 op1->value.character.length);
5348 if (op2->ts.u.cl && op2->ts.u.cl->length)
5349 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5350 else if (op2->expr_type == EXPR_CONSTANT)
5351 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5352 op2->value.character.length);
5354 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5359 e->ts.u.cl->length = gfc_add (e1, e2);
5360 e->ts.u.cl->length->ts.type = BT_INTEGER;
5361 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5362 gfc_simplify_expr (e->ts.u.cl->length, 0);
5363 gfc_resolve_expr (e->ts.u.cl->length);
5369 /* Ensure that an character expression has a charlen and, if possible, a
5370 length expression. */
5373 fixup_charlen (gfc_expr *e)
5375 /* The cases fall through so that changes in expression type and the need
5376 for multiple fixes are picked up. In all circumstances, a charlen should
5377 be available for the middle end to hang a backend_decl on. */
5378 switch (e->expr_type)
5381 gfc_resolve_character_operator (e);
5384 if (e->expr_type == EXPR_ARRAY)
5385 gfc_resolve_character_array_constructor (e);
5387 case EXPR_SUBSTRING:
5388 if (!e->ts.u.cl && e->ref)
5389 gfc_resolve_substring_charlen (e);
5393 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5400 /* Update an actual argument to include the passed-object for type-bound
5401 procedures at the right position. */
5403 static gfc_actual_arglist*
5404 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5407 gcc_assert (argpos > 0);
5411 gfc_actual_arglist* result;
5413 result = gfc_get_actual_arglist ();
5417 result->name = name;
5423 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5425 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5430 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5433 extract_compcall_passed_object (gfc_expr* e)
5437 gcc_assert (e->expr_type == EXPR_COMPCALL);
5439 if (e->value.compcall.base_object)
5440 po = gfc_copy_expr (e->value.compcall.base_object);
5443 po = gfc_get_expr ();
5444 po->expr_type = EXPR_VARIABLE;
5445 po->symtree = e->symtree;
5446 po->ref = gfc_copy_ref (e->ref);
5447 po->where = e->where;
5450 if (gfc_resolve_expr (po) == FAILURE)
5457 /* Update the arglist of an EXPR_COMPCALL expression to include the
5461 update_compcall_arglist (gfc_expr* e)
5464 gfc_typebound_proc* tbp;
5466 tbp = e->value.compcall.tbp;
5471 po = extract_compcall_passed_object (e);
5475 if (tbp->nopass || e->value.compcall.ignore_pass)
5481 gcc_assert (tbp->pass_arg_num > 0);
5482 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5490 /* Extract the passed object from a PPC call (a copy of it). */
5493 extract_ppc_passed_object (gfc_expr *e)
5498 po = gfc_get_expr ();
5499 po->expr_type = EXPR_VARIABLE;
5500 po->symtree = e->symtree;
5501 po->ref = gfc_copy_ref (e->ref);
5502 po->where = e->where;
5504 /* Remove PPC reference. */
5506 while ((*ref)->next)
5507 ref = &(*ref)->next;
5508 gfc_free_ref_list (*ref);
5511 if (gfc_resolve_expr (po) == FAILURE)
5518 /* Update the actual arglist of a procedure pointer component to include the
5522 update_ppc_arglist (gfc_expr* e)
5526 gfc_typebound_proc* tb;
5528 if (!gfc_is_proc_ptr_comp (e, &ppc))
5535 else if (tb->nopass)
5538 po = extract_ppc_passed_object (e);
5545 gfc_error ("Passed-object at %L must be scalar", &e->where);
5550 if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
5552 gfc_error ("Base object for procedure-pointer component call at %L is of"
5553 " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name);
5557 gcc_assert (tb->pass_arg_num > 0);
5558 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5566 /* Check that the object a TBP is called on is valid, i.e. it must not be
5567 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5570 check_typebound_baseobject (gfc_expr* e)
5573 gfc_try return_value = FAILURE;
5575 base = extract_compcall_passed_object (e);
5579 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5582 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5584 gfc_error ("Base object for type-bound procedure call at %L is of"
5585 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5589 /* F08:C1230. If the procedure called is NOPASS,
5590 the base object must be scalar. */
5591 if (e->value.compcall.tbp->nopass && base->rank > 0)
5593 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5594 " be scalar", &e->where);
5598 return_value = SUCCESS;
5601 gfc_free_expr (base);
5602 return return_value;
5606 /* Resolve a call to a type-bound procedure, either function or subroutine,
5607 statically from the data in an EXPR_COMPCALL expression. The adapted
5608 arglist and the target-procedure symtree are returned. */
5611 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5612 gfc_actual_arglist** actual)
5614 gcc_assert (e->expr_type == EXPR_COMPCALL);
5615 gcc_assert (!e->value.compcall.tbp->is_generic);
5617 /* Update the actual arglist for PASS. */
5618 if (update_compcall_arglist (e) == FAILURE)
5621 *actual = e->value.compcall.actual;
5622 *target = e->value.compcall.tbp->u.specific;
5624 gfc_free_ref_list (e->ref);
5626 e->value.compcall.actual = NULL;
5628 /* If we find a deferred typebound procedure, check for derived types
5629 that an overriding typebound procedure has not been missed. */
5630 if (e->value.compcall.name
5631 && !e->value.compcall.tbp->non_overridable
5632 && e->value.compcall.base_object
5633 && e->value.compcall.base_object->ts.type == BT_DERIVED)
5636 gfc_symbol *derived;
5638 /* Use the derived type of the base_object. */
5639 derived = e->value.compcall.base_object->ts.u.derived;
5642 /* If necessary, go throught the inheritance chain. */
5643 while (!st && derived)
5645 /* Look for the typebound procedure 'name'. */
5646 if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
5647 st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
5648 e->value.compcall.name);
5650 derived = gfc_get_derived_super_type (derived);
5653 /* Now find the specific name in the derived type namespace. */
5654 if (st && st->n.tb && st->n.tb->u.specific)
5655 gfc_find_sym_tree (st->n.tb->u.specific->name,
5656 derived->ns, 1, &st);
5664 /* Get the ultimate declared type from an expression. In addition,
5665 return the last class/derived type reference and the copy of the
5666 reference list. If check_types is set true, derived types are
5667 identified as well as class references. */
5669 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5670 gfc_expr *e, bool check_types)
5672 gfc_symbol *declared;
5679 *new_ref = gfc_copy_ref (e->ref);
5681 for (ref = e->ref; ref; ref = ref->next)
5683 if (ref->type != REF_COMPONENT)
5686 if ((ref->u.c.component->ts.type == BT_CLASS
5687 || (check_types && ref->u.c.component->ts.type == BT_DERIVED))
5688 && ref->u.c.component->attr.flavor != FL_PROCEDURE)
5690 declared = ref->u.c.component->ts.u.derived;
5696 if (declared == NULL)
5697 declared = e->symtree->n.sym->ts.u.derived;
5703 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5704 which of the specific bindings (if any) matches the arglist and transform
5705 the expression into a call of that binding. */
5708 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5710 gfc_typebound_proc* genproc;
5711 const char* genname;
5713 gfc_symbol *derived;
5715 gcc_assert (e->expr_type == EXPR_COMPCALL);
5716 genname = e->value.compcall.name;
5717 genproc = e->value.compcall.tbp;
5719 if (!genproc->is_generic)
5722 /* Try the bindings on this type and in the inheritance hierarchy. */
5723 for (; genproc; genproc = genproc->overridden)
5727 gcc_assert (genproc->is_generic);
5728 for (g = genproc->u.generic; g; g = g->next)
5731 gfc_actual_arglist* args;
5734 gcc_assert (g->specific);
5736 if (g->specific->error)
5739 target = g->specific->u.specific->n.sym;
5741 /* Get the right arglist by handling PASS/NOPASS. */
5742 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5743 if (!g->specific->nopass)
5746 po = extract_compcall_passed_object (e);
5750 gcc_assert (g->specific->pass_arg_num > 0);
5751 gcc_assert (!g->specific->error);
5752 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5753 g->specific->pass_arg);
5755 resolve_actual_arglist (args, target->attr.proc,
5756 is_external_proc (target) && !target->formal);
5758 /* Check if this arglist matches the formal. */
5759 matches = gfc_arglist_matches_symbol (&args, target);
5761 /* Clean up and break out of the loop if we've found it. */
5762 gfc_free_actual_arglist (args);
5765 e->value.compcall.tbp = g->specific;
5766 genname = g->specific_st->name;
5767 /* Pass along the name for CLASS methods, where the vtab
5768 procedure pointer component has to be referenced. */
5776 /* Nothing matching found! */
5777 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5778 " '%s' at %L", genname, &e->where);
5782 /* Make sure that we have the right specific instance for the name. */
5783 derived = get_declared_from_expr (NULL, NULL, e, true);
5785 st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
5787 e->value.compcall.tbp = st->n.tb;
5793 /* Resolve a call to a type-bound subroutine. */
5796 resolve_typebound_call (gfc_code* c, const char **name)
5798 gfc_actual_arglist* newactual;
5799 gfc_symtree* target;
5801 /* Check that's really a SUBROUTINE. */
5802 if (!c->expr1->value.compcall.tbp->subroutine)
5804 gfc_error ("'%s' at %L should be a SUBROUTINE",
5805 c->expr1->value.compcall.name, &c->loc);
5809 if (check_typebound_baseobject (c->expr1) == FAILURE)
5812 /* Pass along the name for CLASS methods, where the vtab
5813 procedure pointer component has to be referenced. */
5815 *name = c->expr1->value.compcall.name;
5817 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5820 /* Transform into an ordinary EXEC_CALL for now. */
5822 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5825 c->ext.actual = newactual;
5826 c->symtree = target;
5827 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5829 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5831 gfc_free_expr (c->expr1);
5832 c->expr1 = gfc_get_expr ();
5833 c->expr1->expr_type = EXPR_FUNCTION;
5834 c->expr1->symtree = target;
5835 c->expr1->where = c->loc;
5837 return resolve_call (c);
5841 /* Resolve a component-call expression. */
5843 resolve_compcall (gfc_expr* e, const char **name)
5845 gfc_actual_arglist* newactual;
5846 gfc_symtree* target;
5848 /* Check that's really a FUNCTION. */
5849 if (!e->value.compcall.tbp->function)
5851 gfc_error ("'%s' at %L should be a FUNCTION",
5852 e->value.compcall.name, &e->where);
5856 /* These must not be assign-calls! */
5857 gcc_assert (!e->value.compcall.assign);
5859 if (check_typebound_baseobject (e) == FAILURE)
5862 /* Pass along the name for CLASS methods, where the vtab
5863 procedure pointer component has to be referenced. */
5865 *name = e->value.compcall.name;
5867 if (resolve_typebound_generic_call (e, name) == FAILURE)
5869 gcc_assert (!e->value.compcall.tbp->is_generic);
5871 /* Take the rank from the function's symbol. */
5872 if (e->value.compcall.tbp->u.specific->n.sym->as)
5873 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5875 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5876 arglist to the TBP's binding target. */
5878 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5881 e->value.function.actual = newactual;
5882 e->value.function.name = NULL;
5883 e->value.function.esym = target->n.sym;
5884 e->value.function.isym = NULL;
5885 e->symtree = target;
5886 e->ts = target->n.sym->ts;
5887 e->expr_type = EXPR_FUNCTION;
5889 /* Resolution is not necessary if this is a class subroutine; this
5890 function only has to identify the specific proc. Resolution of
5891 the call will be done next in resolve_typebound_call. */
5892 return gfc_resolve_expr (e);
5897 /* Resolve a typebound function, or 'method'. First separate all
5898 the non-CLASS references by calling resolve_compcall directly. */
5901 resolve_typebound_function (gfc_expr* e)
5903 gfc_symbol *declared;
5915 /* Deal with typebound operators for CLASS objects. */
5916 expr = e->value.compcall.base_object;
5917 overridable = !e->value.compcall.tbp->non_overridable;
5918 if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
5920 /* If the base_object is not a variable, the corresponding actual
5921 argument expression must be stored in e->base_expression so
5922 that the corresponding tree temporary can be used as the base
5923 object in gfc_conv_procedure_call. */
5924 if (expr->expr_type != EXPR_VARIABLE)
5926 gfc_actual_arglist *args;
5928 for (args= e->value.function.actual; args; args = args->next)
5930 if (expr == args->expr)
5935 /* Since the typebound operators are generic, we have to ensure
5936 that any delays in resolution are corrected and that the vtab
5939 declared = ts.u.derived;
5940 c = gfc_find_component (declared, "_vptr", true, true);
5941 if (c->ts.u.derived == NULL)
5942 c->ts.u.derived = gfc_find_derived_vtab (declared);
5944 if (resolve_compcall (e, &name) == FAILURE)
5947 /* Use the generic name if it is there. */
5948 name = name ? name : e->value.function.esym->name;
5949 e->symtree = expr->symtree;
5950 e->ref = gfc_copy_ref (expr->ref);
5951 get_declared_from_expr (&class_ref, NULL, e, false);
5953 /* Trim away the extraneous references that emerge from nested
5954 use of interface.c (extend_expr). */
5955 if (class_ref && class_ref->next)
5957 gfc_free_ref_list (class_ref->next);
5958 class_ref->next = NULL;
5960 else if (e->ref && !class_ref)
5962 gfc_free_ref_list (e->ref);
5966 gfc_add_vptr_component (e);
5967 gfc_add_component_ref (e, name);
5968 e->value.function.esym = NULL;
5969 if (expr->expr_type != EXPR_VARIABLE)
5970 e->base_expr = expr;
5975 return resolve_compcall (e, NULL);
5977 if (resolve_ref (e) == FAILURE)
5980 /* Get the CLASS declared type. */
5981 declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
5983 /* Weed out cases of the ultimate component being a derived type. */
5984 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5985 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5987 gfc_free_ref_list (new_ref);
5988 return resolve_compcall (e, NULL);
5991 c = gfc_find_component (declared, "_data", true, true);
5992 declared = c->ts.u.derived;
5994 /* Treat the call as if it is a typebound procedure, in order to roll
5995 out the correct name for the specific function. */
5996 if (resolve_compcall (e, &name) == FAILURE)
6002 /* Convert the expression to a procedure pointer component call. */
6003 e->value.function.esym = NULL;
6009 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6010 gfc_add_vptr_component (e);
6011 gfc_add_component_ref (e, name);
6013 /* Recover the typespec for the expression. This is really only
6014 necessary for generic procedures, where the additional call
6015 to gfc_add_component_ref seems to throw the collection of the
6016 correct typespec. */
6023 /* Resolve a typebound subroutine, or 'method'. First separate all
6024 the non-CLASS references by calling resolve_typebound_call
6028 resolve_typebound_subroutine (gfc_code *code)
6030 gfc_symbol *declared;
6040 st = code->expr1->symtree;
6042 /* Deal with typebound operators for CLASS objects. */
6043 expr = code->expr1->value.compcall.base_object;
6044 overridable = !code->expr1->value.compcall.tbp->non_overridable;
6045 if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
6047 /* If the base_object is not a variable, the corresponding actual
6048 argument expression must be stored in e->base_expression so
6049 that the corresponding tree temporary can be used as the base
6050 object in gfc_conv_procedure_call. */
6051 if (expr->expr_type != EXPR_VARIABLE)
6053 gfc_actual_arglist *args;
6055 args= code->expr1->value.function.actual;
6056 for (; args; args = args->next)
6057 if (expr == args->expr)
6061 /* Since the typebound operators are generic, we have to ensure
6062 that any delays in resolution are corrected and that the vtab
6064 declared = expr->ts.u.derived;
6065 c = gfc_find_component (declared, "_vptr", true, true);
6066 if (c->ts.u.derived == NULL)
6067 c->ts.u.derived = gfc_find_derived_vtab (declared);
6069 if (resolve_typebound_call (code, &name) == FAILURE)
6072 /* Use the generic name if it is there. */
6073 name = name ? name : code->expr1->value.function.esym->name;
6074 code->expr1->symtree = expr->symtree;
6075 code->expr1->ref = gfc_copy_ref (expr->ref);
6077 /* Trim away the extraneous references that emerge from nested
6078 use of interface.c (extend_expr). */
6079 get_declared_from_expr (&class_ref, NULL, code->expr1, false);
6080 if (class_ref && class_ref->next)
6082 gfc_free_ref_list (class_ref->next);
6083 class_ref->next = NULL;
6085 else if (code->expr1->ref && !class_ref)
6087 gfc_free_ref_list (code->expr1->ref);
6088 code->expr1->ref = NULL;
6091 /* Now use the procedure in the vtable. */
6092 gfc_add_vptr_component (code->expr1);
6093 gfc_add_component_ref (code->expr1, name);
6094 code->expr1->value.function.esym = NULL;
6095 if (expr->expr_type != EXPR_VARIABLE)
6096 code->expr1->base_expr = expr;
6101 return resolve_typebound_call (code, NULL);
6103 if (resolve_ref (code->expr1) == FAILURE)
6106 /* Get the CLASS declared type. */
6107 get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
6109 /* Weed out cases of the ultimate component being a derived type. */
6110 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
6111 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
6113 gfc_free_ref_list (new_ref);
6114 return resolve_typebound_call (code, NULL);
6117 if (resolve_typebound_call (code, &name) == FAILURE)
6119 ts = code->expr1->ts;
6123 /* Convert the expression to a procedure pointer component call. */
6124 code->expr1->value.function.esym = NULL;
6125 code->expr1->symtree = st;
6128 code->expr1->ref = new_ref;
6130 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6131 gfc_add_vptr_component (code->expr1);
6132 gfc_add_component_ref (code->expr1, name);
6134 /* Recover the typespec for the expression. This is really only
6135 necessary for generic procedures, where the additional call
6136 to gfc_add_component_ref seems to throw the collection of the
6137 correct typespec. */
6138 code->expr1->ts = ts;
6145 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6148 resolve_ppc_call (gfc_code* c)
6150 gfc_component *comp;
6153 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
6156 c->resolved_sym = c->expr1->symtree->n.sym;
6157 c->expr1->expr_type = EXPR_VARIABLE;
6159 if (!comp->attr.subroutine)
6160 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
6162 if (resolve_ref (c->expr1) == FAILURE)
6165 if (update_ppc_arglist (c->expr1) == FAILURE)
6168 c->ext.actual = c->expr1->value.compcall.actual;
6170 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
6171 comp->formal == NULL) == FAILURE)
6174 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
6180 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6183 resolve_expr_ppc (gfc_expr* e)
6185 gfc_component *comp;
6188 b = gfc_is_proc_ptr_comp (e, &comp);
6191 /* Convert to EXPR_FUNCTION. */
6192 e->expr_type = EXPR_FUNCTION;
6193 e->value.function.isym = NULL;
6194 e->value.function.actual = e->value.compcall.actual;
6196 if (comp->as != NULL)
6197 e->rank = comp->as->rank;
6199 if (!comp->attr.function)
6200 gfc_add_function (&comp->attr, comp->name, &e->where);
6202 if (resolve_ref (e) == FAILURE)
6205 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
6206 comp->formal == NULL) == FAILURE)
6209 if (update_ppc_arglist (e) == FAILURE)
6212 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
6219 gfc_is_expandable_expr (gfc_expr *e)
6221 gfc_constructor *con;
6223 if (e->expr_type == EXPR_ARRAY)
6225 /* Traverse the constructor looking for variables that are flavor
6226 parameter. Parameters must be expanded since they are fully used at
6228 con = gfc_constructor_first (e->value.constructor);
6229 for (; con; con = gfc_constructor_next (con))
6231 if (con->expr->expr_type == EXPR_VARIABLE
6232 && con->expr->symtree
6233 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6234 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
6236 if (con->expr->expr_type == EXPR_ARRAY
6237 && gfc_is_expandable_expr (con->expr))
6245 /* Resolve an expression. That is, make sure that types of operands agree
6246 with their operators, intrinsic operators are converted to function calls
6247 for overloaded types and unresolved function references are resolved. */
6250 gfc_resolve_expr (gfc_expr *e)
6258 /* inquiry_argument only applies to variables. */
6259 inquiry_save = inquiry_argument;
6260 if (e->expr_type != EXPR_VARIABLE)
6261 inquiry_argument = false;
6263 switch (e->expr_type)
6266 t = resolve_operator (e);
6272 if (check_host_association (e))
6273 t = resolve_function (e);
6276 t = resolve_variable (e);
6278 expression_rank (e);
6281 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6282 && e->ref->type != REF_SUBSTRING)
6283 gfc_resolve_substring_charlen (e);
6288 t = resolve_typebound_function (e);
6291 case EXPR_SUBSTRING:
6292 t = resolve_ref (e);
6301 t = resolve_expr_ppc (e);
6306 if (resolve_ref (e) == FAILURE)
6309 t = gfc_resolve_array_constructor (e);
6310 /* Also try to expand a constructor. */
6313 expression_rank (e);
6314 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6315 gfc_expand_constructor (e, false);
6318 /* This provides the opportunity for the length of constructors with
6319 character valued function elements to propagate the string length
6320 to the expression. */
6321 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6323 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6324 here rather then add a duplicate test for it above. */
6325 gfc_expand_constructor (e, false);
6326 t = gfc_resolve_character_array_constructor (e);
6331 case EXPR_STRUCTURE:
6332 t = resolve_ref (e);
6336 t = resolve_structure_cons (e, 0);
6340 t = gfc_simplify_expr (e, 0);
6344 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6347 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6350 inquiry_argument = inquiry_save;
6356 /* Resolve an expression from an iterator. They must be scalar and have
6357 INTEGER or (optionally) REAL type. */
6360 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6361 const char *name_msgid)
6363 if (gfc_resolve_expr (expr) == FAILURE)
6366 if (expr->rank != 0)
6368 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6372 if (expr->ts.type != BT_INTEGER)
6374 if (expr->ts.type == BT_REAL)
6377 return gfc_notify_std (GFC_STD_F95_DEL,
6378 "Deleted feature: %s at %L must be integer",
6379 _(name_msgid), &expr->where);
6382 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6389 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6397 /* Resolve the expressions in an iterator structure. If REAL_OK is
6398 false allow only INTEGER type iterators, otherwise allow REAL types. */
6401 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6403 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6407 if (gfc_check_vardef_context (iter->var, false, false, _("iterator variable"))
6411 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6412 "Start expression in DO loop") == FAILURE)
6415 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6416 "End expression in DO loop") == FAILURE)
6419 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6420 "Step expression in DO loop") == FAILURE)
6423 if (iter->step->expr_type == EXPR_CONSTANT)
6425 if ((iter->step->ts.type == BT_INTEGER
6426 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6427 || (iter->step->ts.type == BT_REAL
6428 && mpfr_sgn (iter->step->value.real) == 0))
6430 gfc_error ("Step expression in DO loop at %L cannot be zero",
6431 &iter->step->where);
6436 /* Convert start, end, and step to the same type as var. */
6437 if (iter->start->ts.kind != iter->var->ts.kind
6438 || iter->start->ts.type != iter->var->ts.type)
6439 gfc_convert_type (iter->start, &iter->var->ts, 2);
6441 if (iter->end->ts.kind != iter->var->ts.kind
6442 || iter->end->ts.type != iter->var->ts.type)
6443 gfc_convert_type (iter->end, &iter->var->ts, 2);
6445 if (iter->step->ts.kind != iter->var->ts.kind
6446 || iter->step->ts.type != iter->var->ts.type)
6447 gfc_convert_type (iter->step, &iter->var->ts, 2);
6449 if (iter->start->expr_type == EXPR_CONSTANT
6450 && iter->end->expr_type == EXPR_CONSTANT
6451 && iter->step->expr_type == EXPR_CONSTANT)
6454 if (iter->start->ts.type == BT_INTEGER)
6456 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6457 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6461 sgn = mpfr_sgn (iter->step->value.real);
6462 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6464 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6465 gfc_warning ("DO loop at %L will be executed zero times",
6466 &iter->step->where);
6473 /* Traversal function for find_forall_index. f == 2 signals that
6474 that variable itself is not to be checked - only the references. */
6477 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6479 if (expr->expr_type != EXPR_VARIABLE)
6482 /* A scalar assignment */
6483 if (!expr->ref || *f == 1)
6485 if (expr->symtree->n.sym == sym)
6497 /* Check whether the FORALL index appears in the expression or not.
6498 Returns SUCCESS if SYM is found in EXPR. */
6501 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6503 if (gfc_traverse_expr (expr, sym, forall_index, f))
6510 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6511 to be a scalar INTEGER variable. The subscripts and stride are scalar
6512 INTEGERs, and if stride is a constant it must be nonzero.
6513 Furthermore "A subscript or stride in a forall-triplet-spec shall
6514 not contain a reference to any index-name in the
6515 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6518 resolve_forall_iterators (gfc_forall_iterator *it)
6520 gfc_forall_iterator *iter, *iter2;
6522 for (iter = it; iter; iter = iter->next)
6524 if (gfc_resolve_expr (iter->var) == SUCCESS
6525 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6526 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6529 if (gfc_resolve_expr (iter->start) == SUCCESS
6530 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6531 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6532 &iter->start->where);
6533 if (iter->var->ts.kind != iter->start->ts.kind)
6534 gfc_convert_type (iter->start, &iter->var->ts, 1);
6536 if (gfc_resolve_expr (iter->end) == SUCCESS
6537 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6538 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6540 if (iter->var->ts.kind != iter->end->ts.kind)
6541 gfc_convert_type (iter->end, &iter->var->ts, 1);
6543 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6545 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6546 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6547 &iter->stride->where, "INTEGER");
6549 if (iter->stride->expr_type == EXPR_CONSTANT
6550 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6551 gfc_error ("FORALL stride expression at %L cannot be zero",
6552 &iter->stride->where);
6554 if (iter->var->ts.kind != iter->stride->ts.kind)
6555 gfc_convert_type (iter->stride, &iter->var->ts, 1);
6558 for (iter = it; iter; iter = iter->next)
6559 for (iter2 = iter; iter2; iter2 = iter2->next)
6561 if (find_forall_index (iter2->start,
6562 iter->var->symtree->n.sym, 0) == SUCCESS
6563 || find_forall_index (iter2->end,
6564 iter->var->symtree->n.sym, 0) == SUCCESS
6565 || find_forall_index (iter2->stride,
6566 iter->var->symtree->n.sym, 0) == SUCCESS)
6567 gfc_error ("FORALL index '%s' may not appear in triplet "
6568 "specification at %L", iter->var->symtree->name,
6569 &iter2->start->where);
6574 /* Given a pointer to a symbol that is a derived type, see if it's
6575 inaccessible, i.e. if it's defined in another module and the components are
6576 PRIVATE. The search is recursive if necessary. Returns zero if no
6577 inaccessible components are found, nonzero otherwise. */
6580 derived_inaccessible (gfc_symbol *sym)
6584 if (sym->attr.use_assoc && sym->attr.private_comp)
6587 for (c = sym->components; c; c = c->next)
6589 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6597 /* Resolve the argument of a deallocate expression. The expression must be
6598 a pointer or a full array. */
6601 resolve_deallocate_expr (gfc_expr *e)
6603 symbol_attribute attr;
6604 int allocatable, pointer;
6609 if (gfc_resolve_expr (e) == FAILURE)
6612 if (e->expr_type != EXPR_VARIABLE)
6615 sym = e->symtree->n.sym;
6617 if (sym->ts.type == BT_CLASS)
6619 allocatable = CLASS_DATA (sym)->attr.allocatable;
6620 pointer = CLASS_DATA (sym)->attr.class_pointer;
6624 allocatable = sym->attr.allocatable;
6625 pointer = sym->attr.pointer;
6627 for (ref = e->ref; ref; ref = ref->next)
6632 if (ref->u.ar.type != AR_FULL
6633 && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
6634 && ref->u.ar.codimen && gfc_ref_this_image (ref)))
6639 c = ref->u.c.component;
6640 if (c->ts.type == BT_CLASS)
6642 allocatable = CLASS_DATA (c)->attr.allocatable;
6643 pointer = CLASS_DATA (c)->attr.class_pointer;
6647 allocatable = c->attr.allocatable;
6648 pointer = c->attr.pointer;
6658 attr = gfc_expr_attr (e);
6660 if (allocatable == 0 && attr.pointer == 0)
6663 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6669 if (gfc_is_coindexed (e))
6671 gfc_error ("Coindexed allocatable object at %L", &e->where);
6676 && gfc_check_vardef_context (e, true, true, _("DEALLOCATE object"))
6679 if (gfc_check_vardef_context (e, false, true, _("DEALLOCATE object"))
6687 /* Returns true if the expression e contains a reference to the symbol sym. */
6689 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6691 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6698 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6700 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6704 /* Given the expression node e for an allocatable/pointer of derived type to be
6705 allocated, get the expression node to be initialized afterwards (needed for
6706 derived types with default initializers, and derived types with allocatable
6707 components that need nullification.) */
6710 gfc_expr_to_initialize (gfc_expr *e)
6716 result = gfc_copy_expr (e);
6718 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6719 for (ref = result->ref; ref; ref = ref->next)
6720 if (ref->type == REF_ARRAY && ref->next == NULL)
6722 ref->u.ar.type = AR_FULL;
6724 for (i = 0; i < ref->u.ar.dimen; i++)
6725 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6730 gfc_free_shape (&result->shape, result->rank);
6732 /* Recalculate rank, shape, etc. */
6733 gfc_resolve_expr (result);
6738 /* If the last ref of an expression is an array ref, return a copy of the
6739 expression with that one removed. Otherwise, a copy of the original
6740 expression. This is used for allocate-expressions and pointer assignment
6741 LHS, where there may be an array specification that needs to be stripped
6742 off when using gfc_check_vardef_context. */
6745 remove_last_array_ref (gfc_expr* e)
6750 e2 = gfc_copy_expr (e);
6751 for (r = &e2->ref; *r; r = &(*r)->next)
6752 if ((*r)->type == REF_ARRAY && !(*r)->next)
6754 gfc_free_ref_list (*r);
6763 /* Used in resolve_allocate_expr to check that a allocation-object and
6764 a source-expr are conformable. This does not catch all possible
6765 cases; in particular a runtime checking is needed. */
6768 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6771 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6773 /* First compare rank. */
6774 if (tail && e1->rank != tail->u.ar.as->rank)
6776 gfc_error ("Source-expr at %L must be scalar or have the "
6777 "same rank as the allocate-object at %L",
6778 &e1->where, &e2->where);
6789 for (i = 0; i < e1->rank; i++)
6791 if (tail->u.ar.end[i])
6793 mpz_set (s, tail->u.ar.end[i]->value.integer);
6794 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6795 mpz_add_ui (s, s, 1);
6799 mpz_set (s, tail->u.ar.start[i]->value.integer);
6802 if (mpz_cmp (e1->shape[i], s) != 0)
6804 gfc_error ("Source-expr at %L and allocate-object at %L must "
6805 "have the same shape", &e1->where, &e2->where);
6818 /* Resolve the expression in an ALLOCATE statement, doing the additional
6819 checks to see whether the expression is OK or not. The expression must
6820 have a trailing array reference that gives the size of the array. */
6823 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6825 int i, pointer, allocatable, dimension, is_abstract;
6828 symbol_attribute attr;
6829 gfc_ref *ref, *ref2;
6832 gfc_symbol *sym = NULL;
6837 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6838 checking of coarrays. */
6839 for (ref = e->ref; ref; ref = ref->next)
6840 if (ref->next == NULL)
6843 if (ref && ref->type == REF_ARRAY)
6844 ref->u.ar.in_allocate = true;
6846 if (gfc_resolve_expr (e) == FAILURE)
6849 /* Make sure the expression is allocatable or a pointer. If it is
6850 pointer, the next-to-last reference must be a pointer. */
6854 sym = e->symtree->n.sym;
6856 /* Check whether ultimate component is abstract and CLASS. */
6859 if (e->expr_type != EXPR_VARIABLE)
6862 attr = gfc_expr_attr (e);
6863 pointer = attr.pointer;
6864 dimension = attr.dimension;
6865 codimension = attr.codimension;
6869 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
6871 allocatable = CLASS_DATA (sym)->attr.allocatable;
6872 pointer = CLASS_DATA (sym)->attr.class_pointer;
6873 dimension = CLASS_DATA (sym)->attr.dimension;
6874 codimension = CLASS_DATA (sym)->attr.codimension;
6875 is_abstract = CLASS_DATA (sym)->attr.abstract;
6879 allocatable = sym->attr.allocatable;
6880 pointer = sym->attr.pointer;
6881 dimension = sym->attr.dimension;
6882 codimension = sym->attr.codimension;
6887 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6892 if (ref->u.ar.codimen > 0)
6895 for (n = ref->u.ar.dimen;
6896 n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
6897 if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
6904 if (ref->next != NULL)
6912 gfc_error ("Coindexed allocatable object at %L",
6917 c = ref->u.c.component;
6918 if (c->ts.type == BT_CLASS)
6920 allocatable = CLASS_DATA (c)->attr.allocatable;
6921 pointer = CLASS_DATA (c)->attr.class_pointer;
6922 dimension = CLASS_DATA (c)->attr.dimension;
6923 codimension = CLASS_DATA (c)->attr.codimension;
6924 is_abstract = CLASS_DATA (c)->attr.abstract;
6928 allocatable = c->attr.allocatable;
6929 pointer = c->attr.pointer;
6930 dimension = c->attr.dimension;
6931 codimension = c->attr.codimension;
6932 is_abstract = c->attr.abstract;
6944 if (allocatable == 0 && pointer == 0)
6946 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6951 /* Some checks for the SOURCE tag. */
6954 /* Check F03:C631. */
6955 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6957 gfc_error ("Type of entity at %L is type incompatible with "
6958 "source-expr at %L", &e->where, &code->expr3->where);
6962 /* Check F03:C632 and restriction following Note 6.18. */
6963 if (code->expr3->rank > 0
6964 && conformable_arrays (code->expr3, e) == FAILURE)
6967 /* Check F03:C633. */
6968 if (code->expr3->ts.kind != e->ts.kind)
6970 gfc_error ("The allocate-object at %L and the source-expr at %L "
6971 "shall have the same kind type parameter",
6972 &e->where, &code->expr3->where);
6976 /* Check F2008, C642. */
6977 if (code->expr3->ts.type == BT_DERIVED
6978 && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
6979 || (code->expr3->ts.u.derived->from_intmod
6980 == INTMOD_ISO_FORTRAN_ENV
6981 && code->expr3->ts.u.derived->intmod_sym_id
6982 == ISOFORTRAN_LOCK_TYPE)))
6984 gfc_error ("The source-expr at %L shall neither be of type "
6985 "LOCK_TYPE nor have a LOCK_TYPE component if "
6986 "allocate-object at %L is a coarray",
6987 &code->expr3->where, &e->where);
6992 /* Check F08:C629. */
6993 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
6996 gcc_assert (e->ts.type == BT_CLASS);
6997 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6998 "type-spec or source-expr", sym->name, &e->where);
7002 if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred)
7004 int cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
7005 code->ext.alloc.ts.u.cl->length);
7006 if (cmp == 1 || cmp == -1 || cmp == -3)
7008 gfc_error ("Allocating %s at %L with type-spec requires the same "
7009 "character-length parameter as in the declaration",
7010 sym->name, &e->where);
7015 /* In the variable definition context checks, gfc_expr_attr is used
7016 on the expression. This is fooled by the array specification
7017 present in e, thus we have to eliminate that one temporarily. */
7018 e2 = remove_last_array_ref (e);
7020 if (t == SUCCESS && pointer)
7021 t = gfc_check_vardef_context (e2, true, true, _("ALLOCATE object"));
7023 t = gfc_check_vardef_context (e2, false, true, _("ALLOCATE object"));
7028 if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
7029 && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
7031 /* For class arrays, the initialization with SOURCE is done
7032 using _copy and trans_call. It is convenient to exploit that
7033 when the allocated type is different from the declared type but
7034 no SOURCE exists by setting expr3. */
7035 code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
7037 else if (!code->expr3)
7039 /* Set up default initializer if needed. */
7043 if (code->ext.alloc.ts.type == BT_DERIVED)
7044 ts = code->ext.alloc.ts;
7048 if (ts.type == BT_CLASS)
7049 ts = ts.u.derived->components->ts;
7051 if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
7053 gfc_code *init_st = gfc_get_code ();
7054 init_st->loc = code->loc;
7055 init_st->op = EXEC_INIT_ASSIGN;
7056 init_st->expr1 = gfc_expr_to_initialize (e);
7057 init_st->expr2 = init_e;
7058 init_st->next = code->next;
7059 code->next = init_st;
7062 else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
7064 /* Default initialization via MOLD (non-polymorphic). */
7065 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
7066 gfc_resolve_expr (rhs);
7067 gfc_free_expr (code->expr3);
7071 if (e->ts.type == BT_CLASS)
7073 /* Make sure the vtab symbol is present when
7074 the module variables are generated. */
7075 gfc_typespec ts = e->ts;
7077 ts = code->expr3->ts;
7078 else if (code->ext.alloc.ts.type == BT_DERIVED)
7079 ts = code->ext.alloc.ts;
7080 gfc_find_derived_vtab (ts.u.derived);
7082 e = gfc_expr_to_initialize (e);
7085 if (dimension == 0 && codimension == 0)
7088 /* Make sure the last reference node is an array specifiction. */
7090 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
7091 || (dimension && ref2->u.ar.dimen == 0))
7093 gfc_error ("Array specification required in ALLOCATE statement "
7094 "at %L", &e->where);
7098 /* Make sure that the array section reference makes sense in the
7099 context of an ALLOCATE specification. */
7104 for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
7105 if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
7107 gfc_error ("Coarray specification required in ALLOCATE statement "
7108 "at %L", &e->where);
7112 for (i = 0; i < ar->dimen; i++)
7114 if (ref2->u.ar.type == AR_ELEMENT)
7117 switch (ar->dimen_type[i])
7123 if (ar->start[i] != NULL
7124 && ar->end[i] != NULL
7125 && ar->stride[i] == NULL)
7128 /* Fall Through... */
7133 case DIMEN_THIS_IMAGE:
7134 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7140 for (a = code->ext.alloc.list; a; a = a->next)
7142 sym = a->expr->symtree->n.sym;
7144 /* TODO - check derived type components. */
7145 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
7148 if ((ar->start[i] != NULL
7149 && gfc_find_sym_in_expr (sym, ar->start[i]))
7150 || (ar->end[i] != NULL
7151 && gfc_find_sym_in_expr (sym, ar->end[i])))
7153 gfc_error ("'%s' must not appear in the array specification at "
7154 "%L in the same ALLOCATE statement where it is "
7155 "itself allocated", sym->name, &ar->where);
7161 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
7163 if (ar->dimen_type[i] == DIMEN_ELEMENT
7164 || ar->dimen_type[i] == DIMEN_RANGE)
7166 if (i == (ar->dimen + ar->codimen - 1))
7168 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7169 "statement at %L", &e->where);
7175 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
7176 && ar->stride[i] == NULL)
7179 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7192 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
7194 gfc_expr *stat, *errmsg, *pe, *qe;
7195 gfc_alloc *a, *p, *q;
7198 errmsg = code->expr2;
7200 /* Check the stat variable. */
7203 gfc_check_vardef_context (stat, false, false, _("STAT variable"));
7205 if ((stat->ts.type != BT_INTEGER
7206 && !(stat->ref && (stat->ref->type == REF_ARRAY
7207 || stat->ref->type == REF_COMPONENT)))
7209 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7210 "variable", &stat->where);
7212 for (p = code->ext.alloc.list; p; p = p->next)
7213 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
7215 gfc_ref *ref1, *ref2;
7218 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
7219 ref1 = ref1->next, ref2 = ref2->next)
7221 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7223 if (ref1->u.c.component->name != ref2->u.c.component->name)
7232 gfc_error ("Stat-variable at %L shall not be %sd within "
7233 "the same %s statement", &stat->where, fcn, fcn);
7239 /* Check the errmsg variable. */
7243 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7246 gfc_check_vardef_context (errmsg, false, false, _("ERRMSG variable"));
7248 if ((errmsg->ts.type != BT_CHARACTER
7250 && (errmsg->ref->type == REF_ARRAY
7251 || errmsg->ref->type == REF_COMPONENT)))
7252 || errmsg->rank > 0 )
7253 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7254 "variable", &errmsg->where);
7256 for (p = code->ext.alloc.list; p; p = p->next)
7257 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
7259 gfc_ref *ref1, *ref2;
7262 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
7263 ref1 = ref1->next, ref2 = ref2->next)
7265 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7267 if (ref1->u.c.component->name != ref2->u.c.component->name)
7276 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7277 "the same %s statement", &errmsg->where, fcn, fcn);
7283 /* Check that an allocate-object appears only once in the statement. */
7285 for (p = code->ext.alloc.list; p; p = p->next)
7288 for (q = p->next; q; q = q->next)
7291 if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
7293 /* This is a potential collision. */
7294 gfc_ref *pr = pe->ref;
7295 gfc_ref *qr = qe->ref;
7297 /* Follow the references until
7298 a) They start to differ, in which case there is no error;
7299 you can deallocate a%b and a%c in a single statement
7300 b) Both of them stop, which is an error
7301 c) One of them stops, which is also an error. */
7304 if (pr == NULL && qr == NULL)
7306 gfc_error ("Allocate-object at %L also appears at %L",
7307 &pe->where, &qe->where);
7310 else if (pr != NULL && qr == NULL)
7312 gfc_error ("Allocate-object at %L is subobject of"
7313 " object at %L", &pe->where, &qe->where);
7316 else if (pr == NULL && qr != NULL)
7318 gfc_error ("Allocate-object at %L is subobject of"
7319 " object at %L", &qe->where, &pe->where);
7322 /* Here, pr != NULL && qr != NULL */
7323 gcc_assert(pr->type == qr->type);
7324 if (pr->type == REF_ARRAY)
7326 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7328 gcc_assert (qr->type == REF_ARRAY);
7330 if (pr->next && qr->next)
7333 gfc_array_ref *par = &(pr->u.ar);
7334 gfc_array_ref *qar = &(qr->u.ar);
7336 for (i=0; i<par->dimen; i++)
7338 if ((par->start[i] != NULL
7339 || qar->start[i] != NULL)
7340 && gfc_dep_compare_expr (par->start[i],
7341 qar->start[i]) != 0)
7348 if (pr->u.c.component->name != qr->u.c.component->name)
7361 if (strcmp (fcn, "ALLOCATE") == 0)
7363 for (a = code->ext.alloc.list; a; a = a->next)
7364 resolve_allocate_expr (a->expr, code);
7368 for (a = code->ext.alloc.list; a; a = a->next)
7369 resolve_deallocate_expr (a->expr);
7374 /************ SELECT CASE resolution subroutines ************/
7376 /* Callback function for our mergesort variant. Determines interval
7377 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7378 op1 > op2. Assumes we're not dealing with the default case.
7379 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7380 There are nine situations to check. */
7383 compare_cases (const gfc_case *op1, const gfc_case *op2)
7387 if (op1->low == NULL) /* op1 = (:L) */
7389 /* op2 = (:N), so overlap. */
7391 /* op2 = (M:) or (M:N), L < M */
7392 if (op2->low != NULL
7393 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7396 else if (op1->high == NULL) /* op1 = (K:) */
7398 /* op2 = (M:), so overlap. */
7400 /* op2 = (:N) or (M:N), K > N */
7401 if (op2->high != NULL
7402 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7405 else /* op1 = (K:L) */
7407 if (op2->low == NULL) /* op2 = (:N), K > N */
7408 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7410 else if (op2->high == NULL) /* op2 = (M:), L < M */
7411 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7413 else /* op2 = (M:N) */
7417 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7420 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7429 /* Merge-sort a double linked case list, detecting overlap in the
7430 process. LIST is the head of the double linked case list before it
7431 is sorted. Returns the head of the sorted list if we don't see any
7432 overlap, or NULL otherwise. */
7435 check_case_overlap (gfc_case *list)
7437 gfc_case *p, *q, *e, *tail;
7438 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7440 /* If the passed list was empty, return immediately. */
7447 /* Loop unconditionally. The only exit from this loop is a return
7448 statement, when we've finished sorting the case list. */
7455 /* Count the number of merges we do in this pass. */
7458 /* Loop while there exists a merge to be done. */
7463 /* Count this merge. */
7466 /* Cut the list in two pieces by stepping INSIZE places
7467 forward in the list, starting from P. */
7470 for (i = 0; i < insize; i++)
7479 /* Now we have two lists. Merge them! */
7480 while (psize > 0 || (qsize > 0 && q != NULL))
7482 /* See from which the next case to merge comes from. */
7485 /* P is empty so the next case must come from Q. */
7490 else if (qsize == 0 || q == NULL)
7499 cmp = compare_cases (p, q);
7502 /* The whole case range for P is less than the
7510 /* The whole case range for Q is greater than
7511 the case range for P. */
7518 /* The cases overlap, or they are the same
7519 element in the list. Either way, we must
7520 issue an error and get the next case from P. */
7521 /* FIXME: Sort P and Q by line number. */
7522 gfc_error ("CASE label at %L overlaps with CASE "
7523 "label at %L", &p->where, &q->where);
7531 /* Add the next element to the merged list. */
7540 /* P has now stepped INSIZE places along, and so has Q. So
7541 they're the same. */
7546 /* If we have done only one merge or none at all, we've
7547 finished sorting the cases. */
7556 /* Otherwise repeat, merging lists twice the size. */
7562 /* Check to see if an expression is suitable for use in a CASE statement.
7563 Makes sure that all case expressions are scalar constants of the same
7564 type. Return FAILURE if anything is wrong. */
7567 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7569 if (e == NULL) return SUCCESS;
7571 if (e->ts.type != case_expr->ts.type)
7573 gfc_error ("Expression in CASE statement at %L must be of type %s",
7574 &e->where, gfc_basic_typename (case_expr->ts.type));
7578 /* C805 (R808) For a given case-construct, each case-value shall be of
7579 the same type as case-expr. For character type, length differences
7580 are allowed, but the kind type parameters shall be the same. */
7582 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7584 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7585 &e->where, case_expr->ts.kind);
7589 /* Convert the case value kind to that of case expression kind,
7592 if (e->ts.kind != case_expr->ts.kind)
7593 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7597 gfc_error ("Expression in CASE statement at %L must be scalar",
7606 /* Given a completely parsed select statement, we:
7608 - Validate all expressions and code within the SELECT.
7609 - Make sure that the selection expression is not of the wrong type.
7610 - Make sure that no case ranges overlap.
7611 - Eliminate unreachable cases and unreachable code resulting from
7612 removing case labels.
7614 The standard does allow unreachable cases, e.g. CASE (5:3). But
7615 they are a hassle for code generation, and to prevent that, we just
7616 cut them out here. This is not necessary for overlapping cases
7617 because they are illegal and we never even try to generate code.
7619 We have the additional caveat that a SELECT construct could have
7620 been a computed GOTO in the source code. Fortunately we can fairly
7621 easily work around that here: The case_expr for a "real" SELECT CASE
7622 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7623 we have to do is make sure that the case_expr is a scalar integer
7627 resolve_select (gfc_code *code)
7630 gfc_expr *case_expr;
7631 gfc_case *cp, *default_case, *tail, *head;
7632 int seen_unreachable;
7638 if (code->expr1 == NULL)
7640 /* This was actually a computed GOTO statement. */
7641 case_expr = code->expr2;
7642 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7643 gfc_error ("Selection expression in computed GOTO statement "
7644 "at %L must be a scalar integer expression",
7647 /* Further checking is not necessary because this SELECT was built
7648 by the compiler, so it should always be OK. Just move the
7649 case_expr from expr2 to expr so that we can handle computed
7650 GOTOs as normal SELECTs from here on. */
7651 code->expr1 = code->expr2;
7656 case_expr = code->expr1;
7658 type = case_expr->ts.type;
7659 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7661 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7662 &case_expr->where, gfc_typename (&case_expr->ts));
7664 /* Punt. Going on here just produce more garbage error messages. */
7668 /* Raise a warning if an INTEGER case value exceeds the range of
7669 the case-expr. Later, all expressions will be promoted to the
7670 largest kind of all case-labels. */
7672 if (type == BT_INTEGER)
7673 for (body = code->block; body; body = body->block)
7674 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7677 && gfc_check_integer_range (cp->low->value.integer,
7678 case_expr->ts.kind) != ARITH_OK)
7679 gfc_warning ("Expression in CASE statement at %L is "
7680 "not in the range of %s", &cp->low->where,
7681 gfc_typename (&case_expr->ts));
7684 && cp->low != cp->high
7685 && gfc_check_integer_range (cp->high->value.integer,
7686 case_expr->ts.kind) != ARITH_OK)
7687 gfc_warning ("Expression in CASE statement at %L is "
7688 "not in the range of %s", &cp->high->where,
7689 gfc_typename (&case_expr->ts));
7692 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7693 of the SELECT CASE expression and its CASE values. Walk the lists
7694 of case values, and if we find a mismatch, promote case_expr to
7695 the appropriate kind. */
7697 if (type == BT_LOGICAL || type == BT_INTEGER)
7699 for (body = code->block; body; body = body->block)
7701 /* Walk the case label list. */
7702 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7704 /* Intercept the DEFAULT case. It does not have a kind. */
7705 if (cp->low == NULL && cp->high == NULL)
7708 /* Unreachable case ranges are discarded, so ignore. */
7709 if (cp->low != NULL && cp->high != NULL
7710 && cp->low != cp->high
7711 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7715 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7716 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7718 if (cp->high != NULL
7719 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7720 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7725 /* Assume there is no DEFAULT case. */
7726 default_case = NULL;
7731 for (body = code->block; body; body = body->block)
7733 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7735 seen_unreachable = 0;
7737 /* Walk the case label list, making sure that all case labels
7739 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7741 /* Count the number of cases in the whole construct. */
7744 /* Intercept the DEFAULT case. */
7745 if (cp->low == NULL && cp->high == NULL)
7747 if (default_case != NULL)
7749 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7750 "by a second DEFAULT CASE at %L",
7751 &default_case->where, &cp->where);
7762 /* Deal with single value cases and case ranges. Errors are
7763 issued from the validation function. */
7764 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7765 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7771 if (type == BT_LOGICAL
7772 && ((cp->low == NULL || cp->high == NULL)
7773 || cp->low != cp->high))
7775 gfc_error ("Logical range in CASE statement at %L is not "
7776 "allowed", &cp->low->where);
7781 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7784 value = cp->low->value.logical == 0 ? 2 : 1;
7785 if (value & seen_logical)
7787 gfc_error ("Constant logical value in CASE statement "
7788 "is repeated at %L",
7793 seen_logical |= value;
7796 if (cp->low != NULL && cp->high != NULL
7797 && cp->low != cp->high
7798 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7800 if (gfc_option.warn_surprising)
7801 gfc_warning ("Range specification at %L can never "
7802 "be matched", &cp->where);
7804 cp->unreachable = 1;
7805 seen_unreachable = 1;
7809 /* If the case range can be matched, it can also overlap with
7810 other cases. To make sure it does not, we put it in a
7811 double linked list here. We sort that with a merge sort
7812 later on to detect any overlapping cases. */
7816 head->right = head->left = NULL;
7821 tail->right->left = tail;
7828 /* It there was a failure in the previous case label, give up
7829 for this case label list. Continue with the next block. */
7833 /* See if any case labels that are unreachable have been seen.
7834 If so, we eliminate them. This is a bit of a kludge because
7835 the case lists for a single case statement (label) is a
7836 single forward linked lists. */
7837 if (seen_unreachable)
7839 /* Advance until the first case in the list is reachable. */
7840 while (body->ext.block.case_list != NULL
7841 && body->ext.block.case_list->unreachable)
7843 gfc_case *n = body->ext.block.case_list;
7844 body->ext.block.case_list = body->ext.block.case_list->next;
7846 gfc_free_case_list (n);
7849 /* Strip all other unreachable cases. */
7850 if (body->ext.block.case_list)
7852 for (cp = body->ext.block.case_list; cp->next; cp = cp->next)
7854 if (cp->next->unreachable)
7856 gfc_case *n = cp->next;
7857 cp->next = cp->next->next;
7859 gfc_free_case_list (n);
7866 /* See if there were overlapping cases. If the check returns NULL,
7867 there was overlap. In that case we don't do anything. If head
7868 is non-NULL, we prepend the DEFAULT case. The sorted list can
7869 then used during code generation for SELECT CASE constructs with
7870 a case expression of a CHARACTER type. */
7873 head = check_case_overlap (head);
7875 /* Prepend the default_case if it is there. */
7876 if (head != NULL && default_case)
7878 default_case->left = NULL;
7879 default_case->right = head;
7880 head->left = default_case;
7884 /* Eliminate dead blocks that may be the result if we've seen
7885 unreachable case labels for a block. */
7886 for (body = code; body && body->block; body = body->block)
7888 if (body->block->ext.block.case_list == NULL)
7890 /* Cut the unreachable block from the code chain. */
7891 gfc_code *c = body->block;
7892 body->block = c->block;
7894 /* Kill the dead block, but not the blocks below it. */
7896 gfc_free_statements (c);
7900 /* More than two cases is legal but insane for logical selects.
7901 Issue a warning for it. */
7902 if (gfc_option.warn_surprising && type == BT_LOGICAL
7904 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7909 /* Check if a derived type is extensible. */
7912 gfc_type_is_extensible (gfc_symbol *sym)
7914 return !(sym->attr.is_bind_c || sym->attr.sequence);
7918 /* Resolve an associate name: Resolve target and ensure the type-spec is
7919 correct as well as possibly the array-spec. */
7922 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
7926 gcc_assert (sym->assoc);
7927 gcc_assert (sym->attr.flavor == FL_VARIABLE);
7929 /* If this is for SELECT TYPE, the target may not yet be set. In that
7930 case, return. Resolution will be called later manually again when
7932 target = sym->assoc->target;
7935 gcc_assert (!sym->assoc->dangling);
7937 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
7940 /* For variable targets, we get some attributes from the target. */
7941 if (target->expr_type == EXPR_VARIABLE)
7945 gcc_assert (target->symtree);
7946 tsym = target->symtree->n.sym;
7948 sym->attr.asynchronous = tsym->attr.asynchronous;
7949 sym->attr.volatile_ = tsym->attr.volatile_;
7951 sym->attr.target = tsym->attr.target
7952 || gfc_expr_attr (target).pointer;
7955 /* Get type if this was not already set. Note that it can be
7956 some other type than the target in case this is a SELECT TYPE
7957 selector! So we must not update when the type is already there. */
7958 if (sym->ts.type == BT_UNKNOWN)
7959 sym->ts = target->ts;
7960 gcc_assert (sym->ts.type != BT_UNKNOWN);
7962 /* See if this is a valid association-to-variable. */
7963 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
7964 && !gfc_has_vector_subscript (target));
7966 /* Finally resolve if this is an array or not. */
7967 if (sym->attr.dimension && target->rank == 0)
7969 gfc_error ("Associate-name '%s' at %L is used as array",
7970 sym->name, &sym->declared_at);
7971 sym->attr.dimension = 0;
7974 if (target->rank > 0)
7975 sym->attr.dimension = 1;
7977 if (sym->attr.dimension)
7979 sym->as = gfc_get_array_spec ();
7980 sym->as->rank = target->rank;
7981 sym->as->type = AS_DEFERRED;
7983 /* Target must not be coindexed, thus the associate-variable
7985 sym->as->corank = 0;
7990 /* Resolve a SELECT TYPE statement. */
7993 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
7995 gfc_symbol *selector_type;
7996 gfc_code *body, *new_st, *if_st, *tail;
7997 gfc_code *class_is = NULL, *default_case = NULL;
8000 char name[GFC_MAX_SYMBOL_LEN];
8004 ns = code->ext.block.ns;
8007 /* Check for F03:C813. */
8008 if (code->expr1->ts.type != BT_CLASS
8009 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
8011 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8012 "at %L", &code->loc);
8016 if (!code->expr1->symtree->n.sym->attr.class_ok)
8021 if (code->expr1->symtree->n.sym->attr.untyped)
8022 code->expr1->symtree->n.sym->ts = code->expr2->ts;
8023 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
8026 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
8028 /* Loop over TYPE IS / CLASS IS cases. */
8029 for (body = code->block; body; body = body->block)
8031 c = body->ext.block.case_list;
8033 /* Check F03:C815. */
8034 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8035 && !gfc_type_is_extensible (c->ts.u.derived))
8037 gfc_error ("Derived type '%s' at %L must be extensible",
8038 c->ts.u.derived->name, &c->where);
8043 /* Check F03:C816. */
8044 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8045 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
8047 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
8048 c->ts.u.derived->name, &c->where, selector_type->name);
8053 /* Intercept the DEFAULT case. */
8054 if (c->ts.type == BT_UNKNOWN)
8056 /* Check F03:C818. */
8059 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8060 "by a second DEFAULT CASE at %L",
8061 &default_case->ext.block.case_list->where, &c->where);
8066 default_case = body;
8073 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8074 target if present. If there are any EXIT statements referring to the
8075 SELECT TYPE construct, this is no problem because the gfc_code
8076 reference stays the same and EXIT is equally possible from the BLOCK
8077 it is changed to. */
8078 code->op = EXEC_BLOCK;
8081 gfc_association_list* assoc;
8083 assoc = gfc_get_association_list ();
8084 assoc->st = code->expr1->symtree;
8085 assoc->target = gfc_copy_expr (code->expr2);
8086 assoc->target->where = code->expr2->where;
8087 /* assoc->variable will be set by resolve_assoc_var. */
8089 code->ext.block.assoc = assoc;
8090 code->expr1->symtree->n.sym->assoc = assoc;
8092 resolve_assoc_var (code->expr1->symtree->n.sym, false);
8095 code->ext.block.assoc = NULL;
8097 /* Add EXEC_SELECT to switch on type. */
8098 new_st = gfc_get_code ();
8099 new_st->op = code->op;
8100 new_st->expr1 = code->expr1;
8101 new_st->expr2 = code->expr2;
8102 new_st->block = code->block;
8103 code->expr1 = code->expr2 = NULL;
8108 ns->code->next = new_st;
8110 code->op = EXEC_SELECT;
8111 gfc_add_vptr_component (code->expr1);
8112 gfc_add_hash_component (code->expr1);
8114 /* Loop over TYPE IS / CLASS IS cases. */
8115 for (body = code->block; body; body = body->block)
8117 c = body->ext.block.case_list;
8119 if (c->ts.type == BT_DERIVED)
8120 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
8121 c->ts.u.derived->hash_value);
8123 else if (c->ts.type == BT_UNKNOWN)
8126 /* Associate temporary to selector. This should only be done
8127 when this case is actually true, so build a new ASSOCIATE
8128 that does precisely this here (instead of using the
8131 if (c->ts.type == BT_CLASS)
8132 sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
8134 sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
8135 st = gfc_find_symtree (ns->sym_root, name);
8136 gcc_assert (st->n.sym->assoc);
8137 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
8138 st->n.sym->assoc->target->where = code->expr1->where;
8139 if (c->ts.type == BT_DERIVED)
8140 gfc_add_data_component (st->n.sym->assoc->target);
8142 new_st = gfc_get_code ();
8143 new_st->op = EXEC_BLOCK;
8144 new_st->ext.block.ns = gfc_build_block_ns (ns);
8145 new_st->ext.block.ns->code = body->next;
8146 body->next = new_st;
8148 /* Chain in the new list only if it is marked as dangling. Otherwise
8149 there is a CASE label overlap and this is already used. Just ignore,
8150 the error is diagonsed elsewhere. */
8151 if (st->n.sym->assoc->dangling)
8153 new_st->ext.block.assoc = st->n.sym->assoc;
8154 st->n.sym->assoc->dangling = 0;
8157 resolve_assoc_var (st->n.sym, false);
8160 /* Take out CLASS IS cases for separate treatment. */
8162 while (body && body->block)
8164 if (body->block->ext.block.case_list->ts.type == BT_CLASS)
8166 /* Add to class_is list. */
8167 if (class_is == NULL)
8169 class_is = body->block;
8174 for (tail = class_is; tail->block; tail = tail->block) ;
8175 tail->block = body->block;
8178 /* Remove from EXEC_SELECT list. */
8179 body->block = body->block->block;
8192 /* Add a default case to hold the CLASS IS cases. */
8193 for (tail = code; tail->block; tail = tail->block) ;
8194 tail->block = gfc_get_code ();
8196 tail->op = EXEC_SELECT_TYPE;
8197 tail->ext.block.case_list = gfc_get_case ();
8198 tail->ext.block.case_list->ts.type = BT_UNKNOWN;
8200 default_case = tail;
8203 /* More than one CLASS IS block? */
8204 if (class_is->block)
8208 /* Sort CLASS IS blocks by extension level. */
8212 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
8215 /* F03:C817 (check for doubles). */
8216 if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
8217 == c2->ext.block.case_list->ts.u.derived->hash_value)
8219 gfc_error ("Double CLASS IS block in SELECT TYPE "
8221 &c2->ext.block.case_list->where);
8224 if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
8225 < c2->ext.block.case_list->ts.u.derived->attr.extension)
8228 (*c1)->block = c2->block;
8238 /* Generate IF chain. */
8239 if_st = gfc_get_code ();
8240 if_st->op = EXEC_IF;
8242 for (body = class_is; body; body = body->block)
8244 new_st->block = gfc_get_code ();
8245 new_st = new_st->block;
8246 new_st->op = EXEC_IF;
8247 /* Set up IF condition: Call _gfortran_is_extension_of. */
8248 new_st->expr1 = gfc_get_expr ();
8249 new_st->expr1->expr_type = EXPR_FUNCTION;
8250 new_st->expr1->ts.type = BT_LOGICAL;
8251 new_st->expr1->ts.kind = 4;
8252 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
8253 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
8254 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
8255 /* Set up arguments. */
8256 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
8257 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
8258 new_st->expr1->value.function.actual->expr->where = code->loc;
8259 gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
8260 vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
8261 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
8262 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
8263 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
8264 new_st->next = body->next;
8266 if (default_case->next)
8268 new_st->block = gfc_get_code ();
8269 new_st = new_st->block;
8270 new_st->op = EXEC_IF;
8271 new_st->next = default_case->next;
8274 /* Replace CLASS DEFAULT code by the IF chain. */
8275 default_case->next = if_st;
8278 /* Resolve the internal code. This can not be done earlier because
8279 it requires that the sym->assoc of selectors is set already. */
8280 gfc_current_ns = ns;
8281 gfc_resolve_blocks (code->block, gfc_current_ns);
8282 gfc_current_ns = old_ns;
8284 resolve_select (code);
8288 /* Resolve a transfer statement. This is making sure that:
8289 -- a derived type being transferred has only non-pointer components
8290 -- a derived type being transferred doesn't have private components, unless
8291 it's being transferred from the module where the type was defined
8292 -- we're not trying to transfer a whole assumed size array. */
8295 resolve_transfer (gfc_code *code)
8304 while (exp != NULL && exp->expr_type == EXPR_OP
8305 && exp->value.op.op == INTRINSIC_PARENTHESES)
8306 exp = exp->value.op.op1;
8308 if (exp && exp->expr_type == EXPR_NULL && exp->ts.type == BT_UNKNOWN)
8310 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8311 "MOLD=", &exp->where);
8315 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
8316 && exp->expr_type != EXPR_FUNCTION))
8319 /* If we are reading, the variable will be changed. Note that
8320 code->ext.dt may be NULL if the TRANSFER is related to
8321 an INQUIRE statement -- but in this case, we are not reading, either. */
8322 if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
8323 && gfc_check_vardef_context (exp, false, false, _("item in READ"))
8327 sym = exp->symtree->n.sym;
8330 /* Go to actual component transferred. */
8331 for (ref = exp->ref; ref; ref = ref->next)
8332 if (ref->type == REF_COMPONENT)
8333 ts = &ref->u.c.component->ts;
8335 if (ts->type == BT_CLASS)
8337 /* FIXME: Test for defined input/output. */
8338 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8339 "it is processed by a defined input/output procedure",
8344 if (ts->type == BT_DERIVED)
8346 /* Check that transferred derived type doesn't contain POINTER
8348 if (ts->u.derived->attr.pointer_comp)
8350 gfc_error ("Data transfer element at %L cannot have POINTER "
8351 "components unless it is processed by a defined "
8352 "input/output procedure", &code->loc);
8357 if (ts->u.derived->attr.proc_pointer_comp)
8359 gfc_error ("Data transfer element at %L cannot have "
8360 "procedure pointer components", &code->loc);
8364 if (ts->u.derived->attr.alloc_comp)
8366 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8367 "components unless it is processed by a defined "
8368 "input/output procedure", &code->loc);
8372 if (derived_inaccessible (ts->u.derived))
8374 gfc_error ("Data transfer element at %L cannot have "
8375 "PRIVATE components",&code->loc);
8380 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
8381 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
8383 gfc_error ("Data transfer element at %L cannot be a full reference to "
8384 "an assumed-size array", &code->loc);
8390 /*********** Toplevel code resolution subroutines ***********/
8392 /* Find the set of labels that are reachable from this block. We also
8393 record the last statement in each block. */
8396 find_reachable_labels (gfc_code *block)
8403 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
8405 /* Collect labels in this block. We don't keep those corresponding
8406 to END {IF|SELECT}, these are checked in resolve_branch by going
8407 up through the code_stack. */
8408 for (c = block; c; c = c->next)
8410 if (c->here && c->op != EXEC_END_NESTED_BLOCK)
8411 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8414 /* Merge with labels from parent block. */
8417 gcc_assert (cs_base->prev->reachable_labels);
8418 bitmap_ior_into (cs_base->reachable_labels,
8419 cs_base->prev->reachable_labels);
8425 resolve_lock_unlock (gfc_code *code)
8427 if (code->expr1->ts.type != BT_DERIVED
8428 || code->expr1->expr_type != EXPR_VARIABLE
8429 || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
8430 || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
8431 || code->expr1->rank != 0
8432 || (!gfc_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1)))
8433 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8434 &code->expr1->where);
8438 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8439 || code->expr2->expr_type != EXPR_VARIABLE))
8440 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8441 &code->expr2->where);
8444 && gfc_check_vardef_context (code->expr2, false, false,
8445 _("STAT variable")) == FAILURE)
8450 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8451 || code->expr3->expr_type != EXPR_VARIABLE))
8452 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8453 &code->expr3->where);
8456 && gfc_check_vardef_context (code->expr3, false, false,
8457 _("ERRMSG variable")) == FAILURE)
8460 /* Check ACQUIRED_LOCK. */
8462 && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
8463 || code->expr4->expr_type != EXPR_VARIABLE))
8464 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8465 "variable", &code->expr4->where);
8468 && gfc_check_vardef_context (code->expr4, false, false,
8469 _("ACQUIRED_LOCK variable")) == FAILURE)
8475 resolve_sync (gfc_code *code)
8477 /* Check imageset. The * case matches expr1 == NULL. */
8480 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8481 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8482 "INTEGER expression", &code->expr1->where);
8483 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8484 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8485 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8486 &code->expr1->where);
8487 else if (code->expr1->expr_type == EXPR_ARRAY
8488 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8490 gfc_constructor *cons;
8491 cons = gfc_constructor_first (code->expr1->value.constructor);
8492 for (; cons; cons = gfc_constructor_next (cons))
8493 if (cons->expr->expr_type == EXPR_CONSTANT
8494 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8495 gfc_error ("Imageset argument at %L must between 1 and "
8496 "num_images()", &cons->expr->where);
8502 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8503 || code->expr2->expr_type != EXPR_VARIABLE))
8504 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8505 &code->expr2->where);
8509 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8510 || code->expr3->expr_type != EXPR_VARIABLE))
8511 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8512 &code->expr3->where);
8516 /* Given a branch to a label, see if the branch is conforming.
8517 The code node describes where the branch is located. */
8520 resolve_branch (gfc_st_label *label, gfc_code *code)
8527 /* Step one: is this a valid branching target? */
8529 if (label->defined == ST_LABEL_UNKNOWN)
8531 gfc_error ("Label %d referenced at %L is never defined", label->value,
8536 if (label->defined != ST_LABEL_TARGET)
8538 gfc_error ("Statement at %L is not a valid branch target statement "
8539 "for the branch statement at %L", &label->where, &code->loc);
8543 /* Step two: make sure this branch is not a branch to itself ;-) */
8545 if (code->here == label)
8547 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8551 /* Step three: See if the label is in the same block as the
8552 branching statement. The hard work has been done by setting up
8553 the bitmap reachable_labels. */
8555 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8557 /* Check now whether there is a CRITICAL construct; if so, check
8558 whether the label is still visible outside of the CRITICAL block,
8559 which is invalid. */
8560 for (stack = cs_base; stack; stack = stack->prev)
8562 if (stack->current->op == EXEC_CRITICAL
8563 && bitmap_bit_p (stack->reachable_labels, label->value))
8564 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8565 "label at %L", &code->loc, &label->where);
8566 else if (stack->current->op == EXEC_DO_CONCURRENT
8567 && bitmap_bit_p (stack->reachable_labels, label->value))
8568 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8569 "for label at %L", &code->loc, &label->where);
8575 /* Step four: If we haven't found the label in the bitmap, it may
8576 still be the label of the END of the enclosing block, in which
8577 case we find it by going up the code_stack. */
8579 for (stack = cs_base; stack; stack = stack->prev)
8581 if (stack->current->next && stack->current->next->here == label)
8583 if (stack->current->op == EXEC_CRITICAL)
8585 /* Note: A label at END CRITICAL does not leave the CRITICAL
8586 construct as END CRITICAL is still part of it. */
8587 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8588 " at %L", &code->loc, &label->where);
8591 else if (stack->current->op == EXEC_DO_CONCURRENT)
8593 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8594 "label at %L", &code->loc, &label->where);
8601 gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
8605 /* The label is not in an enclosing block, so illegal. This was
8606 allowed in Fortran 66, so we allow it as extension. No
8607 further checks are necessary in this case. */
8608 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
8609 "as the GOTO statement at %L", &label->where,
8615 /* Check whether EXPR1 has the same shape as EXPR2. */
8618 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
8620 mpz_t shape[GFC_MAX_DIMENSIONS];
8621 mpz_t shape2[GFC_MAX_DIMENSIONS];
8622 gfc_try result = FAILURE;
8625 /* Compare the rank. */
8626 if (expr1->rank != expr2->rank)
8629 /* Compare the size of each dimension. */
8630 for (i=0; i<expr1->rank; i++)
8632 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
8635 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
8638 if (mpz_cmp (shape[i], shape2[i]))
8642 /* When either of the two expression is an assumed size array, we
8643 ignore the comparison of dimension sizes. */
8648 gfc_clear_shape (shape, i);
8649 gfc_clear_shape (shape2, i);
8654 /* Check whether a WHERE assignment target or a WHERE mask expression
8655 has the same shape as the outmost WHERE mask expression. */
8658 resolve_where (gfc_code *code, gfc_expr *mask)
8664 cblock = code->block;
8666 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8667 In case of nested WHERE, only the outmost one is stored. */
8668 if (mask == NULL) /* outmost WHERE */
8670 else /* inner WHERE */
8677 /* Check if the mask-expr has a consistent shape with the
8678 outmost WHERE mask-expr. */
8679 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8680 gfc_error ("WHERE mask at %L has inconsistent shape",
8681 &cblock->expr1->where);
8684 /* the assignment statement of a WHERE statement, or the first
8685 statement in where-body-construct of a WHERE construct */
8686 cnext = cblock->next;
8691 /* WHERE assignment statement */
8694 /* Check shape consistent for WHERE assignment target. */
8695 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8696 gfc_error ("WHERE assignment target at %L has "
8697 "inconsistent shape", &cnext->expr1->where);
8701 case EXEC_ASSIGN_CALL:
8702 resolve_call (cnext);
8703 if (!cnext->resolved_sym->attr.elemental)
8704 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8705 &cnext->ext.actual->expr->where);
8708 /* WHERE or WHERE construct is part of a where-body-construct */
8710 resolve_where (cnext, e);
8714 gfc_error ("Unsupported statement inside WHERE at %L",
8717 /* the next statement within the same where-body-construct */
8718 cnext = cnext->next;
8720 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8721 cblock = cblock->block;
8726 /* Resolve assignment in FORALL construct.
8727 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8728 FORALL index variables. */
8731 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8735 for (n = 0; n < nvar; n++)
8737 gfc_symbol *forall_index;
8739 forall_index = var_expr[n]->symtree->n.sym;
8741 /* Check whether the assignment target is one of the FORALL index
8743 if ((code->expr1->expr_type == EXPR_VARIABLE)
8744 && (code->expr1->symtree->n.sym == forall_index))
8745 gfc_error ("Assignment to a FORALL index variable at %L",
8746 &code->expr1->where);
8749 /* If one of the FORALL index variables doesn't appear in the
8750 assignment variable, then there could be a many-to-one
8751 assignment. Emit a warning rather than an error because the
8752 mask could be resolving this problem. */
8753 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8754 gfc_warning ("The FORALL with index '%s' is not used on the "
8755 "left side of the assignment at %L and so might "
8756 "cause multiple assignment to this object",
8757 var_expr[n]->symtree->name, &code->expr1->where);
8763 /* Resolve WHERE statement in FORALL construct. */
8766 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8767 gfc_expr **var_expr)
8772 cblock = code->block;
8775 /* the assignment statement of a WHERE statement, or the first
8776 statement in where-body-construct of a WHERE construct */
8777 cnext = cblock->next;
8782 /* WHERE assignment statement */
8784 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8787 /* WHERE operator assignment statement */
8788 case EXEC_ASSIGN_CALL:
8789 resolve_call (cnext);
8790 if (!cnext->resolved_sym->attr.elemental)
8791 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8792 &cnext->ext.actual->expr->where);
8795 /* WHERE or WHERE construct is part of a where-body-construct */
8797 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8801 gfc_error ("Unsupported statement inside WHERE at %L",
8804 /* the next statement within the same where-body-construct */
8805 cnext = cnext->next;
8807 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8808 cblock = cblock->block;
8813 /* Traverse the FORALL body to check whether the following errors exist:
8814 1. For assignment, check if a many-to-one assignment happens.
8815 2. For WHERE statement, check the WHERE body to see if there is any
8816 many-to-one assignment. */
8819 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8823 c = code->block->next;
8829 case EXEC_POINTER_ASSIGN:
8830 gfc_resolve_assign_in_forall (c, nvar, var_expr);
8833 case EXEC_ASSIGN_CALL:
8837 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8838 there is no need to handle it here. */
8842 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8847 /* The next statement in the FORALL body. */
8853 /* Counts the number of iterators needed inside a forall construct, including
8854 nested forall constructs. This is used to allocate the needed memory
8855 in gfc_resolve_forall. */
8858 gfc_count_forall_iterators (gfc_code *code)
8860 int max_iters, sub_iters, current_iters;
8861 gfc_forall_iterator *fa;
8863 gcc_assert(code->op == EXEC_FORALL);
8867 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8870 code = code->block->next;
8874 if (code->op == EXEC_FORALL)
8876 sub_iters = gfc_count_forall_iterators (code);
8877 if (sub_iters > max_iters)
8878 max_iters = sub_iters;
8883 return current_iters + max_iters;
8887 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8888 gfc_resolve_forall_body to resolve the FORALL body. */
8891 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8893 static gfc_expr **var_expr;
8894 static int total_var = 0;
8895 static int nvar = 0;
8897 gfc_forall_iterator *fa;
8902 /* Start to resolve a FORALL construct */
8903 if (forall_save == 0)
8905 /* Count the total number of FORALL index in the nested FORALL
8906 construct in order to allocate the VAR_EXPR with proper size. */
8907 total_var = gfc_count_forall_iterators (code);
8909 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8910 var_expr = XCNEWVEC (gfc_expr *, total_var);
8913 /* The information about FORALL iterator, including FORALL index start, end
8914 and stride. The FORALL index can not appear in start, end or stride. */
8915 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8917 /* Check if any outer FORALL index name is the same as the current
8919 for (i = 0; i < nvar; i++)
8921 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8923 gfc_error ("An outer FORALL construct already has an index "
8924 "with this name %L", &fa->var->where);
8928 /* Record the current FORALL index. */
8929 var_expr[nvar] = gfc_copy_expr (fa->var);
8933 /* No memory leak. */
8934 gcc_assert (nvar <= total_var);
8937 /* Resolve the FORALL body. */
8938 gfc_resolve_forall_body (code, nvar, var_expr);
8940 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8941 gfc_resolve_blocks (code->block, ns);
8945 /* Free only the VAR_EXPRs allocated in this frame. */
8946 for (i = nvar; i < tmp; i++)
8947 gfc_free_expr (var_expr[i]);
8951 /* We are in the outermost FORALL construct. */
8952 gcc_assert (forall_save == 0);
8954 /* VAR_EXPR is not needed any more. */
8961 /* Resolve a BLOCK construct statement. */
8964 resolve_block_construct (gfc_code* code)
8966 /* Resolve the BLOCK's namespace. */
8967 gfc_resolve (code->ext.block.ns);
8969 /* For an ASSOCIATE block, the associations (and their targets) are already
8970 resolved during resolve_symbol. */
8974 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8977 static void resolve_code (gfc_code *, gfc_namespace *);
8980 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8984 for (; b; b = b->block)
8986 t = gfc_resolve_expr (b->expr1);
8987 if (gfc_resolve_expr (b->expr2) == FAILURE)
8993 if (t == SUCCESS && b->expr1 != NULL
8994 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
8995 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9002 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
9003 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9008 resolve_branch (b->label1, b);
9012 resolve_block_construct (b);
9016 case EXEC_SELECT_TYPE:
9020 case EXEC_DO_CONCURRENT:
9028 case EXEC_OMP_ATOMIC:
9029 case EXEC_OMP_CRITICAL:
9031 case EXEC_OMP_MASTER:
9032 case EXEC_OMP_ORDERED:
9033 case EXEC_OMP_PARALLEL:
9034 case EXEC_OMP_PARALLEL_DO:
9035 case EXEC_OMP_PARALLEL_SECTIONS:
9036 case EXEC_OMP_PARALLEL_WORKSHARE:
9037 case EXEC_OMP_SECTIONS:
9038 case EXEC_OMP_SINGLE:
9040 case EXEC_OMP_TASKWAIT:
9041 case EXEC_OMP_TASKYIELD:
9042 case EXEC_OMP_WORKSHARE:
9046 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9049 resolve_code (b->next, ns);
9054 /* Does everything to resolve an ordinary assignment. Returns true
9055 if this is an interface assignment. */
9057 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
9067 if (gfc_extend_assign (code, ns) == SUCCESS)
9071 if (code->op == EXEC_ASSIGN_CALL)
9073 lhs = code->ext.actual->expr;
9074 rhsptr = &code->ext.actual->next->expr;
9078 gfc_actual_arglist* args;
9079 gfc_typebound_proc* tbp;
9081 gcc_assert (code->op == EXEC_COMPCALL);
9083 args = code->expr1->value.compcall.actual;
9085 rhsptr = &args->next->expr;
9087 tbp = code->expr1->value.compcall.tbp;
9088 gcc_assert (!tbp->is_generic);
9091 /* Make a temporary rhs when there is a default initializer
9092 and rhs is the same symbol as the lhs. */
9093 if ((*rhsptr)->expr_type == EXPR_VARIABLE
9094 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
9095 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
9096 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
9097 *rhsptr = gfc_get_parentheses (*rhsptr);
9106 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
9107 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9108 &code->loc) == FAILURE)
9111 /* Handle the case of a BOZ literal on the RHS. */
9112 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
9115 if (gfc_option.warn_surprising)
9116 gfc_warning ("BOZ literal at %L is bitwise transferred "
9117 "non-integer symbol '%s'", &code->loc,
9118 lhs->symtree->n.sym->name);
9120 if (!gfc_convert_boz (rhs, &lhs->ts))
9122 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
9124 if (rc == ARITH_UNDERFLOW)
9125 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9126 ". This check can be disabled with the option "
9127 "-fno-range-check", &rhs->where);
9128 else if (rc == ARITH_OVERFLOW)
9129 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9130 ". This check can be disabled with the option "
9131 "-fno-range-check", &rhs->where);
9132 else if (rc == ARITH_NAN)
9133 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9134 ". This check can be disabled with the option "
9135 "-fno-range-check", &rhs->where);
9140 if (lhs->ts.type == BT_CHARACTER
9141 && gfc_option.warn_character_truncation)
9143 if (lhs->ts.u.cl != NULL
9144 && lhs->ts.u.cl->length != NULL
9145 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9146 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
9148 if (rhs->expr_type == EXPR_CONSTANT)
9149 rlen = rhs->value.character.length;
9151 else if (rhs->ts.u.cl != NULL
9152 && rhs->ts.u.cl->length != NULL
9153 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9154 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
9156 if (rlen && llen && rlen > llen)
9157 gfc_warning_now ("CHARACTER expression will be truncated "
9158 "in assignment (%d/%d) at %L",
9159 llen, rlen, &code->loc);
9162 /* Ensure that a vector index expression for the lvalue is evaluated
9163 to a temporary if the lvalue symbol is referenced in it. */
9166 for (ref = lhs->ref; ref; ref= ref->next)
9167 if (ref->type == REF_ARRAY)
9169 for (n = 0; n < ref->u.ar.dimen; n++)
9170 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
9171 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
9172 ref->u.ar.start[n]))
9174 = gfc_get_parentheses (ref->u.ar.start[n]);
9178 if (gfc_pure (NULL))
9180 if (lhs->ts.type == BT_DERIVED
9181 && lhs->expr_type == EXPR_VARIABLE
9182 && lhs->ts.u.derived->attr.pointer_comp
9183 && rhs->expr_type == EXPR_VARIABLE
9184 && (gfc_impure_variable (rhs->symtree->n.sym)
9185 || gfc_is_coindexed (rhs)))
9188 if (gfc_is_coindexed (rhs))
9189 gfc_error ("Coindexed expression at %L is assigned to "
9190 "a derived type variable with a POINTER "
9191 "component in a PURE procedure",
9194 gfc_error ("The impure variable at %L is assigned to "
9195 "a derived type variable with a POINTER "
9196 "component in a PURE procedure (12.6)",
9201 /* Fortran 2008, C1283. */
9202 if (gfc_is_coindexed (lhs))
9204 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9205 "procedure", &rhs->where);
9210 if (gfc_implicit_pure (NULL))
9212 if (lhs->expr_type == EXPR_VARIABLE
9213 && lhs->symtree->n.sym != gfc_current_ns->proc_name
9214 && lhs->symtree->n.sym->ns != gfc_current_ns)
9215 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9217 if (lhs->ts.type == BT_DERIVED
9218 && lhs->expr_type == EXPR_VARIABLE
9219 && lhs->ts.u.derived->attr.pointer_comp
9220 && rhs->expr_type == EXPR_VARIABLE
9221 && (gfc_impure_variable (rhs->symtree->n.sym)
9222 || gfc_is_coindexed (rhs)))
9223 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9225 /* Fortran 2008, C1283. */
9226 if (gfc_is_coindexed (lhs))
9227 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9231 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9232 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9233 if (lhs->ts.type == BT_CLASS)
9235 gfc_error ("Variable must not be polymorphic in intrinsic assignment at "
9236 "%L - check that there is a matching specific subroutine "
9237 "for '=' operator", &lhs->where);
9241 /* F2008, Section 7.2.1.2. */
9242 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
9244 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9245 "component in assignment at %L", &lhs->where);
9249 gfc_check_assign (lhs, rhs, 1);
9254 /* Given a block of code, recursively resolve everything pointed to by this
9258 resolve_code (gfc_code *code, gfc_namespace *ns)
9260 int omp_workshare_save;
9261 int forall_save, do_concurrent_save;
9265 frame.prev = cs_base;
9269 find_reachable_labels (code);
9271 for (; code; code = code->next)
9273 frame.current = code;
9274 forall_save = forall_flag;
9275 do_concurrent_save = do_concurrent_flag;
9277 if (code->op == EXEC_FORALL)
9280 gfc_resolve_forall (code, ns, forall_save);
9283 else if (code->block)
9285 omp_workshare_save = -1;
9288 case EXEC_OMP_PARALLEL_WORKSHARE:
9289 omp_workshare_save = omp_workshare_flag;
9290 omp_workshare_flag = 1;
9291 gfc_resolve_omp_parallel_blocks (code, ns);
9293 case EXEC_OMP_PARALLEL:
9294 case EXEC_OMP_PARALLEL_DO:
9295 case EXEC_OMP_PARALLEL_SECTIONS:
9297 omp_workshare_save = omp_workshare_flag;
9298 omp_workshare_flag = 0;
9299 gfc_resolve_omp_parallel_blocks (code, ns);
9302 gfc_resolve_omp_do_blocks (code, ns);
9304 case EXEC_SELECT_TYPE:
9305 /* Blocks are handled in resolve_select_type because we have
9306 to transform the SELECT TYPE into ASSOCIATE first. */
9308 case EXEC_DO_CONCURRENT:
9309 do_concurrent_flag = 1;
9310 gfc_resolve_blocks (code->block, ns);
9311 do_concurrent_flag = 2;
9313 case EXEC_OMP_WORKSHARE:
9314 omp_workshare_save = omp_workshare_flag;
9315 omp_workshare_flag = 1;
9318 gfc_resolve_blocks (code->block, ns);
9322 if (omp_workshare_save != -1)
9323 omp_workshare_flag = omp_workshare_save;
9327 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
9328 t = gfc_resolve_expr (code->expr1);
9329 forall_flag = forall_save;
9330 do_concurrent_flag = do_concurrent_save;
9332 if (gfc_resolve_expr (code->expr2) == FAILURE)
9335 if (code->op == EXEC_ALLOCATE
9336 && gfc_resolve_expr (code->expr3) == FAILURE)
9342 case EXEC_END_BLOCK:
9343 case EXEC_END_NESTED_BLOCK:
9347 case EXEC_ERROR_STOP:
9351 case EXEC_ASSIGN_CALL:
9356 case EXEC_SYNC_IMAGES:
9357 case EXEC_SYNC_MEMORY:
9358 resolve_sync (code);
9363 resolve_lock_unlock (code);
9367 /* Keep track of which entry we are up to. */
9368 current_entry_id = code->ext.entry->id;
9372 resolve_where (code, NULL);
9376 if (code->expr1 != NULL)
9378 if (code->expr1->ts.type != BT_INTEGER)
9379 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9380 "INTEGER variable", &code->expr1->where);
9381 else if (code->expr1->symtree->n.sym->attr.assign != 1)
9382 gfc_error ("Variable '%s' has not been assigned a target "
9383 "label at %L", code->expr1->symtree->n.sym->name,
9384 &code->expr1->where);
9387 resolve_branch (code->label1, code);
9391 if (code->expr1 != NULL
9392 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
9393 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9394 "INTEGER return specifier", &code->expr1->where);
9397 case EXEC_INIT_ASSIGN:
9398 case EXEC_END_PROCEDURE:
9405 if (gfc_check_vardef_context (code->expr1, false, false,
9406 _("assignment")) == FAILURE)
9409 if (resolve_ordinary_assign (code, ns))
9411 if (code->op == EXEC_COMPCALL)
9418 case EXEC_LABEL_ASSIGN:
9419 if (code->label1->defined == ST_LABEL_UNKNOWN)
9420 gfc_error ("Label %d referenced at %L is never defined",
9421 code->label1->value, &code->label1->where);
9423 && (code->expr1->expr_type != EXPR_VARIABLE
9424 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
9425 || code->expr1->symtree->n.sym->ts.kind
9426 != gfc_default_integer_kind
9427 || code->expr1->symtree->n.sym->as != NULL))
9428 gfc_error ("ASSIGN statement at %L requires a scalar "
9429 "default INTEGER variable", &code->expr1->where);
9432 case EXEC_POINTER_ASSIGN:
9439 /* This is both a variable definition and pointer assignment
9440 context, so check both of them. For rank remapping, a final
9441 array ref may be present on the LHS and fool gfc_expr_attr
9442 used in gfc_check_vardef_context. Remove it. */
9443 e = remove_last_array_ref (code->expr1);
9444 t = gfc_check_vardef_context (e, true, false,
9445 _("pointer assignment"));
9447 t = gfc_check_vardef_context (e, false, false,
9448 _("pointer assignment"));
9453 gfc_check_pointer_assign (code->expr1, code->expr2);
9457 case EXEC_ARITHMETIC_IF:
9459 && code->expr1->ts.type != BT_INTEGER
9460 && code->expr1->ts.type != BT_REAL)
9461 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9462 "expression", &code->expr1->where);
9464 resolve_branch (code->label1, code);
9465 resolve_branch (code->label2, code);
9466 resolve_branch (code->label3, code);
9470 if (t == SUCCESS && code->expr1 != NULL
9471 && (code->expr1->ts.type != BT_LOGICAL
9472 || code->expr1->rank != 0))
9473 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9474 &code->expr1->where);
9479 resolve_call (code);
9484 resolve_typebound_subroutine (code);
9488 resolve_ppc_call (code);
9492 /* Select is complicated. Also, a SELECT construct could be
9493 a transformed computed GOTO. */
9494 resolve_select (code);
9497 case EXEC_SELECT_TYPE:
9498 resolve_select_type (code, ns);
9502 resolve_block_construct (code);
9506 if (code->ext.iterator != NULL)
9508 gfc_iterator *iter = code->ext.iterator;
9509 if (gfc_resolve_iterator (iter, true) != FAILURE)
9510 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
9515 if (code->expr1 == NULL)
9516 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9518 && (code->expr1->rank != 0
9519 || code->expr1->ts.type != BT_LOGICAL))
9520 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9521 "a scalar LOGICAL expression", &code->expr1->where);
9526 resolve_allocate_deallocate (code, "ALLOCATE");
9530 case EXEC_DEALLOCATE:
9532 resolve_allocate_deallocate (code, "DEALLOCATE");
9537 if (gfc_resolve_open (code->ext.open) == FAILURE)
9540 resolve_branch (code->ext.open->err, code);
9544 if (gfc_resolve_close (code->ext.close) == FAILURE)
9547 resolve_branch (code->ext.close->err, code);
9550 case EXEC_BACKSPACE:
9554 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
9557 resolve_branch (code->ext.filepos->err, code);
9561 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9564 resolve_branch (code->ext.inquire->err, code);
9568 gcc_assert (code->ext.inquire != NULL);
9569 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9572 resolve_branch (code->ext.inquire->err, code);
9576 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
9579 resolve_branch (code->ext.wait->err, code);
9580 resolve_branch (code->ext.wait->end, code);
9581 resolve_branch (code->ext.wait->eor, code);
9586 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
9589 resolve_branch (code->ext.dt->err, code);
9590 resolve_branch (code->ext.dt->end, code);
9591 resolve_branch (code->ext.dt->eor, code);
9595 resolve_transfer (code);
9598 case EXEC_DO_CONCURRENT:
9600 resolve_forall_iterators (code->ext.forall_iterator);
9602 if (code->expr1 != NULL
9603 && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
9604 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9605 "expression", &code->expr1->where);
9608 case EXEC_OMP_ATOMIC:
9609 case EXEC_OMP_BARRIER:
9610 case EXEC_OMP_CRITICAL:
9611 case EXEC_OMP_FLUSH:
9613 case EXEC_OMP_MASTER:
9614 case EXEC_OMP_ORDERED:
9615 case EXEC_OMP_SECTIONS:
9616 case EXEC_OMP_SINGLE:
9617 case EXEC_OMP_TASKWAIT:
9618 case EXEC_OMP_TASKYIELD:
9619 case EXEC_OMP_WORKSHARE:
9620 gfc_resolve_omp_directive (code, ns);
9623 case EXEC_OMP_PARALLEL:
9624 case EXEC_OMP_PARALLEL_DO:
9625 case EXEC_OMP_PARALLEL_SECTIONS:
9626 case EXEC_OMP_PARALLEL_WORKSHARE:
9628 omp_workshare_save = omp_workshare_flag;
9629 omp_workshare_flag = 0;
9630 gfc_resolve_omp_directive (code, ns);
9631 omp_workshare_flag = omp_workshare_save;
9635 gfc_internal_error ("resolve_code(): Bad statement code");
9639 cs_base = frame.prev;
9643 /* Resolve initial values and make sure they are compatible with
9647 resolve_values (gfc_symbol *sym)
9651 if (sym->value == NULL)
9654 if (sym->value->expr_type == EXPR_STRUCTURE)
9655 t= resolve_structure_cons (sym->value, 1);
9657 t = gfc_resolve_expr (sym->value);
9662 gfc_check_assign_symbol (sym, sym->value);
9666 /* Verify the binding labels for common blocks that are BIND(C). The label
9667 for a BIND(C) common block must be identical in all scoping units in which
9668 the common block is declared. Further, the binding label can not collide
9669 with any other global entity in the program. */
9672 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
9674 if (comm_block_tree->n.common->is_bind_c == 1)
9676 gfc_gsymbol *binding_label_gsym;
9677 gfc_gsymbol *comm_name_gsym;
9678 const char * bind_label = comm_block_tree->n.common->binding_label
9679 ? comm_block_tree->n.common->binding_label : "";
9681 /* See if a global symbol exists by the common block's name. It may
9682 be NULL if the common block is use-associated. */
9683 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
9684 comm_block_tree->n.common->name);
9685 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
9686 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9687 "with the global entity '%s' at %L",
9689 comm_block_tree->n.common->name,
9690 &(comm_block_tree->n.common->where),
9691 comm_name_gsym->name, &(comm_name_gsym->where));
9692 else if (comm_name_gsym != NULL
9693 && strcmp (comm_name_gsym->name,
9694 comm_block_tree->n.common->name) == 0)
9696 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9698 if (comm_name_gsym->binding_label == NULL)
9699 /* No binding label for common block stored yet; save this one. */
9700 comm_name_gsym->binding_label = bind_label;
9701 else if (strcmp (comm_name_gsym->binding_label, bind_label) != 0)
9703 /* Common block names match but binding labels do not. */
9704 gfc_error ("Binding label '%s' for common block '%s' at %L "
9705 "does not match the binding label '%s' for common "
9708 comm_block_tree->n.common->name,
9709 &(comm_block_tree->n.common->where),
9710 comm_name_gsym->binding_label,
9711 comm_name_gsym->name,
9712 &(comm_name_gsym->where));
9717 /* There is no binding label (NAME="") so we have nothing further to
9718 check and nothing to add as a global symbol for the label. */
9719 if (!comm_block_tree->n.common->binding_label)
9722 binding_label_gsym =
9723 gfc_find_gsymbol (gfc_gsym_root,
9724 comm_block_tree->n.common->binding_label);
9725 if (binding_label_gsym == NULL)
9727 /* Need to make a global symbol for the binding label to prevent
9728 it from colliding with another. */
9729 binding_label_gsym =
9730 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9731 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9732 binding_label_gsym->type = GSYM_COMMON;
9736 /* If comm_name_gsym is NULL, the name common block is use
9737 associated and the name could be colliding. */
9738 if (binding_label_gsym->type != GSYM_COMMON)
9739 gfc_error ("Binding label '%s' for common block '%s' at %L "
9740 "collides with the global entity '%s' at %L",
9741 comm_block_tree->n.common->binding_label,
9742 comm_block_tree->n.common->name,
9743 &(comm_block_tree->n.common->where),
9744 binding_label_gsym->name,
9745 &(binding_label_gsym->where));
9746 else if (comm_name_gsym != NULL
9747 && (strcmp (binding_label_gsym->name,
9748 comm_name_gsym->binding_label) != 0)
9749 && (strcmp (binding_label_gsym->sym_name,
9750 comm_name_gsym->name) != 0))
9751 gfc_error ("Binding label '%s' for common block '%s' at %L "
9752 "collides with global entity '%s' at %L",
9753 binding_label_gsym->name, binding_label_gsym->sym_name,
9754 &(comm_block_tree->n.common->where),
9755 comm_name_gsym->name, &(comm_name_gsym->where));
9763 /* Verify any BIND(C) derived types in the namespace so we can report errors
9764 for them once, rather than for each variable declared of that type. */
9767 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9769 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9770 && derived_sym->attr.is_bind_c == 1)
9771 verify_bind_c_derived_type (derived_sym);
9777 /* Verify that any binding labels used in a given namespace do not collide
9778 with the names or binding labels of any global symbols. */
9781 gfc_verify_binding_labels (gfc_symbol *sym)
9785 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9786 && sym->attr.flavor != FL_DERIVED && sym->binding_label)
9788 gfc_gsymbol *bind_c_sym;
9790 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9791 if (bind_c_sym != NULL
9792 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9794 if (sym->attr.if_source == IFSRC_DECL
9795 && (bind_c_sym->type != GSYM_SUBROUTINE
9796 && bind_c_sym->type != GSYM_FUNCTION)
9797 && ((sym->attr.contained == 1
9798 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9799 || (sym->attr.use_assoc == 1
9800 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9802 /* Make sure global procedures don't collide with anything. */
9803 gfc_error ("Binding label '%s' at %L collides with the global "
9804 "entity '%s' at %L", sym->binding_label,
9805 &(sym->declared_at), bind_c_sym->name,
9806 &(bind_c_sym->where));
9809 else if (sym->attr.contained == 0
9810 && (sym->attr.if_source == IFSRC_IFBODY
9811 && sym->attr.flavor == FL_PROCEDURE)
9812 && (bind_c_sym->sym_name != NULL
9813 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9815 /* Make sure procedures in interface bodies don't collide. */
9816 gfc_error ("Binding label '%s' in interface body at %L collides "
9817 "with the global entity '%s' at %L",
9819 &(sym->declared_at), bind_c_sym->name,
9820 &(bind_c_sym->where));
9823 else if (sym->attr.contained == 0
9824 && sym->attr.if_source == IFSRC_UNKNOWN)
9825 if ((sym->attr.use_assoc && bind_c_sym->mod_name
9826 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9827 || sym->attr.use_assoc == 0)
9829 gfc_error ("Binding label '%s' at %L collides with global "
9830 "entity '%s' at %L", sym->binding_label,
9831 &(sym->declared_at), bind_c_sym->name,
9832 &(bind_c_sym->where));
9837 /* Clear the binding label to prevent checking multiple times. */
9838 sym->binding_label = NULL;
9840 else if (bind_c_sym == NULL)
9842 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9843 bind_c_sym->where = sym->declared_at;
9844 bind_c_sym->sym_name = sym->name;
9846 if (sym->attr.use_assoc == 1)
9847 bind_c_sym->mod_name = sym->module;
9849 if (sym->ns->proc_name != NULL)
9850 bind_c_sym->mod_name = sym->ns->proc_name->name;
9852 if (sym->attr.contained == 0)
9854 if (sym->attr.subroutine)
9855 bind_c_sym->type = GSYM_SUBROUTINE;
9856 else if (sym->attr.function)
9857 bind_c_sym->type = GSYM_FUNCTION;
9865 /* Resolve an index expression. */
9868 resolve_index_expr (gfc_expr *e)
9870 if (gfc_resolve_expr (e) == FAILURE)
9873 if (gfc_simplify_expr (e, 0) == FAILURE)
9876 if (gfc_specification_expr (e) == FAILURE)
9883 /* Resolve a charlen structure. */
9886 resolve_charlen (gfc_charlen *cl)
9895 specification_expr = 1;
9897 if (resolve_index_expr (cl->length) == FAILURE)
9899 specification_expr = 0;
9903 /* "If the character length parameter value evaluates to a negative
9904 value, the length of character entities declared is zero." */
9905 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9907 if (gfc_option.warn_surprising)
9908 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9909 " the length has been set to zero",
9910 &cl->length->where, i);
9911 gfc_replace_expr (cl->length,
9912 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9915 /* Check that the character length is not too large. */
9916 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9917 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9918 && cl->length->ts.type == BT_INTEGER
9919 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9921 gfc_error ("String length at %L is too large", &cl->length->where);
9929 /* Test for non-constant shape arrays. */
9932 is_non_constant_shape_array (gfc_symbol *sym)
9938 not_constant = false;
9939 if (sym->as != NULL)
9941 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9942 has not been simplified; parameter array references. Do the
9943 simplification now. */
9944 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9946 e = sym->as->lower[i];
9947 if (e && (resolve_index_expr (e) == FAILURE
9948 || !gfc_is_constant_expr (e)))
9949 not_constant = true;
9950 e = sym->as->upper[i];
9951 if (e && (resolve_index_expr (e) == FAILURE
9952 || !gfc_is_constant_expr (e)))
9953 not_constant = true;
9956 return not_constant;
9959 /* Given a symbol and an initialization expression, add code to initialize
9960 the symbol to the function entry. */
9962 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9966 gfc_namespace *ns = sym->ns;
9968 /* Search for the function namespace if this is a contained
9969 function without an explicit result. */
9970 if (sym->attr.function && sym == sym->result
9971 && sym->name != sym->ns->proc_name->name)
9974 for (;ns; ns = ns->sibling)
9975 if (strcmp (ns->proc_name->name, sym->name) == 0)
9981 gfc_free_expr (init);
9985 /* Build an l-value expression for the result. */
9986 lval = gfc_lval_expr_from_sym (sym);
9988 /* Add the code at scope entry. */
9989 init_st = gfc_get_code ();
9990 init_st->next = ns->code;
9993 /* Assign the default initializer to the l-value. */
9994 init_st->loc = sym->declared_at;
9995 init_st->op = EXEC_INIT_ASSIGN;
9996 init_st->expr1 = lval;
9997 init_st->expr2 = init;
10000 /* Assign the default initializer to a derived type variable or result. */
10003 apply_default_init (gfc_symbol *sym)
10005 gfc_expr *init = NULL;
10007 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
10010 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
10011 init = gfc_default_initializer (&sym->ts);
10013 if (init == NULL && sym->ts.type != BT_CLASS)
10016 build_init_assign (sym, init);
10017 sym->attr.referenced = 1;
10020 /* Build an initializer for a local integer, real, complex, logical, or
10021 character variable, based on the command line flags finit-local-zero,
10022 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10023 null if the symbol should not have a default initialization. */
10025 build_default_init_expr (gfc_symbol *sym)
10028 gfc_expr *init_expr;
10031 /* These symbols should never have a default initialization. */
10032 if (sym->attr.allocatable
10033 || sym->attr.external
10035 || sym->attr.pointer
10036 || sym->attr.in_equivalence
10037 || sym->attr.in_common
10040 || sym->attr.cray_pointee
10041 || sym->attr.cray_pointer
10045 /* Now we'll try to build an initializer expression. */
10046 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
10047 &sym->declared_at);
10049 /* We will only initialize integers, reals, complex, logicals, and
10050 characters, and only if the corresponding command-line flags
10051 were set. Otherwise, we free init_expr and return null. */
10052 switch (sym->ts.type)
10055 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
10056 mpz_set_si (init_expr->value.integer,
10057 gfc_option.flag_init_integer_value);
10060 gfc_free_expr (init_expr);
10066 switch (gfc_option.flag_init_real)
10068 case GFC_INIT_REAL_SNAN:
10069 init_expr->is_snan = 1;
10070 /* Fall through. */
10071 case GFC_INIT_REAL_NAN:
10072 mpfr_set_nan (init_expr->value.real);
10075 case GFC_INIT_REAL_INF:
10076 mpfr_set_inf (init_expr->value.real, 1);
10079 case GFC_INIT_REAL_NEG_INF:
10080 mpfr_set_inf (init_expr->value.real, -1);
10083 case GFC_INIT_REAL_ZERO:
10084 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
10088 gfc_free_expr (init_expr);
10095 switch (gfc_option.flag_init_real)
10097 case GFC_INIT_REAL_SNAN:
10098 init_expr->is_snan = 1;
10099 /* Fall through. */
10100 case GFC_INIT_REAL_NAN:
10101 mpfr_set_nan (mpc_realref (init_expr->value.complex));
10102 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
10105 case GFC_INIT_REAL_INF:
10106 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
10107 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
10110 case GFC_INIT_REAL_NEG_INF:
10111 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
10112 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
10115 case GFC_INIT_REAL_ZERO:
10116 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
10120 gfc_free_expr (init_expr);
10127 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
10128 init_expr->value.logical = 0;
10129 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
10130 init_expr->value.logical = 1;
10133 gfc_free_expr (init_expr);
10139 /* For characters, the length must be constant in order to
10140 create a default initializer. */
10141 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
10142 && sym->ts.u.cl->length
10143 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
10145 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
10146 init_expr->value.character.length = char_len;
10147 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
10148 for (i = 0; i < char_len; i++)
10149 init_expr->value.character.string[i]
10150 = (unsigned char) gfc_option.flag_init_character_value;
10154 gfc_free_expr (init_expr);
10157 if (!init_expr && gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
10158 && sym->ts.u.cl->length)
10160 gfc_actual_arglist *arg;
10161 init_expr = gfc_get_expr ();
10162 init_expr->where = sym->declared_at;
10163 init_expr->ts = sym->ts;
10164 init_expr->expr_type = EXPR_FUNCTION;
10165 init_expr->value.function.isym =
10166 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT);
10167 init_expr->value.function.name = "repeat";
10168 arg = gfc_get_actual_arglist ();
10169 arg->expr = gfc_get_character_expr (sym->ts.kind, &sym->declared_at,
10171 arg->expr->value.character.string[0]
10172 = gfc_option.flag_init_character_value;
10173 arg->next = gfc_get_actual_arglist ();
10174 arg->next->expr = gfc_copy_expr (sym->ts.u.cl->length);
10175 init_expr->value.function.actual = arg;
10180 gfc_free_expr (init_expr);
10186 /* Add an initialization expression to a local variable. */
10188 apply_default_init_local (gfc_symbol *sym)
10190 gfc_expr *init = NULL;
10192 /* The symbol should be a variable or a function return value. */
10193 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
10194 || (sym->attr.function && sym->result != sym))
10197 /* Try to build the initializer expression. If we can't initialize
10198 this symbol, then init will be NULL. */
10199 init = build_default_init_expr (sym);
10203 /* For saved variables, we don't want to add an initializer at function
10204 entry, so we just add a static initializer. Note that automatic variables
10205 are stack allocated even with -fno-automatic. */
10206 if (sym->attr.save || sym->ns->save_all
10207 || (gfc_option.flag_max_stack_var_size == 0
10208 && (!sym->attr.dimension || !is_non_constant_shape_array (sym))))
10210 /* Don't clobber an existing initializer! */
10211 gcc_assert (sym->value == NULL);
10216 build_init_assign (sym, init);
10220 /* Resolution of common features of flavors variable and procedure. */
10223 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
10225 gfc_array_spec *as;
10227 /* Avoid double diagnostics for function result symbols. */
10228 if ((sym->result || sym->attr.result) && !sym->attr.dummy
10229 && (sym->ns != gfc_current_ns))
10232 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
10233 as = CLASS_DATA (sym)->as;
10237 /* Constraints on deferred shape variable. */
10238 if (as == NULL || as->type != AS_DEFERRED)
10240 bool pointer, allocatable, dimension;
10242 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
10244 pointer = CLASS_DATA (sym)->attr.class_pointer;
10245 allocatable = CLASS_DATA (sym)->attr.allocatable;
10246 dimension = CLASS_DATA (sym)->attr.dimension;
10250 pointer = sym->attr.pointer;
10251 allocatable = sym->attr.allocatable;
10252 dimension = sym->attr.dimension;
10259 gfc_error ("Allocatable array '%s' at %L must have "
10260 "a deferred shape", sym->name, &sym->declared_at);
10263 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
10264 "may not be ALLOCATABLE", sym->name,
10265 &sym->declared_at) == FAILURE)
10269 if (pointer && dimension)
10271 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
10272 sym->name, &sym->declared_at);
10278 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
10279 && sym->ts.type != BT_CLASS && !sym->assoc)
10281 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10282 sym->name, &sym->declared_at);
10287 /* Constraints on polymorphic variables. */
10288 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
10291 if (sym->attr.class_ok
10292 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
10294 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10295 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
10296 &sym->declared_at);
10301 /* Assume that use associated symbols were checked in the module ns.
10302 Class-variables that are associate-names are also something special
10303 and excepted from the test. */
10304 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
10306 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10307 "or pointer", sym->name, &sym->declared_at);
10316 /* Additional checks for symbols with flavor variable and derived
10317 type. To be called from resolve_fl_variable. */
10320 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
10322 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
10324 /* Check to see if a derived type is blocked from being host
10325 associated by the presence of another class I symbol in the same
10326 namespace. 14.6.1.3 of the standard and the discussion on
10327 comp.lang.fortran. */
10328 if (sym->ns != sym->ts.u.derived->ns
10329 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
10332 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
10333 if (s && s->attr.generic)
10334 s = gfc_find_dt_in_generic (s);
10335 if (s && s->attr.flavor != FL_DERIVED)
10337 gfc_error ("The type '%s' cannot be host associated at %L "
10338 "because it is blocked by an incompatible object "
10339 "of the same name declared at %L",
10340 sym->ts.u.derived->name, &sym->declared_at,
10346 /* 4th constraint in section 11.3: "If an object of a type for which
10347 component-initialization is specified (R429) appears in the
10348 specification-part of a module and does not have the ALLOCATABLE
10349 or POINTER attribute, the object shall have the SAVE attribute."
10351 The check for initializers is performed with
10352 gfc_has_default_initializer because gfc_default_initializer generates
10353 a hidden default for allocatable components. */
10354 if (!(sym->value || no_init_flag) && sym->ns->proc_name
10355 && sym->ns->proc_name->attr.flavor == FL_MODULE
10356 && !sym->ns->save_all && !sym->attr.save
10357 && !sym->attr.pointer && !sym->attr.allocatable
10358 && gfc_has_default_initializer (sym->ts.u.derived)
10359 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
10360 "module variable '%s' at %L, needed due to "
10361 "the default initialization", sym->name,
10362 &sym->declared_at) == FAILURE)
10365 /* Assign default initializer. */
10366 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
10367 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
10369 sym->value = gfc_default_initializer (&sym->ts);
10376 /* Resolve symbols with flavor variable. */
10379 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
10381 int no_init_flag, automatic_flag;
10383 const char *auto_save_msg;
10385 auto_save_msg = "Automatic object '%s' at %L cannot have the "
10388 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10391 /* Set this flag to check that variables are parameters of all entries.
10392 This check is effected by the call to gfc_resolve_expr through
10393 is_non_constant_shape_array. */
10394 specification_expr = 1;
10396 if (sym->ns->proc_name
10397 && (sym->ns->proc_name->attr.flavor == FL_MODULE
10398 || sym->ns->proc_name->attr.is_main_program)
10399 && !sym->attr.use_assoc
10400 && !sym->attr.allocatable
10401 && !sym->attr.pointer
10402 && is_non_constant_shape_array (sym))
10404 /* The shape of a main program or module array needs to be
10406 gfc_error ("The module or main program array '%s' at %L must "
10407 "have constant shape", sym->name, &sym->declared_at);
10408 specification_expr = 0;
10412 /* Constraints on deferred type parameter. */
10413 if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
10415 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10416 "requires either the pointer or allocatable attribute",
10417 sym->name, &sym->declared_at);
10421 if (sym->ts.type == BT_CHARACTER)
10423 /* Make sure that character string variables with assumed length are
10424 dummy arguments. */
10425 e = sym->ts.u.cl->length;
10426 if (e == NULL && !sym->attr.dummy && !sym->attr.result
10427 && !sym->ts.deferred)
10429 gfc_error ("Entity with assumed character length at %L must be a "
10430 "dummy argument or a PARAMETER", &sym->declared_at);
10434 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
10436 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10440 if (!gfc_is_constant_expr (e)
10441 && !(e->expr_type == EXPR_VARIABLE
10442 && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
10444 if (!sym->attr.use_assoc && sym->ns->proc_name
10445 && (sym->ns->proc_name->attr.flavor == FL_MODULE
10446 || sym->ns->proc_name->attr.is_main_program))
10448 gfc_error ("'%s' at %L must have constant character length "
10449 "in this context", sym->name, &sym->declared_at);
10452 if (sym->attr.in_common)
10454 gfc_error ("COMMON variable '%s' at %L must have constant "
10455 "character length", sym->name, &sym->declared_at);
10461 if (sym->value == NULL && sym->attr.referenced)
10462 apply_default_init_local (sym); /* Try to apply a default initialization. */
10464 /* Determine if the symbol may not have an initializer. */
10465 no_init_flag = automatic_flag = 0;
10466 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
10467 || sym->attr.intrinsic || sym->attr.result)
10469 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
10470 && is_non_constant_shape_array (sym))
10472 no_init_flag = automatic_flag = 1;
10474 /* Also, they must not have the SAVE attribute.
10475 SAVE_IMPLICIT is checked below. */
10476 if (sym->as && sym->attr.codimension)
10478 int corank = sym->as->corank;
10479 sym->as->corank = 0;
10480 no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
10481 sym->as->corank = corank;
10483 if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
10485 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10490 /* Ensure that any initializer is simplified. */
10492 gfc_simplify_expr (sym->value, 1);
10494 /* Reject illegal initializers. */
10495 if (!sym->mark && sym->value)
10497 if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
10498 && CLASS_DATA (sym)->attr.allocatable))
10499 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10500 sym->name, &sym->declared_at);
10501 else if (sym->attr.external)
10502 gfc_error ("External '%s' at %L cannot have an initializer",
10503 sym->name, &sym->declared_at);
10504 else if (sym->attr.dummy
10505 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
10506 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10507 sym->name, &sym->declared_at);
10508 else if (sym->attr.intrinsic)
10509 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10510 sym->name, &sym->declared_at);
10511 else if (sym->attr.result)
10512 gfc_error ("Function result '%s' at %L cannot have an initializer",
10513 sym->name, &sym->declared_at);
10514 else if (automatic_flag)
10515 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10516 sym->name, &sym->declared_at);
10518 goto no_init_error;
10523 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
10524 return resolve_fl_variable_derived (sym, no_init_flag);
10530 /* Resolve a procedure. */
10533 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
10535 gfc_formal_arglist *arg;
10537 if (sym->attr.function
10538 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10541 if (sym->ts.type == BT_CHARACTER)
10543 gfc_charlen *cl = sym->ts.u.cl;
10545 if (cl && cl->length && gfc_is_constant_expr (cl->length)
10546 && resolve_charlen (cl) == FAILURE)
10549 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
10550 && sym->attr.proc == PROC_ST_FUNCTION)
10552 gfc_error ("Character-valued statement function '%s' at %L must "
10553 "have constant length", sym->name, &sym->declared_at);
10558 /* Ensure that derived type for are not of a private type. Internal
10559 module procedures are excluded by 2.2.3.3 - i.e., they are not
10560 externally accessible and can access all the objects accessible in
10562 if (!(sym->ns->parent
10563 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
10564 && gfc_check_symbol_access (sym))
10566 gfc_interface *iface;
10568 for (arg = sym->formal; arg; arg = arg->next)
10571 && arg->sym->ts.type == BT_DERIVED
10572 && !arg->sym->ts.u.derived->attr.use_assoc
10573 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10574 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
10575 "PRIVATE type and cannot be a dummy argument"
10576 " of '%s', which is PUBLIC at %L",
10577 arg->sym->name, sym->name, &sym->declared_at)
10580 /* Stop this message from recurring. */
10581 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10586 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10587 PRIVATE to the containing module. */
10588 for (iface = sym->generic; iface; iface = iface->next)
10590 for (arg = iface->sym->formal; arg; arg = arg->next)
10593 && arg->sym->ts.type == BT_DERIVED
10594 && !arg->sym->ts.u.derived->attr.use_assoc
10595 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10596 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10597 "'%s' in PUBLIC interface '%s' at %L "
10598 "takes dummy arguments of '%s' which is "
10599 "PRIVATE", iface->sym->name, sym->name,
10600 &iface->sym->declared_at,
10601 gfc_typename (&arg->sym->ts)) == FAILURE)
10603 /* Stop this message from recurring. */
10604 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10610 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10611 PRIVATE to the containing module. */
10612 for (iface = sym->generic; iface; iface = iface->next)
10614 for (arg = iface->sym->formal; arg; arg = arg->next)
10617 && arg->sym->ts.type == BT_DERIVED
10618 && !arg->sym->ts.u.derived->attr.use_assoc
10619 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10620 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10621 "'%s' in PUBLIC interface '%s' at %L "
10622 "takes dummy arguments of '%s' which is "
10623 "PRIVATE", iface->sym->name, sym->name,
10624 &iface->sym->declared_at,
10625 gfc_typename (&arg->sym->ts)) == FAILURE)
10627 /* Stop this message from recurring. */
10628 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10635 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10636 && !sym->attr.proc_pointer)
10638 gfc_error ("Function '%s' at %L cannot have an initializer",
10639 sym->name, &sym->declared_at);
10643 /* An external symbol may not have an initializer because it is taken to be
10644 a procedure. Exception: Procedure Pointers. */
10645 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10647 gfc_error ("External object '%s' at %L may not have an initializer",
10648 sym->name, &sym->declared_at);
10652 /* An elemental function is required to return a scalar 12.7.1 */
10653 if (sym->attr.elemental && sym->attr.function && sym->as)
10655 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10656 "result", sym->name, &sym->declared_at);
10657 /* Reset so that the error only occurs once. */
10658 sym->attr.elemental = 0;
10662 if (sym->attr.proc == PROC_ST_FUNCTION
10663 && (sym->attr.allocatable || sym->attr.pointer))
10665 gfc_error ("Statement function '%s' at %L may not have pointer or "
10666 "allocatable attribute", sym->name, &sym->declared_at);
10670 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10671 char-len-param shall not be array-valued, pointer-valued, recursive
10672 or pure. ....snip... A character value of * may only be used in the
10673 following ways: (i) Dummy arg of procedure - dummy associates with
10674 actual length; (ii) To declare a named constant; or (iii) External
10675 function - but length must be declared in calling scoping unit. */
10676 if (sym->attr.function
10677 && sym->ts.type == BT_CHARACTER
10678 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10680 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10681 || (sym->attr.recursive) || (sym->attr.pure))
10683 if (sym->as && sym->as->rank)
10684 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10685 "array-valued", sym->name, &sym->declared_at);
10687 if (sym->attr.pointer)
10688 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10689 "pointer-valued", sym->name, &sym->declared_at);
10691 if (sym->attr.pure)
10692 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10693 "pure", sym->name, &sym->declared_at);
10695 if (sym->attr.recursive)
10696 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10697 "recursive", sym->name, &sym->declared_at);
10702 /* Appendix B.2 of the standard. Contained functions give an
10703 error anyway. Fixed-form is likely to be F77/legacy. Deferred
10704 character length is an F2003 feature. */
10705 if (!sym->attr.contained
10706 && gfc_current_form != FORM_FIXED
10707 && !sym->ts.deferred)
10708 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10709 "CHARACTER(*) function '%s' at %L",
10710 sym->name, &sym->declared_at);
10713 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10715 gfc_formal_arglist *curr_arg;
10716 int has_non_interop_arg = 0;
10718 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10719 sym->common_block) == FAILURE)
10721 /* Clear these to prevent looking at them again if there was an
10723 sym->attr.is_bind_c = 0;
10724 sym->attr.is_c_interop = 0;
10725 sym->ts.is_c_interop = 0;
10729 /* So far, no errors have been found. */
10730 sym->attr.is_c_interop = 1;
10731 sym->ts.is_c_interop = 1;
10734 curr_arg = sym->formal;
10735 while (curr_arg != NULL)
10737 /* Skip implicitly typed dummy args here. */
10738 if (curr_arg->sym->attr.implicit_type == 0)
10739 if (gfc_verify_c_interop_param (curr_arg->sym) == FAILURE)
10740 /* If something is found to fail, record the fact so we
10741 can mark the symbol for the procedure as not being
10742 BIND(C) to try and prevent multiple errors being
10744 has_non_interop_arg = 1;
10746 curr_arg = curr_arg->next;
10749 /* See if any of the arguments were not interoperable and if so, clear
10750 the procedure symbol to prevent duplicate error messages. */
10751 if (has_non_interop_arg != 0)
10753 sym->attr.is_c_interop = 0;
10754 sym->ts.is_c_interop = 0;
10755 sym->attr.is_bind_c = 0;
10759 if (!sym->attr.proc_pointer)
10761 if (sym->attr.save == SAVE_EXPLICIT)
10763 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10764 "in '%s' at %L", sym->name, &sym->declared_at);
10767 if (sym->attr.intent)
10769 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10770 "in '%s' at %L", sym->name, &sym->declared_at);
10773 if (sym->attr.subroutine && sym->attr.result)
10775 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10776 "in '%s' at %L", sym->name, &sym->declared_at);
10779 if (sym->attr.external && sym->attr.function
10780 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10781 || sym->attr.contained))
10783 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10784 "in '%s' at %L", sym->name, &sym->declared_at);
10787 if (strcmp ("ppr@", sym->name) == 0)
10789 gfc_error ("Procedure pointer result '%s' at %L "
10790 "is missing the pointer attribute",
10791 sym->ns->proc_name->name, &sym->declared_at);
10800 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10801 been defined and we now know their defined arguments, check that they fulfill
10802 the requirements of the standard for procedures used as finalizers. */
10805 gfc_resolve_finalizers (gfc_symbol* derived)
10807 gfc_finalizer* list;
10808 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10809 gfc_try result = SUCCESS;
10810 bool seen_scalar = false;
10812 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10815 /* Walk over the list of finalizer-procedures, check them, and if any one
10816 does not fit in with the standard's definition, print an error and remove
10817 it from the list. */
10818 prev_link = &derived->f2k_derived->finalizers;
10819 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10825 /* Skip this finalizer if we already resolved it. */
10826 if (list->proc_tree)
10828 prev_link = &(list->next);
10832 /* Check this exists and is a SUBROUTINE. */
10833 if (!list->proc_sym->attr.subroutine)
10835 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10836 list->proc_sym->name, &list->where);
10840 /* We should have exactly one argument. */
10841 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10843 gfc_error ("FINAL procedure at %L must have exactly one argument",
10847 arg = list->proc_sym->formal->sym;
10849 /* This argument must be of our type. */
10850 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10852 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10853 &arg->declared_at, derived->name);
10857 /* It must neither be a pointer nor allocatable nor optional. */
10858 if (arg->attr.pointer)
10860 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10861 &arg->declared_at);
10864 if (arg->attr.allocatable)
10866 gfc_error ("Argument of FINAL procedure at %L must not be"
10867 " ALLOCATABLE", &arg->declared_at);
10870 if (arg->attr.optional)
10872 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10873 &arg->declared_at);
10877 /* It must not be INTENT(OUT). */
10878 if (arg->attr.intent == INTENT_OUT)
10880 gfc_error ("Argument of FINAL procedure at %L must not be"
10881 " INTENT(OUT)", &arg->declared_at);
10885 /* Warn if the procedure is non-scalar and not assumed shape. */
10886 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10887 && arg->as->type != AS_ASSUMED_SHAPE)
10888 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10889 " shape argument", &arg->declared_at);
10891 /* Check that it does not match in kind and rank with a FINAL procedure
10892 defined earlier. To really loop over the *earlier* declarations,
10893 we need to walk the tail of the list as new ones were pushed at the
10895 /* TODO: Handle kind parameters once they are implemented. */
10896 my_rank = (arg->as ? arg->as->rank : 0);
10897 for (i = list->next; i; i = i->next)
10899 /* Argument list might be empty; that is an error signalled earlier,
10900 but we nevertheless continued resolving. */
10901 if (i->proc_sym->formal)
10903 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10904 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10905 if (i_rank == my_rank)
10907 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10908 " rank (%d) as '%s'",
10909 list->proc_sym->name, &list->where, my_rank,
10910 i->proc_sym->name);
10916 /* Is this the/a scalar finalizer procedure? */
10917 if (!arg->as || arg->as->rank == 0)
10918 seen_scalar = true;
10920 /* Find the symtree for this procedure. */
10921 gcc_assert (!list->proc_tree);
10922 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10924 prev_link = &list->next;
10927 /* Remove wrong nodes immediately from the list so we don't risk any
10928 troubles in the future when they might fail later expectations. */
10932 *prev_link = list->next;
10933 gfc_free_finalizer (i);
10936 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10937 were nodes in the list, must have been for arrays. It is surely a good
10938 idea to have a scalar version there if there's something to finalize. */
10939 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10940 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10941 " defined at %L, suggest also scalar one",
10942 derived->name, &derived->declared_at);
10944 /* TODO: Remove this error when finalization is finished. */
10945 gfc_error ("Finalization at %L is not yet implemented",
10946 &derived->declared_at);
10952 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10955 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10956 const char* generic_name, locus where)
10961 gcc_assert (t1->specific && t2->specific);
10962 gcc_assert (!t1->specific->is_generic);
10963 gcc_assert (!t2->specific->is_generic);
10964 gcc_assert (t1->is_operator == t2->is_operator);
10966 sym1 = t1->specific->u.specific->n.sym;
10967 sym2 = t2->specific->u.specific->n.sym;
10972 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10973 if (sym1->attr.subroutine != sym2->attr.subroutine
10974 || sym1->attr.function != sym2->attr.function)
10976 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10977 " GENERIC '%s' at %L",
10978 sym1->name, sym2->name, generic_name, &where);
10982 /* Compare the interfaces. */
10983 if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
10986 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10987 sym1->name, sym2->name, generic_name, &where);
10995 /* Worker function for resolving a generic procedure binding; this is used to
10996 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10998 The difference between those cases is finding possible inherited bindings
10999 that are overridden, as one has to look for them in tb_sym_root,
11000 tb_uop_root or tb_op, respectively. Thus the caller must already find
11001 the super-type and set p->overridden correctly. */
11004 resolve_tb_generic_targets (gfc_symbol* super_type,
11005 gfc_typebound_proc* p, const char* name)
11007 gfc_tbp_generic* target;
11008 gfc_symtree* first_target;
11009 gfc_symtree* inherited;
11011 gcc_assert (p && p->is_generic);
11013 /* Try to find the specific bindings for the symtrees in our target-list. */
11014 gcc_assert (p->u.generic);
11015 for (target = p->u.generic; target; target = target->next)
11016 if (!target->specific)
11018 gfc_typebound_proc* overridden_tbp;
11019 gfc_tbp_generic* g;
11020 const char* target_name;
11022 target_name = target->specific_st->name;
11024 /* Defined for this type directly. */
11025 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
11027 target->specific = target->specific_st->n.tb;
11028 goto specific_found;
11031 /* Look for an inherited specific binding. */
11034 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
11039 gcc_assert (inherited->n.tb);
11040 target->specific = inherited->n.tb;
11041 goto specific_found;
11045 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11046 " at %L", target_name, name, &p->where);
11049 /* Once we've found the specific binding, check it is not ambiguous with
11050 other specifics already found or inherited for the same GENERIC. */
11052 gcc_assert (target->specific);
11054 /* This must really be a specific binding! */
11055 if (target->specific->is_generic)
11057 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11058 " '%s' is GENERIC, too", name, &p->where, target_name);
11062 /* Check those already resolved on this type directly. */
11063 for (g = p->u.generic; g; g = g->next)
11064 if (g != target && g->specific
11065 && check_generic_tbp_ambiguity (target, g, name, p->where)
11069 /* Check for ambiguity with inherited specific targets. */
11070 for (overridden_tbp = p->overridden; overridden_tbp;
11071 overridden_tbp = overridden_tbp->overridden)
11072 if (overridden_tbp->is_generic)
11074 for (g = overridden_tbp->u.generic; g; g = g->next)
11076 gcc_assert (g->specific);
11077 if (check_generic_tbp_ambiguity (target, g,
11078 name, p->where) == FAILURE)
11084 /* If we attempt to "overwrite" a specific binding, this is an error. */
11085 if (p->overridden && !p->overridden->is_generic)
11087 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11088 " the same name", name, &p->where);
11092 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11093 all must have the same attributes here. */
11094 first_target = p->u.generic->specific->u.specific;
11095 gcc_assert (first_target);
11096 p->subroutine = first_target->n.sym->attr.subroutine;
11097 p->function = first_target->n.sym->attr.function;
11103 /* Resolve a GENERIC procedure binding for a derived type. */
11106 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
11108 gfc_symbol* super_type;
11110 /* Find the overridden binding if any. */
11111 st->n.tb->overridden = NULL;
11112 super_type = gfc_get_derived_super_type (derived);
11115 gfc_symtree* overridden;
11116 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
11119 if (overridden && overridden->n.tb)
11120 st->n.tb->overridden = overridden->n.tb;
11123 /* Resolve using worker function. */
11124 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
11128 /* Retrieve the target-procedure of an operator binding and do some checks in
11129 common for intrinsic and user-defined type-bound operators. */
11132 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
11134 gfc_symbol* target_proc;
11136 gcc_assert (target->specific && !target->specific->is_generic);
11137 target_proc = target->specific->u.specific->n.sym;
11138 gcc_assert (target_proc);
11140 /* All operator bindings must have a passed-object dummy argument. */
11141 if (target->specific->nopass)
11143 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
11147 return target_proc;
11151 /* Resolve a type-bound intrinsic operator. */
11154 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
11155 gfc_typebound_proc* p)
11157 gfc_symbol* super_type;
11158 gfc_tbp_generic* target;
11160 /* If there's already an error here, do nothing (but don't fail again). */
11164 /* Operators should always be GENERIC bindings. */
11165 gcc_assert (p->is_generic);
11167 /* Look for an overridden binding. */
11168 super_type = gfc_get_derived_super_type (derived);
11169 if (super_type && super_type->f2k_derived)
11170 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
11173 p->overridden = NULL;
11175 /* Resolve general GENERIC properties using worker function. */
11176 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
11179 /* Check the targets to be procedures of correct interface. */
11180 for (target = p->u.generic; target; target = target->next)
11182 gfc_symbol* target_proc;
11184 target_proc = get_checked_tb_operator_target (target, p->where);
11188 if (!gfc_check_operator_interface (target_proc, op, p->where))
11200 /* Resolve a type-bound user operator (tree-walker callback). */
11202 static gfc_symbol* resolve_bindings_derived;
11203 static gfc_try resolve_bindings_result;
11205 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
11208 resolve_typebound_user_op (gfc_symtree* stree)
11210 gfc_symbol* super_type;
11211 gfc_tbp_generic* target;
11213 gcc_assert (stree && stree->n.tb);
11215 if (stree->n.tb->error)
11218 /* Operators should always be GENERIC bindings. */
11219 gcc_assert (stree->n.tb->is_generic);
11221 /* Find overridden procedure, if any. */
11222 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11223 if (super_type && super_type->f2k_derived)
11225 gfc_symtree* overridden;
11226 overridden = gfc_find_typebound_user_op (super_type, NULL,
11227 stree->name, true, NULL);
11229 if (overridden && overridden->n.tb)
11230 stree->n.tb->overridden = overridden->n.tb;
11233 stree->n.tb->overridden = NULL;
11235 /* Resolve basically using worker function. */
11236 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
11240 /* Check the targets to be functions of correct interface. */
11241 for (target = stree->n.tb->u.generic; target; target = target->next)
11243 gfc_symbol* target_proc;
11245 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
11249 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
11256 resolve_bindings_result = FAILURE;
11257 stree->n.tb->error = 1;
11261 /* Resolve the type-bound procedures for a derived type. */
11264 resolve_typebound_procedure (gfc_symtree* stree)
11268 gfc_symbol* me_arg;
11269 gfc_symbol* super_type;
11270 gfc_component* comp;
11272 gcc_assert (stree);
11274 /* Undefined specific symbol from GENERIC target definition. */
11278 if (stree->n.tb->error)
11281 /* If this is a GENERIC binding, use that routine. */
11282 if (stree->n.tb->is_generic)
11284 if (resolve_typebound_generic (resolve_bindings_derived, stree)
11290 /* Get the target-procedure to check it. */
11291 gcc_assert (!stree->n.tb->is_generic);
11292 gcc_assert (stree->n.tb->u.specific);
11293 proc = stree->n.tb->u.specific->n.sym;
11294 where = stree->n.tb->where;
11296 /* Default access should already be resolved from the parser. */
11297 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
11299 /* It should be a module procedure or an external procedure with explicit
11300 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
11301 if ((!proc->attr.subroutine && !proc->attr.function)
11302 || (proc->attr.proc != PROC_MODULE
11303 && proc->attr.if_source != IFSRC_IFBODY)
11304 || (proc->attr.abstract && !stree->n.tb->deferred))
11306 gfc_error ("'%s' must be a module procedure or an external procedure with"
11307 " an explicit interface at %L", proc->name, &where);
11310 stree->n.tb->subroutine = proc->attr.subroutine;
11311 stree->n.tb->function = proc->attr.function;
11313 /* Find the super-type of the current derived type. We could do this once and
11314 store in a global if speed is needed, but as long as not I believe this is
11315 more readable and clearer. */
11316 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11318 /* If PASS, resolve and check arguments if not already resolved / loaded
11319 from a .mod file. */
11320 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
11322 if (stree->n.tb->pass_arg)
11324 gfc_formal_arglist* i;
11326 /* If an explicit passing argument name is given, walk the arg-list
11327 and look for it. */
11330 stree->n.tb->pass_arg_num = 1;
11331 for (i = proc->formal; i; i = i->next)
11333 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
11338 ++stree->n.tb->pass_arg_num;
11343 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11345 proc->name, stree->n.tb->pass_arg, &where,
11346 stree->n.tb->pass_arg);
11352 /* Otherwise, take the first one; there should in fact be at least
11354 stree->n.tb->pass_arg_num = 1;
11357 gfc_error ("Procedure '%s' with PASS at %L must have at"
11358 " least one argument", proc->name, &where);
11361 me_arg = proc->formal->sym;
11364 /* Now check that the argument-type matches and the passed-object
11365 dummy argument is generally fine. */
11367 gcc_assert (me_arg);
11369 if (me_arg->ts.type != BT_CLASS)
11371 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11372 " at %L", proc->name, &where);
11376 if (CLASS_DATA (me_arg)->ts.u.derived
11377 != resolve_bindings_derived)
11379 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11380 " the derived-type '%s'", me_arg->name, proc->name,
11381 me_arg->name, &where, resolve_bindings_derived->name);
11385 gcc_assert (me_arg->ts.type == BT_CLASS);
11386 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
11388 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11389 " scalar", proc->name, &where);
11392 if (CLASS_DATA (me_arg)->attr.allocatable)
11394 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11395 " be ALLOCATABLE", proc->name, &where);
11398 if (CLASS_DATA (me_arg)->attr.class_pointer)
11400 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11401 " be POINTER", proc->name, &where);
11406 /* If we are extending some type, check that we don't override a procedure
11407 flagged NON_OVERRIDABLE. */
11408 stree->n.tb->overridden = NULL;
11411 gfc_symtree* overridden;
11412 overridden = gfc_find_typebound_proc (super_type, NULL,
11413 stree->name, true, NULL);
11417 if (overridden->n.tb)
11418 stree->n.tb->overridden = overridden->n.tb;
11420 if (gfc_check_typebound_override (stree, overridden) == FAILURE)
11425 /* See if there's a name collision with a component directly in this type. */
11426 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11427 if (!strcmp (comp->name, stree->name))
11429 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11431 stree->name, &where, resolve_bindings_derived->name);
11435 /* Try to find a name collision with an inherited component. */
11436 if (super_type && gfc_find_component (super_type, stree->name, true, true))
11438 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11439 " component of '%s'",
11440 stree->name, &where, resolve_bindings_derived->name);
11444 stree->n.tb->error = 0;
11448 resolve_bindings_result = FAILURE;
11449 stree->n.tb->error = 1;
11454 resolve_typebound_procedures (gfc_symbol* derived)
11457 gfc_symbol* super_type;
11459 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11462 super_type = gfc_get_derived_super_type (derived);
11464 resolve_typebound_procedures (super_type);
11466 resolve_bindings_derived = derived;
11467 resolve_bindings_result = SUCCESS;
11469 /* Make sure the vtab has been generated. */
11470 gfc_find_derived_vtab (derived);
11472 if (derived->f2k_derived->tb_sym_root)
11473 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11474 &resolve_typebound_procedure);
11476 if (derived->f2k_derived->tb_uop_root)
11477 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11478 &resolve_typebound_user_op);
11480 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11482 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11483 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11485 resolve_bindings_result = FAILURE;
11488 return resolve_bindings_result;
11492 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11493 to give all identical derived types the same backend_decl. */
11495 add_dt_to_dt_list (gfc_symbol *derived)
11497 gfc_dt_list *dt_list;
11499 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11500 if (derived == dt_list->derived)
11503 dt_list = gfc_get_dt_list ();
11504 dt_list->next = gfc_derived_types;
11505 dt_list->derived = derived;
11506 gfc_derived_types = dt_list;
11510 /* Ensure that a derived-type is really not abstract, meaning that every
11511 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11514 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11519 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11521 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11524 if (st->n.tb && st->n.tb->deferred)
11526 gfc_symtree* overriding;
11527 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11530 gcc_assert (overriding->n.tb);
11531 if (overriding->n.tb->deferred)
11533 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11534 " '%s' is DEFERRED and not overridden",
11535 sub->name, &sub->declared_at, st->name);
11544 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11546 /* The algorithm used here is to recursively travel up the ancestry of sub
11547 and for each ancestor-type, check all bindings. If any of them is
11548 DEFERRED, look it up starting from sub and see if the found (overriding)
11549 binding is not DEFERRED.
11550 This is not the most efficient way to do this, but it should be ok and is
11551 clearer than something sophisticated. */
11553 gcc_assert (ancestor && !sub->attr.abstract);
11555 if (!ancestor->attr.abstract)
11558 /* Walk bindings of this ancestor. */
11559 if (ancestor->f2k_derived)
11562 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11567 /* Find next ancestor type and recurse on it. */
11568 ancestor = gfc_get_derived_super_type (ancestor);
11570 return ensure_not_abstract (sub, ancestor);
11576 /* Resolve the components of a derived type. This does not have to wait until
11577 resolution stage, but can be done as soon as the dt declaration has been
11581 resolve_fl_derived0 (gfc_symbol *sym)
11583 gfc_symbol* super_type;
11586 super_type = gfc_get_derived_super_type (sym);
11589 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11591 gfc_error ("As extending type '%s' at %L has a coarray component, "
11592 "parent type '%s' shall also have one", sym->name,
11593 &sym->declared_at, super_type->name);
11597 /* Ensure the extended type gets resolved before we do. */
11598 if (super_type && resolve_fl_derived0 (super_type) == FAILURE)
11601 /* An ABSTRACT type must be extensible. */
11602 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11604 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11605 sym->name, &sym->declared_at);
11609 c = (sym->attr.is_class) ? sym->components->ts.u.derived->components
11612 for ( ; c != NULL; c = c->next)
11614 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
11615 if (c->ts.type == BT_CHARACTER && c->ts.deferred)
11617 gfc_error ("Deferred-length character component '%s' at %L is not "
11618 "yet supported", c->name, &c->loc);
11623 if ((!sym->attr.is_class || c != sym->components)
11624 && c->attr.codimension
11625 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11627 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11628 "deferred shape", c->name, &c->loc);
11633 if (c->attr.codimension && c->ts.type == BT_DERIVED
11634 && c->ts.u.derived->ts.is_iso_c)
11636 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11637 "shall not be a coarray", c->name, &c->loc);
11642 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11643 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11644 || c->attr.allocatable))
11646 gfc_error ("Component '%s' at %L with coarray component "
11647 "shall be a nonpointer, nonallocatable scalar",
11653 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11655 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11656 "is not an array pointer", c->name, &c->loc);
11660 if (c->attr.proc_pointer && c->ts.interface)
11662 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11663 gfc_error ("Interface '%s', used by procedure pointer component "
11664 "'%s' at %L, is declared in a later PROCEDURE statement",
11665 c->ts.interface->name, c->name, &c->loc);
11667 /* Get the attributes from the interface (now resolved). */
11668 if (c->ts.interface->attr.if_source
11669 || c->ts.interface->attr.intrinsic)
11671 gfc_symbol *ifc = c->ts.interface;
11673 if (ifc->formal && !ifc->formal_ns)
11674 resolve_symbol (ifc);
11676 if (ifc->attr.intrinsic)
11677 resolve_intrinsic (ifc, &ifc->declared_at);
11681 c->ts = ifc->result->ts;
11682 c->attr.allocatable = ifc->result->attr.allocatable;
11683 c->attr.pointer = ifc->result->attr.pointer;
11684 c->attr.dimension = ifc->result->attr.dimension;
11685 c->as = gfc_copy_array_spec (ifc->result->as);
11690 c->attr.allocatable = ifc->attr.allocatable;
11691 c->attr.pointer = ifc->attr.pointer;
11692 c->attr.dimension = ifc->attr.dimension;
11693 c->as = gfc_copy_array_spec (ifc->as);
11695 c->ts.interface = ifc;
11696 c->attr.function = ifc->attr.function;
11697 c->attr.subroutine = ifc->attr.subroutine;
11698 gfc_copy_formal_args_ppc (c, ifc);
11700 c->attr.pure = ifc->attr.pure;
11701 c->attr.elemental = ifc->attr.elemental;
11702 c->attr.recursive = ifc->attr.recursive;
11703 c->attr.always_explicit = ifc->attr.always_explicit;
11704 c->attr.ext_attr |= ifc->attr.ext_attr;
11705 /* Replace symbols in array spec. */
11709 for (i = 0; i < c->as->rank; i++)
11711 gfc_expr_replace_comp (c->as->lower[i], c);
11712 gfc_expr_replace_comp (c->as->upper[i], c);
11715 /* Copy char length. */
11716 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11718 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11719 gfc_expr_replace_comp (cl->length, c);
11720 if (cl->length && !cl->resolved
11721 && gfc_resolve_expr (cl->length) == FAILURE)
11726 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11728 gfc_error ("Interface '%s' of procedure pointer component "
11729 "'%s' at %L must be explicit", c->ts.interface->name,
11734 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11736 /* Since PPCs are not implicitly typed, a PPC without an explicit
11737 interface must be a subroutine. */
11738 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11741 /* Procedure pointer components: Check PASS arg. */
11742 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11743 && !sym->attr.vtype)
11745 gfc_symbol* me_arg;
11747 if (c->tb->pass_arg)
11749 gfc_formal_arglist* i;
11751 /* If an explicit passing argument name is given, walk the arg-list
11752 and look for it. */
11755 c->tb->pass_arg_num = 1;
11756 for (i = c->formal; i; i = i->next)
11758 if (!strcmp (i->sym->name, c->tb->pass_arg))
11763 c->tb->pass_arg_num++;
11768 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11769 "at %L has no argument '%s'", c->name,
11770 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11777 /* Otherwise, take the first one; there should in fact be at least
11779 c->tb->pass_arg_num = 1;
11782 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11783 "must have at least one argument",
11788 me_arg = c->formal->sym;
11791 /* Now check that the argument-type matches. */
11792 gcc_assert (me_arg);
11793 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11794 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11795 || (me_arg->ts.type == BT_CLASS
11796 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11798 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11799 " the derived type '%s'", me_arg->name, c->name,
11800 me_arg->name, &c->loc, sym->name);
11805 /* Check for C453. */
11806 if (me_arg->attr.dimension)
11808 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11809 "must be scalar", me_arg->name, c->name, me_arg->name,
11815 if (me_arg->attr.pointer)
11817 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11818 "may not have the POINTER attribute", me_arg->name,
11819 c->name, me_arg->name, &c->loc);
11824 if (me_arg->attr.allocatable)
11826 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11827 "may not be ALLOCATABLE", me_arg->name, c->name,
11828 me_arg->name, &c->loc);
11833 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11834 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11835 " at %L", c->name, &c->loc);
11839 /* Check type-spec if this is not the parent-type component. */
11840 if (((sym->attr.is_class
11841 && (!sym->components->ts.u.derived->attr.extension
11842 || c != sym->components->ts.u.derived->components))
11843 || (!sym->attr.is_class
11844 && (!sym->attr.extension || c != sym->components)))
11845 && !sym->attr.vtype
11846 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11849 /* If this type is an extension, set the accessibility of the parent
11852 && ((sym->attr.is_class
11853 && c == sym->components->ts.u.derived->components)
11854 || (!sym->attr.is_class && c == sym->components))
11855 && strcmp (super_type->name, c->name) == 0)
11856 c->attr.access = super_type->attr.access;
11858 /* If this type is an extension, see if this component has the same name
11859 as an inherited type-bound procedure. */
11860 if (super_type && !sym->attr.is_class
11861 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11863 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11864 " inherited type-bound procedure",
11865 c->name, sym->name, &c->loc);
11869 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
11870 && !c->ts.deferred)
11872 if (c->ts.u.cl->length == NULL
11873 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11874 || !gfc_is_constant_expr (c->ts.u.cl->length))
11876 gfc_error ("Character length of component '%s' needs to "
11877 "be a constant specification expression at %L",
11879 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11884 if (c->ts.type == BT_CHARACTER && c->ts.deferred
11885 && !c->attr.pointer && !c->attr.allocatable)
11887 gfc_error ("Character component '%s' of '%s' at %L with deferred "
11888 "length must be a POINTER or ALLOCATABLE",
11889 c->name, sym->name, &c->loc);
11893 if (c->ts.type == BT_DERIVED
11894 && sym->component_access != ACCESS_PRIVATE
11895 && gfc_check_symbol_access (sym)
11896 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11897 && !c->ts.u.derived->attr.use_assoc
11898 && !gfc_check_symbol_access (c->ts.u.derived)
11899 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11900 "is a PRIVATE type and cannot be a component of "
11901 "'%s', which is PUBLIC at %L", c->name,
11902 sym->name, &sym->declared_at) == FAILURE)
11905 if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
11907 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11908 "type %s", c->name, &c->loc, sym->name);
11912 if (sym->attr.sequence)
11914 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11916 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11917 "not have the SEQUENCE attribute",
11918 c->ts.u.derived->name, &sym->declared_at);
11923 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
11924 c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
11925 else if (c->ts.type == BT_CLASS && c->attr.class_ok
11926 && CLASS_DATA (c)->ts.u.derived->attr.generic)
11927 CLASS_DATA (c)->ts.u.derived
11928 = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
11930 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
11931 && c->attr.pointer && c->ts.u.derived->components == NULL
11932 && !c->ts.u.derived->attr.zero_comp)
11934 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11935 "that has not been declared", c->name, sym->name,
11940 if (c->ts.type == BT_CLASS && c->attr.class_ok
11941 && CLASS_DATA (c)->attr.class_pointer
11942 && CLASS_DATA (c)->ts.u.derived->components == NULL
11943 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11945 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11946 "that has not been declared", c->name, sym->name,
11952 if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE
11953 && (!c->attr.class_ok
11954 || !(CLASS_DATA (c)->attr.class_pointer
11955 || CLASS_DATA (c)->attr.allocatable)))
11957 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11958 "or pointer", c->name, &c->loc);
11962 /* Ensure that all the derived type components are put on the
11963 derived type list; even in formal namespaces, where derived type
11964 pointer components might not have been declared. */
11965 if (c->ts.type == BT_DERIVED
11967 && c->ts.u.derived->components
11969 && sym != c->ts.u.derived)
11970 add_dt_to_dt_list (c->ts.u.derived);
11972 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11973 || c->attr.proc_pointer
11974 || c->attr.allocatable)) == FAILURE)
11978 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11979 all DEFERRED bindings are overridden. */
11980 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11981 && !sym->attr.is_class
11982 && ensure_not_abstract (sym, super_type) == FAILURE)
11985 /* Add derived type to the derived type list. */
11986 add_dt_to_dt_list (sym);
11992 /* The following procedure does the full resolution of a derived type,
11993 including resolution of all type-bound procedures (if present). In contrast
11994 to 'resolve_fl_derived0' this can only be done after the module has been
11995 parsed completely. */
11998 resolve_fl_derived (gfc_symbol *sym)
12000 gfc_symbol *gen_dt = NULL;
12002 if (!sym->attr.is_class)
12003 gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
12004 if (gen_dt && gen_dt->generic && gen_dt->generic->next
12005 && (!gen_dt->generic->sym->attr.use_assoc
12006 || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module)
12007 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Generic name '%s' of "
12008 "function '%s' at %L being the same name as derived "
12009 "type at %L", sym->name,
12010 gen_dt->generic->sym == sym
12011 ? gen_dt->generic->next->sym->name
12012 : gen_dt->generic->sym->name,
12013 gen_dt->generic->sym == sym
12014 ? &gen_dt->generic->next->sym->declared_at
12015 : &gen_dt->generic->sym->declared_at,
12016 &sym->declared_at) == FAILURE)
12019 if (sym->attr.is_class && sym->ts.u.derived == NULL)
12021 /* Fix up incomplete CLASS symbols. */
12022 gfc_component *data = gfc_find_component (sym, "_data", true, true);
12023 gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
12024 if (vptr->ts.u.derived == NULL)
12026 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
12028 vptr->ts.u.derived = vtab->ts.u.derived;
12032 if (resolve_fl_derived0 (sym) == FAILURE)
12035 /* Resolve the type-bound procedures. */
12036 if (resolve_typebound_procedures (sym) == FAILURE)
12039 /* Resolve the finalizer procedures. */
12040 if (gfc_resolve_finalizers (sym) == FAILURE)
12048 resolve_fl_namelist (gfc_symbol *sym)
12053 for (nl = sym->namelist; nl; nl = nl->next)
12055 /* Check again, the check in match only works if NAMELIST comes
12057 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
12059 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12060 "allowed", nl->sym->name, sym->name, &sym->declared_at);
12064 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
12065 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
12066 "object '%s' with assumed shape in namelist "
12067 "'%s' at %L", nl->sym->name, sym->name,
12068 &sym->declared_at) == FAILURE)
12071 if (is_non_constant_shape_array (nl->sym)
12072 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
12073 "object '%s' with nonconstant shape in namelist "
12074 "'%s' at %L", nl->sym->name, sym->name,
12075 &sym->declared_at) == FAILURE)
12078 if (nl->sym->ts.type == BT_CHARACTER
12079 && (nl->sym->ts.u.cl->length == NULL
12080 || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
12081 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
12082 "'%s' with nonconstant character length in "
12083 "namelist '%s' at %L", nl->sym->name, sym->name,
12084 &sym->declared_at) == FAILURE)
12087 /* FIXME: Once UDDTIO is implemented, the following can be
12089 if (nl->sym->ts.type == BT_CLASS)
12091 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12092 "polymorphic and requires a defined input/output "
12093 "procedure", nl->sym->name, sym->name, &sym->declared_at);
12097 if (nl->sym->ts.type == BT_DERIVED
12098 && (nl->sym->ts.u.derived->attr.alloc_comp
12099 || nl->sym->ts.u.derived->attr.pointer_comp))
12101 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
12102 "'%s' in namelist '%s' at %L with ALLOCATABLE "
12103 "or POINTER components", nl->sym->name,
12104 sym->name, &sym->declared_at) == FAILURE)
12107 /* FIXME: Once UDDTIO is implemented, the following can be
12109 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12110 "ALLOCATABLE or POINTER components and thus requires "
12111 "a defined input/output procedure", nl->sym->name,
12112 sym->name, &sym->declared_at);
12117 /* Reject PRIVATE objects in a PUBLIC namelist. */
12118 if (gfc_check_symbol_access (sym))
12120 for (nl = sym->namelist; nl; nl = nl->next)
12122 if (!nl->sym->attr.use_assoc
12123 && !is_sym_host_assoc (nl->sym, sym->ns)
12124 && !gfc_check_symbol_access (nl->sym))
12126 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12127 "cannot be member of PUBLIC namelist '%s' at %L",
12128 nl->sym->name, sym->name, &sym->declared_at);
12132 /* Types with private components that came here by USE-association. */
12133 if (nl->sym->ts.type == BT_DERIVED
12134 && derived_inaccessible (nl->sym->ts.u.derived))
12136 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12137 "components and cannot be member of namelist '%s' at %L",
12138 nl->sym->name, sym->name, &sym->declared_at);
12142 /* Types with private components that are defined in the same module. */
12143 if (nl->sym->ts.type == BT_DERIVED
12144 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
12145 && nl->sym->ts.u.derived->attr.private_comp)
12147 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12148 "cannot be a member of PUBLIC namelist '%s' at %L",
12149 nl->sym->name, sym->name, &sym->declared_at);
12156 /* 14.1.2 A module or internal procedure represent local entities
12157 of the same type as a namelist member and so are not allowed. */
12158 for (nl = sym->namelist; nl; nl = nl->next)
12160 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
12163 if (nl->sym->attr.function && nl->sym == nl->sym->result)
12164 if ((nl->sym == sym->ns->proc_name)
12166 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
12170 if (nl->sym && nl->sym->name)
12171 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
12172 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
12174 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12175 "attribute in '%s' at %L", nlsym->name,
12176 &sym->declared_at);
12186 resolve_fl_parameter (gfc_symbol *sym)
12188 /* A parameter array's shape needs to be constant. */
12189 if (sym->as != NULL
12190 && (sym->as->type == AS_DEFERRED
12191 || is_non_constant_shape_array (sym)))
12193 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12194 "or of deferred shape", sym->name, &sym->declared_at);
12198 /* Make sure a parameter that has been implicitly typed still
12199 matches the implicit type, since PARAMETER statements can precede
12200 IMPLICIT statements. */
12201 if (sym->attr.implicit_type
12202 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
12205 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12206 "later IMPLICIT type", sym->name, &sym->declared_at);
12210 /* Make sure the types of derived parameters are consistent. This
12211 type checking is deferred until resolution because the type may
12212 refer to a derived type from the host. */
12213 if (sym->ts.type == BT_DERIVED
12214 && !gfc_compare_types (&sym->ts, &sym->value->ts))
12216 gfc_error ("Incompatible derived type in PARAMETER at %L",
12217 &sym->value->where);
12224 /* Do anything necessary to resolve a symbol. Right now, we just
12225 assume that an otherwise unknown symbol is a variable. This sort
12226 of thing commonly happens for symbols in module. */
12229 resolve_symbol (gfc_symbol *sym)
12231 int check_constant, mp_flag;
12232 gfc_symtree *symtree;
12233 gfc_symtree *this_symtree;
12236 symbol_attribute class_attr;
12237 gfc_array_spec *as;
12239 if (sym->attr.flavor == FL_UNKNOWN)
12242 /* If we find that a flavorless symbol is an interface in one of the
12243 parent namespaces, find its symtree in this namespace, free the
12244 symbol and set the symtree to point to the interface symbol. */
12245 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
12247 symtree = gfc_find_symtree (ns->sym_root, sym->name);
12248 if (symtree && (symtree->n.sym->generic ||
12249 (symtree->n.sym->attr.flavor == FL_PROCEDURE
12250 && sym->ns->construct_entities)))
12252 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
12254 gfc_release_symbol (sym);
12255 symtree->n.sym->refs++;
12256 this_symtree->n.sym = symtree->n.sym;
12261 /* Otherwise give it a flavor according to such attributes as
12263 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
12264 sym->attr.flavor = FL_VARIABLE;
12267 sym->attr.flavor = FL_PROCEDURE;
12268 if (sym->attr.dimension)
12269 sym->attr.function = 1;
12273 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
12274 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
12276 if (sym->attr.procedure && sym->ts.interface
12277 && sym->attr.if_source != IFSRC_DECL
12278 && resolve_procedure_interface (sym) == FAILURE)
12281 if (sym->attr.is_protected && !sym->attr.proc_pointer
12282 && (sym->attr.procedure || sym->attr.external))
12284 if (sym->attr.external)
12285 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12286 "at %L", &sym->declared_at);
12288 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12289 "at %L", &sym->declared_at);
12294 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
12297 /* Symbols that are module procedures with results (functions) have
12298 the types and array specification copied for type checking in
12299 procedures that call them, as well as for saving to a module
12300 file. These symbols can't stand the scrutiny that their results
12302 mp_flag = (sym->result != NULL && sym->result != sym);
12304 /* Make sure that the intrinsic is consistent with its internal
12305 representation. This needs to be done before assigning a default
12306 type to avoid spurious warnings. */
12307 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
12308 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
12311 /* Resolve associate names. */
12313 resolve_assoc_var (sym, true);
12315 /* Assign default type to symbols that need one and don't have one. */
12316 if (sym->ts.type == BT_UNKNOWN)
12318 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
12320 gfc_set_default_type (sym, 1, NULL);
12323 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
12324 && !sym->attr.function && !sym->attr.subroutine
12325 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
12326 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
12328 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
12330 /* The specific case of an external procedure should emit an error
12331 in the case that there is no implicit type. */
12333 gfc_set_default_type (sym, sym->attr.external, NULL);
12336 /* Result may be in another namespace. */
12337 resolve_symbol (sym->result);
12339 if (!sym->result->attr.proc_pointer)
12341 sym->ts = sym->result->ts;
12342 sym->as = gfc_copy_array_spec (sym->result->as);
12343 sym->attr.dimension = sym->result->attr.dimension;
12344 sym->attr.pointer = sym->result->attr.pointer;
12345 sym->attr.allocatable = sym->result->attr.allocatable;
12346 sym->attr.contiguous = sym->result->attr.contiguous;
12351 else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
12352 gfc_resolve_array_spec (sym->result->as, false);
12354 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
12356 as = CLASS_DATA (sym)->as;
12357 class_attr = CLASS_DATA (sym)->attr;
12358 class_attr.pointer = class_attr.class_pointer;
12362 class_attr = sym->attr;
12367 if (sym->attr.contiguous
12368 && (!class_attr.dimension
12369 || (as->type != AS_ASSUMED_SHAPE && !class_attr.pointer)))
12371 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12372 "array pointer or an assumed-shape array", sym->name,
12373 &sym->declared_at);
12377 /* Assumed size arrays and assumed shape arrays must be dummy
12378 arguments. Array-spec's of implied-shape should have been resolved to
12379 AS_EXPLICIT already. */
12383 gcc_assert (as->type != AS_IMPLIED_SHAPE);
12384 if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
12385 || as->type == AS_ASSUMED_SHAPE)
12386 && sym->attr.dummy == 0)
12388 if (as->type == AS_ASSUMED_SIZE)
12389 gfc_error ("Assumed size array at %L must be a dummy argument",
12390 &sym->declared_at);
12392 gfc_error ("Assumed shape array at %L must be a dummy argument",
12393 &sym->declared_at);
12398 /* Make sure symbols with known intent or optional are really dummy
12399 variable. Because of ENTRY statement, this has to be deferred
12400 until resolution time. */
12402 if (!sym->attr.dummy
12403 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
12405 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
12409 if (sym->attr.value && !sym->attr.dummy)
12411 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12412 "it is not a dummy argument", sym->name, &sym->declared_at);
12416 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
12418 gfc_charlen *cl = sym->ts.u.cl;
12419 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
12421 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12422 "attribute must have constant length",
12423 sym->name, &sym->declared_at);
12427 if (sym->ts.is_c_interop
12428 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
12430 gfc_error ("C interoperable character dummy variable '%s' at %L "
12431 "with VALUE attribute must have length one",
12432 sym->name, &sym->declared_at);
12437 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
12438 && sym->ts.u.derived->attr.generic)
12440 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
12441 if (!sym->ts.u.derived)
12443 gfc_error ("The derived type '%s' at %L is of type '%s', "
12444 "which has not been defined", sym->name,
12445 &sym->declared_at, sym->ts.u.derived->name);
12446 sym->ts.type = BT_UNKNOWN;
12451 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12452 do this for something that was implicitly typed because that is handled
12453 in gfc_set_default_type. Handle dummy arguments and procedure
12454 definitions separately. Also, anything that is use associated is not
12455 handled here but instead is handled in the module it is declared in.
12456 Finally, derived type definitions are allowed to be BIND(C) since that
12457 only implies that they're interoperable, and they are checked fully for
12458 interoperability when a variable is declared of that type. */
12459 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
12460 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
12461 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
12463 gfc_try t = SUCCESS;
12465 /* First, make sure the variable is declared at the
12466 module-level scope (J3/04-007, Section 15.3). */
12467 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
12468 sym->attr.in_common == 0)
12470 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12471 "is neither a COMMON block nor declared at the "
12472 "module level scope", sym->name, &(sym->declared_at));
12475 else if (sym->common_head != NULL)
12477 t = verify_com_block_vars_c_interop (sym->common_head);
12481 /* If type() declaration, we need to verify that the components
12482 of the given type are all C interoperable, etc. */
12483 if (sym->ts.type == BT_DERIVED &&
12484 sym->ts.u.derived->attr.is_c_interop != 1)
12486 /* Make sure the user marked the derived type as BIND(C). If
12487 not, call the verify routine. This could print an error
12488 for the derived type more than once if multiple variables
12489 of that type are declared. */
12490 if (sym->ts.u.derived->attr.is_bind_c != 1)
12491 verify_bind_c_derived_type (sym->ts.u.derived);
12495 /* Verify the variable itself as C interoperable if it
12496 is BIND(C). It is not possible for this to succeed if
12497 the verify_bind_c_derived_type failed, so don't have to handle
12498 any error returned by verify_bind_c_derived_type. */
12499 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
12500 sym->common_block);
12505 /* clear the is_bind_c flag to prevent reporting errors more than
12506 once if something failed. */
12507 sym->attr.is_bind_c = 0;
12512 /* If a derived type symbol has reached this point, without its
12513 type being declared, we have an error. Notice that most
12514 conditions that produce undefined derived types have already
12515 been dealt with. However, the likes of:
12516 implicit type(t) (t) ..... call foo (t) will get us here if
12517 the type is not declared in the scope of the implicit
12518 statement. Change the type to BT_UNKNOWN, both because it is so
12519 and to prevent an ICE. */
12520 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
12521 && sym->ts.u.derived->components == NULL
12522 && !sym->ts.u.derived->attr.zero_comp)
12524 gfc_error ("The derived type '%s' at %L is of type '%s', "
12525 "which has not been defined", sym->name,
12526 &sym->declared_at, sym->ts.u.derived->name);
12527 sym->ts.type = BT_UNKNOWN;
12531 /* Make sure that the derived type has been resolved and that the
12532 derived type is visible in the symbol's namespace, if it is a
12533 module function and is not PRIVATE. */
12534 if (sym->ts.type == BT_DERIVED
12535 && sym->ts.u.derived->attr.use_assoc
12536 && sym->ns->proc_name
12537 && sym->ns->proc_name->attr.flavor == FL_MODULE
12538 && resolve_fl_derived (sym->ts.u.derived) == FAILURE)
12541 /* Unless the derived-type declaration is use associated, Fortran 95
12542 does not allow public entries of private derived types.
12543 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12544 161 in 95-006r3. */
12545 if (sym->ts.type == BT_DERIVED
12546 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12547 && !sym->ts.u.derived->attr.use_assoc
12548 && gfc_check_symbol_access (sym)
12549 && !gfc_check_symbol_access (sym->ts.u.derived)
12550 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12551 "of PRIVATE derived type '%s'",
12552 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12553 : "variable", sym->name, &sym->declared_at,
12554 sym->ts.u.derived->name) == FAILURE)
12557 /* F2008, C1302. */
12558 if (sym->ts.type == BT_DERIVED
12559 && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
12560 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
12561 || sym->ts.u.derived->attr.lock_comp)
12562 && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
12564 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
12565 "type LOCK_TYPE must be a coarray", sym->name,
12566 &sym->declared_at);
12570 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12571 default initialization is defined (5.1.2.4.4). */
12572 if (sym->ts.type == BT_DERIVED
12574 && sym->attr.intent == INTENT_OUT
12576 && sym->as->type == AS_ASSUMED_SIZE)
12578 for (c = sym->ts.u.derived->components; c; c = c->next)
12580 if (c->initializer)
12582 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12583 "ASSUMED SIZE and so cannot have a default initializer",
12584 sym->name, &sym->declared_at);
12591 if (sym->ts.type == BT_DERIVED && sym->attr.dummy
12592 && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
12594 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
12595 "INTENT(OUT)", sym->name, &sym->declared_at);
12600 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12601 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12602 && CLASS_DATA (sym)->attr.coarray_comp))
12603 || class_attr.codimension)
12604 && (sym->attr.result || sym->result == sym))
12606 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12607 "a coarray component", sym->name, &sym->declared_at);
12612 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12613 && sym->ts.u.derived->ts.is_iso_c)
12615 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12616 "shall not be a coarray", sym->name, &sym->declared_at);
12621 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12622 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12623 && CLASS_DATA (sym)->attr.coarray_comp))
12624 && (class_attr.codimension || class_attr.pointer || class_attr.dimension
12625 || class_attr.allocatable))
12627 gfc_error ("Variable '%s' at %L with coarray component "
12628 "shall be a nonpointer, nonallocatable scalar",
12629 sym->name, &sym->declared_at);
12633 /* F2008, C526. The function-result case was handled above. */
12634 if (class_attr.codimension
12635 && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
12636 || sym->attr.select_type_temporary
12637 || sym->ns->save_all
12638 || sym->ns->proc_name->attr.flavor == FL_MODULE
12639 || sym->ns->proc_name->attr.is_main_program
12640 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12642 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
12643 "nor a dummy argument", sym->name, &sym->declared_at);
12647 else if (class_attr.codimension && !sym->attr.select_type_temporary
12648 && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
12650 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12651 "deferred shape", sym->name, &sym->declared_at);
12654 else if (class_attr.codimension && class_attr.allocatable && as
12655 && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
12657 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12658 "deferred shape", sym->name, &sym->declared_at);
12663 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12664 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12665 && CLASS_DATA (sym)->attr.coarray_comp))
12666 || (class_attr.codimension && class_attr.allocatable))
12667 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12669 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12670 "allocatable coarray or have coarray components",
12671 sym->name, &sym->declared_at);
12675 if (class_attr.codimension && sym->attr.dummy
12676 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12678 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12679 "procedure '%s'", sym->name, &sym->declared_at,
12680 sym->ns->proc_name->name);
12684 switch (sym->attr.flavor)
12687 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12692 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12697 if (resolve_fl_namelist (sym) == FAILURE)
12702 if (resolve_fl_parameter (sym) == FAILURE)
12710 /* Resolve array specifier. Check as well some constraints
12711 on COMMON blocks. */
12713 check_constant = sym->attr.in_common && !sym->attr.pointer;
12715 /* Set the formal_arg_flag so that check_conflict will not throw
12716 an error for host associated variables in the specification
12717 expression for an array_valued function. */
12718 if (sym->attr.function && sym->as)
12719 formal_arg_flag = 1;
12721 gfc_resolve_array_spec (sym->as, check_constant);
12723 formal_arg_flag = 0;
12725 /* Resolve formal namespaces. */
12726 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12727 && !sym->attr.contained && !sym->attr.intrinsic)
12728 gfc_resolve (sym->formal_ns);
12730 /* Make sure the formal namespace is present. */
12731 if (sym->formal && !sym->formal_ns)
12733 gfc_formal_arglist *formal = sym->formal;
12734 while (formal && !formal->sym)
12735 formal = formal->next;
12739 sym->formal_ns = formal->sym->ns;
12740 sym->formal_ns->refs++;
12744 /* Check threadprivate restrictions. */
12745 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12746 && (!sym->attr.in_common
12747 && sym->module == NULL
12748 && (sym->ns->proc_name == NULL
12749 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12750 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12752 /* If we have come this far we can apply default-initializers, as
12753 described in 14.7.5, to those variables that have not already
12754 been assigned one. */
12755 if (sym->ts.type == BT_DERIVED
12756 && sym->ns == gfc_current_ns
12758 && !sym->attr.allocatable
12759 && !sym->attr.alloc_comp)
12761 symbol_attribute *a = &sym->attr;
12763 if ((!a->save && !a->dummy && !a->pointer
12764 && !a->in_common && !a->use_assoc
12765 && (a->referenced || a->result)
12766 && !(a->function && sym != sym->result))
12767 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12768 apply_default_init (sym);
12771 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
12772 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
12773 && !CLASS_DATA (sym)->attr.class_pointer
12774 && !CLASS_DATA (sym)->attr.allocatable)
12775 apply_default_init (sym);
12777 /* If this symbol has a type-spec, check it. */
12778 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12779 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12780 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12786 /************* Resolve DATA statements *************/
12790 gfc_data_value *vnode;
12796 /* Advance the values structure to point to the next value in the data list. */
12799 next_data_value (void)
12801 while (mpz_cmp_ui (values.left, 0) == 0)
12804 if (values.vnode->next == NULL)
12807 values.vnode = values.vnode->next;
12808 mpz_set (values.left, values.vnode->repeat);
12816 check_data_variable (gfc_data_variable *var, locus *where)
12822 ar_type mark = AR_UNKNOWN;
12824 mpz_t section_index[GFC_MAX_DIMENSIONS];
12830 if (gfc_resolve_expr (var->expr) == FAILURE)
12834 mpz_init_set_si (offset, 0);
12837 if (e->expr_type != EXPR_VARIABLE)
12838 gfc_internal_error ("check_data_variable(): Bad expression");
12840 sym = e->symtree->n.sym;
12842 if (sym->ns->is_block_data && !sym->attr.in_common)
12844 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12845 sym->name, &sym->declared_at);
12848 if (e->ref == NULL && sym->as)
12850 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12851 " declaration", sym->name, where);
12855 has_pointer = sym->attr.pointer;
12857 if (gfc_is_coindexed (e))
12859 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name,
12864 for (ref = e->ref; ref; ref = ref->next)
12866 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12870 && ref->type == REF_ARRAY
12871 && ref->u.ar.type != AR_FULL)
12873 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12874 "be a full array", sym->name, where);
12879 if (e->rank == 0 || has_pointer)
12881 mpz_init_set_ui (size, 1);
12888 /* Find the array section reference. */
12889 for (ref = e->ref; ref; ref = ref->next)
12891 if (ref->type != REF_ARRAY)
12893 if (ref->u.ar.type == AR_ELEMENT)
12899 /* Set marks according to the reference pattern. */
12900 switch (ref->u.ar.type)
12908 /* Get the start position of array section. */
12909 gfc_get_section_index (ar, section_index, &offset);
12914 gcc_unreachable ();
12917 if (gfc_array_size (e, &size) == FAILURE)
12919 gfc_error ("Nonconstant array section at %L in DATA statement",
12921 mpz_clear (offset);
12928 while (mpz_cmp_ui (size, 0) > 0)
12930 if (next_data_value () == FAILURE)
12932 gfc_error ("DATA statement at %L has more variables than values",
12938 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12942 /* If we have more than one element left in the repeat count,
12943 and we have more than one element left in the target variable,
12944 then create a range assignment. */
12945 /* FIXME: Only done for full arrays for now, since array sections
12947 if (mark == AR_FULL && ref && ref->next == NULL
12948 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12952 if (mpz_cmp (size, values.left) >= 0)
12954 mpz_init_set (range, values.left);
12955 mpz_sub (size, size, values.left);
12956 mpz_set_ui (values.left, 0);
12960 mpz_init_set (range, size);
12961 mpz_sub (values.left, values.left, size);
12962 mpz_set_ui (size, 0);
12965 t = gfc_assign_data_value (var->expr, values.vnode->expr,
12968 mpz_add (offset, offset, range);
12975 /* Assign initial value to symbol. */
12978 mpz_sub_ui (values.left, values.left, 1);
12979 mpz_sub_ui (size, size, 1);
12981 t = gfc_assign_data_value (var->expr, values.vnode->expr,
12986 if (mark == AR_FULL)
12987 mpz_add_ui (offset, offset, 1);
12989 /* Modify the array section indexes and recalculate the offset
12990 for next element. */
12991 else if (mark == AR_SECTION)
12992 gfc_advance_section (section_index, ar, &offset);
12996 if (mark == AR_SECTION)
12998 for (i = 0; i < ar->dimen; i++)
12999 mpz_clear (section_index[i]);
13003 mpz_clear (offset);
13009 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
13011 /* Iterate over a list of elements in a DATA statement. */
13014 traverse_data_list (gfc_data_variable *var, locus *where)
13017 iterator_stack frame;
13018 gfc_expr *e, *start, *end, *step;
13019 gfc_try retval = SUCCESS;
13021 mpz_init (frame.value);
13024 start = gfc_copy_expr (var->iter.start);
13025 end = gfc_copy_expr (var->iter.end);
13026 step = gfc_copy_expr (var->iter.step);
13028 if (gfc_simplify_expr (start, 1) == FAILURE
13029 || start->expr_type != EXPR_CONSTANT)
13031 gfc_error ("start of implied-do loop at %L could not be "
13032 "simplified to a constant value", &start->where);
13036 if (gfc_simplify_expr (end, 1) == FAILURE
13037 || end->expr_type != EXPR_CONSTANT)
13039 gfc_error ("end of implied-do loop at %L could not be "
13040 "simplified to a constant value", &start->where);
13044 if (gfc_simplify_expr (step, 1) == FAILURE
13045 || step->expr_type != EXPR_CONSTANT)
13047 gfc_error ("step of implied-do loop at %L could not be "
13048 "simplified to a constant value", &start->where);
13053 mpz_set (trip, end->value.integer);
13054 mpz_sub (trip, trip, start->value.integer);
13055 mpz_add (trip, trip, step->value.integer);
13057 mpz_div (trip, trip, step->value.integer);
13059 mpz_set (frame.value, start->value.integer);
13061 frame.prev = iter_stack;
13062 frame.variable = var->iter.var->symtree;
13063 iter_stack = &frame;
13065 while (mpz_cmp_ui (trip, 0) > 0)
13067 if (traverse_data_var (var->list, where) == FAILURE)
13073 e = gfc_copy_expr (var->expr);
13074 if (gfc_simplify_expr (e, 1) == FAILURE)
13081 mpz_add (frame.value, frame.value, step->value.integer);
13083 mpz_sub_ui (trip, trip, 1);
13087 mpz_clear (frame.value);
13090 gfc_free_expr (start);
13091 gfc_free_expr (end);
13092 gfc_free_expr (step);
13094 iter_stack = frame.prev;
13099 /* Type resolve variables in the variable list of a DATA statement. */
13102 traverse_data_var (gfc_data_variable *var, locus *where)
13106 for (; var; var = var->next)
13108 if (var->expr == NULL)
13109 t = traverse_data_list (var, where);
13111 t = check_data_variable (var, where);
13121 /* Resolve the expressions and iterators associated with a data statement.
13122 This is separate from the assignment checking because data lists should
13123 only be resolved once. */
13126 resolve_data_variables (gfc_data_variable *d)
13128 for (; d; d = d->next)
13130 if (d->list == NULL)
13132 if (gfc_resolve_expr (d->expr) == FAILURE)
13137 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
13140 if (resolve_data_variables (d->list) == FAILURE)
13149 /* Resolve a single DATA statement. We implement this by storing a pointer to
13150 the value list into static variables, and then recursively traversing the
13151 variables list, expanding iterators and such. */
13154 resolve_data (gfc_data *d)
13157 if (resolve_data_variables (d->var) == FAILURE)
13160 values.vnode = d->value;
13161 if (d->value == NULL)
13162 mpz_set_ui (values.left, 0);
13164 mpz_set (values.left, d->value->repeat);
13166 if (traverse_data_var (d->var, &d->where) == FAILURE)
13169 /* At this point, we better not have any values left. */
13171 if (next_data_value () == SUCCESS)
13172 gfc_error ("DATA statement at %L has more values than variables",
13177 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13178 accessed by host or use association, is a dummy argument to a pure function,
13179 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13180 is storage associated with any such variable, shall not be used in the
13181 following contexts: (clients of this function). */
13183 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13184 procedure. Returns zero if assignment is OK, nonzero if there is a
13187 gfc_impure_variable (gfc_symbol *sym)
13192 if (sym->attr.use_assoc || sym->attr.in_common)
13195 /* Check if the symbol's ns is inside the pure procedure. */
13196 for (ns = gfc_current_ns; ns; ns = ns->parent)
13200 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
13204 proc = sym->ns->proc_name;
13205 if (sym->attr.dummy
13206 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
13207 || proc->attr.function))
13210 /* TODO: Sort out what can be storage associated, if anything, and include
13211 it here. In principle equivalences should be scanned but it does not
13212 seem to be possible to storage associate an impure variable this way. */
13217 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13218 current namespace is inside a pure procedure. */
13221 gfc_pure (gfc_symbol *sym)
13223 symbol_attribute attr;
13228 /* Check if the current namespace or one of its parents
13229 belongs to a pure procedure. */
13230 for (ns = gfc_current_ns; ns; ns = ns->parent)
13232 sym = ns->proc_name;
13236 if (attr.flavor == FL_PROCEDURE && attr.pure)
13244 return attr.flavor == FL_PROCEDURE && attr.pure;
13248 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13249 checks if the current namespace is implicitly pure. Note that this
13250 function returns false for a PURE procedure. */
13253 gfc_implicit_pure (gfc_symbol *sym)
13259 /* Check if the current procedure is implicit_pure. Walk up
13260 the procedure list until we find a procedure. */
13261 for (ns = gfc_current_ns; ns; ns = ns->parent)
13263 sym = ns->proc_name;
13267 if (sym->attr.flavor == FL_PROCEDURE)
13272 return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
13273 && !sym->attr.pure;
13277 /* Test whether the current procedure is elemental or not. */
13280 gfc_elemental (gfc_symbol *sym)
13282 symbol_attribute attr;
13285 sym = gfc_current_ns->proc_name;
13290 return attr.flavor == FL_PROCEDURE && attr.elemental;
13294 /* Warn about unused labels. */
13297 warn_unused_fortran_label (gfc_st_label *label)
13302 warn_unused_fortran_label (label->left);
13304 if (label->defined == ST_LABEL_UNKNOWN)
13307 switch (label->referenced)
13309 case ST_LABEL_UNKNOWN:
13310 gfc_warning ("Label %d at %L defined but not used", label->value,
13314 case ST_LABEL_BAD_TARGET:
13315 gfc_warning ("Label %d at %L defined but cannot be used",
13316 label->value, &label->where);
13323 warn_unused_fortran_label (label->right);
13327 /* Returns the sequence type of a symbol or sequence. */
13330 sequence_type (gfc_typespec ts)
13339 if (ts.u.derived->components == NULL)
13340 return SEQ_NONDEFAULT;
13342 result = sequence_type (ts.u.derived->components->ts);
13343 for (c = ts.u.derived->components->next; c; c = c->next)
13344 if (sequence_type (c->ts) != result)
13350 if (ts.kind != gfc_default_character_kind)
13351 return SEQ_NONDEFAULT;
13353 return SEQ_CHARACTER;
13356 if (ts.kind != gfc_default_integer_kind)
13357 return SEQ_NONDEFAULT;
13359 return SEQ_NUMERIC;
13362 if (!(ts.kind == gfc_default_real_kind
13363 || ts.kind == gfc_default_double_kind))
13364 return SEQ_NONDEFAULT;
13366 return SEQ_NUMERIC;
13369 if (ts.kind != gfc_default_complex_kind)
13370 return SEQ_NONDEFAULT;
13372 return SEQ_NUMERIC;
13375 if (ts.kind != gfc_default_logical_kind)
13376 return SEQ_NONDEFAULT;
13378 return SEQ_NUMERIC;
13381 return SEQ_NONDEFAULT;
13386 /* Resolve derived type EQUIVALENCE object. */
13389 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
13391 gfc_component *c = derived->components;
13396 /* Shall not be an object of nonsequence derived type. */
13397 if (!derived->attr.sequence)
13399 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13400 "attribute to be an EQUIVALENCE object", sym->name,
13405 /* Shall not have allocatable components. */
13406 if (derived->attr.alloc_comp)
13408 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13409 "components to be an EQUIVALENCE object",sym->name,
13414 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
13416 gfc_error ("Derived type variable '%s' at %L with default "
13417 "initialization cannot be in EQUIVALENCE with a variable "
13418 "in COMMON", sym->name, &e->where);
13422 for (; c ; c = c->next)
13424 if (c->ts.type == BT_DERIVED
13425 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
13428 /* Shall not be an object of sequence derived type containing a pointer
13429 in the structure. */
13430 if (c->attr.pointer)
13432 gfc_error ("Derived type variable '%s' at %L with pointer "
13433 "component(s) cannot be an EQUIVALENCE object",
13434 sym->name, &e->where);
13442 /* Resolve equivalence object.
13443 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13444 an allocatable array, an object of nonsequence derived type, an object of
13445 sequence derived type containing a pointer at any level of component
13446 selection, an automatic object, a function name, an entry name, a result
13447 name, a named constant, a structure component, or a subobject of any of
13448 the preceding objects. A substring shall not have length zero. A
13449 derived type shall not have components with default initialization nor
13450 shall two objects of an equivalence group be initialized.
13451 Either all or none of the objects shall have an protected attribute.
13452 The simple constraints are done in symbol.c(check_conflict) and the rest
13453 are implemented here. */
13456 resolve_equivalence (gfc_equiv *eq)
13459 gfc_symbol *first_sym;
13462 locus *last_where = NULL;
13463 seq_type eq_type, last_eq_type;
13464 gfc_typespec *last_ts;
13465 int object, cnt_protected;
13468 last_ts = &eq->expr->symtree->n.sym->ts;
13470 first_sym = eq->expr->symtree->n.sym;
13474 for (object = 1; eq; eq = eq->eq, object++)
13478 e->ts = e->symtree->n.sym->ts;
13479 /* match_varspec might not know yet if it is seeing
13480 array reference or substring reference, as it doesn't
13482 if (e->ref && e->ref->type == REF_ARRAY)
13484 gfc_ref *ref = e->ref;
13485 sym = e->symtree->n.sym;
13487 if (sym->attr.dimension)
13489 ref->u.ar.as = sym->as;
13493 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13494 if (e->ts.type == BT_CHARACTER
13496 && ref->type == REF_ARRAY
13497 && ref->u.ar.dimen == 1
13498 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
13499 && ref->u.ar.stride[0] == NULL)
13501 gfc_expr *start = ref->u.ar.start[0];
13502 gfc_expr *end = ref->u.ar.end[0];
13505 /* Optimize away the (:) reference. */
13506 if (start == NULL && end == NULL)
13509 e->ref = ref->next;
13511 e->ref->next = ref->next;
13516 ref->type = REF_SUBSTRING;
13518 start = gfc_get_int_expr (gfc_default_integer_kind,
13520 ref->u.ss.start = start;
13521 if (end == NULL && e->ts.u.cl)
13522 end = gfc_copy_expr (e->ts.u.cl->length);
13523 ref->u.ss.end = end;
13524 ref->u.ss.length = e->ts.u.cl;
13531 /* Any further ref is an error. */
13534 gcc_assert (ref->type == REF_ARRAY);
13535 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13541 if (gfc_resolve_expr (e) == FAILURE)
13544 sym = e->symtree->n.sym;
13546 if (sym->attr.is_protected)
13548 if (cnt_protected > 0 && cnt_protected != object)
13550 gfc_error ("Either all or none of the objects in the "
13551 "EQUIVALENCE set at %L shall have the "
13552 "PROTECTED attribute",
13557 /* Shall not equivalence common block variables in a PURE procedure. */
13558 if (sym->ns->proc_name
13559 && sym->ns->proc_name->attr.pure
13560 && sym->attr.in_common)
13562 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13563 "object in the pure procedure '%s'",
13564 sym->name, &e->where, sym->ns->proc_name->name);
13568 /* Shall not be a named constant. */
13569 if (e->expr_type == EXPR_CONSTANT)
13571 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13572 "object", sym->name, &e->where);
13576 if (e->ts.type == BT_DERIVED
13577 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
13580 /* Check that the types correspond correctly:
13582 A numeric sequence structure may be equivalenced to another sequence
13583 structure, an object of default integer type, default real type, double
13584 precision real type, default logical type such that components of the
13585 structure ultimately only become associated to objects of the same
13586 kind. A character sequence structure may be equivalenced to an object
13587 of default character kind or another character sequence structure.
13588 Other objects may be equivalenced only to objects of the same type and
13589 kind parameters. */
13591 /* Identical types are unconditionally OK. */
13592 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
13593 goto identical_types;
13595 last_eq_type = sequence_type (*last_ts);
13596 eq_type = sequence_type (sym->ts);
13598 /* Since the pair of objects is not of the same type, mixed or
13599 non-default sequences can be rejected. */
13601 msg = "Sequence %s with mixed components in EQUIVALENCE "
13602 "statement at %L with different type objects";
13604 && last_eq_type == SEQ_MIXED
13605 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
13607 || (eq_type == SEQ_MIXED
13608 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13609 &e->where) == FAILURE))
13612 msg = "Non-default type object or sequence %s in EQUIVALENCE "
13613 "statement at %L with objects of different type";
13615 && last_eq_type == SEQ_NONDEFAULT
13616 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
13617 last_where) == FAILURE)
13618 || (eq_type == SEQ_NONDEFAULT
13619 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13620 &e->where) == FAILURE))
13623 msg ="Non-CHARACTER object '%s' in default CHARACTER "
13624 "EQUIVALENCE statement at %L";
13625 if (last_eq_type == SEQ_CHARACTER
13626 && eq_type != SEQ_CHARACTER
13627 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13628 &e->where) == FAILURE)
13631 msg ="Non-NUMERIC object '%s' in default NUMERIC "
13632 "EQUIVALENCE statement at %L";
13633 if (last_eq_type == SEQ_NUMERIC
13634 && eq_type != SEQ_NUMERIC
13635 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13636 &e->where) == FAILURE)
13641 last_where = &e->where;
13646 /* Shall not be an automatic array. */
13647 if (e->ref->type == REF_ARRAY
13648 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
13650 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13651 "an EQUIVALENCE object", sym->name, &e->where);
13658 /* Shall not be a structure component. */
13659 if (r->type == REF_COMPONENT)
13661 gfc_error ("Structure component '%s' at %L cannot be an "
13662 "EQUIVALENCE object",
13663 r->u.c.component->name, &e->where);
13667 /* A substring shall not have length zero. */
13668 if (r->type == REF_SUBSTRING)
13670 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13672 gfc_error ("Substring at %L has length zero",
13673 &r->u.ss.start->where);
13683 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13686 resolve_fntype (gfc_namespace *ns)
13688 gfc_entry_list *el;
13691 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13694 /* If there are any entries, ns->proc_name is the entry master
13695 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13697 sym = ns->entries->sym;
13699 sym = ns->proc_name;
13700 if (sym->result == sym
13701 && sym->ts.type == BT_UNKNOWN
13702 && gfc_set_default_type (sym, 0, NULL) == FAILURE
13703 && !sym->attr.untyped)
13705 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13706 sym->name, &sym->declared_at);
13707 sym->attr.untyped = 1;
13710 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13711 && !sym->attr.contained
13712 && !gfc_check_symbol_access (sym->ts.u.derived)
13713 && gfc_check_symbol_access (sym))
13715 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13716 "%L of PRIVATE type '%s'", sym->name,
13717 &sym->declared_at, sym->ts.u.derived->name);
13721 for (el = ns->entries->next; el; el = el->next)
13723 if (el->sym->result == el->sym
13724 && el->sym->ts.type == BT_UNKNOWN
13725 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13726 && !el->sym->attr.untyped)
13728 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13729 el->sym->name, &el->sym->declared_at);
13730 el->sym->attr.untyped = 1;
13736 /* 12.3.2.1.1 Defined operators. */
13739 check_uop_procedure (gfc_symbol *sym, locus where)
13741 gfc_formal_arglist *formal;
13743 if (!sym->attr.function)
13745 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13746 sym->name, &where);
13750 if (sym->ts.type == BT_CHARACTER
13751 && !(sym->ts.u.cl && sym->ts.u.cl->length)
13752 && !(sym->result && sym->result->ts.u.cl
13753 && sym->result->ts.u.cl->length))
13755 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13756 "character length", sym->name, &where);
13760 formal = sym->formal;
13761 if (!formal || !formal->sym)
13763 gfc_error ("User operator procedure '%s' at %L must have at least "
13764 "one argument", sym->name, &where);
13768 if (formal->sym->attr.intent != INTENT_IN)
13770 gfc_error ("First argument of operator interface at %L must be "
13771 "INTENT(IN)", &where);
13775 if (formal->sym->attr.optional)
13777 gfc_error ("First argument of operator interface at %L cannot be "
13778 "optional", &where);
13782 formal = formal->next;
13783 if (!formal || !formal->sym)
13786 if (formal->sym->attr.intent != INTENT_IN)
13788 gfc_error ("Second argument of operator interface at %L must be "
13789 "INTENT(IN)", &where);
13793 if (formal->sym->attr.optional)
13795 gfc_error ("Second argument of operator interface at %L cannot be "
13796 "optional", &where);
13802 gfc_error ("Operator interface at %L must have, at most, two "
13803 "arguments", &where);
13811 gfc_resolve_uops (gfc_symtree *symtree)
13813 gfc_interface *itr;
13815 if (symtree == NULL)
13818 gfc_resolve_uops (symtree->left);
13819 gfc_resolve_uops (symtree->right);
13821 for (itr = symtree->n.uop->op; itr; itr = itr->next)
13822 check_uop_procedure (itr->sym, itr->sym->declared_at);
13826 /* Examine all of the expressions associated with a program unit,
13827 assign types to all intermediate expressions, make sure that all
13828 assignments are to compatible types and figure out which names
13829 refer to which functions or subroutines. It doesn't check code
13830 block, which is handled by resolve_code. */
13833 resolve_types (gfc_namespace *ns)
13839 gfc_namespace* old_ns = gfc_current_ns;
13841 /* Check that all IMPLICIT types are ok. */
13842 if (!ns->seen_implicit_none)
13845 for (letter = 0; letter != GFC_LETTERS; ++letter)
13846 if (ns->set_flag[letter]
13847 && resolve_typespec_used (&ns->default_type[letter],
13848 &ns->implicit_loc[letter],
13853 gfc_current_ns = ns;
13855 resolve_entries (ns);
13857 resolve_common_vars (ns->blank_common.head, false);
13858 resolve_common_blocks (ns->common_root);
13860 resolve_contained_functions (ns);
13862 if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
13863 && ns->proc_name->attr.if_source == IFSRC_IFBODY)
13864 resolve_formal_arglist (ns->proc_name);
13866 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13868 for (cl = ns->cl_list; cl; cl = cl->next)
13869 resolve_charlen (cl);
13871 gfc_traverse_ns (ns, resolve_symbol);
13873 resolve_fntype (ns);
13875 for (n = ns->contained; n; n = n->sibling)
13877 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13878 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13879 "also be PURE", n->proc_name->name,
13880 &n->proc_name->declared_at);
13886 do_concurrent_flag = 0;
13887 gfc_check_interfaces (ns);
13889 gfc_traverse_ns (ns, resolve_values);
13895 for (d = ns->data; d; d = d->next)
13899 gfc_traverse_ns (ns, gfc_formalize_init_value);
13901 gfc_traverse_ns (ns, gfc_verify_binding_labels);
13903 if (ns->common_root != NULL)
13904 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13906 for (eq = ns->equiv; eq; eq = eq->next)
13907 resolve_equivalence (eq);
13909 /* Warn about unused labels. */
13910 if (warn_unused_label)
13911 warn_unused_fortran_label (ns->st_labels);
13913 gfc_resolve_uops (ns->uop_root);
13915 gfc_current_ns = old_ns;
13919 /* Call resolve_code recursively. */
13922 resolve_codes (gfc_namespace *ns)
13925 bitmap_obstack old_obstack;
13927 if (ns->resolved == 1)
13930 for (n = ns->contained; n; n = n->sibling)
13933 gfc_current_ns = ns;
13935 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13936 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13939 /* Set to an out of range value. */
13940 current_entry_id = -1;
13942 old_obstack = labels_obstack;
13943 bitmap_obstack_initialize (&labels_obstack);
13945 resolve_code (ns->code, ns);
13947 bitmap_obstack_release (&labels_obstack);
13948 labels_obstack = old_obstack;
13952 /* This function is called after a complete program unit has been compiled.
13953 Its purpose is to examine all of the expressions associated with a program
13954 unit, assign types to all intermediate expressions, make sure that all
13955 assignments are to compatible types and figure out which names refer to
13956 which functions or subroutines. */
13959 gfc_resolve (gfc_namespace *ns)
13961 gfc_namespace *old_ns;
13962 code_stack *old_cs_base;
13968 old_ns = gfc_current_ns;
13969 old_cs_base = cs_base;
13971 resolve_types (ns);
13972 resolve_codes (ns);
13974 gfc_current_ns = old_ns;
13975 cs_base = old_cs_base;
13978 gfc_run_passes (ns);