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)
367 proc->attr.implicit_pure = 0;
369 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
370 proc->attr.implicit_pure = 0;
374 if (gfc_elemental (proc))
377 if (sym->attr.codimension
378 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
379 && CLASS_DATA (sym)->attr.codimension))
381 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
382 "procedure", sym->name, &sym->declared_at);
386 if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
387 && CLASS_DATA (sym)->as))
389 gfc_error ("Argument '%s' of elemental procedure at %L must "
390 "be scalar", sym->name, &sym->declared_at);
394 if (sym->attr.allocatable
395 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
396 && CLASS_DATA (sym)->attr.allocatable))
398 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
399 "have the ALLOCATABLE attribute", sym->name,
404 if (sym->attr.pointer
405 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
406 && CLASS_DATA (sym)->attr.class_pointer))
408 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
409 "have the POINTER attribute", sym->name,
414 if (sym->attr.flavor == FL_PROCEDURE)
416 gfc_error ("Dummy procedure '%s' not allowed in elemental "
417 "procedure '%s' at %L", sym->name, proc->name,
422 if (sym->attr.intent == INTENT_UNKNOWN)
424 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
425 "have its INTENT specified", sym->name, proc->name,
431 /* Each dummy shall be specified to be scalar. */
432 if (proc->attr.proc == PROC_ST_FUNCTION)
436 gfc_error ("Argument '%s' of statement function at %L must "
437 "be scalar", sym->name, &sym->declared_at);
441 if (sym->ts.type == BT_CHARACTER)
443 gfc_charlen *cl = sym->ts.u.cl;
444 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
446 gfc_error ("Character-valued argument '%s' of statement "
447 "function at %L must have constant length",
448 sym->name, &sym->declared_at);
458 /* Work function called when searching for symbols that have argument lists
459 associated with them. */
462 find_arglists (gfc_symbol *sym)
464 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
465 || sym->attr.flavor == FL_DERIVED)
468 resolve_formal_arglist (sym);
472 /* Given a namespace, resolve all formal argument lists within the namespace.
476 resolve_formal_arglists (gfc_namespace *ns)
481 gfc_traverse_ns (ns, find_arglists);
486 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
490 /* If this namespace is not a function or an entry master function,
492 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
493 || sym->attr.entry_master)
496 /* Try to find out of what the return type is. */
497 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
499 t = gfc_set_default_type (sym->result, 0, ns);
501 if (t == FAILURE && !sym->result->attr.untyped)
503 if (sym->result == sym)
504 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
505 sym->name, &sym->declared_at);
506 else if (!sym->result->attr.proc_pointer)
507 gfc_error ("Result '%s' of contained function '%s' at %L has "
508 "no IMPLICIT type", sym->result->name, sym->name,
509 &sym->result->declared_at);
510 sym->result->attr.untyped = 1;
514 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
515 type, lists the only ways a character length value of * can be used:
516 dummy arguments of procedures, named constants, and function results
517 in external functions. Internal function results and results of module
518 procedures are not on this list, ergo, not permitted. */
520 if (sym->result->ts.type == BT_CHARACTER)
522 gfc_charlen *cl = sym->result->ts.u.cl;
523 if ((!cl || !cl->length) && !sym->result->ts.deferred)
525 /* See if this is a module-procedure and adapt error message
528 gcc_assert (ns->parent && ns->parent->proc_name);
529 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
531 gfc_error ("Character-valued %s '%s' at %L must not be"
533 module_proc ? _("module procedure")
534 : _("internal function"),
535 sym->name, &sym->declared_at);
541 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
542 introduce duplicates. */
545 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
547 gfc_formal_arglist *f, *new_arglist;
550 for (; new_args != NULL; new_args = new_args->next)
552 new_sym = new_args->sym;
553 /* See if this arg is already in the formal argument list. */
554 for (f = proc->formal; f; f = f->next)
556 if (new_sym == f->sym)
563 /* Add a new argument. Argument order is not important. */
564 new_arglist = gfc_get_formal_arglist ();
565 new_arglist->sym = new_sym;
566 new_arglist->next = proc->formal;
567 proc->formal = new_arglist;
572 /* Flag the arguments that are not present in all entries. */
575 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
577 gfc_formal_arglist *f, *head;
580 for (f = proc->formal; f; f = f->next)
585 for (new_args = head; new_args; new_args = new_args->next)
587 if (new_args->sym == f->sym)
594 f->sym->attr.not_always_present = 1;
599 /* Resolve alternate entry points. If a symbol has multiple entry points we
600 create a new master symbol for the main routine, and turn the existing
601 symbol into an entry point. */
604 resolve_entries (gfc_namespace *ns)
606 gfc_namespace *old_ns;
610 char name[GFC_MAX_SYMBOL_LEN + 1];
611 static int master_count = 0;
613 if (ns->proc_name == NULL)
616 /* No need to do anything if this procedure doesn't have alternate entry
621 /* We may already have resolved alternate entry points. */
622 if (ns->proc_name->attr.entry_master)
625 /* If this isn't a procedure something has gone horribly wrong. */
626 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
628 /* Remember the current namespace. */
629 old_ns = gfc_current_ns;
633 /* Add the main entry point to the list of entry points. */
634 el = gfc_get_entry_list ();
635 el->sym = ns->proc_name;
637 el->next = ns->entries;
639 ns->proc_name->attr.entry = 1;
641 /* If it is a module function, it needs to be in the right namespace
642 so that gfc_get_fake_result_decl can gather up the results. The
643 need for this arose in get_proc_name, where these beasts were
644 left in their own namespace, to keep prior references linked to
645 the entry declaration.*/
646 if (ns->proc_name->attr.function
647 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
650 /* Do the same for entries where the master is not a module
651 procedure. These are retained in the module namespace because
652 of the module procedure declaration. */
653 for (el = el->next; el; el = el->next)
654 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
655 && el->sym->attr.mod_proc)
659 /* Add an entry statement for it. */
666 /* Create a new symbol for the master function. */
667 /* Give the internal function a unique name (within this file).
668 Also include the function name so the user has some hope of figuring
669 out what is going on. */
670 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
671 master_count++, ns->proc_name->name);
672 gfc_get_ha_symbol (name, &proc);
673 gcc_assert (proc != NULL);
675 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
676 if (ns->proc_name->attr.subroutine)
677 gfc_add_subroutine (&proc->attr, proc->name, NULL);
681 gfc_typespec *ts, *fts;
682 gfc_array_spec *as, *fas;
683 gfc_add_function (&proc->attr, proc->name, NULL);
685 fas = ns->entries->sym->as;
686 fas = fas ? fas : ns->entries->sym->result->as;
687 fts = &ns->entries->sym->result->ts;
688 if (fts->type == BT_UNKNOWN)
689 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
690 for (el = ns->entries->next; el; el = el->next)
692 ts = &el->sym->result->ts;
694 as = as ? as : el->sym->result->as;
695 if (ts->type == BT_UNKNOWN)
696 ts = gfc_get_default_type (el->sym->result->name, NULL);
698 if (! gfc_compare_types (ts, fts)
699 || (el->sym->result->attr.dimension
700 != ns->entries->sym->result->attr.dimension)
701 || (el->sym->result->attr.pointer
702 != ns->entries->sym->result->attr.pointer))
704 else if (as && fas && ns->entries->sym->result != el->sym->result
705 && gfc_compare_array_spec (as, fas) == 0)
706 gfc_error ("Function %s at %L has entries with mismatched "
707 "array specifications", ns->entries->sym->name,
708 &ns->entries->sym->declared_at);
709 /* The characteristics need to match and thus both need to have
710 the same string length, i.e. both len=*, or both len=4.
711 Having both len=<variable> is also possible, but difficult to
712 check at compile time. */
713 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
714 && (((ts->u.cl->length && !fts->u.cl->length)
715 ||(!ts->u.cl->length && fts->u.cl->length))
717 && ts->u.cl->length->expr_type
718 != fts->u.cl->length->expr_type)
720 && ts->u.cl->length->expr_type == EXPR_CONSTANT
721 && mpz_cmp (ts->u.cl->length->value.integer,
722 fts->u.cl->length->value.integer) != 0)))
723 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
724 "entries returning variables of different "
725 "string lengths", ns->entries->sym->name,
726 &ns->entries->sym->declared_at);
731 sym = ns->entries->sym->result;
732 /* All result types the same. */
734 if (sym->attr.dimension)
735 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
736 if (sym->attr.pointer)
737 gfc_add_pointer (&proc->attr, NULL);
741 /* Otherwise the result will be passed through a union by
743 proc->attr.mixed_entry_master = 1;
744 for (el = ns->entries; el; el = el->next)
746 sym = el->sym->result;
747 if (sym->attr.dimension)
749 if (el == ns->entries)
750 gfc_error ("FUNCTION result %s can't be an array in "
751 "FUNCTION %s at %L", sym->name,
752 ns->entries->sym->name, &sym->declared_at);
754 gfc_error ("ENTRY result %s can't be an array in "
755 "FUNCTION %s at %L", sym->name,
756 ns->entries->sym->name, &sym->declared_at);
758 else if (sym->attr.pointer)
760 if (el == ns->entries)
761 gfc_error ("FUNCTION result %s can't be a POINTER in "
762 "FUNCTION %s at %L", sym->name,
763 ns->entries->sym->name, &sym->declared_at);
765 gfc_error ("ENTRY result %s can't be a POINTER in "
766 "FUNCTION %s at %L", sym->name,
767 ns->entries->sym->name, &sym->declared_at);
772 if (ts->type == BT_UNKNOWN)
773 ts = gfc_get_default_type (sym->name, NULL);
777 if (ts->kind == gfc_default_integer_kind)
781 if (ts->kind == gfc_default_real_kind
782 || ts->kind == gfc_default_double_kind)
786 if (ts->kind == gfc_default_complex_kind)
790 if (ts->kind == gfc_default_logical_kind)
794 /* We will issue error elsewhere. */
802 if (el == ns->entries)
803 gfc_error ("FUNCTION result %s can't be of type %s "
804 "in FUNCTION %s at %L", sym->name,
805 gfc_typename (ts), ns->entries->sym->name,
808 gfc_error ("ENTRY result %s can't be of type %s "
809 "in FUNCTION %s at %L", sym->name,
810 gfc_typename (ts), ns->entries->sym->name,
817 proc->attr.access = ACCESS_PRIVATE;
818 proc->attr.entry_master = 1;
820 /* Merge all the entry point arguments. */
821 for (el = ns->entries; el; el = el->next)
822 merge_argument_lists (proc, el->sym->formal);
824 /* Check the master formal arguments for any that are not
825 present in all entry points. */
826 for (el = ns->entries; el; el = el->next)
827 check_argument_lists (proc, el->sym->formal);
829 /* Use the master function for the function body. */
830 ns->proc_name = proc;
832 /* Finalize the new symbols. */
833 gfc_commit_symbols ();
835 /* Restore the original namespace. */
836 gfc_current_ns = old_ns;
840 /* Resolve common variables. */
842 resolve_common_vars (gfc_symbol *sym, bool named_common)
844 gfc_symbol *csym = sym;
846 for (; csym; csym = csym->common_next)
848 if (csym->value || csym->attr.data)
850 if (!csym->ns->is_block_data)
851 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
852 "but only in BLOCK DATA initialization is "
853 "allowed", csym->name, &csym->declared_at);
854 else if (!named_common)
855 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
856 "in a blank COMMON but initialization is only "
857 "allowed in named common blocks", csym->name,
861 if (csym->ts.type != BT_DERIVED)
864 if (!(csym->ts.u.derived->attr.sequence
865 || csym->ts.u.derived->attr.is_bind_c))
866 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
867 "has neither the SEQUENCE nor the BIND(C) "
868 "attribute", csym->name, &csym->declared_at);
869 if (csym->ts.u.derived->attr.alloc_comp)
870 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
871 "has an ultimate component that is "
872 "allocatable", csym->name, &csym->declared_at);
873 if (gfc_has_default_initializer (csym->ts.u.derived))
874 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
875 "may not have default initializer", csym->name,
878 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
879 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
883 /* Resolve common blocks. */
885 resolve_common_blocks (gfc_symtree *common_root)
889 if (common_root == NULL)
892 if (common_root->left)
893 resolve_common_blocks (common_root->left);
894 if (common_root->right)
895 resolve_common_blocks (common_root->right);
897 resolve_common_vars (common_root->n.common->head, true);
899 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
903 if (sym->attr.flavor == FL_PARAMETER)
904 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
905 sym->name, &common_root->n.common->where, &sym->declared_at);
907 if (sym->attr.external)
908 gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
909 sym->name, &common_root->n.common->where);
911 if (sym->attr.intrinsic)
912 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
913 sym->name, &common_root->n.common->where);
914 else if (sym->attr.result
915 || gfc_is_function_return_value (sym, gfc_current_ns))
916 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
917 "that is also a function result", sym->name,
918 &common_root->n.common->where);
919 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
920 && sym->attr.proc != PROC_ST_FUNCTION)
921 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
922 "that is also a global procedure", sym->name,
923 &common_root->n.common->where);
927 /* Resolve contained function types. Because contained functions can call one
928 another, they have to be worked out before any of the contained procedures
931 The good news is that if a function doesn't already have a type, the only
932 way it can get one is through an IMPLICIT type or a RESULT variable, because
933 by definition contained functions are contained namespace they're contained
934 in, not in a sibling or parent namespace. */
937 resolve_contained_functions (gfc_namespace *ns)
939 gfc_namespace *child;
942 resolve_formal_arglists (ns);
944 for (child = ns->contained; child; child = child->sibling)
946 /* Resolve alternate entry points first. */
947 resolve_entries (child);
949 /* Then check function return types. */
950 resolve_contained_fntype (child->proc_name, child);
951 for (el = child->entries; el; el = el->next)
952 resolve_contained_fntype (el->sym, child);
957 static gfc_try resolve_fl_derived0 (gfc_symbol *sym);
960 /* Resolve all of the elements of a structure constructor and make sure that
961 the types are correct. The 'init' flag indicates that the given
962 constructor is an initializer. */
965 resolve_structure_cons (gfc_expr *expr, int init)
967 gfc_constructor *cons;
974 if (expr->ts.type == BT_DERIVED)
975 resolve_fl_derived0 (expr->ts.u.derived);
977 cons = gfc_constructor_first (expr->value.constructor);
979 /* See if the user is trying to invoke a structure constructor for one of
980 the iso_c_binding derived types. */
981 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
982 && expr->ts.u.derived->ts.is_iso_c && cons
983 && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
985 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
986 expr->ts.u.derived->name, &(expr->where));
990 /* Return if structure constructor is c_null_(fun)prt. */
991 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
992 && expr->ts.u.derived->ts.is_iso_c && cons
993 && cons->expr && cons->expr->expr_type == EXPR_NULL)
996 /* A constructor may have references if it is the result of substituting a
997 parameter variable. In this case we just pull out the component we
1000 comp = expr->ref->u.c.sym->components;
1002 comp = expr->ts.u.derived->components;
1004 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1011 if (gfc_resolve_expr (cons->expr) == FAILURE)
1017 rank = comp->as ? comp->as->rank : 0;
1018 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
1019 && (comp->attr.allocatable || cons->expr->rank))
1021 gfc_error ("The rank of the element in the structure "
1022 "constructor at %L does not match that of the "
1023 "component (%d/%d)", &cons->expr->where,
1024 cons->expr->rank, rank);
1028 /* If we don't have the right type, try to convert it. */
1030 if (!comp->attr.proc_pointer &&
1031 !gfc_compare_types (&cons->expr->ts, &comp->ts))
1034 if (strcmp (comp->name, "_extends") == 0)
1036 /* Can afford to be brutal with the _extends initializer.
1037 The derived type can get lost because it is PRIVATE
1038 but it is not usage constrained by the standard. */
1039 cons->expr->ts = comp->ts;
1042 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1043 gfc_error ("The element in the structure constructor at %L, "
1044 "for pointer component '%s', is %s but should be %s",
1045 &cons->expr->where, comp->name,
1046 gfc_basic_typename (cons->expr->ts.type),
1047 gfc_basic_typename (comp->ts.type));
1049 t = gfc_convert_type (cons->expr, &comp->ts, 1);
1052 /* For strings, the length of the constructor should be the same as
1053 the one of the structure, ensure this if the lengths are known at
1054 compile time and when we are dealing with PARAMETER or structure
1056 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1057 && comp->ts.u.cl->length
1058 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1059 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1060 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1061 && cons->expr->rank != 0
1062 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1063 comp->ts.u.cl->length->value.integer) != 0)
1065 if (cons->expr->expr_type == EXPR_VARIABLE
1066 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1068 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1069 to make use of the gfc_resolve_character_array_constructor
1070 machinery. The expression is later simplified away to
1071 an array of string literals. */
1072 gfc_expr *para = cons->expr;
1073 cons->expr = gfc_get_expr ();
1074 cons->expr->ts = para->ts;
1075 cons->expr->where = para->where;
1076 cons->expr->expr_type = EXPR_ARRAY;
1077 cons->expr->rank = para->rank;
1078 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1079 gfc_constructor_append_expr (&cons->expr->value.constructor,
1080 para, &cons->expr->where);
1082 if (cons->expr->expr_type == EXPR_ARRAY)
1085 p = gfc_constructor_first (cons->expr->value.constructor);
1086 if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
1088 gfc_charlen *cl, *cl2;
1091 for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
1093 if (cl == cons->expr->ts.u.cl)
1101 cl2->next = cl->next;
1103 gfc_free_expr (cl->length);
1107 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1108 cons->expr->ts.u.cl->length_from_typespec = true;
1109 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1110 gfc_resolve_character_array_constructor (cons->expr);
1114 if (cons->expr->expr_type == EXPR_NULL
1115 && !(comp->attr.pointer || comp->attr.allocatable
1116 || comp->attr.proc_pointer
1117 || (comp->ts.type == BT_CLASS
1118 && (CLASS_DATA (comp)->attr.class_pointer
1119 || CLASS_DATA (comp)->attr.allocatable))))
1122 gfc_error ("The NULL in the structure constructor at %L is "
1123 "being applied to component '%s', which is neither "
1124 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1128 if (comp->attr.proc_pointer && comp->ts.interface)
1130 /* Check procedure pointer interface. */
1131 gfc_symbol *s2 = NULL;
1136 if (gfc_is_proc_ptr_comp (cons->expr, &c2))
1138 s2 = c2->ts.interface;
1141 else if (cons->expr->expr_type == EXPR_FUNCTION)
1143 s2 = cons->expr->symtree->n.sym->result;
1144 name = cons->expr->symtree->n.sym->result->name;
1146 else if (cons->expr->expr_type != EXPR_NULL)
1148 s2 = cons->expr->symtree->n.sym;
1149 name = cons->expr->symtree->n.sym->name;
1152 if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
1155 gfc_error ("Interface mismatch for procedure-pointer component "
1156 "'%s' in structure constructor at %L: %s",
1157 comp->name, &cons->expr->where, err);
1162 if (!comp->attr.pointer || comp->attr.proc_pointer
1163 || cons->expr->expr_type == EXPR_NULL)
1166 a = gfc_expr_attr (cons->expr);
1168 if (!a.pointer && !a.target)
1171 gfc_error ("The element in the structure constructor at %L, "
1172 "for pointer component '%s' should be a POINTER or "
1173 "a TARGET", &cons->expr->where, comp->name);
1178 /* F08:C461. Additional checks for pointer initialization. */
1182 gfc_error ("Pointer initialization target at %L "
1183 "must not be ALLOCATABLE ", &cons->expr->where);
1188 gfc_error ("Pointer initialization target at %L "
1189 "must have the SAVE attribute", &cons->expr->where);
1193 /* F2003, C1272 (3). */
1194 if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
1195 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1196 || gfc_is_coindexed (cons->expr)))
1199 gfc_error ("Invalid expression in the structure constructor for "
1200 "pointer component '%s' at %L in PURE procedure",
1201 comp->name, &cons->expr->where);
1204 if (gfc_implicit_pure (NULL)
1205 && cons->expr->expr_type == EXPR_VARIABLE
1206 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1207 || gfc_is_coindexed (cons->expr)))
1208 gfc_current_ns->proc_name->attr.implicit_pure = 0;
1216 /****************** Expression name resolution ******************/
1218 /* Returns 0 if a symbol was not declared with a type or
1219 attribute declaration statement, nonzero otherwise. */
1222 was_declared (gfc_symbol *sym)
1228 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1231 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1232 || a.optional || a.pointer || a.save || a.target || a.volatile_
1233 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1234 || a.asynchronous || a.codimension)
1241 /* Determine if a symbol is generic or not. */
1244 generic_sym (gfc_symbol *sym)
1248 if (sym->attr.generic ||
1249 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1252 if (was_declared (sym) || sym->ns->parent == NULL)
1255 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1262 return generic_sym (s);
1269 /* Determine if a symbol is specific or not. */
1272 specific_sym (gfc_symbol *sym)
1276 if (sym->attr.if_source == IFSRC_IFBODY
1277 || sym->attr.proc == PROC_MODULE
1278 || sym->attr.proc == PROC_INTERNAL
1279 || sym->attr.proc == PROC_ST_FUNCTION
1280 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1281 || sym->attr.external)
1284 if (was_declared (sym) || sym->ns->parent == NULL)
1287 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1289 return (s == NULL) ? 0 : specific_sym (s);
1293 /* Figure out if the procedure is specific, generic or unknown. */
1296 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1300 procedure_kind (gfc_symbol *sym)
1302 if (generic_sym (sym))
1303 return PTYPE_GENERIC;
1305 if (specific_sym (sym))
1306 return PTYPE_SPECIFIC;
1308 return PTYPE_UNKNOWN;
1311 /* Check references to assumed size arrays. The flag need_full_assumed_size
1312 is nonzero when matching actual arguments. */
1314 static int need_full_assumed_size = 0;
1317 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1319 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1322 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1323 What should it be? */
1324 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1325 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1326 && (e->ref->u.ar.type == AR_FULL))
1328 gfc_error ("The upper bound in the last dimension must "
1329 "appear in the reference to the assumed size "
1330 "array '%s' at %L", sym->name, &e->where);
1337 /* Look for bad assumed size array references in argument expressions
1338 of elemental and array valued intrinsic procedures. Since this is
1339 called from procedure resolution functions, it only recurses at
1343 resolve_assumed_size_actual (gfc_expr *e)
1348 switch (e->expr_type)
1351 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1356 if (resolve_assumed_size_actual (e->value.op.op1)
1357 || resolve_assumed_size_actual (e->value.op.op2))
1368 /* Check a generic procedure, passed as an actual argument, to see if
1369 there is a matching specific name. If none, it is an error, and if
1370 more than one, the reference is ambiguous. */
1372 count_specific_procs (gfc_expr *e)
1379 sym = e->symtree->n.sym;
1381 for (p = sym->generic; p; p = p->next)
1382 if (strcmp (sym->name, p->sym->name) == 0)
1384 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1390 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1394 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1395 "argument at %L", sym->name, &e->where);
1401 /* See if a call to sym could possibly be a not allowed RECURSION because of
1402 a missing RECURIVE declaration. This means that either sym is the current
1403 context itself, or sym is the parent of a contained procedure calling its
1404 non-RECURSIVE containing procedure.
1405 This also works if sym is an ENTRY. */
1408 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1410 gfc_symbol* proc_sym;
1411 gfc_symbol* context_proc;
1412 gfc_namespace* real_context;
1414 if (sym->attr.flavor == FL_PROGRAM
1415 || sym->attr.flavor == FL_DERIVED)
1418 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1420 /* If we've got an ENTRY, find real procedure. */
1421 if (sym->attr.entry && sym->ns->entries)
1422 proc_sym = sym->ns->entries->sym;
1426 /* If sym is RECURSIVE, all is well of course. */
1427 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1430 /* Find the context procedure's "real" symbol if it has entries.
1431 We look for a procedure symbol, so recurse on the parents if we don't
1432 find one (like in case of a BLOCK construct). */
1433 for (real_context = context; ; real_context = real_context->parent)
1435 /* We should find something, eventually! */
1436 gcc_assert (real_context);
1438 context_proc = (real_context->entries ? real_context->entries->sym
1439 : real_context->proc_name);
1441 /* In some special cases, there may not be a proc_name, like for this
1443 real(bad_kind()) function foo () ...
1444 when checking the call to bad_kind ().
1445 In these cases, we simply return here and assume that the
1450 if (context_proc->attr.flavor != FL_LABEL)
1454 /* A call from sym's body to itself is recursion, of course. */
1455 if (context_proc == proc_sym)
1458 /* The same is true if context is a contained procedure and sym the
1460 if (context_proc->attr.contained)
1462 gfc_symbol* parent_proc;
1464 gcc_assert (context->parent);
1465 parent_proc = (context->parent->entries ? context->parent->entries->sym
1466 : context->parent->proc_name);
1468 if (parent_proc == proc_sym)
1476 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1477 its typespec and formal argument list. */
1480 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1482 gfc_intrinsic_sym* isym = NULL;
1488 /* Already resolved. */
1489 if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
1492 /* We already know this one is an intrinsic, so we don't call
1493 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1494 gfc_find_subroutine directly to check whether it is a function or
1497 if (sym->intmod_sym_id)
1498 isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
1500 isym = gfc_find_function (sym->name);
1504 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1505 && !sym->attr.implicit_type)
1506 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1507 " ignored", sym->name, &sym->declared_at);
1509 if (!sym->attr.function &&
1510 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1515 else if ((isym = gfc_find_subroutine (sym->name)))
1517 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1519 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1520 " specifier", sym->name, &sym->declared_at);
1524 if (!sym->attr.subroutine &&
1525 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1530 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1535 gfc_copy_formal_args_intr (sym, isym);
1537 /* Check it is actually available in the standard settings. */
1538 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1541 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1542 " available in the current standard settings but %s. Use"
1543 " an appropriate -std=* option or enable -fall-intrinsics"
1544 " in order to use it.",
1545 sym->name, &sym->declared_at, symstd);
1553 /* Resolve a procedure expression, like passing it to a called procedure or as
1554 RHS for a procedure pointer assignment. */
1557 resolve_procedure_expression (gfc_expr* expr)
1561 if (expr->expr_type != EXPR_VARIABLE)
1563 gcc_assert (expr->symtree);
1565 sym = expr->symtree->n.sym;
1567 if (sym->attr.intrinsic)
1568 resolve_intrinsic (sym, &expr->where);
1570 if (sym->attr.flavor != FL_PROCEDURE
1571 || (sym->attr.function && sym->result == sym))
1574 /* A non-RECURSIVE procedure that is used as procedure expression within its
1575 own body is in danger of being called recursively. */
1576 if (is_illegal_recursion (sym, gfc_current_ns))
1577 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1578 " itself recursively. Declare it RECURSIVE or use"
1579 " -frecursive", sym->name, &expr->where);
1586 symbol_as (gfc_symbol *sym)
1588 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
1589 return CLASS_DATA (sym)->as;
1595 /* Resolve an actual argument list. Most of the time, this is just
1596 resolving the expressions in the list.
1597 The exception is that we sometimes have to decide whether arguments
1598 that look like procedure arguments are really simple variable
1602 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1603 bool no_formal_args)
1606 gfc_symtree *parent_st;
1608 int save_need_full_assumed_size;
1610 for (; arg; arg = arg->next)
1615 /* Check the label is a valid branching target. */
1618 if (arg->label->defined == ST_LABEL_UNKNOWN)
1620 gfc_error ("Label %d referenced at %L is never defined",
1621 arg->label->value, &arg->label->where);
1628 if (e->expr_type == EXPR_VARIABLE
1629 && e->symtree->n.sym->attr.generic
1631 && count_specific_procs (e) != 1)
1634 if (e->ts.type != BT_PROCEDURE)
1636 save_need_full_assumed_size = need_full_assumed_size;
1637 if (e->expr_type != EXPR_VARIABLE)
1638 need_full_assumed_size = 0;
1639 if (gfc_resolve_expr (e) != SUCCESS)
1641 need_full_assumed_size = save_need_full_assumed_size;
1645 /* See if the expression node should really be a variable reference. */
1647 sym = e->symtree->n.sym;
1649 if (sym->attr.flavor == FL_PROCEDURE
1650 || sym->attr.intrinsic
1651 || sym->attr.external)
1655 /* If a procedure is not already determined to be something else
1656 check if it is intrinsic. */
1657 if (!sym->attr.intrinsic
1658 && !(sym->attr.external || sym->attr.use_assoc
1659 || sym->attr.if_source == IFSRC_IFBODY)
1660 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1661 sym->attr.intrinsic = 1;
1663 if (sym->attr.proc == PROC_ST_FUNCTION)
1665 gfc_error ("Statement function '%s' at %L is not allowed as an "
1666 "actual argument", sym->name, &e->where);
1669 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1670 sym->attr.subroutine);
1671 if (sym->attr.intrinsic && actual_ok == 0)
1673 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1674 "actual argument", sym->name, &e->where);
1677 if (sym->attr.contained && !sym->attr.use_assoc
1678 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1680 if (gfc_notify_std (GFC_STD_F2008,
1681 "Fortran 2008: Internal procedure '%s' is"
1682 " used as actual argument at %L",
1683 sym->name, &e->where) == FAILURE)
1687 if (sym->attr.elemental && !sym->attr.intrinsic)
1689 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1690 "allowed as an actual argument at %L", sym->name,
1694 /* Check if a generic interface has a specific procedure
1695 with the same name before emitting an error. */
1696 if (sym->attr.generic && count_specific_procs (e) != 1)
1699 /* Just in case a specific was found for the expression. */
1700 sym = e->symtree->n.sym;
1702 /* If the symbol is the function that names the current (or
1703 parent) scope, then we really have a variable reference. */
1705 if (gfc_is_function_return_value (sym, sym->ns))
1708 /* If all else fails, see if we have a specific intrinsic. */
1709 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1711 gfc_intrinsic_sym *isym;
1713 isym = gfc_find_function (sym->name);
1714 if (isym == NULL || !isym->specific)
1716 gfc_error ("Unable to find a specific INTRINSIC procedure "
1717 "for the reference '%s' at %L", sym->name,
1722 sym->attr.intrinsic = 1;
1723 sym->attr.function = 1;
1726 if (gfc_resolve_expr (e) == FAILURE)
1731 /* See if the name is a module procedure in a parent unit. */
1733 if (was_declared (sym) || sym->ns->parent == NULL)
1736 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1738 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1742 if (parent_st == NULL)
1745 sym = parent_st->n.sym;
1746 e->symtree = parent_st; /* Point to the right thing. */
1748 if (sym->attr.flavor == FL_PROCEDURE
1749 || sym->attr.intrinsic
1750 || sym->attr.external)
1752 if (gfc_resolve_expr (e) == FAILURE)
1758 e->expr_type = EXPR_VARIABLE;
1760 if ((sym->as != NULL && sym->ts.type != BT_CLASS)
1761 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
1762 && CLASS_DATA (sym)->as))
1764 e->rank = sym->ts.type == BT_CLASS
1765 ? CLASS_DATA (sym)->as->rank : sym->as->rank;
1766 e->ref = gfc_get_ref ();
1767 e->ref->type = REF_ARRAY;
1768 e->ref->u.ar.type = AR_FULL;
1769 e->ref->u.ar.as = sym->ts.type == BT_CLASS
1770 ? CLASS_DATA (sym)->as : sym->as;
1773 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1774 primary.c (match_actual_arg). If above code determines that it
1775 is a variable instead, it needs to be resolved as it was not
1776 done at the beginning of this function. */
1777 save_need_full_assumed_size = need_full_assumed_size;
1778 if (e->expr_type != EXPR_VARIABLE)
1779 need_full_assumed_size = 0;
1780 if (gfc_resolve_expr (e) != SUCCESS)
1782 need_full_assumed_size = save_need_full_assumed_size;
1785 /* Check argument list functions %VAL, %LOC and %REF. There is
1786 nothing to do for %REF. */
1787 if (arg->name && arg->name[0] == '%')
1789 if (strncmp ("%VAL", arg->name, 4) == 0)
1791 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1793 gfc_error ("By-value argument at %L is not of numeric "
1800 gfc_error ("By-value argument at %L cannot be an array or "
1801 "an array section", &e->where);
1805 /* Intrinsics are still PROC_UNKNOWN here. However,
1806 since same file external procedures are not resolvable
1807 in gfortran, it is a good deal easier to leave them to
1809 if (ptype != PROC_UNKNOWN
1810 && ptype != PROC_DUMMY
1811 && ptype != PROC_EXTERNAL
1812 && ptype != PROC_MODULE)
1814 gfc_error ("By-value argument at %L is not allowed "
1815 "in this context", &e->where);
1820 /* Statement functions have already been excluded above. */
1821 else if (strncmp ("%LOC", arg->name, 4) == 0
1822 && e->ts.type == BT_PROCEDURE)
1824 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1826 gfc_error ("Passing internal procedure at %L by location "
1827 "not allowed", &e->where);
1833 /* Fortran 2008, C1237. */
1834 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1835 && gfc_has_ultimate_pointer (e))
1837 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1838 "component", &e->where);
1847 /* Do the checks of the actual argument list that are specific to elemental
1848 procedures. If called with c == NULL, we have a function, otherwise if
1849 expr == NULL, we have a subroutine. */
1852 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1854 gfc_actual_arglist *arg0;
1855 gfc_actual_arglist *arg;
1856 gfc_symbol *esym = NULL;
1857 gfc_intrinsic_sym *isym = NULL;
1859 gfc_intrinsic_arg *iformal = NULL;
1860 gfc_formal_arglist *eformal = NULL;
1861 bool formal_optional = false;
1862 bool set_by_optional = false;
1866 /* Is this an elemental procedure? */
1867 if (expr && expr->value.function.actual != NULL)
1869 if (expr->value.function.esym != NULL
1870 && expr->value.function.esym->attr.elemental)
1872 arg0 = expr->value.function.actual;
1873 esym = expr->value.function.esym;
1875 else if (expr->value.function.isym != NULL
1876 && expr->value.function.isym->elemental)
1878 arg0 = expr->value.function.actual;
1879 isym = expr->value.function.isym;
1884 else if (c && c->ext.actual != NULL)
1886 arg0 = c->ext.actual;
1888 if (c->resolved_sym)
1889 esym = c->resolved_sym;
1891 esym = c->symtree->n.sym;
1894 if (!esym->attr.elemental)
1900 /* The rank of an elemental is the rank of its array argument(s). */
1901 for (arg = arg0; arg; arg = arg->next)
1903 if (arg->expr != NULL && arg->expr->rank > 0)
1905 rank = arg->expr->rank;
1906 if (arg->expr->expr_type == EXPR_VARIABLE
1907 && arg->expr->symtree->n.sym->attr.optional)
1908 set_by_optional = true;
1910 /* Function specific; set the result rank and shape. */
1914 if (!expr->shape && arg->expr->shape)
1916 expr->shape = gfc_get_shape (rank);
1917 for (i = 0; i < rank; i++)
1918 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1925 /* If it is an array, it shall not be supplied as an actual argument
1926 to an elemental procedure unless an array of the same rank is supplied
1927 as an actual argument corresponding to a nonoptional dummy argument of
1928 that elemental procedure(12.4.1.5). */
1929 formal_optional = false;
1931 iformal = isym->formal;
1933 eformal = esym->formal;
1935 for (arg = arg0; arg; arg = arg->next)
1939 if (eformal->sym && eformal->sym->attr.optional)
1940 formal_optional = true;
1941 eformal = eformal->next;
1943 else if (isym && iformal)
1945 if (iformal->optional)
1946 formal_optional = true;
1947 iformal = iformal->next;
1950 formal_optional = true;
1952 if (pedantic && arg->expr != NULL
1953 && arg->expr->expr_type == EXPR_VARIABLE
1954 && arg->expr->symtree->n.sym->attr.optional
1957 && (set_by_optional || arg->expr->rank != rank)
1958 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1960 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1961 "MISSING, it cannot be the actual argument of an "
1962 "ELEMENTAL procedure unless there is a non-optional "
1963 "argument with the same rank (12.4.1.5)",
1964 arg->expr->symtree->n.sym->name, &arg->expr->where);
1969 for (arg = arg0; arg; arg = arg->next)
1971 if (arg->expr == NULL || arg->expr->rank == 0)
1974 /* Being elemental, the last upper bound of an assumed size array
1975 argument must be present. */
1976 if (resolve_assumed_size_actual (arg->expr))
1979 /* Elemental procedure's array actual arguments must conform. */
1982 if (gfc_check_conformance (arg->expr, e,
1983 "elemental procedure") == FAILURE)
1990 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1991 is an array, the intent inout/out variable needs to be also an array. */
1992 if (rank > 0 && esym && expr == NULL)
1993 for (eformal = esym->formal, arg = arg0; arg && eformal;
1994 arg = arg->next, eformal = eformal->next)
1995 if ((eformal->sym->attr.intent == INTENT_OUT
1996 || eformal->sym->attr.intent == INTENT_INOUT)
1997 && arg->expr && arg->expr->rank == 0)
1999 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
2000 "ELEMENTAL subroutine '%s' is a scalar, but another "
2001 "actual argument is an array", &arg->expr->where,
2002 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
2003 : "INOUT", eformal->sym->name, esym->name);
2010 /* This function does the checking of references to global procedures
2011 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2012 77 and 95 standards. It checks for a gsymbol for the name, making
2013 one if it does not already exist. If it already exists, then the
2014 reference being resolved must correspond to the type of gsymbol.
2015 Otherwise, the new symbol is equipped with the attributes of the
2016 reference. The corresponding code that is called in creating
2017 global entities is parse.c.
2019 In addition, for all but -std=legacy, the gsymbols are used to
2020 check the interfaces of external procedures from the same file.
2021 The namespace of the gsymbol is resolved and then, once this is
2022 done the interface is checked. */
2026 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2028 if (!gsym_ns->proc_name->attr.recursive)
2031 if (sym->ns == gsym_ns)
2034 if (sym->ns->parent && sym->ns->parent == gsym_ns)
2041 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
2043 if (gsym_ns->entries)
2045 gfc_entry_list *entry = gsym_ns->entries;
2047 for (; entry; entry = entry->next)
2049 if (strcmp (sym->name, entry->sym->name) == 0)
2051 if (strcmp (gsym_ns->proc_name->name,
2052 sym->ns->proc_name->name) == 0)
2056 && strcmp (gsym_ns->proc_name->name,
2057 sym->ns->parent->proc_name->name) == 0)
2066 resolve_global_procedure (gfc_symbol *sym, locus *where,
2067 gfc_actual_arglist **actual, int sub)
2071 enum gfc_symbol_type type;
2073 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2075 gsym = gfc_get_gsymbol (sym->name);
2077 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2078 gfc_global_used (gsym, where);
2080 if (gfc_option.flag_whole_file
2081 && (sym->attr.if_source == IFSRC_UNKNOWN
2082 || sym->attr.if_source == IFSRC_IFBODY)
2083 && gsym->type != GSYM_UNKNOWN
2085 && gsym->ns->resolved != -1
2086 && gsym->ns->proc_name
2087 && not_in_recursive (sym, gsym->ns)
2088 && not_entry_self_reference (sym, gsym->ns))
2090 gfc_symbol *def_sym;
2092 /* Resolve the gsymbol namespace if needed. */
2093 if (!gsym->ns->resolved)
2095 gfc_dt_list *old_dt_list;
2096 struct gfc_omp_saved_state old_omp_state;
2098 /* Stash away derived types so that the backend_decls do not
2100 old_dt_list = gfc_derived_types;
2101 gfc_derived_types = NULL;
2102 /* And stash away openmp state. */
2103 gfc_omp_save_and_clear_state (&old_omp_state);
2105 gfc_resolve (gsym->ns);
2107 /* Store the new derived types with the global namespace. */
2108 if (gfc_derived_types)
2109 gsym->ns->derived_types = gfc_derived_types;
2111 /* Restore the derived types of this namespace. */
2112 gfc_derived_types = old_dt_list;
2113 /* And openmp state. */
2114 gfc_omp_restore_state (&old_omp_state);
2117 /* Make sure that translation for the gsymbol occurs before
2118 the procedure currently being resolved. */
2119 ns = gfc_global_ns_list;
2120 for (; ns && ns != gsym->ns; ns = ns->sibling)
2122 if (ns->sibling == gsym->ns)
2124 ns->sibling = gsym->ns->sibling;
2125 gsym->ns->sibling = gfc_global_ns_list;
2126 gfc_global_ns_list = gsym->ns;
2131 def_sym = gsym->ns->proc_name;
2132 if (def_sym->attr.entry_master)
2134 gfc_entry_list *entry;
2135 for (entry = gsym->ns->entries; entry; entry = entry->next)
2136 if (strcmp (entry->sym->name, sym->name) == 0)
2138 def_sym = entry->sym;
2143 /* Differences in constant character lengths. */
2144 if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2146 long int l1 = 0, l2 = 0;
2147 gfc_charlen *cl1 = sym->ts.u.cl;
2148 gfc_charlen *cl2 = def_sym->ts.u.cl;
2151 && cl1->length != NULL
2152 && cl1->length->expr_type == EXPR_CONSTANT)
2153 l1 = mpz_get_si (cl1->length->value.integer);
2156 && cl2->length != NULL
2157 && cl2->length->expr_type == EXPR_CONSTANT)
2158 l2 = mpz_get_si (cl2->length->value.integer);
2160 if (l1 && l2 && l1 != l2)
2161 gfc_error ("Character length mismatch in return type of "
2162 "function '%s' at %L (%ld/%ld)", sym->name,
2163 &sym->declared_at, l1, l2);
2166 /* Type mismatch of function return type and expected type. */
2167 if (sym->attr.function
2168 && !gfc_compare_types (&sym->ts, &def_sym->ts))
2169 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2170 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2171 gfc_typename (&def_sym->ts));
2173 if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2175 gfc_formal_arglist *arg = def_sym->formal;
2176 for ( ; arg; arg = arg->next)
2179 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2180 else if (arg->sym->attr.allocatable
2181 || arg->sym->attr.asynchronous
2182 || arg->sym->attr.optional
2183 || arg->sym->attr.pointer
2184 || arg->sym->attr.target
2185 || arg->sym->attr.value
2186 || arg->sym->attr.volatile_)
2188 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2189 "has an attribute that requires an explicit "
2190 "interface for this procedure", arg->sym->name,
2191 sym->name, &sym->declared_at);
2194 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2195 else if (arg->sym && arg->sym->as
2196 && arg->sym->as->type == AS_ASSUMED_SHAPE)
2198 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2199 "argument '%s' must have an explicit interface",
2200 sym->name, &sym->declared_at, arg->sym->name);
2203 /* F2008, 12.4.2.2 (2c) */
2204 else if (arg->sym->attr.codimension)
2206 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2207 "'%s' must have an explicit interface",
2208 sym->name, &sym->declared_at, arg->sym->name);
2211 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2212 else if (false) /* TODO: is a parametrized derived type */
2214 gfc_error ("Procedure '%s' at %L with parametrized derived "
2215 "type argument '%s' must have an explicit "
2216 "interface", sym->name, &sym->declared_at,
2220 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2221 else if (arg->sym->ts.type == BT_CLASS)
2223 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2224 "argument '%s' must have an explicit interface",
2225 sym->name, &sym->declared_at, arg->sym->name);
2230 if (def_sym->attr.function)
2232 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2233 if (def_sym->as && def_sym->as->rank
2234 && (!sym->as || sym->as->rank != def_sym->as->rank))
2235 gfc_error ("The reference to function '%s' at %L either needs an "
2236 "explicit INTERFACE or the rank is incorrect", sym->name,
2239 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2240 if ((def_sym->result->attr.pointer
2241 || def_sym->result->attr.allocatable)
2242 && (sym->attr.if_source != IFSRC_IFBODY
2243 || def_sym->result->attr.pointer
2244 != sym->result->attr.pointer
2245 || def_sym->result->attr.allocatable
2246 != sym->result->attr.allocatable))
2247 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2248 "result must have an explicit interface", sym->name,
2251 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2252 if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2253 && def_sym->ts.type == BT_CHARACTER && def_sym->ts.u.cl->length != NULL)
2255 gfc_charlen *cl = sym->ts.u.cl;
2257 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2258 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2260 gfc_error ("Nonconstant character-length function '%s' at %L "
2261 "must have an explicit interface", sym->name,
2267 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2268 if (def_sym->attr.elemental && !sym->attr.elemental)
2270 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2271 "interface", sym->name, &sym->declared_at);
2274 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2275 if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2277 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2278 "an explicit interface", sym->name, &sym->declared_at);
2281 if (gfc_option.flag_whole_file == 1
2282 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2283 && !(gfc_option.warn_std & GFC_STD_GNU)))
2284 gfc_errors_to_warnings (1);
2286 if (sym->attr.if_source != IFSRC_IFBODY)
2287 gfc_procedure_use (def_sym, actual, where);
2289 gfc_errors_to_warnings (0);
2292 if (gsym->type == GSYM_UNKNOWN)
2295 gsym->where = *where;
2302 /************* Function resolution *************/
2304 /* Resolve a function call known to be generic.
2305 Section 14.1.2.4.1. */
2308 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2312 if (sym->attr.generic)
2314 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2317 expr->value.function.name = s->name;
2318 expr->value.function.esym = s;
2320 if (s->ts.type != BT_UNKNOWN)
2322 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2323 expr->ts = s->result->ts;
2326 expr->rank = s->as->rank;
2327 else if (s->result != NULL && s->result->as != NULL)
2328 expr->rank = s->result->as->rank;
2330 gfc_set_sym_referenced (expr->value.function.esym);
2335 /* TODO: Need to search for elemental references in generic
2339 if (sym->attr.intrinsic)
2340 return gfc_intrinsic_func_interface (expr, 0);
2347 resolve_generic_f (gfc_expr *expr)
2351 gfc_interface *intr = NULL;
2353 sym = expr->symtree->n.sym;
2357 m = resolve_generic_f0 (expr, sym);
2360 else if (m == MATCH_ERROR)
2365 for (intr = sym->generic; intr; intr = intr->next)
2366 if (intr->sym->attr.flavor == FL_DERIVED)
2369 if (sym->ns->parent == NULL)
2371 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2375 if (!generic_sym (sym))
2379 /* Last ditch attempt. See if the reference is to an intrinsic
2380 that possesses a matching interface. 14.1.2.4 */
2381 if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
2383 gfc_error ("There is no specific function for the generic '%s' "
2384 "at %L", expr->symtree->n.sym->name, &expr->where);
2390 if (gfc_convert_to_structure_constructor (expr, intr->sym, NULL, NULL,
2393 return resolve_structure_cons (expr, 0);
2396 m = gfc_intrinsic_func_interface (expr, 0);
2401 gfc_error ("Generic function '%s' at %L is not consistent with a "
2402 "specific intrinsic interface", expr->symtree->n.sym->name,
2409 /* Resolve a function call known to be specific. */
2412 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2416 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2418 if (sym->attr.dummy)
2420 sym->attr.proc = PROC_DUMMY;
2424 sym->attr.proc = PROC_EXTERNAL;
2428 if (sym->attr.proc == PROC_MODULE
2429 || sym->attr.proc == PROC_ST_FUNCTION
2430 || sym->attr.proc == PROC_INTERNAL)
2433 if (sym->attr.intrinsic)
2435 m = gfc_intrinsic_func_interface (expr, 1);
2439 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2440 "with an intrinsic", sym->name, &expr->where);
2448 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2451 expr->ts = sym->result->ts;
2454 expr->value.function.name = sym->name;
2455 expr->value.function.esym = sym;
2456 if (sym->as != NULL)
2457 expr->rank = sym->as->rank;
2464 resolve_specific_f (gfc_expr *expr)
2469 sym = expr->symtree->n.sym;
2473 m = resolve_specific_f0 (sym, expr);
2476 if (m == MATCH_ERROR)
2479 if (sym->ns->parent == NULL)
2482 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2488 gfc_error ("Unable to resolve the specific function '%s' at %L",
2489 expr->symtree->n.sym->name, &expr->where);
2495 /* Resolve a procedure call not known to be generic nor specific. */
2498 resolve_unknown_f (gfc_expr *expr)
2503 sym = expr->symtree->n.sym;
2505 if (sym->attr.dummy)
2507 sym->attr.proc = PROC_DUMMY;
2508 expr->value.function.name = sym->name;
2512 /* See if we have an intrinsic function reference. */
2514 if (gfc_is_intrinsic (sym, 0, expr->where))
2516 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2521 /* The reference is to an external name. */
2523 sym->attr.proc = PROC_EXTERNAL;
2524 expr->value.function.name = sym->name;
2525 expr->value.function.esym = expr->symtree->n.sym;
2527 if (sym->as != NULL)
2528 expr->rank = sym->as->rank;
2530 /* Type of the expression is either the type of the symbol or the
2531 default type of the symbol. */
2534 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2536 if (sym->ts.type != BT_UNKNOWN)
2540 ts = gfc_get_default_type (sym->name, sym->ns);
2542 if (ts->type == BT_UNKNOWN)
2544 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2545 sym->name, &expr->where);
2556 /* Return true, if the symbol is an external procedure. */
2558 is_external_proc (gfc_symbol *sym)
2560 if (!sym->attr.dummy && !sym->attr.contained
2561 && !(sym->attr.intrinsic
2562 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2563 && sym->attr.proc != PROC_ST_FUNCTION
2564 && !sym->attr.proc_pointer
2565 && !sym->attr.use_assoc
2573 /* Figure out if a function reference is pure or not. Also set the name
2574 of the function for a potential error message. Return nonzero if the
2575 function is PURE, zero if not. */
2577 pure_stmt_function (gfc_expr *, gfc_symbol *);
2580 pure_function (gfc_expr *e, const char **name)
2586 if (e->symtree != NULL
2587 && e->symtree->n.sym != NULL
2588 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2589 return pure_stmt_function (e, e->symtree->n.sym);
2591 if (e->value.function.esym)
2593 pure = gfc_pure (e->value.function.esym);
2594 *name = e->value.function.esym->name;
2596 else if (e->value.function.isym)
2598 pure = e->value.function.isym->pure
2599 || e->value.function.isym->elemental;
2600 *name = e->value.function.isym->name;
2604 /* Implicit functions are not pure. */
2606 *name = e->value.function.name;
2614 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2615 int *f ATTRIBUTE_UNUSED)
2619 /* Don't bother recursing into other statement functions
2620 since they will be checked individually for purity. */
2621 if (e->expr_type != EXPR_FUNCTION
2623 || e->symtree->n.sym == sym
2624 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2627 return pure_function (e, &name) ? false : true;
2632 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2634 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2639 is_scalar_expr_ptr (gfc_expr *expr)
2641 gfc_try retval = SUCCESS;
2646 /* See if we have a gfc_ref, which means we have a substring, array
2647 reference, or a component. */
2648 if (expr->ref != NULL)
2651 while (ref->next != NULL)
2657 if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
2658 || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
2663 if (ref->u.ar.type == AR_ELEMENT)
2665 else if (ref->u.ar.type == AR_FULL)
2667 /* The user can give a full array if the array is of size 1. */
2668 if (ref->u.ar.as != NULL
2669 && ref->u.ar.as->rank == 1
2670 && ref->u.ar.as->type == AS_EXPLICIT
2671 && ref->u.ar.as->lower[0] != NULL
2672 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2673 && ref->u.ar.as->upper[0] != NULL
2674 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2676 /* If we have a character string, we need to check if
2677 its length is one. */
2678 if (expr->ts.type == BT_CHARACTER)
2680 if (expr->ts.u.cl == NULL
2681 || expr->ts.u.cl->length == NULL
2682 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2688 /* We have constant lower and upper bounds. If the
2689 difference between is 1, it can be considered a
2691 FIXME: Use gfc_dep_compare_expr instead. */
2692 start = (int) mpz_get_si
2693 (ref->u.ar.as->lower[0]->value.integer);
2694 end = (int) mpz_get_si
2695 (ref->u.ar.as->upper[0]->value.integer);
2696 if (end - start + 1 != 1)
2711 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2713 /* Character string. Make sure it's of length 1. */
2714 if (expr->ts.u.cl == NULL
2715 || expr->ts.u.cl->length == NULL
2716 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2719 else if (expr->rank != 0)
2726 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2727 and, in the case of c_associated, set the binding label based on
2731 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2732 gfc_symbol **new_sym)
2734 char name[GFC_MAX_SYMBOL_LEN + 1];
2735 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2736 int optional_arg = 0;
2737 gfc_try retval = SUCCESS;
2738 gfc_symbol *args_sym;
2739 gfc_typespec *arg_ts;
2740 symbol_attribute arg_attr;
2742 if (args->expr->expr_type == EXPR_CONSTANT
2743 || args->expr->expr_type == EXPR_OP
2744 || args->expr->expr_type == EXPR_NULL)
2746 gfc_error ("Argument to '%s' at %L is not a variable",
2747 sym->name, &(args->expr->where));
2751 args_sym = args->expr->symtree->n.sym;
2753 /* The typespec for the actual arg should be that stored in the expr
2754 and not necessarily that of the expr symbol (args_sym), because
2755 the actual expression could be a part-ref of the expr symbol. */
2756 arg_ts = &(args->expr->ts);
2757 arg_attr = gfc_expr_attr (args->expr);
2759 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2761 /* If the user gave two args then they are providing something for
2762 the optional arg (the second cptr). Therefore, set the name and
2763 binding label to the c_associated for two cptrs. Otherwise,
2764 set c_associated to expect one cptr. */
2768 sprintf (name, "%s_2", sym->name);
2769 sprintf (binding_label, "%s_2", sym->binding_label);
2775 sprintf (name, "%s_1", sym->name);
2776 sprintf (binding_label, "%s_1", sym->binding_label);
2780 /* Get a new symbol for the version of c_associated that
2782 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2784 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2785 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2787 sprintf (name, "%s", sym->name);
2788 sprintf (binding_label, "%s", sym->binding_label);
2790 /* Error check the call. */
2791 if (args->next != NULL)
2793 gfc_error_now ("More actual than formal arguments in '%s' "
2794 "call at %L", name, &(args->expr->where));
2797 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2802 /* Make sure we have either the target or pointer attribute. */
2803 if (!arg_attr.target && !arg_attr.pointer)
2805 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2806 "a TARGET or an associated pointer",
2808 sym->name, &(args->expr->where));
2812 if (gfc_is_coindexed (args->expr))
2814 gfc_error_now ("Coindexed argument not permitted"
2815 " in '%s' call at %L", name,
2816 &(args->expr->where));
2820 /* Follow references to make sure there are no array
2822 seen_section = false;
2824 for (ref=args->expr->ref; ref; ref = ref->next)
2826 if (ref->type == REF_ARRAY)
2828 if (ref->u.ar.type == AR_SECTION)
2829 seen_section = true;
2831 if (ref->u.ar.type != AR_ELEMENT)
2834 for (r = ref->next; r; r=r->next)
2835 if (r->type == REF_COMPONENT)
2837 gfc_error_now ("Array section not permitted"
2838 " in '%s' call at %L", name,
2839 &(args->expr->where));
2847 if (seen_section && retval == SUCCESS)
2848 gfc_warning ("Array section in '%s' call at %L", name,
2849 &(args->expr->where));
2851 /* See if we have interoperable type and type param. */
2852 if (gfc_verify_c_interop (arg_ts) == SUCCESS
2853 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2855 if (args_sym->attr.target == 1)
2857 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2858 has the target attribute and is interoperable. */
2859 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2860 allocatable variable that has the TARGET attribute and
2861 is not an array of zero size. */
2862 if (args_sym->attr.allocatable == 1)
2864 if (args_sym->attr.dimension != 0
2865 && (args_sym->as && args_sym->as->rank == 0))
2867 gfc_error_now ("Allocatable variable '%s' used as a "
2868 "parameter to '%s' at %L must not be "
2869 "an array of zero size",
2870 args_sym->name, sym->name,
2871 &(args->expr->where));
2877 /* A non-allocatable target variable with C
2878 interoperable type and type parameters must be
2880 if (args_sym && args_sym->attr.dimension)
2882 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2884 gfc_error ("Assumed-shape array '%s' at %L "
2885 "cannot be an argument to the "
2886 "procedure '%s' because "
2887 "it is not C interoperable",
2889 &(args->expr->where), sym->name);
2892 else if (args_sym->as->type == AS_DEFERRED)
2894 gfc_error ("Deferred-shape array '%s' at %L "
2895 "cannot be an argument to the "
2896 "procedure '%s' because "
2897 "it is not C interoperable",
2899 &(args->expr->where), sym->name);
2904 /* Make sure it's not a character string. Arrays of
2905 any type should be ok if the variable is of a C
2906 interoperable type. */
2907 if (arg_ts->type == BT_CHARACTER)
2908 if (arg_ts->u.cl != NULL
2909 && (arg_ts->u.cl->length == NULL
2910 || arg_ts->u.cl->length->expr_type
2913 (arg_ts->u.cl->length->value.integer, 1)
2915 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2917 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2918 "at %L must have a length of 1",
2919 args_sym->name, sym->name,
2920 &(args->expr->where));
2925 else if (arg_attr.pointer
2926 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2928 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2930 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2931 "associated scalar POINTER", args_sym->name,
2932 sym->name, &(args->expr->where));
2938 /* The parameter is not required to be C interoperable. If it
2939 is not C interoperable, it must be a nonpolymorphic scalar
2940 with no length type parameters. It still must have either
2941 the pointer or target attribute, and it can be
2942 allocatable (but must be allocated when c_loc is called). */
2943 if (args->expr->rank != 0
2944 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2946 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2947 "scalar", args_sym->name, sym->name,
2948 &(args->expr->where));
2951 else if (arg_ts->type == BT_CHARACTER
2952 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2954 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2955 "%L must have a length of 1",
2956 args_sym->name, sym->name,
2957 &(args->expr->where));
2960 else if (arg_ts->type == BT_CLASS)
2962 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2963 "polymorphic", args_sym->name, sym->name,
2964 &(args->expr->where));
2969 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2971 if (args_sym->attr.flavor != FL_PROCEDURE)
2973 /* TODO: Update this error message to allow for procedure
2974 pointers once they are implemented. */
2975 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2977 args_sym->name, sym->name,
2978 &(args->expr->where));
2981 else if (args_sym->attr.is_bind_c != 1)
2983 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2985 args_sym->name, sym->name,
2986 &(args->expr->where));
2991 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2996 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2997 "iso_c_binding function: '%s'!\n", sym->name);
3004 /* Resolve a function call, which means resolving the arguments, then figuring
3005 out which entity the name refers to. */
3008 resolve_function (gfc_expr *expr)
3010 gfc_actual_arglist *arg;
3015 procedure_type p = PROC_INTRINSIC;
3016 bool no_formal_args;
3020 sym = expr->symtree->n.sym;
3022 /* If this is a procedure pointer component, it has already been resolved. */
3023 if (gfc_is_proc_ptr_comp (expr, NULL))
3026 if (sym && sym->attr.intrinsic
3027 && resolve_intrinsic (sym, &expr->where) == FAILURE)
3030 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
3032 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
3036 /* If this ia a deferred TBP with an abstract interface (which may
3037 of course be referenced), expr->value.function.esym will be set. */
3038 if (sym && sym->attr.abstract && !expr->value.function.esym)
3040 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3041 sym->name, &expr->where);
3045 /* Switch off assumed size checking and do this again for certain kinds
3046 of procedure, once the procedure itself is resolved. */
3047 need_full_assumed_size++;
3049 if (expr->symtree && expr->symtree->n.sym)
3050 p = expr->symtree->n.sym->attr.proc;
3052 if (expr->value.function.isym && expr->value.function.isym->inquiry)
3053 inquiry_argument = true;
3054 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
3056 if (resolve_actual_arglist (expr->value.function.actual,
3057 p, no_formal_args) == FAILURE)
3059 inquiry_argument = false;
3063 inquiry_argument = false;
3065 /* Need to setup the call to the correct c_associated, depending on
3066 the number of cptrs to user gives to compare. */
3067 if (sym && sym->attr.is_iso_c == 1)
3069 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
3073 /* Get the symtree for the new symbol (resolved func).
3074 the old one will be freed later, when it's no longer used. */
3075 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
3078 /* Resume assumed_size checking. */
3079 need_full_assumed_size--;
3081 /* If the procedure is external, check for usage. */
3082 if (sym && is_external_proc (sym))
3083 resolve_global_procedure (sym, &expr->where,
3084 &expr->value.function.actual, 0);
3086 if (sym && sym->ts.type == BT_CHARACTER
3088 && sym->ts.u.cl->length == NULL
3090 && !sym->ts.deferred
3091 && expr->value.function.esym == NULL
3092 && !sym->attr.contained)
3094 /* Internal procedures are taken care of in resolve_contained_fntype. */
3095 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
3096 "be used at %L since it is not a dummy argument",
3097 sym->name, &expr->where);
3101 /* See if function is already resolved. */
3103 if (expr->value.function.name != NULL)
3105 if (expr->ts.type == BT_UNKNOWN)
3111 /* Apply the rules of section 14.1.2. */
3113 switch (procedure_kind (sym))
3116 t = resolve_generic_f (expr);
3119 case PTYPE_SPECIFIC:
3120 t = resolve_specific_f (expr);
3124 t = resolve_unknown_f (expr);
3128 gfc_internal_error ("resolve_function(): bad function type");
3132 /* If the expression is still a function (it might have simplified),
3133 then we check to see if we are calling an elemental function. */
3135 if (expr->expr_type != EXPR_FUNCTION)
3138 temp = need_full_assumed_size;
3139 need_full_assumed_size = 0;
3141 if (resolve_elemental_actual (expr, NULL) == FAILURE)
3144 if (omp_workshare_flag
3145 && expr->value.function.esym
3146 && ! gfc_elemental (expr->value.function.esym))
3148 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3149 "in WORKSHARE construct", expr->value.function.esym->name,
3154 #define GENERIC_ID expr->value.function.isym->id
3155 else if (expr->value.function.actual != NULL
3156 && expr->value.function.isym != NULL
3157 && GENERIC_ID != GFC_ISYM_LBOUND
3158 && GENERIC_ID != GFC_ISYM_LEN
3159 && GENERIC_ID != GFC_ISYM_LOC
3160 && GENERIC_ID != GFC_ISYM_PRESENT)
3162 /* Array intrinsics must also have the last upper bound of an
3163 assumed size array argument. UBOUND and SIZE have to be
3164 excluded from the check if the second argument is anything
3167 for (arg = expr->value.function.actual; arg; arg = arg->next)
3169 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3170 && arg->next != NULL && arg->next->expr)
3172 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3175 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3178 if ((int)mpz_get_si (arg->next->expr->value.integer)
3183 if (arg->expr != NULL
3184 && arg->expr->rank > 0
3185 && resolve_assumed_size_actual (arg->expr))
3191 need_full_assumed_size = temp;
3194 if (!pure_function (expr, &name) && name)
3198 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3199 "FORALL %s", name, &expr->where,
3200 forall_flag == 2 ? "mask" : "block");
3203 else if (do_concurrent_flag)
3205 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3206 "DO CONCURRENT %s", name, &expr->where,
3207 do_concurrent_flag == 2 ? "mask" : "block");
3210 else if (gfc_pure (NULL))
3212 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3213 "procedure within a PURE procedure", name, &expr->where);
3217 if (gfc_implicit_pure (NULL))
3218 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3221 /* Functions without the RECURSIVE attribution are not allowed to
3222 * call themselves. */
3223 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3226 esym = expr->value.function.esym;
3228 if (is_illegal_recursion (esym, gfc_current_ns))
3230 if (esym->attr.entry && esym->ns->entries)
3231 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3232 " function '%s' is not RECURSIVE",
3233 esym->name, &expr->where, esym->ns->entries->sym->name);
3235 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3236 " is not RECURSIVE", esym->name, &expr->where);
3242 /* Character lengths of use associated functions may contains references to
3243 symbols not referenced from the current program unit otherwise. Make sure
3244 those symbols are marked as referenced. */
3246 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3247 && expr->value.function.esym->attr.use_assoc)
3249 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3252 /* Make sure that the expression has a typespec that works. */
3253 if (expr->ts.type == BT_UNKNOWN)
3255 if (expr->symtree->n.sym->result
3256 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3257 && !expr->symtree->n.sym->result->attr.proc_pointer)
3258 expr->ts = expr->symtree->n.sym->result->ts;
3265 /************* Subroutine resolution *************/
3268 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3274 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3275 sym->name, &c->loc);
3276 else if (do_concurrent_flag)
3277 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3278 "PURE", sym->name, &c->loc);
3279 else if (gfc_pure (NULL))
3280 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3283 if (gfc_implicit_pure (NULL))
3284 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3289 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3293 if (sym->attr.generic)
3295 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3298 c->resolved_sym = s;
3299 pure_subroutine (c, s);
3303 /* TODO: Need to search for elemental references in generic interface. */
3306 if (sym->attr.intrinsic)
3307 return gfc_intrinsic_sub_interface (c, 0);
3314 resolve_generic_s (gfc_code *c)
3319 sym = c->symtree->n.sym;
3323 m = resolve_generic_s0 (c, sym);
3326 else if (m == MATCH_ERROR)
3330 if (sym->ns->parent == NULL)
3332 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3336 if (!generic_sym (sym))
3340 /* Last ditch attempt. See if the reference is to an intrinsic
3341 that possesses a matching interface. 14.1.2.4 */
3342 sym = c->symtree->n.sym;
3344 if (!gfc_is_intrinsic (sym, 1, c->loc))
3346 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3347 sym->name, &c->loc);
3351 m = gfc_intrinsic_sub_interface (c, 0);
3355 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3356 "intrinsic subroutine interface", sym->name, &c->loc);
3362 /* Set the name and binding label of the subroutine symbol in the call
3363 expression represented by 'c' to include the type and kind of the
3364 second parameter. This function is for resolving the appropriate
3365 version of c_f_pointer() and c_f_procpointer(). For example, a
3366 call to c_f_pointer() for a default integer pointer could have a
3367 name of c_f_pointer_i4. If no second arg exists, which is an error
3368 for these two functions, it defaults to the generic symbol's name
3369 and binding label. */
3372 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3373 char *name, char *binding_label)
3375 gfc_expr *arg = NULL;
3379 /* The second arg of c_f_pointer and c_f_procpointer determines
3380 the type and kind for the procedure name. */
3381 arg = c->ext.actual->next->expr;
3385 /* Set up the name to have the given symbol's name,
3386 plus the type and kind. */
3387 /* a derived type is marked with the type letter 'u' */
3388 if (arg->ts.type == BT_DERIVED)
3391 kind = 0; /* set the kind as 0 for now */
3395 type = gfc_type_letter (arg->ts.type);
3396 kind = arg->ts.kind;
3399 if (arg->ts.type == BT_CHARACTER)
3400 /* Kind info for character strings not needed. */
3403 sprintf (name, "%s_%c%d", sym->name, type, kind);
3404 /* Set up the binding label as the given symbol's label plus
3405 the type and kind. */
3406 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
3410 /* If the second arg is missing, set the name and label as
3411 was, cause it should at least be found, and the missing
3412 arg error will be caught by compare_parameters(). */
3413 sprintf (name, "%s", sym->name);
3414 sprintf (binding_label, "%s", sym->binding_label);
3421 /* Resolve a generic version of the iso_c_binding procedure given
3422 (sym) to the specific one based on the type and kind of the
3423 argument(s). Currently, this function resolves c_f_pointer() and
3424 c_f_procpointer based on the type and kind of the second argument
3425 (FPTR). Other iso_c_binding procedures aren't specially handled.
3426 Upon successfully exiting, c->resolved_sym will hold the resolved
3427 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3431 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3433 gfc_symbol *new_sym;
3434 /* this is fine, since we know the names won't use the max */
3435 char name[GFC_MAX_SYMBOL_LEN + 1];
3436 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
3437 /* default to success; will override if find error */
3438 match m = MATCH_YES;
3440 /* Make sure the actual arguments are in the necessary order (based on the
3441 formal args) before resolving. */
3442 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3444 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3445 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3447 set_name_and_label (c, sym, name, binding_label);
3449 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3451 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3453 /* Make sure we got a third arg if the second arg has non-zero
3454 rank. We must also check that the type and rank are
3455 correct since we short-circuit this check in
3456 gfc_procedure_use() (called above to sort actual args). */
3457 if (c->ext.actual->next->expr->rank != 0)
3459 if(c->ext.actual->next->next == NULL
3460 || c->ext.actual->next->next->expr == NULL)
3463 gfc_error ("Missing SHAPE parameter for call to %s "
3464 "at %L", sym->name, &(c->loc));
3466 else if (c->ext.actual->next->next->expr->ts.type
3468 || c->ext.actual->next->next->expr->rank != 1)
3471 gfc_error ("SHAPE parameter for call to %s at %L must "
3472 "be a rank 1 INTEGER array", sym->name,
3479 if (m != MATCH_ERROR)
3481 /* the 1 means to add the optional arg to formal list */
3482 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3484 /* for error reporting, say it's declared where the original was */
3485 new_sym->declared_at = sym->declared_at;
3490 /* no differences for c_loc or c_funloc */
3494 /* set the resolved symbol */
3495 if (m != MATCH_ERROR)
3496 c->resolved_sym = new_sym;
3498 c->resolved_sym = sym;
3504 /* Resolve a subroutine call known to be specific. */
3507 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3511 if(sym->attr.is_iso_c)
3513 m = gfc_iso_c_sub_interface (c,sym);
3517 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3519 if (sym->attr.dummy)
3521 sym->attr.proc = PROC_DUMMY;
3525 sym->attr.proc = PROC_EXTERNAL;
3529 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3532 if (sym->attr.intrinsic)
3534 m = gfc_intrinsic_sub_interface (c, 1);
3538 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3539 "with an intrinsic", sym->name, &c->loc);
3547 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3549 c->resolved_sym = sym;
3550 pure_subroutine (c, sym);
3557 resolve_specific_s (gfc_code *c)
3562 sym = c->symtree->n.sym;
3566 m = resolve_specific_s0 (c, sym);
3569 if (m == MATCH_ERROR)
3572 if (sym->ns->parent == NULL)
3575 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3581 sym = c->symtree->n.sym;
3582 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3583 sym->name, &c->loc);
3589 /* Resolve a subroutine call not known to be generic nor specific. */
3592 resolve_unknown_s (gfc_code *c)
3596 sym = c->symtree->n.sym;
3598 if (sym->attr.dummy)
3600 sym->attr.proc = PROC_DUMMY;
3604 /* See if we have an intrinsic function reference. */
3606 if (gfc_is_intrinsic (sym, 1, c->loc))
3608 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3613 /* The reference is to an external name. */
3616 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3618 c->resolved_sym = sym;
3620 pure_subroutine (c, sym);
3626 /* Resolve a subroutine call. Although it was tempting to use the same code
3627 for functions, subroutines and functions are stored differently and this
3628 makes things awkward. */
3631 resolve_call (gfc_code *c)
3634 procedure_type ptype = PROC_INTRINSIC;
3635 gfc_symbol *csym, *sym;
3636 bool no_formal_args;
3638 csym = c->symtree ? c->symtree->n.sym : NULL;
3640 if (csym && csym->ts.type != BT_UNKNOWN)
3642 gfc_error ("'%s' at %L has a type, which is not consistent with "
3643 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3647 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3650 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3651 sym = st ? st->n.sym : NULL;
3652 if (sym && csym != sym
3653 && sym->ns == gfc_current_ns
3654 && sym->attr.flavor == FL_PROCEDURE
3655 && sym->attr.contained)
3658 if (csym->attr.generic)
3659 c->symtree->n.sym = sym;
3662 csym = c->symtree->n.sym;
3666 /* If this ia a deferred TBP with an abstract interface
3667 (which may of course be referenced), c->expr1 will be set. */
3668 if (csym && csym->attr.abstract && !c->expr1)
3670 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3671 csym->name, &c->loc);
3675 /* Subroutines without the RECURSIVE attribution are not allowed to
3676 * call themselves. */
3677 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3679 if (csym->attr.entry && csym->ns->entries)
3680 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3681 " subroutine '%s' is not RECURSIVE",
3682 csym->name, &c->loc, csym->ns->entries->sym->name);
3684 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3685 " is not RECURSIVE", csym->name, &c->loc);
3690 /* Switch off assumed size checking and do this again for certain kinds
3691 of procedure, once the procedure itself is resolved. */
3692 need_full_assumed_size++;
3695 ptype = csym->attr.proc;
3697 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3698 if (resolve_actual_arglist (c->ext.actual, ptype,
3699 no_formal_args) == FAILURE)
3702 /* Resume assumed_size checking. */
3703 need_full_assumed_size--;
3705 /* If external, check for usage. */
3706 if (csym && is_external_proc (csym))
3707 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3710 if (c->resolved_sym == NULL)
3712 c->resolved_isym = NULL;
3713 switch (procedure_kind (csym))
3716 t = resolve_generic_s (c);
3719 case PTYPE_SPECIFIC:
3720 t = resolve_specific_s (c);
3724 t = resolve_unknown_s (c);
3728 gfc_internal_error ("resolve_subroutine(): bad function type");
3732 /* Some checks of elemental subroutine actual arguments. */
3733 if (resolve_elemental_actual (NULL, c) == FAILURE)
3740 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3741 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3742 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3743 if their shapes do not match. If either op1->shape or op2->shape is
3744 NULL, return SUCCESS. */
3747 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3754 if (op1->shape != NULL && op2->shape != NULL)
3756 for (i = 0; i < op1->rank; i++)
3758 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3760 gfc_error ("Shapes for operands at %L and %L are not conformable",
3761 &op1->where, &op2->where);
3772 /* Resolve an operator expression node. This can involve replacing the
3773 operation with a user defined function call. */
3776 resolve_operator (gfc_expr *e)
3778 gfc_expr *op1, *op2;
3780 bool dual_locus_error;
3783 /* Resolve all subnodes-- give them types. */
3785 switch (e->value.op.op)
3788 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3791 /* Fall through... */
3794 case INTRINSIC_UPLUS:
3795 case INTRINSIC_UMINUS:
3796 case INTRINSIC_PARENTHESES:
3797 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3802 /* Typecheck the new node. */
3804 op1 = e->value.op.op1;
3805 op2 = e->value.op.op2;
3806 dual_locus_error = false;
3808 if ((op1 && op1->expr_type == EXPR_NULL)
3809 || (op2 && op2->expr_type == EXPR_NULL))
3811 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3815 switch (e->value.op.op)
3817 case INTRINSIC_UPLUS:
3818 case INTRINSIC_UMINUS:
3819 if (op1->ts.type == BT_INTEGER
3820 || op1->ts.type == BT_REAL
3821 || op1->ts.type == BT_COMPLEX)
3827 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3828 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3831 case INTRINSIC_PLUS:
3832 case INTRINSIC_MINUS:
3833 case INTRINSIC_TIMES:
3834 case INTRINSIC_DIVIDE:
3835 case INTRINSIC_POWER:
3836 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3838 gfc_type_convert_binary (e, 1);
3843 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3844 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3845 gfc_typename (&op2->ts));
3848 case INTRINSIC_CONCAT:
3849 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3850 && op1->ts.kind == op2->ts.kind)
3852 e->ts.type = BT_CHARACTER;
3853 e->ts.kind = op1->ts.kind;
3858 _("Operands of string concatenation operator at %%L are %s/%s"),
3859 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3865 case INTRINSIC_NEQV:
3866 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3868 e->ts.type = BT_LOGICAL;
3869 e->ts.kind = gfc_kind_max (op1, op2);
3870 if (op1->ts.kind < e->ts.kind)
3871 gfc_convert_type (op1, &e->ts, 2);
3872 else if (op2->ts.kind < e->ts.kind)
3873 gfc_convert_type (op2, &e->ts, 2);
3877 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3878 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3879 gfc_typename (&op2->ts));
3884 if (op1->ts.type == BT_LOGICAL)
3886 e->ts.type = BT_LOGICAL;
3887 e->ts.kind = op1->ts.kind;
3891 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3892 gfc_typename (&op1->ts));
3896 case INTRINSIC_GT_OS:
3898 case INTRINSIC_GE_OS:
3900 case INTRINSIC_LT_OS:
3902 case INTRINSIC_LE_OS:
3903 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3905 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3909 /* Fall through... */
3912 case INTRINSIC_EQ_OS:
3914 case INTRINSIC_NE_OS:
3915 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3916 && op1->ts.kind == op2->ts.kind)
3918 e->ts.type = BT_LOGICAL;
3919 e->ts.kind = gfc_default_logical_kind;
3923 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3925 gfc_type_convert_binary (e, 1);
3927 e->ts.type = BT_LOGICAL;
3928 e->ts.kind = gfc_default_logical_kind;
3932 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3934 _("Logicals at %%L must be compared with %s instead of %s"),
3935 (e->value.op.op == INTRINSIC_EQ
3936 || e->value.op.op == INTRINSIC_EQ_OS)
3937 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3940 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3941 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3942 gfc_typename (&op2->ts));
3946 case INTRINSIC_USER:
3947 if (e->value.op.uop->op == NULL)
3948 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3949 else if (op2 == NULL)
3950 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3951 e->value.op.uop->name, gfc_typename (&op1->ts));
3954 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3955 e->value.op.uop->name, gfc_typename (&op1->ts),
3956 gfc_typename (&op2->ts));
3957 e->value.op.uop->op->sym->attr.referenced = 1;
3962 case INTRINSIC_PARENTHESES:
3964 if (e->ts.type == BT_CHARACTER)
3965 e->ts.u.cl = op1->ts.u.cl;
3969 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3972 /* Deal with arrayness of an operand through an operator. */
3976 switch (e->value.op.op)
3978 case INTRINSIC_PLUS:
3979 case INTRINSIC_MINUS:
3980 case INTRINSIC_TIMES:
3981 case INTRINSIC_DIVIDE:
3982 case INTRINSIC_POWER:
3983 case INTRINSIC_CONCAT:
3987 case INTRINSIC_NEQV:
3989 case INTRINSIC_EQ_OS:
3991 case INTRINSIC_NE_OS:
3993 case INTRINSIC_GT_OS:
3995 case INTRINSIC_GE_OS:
3997 case INTRINSIC_LT_OS:
3999 case INTRINSIC_LE_OS:
4001 if (op1->rank == 0 && op2->rank == 0)
4004 if (op1->rank == 0 && op2->rank != 0)
4006 e->rank = op2->rank;
4008 if (e->shape == NULL)
4009 e->shape = gfc_copy_shape (op2->shape, op2->rank);
4012 if (op1->rank != 0 && op2->rank == 0)
4014 e->rank = op1->rank;
4016 if (e->shape == NULL)
4017 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4020 if (op1->rank != 0 && op2->rank != 0)
4022 if (op1->rank == op2->rank)
4024 e->rank = op1->rank;
4025 if (e->shape == NULL)
4027 t = compare_shapes (op1, op2);
4031 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4036 /* Allow higher level expressions to work. */
4039 /* Try user-defined operators, and otherwise throw an error. */
4040 dual_locus_error = true;
4042 _("Inconsistent ranks for operator at %%L and %%L"));
4049 case INTRINSIC_PARENTHESES:
4051 case INTRINSIC_UPLUS:
4052 case INTRINSIC_UMINUS:
4053 /* Simply copy arrayness attribute */
4054 e->rank = op1->rank;
4056 if (e->shape == NULL)
4057 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4065 /* Attempt to simplify the expression. */
4068 t = gfc_simplify_expr (e, 0);
4069 /* Some calls do not succeed in simplification and return FAILURE
4070 even though there is no error; e.g. variable references to
4071 PARAMETER arrays. */
4072 if (!gfc_is_constant_expr (e))
4080 match m = gfc_extend_expr (e);
4083 if (m == MATCH_ERROR)
4087 if (dual_locus_error)
4088 gfc_error (msg, &op1->where, &op2->where);
4090 gfc_error (msg, &e->where);
4096 /************** Array resolution subroutines **************/
4099 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
4102 /* Compare two integer expressions. */
4105 compare_bound (gfc_expr *a, gfc_expr *b)
4109 if (a == NULL || a->expr_type != EXPR_CONSTANT
4110 || b == NULL || b->expr_type != EXPR_CONSTANT)
4113 /* If either of the types isn't INTEGER, we must have
4114 raised an error earlier. */
4116 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
4119 i = mpz_cmp (a->value.integer, b->value.integer);
4129 /* Compare an integer expression with an integer. */
4132 compare_bound_int (gfc_expr *a, int b)
4136 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4139 if (a->ts.type != BT_INTEGER)
4140 gfc_internal_error ("compare_bound_int(): Bad expression");
4142 i = mpz_cmp_si (a->value.integer, b);
4152 /* Compare an integer expression with a mpz_t. */
4155 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4159 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4162 if (a->ts.type != BT_INTEGER)
4163 gfc_internal_error ("compare_bound_int(): Bad expression");
4165 i = mpz_cmp (a->value.integer, b);
4175 /* Compute the last value of a sequence given by a triplet.
4176 Return 0 if it wasn't able to compute the last value, or if the
4177 sequence if empty, and 1 otherwise. */
4180 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4181 gfc_expr *stride, mpz_t last)
4185 if (start == NULL || start->expr_type != EXPR_CONSTANT
4186 || end == NULL || end->expr_type != EXPR_CONSTANT
4187 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4190 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4191 || (stride != NULL && stride->ts.type != BT_INTEGER))
4194 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
4196 if (compare_bound (start, end) == CMP_GT)
4198 mpz_set (last, end->value.integer);
4202 if (compare_bound_int (stride, 0) == CMP_GT)
4204 /* Stride is positive */
4205 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4210 /* Stride is negative */
4211 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4216 mpz_sub (rem, end->value.integer, start->value.integer);
4217 mpz_tdiv_r (rem, rem, stride->value.integer);
4218 mpz_sub (last, end->value.integer, rem);
4225 /* Compare a single dimension of an array reference to the array
4229 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4233 if (ar->dimen_type[i] == DIMEN_STAR)
4235 gcc_assert (ar->stride[i] == NULL);
4236 /* This implies [*] as [*:] and [*:3] are not possible. */
4237 if (ar->start[i] == NULL)
4239 gcc_assert (ar->end[i] == NULL);
4244 /* Given start, end and stride values, calculate the minimum and
4245 maximum referenced indexes. */
4247 switch (ar->dimen_type[i])
4250 case DIMEN_THIS_IMAGE:
4255 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4258 gfc_warning ("Array reference at %L is out of bounds "
4259 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4260 mpz_get_si (ar->start[i]->value.integer),
4261 mpz_get_si (as->lower[i]->value.integer), i+1);
4263 gfc_warning ("Array reference at %L is out of bounds "
4264 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4265 mpz_get_si (ar->start[i]->value.integer),
4266 mpz_get_si (as->lower[i]->value.integer),
4270 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4273 gfc_warning ("Array reference at %L is out of bounds "
4274 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4275 mpz_get_si (ar->start[i]->value.integer),
4276 mpz_get_si (as->upper[i]->value.integer), i+1);
4278 gfc_warning ("Array reference at %L is out of bounds "
4279 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4280 mpz_get_si (ar->start[i]->value.integer),
4281 mpz_get_si (as->upper[i]->value.integer),
4290 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4291 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4293 comparison comp_start_end = compare_bound (AR_START, AR_END);
4295 /* Check for zero stride, which is not allowed. */
4296 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4298 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4302 /* if start == len || (stride > 0 && start < len)
4303 || (stride < 0 && start > len),
4304 then the array section contains at least one element. In this
4305 case, there is an out-of-bounds access if
4306 (start < lower || start > upper). */
4307 if (compare_bound (AR_START, AR_END) == CMP_EQ
4308 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4309 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4310 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4311 && comp_start_end == CMP_GT))
4313 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4315 gfc_warning ("Lower array reference at %L is out of bounds "
4316 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4317 mpz_get_si (AR_START->value.integer),
4318 mpz_get_si (as->lower[i]->value.integer), i+1);
4321 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4323 gfc_warning ("Lower array reference at %L is out of bounds "
4324 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4325 mpz_get_si (AR_START->value.integer),
4326 mpz_get_si (as->upper[i]->value.integer), i+1);
4331 /* If we can compute the highest index of the array section,
4332 then it also has to be between lower and upper. */
4333 mpz_init (last_value);
4334 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4337 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4339 gfc_warning ("Upper array reference at %L is out of bounds "
4340 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4341 mpz_get_si (last_value),
4342 mpz_get_si (as->lower[i]->value.integer), i+1);
4343 mpz_clear (last_value);
4346 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4348 gfc_warning ("Upper array reference at %L is out of bounds "
4349 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4350 mpz_get_si (last_value),
4351 mpz_get_si (as->upper[i]->value.integer), i+1);
4352 mpz_clear (last_value);
4356 mpz_clear (last_value);
4364 gfc_internal_error ("check_dimension(): Bad array reference");
4371 /* Compare an array reference with an array specification. */
4374 compare_spec_to_ref (gfc_array_ref *ar)
4381 /* TODO: Full array sections are only allowed as actual parameters. */
4382 if (as->type == AS_ASSUMED_SIZE
4383 && (/*ar->type == AR_FULL
4384 ||*/ (ar->type == AR_SECTION
4385 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4387 gfc_error ("Rightmost upper bound of assumed size array section "
4388 "not specified at %L", &ar->where);
4392 if (ar->type == AR_FULL)
4395 if (as->rank != ar->dimen)
4397 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4398 &ar->where, ar->dimen, as->rank);
4402 /* ar->codimen == 0 is a local array. */
4403 if (as->corank != ar->codimen && ar->codimen != 0)
4405 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4406 &ar->where, ar->codimen, as->corank);
4410 for (i = 0; i < as->rank; i++)
4411 if (check_dimension (i, ar, as) == FAILURE)
4414 /* Local access has no coarray spec. */
4415 if (ar->codimen != 0)
4416 for (i = as->rank; i < as->rank + as->corank; i++)
4418 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
4419 && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
4421 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4422 i + 1 - as->rank, &ar->where);
4425 if (check_dimension (i, ar, as) == FAILURE)
4433 /* Resolve one part of an array index. */
4436 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4437 int force_index_integer_kind)
4444 if (gfc_resolve_expr (index) == FAILURE)
4447 if (check_scalar && index->rank != 0)
4449 gfc_error ("Array index at %L must be scalar", &index->where);
4453 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4455 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4456 &index->where, gfc_basic_typename (index->ts.type));
4460 if (index->ts.type == BT_REAL)
4461 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
4462 &index->where) == FAILURE)
4465 if ((index->ts.kind != gfc_index_integer_kind
4466 && force_index_integer_kind)
4467 || index->ts.type != BT_INTEGER)
4470 ts.type = BT_INTEGER;
4471 ts.kind = gfc_index_integer_kind;
4473 gfc_convert_type_warn (index, &ts, 2, 0);
4479 /* Resolve one part of an array index. */
4482 gfc_resolve_index (gfc_expr *index, int check_scalar)
4484 return gfc_resolve_index_1 (index, check_scalar, 1);
4487 /* Resolve a dim argument to an intrinsic function. */
4490 gfc_resolve_dim_arg (gfc_expr *dim)
4495 if (gfc_resolve_expr (dim) == FAILURE)
4500 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4505 if (dim->ts.type != BT_INTEGER)
4507 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4511 if (dim->ts.kind != gfc_index_integer_kind)
4516 ts.type = BT_INTEGER;
4517 ts.kind = gfc_index_integer_kind;
4519 gfc_convert_type_warn (dim, &ts, 2, 0);
4525 /* Given an expression that contains array references, update those array
4526 references to point to the right array specifications. While this is
4527 filled in during matching, this information is difficult to save and load
4528 in a module, so we take care of it here.
4530 The idea here is that the original array reference comes from the
4531 base symbol. We traverse the list of reference structures, setting
4532 the stored reference to references. Component references can
4533 provide an additional array specification. */
4536 find_array_spec (gfc_expr *e)
4542 if (e->symtree->n.sym->ts.type == BT_CLASS)
4543 as = CLASS_DATA (e->symtree->n.sym)->as;
4545 as = e->symtree->n.sym->as;
4547 for (ref = e->ref; ref; ref = ref->next)
4552 gfc_internal_error ("find_array_spec(): Missing spec");
4559 c = ref->u.c.component;
4560 if (c->attr.dimension)
4563 gfc_internal_error ("find_array_spec(): unused as(1)");
4574 gfc_internal_error ("find_array_spec(): unused as(2)");
4578 /* Resolve an array reference. */
4581 resolve_array_ref (gfc_array_ref *ar)
4583 int i, check_scalar;
4586 for (i = 0; i < ar->dimen + ar->codimen; i++)
4588 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4590 /* Do not force gfc_index_integer_kind for the start. We can
4591 do fine with any integer kind. This avoids temporary arrays
4592 created for indexing with a vector. */
4593 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4595 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4597 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4602 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4606 ar->dimen_type[i] = DIMEN_ELEMENT;
4610 ar->dimen_type[i] = DIMEN_VECTOR;
4611 if (e->expr_type == EXPR_VARIABLE
4612 && e->symtree->n.sym->ts.type == BT_DERIVED)
4613 ar->start[i] = gfc_get_parentheses (e);
4617 gfc_error ("Array index at %L is an array of rank %d",
4618 &ar->c_where[i], e->rank);
4622 /* Fill in the upper bound, which may be lower than the
4623 specified one for something like a(2:10:5), which is
4624 identical to a(2:7:5). Only relevant for strides not equal
4625 to one. Don't try a division by zero. */
4626 if (ar->dimen_type[i] == DIMEN_RANGE
4627 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4628 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
4629 && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
4633 if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4635 if (ar->end[i] == NULL)
4638 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4640 mpz_set (ar->end[i]->value.integer, end);
4642 else if (ar->end[i]->ts.type == BT_INTEGER
4643 && ar->end[i]->expr_type == EXPR_CONSTANT)
4645 mpz_set (ar->end[i]->value.integer, end);
4656 if (ar->type == AR_FULL)
4658 if (ar->as->rank == 0)
4659 ar->type = AR_ELEMENT;
4661 /* Make sure array is the same as array(:,:), this way
4662 we don't need to special case all the time. */
4663 ar->dimen = ar->as->rank;
4664 for (i = 0; i < ar->dimen; i++)
4666 ar->dimen_type[i] = DIMEN_RANGE;
4668 gcc_assert (ar->start[i] == NULL);
4669 gcc_assert (ar->end[i] == NULL);
4670 gcc_assert (ar->stride[i] == NULL);
4674 /* If the reference type is unknown, figure out what kind it is. */
4676 if (ar->type == AR_UNKNOWN)
4678 ar->type = AR_ELEMENT;
4679 for (i = 0; i < ar->dimen; i++)
4680 if (ar->dimen_type[i] == DIMEN_RANGE
4681 || ar->dimen_type[i] == DIMEN_VECTOR)
4683 ar->type = AR_SECTION;
4688 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4691 if (ar->as->corank && ar->codimen == 0)
4694 ar->codimen = ar->as->corank;
4695 for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
4696 ar->dimen_type[n] = DIMEN_THIS_IMAGE;
4704 resolve_substring (gfc_ref *ref)
4706 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4708 if (ref->u.ss.start != NULL)
4710 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4713 if (ref->u.ss.start->ts.type != BT_INTEGER)
4715 gfc_error ("Substring start index at %L must be of type INTEGER",
4716 &ref->u.ss.start->where);
4720 if (ref->u.ss.start->rank != 0)
4722 gfc_error ("Substring start index at %L must be scalar",
4723 &ref->u.ss.start->where);
4727 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4728 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4729 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4731 gfc_error ("Substring start index at %L is less than one",
4732 &ref->u.ss.start->where);
4737 if (ref->u.ss.end != NULL)
4739 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4742 if (ref->u.ss.end->ts.type != BT_INTEGER)
4744 gfc_error ("Substring end index at %L must be of type INTEGER",
4745 &ref->u.ss.end->where);
4749 if (ref->u.ss.end->rank != 0)
4751 gfc_error ("Substring end index at %L must be scalar",
4752 &ref->u.ss.end->where);
4756 if (ref->u.ss.length != NULL
4757 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4758 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4759 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4761 gfc_error ("Substring end index at %L exceeds the string length",
4762 &ref->u.ss.start->where);
4766 if (compare_bound_mpz_t (ref->u.ss.end,
4767 gfc_integer_kinds[k].huge) == CMP_GT
4768 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4769 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4771 gfc_error ("Substring end index at %L is too large",
4772 &ref->u.ss.end->where);
4781 /* This function supplies missing substring charlens. */
4784 gfc_resolve_substring_charlen (gfc_expr *e)
4787 gfc_expr *start, *end;
4789 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4790 if (char_ref->type == REF_SUBSTRING)
4796 gcc_assert (char_ref->next == NULL);
4800 if (e->ts.u.cl->length)
4801 gfc_free_expr (e->ts.u.cl->length);
4802 else if (e->expr_type == EXPR_VARIABLE
4803 && e->symtree->n.sym->attr.dummy)
4807 e->ts.type = BT_CHARACTER;
4808 e->ts.kind = gfc_default_character_kind;
4811 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4813 if (char_ref->u.ss.start)
4814 start = gfc_copy_expr (char_ref->u.ss.start);
4816 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4818 if (char_ref->u.ss.end)
4819 end = gfc_copy_expr (char_ref->u.ss.end);
4820 else if (e->expr_type == EXPR_VARIABLE)
4821 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4828 /* Length = (end - start +1). */
4829 e->ts.u.cl->length = gfc_subtract (end, start);
4830 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4831 gfc_get_int_expr (gfc_default_integer_kind,
4834 e->ts.u.cl->length->ts.type = BT_INTEGER;
4835 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4837 /* Make sure that the length is simplified. */
4838 gfc_simplify_expr (e->ts.u.cl->length, 1);
4839 gfc_resolve_expr (e->ts.u.cl->length);
4843 /* Resolve subtype references. */
4846 resolve_ref (gfc_expr *expr)
4848 int current_part_dimension, n_components, seen_part_dimension;
4851 for (ref = expr->ref; ref; ref = ref->next)
4852 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4854 find_array_spec (expr);
4858 for (ref = expr->ref; ref; ref = ref->next)
4862 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4870 if (resolve_substring (ref) == FAILURE)
4875 /* Check constraints on part references. */
4877 current_part_dimension = 0;
4878 seen_part_dimension = 0;
4881 for (ref = expr->ref; ref; ref = ref->next)
4886 switch (ref->u.ar.type)
4889 /* Coarray scalar. */
4890 if (ref->u.ar.as->rank == 0)
4892 current_part_dimension = 0;
4897 current_part_dimension = 1;
4901 current_part_dimension = 0;
4905 gfc_internal_error ("resolve_ref(): Bad array reference");
4911 if (current_part_dimension || seen_part_dimension)
4914 if (ref->u.c.component->attr.pointer
4915 || ref->u.c.component->attr.proc_pointer)
4917 gfc_error ("Component to the right of a part reference "
4918 "with nonzero rank must not have the POINTER "
4919 "attribute at %L", &expr->where);
4922 else if (ref->u.c.component->attr.allocatable)
4924 gfc_error ("Component to the right of a part reference "
4925 "with nonzero rank must not have the ALLOCATABLE "
4926 "attribute at %L", &expr->where);
4938 if (((ref->type == REF_COMPONENT && n_components > 1)
4939 || ref->next == NULL)
4940 && current_part_dimension
4941 && seen_part_dimension)
4943 gfc_error ("Two or more part references with nonzero rank must "
4944 "not be specified at %L", &expr->where);
4948 if (ref->type == REF_COMPONENT)
4950 if (current_part_dimension)
4951 seen_part_dimension = 1;
4953 /* reset to make sure */
4954 current_part_dimension = 0;
4962 /* Given an expression, determine its shape. This is easier than it sounds.
4963 Leaves the shape array NULL if it is not possible to determine the shape. */
4966 expression_shape (gfc_expr *e)
4968 mpz_t array[GFC_MAX_DIMENSIONS];
4971 if (e->rank == 0 || e->shape != NULL)
4974 for (i = 0; i < e->rank; i++)
4975 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4978 e->shape = gfc_get_shape (e->rank);
4980 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4985 for (i--; i >= 0; i--)
4986 mpz_clear (array[i]);
4990 /* Given a variable expression node, compute the rank of the expression by
4991 examining the base symbol and any reference structures it may have. */
4994 expression_rank (gfc_expr *e)
4999 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5000 could lead to serious confusion... */
5001 gcc_assert (e->expr_type != EXPR_COMPCALL);
5005 if (e->expr_type == EXPR_ARRAY)
5007 /* Constructors can have a rank different from one via RESHAPE(). */
5009 if (e->symtree == NULL)
5015 e->rank = (e->symtree->n.sym->as == NULL)
5016 ? 0 : e->symtree->n.sym->as->rank;
5022 for (ref = e->ref; ref; ref = ref->next)
5024 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
5025 && ref->u.c.component->attr.function && !ref->next)
5026 rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
5028 if (ref->type != REF_ARRAY)
5031 if (ref->u.ar.type == AR_FULL)
5033 rank = ref->u.ar.as->rank;
5037 if (ref->u.ar.type == AR_SECTION)
5039 /* Figure out the rank of the section. */
5041 gfc_internal_error ("expression_rank(): Two array specs");
5043 for (i = 0; i < ref->u.ar.dimen; i++)
5044 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
5045 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
5055 expression_shape (e);
5059 /* Resolve a variable expression. */
5062 resolve_variable (gfc_expr *e)
5069 if (e->symtree == NULL)
5071 sym = e->symtree->n.sym;
5073 /* If this is an associate-name, it may be parsed with an array reference
5074 in error even though the target is scalar. Fail directly in this case. */
5075 if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
5078 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
5079 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
5081 /* On the other hand, the parser may not have known this is an array;
5082 in this case, we have to add a FULL reference. */
5083 if (sym->assoc && sym->attr.dimension && !e->ref)
5085 e->ref = gfc_get_ref ();
5086 e->ref->type = REF_ARRAY;
5087 e->ref->u.ar.type = AR_FULL;
5088 e->ref->u.ar.dimen = 0;
5091 if (e->ref && resolve_ref (e) == FAILURE)
5094 if (sym->attr.flavor == FL_PROCEDURE
5095 && (!sym->attr.function
5096 || (sym->attr.function && sym->result
5097 && sym->result->attr.proc_pointer
5098 && !sym->result->attr.function)))
5100 e->ts.type = BT_PROCEDURE;
5101 goto resolve_procedure;
5104 if (sym->ts.type != BT_UNKNOWN)
5105 gfc_variable_attr (e, &e->ts);
5108 /* Must be a simple variable reference. */
5109 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
5114 if (check_assumed_size_reference (sym, e))
5117 /* Deal with forward references to entries during resolve_code, to
5118 satisfy, at least partially, 12.5.2.5. */
5119 if (gfc_current_ns->entries
5120 && current_entry_id == sym->entry_id
5123 && cs_base->current->op != EXEC_ENTRY)
5125 gfc_entry_list *entry;
5126 gfc_formal_arglist *formal;
5130 /* If the symbol is a dummy... */
5131 if (sym->attr.dummy && sym->ns == gfc_current_ns)
5133 entry = gfc_current_ns->entries;
5136 /* ...test if the symbol is a parameter of previous entries. */
5137 for (; entry && entry->id <= current_entry_id; entry = entry->next)
5138 for (formal = entry->sym->formal; formal; formal = formal->next)
5140 if (formal->sym && sym->name == formal->sym->name)
5144 /* If it has not been seen as a dummy, this is an error. */
5147 if (specification_expr)
5148 gfc_error ("Variable '%s', used in a specification expression"
5149 ", is referenced at %L before the ENTRY statement "
5150 "in which it is a parameter",
5151 sym->name, &cs_base->current->loc);
5153 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5154 "statement in which it is a parameter",
5155 sym->name, &cs_base->current->loc);
5160 /* Now do the same check on the specification expressions. */
5161 specification_expr = 1;
5162 if (sym->ts.type == BT_CHARACTER
5163 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
5167 for (n = 0; n < sym->as->rank; n++)
5169 specification_expr = 1;
5170 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
5172 specification_expr = 1;
5173 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
5176 specification_expr = 0;
5179 /* Update the symbol's entry level. */
5180 sym->entry_id = current_entry_id + 1;
5183 /* If a symbol has been host_associated mark it. This is used latter,
5184 to identify if aliasing is possible via host association. */
5185 if (sym->attr.flavor == FL_VARIABLE
5186 && gfc_current_ns->parent
5187 && (gfc_current_ns->parent == sym->ns
5188 || (gfc_current_ns->parent->parent
5189 && gfc_current_ns->parent->parent == sym->ns)))
5190 sym->attr.host_assoc = 1;
5193 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
5196 /* F2008, C617 and C1229. */
5197 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5198 && gfc_is_coindexed (e))
5200 gfc_ref *ref, *ref2 = NULL;
5202 for (ref = e->ref; ref; ref = ref->next)
5204 if (ref->type == REF_COMPONENT)
5206 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5210 for ( ; ref; ref = ref->next)
5211 if (ref->type == REF_COMPONENT)
5214 /* Expression itself is not coindexed object. */
5215 if (ref && e->ts.type == BT_CLASS)
5217 gfc_error ("Polymorphic subobject of coindexed object at %L",
5222 /* Expression itself is coindexed object. */
5226 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5227 for ( ; c; c = c->next)
5228 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5230 gfc_error ("Coindexed object with polymorphic allocatable "
5231 "subcomponent at %L", &e->where);
5242 /* Checks to see that the correct symbol has been host associated.
5243 The only situation where this arises is that in which a twice
5244 contained function is parsed after the host association is made.
5245 Therefore, on detecting this, change the symbol in the expression
5246 and convert the array reference into an actual arglist if the old
5247 symbol is a variable. */
5249 check_host_association (gfc_expr *e)
5251 gfc_symbol *sym, *old_sym;
5255 gfc_actual_arglist *arg, *tail = NULL;
5256 bool retval = e->expr_type == EXPR_FUNCTION;
5258 /* If the expression is the result of substitution in
5259 interface.c(gfc_extend_expr) because there is no way in
5260 which the host association can be wrong. */
5261 if (e->symtree == NULL
5262 || e->symtree->n.sym == NULL
5263 || e->user_operator)
5266 old_sym = e->symtree->n.sym;
5268 if (gfc_current_ns->parent
5269 && old_sym->ns != gfc_current_ns)
5271 /* Use the 'USE' name so that renamed module symbols are
5272 correctly handled. */
5273 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5275 if (sym && old_sym != sym
5276 && sym->ts.type == old_sym->ts.type
5277 && sym->attr.flavor == FL_PROCEDURE
5278 && sym->attr.contained)
5280 /* Clear the shape, since it might not be valid. */
5281 gfc_free_shape (&e->shape, e->rank);
5283 /* Give the expression the right symtree! */
5284 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5285 gcc_assert (st != NULL);
5287 if (old_sym->attr.flavor == FL_PROCEDURE
5288 || e->expr_type == EXPR_FUNCTION)
5290 /* Original was function so point to the new symbol, since
5291 the actual argument list is already attached to the
5293 e->value.function.esym = NULL;
5298 /* Original was variable so convert array references into
5299 an actual arglist. This does not need any checking now
5300 since resolve_function will take care of it. */
5301 e->value.function.actual = NULL;
5302 e->expr_type = EXPR_FUNCTION;
5305 /* Ambiguity will not arise if the array reference is not
5306 the last reference. */
5307 for (ref = e->ref; ref; ref = ref->next)
5308 if (ref->type == REF_ARRAY && ref->next == NULL)
5311 gcc_assert (ref->type == REF_ARRAY);
5313 /* Grab the start expressions from the array ref and
5314 copy them into actual arguments. */
5315 for (n = 0; n < ref->u.ar.dimen; n++)
5317 arg = gfc_get_actual_arglist ();
5318 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5319 if (e->value.function.actual == NULL)
5320 tail = e->value.function.actual = arg;
5328 /* Dump the reference list and set the rank. */
5329 gfc_free_ref_list (e->ref);
5331 e->rank = sym->as ? sym->as->rank : 0;
5334 gfc_resolve_expr (e);
5338 /* This might have changed! */
5339 return e->expr_type == EXPR_FUNCTION;
5344 gfc_resolve_character_operator (gfc_expr *e)
5346 gfc_expr *op1 = e->value.op.op1;
5347 gfc_expr *op2 = e->value.op.op2;
5348 gfc_expr *e1 = NULL;
5349 gfc_expr *e2 = NULL;
5351 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5353 if (op1->ts.u.cl && op1->ts.u.cl->length)
5354 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5355 else if (op1->expr_type == EXPR_CONSTANT)
5356 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5357 op1->value.character.length);
5359 if (op2->ts.u.cl && op2->ts.u.cl->length)
5360 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5361 else if (op2->expr_type == EXPR_CONSTANT)
5362 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5363 op2->value.character.length);
5365 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5370 e->ts.u.cl->length = gfc_add (e1, e2);
5371 e->ts.u.cl->length->ts.type = BT_INTEGER;
5372 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5373 gfc_simplify_expr (e->ts.u.cl->length, 0);
5374 gfc_resolve_expr (e->ts.u.cl->length);
5380 /* Ensure that an character expression has a charlen and, if possible, a
5381 length expression. */
5384 fixup_charlen (gfc_expr *e)
5386 /* The cases fall through so that changes in expression type and the need
5387 for multiple fixes are picked up. In all circumstances, a charlen should
5388 be available for the middle end to hang a backend_decl on. */
5389 switch (e->expr_type)
5392 gfc_resolve_character_operator (e);
5395 if (e->expr_type == EXPR_ARRAY)
5396 gfc_resolve_character_array_constructor (e);
5398 case EXPR_SUBSTRING:
5399 if (!e->ts.u.cl && e->ref)
5400 gfc_resolve_substring_charlen (e);
5404 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5411 /* Update an actual argument to include the passed-object for type-bound
5412 procedures at the right position. */
5414 static gfc_actual_arglist*
5415 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5418 gcc_assert (argpos > 0);
5422 gfc_actual_arglist* result;
5424 result = gfc_get_actual_arglist ();
5428 result->name = name;
5434 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5436 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5441 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5444 extract_compcall_passed_object (gfc_expr* e)
5448 gcc_assert (e->expr_type == EXPR_COMPCALL);
5450 if (e->value.compcall.base_object)
5451 po = gfc_copy_expr (e->value.compcall.base_object);
5454 po = gfc_get_expr ();
5455 po->expr_type = EXPR_VARIABLE;
5456 po->symtree = e->symtree;
5457 po->ref = gfc_copy_ref (e->ref);
5458 po->where = e->where;
5461 if (gfc_resolve_expr (po) == FAILURE)
5468 /* Update the arglist of an EXPR_COMPCALL expression to include the
5472 update_compcall_arglist (gfc_expr* e)
5475 gfc_typebound_proc* tbp;
5477 tbp = e->value.compcall.tbp;
5482 po = extract_compcall_passed_object (e);
5486 if (tbp->nopass || e->value.compcall.ignore_pass)
5492 gcc_assert (tbp->pass_arg_num > 0);
5493 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5501 /* Extract the passed object from a PPC call (a copy of it). */
5504 extract_ppc_passed_object (gfc_expr *e)
5509 po = gfc_get_expr ();
5510 po->expr_type = EXPR_VARIABLE;
5511 po->symtree = e->symtree;
5512 po->ref = gfc_copy_ref (e->ref);
5513 po->where = e->where;
5515 /* Remove PPC reference. */
5517 while ((*ref)->next)
5518 ref = &(*ref)->next;
5519 gfc_free_ref_list (*ref);
5522 if (gfc_resolve_expr (po) == FAILURE)
5529 /* Update the actual arglist of a procedure pointer component to include the
5533 update_ppc_arglist (gfc_expr* e)
5537 gfc_typebound_proc* tb;
5539 if (!gfc_is_proc_ptr_comp (e, &ppc))
5546 else if (tb->nopass)
5549 po = extract_ppc_passed_object (e);
5556 gfc_error ("Passed-object at %L must be scalar", &e->where);
5561 if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
5563 gfc_error ("Base object for procedure-pointer component call at %L is of"
5564 " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name);
5568 gcc_assert (tb->pass_arg_num > 0);
5569 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5577 /* Check that the object a TBP is called on is valid, i.e. it must not be
5578 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5581 check_typebound_baseobject (gfc_expr* e)
5584 gfc_try return_value = FAILURE;
5586 base = extract_compcall_passed_object (e);
5590 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5593 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5595 gfc_error ("Base object for type-bound procedure call at %L is of"
5596 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5600 /* F08:C1230. If the procedure called is NOPASS,
5601 the base object must be scalar. */
5602 if (e->value.compcall.tbp->nopass && base->rank > 0)
5604 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5605 " be scalar", &e->where);
5609 return_value = SUCCESS;
5612 gfc_free_expr (base);
5613 return return_value;
5617 /* Resolve a call to a type-bound procedure, either function or subroutine,
5618 statically from the data in an EXPR_COMPCALL expression. The adapted
5619 arglist and the target-procedure symtree are returned. */
5622 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5623 gfc_actual_arglist** actual)
5625 gcc_assert (e->expr_type == EXPR_COMPCALL);
5626 gcc_assert (!e->value.compcall.tbp->is_generic);
5628 /* Update the actual arglist for PASS. */
5629 if (update_compcall_arglist (e) == FAILURE)
5632 *actual = e->value.compcall.actual;
5633 *target = e->value.compcall.tbp->u.specific;
5635 gfc_free_ref_list (e->ref);
5637 e->value.compcall.actual = NULL;
5639 /* If we find a deferred typebound procedure, check for derived types
5640 that an over-riding typebound procedure has not been missed. */
5641 if (e->value.compcall.tbp->deferred
5642 && e->value.compcall.name
5643 && !e->value.compcall.tbp->non_overridable
5644 && e->value.compcall.base_object
5645 && e->value.compcall.base_object->ts.type == BT_DERIVED)
5648 gfc_symbol *derived;
5650 /* Use the derived type of the base_object. */
5651 derived = e->value.compcall.base_object->ts.u.derived;
5654 /* If necessary, go throught the inheritance chain. */
5655 while (!st && derived)
5657 /* Look for the typebound procedure 'name'. */
5658 if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
5659 st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
5660 e->value.compcall.name);
5662 derived = gfc_get_derived_super_type (derived);
5665 /* Now find the specific name in the derived type namespace. */
5666 if (st && st->n.tb && st->n.tb->u.specific)
5667 gfc_find_sym_tree (st->n.tb->u.specific->name,
5668 derived->ns, 1, &st);
5676 /* Get the ultimate declared type from an expression. In addition,
5677 return the last class/derived type reference and the copy of the
5678 reference list. If check_types is set true, derived types are
5679 identified as well as class references. */
5681 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5682 gfc_expr *e, bool check_types)
5684 gfc_symbol *declared;
5691 *new_ref = gfc_copy_ref (e->ref);
5693 for (ref = e->ref; ref; ref = ref->next)
5695 if (ref->type != REF_COMPONENT)
5698 if ((ref->u.c.component->ts.type == BT_CLASS
5699 || (check_types && ref->u.c.component->ts.type == BT_DERIVED))
5700 && ref->u.c.component->attr.flavor != FL_PROCEDURE)
5702 declared = ref->u.c.component->ts.u.derived;
5708 if (declared == NULL)
5709 declared = e->symtree->n.sym->ts.u.derived;
5715 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5716 which of the specific bindings (if any) matches the arglist and transform
5717 the expression into a call of that binding. */
5720 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5722 gfc_typebound_proc* genproc;
5723 const char* genname;
5725 gfc_symbol *derived;
5727 gcc_assert (e->expr_type == EXPR_COMPCALL);
5728 genname = e->value.compcall.name;
5729 genproc = e->value.compcall.tbp;
5731 if (!genproc->is_generic)
5734 /* Try the bindings on this type and in the inheritance hierarchy. */
5735 for (; genproc; genproc = genproc->overridden)
5739 gcc_assert (genproc->is_generic);
5740 for (g = genproc->u.generic; g; g = g->next)
5743 gfc_actual_arglist* args;
5746 gcc_assert (g->specific);
5748 if (g->specific->error)
5751 target = g->specific->u.specific->n.sym;
5753 /* Get the right arglist by handling PASS/NOPASS. */
5754 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5755 if (!g->specific->nopass)
5758 po = extract_compcall_passed_object (e);
5762 gcc_assert (g->specific->pass_arg_num > 0);
5763 gcc_assert (!g->specific->error);
5764 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5765 g->specific->pass_arg);
5767 resolve_actual_arglist (args, target->attr.proc,
5768 is_external_proc (target) && !target->formal);
5770 /* Check if this arglist matches the formal. */
5771 matches = gfc_arglist_matches_symbol (&args, target);
5773 /* Clean up and break out of the loop if we've found it. */
5774 gfc_free_actual_arglist (args);
5777 e->value.compcall.tbp = g->specific;
5778 genname = g->specific_st->name;
5779 /* Pass along the name for CLASS methods, where the vtab
5780 procedure pointer component has to be referenced. */
5788 /* Nothing matching found! */
5789 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5790 " '%s' at %L", genname, &e->where);
5794 /* Make sure that we have the right specific instance for the name. */
5795 derived = get_declared_from_expr (NULL, NULL, e, true);
5797 st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
5799 e->value.compcall.tbp = st->n.tb;
5805 /* Resolve a call to a type-bound subroutine. */
5808 resolve_typebound_call (gfc_code* c, const char **name)
5810 gfc_actual_arglist* newactual;
5811 gfc_symtree* target;
5813 /* Check that's really a SUBROUTINE. */
5814 if (!c->expr1->value.compcall.tbp->subroutine)
5816 gfc_error ("'%s' at %L should be a SUBROUTINE",
5817 c->expr1->value.compcall.name, &c->loc);
5821 if (check_typebound_baseobject (c->expr1) == FAILURE)
5824 /* Pass along the name for CLASS methods, where the vtab
5825 procedure pointer component has to be referenced. */
5827 *name = c->expr1->value.compcall.name;
5829 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5832 /* Transform into an ordinary EXEC_CALL for now. */
5834 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5837 c->ext.actual = newactual;
5838 c->symtree = target;
5839 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5841 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5843 gfc_free_expr (c->expr1);
5844 c->expr1 = gfc_get_expr ();
5845 c->expr1->expr_type = EXPR_FUNCTION;
5846 c->expr1->symtree = target;
5847 c->expr1->where = c->loc;
5849 return resolve_call (c);
5853 /* Resolve a component-call expression. */
5855 resolve_compcall (gfc_expr* e, const char **name)
5857 gfc_actual_arglist* newactual;
5858 gfc_symtree* target;
5860 /* Check that's really a FUNCTION. */
5861 if (!e->value.compcall.tbp->function)
5863 gfc_error ("'%s' at %L should be a FUNCTION",
5864 e->value.compcall.name, &e->where);
5868 /* These must not be assign-calls! */
5869 gcc_assert (!e->value.compcall.assign);
5871 if (check_typebound_baseobject (e) == FAILURE)
5874 /* Pass along the name for CLASS methods, where the vtab
5875 procedure pointer component has to be referenced. */
5877 *name = e->value.compcall.name;
5879 if (resolve_typebound_generic_call (e, name) == FAILURE)
5881 gcc_assert (!e->value.compcall.tbp->is_generic);
5883 /* Take the rank from the function's symbol. */
5884 if (e->value.compcall.tbp->u.specific->n.sym->as)
5885 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5887 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5888 arglist to the TBP's binding target. */
5890 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5893 e->value.function.actual = newactual;
5894 e->value.function.name = NULL;
5895 e->value.function.esym = target->n.sym;
5896 e->value.function.isym = NULL;
5897 e->symtree = target;
5898 e->ts = target->n.sym->ts;
5899 e->expr_type = EXPR_FUNCTION;
5901 /* Resolution is not necessary if this is a class subroutine; this
5902 function only has to identify the specific proc. Resolution of
5903 the call will be done next in resolve_typebound_call. */
5904 return gfc_resolve_expr (e);
5909 /* Resolve a typebound function, or 'method'. First separate all
5910 the non-CLASS references by calling resolve_compcall directly. */
5913 resolve_typebound_function (gfc_expr* e)
5915 gfc_symbol *declared;
5927 /* Deal with typebound operators for CLASS objects. */
5928 expr = e->value.compcall.base_object;
5929 overridable = !e->value.compcall.tbp->non_overridable;
5930 if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
5932 /* If the base_object is not a variable, the corresponding actual
5933 argument expression must be stored in e->base_expression so
5934 that the corresponding tree temporary can be used as the base
5935 object in gfc_conv_procedure_call. */
5936 if (expr->expr_type != EXPR_VARIABLE)
5938 gfc_actual_arglist *args;
5940 for (args= e->value.function.actual; args; args = args->next)
5942 if (expr == args->expr)
5947 /* Since the typebound operators are generic, we have to ensure
5948 that any delays in resolution are corrected and that the vtab
5951 declared = ts.u.derived;
5952 c = gfc_find_component (declared, "_vptr", true, true);
5953 if (c->ts.u.derived == NULL)
5954 c->ts.u.derived = gfc_find_derived_vtab (declared);
5956 if (resolve_compcall (e, &name) == FAILURE)
5959 /* Use the generic name if it is there. */
5960 name = name ? name : e->value.function.esym->name;
5961 e->symtree = expr->symtree;
5962 e->ref = gfc_copy_ref (expr->ref);
5963 get_declared_from_expr (&class_ref, NULL, e, false);
5965 /* Trim away the extraneous references that emerge from nested
5966 use of interface.c (extend_expr). */
5967 if (class_ref && class_ref->next)
5969 gfc_free_ref_list (class_ref->next);
5970 class_ref->next = NULL;
5972 else if (e->ref && !class_ref)
5974 gfc_free_ref_list (e->ref);
5978 gfc_add_vptr_component (e);
5979 gfc_add_component_ref (e, name);
5980 e->value.function.esym = NULL;
5981 if (expr->expr_type != EXPR_VARIABLE)
5982 e->base_expr = expr;
5987 return resolve_compcall (e, NULL);
5989 if (resolve_ref (e) == FAILURE)
5992 /* Get the CLASS declared type. */
5993 declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
5995 /* Weed out cases of the ultimate component being a derived type. */
5996 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5997 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5999 gfc_free_ref_list (new_ref);
6000 return resolve_compcall (e, NULL);
6003 c = gfc_find_component (declared, "_data", true, true);
6004 declared = c->ts.u.derived;
6006 /* Treat the call as if it is a typebound procedure, in order to roll
6007 out the correct name for the specific function. */
6008 if (resolve_compcall (e, &name) == FAILURE)
6014 /* Convert the expression to a procedure pointer component call. */
6015 e->value.function.esym = NULL;
6021 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6022 gfc_add_vptr_component (e);
6023 gfc_add_component_ref (e, name);
6025 /* Recover the typespec for the expression. This is really only
6026 necessary for generic procedures, where the additional call
6027 to gfc_add_component_ref seems to throw the collection of the
6028 correct typespec. */
6035 /* Resolve a typebound subroutine, or 'method'. First separate all
6036 the non-CLASS references by calling resolve_typebound_call
6040 resolve_typebound_subroutine (gfc_code *code)
6042 gfc_symbol *declared;
6052 st = code->expr1->symtree;
6054 /* Deal with typebound operators for CLASS objects. */
6055 expr = code->expr1->value.compcall.base_object;
6056 overridable = !code->expr1->value.compcall.tbp->non_overridable;
6057 if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
6059 /* If the base_object is not a variable, the corresponding actual
6060 argument expression must be stored in e->base_expression so
6061 that the corresponding tree temporary can be used as the base
6062 object in gfc_conv_procedure_call. */
6063 if (expr->expr_type != EXPR_VARIABLE)
6065 gfc_actual_arglist *args;
6067 args= code->expr1->value.function.actual;
6068 for (; args; args = args->next)
6069 if (expr == args->expr)
6073 /* Since the typebound operators are generic, we have to ensure
6074 that any delays in resolution are corrected and that the vtab
6076 declared = expr->ts.u.derived;
6077 c = gfc_find_component (declared, "_vptr", true, true);
6078 if (c->ts.u.derived == NULL)
6079 c->ts.u.derived = gfc_find_derived_vtab (declared);
6081 if (resolve_typebound_call (code, &name) == FAILURE)
6084 /* Use the generic name if it is there. */
6085 name = name ? name : code->expr1->value.function.esym->name;
6086 code->expr1->symtree = expr->symtree;
6087 code->expr1->ref = gfc_copy_ref (expr->ref);
6089 /* Trim away the extraneous references that emerge from nested
6090 use of interface.c (extend_expr). */
6091 get_declared_from_expr (&class_ref, NULL, code->expr1, false);
6092 if (class_ref && class_ref->next)
6094 gfc_free_ref_list (class_ref->next);
6095 class_ref->next = NULL;
6097 else if (code->expr1->ref && !class_ref)
6099 gfc_free_ref_list (code->expr1->ref);
6100 code->expr1->ref = NULL;
6103 /* Now use the procedure in the vtable. */
6104 gfc_add_vptr_component (code->expr1);
6105 gfc_add_component_ref (code->expr1, name);
6106 code->expr1->value.function.esym = NULL;
6107 if (expr->expr_type != EXPR_VARIABLE)
6108 code->expr1->base_expr = expr;
6113 return resolve_typebound_call (code, NULL);
6115 if (resolve_ref (code->expr1) == FAILURE)
6118 /* Get the CLASS declared type. */
6119 get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
6121 /* Weed out cases of the ultimate component being a derived type. */
6122 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
6123 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
6125 gfc_free_ref_list (new_ref);
6126 return resolve_typebound_call (code, NULL);
6129 if (resolve_typebound_call (code, &name) == FAILURE)
6131 ts = code->expr1->ts;
6135 /* Convert the expression to a procedure pointer component call. */
6136 code->expr1->value.function.esym = NULL;
6137 code->expr1->symtree = st;
6140 code->expr1->ref = new_ref;
6142 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6143 gfc_add_vptr_component (code->expr1);
6144 gfc_add_component_ref (code->expr1, name);
6146 /* Recover the typespec for the expression. This is really only
6147 necessary for generic procedures, where the additional call
6148 to gfc_add_component_ref seems to throw the collection of the
6149 correct typespec. */
6150 code->expr1->ts = ts;
6157 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6160 resolve_ppc_call (gfc_code* c)
6162 gfc_component *comp;
6165 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
6168 c->resolved_sym = c->expr1->symtree->n.sym;
6169 c->expr1->expr_type = EXPR_VARIABLE;
6171 if (!comp->attr.subroutine)
6172 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
6174 if (resolve_ref (c->expr1) == FAILURE)
6177 if (update_ppc_arglist (c->expr1) == FAILURE)
6180 c->ext.actual = c->expr1->value.compcall.actual;
6182 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
6183 comp->formal == NULL) == FAILURE)
6186 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
6192 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6195 resolve_expr_ppc (gfc_expr* e)
6197 gfc_component *comp;
6200 b = gfc_is_proc_ptr_comp (e, &comp);
6203 /* Convert to EXPR_FUNCTION. */
6204 e->expr_type = EXPR_FUNCTION;
6205 e->value.function.isym = NULL;
6206 e->value.function.actual = e->value.compcall.actual;
6208 if (comp->as != NULL)
6209 e->rank = comp->as->rank;
6211 if (!comp->attr.function)
6212 gfc_add_function (&comp->attr, comp->name, &e->where);
6214 if (resolve_ref (e) == FAILURE)
6217 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
6218 comp->formal == NULL) == FAILURE)
6221 if (update_ppc_arglist (e) == FAILURE)
6224 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
6231 gfc_is_expandable_expr (gfc_expr *e)
6233 gfc_constructor *con;
6235 if (e->expr_type == EXPR_ARRAY)
6237 /* Traverse the constructor looking for variables that are flavor
6238 parameter. Parameters must be expanded since they are fully used at
6240 con = gfc_constructor_first (e->value.constructor);
6241 for (; con; con = gfc_constructor_next (con))
6243 if (con->expr->expr_type == EXPR_VARIABLE
6244 && con->expr->symtree
6245 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6246 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
6248 if (con->expr->expr_type == EXPR_ARRAY
6249 && gfc_is_expandable_expr (con->expr))
6257 /* Resolve an expression. That is, make sure that types of operands agree
6258 with their operators, intrinsic operators are converted to function calls
6259 for overloaded types and unresolved function references are resolved. */
6262 gfc_resolve_expr (gfc_expr *e)
6270 /* inquiry_argument only applies to variables. */
6271 inquiry_save = inquiry_argument;
6272 if (e->expr_type != EXPR_VARIABLE)
6273 inquiry_argument = false;
6275 switch (e->expr_type)
6278 t = resolve_operator (e);
6284 if (check_host_association (e))
6285 t = resolve_function (e);
6288 t = resolve_variable (e);
6290 expression_rank (e);
6293 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6294 && e->ref->type != REF_SUBSTRING)
6295 gfc_resolve_substring_charlen (e);
6300 t = resolve_typebound_function (e);
6303 case EXPR_SUBSTRING:
6304 t = resolve_ref (e);
6313 t = resolve_expr_ppc (e);
6318 if (resolve_ref (e) == FAILURE)
6321 t = gfc_resolve_array_constructor (e);
6322 /* Also try to expand a constructor. */
6325 expression_rank (e);
6326 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6327 gfc_expand_constructor (e, false);
6330 /* This provides the opportunity for the length of constructors with
6331 character valued function elements to propagate the string length
6332 to the expression. */
6333 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6335 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6336 here rather then add a duplicate test for it above. */
6337 gfc_expand_constructor (e, false);
6338 t = gfc_resolve_character_array_constructor (e);
6343 case EXPR_STRUCTURE:
6344 t = resolve_ref (e);
6348 t = resolve_structure_cons (e, 0);
6352 t = gfc_simplify_expr (e, 0);
6356 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6359 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6362 inquiry_argument = inquiry_save;
6368 /* Resolve an expression from an iterator. They must be scalar and have
6369 INTEGER or (optionally) REAL type. */
6372 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6373 const char *name_msgid)
6375 if (gfc_resolve_expr (expr) == FAILURE)
6378 if (expr->rank != 0)
6380 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6384 if (expr->ts.type != BT_INTEGER)
6386 if (expr->ts.type == BT_REAL)
6389 return gfc_notify_std (GFC_STD_F95_DEL,
6390 "Deleted feature: %s at %L must be integer",
6391 _(name_msgid), &expr->where);
6394 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6401 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6409 /* Resolve the expressions in an iterator structure. If REAL_OK is
6410 false allow only INTEGER type iterators, otherwise allow REAL types. */
6413 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6415 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6419 if (gfc_check_vardef_context (iter->var, false, false, _("iterator variable"))
6423 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6424 "Start expression in DO loop") == FAILURE)
6427 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6428 "End expression in DO loop") == FAILURE)
6431 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6432 "Step expression in DO loop") == FAILURE)
6435 if (iter->step->expr_type == EXPR_CONSTANT)
6437 if ((iter->step->ts.type == BT_INTEGER
6438 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6439 || (iter->step->ts.type == BT_REAL
6440 && mpfr_sgn (iter->step->value.real) == 0))
6442 gfc_error ("Step expression in DO loop at %L cannot be zero",
6443 &iter->step->where);
6448 /* Convert start, end, and step to the same type as var. */
6449 if (iter->start->ts.kind != iter->var->ts.kind
6450 || iter->start->ts.type != iter->var->ts.type)
6451 gfc_convert_type (iter->start, &iter->var->ts, 2);
6453 if (iter->end->ts.kind != iter->var->ts.kind
6454 || iter->end->ts.type != iter->var->ts.type)
6455 gfc_convert_type (iter->end, &iter->var->ts, 2);
6457 if (iter->step->ts.kind != iter->var->ts.kind
6458 || iter->step->ts.type != iter->var->ts.type)
6459 gfc_convert_type (iter->step, &iter->var->ts, 2);
6461 if (iter->start->expr_type == EXPR_CONSTANT
6462 && iter->end->expr_type == EXPR_CONSTANT
6463 && iter->step->expr_type == EXPR_CONSTANT)
6466 if (iter->start->ts.type == BT_INTEGER)
6468 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6469 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6473 sgn = mpfr_sgn (iter->step->value.real);
6474 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6476 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6477 gfc_warning ("DO loop at %L will be executed zero times",
6478 &iter->step->where);
6485 /* Traversal function for find_forall_index. f == 2 signals that
6486 that variable itself is not to be checked - only the references. */
6489 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6491 if (expr->expr_type != EXPR_VARIABLE)
6494 /* A scalar assignment */
6495 if (!expr->ref || *f == 1)
6497 if (expr->symtree->n.sym == sym)
6509 /* Check whether the FORALL index appears in the expression or not.
6510 Returns SUCCESS if SYM is found in EXPR. */
6513 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6515 if (gfc_traverse_expr (expr, sym, forall_index, f))
6522 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6523 to be a scalar INTEGER variable. The subscripts and stride are scalar
6524 INTEGERs, and if stride is a constant it must be nonzero.
6525 Furthermore "A subscript or stride in a forall-triplet-spec shall
6526 not contain a reference to any index-name in the
6527 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6530 resolve_forall_iterators (gfc_forall_iterator *it)
6532 gfc_forall_iterator *iter, *iter2;
6534 for (iter = it; iter; iter = iter->next)
6536 if (gfc_resolve_expr (iter->var) == SUCCESS
6537 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6538 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6541 if (gfc_resolve_expr (iter->start) == SUCCESS
6542 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6543 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6544 &iter->start->where);
6545 if (iter->var->ts.kind != iter->start->ts.kind)
6546 gfc_convert_type (iter->start, &iter->var->ts, 1);
6548 if (gfc_resolve_expr (iter->end) == SUCCESS
6549 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6550 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6552 if (iter->var->ts.kind != iter->end->ts.kind)
6553 gfc_convert_type (iter->end, &iter->var->ts, 1);
6555 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6557 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6558 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6559 &iter->stride->where, "INTEGER");
6561 if (iter->stride->expr_type == EXPR_CONSTANT
6562 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6563 gfc_error ("FORALL stride expression at %L cannot be zero",
6564 &iter->stride->where);
6566 if (iter->var->ts.kind != iter->stride->ts.kind)
6567 gfc_convert_type (iter->stride, &iter->var->ts, 1);
6570 for (iter = it; iter; iter = iter->next)
6571 for (iter2 = iter; iter2; iter2 = iter2->next)
6573 if (find_forall_index (iter2->start,
6574 iter->var->symtree->n.sym, 0) == SUCCESS
6575 || find_forall_index (iter2->end,
6576 iter->var->symtree->n.sym, 0) == SUCCESS
6577 || find_forall_index (iter2->stride,
6578 iter->var->symtree->n.sym, 0) == SUCCESS)
6579 gfc_error ("FORALL index '%s' may not appear in triplet "
6580 "specification at %L", iter->var->symtree->name,
6581 &iter2->start->where);
6586 /* Given a pointer to a symbol that is a derived type, see if it's
6587 inaccessible, i.e. if it's defined in another module and the components are
6588 PRIVATE. The search is recursive if necessary. Returns zero if no
6589 inaccessible components are found, nonzero otherwise. */
6592 derived_inaccessible (gfc_symbol *sym)
6596 if (sym->attr.use_assoc && sym->attr.private_comp)
6599 for (c = sym->components; c; c = c->next)
6601 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6609 /* Resolve the argument of a deallocate expression. The expression must be
6610 a pointer or a full array. */
6613 resolve_deallocate_expr (gfc_expr *e)
6615 symbol_attribute attr;
6616 int allocatable, pointer;
6621 if (gfc_resolve_expr (e) == FAILURE)
6624 if (e->expr_type != EXPR_VARIABLE)
6627 sym = e->symtree->n.sym;
6629 if (sym->ts.type == BT_CLASS)
6631 allocatable = CLASS_DATA (sym)->attr.allocatable;
6632 pointer = CLASS_DATA (sym)->attr.class_pointer;
6636 allocatable = sym->attr.allocatable;
6637 pointer = sym->attr.pointer;
6639 for (ref = e->ref; ref; ref = ref->next)
6644 if (ref->u.ar.type != AR_FULL
6645 && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
6646 && ref->u.ar.codimen && gfc_ref_this_image (ref)))
6651 c = ref->u.c.component;
6652 if (c->ts.type == BT_CLASS)
6654 allocatable = CLASS_DATA (c)->attr.allocatable;
6655 pointer = CLASS_DATA (c)->attr.class_pointer;
6659 allocatable = c->attr.allocatable;
6660 pointer = c->attr.pointer;
6670 attr = gfc_expr_attr (e);
6672 if (allocatable == 0 && attr.pointer == 0)
6675 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6681 if (gfc_is_coindexed (e))
6683 gfc_error ("Coindexed allocatable object at %L", &e->where);
6688 && gfc_check_vardef_context (e, true, true, _("DEALLOCATE object"))
6691 if (gfc_check_vardef_context (e, false, true, _("DEALLOCATE object"))
6699 /* Returns true if the expression e contains a reference to the symbol sym. */
6701 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6703 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6710 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6712 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6716 /* Given the expression node e for an allocatable/pointer of derived type to be
6717 allocated, get the expression node to be initialized afterwards (needed for
6718 derived types with default initializers, and derived types with allocatable
6719 components that need nullification.) */
6722 gfc_expr_to_initialize (gfc_expr *e)
6728 result = gfc_copy_expr (e);
6730 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6731 for (ref = result->ref; ref; ref = ref->next)
6732 if (ref->type == REF_ARRAY && ref->next == NULL)
6734 ref->u.ar.type = AR_FULL;
6736 for (i = 0; i < ref->u.ar.dimen; i++)
6737 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6742 gfc_free_shape (&result->shape, result->rank);
6744 /* Recalculate rank, shape, etc. */
6745 gfc_resolve_expr (result);
6750 /* If the last ref of an expression is an array ref, return a copy of the
6751 expression with that one removed. Otherwise, a copy of the original
6752 expression. This is used for allocate-expressions and pointer assignment
6753 LHS, where there may be an array specification that needs to be stripped
6754 off when using gfc_check_vardef_context. */
6757 remove_last_array_ref (gfc_expr* e)
6762 e2 = gfc_copy_expr (e);
6763 for (r = &e2->ref; *r; r = &(*r)->next)
6764 if ((*r)->type == REF_ARRAY && !(*r)->next)
6766 gfc_free_ref_list (*r);
6775 /* Used in resolve_allocate_expr to check that a allocation-object and
6776 a source-expr are conformable. This does not catch all possible
6777 cases; in particular a runtime checking is needed. */
6780 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6783 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6785 /* First compare rank. */
6786 if (tail && e1->rank != tail->u.ar.as->rank)
6788 gfc_error ("Source-expr at %L must be scalar or have the "
6789 "same rank as the allocate-object at %L",
6790 &e1->where, &e2->where);
6801 for (i = 0; i < e1->rank; i++)
6803 if (tail->u.ar.end[i])
6805 mpz_set (s, tail->u.ar.end[i]->value.integer);
6806 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6807 mpz_add_ui (s, s, 1);
6811 mpz_set (s, tail->u.ar.start[i]->value.integer);
6814 if (mpz_cmp (e1->shape[i], s) != 0)
6816 gfc_error ("Source-expr at %L and allocate-object at %L must "
6817 "have the same shape", &e1->where, &e2->where);
6830 /* Resolve the expression in an ALLOCATE statement, doing the additional
6831 checks to see whether the expression is OK or not. The expression must
6832 have a trailing array reference that gives the size of the array. */
6835 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6837 int i, pointer, allocatable, dimension, is_abstract;
6840 symbol_attribute attr;
6841 gfc_ref *ref, *ref2;
6844 gfc_symbol *sym = NULL;
6849 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6850 checking of coarrays. */
6851 for (ref = e->ref; ref; ref = ref->next)
6852 if (ref->next == NULL)
6855 if (ref && ref->type == REF_ARRAY)
6856 ref->u.ar.in_allocate = true;
6858 if (gfc_resolve_expr (e) == FAILURE)
6861 /* Make sure the expression is allocatable or a pointer. If it is
6862 pointer, the next-to-last reference must be a pointer. */
6866 sym = e->symtree->n.sym;
6868 /* Check whether ultimate component is abstract and CLASS. */
6871 if (e->expr_type != EXPR_VARIABLE)
6874 attr = gfc_expr_attr (e);
6875 pointer = attr.pointer;
6876 dimension = attr.dimension;
6877 codimension = attr.codimension;
6881 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
6883 allocatable = CLASS_DATA (sym)->attr.allocatable;
6884 pointer = CLASS_DATA (sym)->attr.class_pointer;
6885 dimension = CLASS_DATA (sym)->attr.dimension;
6886 codimension = CLASS_DATA (sym)->attr.codimension;
6887 is_abstract = CLASS_DATA (sym)->attr.abstract;
6891 allocatable = sym->attr.allocatable;
6892 pointer = sym->attr.pointer;
6893 dimension = sym->attr.dimension;
6894 codimension = sym->attr.codimension;
6899 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6904 if (ref->u.ar.codimen > 0)
6907 for (n = ref->u.ar.dimen;
6908 n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
6909 if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
6916 if (ref->next != NULL)
6924 gfc_error ("Coindexed allocatable object at %L",
6929 c = ref->u.c.component;
6930 if (c->ts.type == BT_CLASS)
6932 allocatable = CLASS_DATA (c)->attr.allocatable;
6933 pointer = CLASS_DATA (c)->attr.class_pointer;
6934 dimension = CLASS_DATA (c)->attr.dimension;
6935 codimension = CLASS_DATA (c)->attr.codimension;
6936 is_abstract = CLASS_DATA (c)->attr.abstract;
6940 allocatable = c->attr.allocatable;
6941 pointer = c->attr.pointer;
6942 dimension = c->attr.dimension;
6943 codimension = c->attr.codimension;
6944 is_abstract = c->attr.abstract;
6956 if (allocatable == 0 && pointer == 0)
6958 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6963 /* Some checks for the SOURCE tag. */
6966 /* Check F03:C631. */
6967 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6969 gfc_error ("Type of entity at %L is type incompatible with "
6970 "source-expr at %L", &e->where, &code->expr3->where);
6974 /* Check F03:C632 and restriction following Note 6.18. */
6975 if (code->expr3->rank > 0
6976 && conformable_arrays (code->expr3, e) == FAILURE)
6979 /* Check F03:C633. */
6980 if (code->expr3->ts.kind != e->ts.kind)
6982 gfc_error ("The allocate-object at %L and the source-expr at %L "
6983 "shall have the same kind type parameter",
6984 &e->where, &code->expr3->where);
6988 /* Check F2008, C642. */
6989 if (code->expr3->ts.type == BT_DERIVED
6990 && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
6991 || (code->expr3->ts.u.derived->from_intmod
6992 == INTMOD_ISO_FORTRAN_ENV
6993 && code->expr3->ts.u.derived->intmod_sym_id
6994 == ISOFORTRAN_LOCK_TYPE)))
6996 gfc_error ("The source-expr at %L shall neither be of type "
6997 "LOCK_TYPE nor have a LOCK_TYPE component if "
6998 "allocate-object at %L is a coarray",
6999 &code->expr3->where, &e->where);
7004 /* Check F08:C629. */
7005 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
7008 gcc_assert (e->ts.type == BT_CLASS);
7009 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7010 "type-spec or source-expr", sym->name, &e->where);
7014 if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred)
7016 int cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
7017 code->ext.alloc.ts.u.cl->length);
7018 if (cmp == 1 || cmp == -1 || cmp == -3)
7020 gfc_error ("Allocating %s at %L with type-spec requires the same "
7021 "character-length parameter as in the declaration",
7022 sym->name, &e->where);
7027 /* In the variable definition context checks, gfc_expr_attr is used
7028 on the expression. This is fooled by the array specification
7029 present in e, thus we have to eliminate that one temporarily. */
7030 e2 = remove_last_array_ref (e);
7032 if (t == SUCCESS && pointer)
7033 t = gfc_check_vardef_context (e2, true, true, _("ALLOCATE object"));
7035 t = gfc_check_vardef_context (e2, false, true, _("ALLOCATE object"));
7040 if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
7041 && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
7043 /* For class arrays, the initialization with SOURCE is done
7044 using _copy and trans_call. It is convenient to exploit that
7045 when the allocated type is different from the declared type but
7046 no SOURCE exists by setting expr3. */
7047 code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
7049 else if (!code->expr3)
7051 /* Set up default initializer if needed. */
7055 if (code->ext.alloc.ts.type == BT_DERIVED)
7056 ts = code->ext.alloc.ts;
7060 if (ts.type == BT_CLASS)
7061 ts = ts.u.derived->components->ts;
7063 if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
7065 gfc_code *init_st = gfc_get_code ();
7066 init_st->loc = code->loc;
7067 init_st->op = EXEC_INIT_ASSIGN;
7068 init_st->expr1 = gfc_expr_to_initialize (e);
7069 init_st->expr2 = init_e;
7070 init_st->next = code->next;
7071 code->next = init_st;
7074 else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
7076 /* Default initialization via MOLD (non-polymorphic). */
7077 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
7078 gfc_resolve_expr (rhs);
7079 gfc_free_expr (code->expr3);
7083 if (e->ts.type == BT_CLASS)
7085 /* Make sure the vtab symbol is present when
7086 the module variables are generated. */
7087 gfc_typespec ts = e->ts;
7089 ts = code->expr3->ts;
7090 else if (code->ext.alloc.ts.type == BT_DERIVED)
7091 ts = code->ext.alloc.ts;
7092 gfc_find_derived_vtab (ts.u.derived);
7094 e = gfc_expr_to_initialize (e);
7097 if (dimension == 0 && codimension == 0)
7100 /* Make sure the last reference node is an array specifiction. */
7102 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
7103 || (dimension && ref2->u.ar.dimen == 0))
7105 gfc_error ("Array specification required in ALLOCATE statement "
7106 "at %L", &e->where);
7110 /* Make sure that the array section reference makes sense in the
7111 context of an ALLOCATE specification. */
7116 for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
7117 if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
7119 gfc_error ("Coarray specification required in ALLOCATE statement "
7120 "at %L", &e->where);
7124 for (i = 0; i < ar->dimen; i++)
7126 if (ref2->u.ar.type == AR_ELEMENT)
7129 switch (ar->dimen_type[i])
7135 if (ar->start[i] != NULL
7136 && ar->end[i] != NULL
7137 && ar->stride[i] == NULL)
7140 /* Fall Through... */
7145 case DIMEN_THIS_IMAGE:
7146 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7152 for (a = code->ext.alloc.list; a; a = a->next)
7154 sym = a->expr->symtree->n.sym;
7156 /* TODO - check derived type components. */
7157 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
7160 if ((ar->start[i] != NULL
7161 && gfc_find_sym_in_expr (sym, ar->start[i]))
7162 || (ar->end[i] != NULL
7163 && gfc_find_sym_in_expr (sym, ar->end[i])))
7165 gfc_error ("'%s' must not appear in the array specification at "
7166 "%L in the same ALLOCATE statement where it is "
7167 "itself allocated", sym->name, &ar->where);
7173 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
7175 if (ar->dimen_type[i] == DIMEN_ELEMENT
7176 || ar->dimen_type[i] == DIMEN_RANGE)
7178 if (i == (ar->dimen + ar->codimen - 1))
7180 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7181 "statement at %L", &e->where);
7187 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
7188 && ar->stride[i] == NULL)
7191 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7204 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
7206 gfc_expr *stat, *errmsg, *pe, *qe;
7207 gfc_alloc *a, *p, *q;
7210 errmsg = code->expr2;
7212 /* Check the stat variable. */
7215 gfc_check_vardef_context (stat, false, false, _("STAT variable"));
7217 if ((stat->ts.type != BT_INTEGER
7218 && !(stat->ref && (stat->ref->type == REF_ARRAY
7219 || stat->ref->type == REF_COMPONENT)))
7221 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7222 "variable", &stat->where);
7224 for (p = code->ext.alloc.list; p; p = p->next)
7225 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
7227 gfc_ref *ref1, *ref2;
7230 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
7231 ref1 = ref1->next, ref2 = ref2->next)
7233 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7235 if (ref1->u.c.component->name != ref2->u.c.component->name)
7244 gfc_error ("Stat-variable at %L shall not be %sd within "
7245 "the same %s statement", &stat->where, fcn, fcn);
7251 /* Check the errmsg variable. */
7255 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7258 gfc_check_vardef_context (errmsg, false, false, _("ERRMSG variable"));
7260 if ((errmsg->ts.type != BT_CHARACTER
7262 && (errmsg->ref->type == REF_ARRAY
7263 || errmsg->ref->type == REF_COMPONENT)))
7264 || errmsg->rank > 0 )
7265 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7266 "variable", &errmsg->where);
7268 for (p = code->ext.alloc.list; p; p = p->next)
7269 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
7271 gfc_ref *ref1, *ref2;
7274 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
7275 ref1 = ref1->next, ref2 = ref2->next)
7277 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7279 if (ref1->u.c.component->name != ref2->u.c.component->name)
7288 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7289 "the same %s statement", &errmsg->where, fcn, fcn);
7295 /* Check that an allocate-object appears only once in the statement.
7296 FIXME: Checking derived types is disabled. */
7297 for (p = code->ext.alloc.list; p; p = p->next)
7300 for (q = p->next; q; q = q->next)
7303 if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
7305 /* This is a potential collision. */
7306 gfc_ref *pr = pe->ref;
7307 gfc_ref *qr = qe->ref;
7309 /* Follow the references until
7310 a) They start to differ, in which case there is no error;
7311 you can deallocate a%b and a%c in a single statement
7312 b) Both of them stop, which is an error
7313 c) One of them stops, which is also an error. */
7316 if (pr == NULL && qr == NULL)
7318 gfc_error ("Allocate-object at %L also appears at %L",
7319 &pe->where, &qe->where);
7322 else if (pr != NULL && qr == NULL)
7324 gfc_error ("Allocate-object at %L is subobject of"
7325 " object at %L", &pe->where, &qe->where);
7328 else if (pr == NULL && qr != NULL)
7330 gfc_error ("Allocate-object at %L is subobject of"
7331 " object at %L", &qe->where, &pe->where);
7334 /* Here, pr != NULL && qr != NULL */
7335 gcc_assert(pr->type == qr->type);
7336 if (pr->type == REF_ARRAY)
7338 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7340 gcc_assert (qr->type == REF_ARRAY);
7342 if (pr->next && qr->next)
7344 gfc_array_ref *par = &(pr->u.ar);
7345 gfc_array_ref *qar = &(qr->u.ar);
7346 if (gfc_dep_compare_expr (par->start[0],
7347 qar->start[0]) != 0)
7353 if (pr->u.c.component->name != qr->u.c.component->name)
7364 if (strcmp (fcn, "ALLOCATE") == 0)
7366 for (a = code->ext.alloc.list; a; a = a->next)
7367 resolve_allocate_expr (a->expr, code);
7371 for (a = code->ext.alloc.list; a; a = a->next)
7372 resolve_deallocate_expr (a->expr);
7377 /************ SELECT CASE resolution subroutines ************/
7379 /* Callback function for our mergesort variant. Determines interval
7380 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7381 op1 > op2. Assumes we're not dealing with the default case.
7382 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7383 There are nine situations to check. */
7386 compare_cases (const gfc_case *op1, const gfc_case *op2)
7390 if (op1->low == NULL) /* op1 = (:L) */
7392 /* op2 = (:N), so overlap. */
7394 /* op2 = (M:) or (M:N), L < M */
7395 if (op2->low != NULL
7396 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7399 else if (op1->high == NULL) /* op1 = (K:) */
7401 /* op2 = (M:), so overlap. */
7403 /* op2 = (:N) or (M:N), K > N */
7404 if (op2->high != NULL
7405 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7408 else /* op1 = (K:L) */
7410 if (op2->low == NULL) /* op2 = (:N), K > N */
7411 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7413 else if (op2->high == NULL) /* op2 = (M:), L < M */
7414 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7416 else /* op2 = (M:N) */
7420 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7423 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7432 /* Merge-sort a double linked case list, detecting overlap in the
7433 process. LIST is the head of the double linked case list before it
7434 is sorted. Returns the head of the sorted list if we don't see any
7435 overlap, or NULL otherwise. */
7438 check_case_overlap (gfc_case *list)
7440 gfc_case *p, *q, *e, *tail;
7441 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7443 /* If the passed list was empty, return immediately. */
7450 /* Loop unconditionally. The only exit from this loop is a return
7451 statement, when we've finished sorting the case list. */
7458 /* Count the number of merges we do in this pass. */
7461 /* Loop while there exists a merge to be done. */
7466 /* Count this merge. */
7469 /* Cut the list in two pieces by stepping INSIZE places
7470 forward in the list, starting from P. */
7473 for (i = 0; i < insize; i++)
7482 /* Now we have two lists. Merge them! */
7483 while (psize > 0 || (qsize > 0 && q != NULL))
7485 /* See from which the next case to merge comes from. */
7488 /* P is empty so the next case must come from Q. */
7493 else if (qsize == 0 || q == NULL)
7502 cmp = compare_cases (p, q);
7505 /* The whole case range for P is less than the
7513 /* The whole case range for Q is greater than
7514 the case range for P. */
7521 /* The cases overlap, or they are the same
7522 element in the list. Either way, we must
7523 issue an error and get the next case from P. */
7524 /* FIXME: Sort P and Q by line number. */
7525 gfc_error ("CASE label at %L overlaps with CASE "
7526 "label at %L", &p->where, &q->where);
7534 /* Add the next element to the merged list. */
7543 /* P has now stepped INSIZE places along, and so has Q. So
7544 they're the same. */
7549 /* If we have done only one merge or none at all, we've
7550 finished sorting the cases. */
7559 /* Otherwise repeat, merging lists twice the size. */
7565 /* Check to see if an expression is suitable for use in a CASE statement.
7566 Makes sure that all case expressions are scalar constants of the same
7567 type. Return FAILURE if anything is wrong. */
7570 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7572 if (e == NULL) return SUCCESS;
7574 if (e->ts.type != case_expr->ts.type)
7576 gfc_error ("Expression in CASE statement at %L must be of type %s",
7577 &e->where, gfc_basic_typename (case_expr->ts.type));
7581 /* C805 (R808) For a given case-construct, each case-value shall be of
7582 the same type as case-expr. For character type, length differences
7583 are allowed, but the kind type parameters shall be the same. */
7585 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7587 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7588 &e->where, case_expr->ts.kind);
7592 /* Convert the case value kind to that of case expression kind,
7595 if (e->ts.kind != case_expr->ts.kind)
7596 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7600 gfc_error ("Expression in CASE statement at %L must be scalar",
7609 /* Given a completely parsed select statement, we:
7611 - Validate all expressions and code within the SELECT.
7612 - Make sure that the selection expression is not of the wrong type.
7613 - Make sure that no case ranges overlap.
7614 - Eliminate unreachable cases and unreachable code resulting from
7615 removing case labels.
7617 The standard does allow unreachable cases, e.g. CASE (5:3). But
7618 they are a hassle for code generation, and to prevent that, we just
7619 cut them out here. This is not necessary for overlapping cases
7620 because they are illegal and we never even try to generate code.
7622 We have the additional caveat that a SELECT construct could have
7623 been a computed GOTO in the source code. Fortunately we can fairly
7624 easily work around that here: The case_expr for a "real" SELECT CASE
7625 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7626 we have to do is make sure that the case_expr is a scalar integer
7630 resolve_select (gfc_code *code)
7633 gfc_expr *case_expr;
7634 gfc_case *cp, *default_case, *tail, *head;
7635 int seen_unreachable;
7641 if (code->expr1 == NULL)
7643 /* This was actually a computed GOTO statement. */
7644 case_expr = code->expr2;
7645 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7646 gfc_error ("Selection expression in computed GOTO statement "
7647 "at %L must be a scalar integer expression",
7650 /* Further checking is not necessary because this SELECT was built
7651 by the compiler, so it should always be OK. Just move the
7652 case_expr from expr2 to expr so that we can handle computed
7653 GOTOs as normal SELECTs from here on. */
7654 code->expr1 = code->expr2;
7659 case_expr = code->expr1;
7661 type = case_expr->ts.type;
7662 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7664 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7665 &case_expr->where, gfc_typename (&case_expr->ts));
7667 /* Punt. Going on here just produce more garbage error messages. */
7671 /* Raise a warning if an INTEGER case value exceeds the range of
7672 the case-expr. Later, all expressions will be promoted to the
7673 largest kind of all case-labels. */
7675 if (type == BT_INTEGER)
7676 for (body = code->block; body; body = body->block)
7677 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7680 && gfc_check_integer_range (cp->low->value.integer,
7681 case_expr->ts.kind) != ARITH_OK)
7682 gfc_warning ("Expression in CASE statement at %L is "
7683 "not in the range of %s", &cp->low->where,
7684 gfc_typename (&case_expr->ts));
7687 && cp->low != cp->high
7688 && gfc_check_integer_range (cp->high->value.integer,
7689 case_expr->ts.kind) != ARITH_OK)
7690 gfc_warning ("Expression in CASE statement at %L is "
7691 "not in the range of %s", &cp->high->where,
7692 gfc_typename (&case_expr->ts));
7695 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7696 of the SELECT CASE expression and its CASE values. Walk the lists
7697 of case values, and if we find a mismatch, promote case_expr to
7698 the appropriate kind. */
7700 if (type == BT_LOGICAL || type == BT_INTEGER)
7702 for (body = code->block; body; body = body->block)
7704 /* Walk the case label list. */
7705 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7707 /* Intercept the DEFAULT case. It does not have a kind. */
7708 if (cp->low == NULL && cp->high == NULL)
7711 /* Unreachable case ranges are discarded, so ignore. */
7712 if (cp->low != NULL && cp->high != NULL
7713 && cp->low != cp->high
7714 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7718 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7719 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7721 if (cp->high != NULL
7722 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7723 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7728 /* Assume there is no DEFAULT case. */
7729 default_case = NULL;
7734 for (body = code->block; body; body = body->block)
7736 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7738 seen_unreachable = 0;
7740 /* Walk the case label list, making sure that all case labels
7742 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7744 /* Count the number of cases in the whole construct. */
7747 /* Intercept the DEFAULT case. */
7748 if (cp->low == NULL && cp->high == NULL)
7750 if (default_case != NULL)
7752 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7753 "by a second DEFAULT CASE at %L",
7754 &default_case->where, &cp->where);
7765 /* Deal with single value cases and case ranges. Errors are
7766 issued from the validation function. */
7767 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7768 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7774 if (type == BT_LOGICAL
7775 && ((cp->low == NULL || cp->high == NULL)
7776 || cp->low != cp->high))
7778 gfc_error ("Logical range in CASE statement at %L is not "
7779 "allowed", &cp->low->where);
7784 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7787 value = cp->low->value.logical == 0 ? 2 : 1;
7788 if (value & seen_logical)
7790 gfc_error ("Constant logical value in CASE statement "
7791 "is repeated at %L",
7796 seen_logical |= value;
7799 if (cp->low != NULL && cp->high != NULL
7800 && cp->low != cp->high
7801 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7803 if (gfc_option.warn_surprising)
7804 gfc_warning ("Range specification at %L can never "
7805 "be matched", &cp->where);
7807 cp->unreachable = 1;
7808 seen_unreachable = 1;
7812 /* If the case range can be matched, it can also overlap with
7813 other cases. To make sure it does not, we put it in a
7814 double linked list here. We sort that with a merge sort
7815 later on to detect any overlapping cases. */
7819 head->right = head->left = NULL;
7824 tail->right->left = tail;
7831 /* It there was a failure in the previous case label, give up
7832 for this case label list. Continue with the next block. */
7836 /* See if any case labels that are unreachable have been seen.
7837 If so, we eliminate them. This is a bit of a kludge because
7838 the case lists for a single case statement (label) is a
7839 single forward linked lists. */
7840 if (seen_unreachable)
7842 /* Advance until the first case in the list is reachable. */
7843 while (body->ext.block.case_list != NULL
7844 && body->ext.block.case_list->unreachable)
7846 gfc_case *n = body->ext.block.case_list;
7847 body->ext.block.case_list = body->ext.block.case_list->next;
7849 gfc_free_case_list (n);
7852 /* Strip all other unreachable cases. */
7853 if (body->ext.block.case_list)
7855 for (cp = body->ext.block.case_list; cp->next; cp = cp->next)
7857 if (cp->next->unreachable)
7859 gfc_case *n = cp->next;
7860 cp->next = cp->next->next;
7862 gfc_free_case_list (n);
7869 /* See if there were overlapping cases. If the check returns NULL,
7870 there was overlap. In that case we don't do anything. If head
7871 is non-NULL, we prepend the DEFAULT case. The sorted list can
7872 then used during code generation for SELECT CASE constructs with
7873 a case expression of a CHARACTER type. */
7876 head = check_case_overlap (head);
7878 /* Prepend the default_case if it is there. */
7879 if (head != NULL && default_case)
7881 default_case->left = NULL;
7882 default_case->right = head;
7883 head->left = default_case;
7887 /* Eliminate dead blocks that may be the result if we've seen
7888 unreachable case labels for a block. */
7889 for (body = code; body && body->block; body = body->block)
7891 if (body->block->ext.block.case_list == NULL)
7893 /* Cut the unreachable block from the code chain. */
7894 gfc_code *c = body->block;
7895 body->block = c->block;
7897 /* Kill the dead block, but not the blocks below it. */
7899 gfc_free_statements (c);
7903 /* More than two cases is legal but insane for logical selects.
7904 Issue a warning for it. */
7905 if (gfc_option.warn_surprising && type == BT_LOGICAL
7907 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7912 /* Check if a derived type is extensible. */
7915 gfc_type_is_extensible (gfc_symbol *sym)
7917 return !(sym->attr.is_bind_c || sym->attr.sequence);
7921 /* Resolve an associate name: Resolve target and ensure the type-spec is
7922 correct as well as possibly the array-spec. */
7925 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
7929 gcc_assert (sym->assoc);
7930 gcc_assert (sym->attr.flavor == FL_VARIABLE);
7932 /* If this is for SELECT TYPE, the target may not yet be set. In that
7933 case, return. Resolution will be called later manually again when
7935 target = sym->assoc->target;
7938 gcc_assert (!sym->assoc->dangling);
7940 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
7943 /* For variable targets, we get some attributes from the target. */
7944 if (target->expr_type == EXPR_VARIABLE)
7948 gcc_assert (target->symtree);
7949 tsym = target->symtree->n.sym;
7951 sym->attr.asynchronous = tsym->attr.asynchronous;
7952 sym->attr.volatile_ = tsym->attr.volatile_;
7954 sym->attr.target = tsym->attr.target
7955 || gfc_expr_attr (target).pointer;
7958 /* Get type if this was not already set. Note that it can be
7959 some other type than the target in case this is a SELECT TYPE
7960 selector! So we must not update when the type is already there. */
7961 if (sym->ts.type == BT_UNKNOWN)
7962 sym->ts = target->ts;
7963 gcc_assert (sym->ts.type != BT_UNKNOWN);
7965 /* See if this is a valid association-to-variable. */
7966 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
7967 && !gfc_has_vector_subscript (target));
7969 /* Finally resolve if this is an array or not. */
7970 if (sym->attr.dimension && target->rank == 0)
7972 gfc_error ("Associate-name '%s' at %L is used as array",
7973 sym->name, &sym->declared_at);
7974 sym->attr.dimension = 0;
7977 if (target->rank > 0)
7978 sym->attr.dimension = 1;
7980 if (sym->attr.dimension)
7982 sym->as = gfc_get_array_spec ();
7983 sym->as->rank = target->rank;
7984 sym->as->type = AS_DEFERRED;
7986 /* Target must not be coindexed, thus the associate-variable
7988 sym->as->corank = 0;
7993 /* Resolve a SELECT TYPE statement. */
7996 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
7998 gfc_symbol *selector_type;
7999 gfc_code *body, *new_st, *if_st, *tail;
8000 gfc_code *class_is = NULL, *default_case = NULL;
8003 char name[GFC_MAX_SYMBOL_LEN];
8007 ns = code->ext.block.ns;
8010 /* Check for F03:C813. */
8011 if (code->expr1->ts.type != BT_CLASS
8012 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
8014 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8015 "at %L", &code->loc);
8019 if (!code->expr1->symtree->n.sym->attr.class_ok)
8024 if (code->expr1->symtree->n.sym->attr.untyped)
8025 code->expr1->symtree->n.sym->ts = code->expr2->ts;
8026 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
8029 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
8031 /* Loop over TYPE IS / CLASS IS cases. */
8032 for (body = code->block; body; body = body->block)
8034 c = body->ext.block.case_list;
8036 /* Check F03:C815. */
8037 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8038 && !gfc_type_is_extensible (c->ts.u.derived))
8040 gfc_error ("Derived type '%s' at %L must be extensible",
8041 c->ts.u.derived->name, &c->where);
8046 /* Check F03:C816. */
8047 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8048 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
8050 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
8051 c->ts.u.derived->name, &c->where, selector_type->name);
8056 /* Intercept the DEFAULT case. */
8057 if (c->ts.type == BT_UNKNOWN)
8059 /* Check F03:C818. */
8062 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8063 "by a second DEFAULT CASE at %L",
8064 &default_case->ext.block.case_list->where, &c->where);
8069 default_case = body;
8076 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8077 target if present. If there are any EXIT statements referring to the
8078 SELECT TYPE construct, this is no problem because the gfc_code
8079 reference stays the same and EXIT is equally possible from the BLOCK
8080 it is changed to. */
8081 code->op = EXEC_BLOCK;
8084 gfc_association_list* assoc;
8086 assoc = gfc_get_association_list ();
8087 assoc->st = code->expr1->symtree;
8088 assoc->target = gfc_copy_expr (code->expr2);
8089 assoc->target->where = code->expr2->where;
8090 /* assoc->variable will be set by resolve_assoc_var. */
8092 code->ext.block.assoc = assoc;
8093 code->expr1->symtree->n.sym->assoc = assoc;
8095 resolve_assoc_var (code->expr1->symtree->n.sym, false);
8098 code->ext.block.assoc = NULL;
8100 /* Add EXEC_SELECT to switch on type. */
8101 new_st = gfc_get_code ();
8102 new_st->op = code->op;
8103 new_st->expr1 = code->expr1;
8104 new_st->expr2 = code->expr2;
8105 new_st->block = code->block;
8106 code->expr1 = code->expr2 = NULL;
8111 ns->code->next = new_st;
8113 code->op = EXEC_SELECT;
8114 gfc_add_vptr_component (code->expr1);
8115 gfc_add_hash_component (code->expr1);
8117 /* Loop over TYPE IS / CLASS IS cases. */
8118 for (body = code->block; body; body = body->block)
8120 c = body->ext.block.case_list;
8122 if (c->ts.type == BT_DERIVED)
8123 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
8124 c->ts.u.derived->hash_value);
8126 else if (c->ts.type == BT_UNKNOWN)
8129 /* Associate temporary to selector. This should only be done
8130 when this case is actually true, so build a new ASSOCIATE
8131 that does precisely this here (instead of using the
8134 if (c->ts.type == BT_CLASS)
8135 sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
8137 sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
8138 st = gfc_find_symtree (ns->sym_root, name);
8139 gcc_assert (st->n.sym->assoc);
8140 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
8141 st->n.sym->assoc->target->where = code->expr1->where;
8142 if (c->ts.type == BT_DERIVED)
8143 gfc_add_data_component (st->n.sym->assoc->target);
8145 new_st = gfc_get_code ();
8146 new_st->op = EXEC_BLOCK;
8147 new_st->ext.block.ns = gfc_build_block_ns (ns);
8148 new_st->ext.block.ns->code = body->next;
8149 body->next = new_st;
8151 /* Chain in the new list only if it is marked as dangling. Otherwise
8152 there is a CASE label overlap and this is already used. Just ignore,
8153 the error is diagonsed elsewhere. */
8154 if (st->n.sym->assoc->dangling)
8156 new_st->ext.block.assoc = st->n.sym->assoc;
8157 st->n.sym->assoc->dangling = 0;
8160 resolve_assoc_var (st->n.sym, false);
8163 /* Take out CLASS IS cases for separate treatment. */
8165 while (body && body->block)
8167 if (body->block->ext.block.case_list->ts.type == BT_CLASS)
8169 /* Add to class_is list. */
8170 if (class_is == NULL)
8172 class_is = body->block;
8177 for (tail = class_is; tail->block; tail = tail->block) ;
8178 tail->block = body->block;
8181 /* Remove from EXEC_SELECT list. */
8182 body->block = body->block->block;
8195 /* Add a default case to hold the CLASS IS cases. */
8196 for (tail = code; tail->block; tail = tail->block) ;
8197 tail->block = gfc_get_code ();
8199 tail->op = EXEC_SELECT_TYPE;
8200 tail->ext.block.case_list = gfc_get_case ();
8201 tail->ext.block.case_list->ts.type = BT_UNKNOWN;
8203 default_case = tail;
8206 /* More than one CLASS IS block? */
8207 if (class_is->block)
8211 /* Sort CLASS IS blocks by extension level. */
8215 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
8218 /* F03:C817 (check for doubles). */
8219 if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
8220 == c2->ext.block.case_list->ts.u.derived->hash_value)
8222 gfc_error ("Double CLASS IS block in SELECT TYPE "
8224 &c2->ext.block.case_list->where);
8227 if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
8228 < c2->ext.block.case_list->ts.u.derived->attr.extension)
8231 (*c1)->block = c2->block;
8241 /* Generate IF chain. */
8242 if_st = gfc_get_code ();
8243 if_st->op = EXEC_IF;
8245 for (body = class_is; body; body = body->block)
8247 new_st->block = gfc_get_code ();
8248 new_st = new_st->block;
8249 new_st->op = EXEC_IF;
8250 /* Set up IF condition: Call _gfortran_is_extension_of. */
8251 new_st->expr1 = gfc_get_expr ();
8252 new_st->expr1->expr_type = EXPR_FUNCTION;
8253 new_st->expr1->ts.type = BT_LOGICAL;
8254 new_st->expr1->ts.kind = 4;
8255 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
8256 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
8257 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
8258 /* Set up arguments. */
8259 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
8260 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
8261 new_st->expr1->value.function.actual->expr->where = code->loc;
8262 gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
8263 vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
8264 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
8265 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
8266 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
8267 new_st->next = body->next;
8269 if (default_case->next)
8271 new_st->block = gfc_get_code ();
8272 new_st = new_st->block;
8273 new_st->op = EXEC_IF;
8274 new_st->next = default_case->next;
8277 /* Replace CLASS DEFAULT code by the IF chain. */
8278 default_case->next = if_st;
8281 /* Resolve the internal code. This can not be done earlier because
8282 it requires that the sym->assoc of selectors is set already. */
8283 gfc_current_ns = ns;
8284 gfc_resolve_blocks (code->block, gfc_current_ns);
8285 gfc_current_ns = old_ns;
8287 resolve_select (code);
8291 /* Resolve a transfer statement. This is making sure that:
8292 -- a derived type being transferred has only non-pointer components
8293 -- a derived type being transferred doesn't have private components, unless
8294 it's being transferred from the module where the type was defined
8295 -- we're not trying to transfer a whole assumed size array. */
8298 resolve_transfer (gfc_code *code)
8307 while (exp != NULL && exp->expr_type == EXPR_OP
8308 && exp->value.op.op == INTRINSIC_PARENTHESES)
8309 exp = exp->value.op.op1;
8311 if (exp && exp->expr_type == EXPR_NULL && exp->ts.type == BT_UNKNOWN)
8313 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8314 "MOLD=", &exp->where);
8318 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
8319 && exp->expr_type != EXPR_FUNCTION))
8322 /* If we are reading, the variable will be changed. Note that
8323 code->ext.dt may be NULL if the TRANSFER is related to
8324 an INQUIRE statement -- but in this case, we are not reading, either. */
8325 if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
8326 && gfc_check_vardef_context (exp, false, false, _("item in READ"))
8330 sym = exp->symtree->n.sym;
8333 /* Go to actual component transferred. */
8334 for (ref = exp->ref; ref; ref = ref->next)
8335 if (ref->type == REF_COMPONENT)
8336 ts = &ref->u.c.component->ts;
8338 if (ts->type == BT_CLASS)
8340 /* FIXME: Test for defined input/output. */
8341 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8342 "it is processed by a defined input/output procedure",
8347 if (ts->type == BT_DERIVED)
8349 /* Check that transferred derived type doesn't contain POINTER
8351 if (ts->u.derived->attr.pointer_comp)
8353 gfc_error ("Data transfer element at %L cannot have POINTER "
8354 "components unless it is processed by a defined "
8355 "input/output procedure", &code->loc);
8360 if (ts->u.derived->attr.proc_pointer_comp)
8362 gfc_error ("Data transfer element at %L cannot have "
8363 "procedure pointer components", &code->loc);
8367 if (ts->u.derived->attr.alloc_comp)
8369 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8370 "components unless it is processed by a defined "
8371 "input/output procedure", &code->loc);
8375 if (derived_inaccessible (ts->u.derived))
8377 gfc_error ("Data transfer element at %L cannot have "
8378 "PRIVATE components",&code->loc);
8383 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
8384 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
8386 gfc_error ("Data transfer element at %L cannot be a full reference to "
8387 "an assumed-size array", &code->loc);
8393 /*********** Toplevel code resolution subroutines ***********/
8395 /* Find the set of labels that are reachable from this block. We also
8396 record the last statement in each block. */
8399 find_reachable_labels (gfc_code *block)
8406 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
8408 /* Collect labels in this block. We don't keep those corresponding
8409 to END {IF|SELECT}, these are checked in resolve_branch by going
8410 up through the code_stack. */
8411 for (c = block; c; c = c->next)
8413 if (c->here && c->op != EXEC_END_NESTED_BLOCK)
8414 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8417 /* Merge with labels from parent block. */
8420 gcc_assert (cs_base->prev->reachable_labels);
8421 bitmap_ior_into (cs_base->reachable_labels,
8422 cs_base->prev->reachable_labels);
8428 resolve_lock_unlock (gfc_code *code)
8430 if (code->expr1->ts.type != BT_DERIVED
8431 || code->expr1->expr_type != EXPR_VARIABLE
8432 || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
8433 || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
8434 || code->expr1->rank != 0
8435 || (!gfc_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1)))
8436 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8437 &code->expr1->where);
8441 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8442 || code->expr2->expr_type != EXPR_VARIABLE))
8443 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8444 &code->expr2->where);
8447 && gfc_check_vardef_context (code->expr2, false, false,
8448 _("STAT variable")) == FAILURE)
8453 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8454 || code->expr3->expr_type != EXPR_VARIABLE))
8455 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8456 &code->expr3->where);
8459 && gfc_check_vardef_context (code->expr3, false, false,
8460 _("ERRMSG variable")) == FAILURE)
8463 /* Check ACQUIRED_LOCK. */
8465 && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
8466 || code->expr4->expr_type != EXPR_VARIABLE))
8467 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8468 "variable", &code->expr4->where);
8471 && gfc_check_vardef_context (code->expr4, false, false,
8472 _("ACQUIRED_LOCK variable")) == FAILURE)
8478 resolve_sync (gfc_code *code)
8480 /* Check imageset. The * case matches expr1 == NULL. */
8483 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8484 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8485 "INTEGER expression", &code->expr1->where);
8486 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8487 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8488 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8489 &code->expr1->where);
8490 else if (code->expr1->expr_type == EXPR_ARRAY
8491 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8493 gfc_constructor *cons;
8494 cons = gfc_constructor_first (code->expr1->value.constructor);
8495 for (; cons; cons = gfc_constructor_next (cons))
8496 if (cons->expr->expr_type == EXPR_CONSTANT
8497 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8498 gfc_error ("Imageset argument at %L must between 1 and "
8499 "num_images()", &cons->expr->where);
8505 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8506 || code->expr2->expr_type != EXPR_VARIABLE))
8507 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8508 &code->expr2->where);
8512 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8513 || code->expr3->expr_type != EXPR_VARIABLE))
8514 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8515 &code->expr3->where);
8519 /* Given a branch to a label, see if the branch is conforming.
8520 The code node describes where the branch is located. */
8523 resolve_branch (gfc_st_label *label, gfc_code *code)
8530 /* Step one: is this a valid branching target? */
8532 if (label->defined == ST_LABEL_UNKNOWN)
8534 gfc_error ("Label %d referenced at %L is never defined", label->value,
8539 if (label->defined != ST_LABEL_TARGET)
8541 gfc_error ("Statement at %L is not a valid branch target statement "
8542 "for the branch statement at %L", &label->where, &code->loc);
8546 /* Step two: make sure this branch is not a branch to itself ;-) */
8548 if (code->here == label)
8550 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8554 /* Step three: See if the label is in the same block as the
8555 branching statement. The hard work has been done by setting up
8556 the bitmap reachable_labels. */
8558 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8560 /* Check now whether there is a CRITICAL construct; if so, check
8561 whether the label is still visible outside of the CRITICAL block,
8562 which is invalid. */
8563 for (stack = cs_base; stack; stack = stack->prev)
8565 if (stack->current->op == EXEC_CRITICAL
8566 && bitmap_bit_p (stack->reachable_labels, label->value))
8567 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8568 "label at %L", &code->loc, &label->where);
8569 else if (stack->current->op == EXEC_DO_CONCURRENT
8570 && bitmap_bit_p (stack->reachable_labels, label->value))
8571 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8572 "for label at %L", &code->loc, &label->where);
8578 /* Step four: If we haven't found the label in the bitmap, it may
8579 still be the label of the END of the enclosing block, in which
8580 case we find it by going up the code_stack. */
8582 for (stack = cs_base; stack; stack = stack->prev)
8584 if (stack->current->next && stack->current->next->here == label)
8586 if (stack->current->op == EXEC_CRITICAL)
8588 /* Note: A label at END CRITICAL does not leave the CRITICAL
8589 construct as END CRITICAL is still part of it. */
8590 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8591 " at %L", &code->loc, &label->where);
8594 else if (stack->current->op == EXEC_DO_CONCURRENT)
8596 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8597 "label at %L", &code->loc, &label->where);
8604 gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
8608 /* The label is not in an enclosing block, so illegal. This was
8609 allowed in Fortran 66, so we allow it as extension. No
8610 further checks are necessary in this case. */
8611 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
8612 "as the GOTO statement at %L", &label->where,
8618 /* Check whether EXPR1 has the same shape as EXPR2. */
8621 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
8623 mpz_t shape[GFC_MAX_DIMENSIONS];
8624 mpz_t shape2[GFC_MAX_DIMENSIONS];
8625 gfc_try result = FAILURE;
8628 /* Compare the rank. */
8629 if (expr1->rank != expr2->rank)
8632 /* Compare the size of each dimension. */
8633 for (i=0; i<expr1->rank; i++)
8635 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
8638 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
8641 if (mpz_cmp (shape[i], shape2[i]))
8645 /* When either of the two expression is an assumed size array, we
8646 ignore the comparison of dimension sizes. */
8651 gfc_clear_shape (shape, i);
8652 gfc_clear_shape (shape2, i);
8657 /* Check whether a WHERE assignment target or a WHERE mask expression
8658 has the same shape as the outmost WHERE mask expression. */
8661 resolve_where (gfc_code *code, gfc_expr *mask)
8667 cblock = code->block;
8669 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8670 In case of nested WHERE, only the outmost one is stored. */
8671 if (mask == NULL) /* outmost WHERE */
8673 else /* inner WHERE */
8680 /* Check if the mask-expr has a consistent shape with the
8681 outmost WHERE mask-expr. */
8682 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8683 gfc_error ("WHERE mask at %L has inconsistent shape",
8684 &cblock->expr1->where);
8687 /* the assignment statement of a WHERE statement, or the first
8688 statement in where-body-construct of a WHERE construct */
8689 cnext = cblock->next;
8694 /* WHERE assignment statement */
8697 /* Check shape consistent for WHERE assignment target. */
8698 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8699 gfc_error ("WHERE assignment target at %L has "
8700 "inconsistent shape", &cnext->expr1->where);
8704 case EXEC_ASSIGN_CALL:
8705 resolve_call (cnext);
8706 if (!cnext->resolved_sym->attr.elemental)
8707 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8708 &cnext->ext.actual->expr->where);
8711 /* WHERE or WHERE construct is part of a where-body-construct */
8713 resolve_where (cnext, e);
8717 gfc_error ("Unsupported statement inside WHERE at %L",
8720 /* the next statement within the same where-body-construct */
8721 cnext = cnext->next;
8723 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8724 cblock = cblock->block;
8729 /* Resolve assignment in FORALL construct.
8730 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8731 FORALL index variables. */
8734 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8738 for (n = 0; n < nvar; n++)
8740 gfc_symbol *forall_index;
8742 forall_index = var_expr[n]->symtree->n.sym;
8744 /* Check whether the assignment target is one of the FORALL index
8746 if ((code->expr1->expr_type == EXPR_VARIABLE)
8747 && (code->expr1->symtree->n.sym == forall_index))
8748 gfc_error ("Assignment to a FORALL index variable at %L",
8749 &code->expr1->where);
8752 /* If one of the FORALL index variables doesn't appear in the
8753 assignment variable, then there could be a many-to-one
8754 assignment. Emit a warning rather than an error because the
8755 mask could be resolving this problem. */
8756 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8757 gfc_warning ("The FORALL with index '%s' is not used on the "
8758 "left side of the assignment at %L and so might "
8759 "cause multiple assignment to this object",
8760 var_expr[n]->symtree->name, &code->expr1->where);
8766 /* Resolve WHERE statement in FORALL construct. */
8769 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8770 gfc_expr **var_expr)
8775 cblock = code->block;
8778 /* the assignment statement of a WHERE statement, or the first
8779 statement in where-body-construct of a WHERE construct */
8780 cnext = cblock->next;
8785 /* WHERE assignment statement */
8787 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8790 /* WHERE operator assignment statement */
8791 case EXEC_ASSIGN_CALL:
8792 resolve_call (cnext);
8793 if (!cnext->resolved_sym->attr.elemental)
8794 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8795 &cnext->ext.actual->expr->where);
8798 /* WHERE or WHERE construct is part of a where-body-construct */
8800 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8804 gfc_error ("Unsupported statement inside WHERE at %L",
8807 /* the next statement within the same where-body-construct */
8808 cnext = cnext->next;
8810 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8811 cblock = cblock->block;
8816 /* Traverse the FORALL body to check whether the following errors exist:
8817 1. For assignment, check if a many-to-one assignment happens.
8818 2. For WHERE statement, check the WHERE body to see if there is any
8819 many-to-one assignment. */
8822 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8826 c = code->block->next;
8832 case EXEC_POINTER_ASSIGN:
8833 gfc_resolve_assign_in_forall (c, nvar, var_expr);
8836 case EXEC_ASSIGN_CALL:
8840 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8841 there is no need to handle it here. */
8845 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8850 /* The next statement in the FORALL body. */
8856 /* Counts the number of iterators needed inside a forall construct, including
8857 nested forall constructs. This is used to allocate the needed memory
8858 in gfc_resolve_forall. */
8861 gfc_count_forall_iterators (gfc_code *code)
8863 int max_iters, sub_iters, current_iters;
8864 gfc_forall_iterator *fa;
8866 gcc_assert(code->op == EXEC_FORALL);
8870 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8873 code = code->block->next;
8877 if (code->op == EXEC_FORALL)
8879 sub_iters = gfc_count_forall_iterators (code);
8880 if (sub_iters > max_iters)
8881 max_iters = sub_iters;
8886 return current_iters + max_iters;
8890 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8891 gfc_resolve_forall_body to resolve the FORALL body. */
8894 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8896 static gfc_expr **var_expr;
8897 static int total_var = 0;
8898 static int nvar = 0;
8900 gfc_forall_iterator *fa;
8905 /* Start to resolve a FORALL construct */
8906 if (forall_save == 0)
8908 /* Count the total number of FORALL index in the nested FORALL
8909 construct in order to allocate the VAR_EXPR with proper size. */
8910 total_var = gfc_count_forall_iterators (code);
8912 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8913 var_expr = XCNEWVEC (gfc_expr *, total_var);
8916 /* The information about FORALL iterator, including FORALL index start, end
8917 and stride. The FORALL index can not appear in start, end or stride. */
8918 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8920 /* Check if any outer FORALL index name is the same as the current
8922 for (i = 0; i < nvar; i++)
8924 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8926 gfc_error ("An outer FORALL construct already has an index "
8927 "with this name %L", &fa->var->where);
8931 /* Record the current FORALL index. */
8932 var_expr[nvar] = gfc_copy_expr (fa->var);
8936 /* No memory leak. */
8937 gcc_assert (nvar <= total_var);
8940 /* Resolve the FORALL body. */
8941 gfc_resolve_forall_body (code, nvar, var_expr);
8943 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8944 gfc_resolve_blocks (code->block, ns);
8948 /* Free only the VAR_EXPRs allocated in this frame. */
8949 for (i = nvar; i < tmp; i++)
8950 gfc_free_expr (var_expr[i]);
8954 /* We are in the outermost FORALL construct. */
8955 gcc_assert (forall_save == 0);
8957 /* VAR_EXPR is not needed any more. */
8964 /* Resolve a BLOCK construct statement. */
8967 resolve_block_construct (gfc_code* code)
8969 /* Resolve the BLOCK's namespace. */
8970 gfc_resolve (code->ext.block.ns);
8972 /* For an ASSOCIATE block, the associations (and their targets) are already
8973 resolved during resolve_symbol. */
8977 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8980 static void resolve_code (gfc_code *, gfc_namespace *);
8983 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8987 for (; b; b = b->block)
8989 t = gfc_resolve_expr (b->expr1);
8990 if (gfc_resolve_expr (b->expr2) == FAILURE)
8996 if (t == SUCCESS && b->expr1 != NULL
8997 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
8998 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9005 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
9006 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9011 resolve_branch (b->label1, b);
9015 resolve_block_construct (b);
9019 case EXEC_SELECT_TYPE:
9023 case EXEC_DO_CONCURRENT:
9031 case EXEC_OMP_ATOMIC:
9032 case EXEC_OMP_CRITICAL:
9034 case EXEC_OMP_MASTER:
9035 case EXEC_OMP_ORDERED:
9036 case EXEC_OMP_PARALLEL:
9037 case EXEC_OMP_PARALLEL_DO:
9038 case EXEC_OMP_PARALLEL_SECTIONS:
9039 case EXEC_OMP_PARALLEL_WORKSHARE:
9040 case EXEC_OMP_SECTIONS:
9041 case EXEC_OMP_SINGLE:
9043 case EXEC_OMP_TASKWAIT:
9044 case EXEC_OMP_TASKYIELD:
9045 case EXEC_OMP_WORKSHARE:
9049 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9052 resolve_code (b->next, ns);
9057 /* Does everything to resolve an ordinary assignment. Returns true
9058 if this is an interface assignment. */
9060 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
9070 if (gfc_extend_assign (code, ns) == SUCCESS)
9074 if (code->op == EXEC_ASSIGN_CALL)
9076 lhs = code->ext.actual->expr;
9077 rhsptr = &code->ext.actual->next->expr;
9081 gfc_actual_arglist* args;
9082 gfc_typebound_proc* tbp;
9084 gcc_assert (code->op == EXEC_COMPCALL);
9086 args = code->expr1->value.compcall.actual;
9088 rhsptr = &args->next->expr;
9090 tbp = code->expr1->value.compcall.tbp;
9091 gcc_assert (!tbp->is_generic);
9094 /* Make a temporary rhs when there is a default initializer
9095 and rhs is the same symbol as the lhs. */
9096 if ((*rhsptr)->expr_type == EXPR_VARIABLE
9097 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
9098 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
9099 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
9100 *rhsptr = gfc_get_parentheses (*rhsptr);
9109 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
9110 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9111 &code->loc) == FAILURE)
9114 /* Handle the case of a BOZ literal on the RHS. */
9115 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
9118 if (gfc_option.warn_surprising)
9119 gfc_warning ("BOZ literal at %L is bitwise transferred "
9120 "non-integer symbol '%s'", &code->loc,
9121 lhs->symtree->n.sym->name);
9123 if (!gfc_convert_boz (rhs, &lhs->ts))
9125 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
9127 if (rc == ARITH_UNDERFLOW)
9128 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9129 ". This check can be disabled with the option "
9130 "-fno-range-check", &rhs->where);
9131 else if (rc == ARITH_OVERFLOW)
9132 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9133 ". This check can be disabled with the option "
9134 "-fno-range-check", &rhs->where);
9135 else if (rc == ARITH_NAN)
9136 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9137 ". This check can be disabled with the option "
9138 "-fno-range-check", &rhs->where);
9143 if (lhs->ts.type == BT_CHARACTER
9144 && gfc_option.warn_character_truncation)
9146 if (lhs->ts.u.cl != NULL
9147 && lhs->ts.u.cl->length != NULL
9148 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9149 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
9151 if (rhs->expr_type == EXPR_CONSTANT)
9152 rlen = rhs->value.character.length;
9154 else if (rhs->ts.u.cl != NULL
9155 && rhs->ts.u.cl->length != NULL
9156 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9157 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
9159 if (rlen && llen && rlen > llen)
9160 gfc_warning_now ("CHARACTER expression will be truncated "
9161 "in assignment (%d/%d) at %L",
9162 llen, rlen, &code->loc);
9165 /* Ensure that a vector index expression for the lvalue is evaluated
9166 to a temporary if the lvalue symbol is referenced in it. */
9169 for (ref = lhs->ref; ref; ref= ref->next)
9170 if (ref->type == REF_ARRAY)
9172 for (n = 0; n < ref->u.ar.dimen; n++)
9173 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
9174 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
9175 ref->u.ar.start[n]))
9177 = gfc_get_parentheses (ref->u.ar.start[n]);
9181 if (gfc_pure (NULL))
9183 if (lhs->ts.type == BT_DERIVED
9184 && lhs->expr_type == EXPR_VARIABLE
9185 && lhs->ts.u.derived->attr.pointer_comp
9186 && rhs->expr_type == EXPR_VARIABLE
9187 && (gfc_impure_variable (rhs->symtree->n.sym)
9188 || gfc_is_coindexed (rhs)))
9191 if (gfc_is_coindexed (rhs))
9192 gfc_error ("Coindexed expression at %L is assigned to "
9193 "a derived type variable with a POINTER "
9194 "component in a PURE procedure",
9197 gfc_error ("The impure variable at %L is assigned to "
9198 "a derived type variable with a POINTER "
9199 "component in a PURE procedure (12.6)",
9204 /* Fortran 2008, C1283. */
9205 if (gfc_is_coindexed (lhs))
9207 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9208 "procedure", &rhs->where);
9213 if (gfc_implicit_pure (NULL))
9215 if (lhs->expr_type == EXPR_VARIABLE
9216 && lhs->symtree->n.sym != gfc_current_ns->proc_name
9217 && lhs->symtree->n.sym->ns != gfc_current_ns)
9218 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9220 if (lhs->ts.type == BT_DERIVED
9221 && lhs->expr_type == EXPR_VARIABLE
9222 && lhs->ts.u.derived->attr.pointer_comp
9223 && rhs->expr_type == EXPR_VARIABLE
9224 && (gfc_impure_variable (rhs->symtree->n.sym)
9225 || gfc_is_coindexed (rhs)))
9226 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9228 /* Fortran 2008, C1283. */
9229 if (gfc_is_coindexed (lhs))
9230 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9234 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9235 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9236 if (lhs->ts.type == BT_CLASS)
9238 gfc_error ("Variable must not be polymorphic in intrinsic assignment at "
9239 "%L - check that there is a matching specific subroutine "
9240 "for '=' operator", &lhs->where);
9244 /* F2008, Section 7.2.1.2. */
9245 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
9247 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9248 "component in assignment at %L", &lhs->where);
9252 gfc_check_assign (lhs, rhs, 1);
9257 /* Given a block of code, recursively resolve everything pointed to by this
9261 resolve_code (gfc_code *code, gfc_namespace *ns)
9263 int omp_workshare_save;
9264 int forall_save, do_concurrent_save;
9268 frame.prev = cs_base;
9272 find_reachable_labels (code);
9274 for (; code; code = code->next)
9276 frame.current = code;
9277 forall_save = forall_flag;
9278 do_concurrent_save = do_concurrent_flag;
9280 if (code->op == EXEC_FORALL)
9283 gfc_resolve_forall (code, ns, forall_save);
9286 else if (code->block)
9288 omp_workshare_save = -1;
9291 case EXEC_OMP_PARALLEL_WORKSHARE:
9292 omp_workshare_save = omp_workshare_flag;
9293 omp_workshare_flag = 1;
9294 gfc_resolve_omp_parallel_blocks (code, ns);
9296 case EXEC_OMP_PARALLEL:
9297 case EXEC_OMP_PARALLEL_DO:
9298 case EXEC_OMP_PARALLEL_SECTIONS:
9300 omp_workshare_save = omp_workshare_flag;
9301 omp_workshare_flag = 0;
9302 gfc_resolve_omp_parallel_blocks (code, ns);
9305 gfc_resolve_omp_do_blocks (code, ns);
9307 case EXEC_SELECT_TYPE:
9308 /* Blocks are handled in resolve_select_type because we have
9309 to transform the SELECT TYPE into ASSOCIATE first. */
9311 case EXEC_DO_CONCURRENT:
9312 do_concurrent_flag = 1;
9313 gfc_resolve_blocks (code->block, ns);
9314 do_concurrent_flag = 2;
9316 case EXEC_OMP_WORKSHARE:
9317 omp_workshare_save = omp_workshare_flag;
9318 omp_workshare_flag = 1;
9321 gfc_resolve_blocks (code->block, ns);
9325 if (omp_workshare_save != -1)
9326 omp_workshare_flag = omp_workshare_save;
9330 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
9331 t = gfc_resolve_expr (code->expr1);
9332 forall_flag = forall_save;
9333 do_concurrent_flag = do_concurrent_save;
9335 if (gfc_resolve_expr (code->expr2) == FAILURE)
9338 if (code->op == EXEC_ALLOCATE
9339 && gfc_resolve_expr (code->expr3) == FAILURE)
9345 case EXEC_END_BLOCK:
9346 case EXEC_END_NESTED_BLOCK:
9350 case EXEC_ERROR_STOP:
9354 case EXEC_ASSIGN_CALL:
9359 case EXEC_SYNC_IMAGES:
9360 case EXEC_SYNC_MEMORY:
9361 resolve_sync (code);
9366 resolve_lock_unlock (code);
9370 /* Keep track of which entry we are up to. */
9371 current_entry_id = code->ext.entry->id;
9375 resolve_where (code, NULL);
9379 if (code->expr1 != NULL)
9381 if (code->expr1->ts.type != BT_INTEGER)
9382 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9383 "INTEGER variable", &code->expr1->where);
9384 else if (code->expr1->symtree->n.sym->attr.assign != 1)
9385 gfc_error ("Variable '%s' has not been assigned a target "
9386 "label at %L", code->expr1->symtree->n.sym->name,
9387 &code->expr1->where);
9390 resolve_branch (code->label1, code);
9394 if (code->expr1 != NULL
9395 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
9396 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9397 "INTEGER return specifier", &code->expr1->where);
9400 case EXEC_INIT_ASSIGN:
9401 case EXEC_END_PROCEDURE:
9408 if (gfc_check_vardef_context (code->expr1, false, false,
9409 _("assignment")) == FAILURE)
9412 if (resolve_ordinary_assign (code, ns))
9414 if (code->op == EXEC_COMPCALL)
9421 case EXEC_LABEL_ASSIGN:
9422 if (code->label1->defined == ST_LABEL_UNKNOWN)
9423 gfc_error ("Label %d referenced at %L is never defined",
9424 code->label1->value, &code->label1->where);
9426 && (code->expr1->expr_type != EXPR_VARIABLE
9427 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
9428 || code->expr1->symtree->n.sym->ts.kind
9429 != gfc_default_integer_kind
9430 || code->expr1->symtree->n.sym->as != NULL))
9431 gfc_error ("ASSIGN statement at %L requires a scalar "
9432 "default INTEGER variable", &code->expr1->where);
9435 case EXEC_POINTER_ASSIGN:
9442 /* This is both a variable definition and pointer assignment
9443 context, so check both of them. For rank remapping, a final
9444 array ref may be present on the LHS and fool gfc_expr_attr
9445 used in gfc_check_vardef_context. Remove it. */
9446 e = remove_last_array_ref (code->expr1);
9447 t = gfc_check_vardef_context (e, true, false,
9448 _("pointer assignment"));
9450 t = gfc_check_vardef_context (e, false, false,
9451 _("pointer assignment"));
9456 gfc_check_pointer_assign (code->expr1, code->expr2);
9460 case EXEC_ARITHMETIC_IF:
9462 && code->expr1->ts.type != BT_INTEGER
9463 && code->expr1->ts.type != BT_REAL)
9464 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9465 "expression", &code->expr1->where);
9467 resolve_branch (code->label1, code);
9468 resolve_branch (code->label2, code);
9469 resolve_branch (code->label3, code);
9473 if (t == SUCCESS && code->expr1 != NULL
9474 && (code->expr1->ts.type != BT_LOGICAL
9475 || code->expr1->rank != 0))
9476 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9477 &code->expr1->where);
9482 resolve_call (code);
9487 resolve_typebound_subroutine (code);
9491 resolve_ppc_call (code);
9495 /* Select is complicated. Also, a SELECT construct could be
9496 a transformed computed GOTO. */
9497 resolve_select (code);
9500 case EXEC_SELECT_TYPE:
9501 resolve_select_type (code, ns);
9505 resolve_block_construct (code);
9509 if (code->ext.iterator != NULL)
9511 gfc_iterator *iter = code->ext.iterator;
9512 if (gfc_resolve_iterator (iter, true) != FAILURE)
9513 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
9518 if (code->expr1 == NULL)
9519 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9521 && (code->expr1->rank != 0
9522 || code->expr1->ts.type != BT_LOGICAL))
9523 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9524 "a scalar LOGICAL expression", &code->expr1->where);
9529 resolve_allocate_deallocate (code, "ALLOCATE");
9533 case EXEC_DEALLOCATE:
9535 resolve_allocate_deallocate (code, "DEALLOCATE");
9540 if (gfc_resolve_open (code->ext.open) == FAILURE)
9543 resolve_branch (code->ext.open->err, code);
9547 if (gfc_resolve_close (code->ext.close) == FAILURE)
9550 resolve_branch (code->ext.close->err, code);
9553 case EXEC_BACKSPACE:
9557 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
9560 resolve_branch (code->ext.filepos->err, code);
9564 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9567 resolve_branch (code->ext.inquire->err, code);
9571 gcc_assert (code->ext.inquire != NULL);
9572 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9575 resolve_branch (code->ext.inquire->err, code);
9579 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
9582 resolve_branch (code->ext.wait->err, code);
9583 resolve_branch (code->ext.wait->end, code);
9584 resolve_branch (code->ext.wait->eor, code);
9589 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
9592 resolve_branch (code->ext.dt->err, code);
9593 resolve_branch (code->ext.dt->end, code);
9594 resolve_branch (code->ext.dt->eor, code);
9598 resolve_transfer (code);
9601 case EXEC_DO_CONCURRENT:
9603 resolve_forall_iterators (code->ext.forall_iterator);
9605 if (code->expr1 != NULL
9606 && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
9607 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9608 "expression", &code->expr1->where);
9611 case EXEC_OMP_ATOMIC:
9612 case EXEC_OMP_BARRIER:
9613 case EXEC_OMP_CRITICAL:
9614 case EXEC_OMP_FLUSH:
9616 case EXEC_OMP_MASTER:
9617 case EXEC_OMP_ORDERED:
9618 case EXEC_OMP_SECTIONS:
9619 case EXEC_OMP_SINGLE:
9620 case EXEC_OMP_TASKWAIT:
9621 case EXEC_OMP_TASKYIELD:
9622 case EXEC_OMP_WORKSHARE:
9623 gfc_resolve_omp_directive (code, ns);
9626 case EXEC_OMP_PARALLEL:
9627 case EXEC_OMP_PARALLEL_DO:
9628 case EXEC_OMP_PARALLEL_SECTIONS:
9629 case EXEC_OMP_PARALLEL_WORKSHARE:
9631 omp_workshare_save = omp_workshare_flag;
9632 omp_workshare_flag = 0;
9633 gfc_resolve_omp_directive (code, ns);
9634 omp_workshare_flag = omp_workshare_save;
9638 gfc_internal_error ("resolve_code(): Bad statement code");
9642 cs_base = frame.prev;
9646 /* Resolve initial values and make sure they are compatible with
9650 resolve_values (gfc_symbol *sym)
9654 if (sym->value == NULL)
9657 if (sym->value->expr_type == EXPR_STRUCTURE)
9658 t= resolve_structure_cons (sym->value, 1);
9660 t = gfc_resolve_expr (sym->value);
9665 gfc_check_assign_symbol (sym, sym->value);
9669 /* Verify the binding labels for common blocks that are BIND(C). The label
9670 for a BIND(C) common block must be identical in all scoping units in which
9671 the common block is declared. Further, the binding label can not collide
9672 with any other global entity in the program. */
9675 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
9677 if (comm_block_tree->n.common->is_bind_c == 1)
9679 gfc_gsymbol *binding_label_gsym;
9680 gfc_gsymbol *comm_name_gsym;
9682 /* See if a global symbol exists by the common block's name. It may
9683 be NULL if the common block is use-associated. */
9684 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
9685 comm_block_tree->n.common->name);
9686 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
9687 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9688 "with the global entity '%s' at %L",
9689 comm_block_tree->n.common->binding_label,
9690 comm_block_tree->n.common->name,
9691 &(comm_block_tree->n.common->where),
9692 comm_name_gsym->name, &(comm_name_gsym->where));
9693 else if (comm_name_gsym != NULL
9694 && strcmp (comm_name_gsym->name,
9695 comm_block_tree->n.common->name) == 0)
9697 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9699 if (comm_name_gsym->binding_label == NULL)
9700 /* No binding label for common block stored yet; save this one. */
9701 comm_name_gsym->binding_label =
9702 comm_block_tree->n.common->binding_label;
9704 if (strcmp (comm_name_gsym->binding_label,
9705 comm_block_tree->n.common->binding_label) != 0)
9707 /* Common block names match but binding labels do not. */
9708 gfc_error ("Binding label '%s' for common block '%s' at %L "
9709 "does not match the binding label '%s' for common "
9711 comm_block_tree->n.common->binding_label,
9712 comm_block_tree->n.common->name,
9713 &(comm_block_tree->n.common->where),
9714 comm_name_gsym->binding_label,
9715 comm_name_gsym->name,
9716 &(comm_name_gsym->where));
9721 /* There is no binding label (NAME="") so we have nothing further to
9722 check and nothing to add as a global symbol for the label. */
9723 if (comm_block_tree->n.common->binding_label[0] == '\0' )
9726 binding_label_gsym =
9727 gfc_find_gsymbol (gfc_gsym_root,
9728 comm_block_tree->n.common->binding_label);
9729 if (binding_label_gsym == NULL)
9731 /* Need to make a global symbol for the binding label to prevent
9732 it from colliding with another. */
9733 binding_label_gsym =
9734 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9735 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9736 binding_label_gsym->type = GSYM_COMMON;
9740 /* If comm_name_gsym is NULL, the name common block is use
9741 associated and the name could be colliding. */
9742 if (binding_label_gsym->type != GSYM_COMMON)
9743 gfc_error ("Binding label '%s' for common block '%s' at %L "
9744 "collides with the global entity '%s' at %L",
9745 comm_block_tree->n.common->binding_label,
9746 comm_block_tree->n.common->name,
9747 &(comm_block_tree->n.common->where),
9748 binding_label_gsym->name,
9749 &(binding_label_gsym->where));
9750 else if (comm_name_gsym != NULL
9751 && (strcmp (binding_label_gsym->name,
9752 comm_name_gsym->binding_label) != 0)
9753 && (strcmp (binding_label_gsym->sym_name,
9754 comm_name_gsym->name) != 0))
9755 gfc_error ("Binding label '%s' for common block '%s' at %L "
9756 "collides with global entity '%s' at %L",
9757 binding_label_gsym->name, binding_label_gsym->sym_name,
9758 &(comm_block_tree->n.common->where),
9759 comm_name_gsym->name, &(comm_name_gsym->where));
9767 /* Verify any BIND(C) derived types in the namespace so we can report errors
9768 for them once, rather than for each variable declared of that type. */
9771 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9773 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9774 && derived_sym->attr.is_bind_c == 1)
9775 verify_bind_c_derived_type (derived_sym);
9781 /* Verify that any binding labels used in a given namespace do not collide
9782 with the names or binding labels of any global symbols. */
9785 gfc_verify_binding_labels (gfc_symbol *sym)
9789 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9790 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
9792 gfc_gsymbol *bind_c_sym;
9794 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9795 if (bind_c_sym != NULL
9796 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9798 if (sym->attr.if_source == IFSRC_DECL
9799 && (bind_c_sym->type != GSYM_SUBROUTINE
9800 && bind_c_sym->type != GSYM_FUNCTION)
9801 && ((sym->attr.contained == 1
9802 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9803 || (sym->attr.use_assoc == 1
9804 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9806 /* Make sure global procedures don't collide with anything. */
9807 gfc_error ("Binding label '%s' at %L collides with the global "
9808 "entity '%s' at %L", sym->binding_label,
9809 &(sym->declared_at), bind_c_sym->name,
9810 &(bind_c_sym->where));
9813 else if (sym->attr.contained == 0
9814 && (sym->attr.if_source == IFSRC_IFBODY
9815 && sym->attr.flavor == FL_PROCEDURE)
9816 && (bind_c_sym->sym_name != NULL
9817 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9819 /* Make sure procedures in interface bodies don't collide. */
9820 gfc_error ("Binding label '%s' in interface body at %L collides "
9821 "with the global entity '%s' at %L",
9823 &(sym->declared_at), bind_c_sym->name,
9824 &(bind_c_sym->where));
9827 else if (sym->attr.contained == 0
9828 && sym->attr.if_source == IFSRC_UNKNOWN)
9829 if ((sym->attr.use_assoc && bind_c_sym->mod_name
9830 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9831 || sym->attr.use_assoc == 0)
9833 gfc_error ("Binding label '%s' at %L collides with global "
9834 "entity '%s' at %L", sym->binding_label,
9835 &(sym->declared_at), bind_c_sym->name,
9836 &(bind_c_sym->where));
9841 /* Clear the binding label to prevent checking multiple times. */
9842 sym->binding_label[0] = '\0';
9844 else if (bind_c_sym == NULL)
9846 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9847 bind_c_sym->where = sym->declared_at;
9848 bind_c_sym->sym_name = sym->name;
9850 if (sym->attr.use_assoc == 1)
9851 bind_c_sym->mod_name = sym->module;
9853 if (sym->ns->proc_name != NULL)
9854 bind_c_sym->mod_name = sym->ns->proc_name->name;
9856 if (sym->attr.contained == 0)
9858 if (sym->attr.subroutine)
9859 bind_c_sym->type = GSYM_SUBROUTINE;
9860 else if (sym->attr.function)
9861 bind_c_sym->type = GSYM_FUNCTION;
9869 /* Resolve an index expression. */
9872 resolve_index_expr (gfc_expr *e)
9874 if (gfc_resolve_expr (e) == FAILURE)
9877 if (gfc_simplify_expr (e, 0) == FAILURE)
9880 if (gfc_specification_expr (e) == FAILURE)
9887 /* Resolve a charlen structure. */
9890 resolve_charlen (gfc_charlen *cl)
9899 specification_expr = 1;
9901 if (resolve_index_expr (cl->length) == FAILURE)
9903 specification_expr = 0;
9907 /* "If the character length parameter value evaluates to a negative
9908 value, the length of character entities declared is zero." */
9909 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9911 if (gfc_option.warn_surprising)
9912 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9913 " the length has been set to zero",
9914 &cl->length->where, i);
9915 gfc_replace_expr (cl->length,
9916 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9919 /* Check that the character length is not too large. */
9920 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9921 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9922 && cl->length->ts.type == BT_INTEGER
9923 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9925 gfc_error ("String length at %L is too large", &cl->length->where);
9933 /* Test for non-constant shape arrays. */
9936 is_non_constant_shape_array (gfc_symbol *sym)
9942 not_constant = false;
9943 if (sym->as != NULL)
9945 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9946 has not been simplified; parameter array references. Do the
9947 simplification now. */
9948 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9950 e = sym->as->lower[i];
9951 if (e && (resolve_index_expr (e) == FAILURE
9952 || !gfc_is_constant_expr (e)))
9953 not_constant = true;
9954 e = sym->as->upper[i];
9955 if (e && (resolve_index_expr (e) == FAILURE
9956 || !gfc_is_constant_expr (e)))
9957 not_constant = true;
9960 return not_constant;
9963 /* Given a symbol and an initialization expression, add code to initialize
9964 the symbol to the function entry. */
9966 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9970 gfc_namespace *ns = sym->ns;
9972 /* Search for the function namespace if this is a contained
9973 function without an explicit result. */
9974 if (sym->attr.function && sym == sym->result
9975 && sym->name != sym->ns->proc_name->name)
9978 for (;ns; ns = ns->sibling)
9979 if (strcmp (ns->proc_name->name, sym->name) == 0)
9985 gfc_free_expr (init);
9989 /* Build an l-value expression for the result. */
9990 lval = gfc_lval_expr_from_sym (sym);
9992 /* Add the code at scope entry. */
9993 init_st = gfc_get_code ();
9994 init_st->next = ns->code;
9997 /* Assign the default initializer to the l-value. */
9998 init_st->loc = sym->declared_at;
9999 init_st->op = EXEC_INIT_ASSIGN;
10000 init_st->expr1 = lval;
10001 init_st->expr2 = init;
10004 /* Assign the default initializer to a derived type variable or result. */
10007 apply_default_init (gfc_symbol *sym)
10009 gfc_expr *init = NULL;
10011 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
10014 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
10015 init = gfc_default_initializer (&sym->ts);
10017 if (init == NULL && sym->ts.type != BT_CLASS)
10020 build_init_assign (sym, init);
10021 sym->attr.referenced = 1;
10024 /* Build an initializer for a local integer, real, complex, logical, or
10025 character variable, based on the command line flags finit-local-zero,
10026 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10027 null if the symbol should not have a default initialization. */
10029 build_default_init_expr (gfc_symbol *sym)
10032 gfc_expr *init_expr;
10035 /* These symbols should never have a default initialization. */
10036 if (sym->attr.allocatable
10037 || sym->attr.external
10039 || sym->attr.pointer
10040 || sym->attr.in_equivalence
10041 || sym->attr.in_common
10044 || sym->attr.cray_pointee
10045 || sym->attr.cray_pointer)
10048 /* Now we'll try to build an initializer expression. */
10049 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
10050 &sym->declared_at);
10052 /* We will only initialize integers, reals, complex, logicals, and
10053 characters, and only if the corresponding command-line flags
10054 were set. Otherwise, we free init_expr and return null. */
10055 switch (sym->ts.type)
10058 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
10059 mpz_set_si (init_expr->value.integer,
10060 gfc_option.flag_init_integer_value);
10063 gfc_free_expr (init_expr);
10069 switch (gfc_option.flag_init_real)
10071 case GFC_INIT_REAL_SNAN:
10072 init_expr->is_snan = 1;
10073 /* Fall through. */
10074 case GFC_INIT_REAL_NAN:
10075 mpfr_set_nan (init_expr->value.real);
10078 case GFC_INIT_REAL_INF:
10079 mpfr_set_inf (init_expr->value.real, 1);
10082 case GFC_INIT_REAL_NEG_INF:
10083 mpfr_set_inf (init_expr->value.real, -1);
10086 case GFC_INIT_REAL_ZERO:
10087 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
10091 gfc_free_expr (init_expr);
10098 switch (gfc_option.flag_init_real)
10100 case GFC_INIT_REAL_SNAN:
10101 init_expr->is_snan = 1;
10102 /* Fall through. */
10103 case GFC_INIT_REAL_NAN:
10104 mpfr_set_nan (mpc_realref (init_expr->value.complex));
10105 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
10108 case GFC_INIT_REAL_INF:
10109 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
10110 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
10113 case GFC_INIT_REAL_NEG_INF:
10114 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
10115 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
10118 case GFC_INIT_REAL_ZERO:
10119 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
10123 gfc_free_expr (init_expr);
10130 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
10131 init_expr->value.logical = 0;
10132 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
10133 init_expr->value.logical = 1;
10136 gfc_free_expr (init_expr);
10142 /* For characters, the length must be constant in order to
10143 create a default initializer. */
10144 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
10145 && sym->ts.u.cl->length
10146 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
10148 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
10149 init_expr->value.character.length = char_len;
10150 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
10151 for (i = 0; i < char_len; i++)
10152 init_expr->value.character.string[i]
10153 = (unsigned char) gfc_option.flag_init_character_value;
10157 gfc_free_expr (init_expr);
10160 if (!init_expr && gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
10161 && sym->ts.u.cl->length)
10163 gfc_actual_arglist *arg;
10164 init_expr = gfc_get_expr ();
10165 init_expr->where = sym->declared_at;
10166 init_expr->ts = sym->ts;
10167 init_expr->expr_type = EXPR_FUNCTION;
10168 init_expr->value.function.isym =
10169 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT);
10170 init_expr->value.function.name = "repeat";
10171 arg = gfc_get_actual_arglist ();
10172 arg->expr = gfc_get_character_expr (sym->ts.kind, &sym->declared_at,
10174 arg->expr->value.character.string[0]
10175 = gfc_option.flag_init_character_value;
10176 arg->next = gfc_get_actual_arglist ();
10177 arg->next->expr = gfc_copy_expr (sym->ts.u.cl->length);
10178 init_expr->value.function.actual = arg;
10183 gfc_free_expr (init_expr);
10189 /* Add an initialization expression to a local variable. */
10191 apply_default_init_local (gfc_symbol *sym)
10193 gfc_expr *init = NULL;
10195 /* The symbol should be a variable or a function return value. */
10196 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
10197 || (sym->attr.function && sym->result != sym))
10200 /* Try to build the initializer expression. If we can't initialize
10201 this symbol, then init will be NULL. */
10202 init = build_default_init_expr (sym);
10206 /* For saved variables, we don't want to add an initializer at function
10207 entry, so we just add a static initializer. Note that automatic variables
10208 are stack allocated even with -fno-automatic. */
10209 if (sym->attr.save || sym->ns->save_all
10210 || (gfc_option.flag_max_stack_var_size == 0
10211 && (!sym->attr.dimension || !is_non_constant_shape_array (sym))))
10213 /* Don't clobber an existing initializer! */
10214 gcc_assert (sym->value == NULL);
10219 build_init_assign (sym, init);
10223 /* Resolution of common features of flavors variable and procedure. */
10226 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
10228 gfc_array_spec *as;
10230 /* Avoid double diagnostics for function result symbols. */
10231 if ((sym->result || sym->attr.result) && !sym->attr.dummy
10232 && (sym->ns != gfc_current_ns))
10235 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
10236 as = CLASS_DATA (sym)->as;
10240 /* Constraints on deferred shape variable. */
10241 if (as == NULL || as->type != AS_DEFERRED)
10243 bool pointer, allocatable, dimension;
10245 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
10247 pointer = CLASS_DATA (sym)->attr.class_pointer;
10248 allocatable = CLASS_DATA (sym)->attr.allocatable;
10249 dimension = CLASS_DATA (sym)->attr.dimension;
10253 pointer = sym->attr.pointer;
10254 allocatable = sym->attr.allocatable;
10255 dimension = sym->attr.dimension;
10262 gfc_error ("Allocatable array '%s' at %L must have "
10263 "a deferred shape", sym->name, &sym->declared_at);
10266 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
10267 "may not be ALLOCATABLE", sym->name,
10268 &sym->declared_at) == FAILURE)
10272 if (pointer && dimension)
10274 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
10275 sym->name, &sym->declared_at);
10281 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
10282 && sym->ts.type != BT_CLASS && !sym->assoc)
10284 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10285 sym->name, &sym->declared_at);
10290 /* Constraints on polymorphic variables. */
10291 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
10294 if (sym->attr.class_ok
10295 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
10297 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10298 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
10299 &sym->declared_at);
10304 /* Assume that use associated symbols were checked in the module ns.
10305 Class-variables that are associate-names are also something special
10306 and excepted from the test. */
10307 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
10309 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10310 "or pointer", sym->name, &sym->declared_at);
10319 /* Additional checks for symbols with flavor variable and derived
10320 type. To be called from resolve_fl_variable. */
10323 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
10325 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
10327 /* Check to see if a derived type is blocked from being host
10328 associated by the presence of another class I symbol in the same
10329 namespace. 14.6.1.3 of the standard and the discussion on
10330 comp.lang.fortran. */
10331 if (sym->ns != sym->ts.u.derived->ns
10332 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
10335 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
10336 if (s && s->attr.generic)
10337 s = gfc_find_dt_in_generic (s);
10338 if (s && s->attr.flavor != FL_DERIVED)
10340 gfc_error ("The type '%s' cannot be host associated at %L "
10341 "because it is blocked by an incompatible object "
10342 "of the same name declared at %L",
10343 sym->ts.u.derived->name, &sym->declared_at,
10349 /* 4th constraint in section 11.3: "If an object of a type for which
10350 component-initialization is specified (R429) appears in the
10351 specification-part of a module and does not have the ALLOCATABLE
10352 or POINTER attribute, the object shall have the SAVE attribute."
10354 The check for initializers is performed with
10355 gfc_has_default_initializer because gfc_default_initializer generates
10356 a hidden default for allocatable components. */
10357 if (!(sym->value || no_init_flag) && sym->ns->proc_name
10358 && sym->ns->proc_name->attr.flavor == FL_MODULE
10359 && !sym->ns->save_all && !sym->attr.save
10360 && !sym->attr.pointer && !sym->attr.allocatable
10361 && gfc_has_default_initializer (sym->ts.u.derived)
10362 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
10363 "module variable '%s' at %L, needed due to "
10364 "the default initialization", sym->name,
10365 &sym->declared_at) == FAILURE)
10368 /* Assign default initializer. */
10369 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
10370 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
10372 sym->value = gfc_default_initializer (&sym->ts);
10379 /* Resolve symbols with flavor variable. */
10382 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
10384 int no_init_flag, automatic_flag;
10386 const char *auto_save_msg;
10388 auto_save_msg = "Automatic object '%s' at %L cannot have the "
10391 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10394 /* Set this flag to check that variables are parameters of all entries.
10395 This check is effected by the call to gfc_resolve_expr through
10396 is_non_constant_shape_array. */
10397 specification_expr = 1;
10399 if (sym->ns->proc_name
10400 && (sym->ns->proc_name->attr.flavor == FL_MODULE
10401 || sym->ns->proc_name->attr.is_main_program)
10402 && !sym->attr.use_assoc
10403 && !sym->attr.allocatable
10404 && !sym->attr.pointer
10405 && is_non_constant_shape_array (sym))
10407 /* The shape of a main program or module array needs to be
10409 gfc_error ("The module or main program array '%s' at %L must "
10410 "have constant shape", sym->name, &sym->declared_at);
10411 specification_expr = 0;
10415 /* Constraints on deferred type parameter. */
10416 if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
10418 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10419 "requires either the pointer or allocatable attribute",
10420 sym->name, &sym->declared_at);
10424 if (sym->ts.type == BT_CHARACTER)
10426 /* Make sure that character string variables with assumed length are
10427 dummy arguments. */
10428 e = sym->ts.u.cl->length;
10429 if (e == NULL && !sym->attr.dummy && !sym->attr.result
10430 && !sym->ts.deferred)
10432 gfc_error ("Entity with assumed character length at %L must be a "
10433 "dummy argument or a PARAMETER", &sym->declared_at);
10437 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
10439 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10443 if (!gfc_is_constant_expr (e)
10444 && !(e->expr_type == EXPR_VARIABLE
10445 && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
10447 if (!sym->attr.use_assoc && sym->ns->proc_name
10448 && (sym->ns->proc_name->attr.flavor == FL_MODULE
10449 || sym->ns->proc_name->attr.is_main_program))
10451 gfc_error ("'%s' at %L must have constant character length "
10452 "in this context", sym->name, &sym->declared_at);
10455 if (sym->attr.in_common)
10457 gfc_error ("COMMON variable '%s' at %L must have constant "
10458 "character length", sym->name, &sym->declared_at);
10464 if (sym->value == NULL && sym->attr.referenced)
10465 apply_default_init_local (sym); /* Try to apply a default initialization. */
10467 /* Determine if the symbol may not have an initializer. */
10468 no_init_flag = automatic_flag = 0;
10469 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
10470 || sym->attr.intrinsic || sym->attr.result)
10472 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
10473 && is_non_constant_shape_array (sym))
10475 no_init_flag = automatic_flag = 1;
10477 /* Also, they must not have the SAVE attribute.
10478 SAVE_IMPLICIT is checked below. */
10479 if (sym->as && sym->attr.codimension)
10481 int corank = sym->as->corank;
10482 sym->as->corank = 0;
10483 no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
10484 sym->as->corank = corank;
10486 if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
10488 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10493 /* Ensure that any initializer is simplified. */
10495 gfc_simplify_expr (sym->value, 1);
10497 /* Reject illegal initializers. */
10498 if (!sym->mark && sym->value)
10500 if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
10501 && CLASS_DATA (sym)->attr.allocatable))
10502 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10503 sym->name, &sym->declared_at);
10504 else if (sym->attr.external)
10505 gfc_error ("External '%s' at %L cannot have an initializer",
10506 sym->name, &sym->declared_at);
10507 else if (sym->attr.dummy
10508 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
10509 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10510 sym->name, &sym->declared_at);
10511 else if (sym->attr.intrinsic)
10512 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10513 sym->name, &sym->declared_at);
10514 else if (sym->attr.result)
10515 gfc_error ("Function result '%s' at %L cannot have an initializer",
10516 sym->name, &sym->declared_at);
10517 else if (automatic_flag)
10518 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10519 sym->name, &sym->declared_at);
10521 goto no_init_error;
10526 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
10527 return resolve_fl_variable_derived (sym, no_init_flag);
10533 /* Resolve a procedure. */
10536 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
10538 gfc_formal_arglist *arg;
10540 if (sym->attr.function
10541 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10544 if (sym->ts.type == BT_CHARACTER)
10546 gfc_charlen *cl = sym->ts.u.cl;
10548 if (cl && cl->length && gfc_is_constant_expr (cl->length)
10549 && resolve_charlen (cl) == FAILURE)
10552 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
10553 && sym->attr.proc == PROC_ST_FUNCTION)
10555 gfc_error ("Character-valued statement function '%s' at %L must "
10556 "have constant length", sym->name, &sym->declared_at);
10561 /* Ensure that derived type for are not of a private type. Internal
10562 module procedures are excluded by 2.2.3.3 - i.e., they are not
10563 externally accessible and can access all the objects accessible in
10565 if (!(sym->ns->parent
10566 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
10567 && gfc_check_symbol_access (sym))
10569 gfc_interface *iface;
10571 for (arg = sym->formal; arg; arg = arg->next)
10574 && arg->sym->ts.type == BT_DERIVED
10575 && !arg->sym->ts.u.derived->attr.use_assoc
10576 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10577 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
10578 "PRIVATE type and cannot be a dummy argument"
10579 " of '%s', which is PUBLIC at %L",
10580 arg->sym->name, sym->name, &sym->declared_at)
10583 /* Stop this message from recurring. */
10584 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10589 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10590 PRIVATE to the containing module. */
10591 for (iface = sym->generic; iface; iface = iface->next)
10593 for (arg = iface->sym->formal; arg; arg = arg->next)
10596 && arg->sym->ts.type == BT_DERIVED
10597 && !arg->sym->ts.u.derived->attr.use_assoc
10598 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10599 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10600 "'%s' in PUBLIC interface '%s' at %L "
10601 "takes dummy arguments of '%s' which is "
10602 "PRIVATE", iface->sym->name, sym->name,
10603 &iface->sym->declared_at,
10604 gfc_typename (&arg->sym->ts)) == FAILURE)
10606 /* Stop this message from recurring. */
10607 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10613 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10614 PRIVATE to the containing module. */
10615 for (iface = sym->generic; iface; iface = iface->next)
10617 for (arg = iface->sym->formal; arg; arg = arg->next)
10620 && arg->sym->ts.type == BT_DERIVED
10621 && !arg->sym->ts.u.derived->attr.use_assoc
10622 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10623 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10624 "'%s' in PUBLIC interface '%s' at %L "
10625 "takes dummy arguments of '%s' which is "
10626 "PRIVATE", iface->sym->name, sym->name,
10627 &iface->sym->declared_at,
10628 gfc_typename (&arg->sym->ts)) == FAILURE)
10630 /* Stop this message from recurring. */
10631 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10638 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10639 && !sym->attr.proc_pointer)
10641 gfc_error ("Function '%s' at %L cannot have an initializer",
10642 sym->name, &sym->declared_at);
10646 /* An external symbol may not have an initializer because it is taken to be
10647 a procedure. Exception: Procedure Pointers. */
10648 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10650 gfc_error ("External object '%s' at %L may not have an initializer",
10651 sym->name, &sym->declared_at);
10655 /* An elemental function is required to return a scalar 12.7.1 */
10656 if (sym->attr.elemental && sym->attr.function && sym->as)
10658 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10659 "result", sym->name, &sym->declared_at);
10660 /* Reset so that the error only occurs once. */
10661 sym->attr.elemental = 0;
10665 if (sym->attr.proc == PROC_ST_FUNCTION
10666 && (sym->attr.allocatable || sym->attr.pointer))
10668 gfc_error ("Statement function '%s' at %L may not have pointer or "
10669 "allocatable attribute", sym->name, &sym->declared_at);
10673 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10674 char-len-param shall not be array-valued, pointer-valued, recursive
10675 or pure. ....snip... A character value of * may only be used in the
10676 following ways: (i) Dummy arg of procedure - dummy associates with
10677 actual length; (ii) To declare a named constant; or (iii) External
10678 function - but length must be declared in calling scoping unit. */
10679 if (sym->attr.function
10680 && sym->ts.type == BT_CHARACTER
10681 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10683 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10684 || (sym->attr.recursive) || (sym->attr.pure))
10686 if (sym->as && sym->as->rank)
10687 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10688 "array-valued", sym->name, &sym->declared_at);
10690 if (sym->attr.pointer)
10691 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10692 "pointer-valued", sym->name, &sym->declared_at);
10694 if (sym->attr.pure)
10695 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10696 "pure", sym->name, &sym->declared_at);
10698 if (sym->attr.recursive)
10699 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10700 "recursive", sym->name, &sym->declared_at);
10705 /* Appendix B.2 of the standard. Contained functions give an
10706 error anyway. Fixed-form is likely to be F77/legacy. Deferred
10707 character length is an F2003 feature. */
10708 if (!sym->attr.contained
10709 && gfc_current_form != FORM_FIXED
10710 && !sym->ts.deferred)
10711 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10712 "CHARACTER(*) function '%s' at %L",
10713 sym->name, &sym->declared_at);
10716 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10718 gfc_formal_arglist *curr_arg;
10719 int has_non_interop_arg = 0;
10721 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10722 sym->common_block) == FAILURE)
10724 /* Clear these to prevent looking at them again if there was an
10726 sym->attr.is_bind_c = 0;
10727 sym->attr.is_c_interop = 0;
10728 sym->ts.is_c_interop = 0;
10732 /* So far, no errors have been found. */
10733 sym->attr.is_c_interop = 1;
10734 sym->ts.is_c_interop = 1;
10737 curr_arg = sym->formal;
10738 while (curr_arg != NULL)
10740 /* Skip implicitly typed dummy args here. */
10741 if (curr_arg->sym->attr.implicit_type == 0)
10742 if (gfc_verify_c_interop_param (curr_arg->sym) == FAILURE)
10743 /* If something is found to fail, record the fact so we
10744 can mark the symbol for the procedure as not being
10745 BIND(C) to try and prevent multiple errors being
10747 has_non_interop_arg = 1;
10749 curr_arg = curr_arg->next;
10752 /* See if any of the arguments were not interoperable and if so, clear
10753 the procedure symbol to prevent duplicate error messages. */
10754 if (has_non_interop_arg != 0)
10756 sym->attr.is_c_interop = 0;
10757 sym->ts.is_c_interop = 0;
10758 sym->attr.is_bind_c = 0;
10762 if (!sym->attr.proc_pointer)
10764 if (sym->attr.save == SAVE_EXPLICIT)
10766 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10767 "in '%s' at %L", sym->name, &sym->declared_at);
10770 if (sym->attr.intent)
10772 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10773 "in '%s' at %L", sym->name, &sym->declared_at);
10776 if (sym->attr.subroutine && sym->attr.result)
10778 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10779 "in '%s' at %L", sym->name, &sym->declared_at);
10782 if (sym->attr.external && sym->attr.function
10783 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10784 || sym->attr.contained))
10786 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10787 "in '%s' at %L", sym->name, &sym->declared_at);
10790 if (strcmp ("ppr@", sym->name) == 0)
10792 gfc_error ("Procedure pointer result '%s' at %L "
10793 "is missing the pointer attribute",
10794 sym->ns->proc_name->name, &sym->declared_at);
10803 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10804 been defined and we now know their defined arguments, check that they fulfill
10805 the requirements of the standard for procedures used as finalizers. */
10808 gfc_resolve_finalizers (gfc_symbol* derived)
10810 gfc_finalizer* list;
10811 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10812 gfc_try result = SUCCESS;
10813 bool seen_scalar = false;
10815 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10818 /* Walk over the list of finalizer-procedures, check them, and if any one
10819 does not fit in with the standard's definition, print an error and remove
10820 it from the list. */
10821 prev_link = &derived->f2k_derived->finalizers;
10822 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10828 /* Skip this finalizer if we already resolved it. */
10829 if (list->proc_tree)
10831 prev_link = &(list->next);
10835 /* Check this exists and is a SUBROUTINE. */
10836 if (!list->proc_sym->attr.subroutine)
10838 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10839 list->proc_sym->name, &list->where);
10843 /* We should have exactly one argument. */
10844 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10846 gfc_error ("FINAL procedure at %L must have exactly one argument",
10850 arg = list->proc_sym->formal->sym;
10852 /* This argument must be of our type. */
10853 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10855 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10856 &arg->declared_at, derived->name);
10860 /* It must neither be a pointer nor allocatable nor optional. */
10861 if (arg->attr.pointer)
10863 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10864 &arg->declared_at);
10867 if (arg->attr.allocatable)
10869 gfc_error ("Argument of FINAL procedure at %L must not be"
10870 " ALLOCATABLE", &arg->declared_at);
10873 if (arg->attr.optional)
10875 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10876 &arg->declared_at);
10880 /* It must not be INTENT(OUT). */
10881 if (arg->attr.intent == INTENT_OUT)
10883 gfc_error ("Argument of FINAL procedure at %L must not be"
10884 " INTENT(OUT)", &arg->declared_at);
10888 /* Warn if the procedure is non-scalar and not assumed shape. */
10889 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10890 && arg->as->type != AS_ASSUMED_SHAPE)
10891 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10892 " shape argument", &arg->declared_at);
10894 /* Check that it does not match in kind and rank with a FINAL procedure
10895 defined earlier. To really loop over the *earlier* declarations,
10896 we need to walk the tail of the list as new ones were pushed at the
10898 /* TODO: Handle kind parameters once they are implemented. */
10899 my_rank = (arg->as ? arg->as->rank : 0);
10900 for (i = list->next; i; i = i->next)
10902 /* Argument list might be empty; that is an error signalled earlier,
10903 but we nevertheless continued resolving. */
10904 if (i->proc_sym->formal)
10906 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10907 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10908 if (i_rank == my_rank)
10910 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10911 " rank (%d) as '%s'",
10912 list->proc_sym->name, &list->where, my_rank,
10913 i->proc_sym->name);
10919 /* Is this the/a scalar finalizer procedure? */
10920 if (!arg->as || arg->as->rank == 0)
10921 seen_scalar = true;
10923 /* Find the symtree for this procedure. */
10924 gcc_assert (!list->proc_tree);
10925 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10927 prev_link = &list->next;
10930 /* Remove wrong nodes immediately from the list so we don't risk any
10931 troubles in the future when they might fail later expectations. */
10935 *prev_link = list->next;
10936 gfc_free_finalizer (i);
10939 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10940 were nodes in the list, must have been for arrays. It is surely a good
10941 idea to have a scalar version there if there's something to finalize. */
10942 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10943 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10944 " defined at %L, suggest also scalar one",
10945 derived->name, &derived->declared_at);
10947 /* TODO: Remove this error when finalization is finished. */
10948 gfc_error ("Finalization at %L is not yet implemented",
10949 &derived->declared_at);
10955 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10958 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10959 const char* generic_name, locus where)
10964 gcc_assert (t1->specific && t2->specific);
10965 gcc_assert (!t1->specific->is_generic);
10966 gcc_assert (!t2->specific->is_generic);
10968 sym1 = t1->specific->u.specific->n.sym;
10969 sym2 = t2->specific->u.specific->n.sym;
10974 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10975 if (sym1->attr.subroutine != sym2->attr.subroutine
10976 || sym1->attr.function != sym2->attr.function)
10978 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10979 " GENERIC '%s' at %L",
10980 sym1->name, sym2->name, generic_name, &where);
10984 /* Compare the interfaces. */
10985 if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
10987 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10988 sym1->name, sym2->name, generic_name, &where);
10996 /* Worker function for resolving a generic procedure binding; this is used to
10997 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10999 The difference between those cases is finding possible inherited bindings
11000 that are overridden, as one has to look for them in tb_sym_root,
11001 tb_uop_root or tb_op, respectively. Thus the caller must already find
11002 the super-type and set p->overridden correctly. */
11005 resolve_tb_generic_targets (gfc_symbol* super_type,
11006 gfc_typebound_proc* p, const char* name)
11008 gfc_tbp_generic* target;
11009 gfc_symtree* first_target;
11010 gfc_symtree* inherited;
11012 gcc_assert (p && p->is_generic);
11014 /* Try to find the specific bindings for the symtrees in our target-list. */
11015 gcc_assert (p->u.generic);
11016 for (target = p->u.generic; target; target = target->next)
11017 if (!target->specific)
11019 gfc_typebound_proc* overridden_tbp;
11020 gfc_tbp_generic* g;
11021 const char* target_name;
11023 target_name = target->specific_st->name;
11025 /* Defined for this type directly. */
11026 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
11028 target->specific = target->specific_st->n.tb;
11029 goto specific_found;
11032 /* Look for an inherited specific binding. */
11035 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
11040 gcc_assert (inherited->n.tb);
11041 target->specific = inherited->n.tb;
11042 goto specific_found;
11046 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11047 " at %L", target_name, name, &p->where);
11050 /* Once we've found the specific binding, check it is not ambiguous with
11051 other specifics already found or inherited for the same GENERIC. */
11053 gcc_assert (target->specific);
11055 /* This must really be a specific binding! */
11056 if (target->specific->is_generic)
11058 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11059 " '%s' is GENERIC, too", name, &p->where, target_name);
11063 /* Check those already resolved on this type directly. */
11064 for (g = p->u.generic; g; g = g->next)
11065 if (g != target && g->specific
11066 && check_generic_tbp_ambiguity (target, g, name, p->where)
11070 /* Check for ambiguity with inherited specific targets. */
11071 for (overridden_tbp = p->overridden; overridden_tbp;
11072 overridden_tbp = overridden_tbp->overridden)
11073 if (overridden_tbp->is_generic)
11075 for (g = overridden_tbp->u.generic; g; g = g->next)
11077 gcc_assert (g->specific);
11078 if (check_generic_tbp_ambiguity (target, g,
11079 name, p->where) == FAILURE)
11085 /* If we attempt to "overwrite" a specific binding, this is an error. */
11086 if (p->overridden && !p->overridden->is_generic)
11088 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11089 " the same name", name, &p->where);
11093 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11094 all must have the same attributes here. */
11095 first_target = p->u.generic->specific->u.specific;
11096 gcc_assert (first_target);
11097 p->subroutine = first_target->n.sym->attr.subroutine;
11098 p->function = first_target->n.sym->attr.function;
11104 /* Resolve a GENERIC procedure binding for a derived type. */
11107 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
11109 gfc_symbol* super_type;
11111 /* Find the overridden binding if any. */
11112 st->n.tb->overridden = NULL;
11113 super_type = gfc_get_derived_super_type (derived);
11116 gfc_symtree* overridden;
11117 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
11120 if (overridden && overridden->n.tb)
11121 st->n.tb->overridden = overridden->n.tb;
11124 /* Resolve using worker function. */
11125 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
11129 /* Retrieve the target-procedure of an operator binding and do some checks in
11130 common for intrinsic and user-defined type-bound operators. */
11133 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
11135 gfc_symbol* target_proc;
11137 gcc_assert (target->specific && !target->specific->is_generic);
11138 target_proc = target->specific->u.specific->n.sym;
11139 gcc_assert (target_proc);
11141 /* All operator bindings must have a passed-object dummy argument. */
11142 if (target->specific->nopass)
11144 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
11148 return target_proc;
11152 /* Resolve a type-bound intrinsic operator. */
11155 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
11156 gfc_typebound_proc* p)
11158 gfc_symbol* super_type;
11159 gfc_tbp_generic* target;
11161 /* If there's already an error here, do nothing (but don't fail again). */
11165 /* Operators should always be GENERIC bindings. */
11166 gcc_assert (p->is_generic);
11168 /* Look for an overridden binding. */
11169 super_type = gfc_get_derived_super_type (derived);
11170 if (super_type && super_type->f2k_derived)
11171 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
11174 p->overridden = NULL;
11176 /* Resolve general GENERIC properties using worker function. */
11177 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
11180 /* Check the targets to be procedures of correct interface. */
11181 for (target = p->u.generic; target; target = target->next)
11183 gfc_symbol* target_proc;
11185 target_proc = get_checked_tb_operator_target (target, p->where);
11189 if (!gfc_check_operator_interface (target_proc, op, p->where))
11201 /* Resolve a type-bound user operator (tree-walker callback). */
11203 static gfc_symbol* resolve_bindings_derived;
11204 static gfc_try resolve_bindings_result;
11206 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
11209 resolve_typebound_user_op (gfc_symtree* stree)
11211 gfc_symbol* super_type;
11212 gfc_tbp_generic* target;
11214 gcc_assert (stree && stree->n.tb);
11216 if (stree->n.tb->error)
11219 /* Operators should always be GENERIC bindings. */
11220 gcc_assert (stree->n.tb->is_generic);
11222 /* Find overridden procedure, if any. */
11223 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11224 if (super_type && super_type->f2k_derived)
11226 gfc_symtree* overridden;
11227 overridden = gfc_find_typebound_user_op (super_type, NULL,
11228 stree->name, true, NULL);
11230 if (overridden && overridden->n.tb)
11231 stree->n.tb->overridden = overridden->n.tb;
11234 stree->n.tb->overridden = NULL;
11236 /* Resolve basically using worker function. */
11237 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
11241 /* Check the targets to be functions of correct interface. */
11242 for (target = stree->n.tb->u.generic; target; target = target->next)
11244 gfc_symbol* target_proc;
11246 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
11250 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
11257 resolve_bindings_result = FAILURE;
11258 stree->n.tb->error = 1;
11262 /* Resolve the type-bound procedures for a derived type. */
11265 resolve_typebound_procedure (gfc_symtree* stree)
11269 gfc_symbol* me_arg;
11270 gfc_symbol* super_type;
11271 gfc_component* comp;
11273 gcc_assert (stree);
11275 /* Undefined specific symbol from GENERIC target definition. */
11279 if (stree->n.tb->error)
11282 /* If this is a GENERIC binding, use that routine. */
11283 if (stree->n.tb->is_generic)
11285 if (resolve_typebound_generic (resolve_bindings_derived, stree)
11291 /* Get the target-procedure to check it. */
11292 gcc_assert (!stree->n.tb->is_generic);
11293 gcc_assert (stree->n.tb->u.specific);
11294 proc = stree->n.tb->u.specific->n.sym;
11295 where = stree->n.tb->where;
11297 /* Default access should already be resolved from the parser. */
11298 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
11300 /* It should be a module procedure or an external procedure with explicit
11301 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
11302 if ((!proc->attr.subroutine && !proc->attr.function)
11303 || (proc->attr.proc != PROC_MODULE
11304 && proc->attr.if_source != IFSRC_IFBODY)
11305 || (proc->attr.abstract && !stree->n.tb->deferred))
11307 gfc_error ("'%s' must be a module procedure or an external procedure with"
11308 " an explicit interface at %L", proc->name, &where);
11311 stree->n.tb->subroutine = proc->attr.subroutine;
11312 stree->n.tb->function = proc->attr.function;
11314 /* Find the super-type of the current derived type. We could do this once and
11315 store in a global if speed is needed, but as long as not I believe this is
11316 more readable and clearer. */
11317 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11319 /* If PASS, resolve and check arguments if not already resolved / loaded
11320 from a .mod file. */
11321 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
11323 if (stree->n.tb->pass_arg)
11325 gfc_formal_arglist* i;
11327 /* If an explicit passing argument name is given, walk the arg-list
11328 and look for it. */
11331 stree->n.tb->pass_arg_num = 1;
11332 for (i = proc->formal; i; i = i->next)
11334 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
11339 ++stree->n.tb->pass_arg_num;
11344 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11346 proc->name, stree->n.tb->pass_arg, &where,
11347 stree->n.tb->pass_arg);
11353 /* Otherwise, take the first one; there should in fact be at least
11355 stree->n.tb->pass_arg_num = 1;
11358 gfc_error ("Procedure '%s' with PASS at %L must have at"
11359 " least one argument", proc->name, &where);
11362 me_arg = proc->formal->sym;
11365 /* Now check that the argument-type matches and the passed-object
11366 dummy argument is generally fine. */
11368 gcc_assert (me_arg);
11370 if (me_arg->ts.type != BT_CLASS)
11372 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11373 " at %L", proc->name, &where);
11377 if (CLASS_DATA (me_arg)->ts.u.derived
11378 != resolve_bindings_derived)
11380 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11381 " the derived-type '%s'", me_arg->name, proc->name,
11382 me_arg->name, &where, resolve_bindings_derived->name);
11386 gcc_assert (me_arg->ts.type == BT_CLASS);
11387 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
11389 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11390 " scalar", proc->name, &where);
11393 if (CLASS_DATA (me_arg)->attr.allocatable)
11395 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11396 " be ALLOCATABLE", proc->name, &where);
11399 if (CLASS_DATA (me_arg)->attr.class_pointer)
11401 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11402 " be POINTER", proc->name, &where);
11407 /* If we are extending some type, check that we don't override a procedure
11408 flagged NON_OVERRIDABLE. */
11409 stree->n.tb->overridden = NULL;
11412 gfc_symtree* overridden;
11413 overridden = gfc_find_typebound_proc (super_type, NULL,
11414 stree->name, true, NULL);
11418 if (overridden->n.tb)
11419 stree->n.tb->overridden = overridden->n.tb;
11421 if (gfc_check_typebound_override (stree, overridden) == FAILURE)
11426 /* See if there's a name collision with a component directly in this type. */
11427 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11428 if (!strcmp (comp->name, stree->name))
11430 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11432 stree->name, &where, resolve_bindings_derived->name);
11436 /* Try to find a name collision with an inherited component. */
11437 if (super_type && gfc_find_component (super_type, stree->name, true, true))
11439 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11440 " component of '%s'",
11441 stree->name, &where, resolve_bindings_derived->name);
11445 stree->n.tb->error = 0;
11449 resolve_bindings_result = FAILURE;
11450 stree->n.tb->error = 1;
11455 resolve_typebound_procedures (gfc_symbol* derived)
11458 gfc_symbol* super_type;
11460 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11463 super_type = gfc_get_derived_super_type (derived);
11465 resolve_typebound_procedures (super_type);
11467 resolve_bindings_derived = derived;
11468 resolve_bindings_result = SUCCESS;
11470 /* Make sure the vtab has been generated. */
11471 gfc_find_derived_vtab (derived);
11473 if (derived->f2k_derived->tb_sym_root)
11474 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11475 &resolve_typebound_procedure);
11477 if (derived->f2k_derived->tb_uop_root)
11478 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11479 &resolve_typebound_user_op);
11481 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11483 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11484 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11486 resolve_bindings_result = FAILURE;
11489 return resolve_bindings_result;
11493 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11494 to give all identical derived types the same backend_decl. */
11496 add_dt_to_dt_list (gfc_symbol *derived)
11498 gfc_dt_list *dt_list;
11500 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11501 if (derived == dt_list->derived)
11504 dt_list = gfc_get_dt_list ();
11505 dt_list->next = gfc_derived_types;
11506 dt_list->derived = derived;
11507 gfc_derived_types = dt_list;
11511 /* Ensure that a derived-type is really not abstract, meaning that every
11512 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11515 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11520 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11522 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11525 if (st->n.tb && st->n.tb->deferred)
11527 gfc_symtree* overriding;
11528 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11531 gcc_assert (overriding->n.tb);
11532 if (overriding->n.tb->deferred)
11534 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11535 " '%s' is DEFERRED and not overridden",
11536 sub->name, &sub->declared_at, st->name);
11545 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11547 /* The algorithm used here is to recursively travel up the ancestry of sub
11548 and for each ancestor-type, check all bindings. If any of them is
11549 DEFERRED, look it up starting from sub and see if the found (overriding)
11550 binding is not DEFERRED.
11551 This is not the most efficient way to do this, but it should be ok and is
11552 clearer than something sophisticated. */
11554 gcc_assert (ancestor && !sub->attr.abstract);
11556 if (!ancestor->attr.abstract)
11559 /* Walk bindings of this ancestor. */
11560 if (ancestor->f2k_derived)
11563 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11568 /* Find next ancestor type and recurse on it. */
11569 ancestor = gfc_get_derived_super_type (ancestor);
11571 return ensure_not_abstract (sub, ancestor);
11577 /* Resolve the components of a derived type. This does not have to wait until
11578 resolution stage, but can be done as soon as the dt declaration has been
11582 resolve_fl_derived0 (gfc_symbol *sym)
11584 gfc_symbol* super_type;
11587 super_type = gfc_get_derived_super_type (sym);
11590 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11592 gfc_error ("As extending type '%s' at %L has a coarray component, "
11593 "parent type '%s' shall also have one", sym->name,
11594 &sym->declared_at, super_type->name);
11598 /* Ensure the extended type gets resolved before we do. */
11599 if (super_type && resolve_fl_derived0 (super_type) == FAILURE)
11602 /* An ABSTRACT type must be extensible. */
11603 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11605 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11606 sym->name, &sym->declared_at);
11610 c = (sym->attr.is_class) ? sym->components->ts.u.derived->components
11613 for ( ; c != NULL; c = c->next)
11615 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
11616 if (c->ts.type == BT_CHARACTER && c->ts.deferred)
11618 gfc_error ("Deferred-length character component '%s' at %L is not "
11619 "yet supported", c->name, &c->loc);
11624 if ((!sym->attr.is_class || c != sym->components)
11625 && c->attr.codimension
11626 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11628 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11629 "deferred shape", c->name, &c->loc);
11634 if (c->attr.codimension && c->ts.type == BT_DERIVED
11635 && c->ts.u.derived->ts.is_iso_c)
11637 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11638 "shall not be a coarray", c->name, &c->loc);
11643 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11644 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11645 || c->attr.allocatable))
11647 gfc_error ("Component '%s' at %L with coarray component "
11648 "shall be a nonpointer, nonallocatable scalar",
11654 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11656 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11657 "is not an array pointer", c->name, &c->loc);
11661 if (c->attr.proc_pointer && c->ts.interface)
11663 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11664 gfc_error ("Interface '%s', used by procedure pointer component "
11665 "'%s' at %L, is declared in a later PROCEDURE statement",
11666 c->ts.interface->name, c->name, &c->loc);
11668 /* Get the attributes from the interface (now resolved). */
11669 if (c->ts.interface->attr.if_source
11670 || c->ts.interface->attr.intrinsic)
11672 gfc_symbol *ifc = c->ts.interface;
11674 if (ifc->formal && !ifc->formal_ns)
11675 resolve_symbol (ifc);
11677 if (ifc->attr.intrinsic)
11678 resolve_intrinsic (ifc, &ifc->declared_at);
11682 c->ts = ifc->result->ts;
11683 c->attr.allocatable = ifc->result->attr.allocatable;
11684 c->attr.pointer = ifc->result->attr.pointer;
11685 c->attr.dimension = ifc->result->attr.dimension;
11686 c->as = gfc_copy_array_spec (ifc->result->as);
11691 c->attr.allocatable = ifc->attr.allocatable;
11692 c->attr.pointer = ifc->attr.pointer;
11693 c->attr.dimension = ifc->attr.dimension;
11694 c->as = gfc_copy_array_spec (ifc->as);
11696 c->ts.interface = ifc;
11697 c->attr.function = ifc->attr.function;
11698 c->attr.subroutine = ifc->attr.subroutine;
11699 gfc_copy_formal_args_ppc (c, ifc);
11701 c->attr.pure = ifc->attr.pure;
11702 c->attr.elemental = ifc->attr.elemental;
11703 c->attr.recursive = ifc->attr.recursive;
11704 c->attr.always_explicit = ifc->attr.always_explicit;
11705 c->attr.ext_attr |= ifc->attr.ext_attr;
11706 /* Replace symbols in array spec. */
11710 for (i = 0; i < c->as->rank; i++)
11712 gfc_expr_replace_comp (c->as->lower[i], c);
11713 gfc_expr_replace_comp (c->as->upper[i], c);
11716 /* Copy char length. */
11717 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11719 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11720 gfc_expr_replace_comp (cl->length, c);
11721 if (cl->length && !cl->resolved
11722 && gfc_resolve_expr (cl->length) == FAILURE)
11727 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11729 gfc_error ("Interface '%s' of procedure pointer component "
11730 "'%s' at %L must be explicit", c->ts.interface->name,
11735 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11737 /* Since PPCs are not implicitly typed, a PPC without an explicit
11738 interface must be a subroutine. */
11739 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11742 /* Procedure pointer components: Check PASS arg. */
11743 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11744 && !sym->attr.vtype)
11746 gfc_symbol* me_arg;
11748 if (c->tb->pass_arg)
11750 gfc_formal_arglist* i;
11752 /* If an explicit passing argument name is given, walk the arg-list
11753 and look for it. */
11756 c->tb->pass_arg_num = 1;
11757 for (i = c->formal; i; i = i->next)
11759 if (!strcmp (i->sym->name, c->tb->pass_arg))
11764 c->tb->pass_arg_num++;
11769 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11770 "at %L has no argument '%s'", c->name,
11771 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11778 /* Otherwise, take the first one; there should in fact be at least
11780 c->tb->pass_arg_num = 1;
11783 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11784 "must have at least one argument",
11789 me_arg = c->formal->sym;
11792 /* Now check that the argument-type matches. */
11793 gcc_assert (me_arg);
11794 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11795 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11796 || (me_arg->ts.type == BT_CLASS
11797 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11799 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11800 " the derived type '%s'", me_arg->name, c->name,
11801 me_arg->name, &c->loc, sym->name);
11806 /* Check for C453. */
11807 if (me_arg->attr.dimension)
11809 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11810 "must be scalar", me_arg->name, c->name, me_arg->name,
11816 if (me_arg->attr.pointer)
11818 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11819 "may not have the POINTER attribute", me_arg->name,
11820 c->name, me_arg->name, &c->loc);
11825 if (me_arg->attr.allocatable)
11827 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11828 "may not be ALLOCATABLE", me_arg->name, c->name,
11829 me_arg->name, &c->loc);
11834 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11835 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11836 " at %L", c->name, &c->loc);
11840 /* Check type-spec if this is not the parent-type component. */
11841 if (((sym->attr.is_class
11842 && (!sym->components->ts.u.derived->attr.extension
11843 || c != sym->components->ts.u.derived->components))
11844 || (!sym->attr.is_class
11845 && (!sym->attr.extension || c != sym->components)))
11846 && !sym->attr.vtype
11847 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11850 /* If this type is an extension, set the accessibility of the parent
11853 && ((sym->attr.is_class
11854 && c == sym->components->ts.u.derived->components)
11855 || (!sym->attr.is_class && c == sym->components))
11856 && strcmp (super_type->name, c->name) == 0)
11857 c->attr.access = super_type->attr.access;
11859 /* If this type is an extension, see if this component has the same name
11860 as an inherited type-bound procedure. */
11861 if (super_type && !sym->attr.is_class
11862 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11864 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11865 " inherited type-bound procedure",
11866 c->name, sym->name, &c->loc);
11870 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
11871 && !c->ts.deferred)
11873 if (c->ts.u.cl->length == NULL
11874 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11875 || !gfc_is_constant_expr (c->ts.u.cl->length))
11877 gfc_error ("Character length of component '%s' needs to "
11878 "be a constant specification expression at %L",
11880 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11885 if (c->ts.type == BT_CHARACTER && c->ts.deferred
11886 && !c->attr.pointer && !c->attr.allocatable)
11888 gfc_error ("Character component '%s' of '%s' at %L with deferred "
11889 "length must be a POINTER or ALLOCATABLE",
11890 c->name, sym->name, &c->loc);
11894 if (c->ts.type == BT_DERIVED
11895 && sym->component_access != ACCESS_PRIVATE
11896 && gfc_check_symbol_access (sym)
11897 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11898 && !c->ts.u.derived->attr.use_assoc
11899 && !gfc_check_symbol_access (c->ts.u.derived)
11900 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11901 "is a PRIVATE type and cannot be a component of "
11902 "'%s', which is PUBLIC at %L", c->name,
11903 sym->name, &sym->declared_at) == FAILURE)
11906 if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
11908 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11909 "type %s", c->name, &c->loc, sym->name);
11913 if (sym->attr.sequence)
11915 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11917 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11918 "not have the SEQUENCE attribute",
11919 c->ts.u.derived->name, &sym->declared_at);
11924 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
11925 c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
11926 else if (c->ts.type == BT_CLASS && c->attr.class_ok
11927 && CLASS_DATA (c)->ts.u.derived->attr.generic)
11928 CLASS_DATA (c)->ts.u.derived
11929 = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
11931 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
11932 && c->attr.pointer && c->ts.u.derived->components == NULL
11933 && !c->ts.u.derived->attr.zero_comp)
11935 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11936 "that has not been declared", c->name, sym->name,
11941 if (c->ts.type == BT_CLASS && c->attr.class_ok
11942 && CLASS_DATA (c)->attr.class_pointer
11943 && CLASS_DATA (c)->ts.u.derived->components == NULL
11944 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11946 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11947 "that has not been declared", c->name, sym->name,
11953 if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE
11954 && (!c->attr.class_ok
11955 || !(CLASS_DATA (c)->attr.class_pointer
11956 || CLASS_DATA (c)->attr.allocatable)))
11958 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11959 "or pointer", c->name, &c->loc);
11963 /* Ensure that all the derived type components are put on the
11964 derived type list; even in formal namespaces, where derived type
11965 pointer components might not have been declared. */
11966 if (c->ts.type == BT_DERIVED
11968 && c->ts.u.derived->components
11970 && sym != c->ts.u.derived)
11971 add_dt_to_dt_list (c->ts.u.derived);
11973 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11974 || c->attr.proc_pointer
11975 || c->attr.allocatable)) == FAILURE)
11979 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11980 all DEFERRED bindings are overridden. */
11981 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11982 && !sym->attr.is_class
11983 && ensure_not_abstract (sym, super_type) == FAILURE)
11986 /* Add derived type to the derived type list. */
11987 add_dt_to_dt_list (sym);
11993 /* The following procedure does the full resolution of a derived type,
11994 including resolution of all type-bound procedures (if present). In contrast
11995 to 'resolve_fl_derived0' this can only be done after the module has been
11996 parsed completely. */
11999 resolve_fl_derived (gfc_symbol *sym)
12001 gfc_symbol *gen_dt = NULL;
12003 if (!sym->attr.is_class)
12004 gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
12005 if (gen_dt && gen_dt->generic && gen_dt->generic->next
12006 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Generic name '%s' of "
12007 "function '%s' at %L being the same name as derived "
12008 "type at %L", sym->name,
12009 gen_dt->generic->sym == sym
12010 ? gen_dt->generic->next->sym->name
12011 : gen_dt->generic->sym->name,
12012 gen_dt->generic->sym == sym
12013 ? &gen_dt->generic->next->sym->declared_at
12014 : &gen_dt->generic->sym->declared_at,
12015 &sym->declared_at) == FAILURE)
12018 if (sym->attr.is_class && sym->ts.u.derived == NULL)
12020 /* Fix up incomplete CLASS symbols. */
12021 gfc_component *data = gfc_find_component (sym, "_data", true, true);
12022 gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
12023 if (vptr->ts.u.derived == NULL)
12025 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
12027 vptr->ts.u.derived = vtab->ts.u.derived;
12031 if (resolve_fl_derived0 (sym) == FAILURE)
12034 /* Resolve the type-bound procedures. */
12035 if (resolve_typebound_procedures (sym) == FAILURE)
12038 /* Resolve the finalizer procedures. */
12039 if (gfc_resolve_finalizers (sym) == FAILURE)
12047 resolve_fl_namelist (gfc_symbol *sym)
12052 for (nl = sym->namelist; nl; nl = nl->next)
12054 /* Check again, the check in match only works if NAMELIST comes
12056 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
12058 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12059 "allowed", nl->sym->name, sym->name, &sym->declared_at);
12063 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
12064 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
12065 "object '%s' with assumed shape in namelist "
12066 "'%s' at %L", nl->sym->name, sym->name,
12067 &sym->declared_at) == FAILURE)
12070 if (is_non_constant_shape_array (nl->sym)
12071 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
12072 "object '%s' with nonconstant shape in namelist "
12073 "'%s' at %L", nl->sym->name, sym->name,
12074 &sym->declared_at) == FAILURE)
12077 if (nl->sym->ts.type == BT_CHARACTER
12078 && (nl->sym->ts.u.cl->length == NULL
12079 || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
12080 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
12081 "'%s' with nonconstant character length in "
12082 "namelist '%s' at %L", nl->sym->name, sym->name,
12083 &sym->declared_at) == FAILURE)
12086 /* FIXME: Once UDDTIO is implemented, the following can be
12088 if (nl->sym->ts.type == BT_CLASS)
12090 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12091 "polymorphic and requires a defined input/output "
12092 "procedure", nl->sym->name, sym->name, &sym->declared_at);
12096 if (nl->sym->ts.type == BT_DERIVED
12097 && (nl->sym->ts.u.derived->attr.alloc_comp
12098 || nl->sym->ts.u.derived->attr.pointer_comp))
12100 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
12101 "'%s' in namelist '%s' at %L with ALLOCATABLE "
12102 "or POINTER components", nl->sym->name,
12103 sym->name, &sym->declared_at) == FAILURE)
12106 /* FIXME: Once UDDTIO is implemented, the following can be
12108 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12109 "ALLOCATABLE or POINTER components and thus requires "
12110 "a defined input/output procedure", nl->sym->name,
12111 sym->name, &sym->declared_at);
12116 /* Reject PRIVATE objects in a PUBLIC namelist. */
12117 if (gfc_check_symbol_access (sym))
12119 for (nl = sym->namelist; nl; nl = nl->next)
12121 if (!nl->sym->attr.use_assoc
12122 && !is_sym_host_assoc (nl->sym, sym->ns)
12123 && !gfc_check_symbol_access (nl->sym))
12125 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12126 "cannot be member of PUBLIC namelist '%s' at %L",
12127 nl->sym->name, sym->name, &sym->declared_at);
12131 /* Types with private components that came here by USE-association. */
12132 if (nl->sym->ts.type == BT_DERIVED
12133 && derived_inaccessible (nl->sym->ts.u.derived))
12135 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12136 "components and cannot be member of namelist '%s' at %L",
12137 nl->sym->name, sym->name, &sym->declared_at);
12141 /* Types with private components that are defined in the same module. */
12142 if (nl->sym->ts.type == BT_DERIVED
12143 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
12144 && nl->sym->ts.u.derived->attr.private_comp)
12146 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12147 "cannot be a member of PUBLIC namelist '%s' at %L",
12148 nl->sym->name, sym->name, &sym->declared_at);
12155 /* 14.1.2 A module or internal procedure represent local entities
12156 of the same type as a namelist member and so are not allowed. */
12157 for (nl = sym->namelist; nl; nl = nl->next)
12159 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
12162 if (nl->sym->attr.function && nl->sym == nl->sym->result)
12163 if ((nl->sym == sym->ns->proc_name)
12165 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
12169 if (nl->sym && nl->sym->name)
12170 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
12171 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
12173 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12174 "attribute in '%s' at %L", nlsym->name,
12175 &sym->declared_at);
12185 resolve_fl_parameter (gfc_symbol *sym)
12187 /* A parameter array's shape needs to be constant. */
12188 if (sym->as != NULL
12189 && (sym->as->type == AS_DEFERRED
12190 || is_non_constant_shape_array (sym)))
12192 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12193 "or of deferred shape", sym->name, &sym->declared_at);
12197 /* Make sure a parameter that has been implicitly typed still
12198 matches the implicit type, since PARAMETER statements can precede
12199 IMPLICIT statements. */
12200 if (sym->attr.implicit_type
12201 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
12204 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12205 "later IMPLICIT type", sym->name, &sym->declared_at);
12209 /* Make sure the types of derived parameters are consistent. This
12210 type checking is deferred until resolution because the type may
12211 refer to a derived type from the host. */
12212 if (sym->ts.type == BT_DERIVED
12213 && !gfc_compare_types (&sym->ts, &sym->value->ts))
12215 gfc_error ("Incompatible derived type in PARAMETER at %L",
12216 &sym->value->where);
12223 /* Do anything necessary to resolve a symbol. Right now, we just
12224 assume that an otherwise unknown symbol is a variable. This sort
12225 of thing commonly happens for symbols in module. */
12228 resolve_symbol (gfc_symbol *sym)
12230 int check_constant, mp_flag;
12231 gfc_symtree *symtree;
12232 gfc_symtree *this_symtree;
12235 symbol_attribute class_attr;
12236 gfc_array_spec *as;
12238 if (sym->attr.flavor == FL_UNKNOWN)
12241 /* If we find that a flavorless symbol is an interface in one of the
12242 parent namespaces, find its symtree in this namespace, free the
12243 symbol and set the symtree to point to the interface symbol. */
12244 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
12246 symtree = gfc_find_symtree (ns->sym_root, sym->name);
12247 if (symtree && (symtree->n.sym->generic ||
12248 (symtree->n.sym->attr.flavor == FL_PROCEDURE
12249 && sym->ns->construct_entities)))
12251 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
12253 gfc_release_symbol (sym);
12254 symtree->n.sym->refs++;
12255 this_symtree->n.sym = symtree->n.sym;
12260 /* Otherwise give it a flavor according to such attributes as
12262 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
12263 sym->attr.flavor = FL_VARIABLE;
12266 sym->attr.flavor = FL_PROCEDURE;
12267 if (sym->attr.dimension)
12268 sym->attr.function = 1;
12272 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
12273 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
12275 if (sym->attr.procedure && sym->ts.interface
12276 && sym->attr.if_source != IFSRC_DECL
12277 && resolve_procedure_interface (sym) == FAILURE)
12280 if (sym->attr.is_protected && !sym->attr.proc_pointer
12281 && (sym->attr.procedure || sym->attr.external))
12283 if (sym->attr.external)
12284 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12285 "at %L", &sym->declared_at);
12287 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12288 "at %L", &sym->declared_at);
12293 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
12296 /* Symbols that are module procedures with results (functions) have
12297 the types and array specification copied for type checking in
12298 procedures that call them, as well as for saving to a module
12299 file. These symbols can't stand the scrutiny that their results
12301 mp_flag = (sym->result != NULL && sym->result != sym);
12303 /* Make sure that the intrinsic is consistent with its internal
12304 representation. This needs to be done before assigning a default
12305 type to avoid spurious warnings. */
12306 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
12307 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
12310 /* Resolve associate names. */
12312 resolve_assoc_var (sym, true);
12314 /* Assign default type to symbols that need one and don't have one. */
12315 if (sym->ts.type == BT_UNKNOWN)
12317 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
12319 gfc_set_default_type (sym, 1, NULL);
12322 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
12323 && !sym->attr.function && !sym->attr.subroutine
12324 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
12325 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
12327 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
12329 /* The specific case of an external procedure should emit an error
12330 in the case that there is no implicit type. */
12332 gfc_set_default_type (sym, sym->attr.external, NULL);
12335 /* Result may be in another namespace. */
12336 resolve_symbol (sym->result);
12338 if (!sym->result->attr.proc_pointer)
12340 sym->ts = sym->result->ts;
12341 sym->as = gfc_copy_array_spec (sym->result->as);
12342 sym->attr.dimension = sym->result->attr.dimension;
12343 sym->attr.pointer = sym->result->attr.pointer;
12344 sym->attr.allocatable = sym->result->attr.allocatable;
12345 sym->attr.contiguous = sym->result->attr.contiguous;
12350 else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
12351 gfc_resolve_array_spec (sym->result->as, false);
12353 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
12355 as = CLASS_DATA (sym)->as;
12356 class_attr = CLASS_DATA (sym)->attr;
12357 class_attr.pointer = class_attr.class_pointer;
12361 class_attr = sym->attr;
12366 if (sym->attr.contiguous
12367 && (!class_attr.dimension
12368 || (as->type != AS_ASSUMED_SHAPE && !class_attr.pointer)))
12370 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12371 "array pointer or an assumed-shape array", sym->name,
12372 &sym->declared_at);
12376 /* Assumed size arrays and assumed shape arrays must be dummy
12377 arguments. Array-spec's of implied-shape should have been resolved to
12378 AS_EXPLICIT already. */
12382 gcc_assert (as->type != AS_IMPLIED_SHAPE);
12383 if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
12384 || as->type == AS_ASSUMED_SHAPE)
12385 && sym->attr.dummy == 0)
12387 if (as->type == AS_ASSUMED_SIZE)
12388 gfc_error ("Assumed size array at %L must be a dummy argument",
12389 &sym->declared_at);
12391 gfc_error ("Assumed shape array at %L must be a dummy argument",
12392 &sym->declared_at);
12397 /* Make sure symbols with known intent or optional are really dummy
12398 variable. Because of ENTRY statement, this has to be deferred
12399 until resolution time. */
12401 if (!sym->attr.dummy
12402 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
12404 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
12408 if (sym->attr.value && !sym->attr.dummy)
12410 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12411 "it is not a dummy argument", sym->name, &sym->declared_at);
12415 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
12417 gfc_charlen *cl = sym->ts.u.cl;
12418 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
12420 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12421 "attribute must have constant length",
12422 sym->name, &sym->declared_at);
12426 if (sym->ts.is_c_interop
12427 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
12429 gfc_error ("C interoperable character dummy variable '%s' at %L "
12430 "with VALUE attribute must have length one",
12431 sym->name, &sym->declared_at);
12436 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
12437 && sym->ts.u.derived->attr.generic)
12439 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
12440 if (!sym->ts.u.derived)
12442 gfc_error ("The derived type '%s' at %L is of type '%s', "
12443 "which has not been defined", sym->name,
12444 &sym->declared_at, sym->ts.u.derived->name);
12445 sym->ts.type = BT_UNKNOWN;
12450 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12451 do this for something that was implicitly typed because that is handled
12452 in gfc_set_default_type. Handle dummy arguments and procedure
12453 definitions separately. Also, anything that is use associated is not
12454 handled here but instead is handled in the module it is declared in.
12455 Finally, derived type definitions are allowed to be BIND(C) since that
12456 only implies that they're interoperable, and they are checked fully for
12457 interoperability when a variable is declared of that type. */
12458 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
12459 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
12460 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
12462 gfc_try t = SUCCESS;
12464 /* First, make sure the variable is declared at the
12465 module-level scope (J3/04-007, Section 15.3). */
12466 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
12467 sym->attr.in_common == 0)
12469 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12470 "is neither a COMMON block nor declared at the "
12471 "module level scope", sym->name, &(sym->declared_at));
12474 else if (sym->common_head != NULL)
12476 t = verify_com_block_vars_c_interop (sym->common_head);
12480 /* If type() declaration, we need to verify that the components
12481 of the given type are all C interoperable, etc. */
12482 if (sym->ts.type == BT_DERIVED &&
12483 sym->ts.u.derived->attr.is_c_interop != 1)
12485 /* Make sure the user marked the derived type as BIND(C). If
12486 not, call the verify routine. This could print an error
12487 for the derived type more than once if multiple variables
12488 of that type are declared. */
12489 if (sym->ts.u.derived->attr.is_bind_c != 1)
12490 verify_bind_c_derived_type (sym->ts.u.derived);
12494 /* Verify the variable itself as C interoperable if it
12495 is BIND(C). It is not possible for this to succeed if
12496 the verify_bind_c_derived_type failed, so don't have to handle
12497 any error returned by verify_bind_c_derived_type. */
12498 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
12499 sym->common_block);
12504 /* clear the is_bind_c flag to prevent reporting errors more than
12505 once if something failed. */
12506 sym->attr.is_bind_c = 0;
12511 /* If a derived type symbol has reached this point, without its
12512 type being declared, we have an error. Notice that most
12513 conditions that produce undefined derived types have already
12514 been dealt with. However, the likes of:
12515 implicit type(t) (t) ..... call foo (t) will get us here if
12516 the type is not declared in the scope of the implicit
12517 statement. Change the type to BT_UNKNOWN, both because it is so
12518 and to prevent an ICE. */
12519 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
12520 && sym->ts.u.derived->components == NULL
12521 && !sym->ts.u.derived->attr.zero_comp)
12523 gfc_error ("The derived type '%s' at %L is of type '%s', "
12524 "which has not been defined", sym->name,
12525 &sym->declared_at, sym->ts.u.derived->name);
12526 sym->ts.type = BT_UNKNOWN;
12530 /* Make sure that the derived type has been resolved and that the
12531 derived type is visible in the symbol's namespace, if it is a
12532 module function and is not PRIVATE. */
12533 if (sym->ts.type == BT_DERIVED
12534 && sym->ts.u.derived->attr.use_assoc
12535 && sym->ns->proc_name
12536 && sym->ns->proc_name->attr.flavor == FL_MODULE
12537 && resolve_fl_derived (sym->ts.u.derived) == FAILURE)
12540 /* Unless the derived-type declaration is use associated, Fortran 95
12541 does not allow public entries of private derived types.
12542 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12543 161 in 95-006r3. */
12544 if (sym->ts.type == BT_DERIVED
12545 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12546 && !sym->ts.u.derived->attr.use_assoc
12547 && gfc_check_symbol_access (sym)
12548 && !gfc_check_symbol_access (sym->ts.u.derived)
12549 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12550 "of PRIVATE derived type '%s'",
12551 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12552 : "variable", sym->name, &sym->declared_at,
12553 sym->ts.u.derived->name) == FAILURE)
12556 /* F2008, C1302. */
12557 if (sym->ts.type == BT_DERIVED
12558 && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
12559 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
12560 || sym->ts.u.derived->attr.lock_comp)
12561 && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
12563 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
12564 "type LOCK_TYPE must be a coarray", sym->name,
12565 &sym->declared_at);
12569 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12570 default initialization is defined (5.1.2.4.4). */
12571 if (sym->ts.type == BT_DERIVED
12573 && sym->attr.intent == INTENT_OUT
12575 && sym->as->type == AS_ASSUMED_SIZE)
12577 for (c = sym->ts.u.derived->components; c; c = c->next)
12579 if (c->initializer)
12581 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12582 "ASSUMED SIZE and so cannot have a default initializer",
12583 sym->name, &sym->declared_at);
12590 if (sym->ts.type == BT_DERIVED && sym->attr.dummy
12591 && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
12593 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
12594 "INTENT(OUT)", sym->name, &sym->declared_at);
12599 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12600 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12601 && CLASS_DATA (sym)->attr.coarray_comp))
12602 || class_attr.codimension)
12603 && (sym->attr.result || sym->result == sym))
12605 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12606 "a coarray component", sym->name, &sym->declared_at);
12611 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12612 && sym->ts.u.derived->ts.is_iso_c)
12614 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12615 "shall not be a coarray", sym->name, &sym->declared_at);
12620 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12621 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12622 && CLASS_DATA (sym)->attr.coarray_comp))
12623 && (class_attr.codimension || class_attr.pointer || class_attr.dimension
12624 || class_attr.allocatable))
12626 gfc_error ("Variable '%s' at %L with coarray component "
12627 "shall be a nonpointer, nonallocatable scalar",
12628 sym->name, &sym->declared_at);
12632 /* F2008, C526. The function-result case was handled above. */
12633 if (class_attr.codimension
12634 && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
12635 || sym->attr.select_type_temporary
12636 || sym->ns->save_all
12637 || sym->ns->proc_name->attr.flavor == FL_MODULE
12638 || sym->ns->proc_name->attr.is_main_program
12639 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12641 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
12642 "nor a dummy argument", sym->name, &sym->declared_at);
12646 else if (class_attr.codimension && !sym->attr.select_type_temporary
12647 && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
12649 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12650 "deferred shape", sym->name, &sym->declared_at);
12653 else if (class_attr.codimension && class_attr.allocatable && as
12654 && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
12656 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12657 "deferred shape", sym->name, &sym->declared_at);
12662 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12663 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12664 && CLASS_DATA (sym)->attr.coarray_comp))
12665 || (class_attr.codimension && class_attr.allocatable))
12666 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12668 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12669 "allocatable coarray or have coarray components",
12670 sym->name, &sym->declared_at);
12674 if (class_attr.codimension && sym->attr.dummy
12675 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12677 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12678 "procedure '%s'", sym->name, &sym->declared_at,
12679 sym->ns->proc_name->name);
12683 switch (sym->attr.flavor)
12686 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12691 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12696 if (resolve_fl_namelist (sym) == FAILURE)
12701 if (resolve_fl_parameter (sym) == FAILURE)
12709 /* Resolve array specifier. Check as well some constraints
12710 on COMMON blocks. */
12712 check_constant = sym->attr.in_common && !sym->attr.pointer;
12714 /* Set the formal_arg_flag so that check_conflict will not throw
12715 an error for host associated variables in the specification
12716 expression for an array_valued function. */
12717 if (sym->attr.function && sym->as)
12718 formal_arg_flag = 1;
12720 gfc_resolve_array_spec (sym->as, check_constant);
12722 formal_arg_flag = 0;
12724 /* Resolve formal namespaces. */
12725 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12726 && !sym->attr.contained && !sym->attr.intrinsic)
12727 gfc_resolve (sym->formal_ns);
12729 /* Make sure the formal namespace is present. */
12730 if (sym->formal && !sym->formal_ns)
12732 gfc_formal_arglist *formal = sym->formal;
12733 while (formal && !formal->sym)
12734 formal = formal->next;
12738 sym->formal_ns = formal->sym->ns;
12739 sym->formal_ns->refs++;
12743 /* Check threadprivate restrictions. */
12744 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12745 && (!sym->attr.in_common
12746 && sym->module == NULL
12747 && (sym->ns->proc_name == NULL
12748 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12749 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12751 /* If we have come this far we can apply default-initializers, as
12752 described in 14.7.5, to those variables that have not already
12753 been assigned one. */
12754 if (sym->ts.type == BT_DERIVED
12755 && sym->ns == gfc_current_ns
12757 && !sym->attr.allocatable
12758 && !sym->attr.alloc_comp)
12760 symbol_attribute *a = &sym->attr;
12762 if ((!a->save && !a->dummy && !a->pointer
12763 && !a->in_common && !a->use_assoc
12764 && (a->referenced || a->result)
12765 && !(a->function && sym != sym->result))
12766 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12767 apply_default_init (sym);
12770 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
12771 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
12772 && !CLASS_DATA (sym)->attr.class_pointer
12773 && !CLASS_DATA (sym)->attr.allocatable)
12774 apply_default_init (sym);
12776 /* If this symbol has a type-spec, check it. */
12777 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12778 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12779 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12785 /************* Resolve DATA statements *************/
12789 gfc_data_value *vnode;
12795 /* Advance the values structure to point to the next value in the data list. */
12798 next_data_value (void)
12800 while (mpz_cmp_ui (values.left, 0) == 0)
12803 if (values.vnode->next == NULL)
12806 values.vnode = values.vnode->next;
12807 mpz_set (values.left, values.vnode->repeat);
12815 check_data_variable (gfc_data_variable *var, locus *where)
12821 ar_type mark = AR_UNKNOWN;
12823 mpz_t section_index[GFC_MAX_DIMENSIONS];
12829 if (gfc_resolve_expr (var->expr) == FAILURE)
12833 mpz_init_set_si (offset, 0);
12836 if (e->expr_type != EXPR_VARIABLE)
12837 gfc_internal_error ("check_data_variable(): Bad expression");
12839 sym = e->symtree->n.sym;
12841 if (sym->ns->is_block_data && !sym->attr.in_common)
12843 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12844 sym->name, &sym->declared_at);
12847 if (e->ref == NULL && sym->as)
12849 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12850 " declaration", sym->name, where);
12854 has_pointer = sym->attr.pointer;
12856 if (gfc_is_coindexed (e))
12858 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name,
12863 for (ref = e->ref; ref; ref = ref->next)
12865 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12869 && ref->type == REF_ARRAY
12870 && ref->u.ar.type != AR_FULL)
12872 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12873 "be a full array", sym->name, where);
12878 if (e->rank == 0 || has_pointer)
12880 mpz_init_set_ui (size, 1);
12887 /* Find the array section reference. */
12888 for (ref = e->ref; ref; ref = ref->next)
12890 if (ref->type != REF_ARRAY)
12892 if (ref->u.ar.type == AR_ELEMENT)
12898 /* Set marks according to the reference pattern. */
12899 switch (ref->u.ar.type)
12907 /* Get the start position of array section. */
12908 gfc_get_section_index (ar, section_index, &offset);
12913 gcc_unreachable ();
12916 if (gfc_array_size (e, &size) == FAILURE)
12918 gfc_error ("Nonconstant array section at %L in DATA statement",
12920 mpz_clear (offset);
12927 while (mpz_cmp_ui (size, 0) > 0)
12929 if (next_data_value () == FAILURE)
12931 gfc_error ("DATA statement at %L has more variables than values",
12937 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12941 /* If we have more than one element left in the repeat count,
12942 and we have more than one element left in the target variable,
12943 then create a range assignment. */
12944 /* FIXME: Only done for full arrays for now, since array sections
12946 if (mark == AR_FULL && ref && ref->next == NULL
12947 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12951 if (mpz_cmp (size, values.left) >= 0)
12953 mpz_init_set (range, values.left);
12954 mpz_sub (size, size, values.left);
12955 mpz_set_ui (values.left, 0);
12959 mpz_init_set (range, size);
12960 mpz_sub (values.left, values.left, size);
12961 mpz_set_ui (size, 0);
12964 t = gfc_assign_data_value (var->expr, values.vnode->expr,
12967 mpz_add (offset, offset, range);
12974 /* Assign initial value to symbol. */
12977 mpz_sub_ui (values.left, values.left, 1);
12978 mpz_sub_ui (size, size, 1);
12980 t = gfc_assign_data_value (var->expr, values.vnode->expr,
12985 if (mark == AR_FULL)
12986 mpz_add_ui (offset, offset, 1);
12988 /* Modify the array section indexes and recalculate the offset
12989 for next element. */
12990 else if (mark == AR_SECTION)
12991 gfc_advance_section (section_index, ar, &offset);
12995 if (mark == AR_SECTION)
12997 for (i = 0; i < ar->dimen; i++)
12998 mpz_clear (section_index[i]);
13002 mpz_clear (offset);
13008 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
13010 /* Iterate over a list of elements in a DATA statement. */
13013 traverse_data_list (gfc_data_variable *var, locus *where)
13016 iterator_stack frame;
13017 gfc_expr *e, *start, *end, *step;
13018 gfc_try retval = SUCCESS;
13020 mpz_init (frame.value);
13023 start = gfc_copy_expr (var->iter.start);
13024 end = gfc_copy_expr (var->iter.end);
13025 step = gfc_copy_expr (var->iter.step);
13027 if (gfc_simplify_expr (start, 1) == FAILURE
13028 || start->expr_type != EXPR_CONSTANT)
13030 gfc_error ("start of implied-do loop at %L could not be "
13031 "simplified to a constant value", &start->where);
13035 if (gfc_simplify_expr (end, 1) == FAILURE
13036 || end->expr_type != EXPR_CONSTANT)
13038 gfc_error ("end of implied-do loop at %L could not be "
13039 "simplified to a constant value", &start->where);
13043 if (gfc_simplify_expr (step, 1) == FAILURE
13044 || step->expr_type != EXPR_CONSTANT)
13046 gfc_error ("step of implied-do loop at %L could not be "
13047 "simplified to a constant value", &start->where);
13052 mpz_set (trip, end->value.integer);
13053 mpz_sub (trip, trip, start->value.integer);
13054 mpz_add (trip, trip, step->value.integer);
13056 mpz_div (trip, trip, step->value.integer);
13058 mpz_set (frame.value, start->value.integer);
13060 frame.prev = iter_stack;
13061 frame.variable = var->iter.var->symtree;
13062 iter_stack = &frame;
13064 while (mpz_cmp_ui (trip, 0) > 0)
13066 if (traverse_data_var (var->list, where) == FAILURE)
13072 e = gfc_copy_expr (var->expr);
13073 if (gfc_simplify_expr (e, 1) == FAILURE)
13080 mpz_add (frame.value, frame.value, step->value.integer);
13082 mpz_sub_ui (trip, trip, 1);
13086 mpz_clear (frame.value);
13089 gfc_free_expr (start);
13090 gfc_free_expr (end);
13091 gfc_free_expr (step);
13093 iter_stack = frame.prev;
13098 /* Type resolve variables in the variable list of a DATA statement. */
13101 traverse_data_var (gfc_data_variable *var, locus *where)
13105 for (; var; var = var->next)
13107 if (var->expr == NULL)
13108 t = traverse_data_list (var, where);
13110 t = check_data_variable (var, where);
13120 /* Resolve the expressions and iterators associated with a data statement.
13121 This is separate from the assignment checking because data lists should
13122 only be resolved once. */
13125 resolve_data_variables (gfc_data_variable *d)
13127 for (; d; d = d->next)
13129 if (d->list == NULL)
13131 if (gfc_resolve_expr (d->expr) == FAILURE)
13136 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
13139 if (resolve_data_variables (d->list) == FAILURE)
13148 /* Resolve a single DATA statement. We implement this by storing a pointer to
13149 the value list into static variables, and then recursively traversing the
13150 variables list, expanding iterators and such. */
13153 resolve_data (gfc_data *d)
13156 if (resolve_data_variables (d->var) == FAILURE)
13159 values.vnode = d->value;
13160 if (d->value == NULL)
13161 mpz_set_ui (values.left, 0);
13163 mpz_set (values.left, d->value->repeat);
13165 if (traverse_data_var (d->var, &d->where) == FAILURE)
13168 /* At this point, we better not have any values left. */
13170 if (next_data_value () == SUCCESS)
13171 gfc_error ("DATA statement at %L has more values than variables",
13176 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13177 accessed by host or use association, is a dummy argument to a pure function,
13178 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13179 is storage associated with any such variable, shall not be used in the
13180 following contexts: (clients of this function). */
13182 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13183 procedure. Returns zero if assignment is OK, nonzero if there is a
13186 gfc_impure_variable (gfc_symbol *sym)
13191 if (sym->attr.use_assoc || sym->attr.in_common)
13194 /* Check if the symbol's ns is inside the pure procedure. */
13195 for (ns = gfc_current_ns; ns; ns = ns->parent)
13199 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
13203 proc = sym->ns->proc_name;
13204 if (sym->attr.dummy && gfc_pure (proc)
13205 && ((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);