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)
379 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
380 "procedure", sym->name, &sym->declared_at);
386 gfc_error ("Argument '%s' of elemental procedure at %L must "
387 "be scalar", sym->name, &sym->declared_at);
391 if (sym->attr.allocatable)
393 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
394 "have the ALLOCATABLE attribute", sym->name,
399 if (sym->attr.pointer)
401 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
402 "have the POINTER attribute", sym->name,
407 if (sym->attr.flavor == FL_PROCEDURE)
409 gfc_error ("Dummy procedure '%s' not allowed in elemental "
410 "procedure '%s' at %L", sym->name, proc->name,
415 if (sym->attr.intent == INTENT_UNKNOWN)
417 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
418 "have its INTENT specified", sym->name, proc->name,
424 /* Each dummy shall be specified to be scalar. */
425 if (proc->attr.proc == PROC_ST_FUNCTION)
429 gfc_error ("Argument '%s' of statement function at %L must "
430 "be scalar", sym->name, &sym->declared_at);
434 if (sym->ts.type == BT_CHARACTER)
436 gfc_charlen *cl = sym->ts.u.cl;
437 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
439 gfc_error ("Character-valued argument '%s' of statement "
440 "function at %L must have constant length",
441 sym->name, &sym->declared_at);
451 /* Work function called when searching for symbols that have argument lists
452 associated with them. */
455 find_arglists (gfc_symbol *sym)
457 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
458 || sym->attr.flavor == FL_DERIVED)
461 resolve_formal_arglist (sym);
465 /* Given a namespace, resolve all formal argument lists within the namespace.
469 resolve_formal_arglists (gfc_namespace *ns)
474 gfc_traverse_ns (ns, find_arglists);
479 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
483 /* If this namespace is not a function or an entry master function,
485 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
486 || sym->attr.entry_master)
489 /* Try to find out of what the return type is. */
490 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
492 t = gfc_set_default_type (sym->result, 0, ns);
494 if (t == FAILURE && !sym->result->attr.untyped)
496 if (sym->result == sym)
497 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
498 sym->name, &sym->declared_at);
499 else if (!sym->result->attr.proc_pointer)
500 gfc_error ("Result '%s' of contained function '%s' at %L has "
501 "no IMPLICIT type", sym->result->name, sym->name,
502 &sym->result->declared_at);
503 sym->result->attr.untyped = 1;
507 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
508 type, lists the only ways a character length value of * can be used:
509 dummy arguments of procedures, named constants, and function results
510 in external functions. Internal function results and results of module
511 procedures are not on this list, ergo, not permitted. */
513 if (sym->result->ts.type == BT_CHARACTER)
515 gfc_charlen *cl = sym->result->ts.u.cl;
516 if ((!cl || !cl->length) && !sym->result->ts.deferred)
518 /* See if this is a module-procedure and adapt error message
521 gcc_assert (ns->parent && ns->parent->proc_name);
522 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
524 gfc_error ("Character-valued %s '%s' at %L must not be"
526 module_proc ? _("module procedure")
527 : _("internal function"),
528 sym->name, &sym->declared_at);
534 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
535 introduce duplicates. */
538 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
540 gfc_formal_arglist *f, *new_arglist;
543 for (; new_args != NULL; new_args = new_args->next)
545 new_sym = new_args->sym;
546 /* See if this arg is already in the formal argument list. */
547 for (f = proc->formal; f; f = f->next)
549 if (new_sym == f->sym)
556 /* Add a new argument. Argument order is not important. */
557 new_arglist = gfc_get_formal_arglist ();
558 new_arglist->sym = new_sym;
559 new_arglist->next = proc->formal;
560 proc->formal = new_arglist;
565 /* Flag the arguments that are not present in all entries. */
568 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
570 gfc_formal_arglist *f, *head;
573 for (f = proc->formal; f; f = f->next)
578 for (new_args = head; new_args; new_args = new_args->next)
580 if (new_args->sym == f->sym)
587 f->sym->attr.not_always_present = 1;
592 /* Resolve alternate entry points. If a symbol has multiple entry points we
593 create a new master symbol for the main routine, and turn the existing
594 symbol into an entry point. */
597 resolve_entries (gfc_namespace *ns)
599 gfc_namespace *old_ns;
603 char name[GFC_MAX_SYMBOL_LEN + 1];
604 static int master_count = 0;
606 if (ns->proc_name == NULL)
609 /* No need to do anything if this procedure doesn't have alternate entry
614 /* We may already have resolved alternate entry points. */
615 if (ns->proc_name->attr.entry_master)
618 /* If this isn't a procedure something has gone horribly wrong. */
619 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
621 /* Remember the current namespace. */
622 old_ns = gfc_current_ns;
626 /* Add the main entry point to the list of entry points. */
627 el = gfc_get_entry_list ();
628 el->sym = ns->proc_name;
630 el->next = ns->entries;
632 ns->proc_name->attr.entry = 1;
634 /* If it is a module function, it needs to be in the right namespace
635 so that gfc_get_fake_result_decl can gather up the results. The
636 need for this arose in get_proc_name, where these beasts were
637 left in their own namespace, to keep prior references linked to
638 the entry declaration.*/
639 if (ns->proc_name->attr.function
640 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
643 /* Do the same for entries where the master is not a module
644 procedure. These are retained in the module namespace because
645 of the module procedure declaration. */
646 for (el = el->next; el; el = el->next)
647 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
648 && el->sym->attr.mod_proc)
652 /* Add an entry statement for it. */
659 /* Create a new symbol for the master function. */
660 /* Give the internal function a unique name (within this file).
661 Also include the function name so the user has some hope of figuring
662 out what is going on. */
663 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
664 master_count++, ns->proc_name->name);
665 gfc_get_ha_symbol (name, &proc);
666 gcc_assert (proc != NULL);
668 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
669 if (ns->proc_name->attr.subroutine)
670 gfc_add_subroutine (&proc->attr, proc->name, NULL);
674 gfc_typespec *ts, *fts;
675 gfc_array_spec *as, *fas;
676 gfc_add_function (&proc->attr, proc->name, NULL);
678 fas = ns->entries->sym->as;
679 fas = fas ? fas : ns->entries->sym->result->as;
680 fts = &ns->entries->sym->result->ts;
681 if (fts->type == BT_UNKNOWN)
682 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
683 for (el = ns->entries->next; el; el = el->next)
685 ts = &el->sym->result->ts;
687 as = as ? as : el->sym->result->as;
688 if (ts->type == BT_UNKNOWN)
689 ts = gfc_get_default_type (el->sym->result->name, NULL);
691 if (! gfc_compare_types (ts, fts)
692 || (el->sym->result->attr.dimension
693 != ns->entries->sym->result->attr.dimension)
694 || (el->sym->result->attr.pointer
695 != ns->entries->sym->result->attr.pointer))
697 else if (as && fas && ns->entries->sym->result != el->sym->result
698 && gfc_compare_array_spec (as, fas) == 0)
699 gfc_error ("Function %s at %L has entries with mismatched "
700 "array specifications", ns->entries->sym->name,
701 &ns->entries->sym->declared_at);
702 /* The characteristics need to match and thus both need to have
703 the same string length, i.e. both len=*, or both len=4.
704 Having both len=<variable> is also possible, but difficult to
705 check at compile time. */
706 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
707 && (((ts->u.cl->length && !fts->u.cl->length)
708 ||(!ts->u.cl->length && fts->u.cl->length))
710 && ts->u.cl->length->expr_type
711 != fts->u.cl->length->expr_type)
713 && ts->u.cl->length->expr_type == EXPR_CONSTANT
714 && mpz_cmp (ts->u.cl->length->value.integer,
715 fts->u.cl->length->value.integer) != 0)))
716 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
717 "entries returning variables of different "
718 "string lengths", ns->entries->sym->name,
719 &ns->entries->sym->declared_at);
724 sym = ns->entries->sym->result;
725 /* All result types the same. */
727 if (sym->attr.dimension)
728 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
729 if (sym->attr.pointer)
730 gfc_add_pointer (&proc->attr, NULL);
734 /* Otherwise the result will be passed through a union by
736 proc->attr.mixed_entry_master = 1;
737 for (el = ns->entries; el; el = el->next)
739 sym = el->sym->result;
740 if (sym->attr.dimension)
742 if (el == ns->entries)
743 gfc_error ("FUNCTION result %s can't be an array in "
744 "FUNCTION %s at %L", sym->name,
745 ns->entries->sym->name, &sym->declared_at);
747 gfc_error ("ENTRY result %s can't be an array in "
748 "FUNCTION %s at %L", sym->name,
749 ns->entries->sym->name, &sym->declared_at);
751 else if (sym->attr.pointer)
753 if (el == ns->entries)
754 gfc_error ("FUNCTION result %s can't be a POINTER in "
755 "FUNCTION %s at %L", sym->name,
756 ns->entries->sym->name, &sym->declared_at);
758 gfc_error ("ENTRY result %s can't be a POINTER in "
759 "FUNCTION %s at %L", sym->name,
760 ns->entries->sym->name, &sym->declared_at);
765 if (ts->type == BT_UNKNOWN)
766 ts = gfc_get_default_type (sym->name, NULL);
770 if (ts->kind == gfc_default_integer_kind)
774 if (ts->kind == gfc_default_real_kind
775 || ts->kind == gfc_default_double_kind)
779 if (ts->kind == gfc_default_complex_kind)
783 if (ts->kind == gfc_default_logical_kind)
787 /* We will issue error elsewhere. */
795 if (el == ns->entries)
796 gfc_error ("FUNCTION result %s can't be of type %s "
797 "in FUNCTION %s at %L", sym->name,
798 gfc_typename (ts), ns->entries->sym->name,
801 gfc_error ("ENTRY result %s can't be of type %s "
802 "in FUNCTION %s at %L", sym->name,
803 gfc_typename (ts), ns->entries->sym->name,
810 proc->attr.access = ACCESS_PRIVATE;
811 proc->attr.entry_master = 1;
813 /* Merge all the entry point arguments. */
814 for (el = ns->entries; el; el = el->next)
815 merge_argument_lists (proc, el->sym->formal);
817 /* Check the master formal arguments for any that are not
818 present in all entry points. */
819 for (el = ns->entries; el; el = el->next)
820 check_argument_lists (proc, el->sym->formal);
822 /* Use the master function for the function body. */
823 ns->proc_name = proc;
825 /* Finalize the new symbols. */
826 gfc_commit_symbols ();
828 /* Restore the original namespace. */
829 gfc_current_ns = old_ns;
833 /* Resolve common variables. */
835 resolve_common_vars (gfc_symbol *sym, bool named_common)
837 gfc_symbol *csym = sym;
839 for (; csym; csym = csym->common_next)
841 if (csym->value || csym->attr.data)
843 if (!csym->ns->is_block_data)
844 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
845 "but only in BLOCK DATA initialization is "
846 "allowed", csym->name, &csym->declared_at);
847 else if (!named_common)
848 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
849 "in a blank COMMON but initialization is only "
850 "allowed in named common blocks", csym->name,
854 if (csym->ts.type != BT_DERIVED)
857 if (!(csym->ts.u.derived->attr.sequence
858 || csym->ts.u.derived->attr.is_bind_c))
859 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
860 "has neither the SEQUENCE nor the BIND(C) "
861 "attribute", csym->name, &csym->declared_at);
862 if (csym->ts.u.derived->attr.alloc_comp)
863 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
864 "has an ultimate component that is "
865 "allocatable", csym->name, &csym->declared_at);
866 if (gfc_has_default_initializer (csym->ts.u.derived))
867 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
868 "may not have default initializer", csym->name,
871 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
872 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
876 /* Resolve common blocks. */
878 resolve_common_blocks (gfc_symtree *common_root)
882 if (common_root == NULL)
885 if (common_root->left)
886 resolve_common_blocks (common_root->left);
887 if (common_root->right)
888 resolve_common_blocks (common_root->right);
890 resolve_common_vars (common_root->n.common->head, true);
892 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
896 if (sym->attr.flavor == FL_PARAMETER)
897 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
898 sym->name, &common_root->n.common->where, &sym->declared_at);
900 if (sym->attr.external)
901 gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
902 sym->name, &common_root->n.common->where);
904 if (sym->attr.intrinsic)
905 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
906 sym->name, &common_root->n.common->where);
907 else if (sym->attr.result
908 || gfc_is_function_return_value (sym, gfc_current_ns))
909 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
910 "that is also a function result", sym->name,
911 &common_root->n.common->where);
912 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
913 && sym->attr.proc != PROC_ST_FUNCTION)
914 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
915 "that is also a global procedure", sym->name,
916 &common_root->n.common->where);
920 /* Resolve contained function types. Because contained functions can call one
921 another, they have to be worked out before any of the contained procedures
924 The good news is that if a function doesn't already have a type, the only
925 way it can get one is through an IMPLICIT type or a RESULT variable, because
926 by definition contained functions are contained namespace they're contained
927 in, not in a sibling or parent namespace. */
930 resolve_contained_functions (gfc_namespace *ns)
932 gfc_namespace *child;
935 resolve_formal_arglists (ns);
937 for (child = ns->contained; child; child = child->sibling)
939 /* Resolve alternate entry points first. */
940 resolve_entries (child);
942 /* Then check function return types. */
943 resolve_contained_fntype (child->proc_name, child);
944 for (el = child->entries; el; el = el->next)
945 resolve_contained_fntype (el->sym, child);
950 static gfc_try resolve_fl_derived0 (gfc_symbol *sym);
953 /* Resolve all of the elements of a structure constructor and make sure that
954 the types are correct. The 'init' flag indicates that the given
955 constructor is an initializer. */
958 resolve_structure_cons (gfc_expr *expr, int init)
960 gfc_constructor *cons;
967 if (expr->ts.type == BT_DERIVED)
968 resolve_fl_derived0 (expr->ts.u.derived);
970 cons = gfc_constructor_first (expr->value.constructor);
972 /* See if the user is trying to invoke a structure constructor for one of
973 the iso_c_binding derived types. */
974 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
975 && expr->ts.u.derived->ts.is_iso_c && cons
976 && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
978 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
979 expr->ts.u.derived->name, &(expr->where));
983 /* Return if structure constructor is c_null_(fun)prt. */
984 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
985 && expr->ts.u.derived->ts.is_iso_c && cons
986 && cons->expr && cons->expr->expr_type == EXPR_NULL)
989 /* A constructor may have references if it is the result of substituting a
990 parameter variable. In this case we just pull out the component we
993 comp = expr->ref->u.c.sym->components;
995 comp = expr->ts.u.derived->components;
997 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1004 if (gfc_resolve_expr (cons->expr) == FAILURE)
1010 rank = comp->as ? comp->as->rank : 0;
1011 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
1012 && (comp->attr.allocatable || cons->expr->rank))
1014 gfc_error ("The rank of the element in the structure "
1015 "constructor at %L does not match that of the "
1016 "component (%d/%d)", &cons->expr->where,
1017 cons->expr->rank, rank);
1021 /* If we don't have the right type, try to convert it. */
1023 if (!comp->attr.proc_pointer &&
1024 !gfc_compare_types (&cons->expr->ts, &comp->ts))
1027 if (strcmp (comp->name, "_extends") == 0)
1029 /* Can afford to be brutal with the _extends initializer.
1030 The derived type can get lost because it is PRIVATE
1031 but it is not usage constrained by the standard. */
1032 cons->expr->ts = comp->ts;
1035 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1036 gfc_error ("The element in the structure constructor at %L, "
1037 "for pointer component '%s', is %s but should be %s",
1038 &cons->expr->where, comp->name,
1039 gfc_basic_typename (cons->expr->ts.type),
1040 gfc_basic_typename (comp->ts.type));
1042 t = gfc_convert_type (cons->expr, &comp->ts, 1);
1045 /* For strings, the length of the constructor should be the same as
1046 the one of the structure, ensure this if the lengths are known at
1047 compile time and when we are dealing with PARAMETER or structure
1049 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1050 && comp->ts.u.cl->length
1051 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1052 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1053 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1054 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1055 comp->ts.u.cl->length->value.integer) != 0)
1057 if (cons->expr->expr_type == EXPR_VARIABLE
1058 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1060 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1061 to make use of the gfc_resolve_character_array_constructor
1062 machinery. The expression is later simplified away to
1063 an array of string literals. */
1064 gfc_expr *para = cons->expr;
1065 cons->expr = gfc_get_expr ();
1066 cons->expr->ts = para->ts;
1067 cons->expr->where = para->where;
1068 cons->expr->expr_type = EXPR_ARRAY;
1069 cons->expr->rank = para->rank;
1070 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1071 gfc_constructor_append_expr (&cons->expr->value.constructor,
1072 para, &cons->expr->where);
1074 if (cons->expr->expr_type == EXPR_ARRAY)
1077 p = gfc_constructor_first (cons->expr->value.constructor);
1078 if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
1080 gfc_charlen *cl, *cl2;
1083 for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
1085 if (cl == cons->expr->ts.u.cl)
1093 cl2->next = cl->next;
1095 gfc_free_expr (cl->length);
1099 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1100 cons->expr->ts.u.cl->length_from_typespec = true;
1101 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1102 gfc_resolve_character_array_constructor (cons->expr);
1106 if (cons->expr->expr_type == EXPR_NULL
1107 && !(comp->attr.pointer || comp->attr.allocatable
1108 || comp->attr.proc_pointer
1109 || (comp->ts.type == BT_CLASS
1110 && (CLASS_DATA (comp)->attr.class_pointer
1111 || CLASS_DATA (comp)->attr.allocatable))))
1114 gfc_error ("The NULL in the structure constructor at %L is "
1115 "being applied to component '%s', which is neither "
1116 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1120 if (comp->attr.proc_pointer && comp->ts.interface)
1122 /* Check procedure pointer interface. */
1123 gfc_symbol *s2 = NULL;
1128 if (gfc_is_proc_ptr_comp (cons->expr, &c2))
1130 s2 = c2->ts.interface;
1133 else if (cons->expr->expr_type == EXPR_FUNCTION)
1135 s2 = cons->expr->symtree->n.sym->result;
1136 name = cons->expr->symtree->n.sym->result->name;
1138 else if (cons->expr->expr_type != EXPR_NULL)
1140 s2 = cons->expr->symtree->n.sym;
1141 name = cons->expr->symtree->n.sym->name;
1144 if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
1147 gfc_error ("Interface mismatch for procedure-pointer component "
1148 "'%s' in structure constructor at %L: %s",
1149 comp->name, &cons->expr->where, err);
1154 if (!comp->attr.pointer || comp->attr.proc_pointer
1155 || cons->expr->expr_type == EXPR_NULL)
1158 a = gfc_expr_attr (cons->expr);
1160 if (!a.pointer && !a.target)
1163 gfc_error ("The element in the structure constructor at %L, "
1164 "for pointer component '%s' should be a POINTER or "
1165 "a TARGET", &cons->expr->where, comp->name);
1170 /* F08:C461. Additional checks for pointer initialization. */
1174 gfc_error ("Pointer initialization target at %L "
1175 "must not be ALLOCATABLE ", &cons->expr->where);
1180 gfc_error ("Pointer initialization target at %L "
1181 "must have the SAVE attribute", &cons->expr->where);
1185 /* F2003, C1272 (3). */
1186 if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
1187 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1188 || gfc_is_coindexed (cons->expr)))
1191 gfc_error ("Invalid expression in the structure constructor for "
1192 "pointer component '%s' at %L in PURE procedure",
1193 comp->name, &cons->expr->where);
1196 if (gfc_implicit_pure (NULL)
1197 && cons->expr->expr_type == EXPR_VARIABLE
1198 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1199 || gfc_is_coindexed (cons->expr)))
1200 gfc_current_ns->proc_name->attr.implicit_pure = 0;
1208 /****************** Expression name resolution ******************/
1210 /* Returns 0 if a symbol was not declared with a type or
1211 attribute declaration statement, nonzero otherwise. */
1214 was_declared (gfc_symbol *sym)
1220 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1223 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1224 || a.optional || a.pointer || a.save || a.target || a.volatile_
1225 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1226 || a.asynchronous || a.codimension)
1233 /* Determine if a symbol is generic or not. */
1236 generic_sym (gfc_symbol *sym)
1240 if (sym->attr.generic ||
1241 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1244 if (was_declared (sym) || sym->ns->parent == NULL)
1247 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1254 return generic_sym (s);
1261 /* Determine if a symbol is specific or not. */
1264 specific_sym (gfc_symbol *sym)
1268 if (sym->attr.if_source == IFSRC_IFBODY
1269 || sym->attr.proc == PROC_MODULE
1270 || sym->attr.proc == PROC_INTERNAL
1271 || sym->attr.proc == PROC_ST_FUNCTION
1272 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1273 || sym->attr.external)
1276 if (was_declared (sym) || sym->ns->parent == NULL)
1279 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1281 return (s == NULL) ? 0 : specific_sym (s);
1285 /* Figure out if the procedure is specific, generic or unknown. */
1288 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1292 procedure_kind (gfc_symbol *sym)
1294 if (generic_sym (sym))
1295 return PTYPE_GENERIC;
1297 if (specific_sym (sym))
1298 return PTYPE_SPECIFIC;
1300 return PTYPE_UNKNOWN;
1303 /* Check references to assumed size arrays. The flag need_full_assumed_size
1304 is nonzero when matching actual arguments. */
1306 static int need_full_assumed_size = 0;
1309 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1311 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1314 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1315 What should it be? */
1316 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1317 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1318 && (e->ref->u.ar.type == AR_FULL))
1320 gfc_error ("The upper bound in the last dimension must "
1321 "appear in the reference to the assumed size "
1322 "array '%s' at %L", sym->name, &e->where);
1329 /* Look for bad assumed size array references in argument expressions
1330 of elemental and array valued intrinsic procedures. Since this is
1331 called from procedure resolution functions, it only recurses at
1335 resolve_assumed_size_actual (gfc_expr *e)
1340 switch (e->expr_type)
1343 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1348 if (resolve_assumed_size_actual (e->value.op.op1)
1349 || resolve_assumed_size_actual (e->value.op.op2))
1360 /* Check a generic procedure, passed as an actual argument, to see if
1361 there is a matching specific name. If none, it is an error, and if
1362 more than one, the reference is ambiguous. */
1364 count_specific_procs (gfc_expr *e)
1371 sym = e->symtree->n.sym;
1373 for (p = sym->generic; p; p = p->next)
1374 if (strcmp (sym->name, p->sym->name) == 0)
1376 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1382 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1386 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1387 "argument at %L", sym->name, &e->where);
1393 /* See if a call to sym could possibly be a not allowed RECURSION because of
1394 a missing RECURIVE declaration. This means that either sym is the current
1395 context itself, or sym is the parent of a contained procedure calling its
1396 non-RECURSIVE containing procedure.
1397 This also works if sym is an ENTRY. */
1400 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1402 gfc_symbol* proc_sym;
1403 gfc_symbol* context_proc;
1404 gfc_namespace* real_context;
1406 if (sym->attr.flavor == FL_PROGRAM
1407 || sym->attr.flavor == FL_DERIVED)
1410 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1412 /* If we've got an ENTRY, find real procedure. */
1413 if (sym->attr.entry && sym->ns->entries)
1414 proc_sym = sym->ns->entries->sym;
1418 /* If sym is RECURSIVE, all is well of course. */
1419 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1422 /* Find the context procedure's "real" symbol if it has entries.
1423 We look for a procedure symbol, so recurse on the parents if we don't
1424 find one (like in case of a BLOCK construct). */
1425 for (real_context = context; ; real_context = real_context->parent)
1427 /* We should find something, eventually! */
1428 gcc_assert (real_context);
1430 context_proc = (real_context->entries ? real_context->entries->sym
1431 : real_context->proc_name);
1433 /* In some special cases, there may not be a proc_name, like for this
1435 real(bad_kind()) function foo () ...
1436 when checking the call to bad_kind ().
1437 In these cases, we simply return here and assume that the
1442 if (context_proc->attr.flavor != FL_LABEL)
1446 /* A call from sym's body to itself is recursion, of course. */
1447 if (context_proc == proc_sym)
1450 /* The same is true if context is a contained procedure and sym the
1452 if (context_proc->attr.contained)
1454 gfc_symbol* parent_proc;
1456 gcc_assert (context->parent);
1457 parent_proc = (context->parent->entries ? context->parent->entries->sym
1458 : context->parent->proc_name);
1460 if (parent_proc == proc_sym)
1468 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1469 its typespec and formal argument list. */
1472 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1474 gfc_intrinsic_sym* isym = NULL;
1480 /* Already resolved. */
1481 if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
1484 /* We already know this one is an intrinsic, so we don't call
1485 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1486 gfc_find_subroutine directly to check whether it is a function or
1489 if (sym->intmod_sym_id)
1490 isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
1492 isym = gfc_find_function (sym->name);
1496 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1497 && !sym->attr.implicit_type)
1498 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1499 " ignored", sym->name, &sym->declared_at);
1501 if (!sym->attr.function &&
1502 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1507 else if ((isym = gfc_find_subroutine (sym->name)))
1509 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1511 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1512 " specifier", sym->name, &sym->declared_at);
1516 if (!sym->attr.subroutine &&
1517 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1522 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1527 gfc_copy_formal_args_intr (sym, isym);
1529 /* Check it is actually available in the standard settings. */
1530 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1533 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1534 " available in the current standard settings but %s. Use"
1535 " an appropriate -std=* option or enable -fall-intrinsics"
1536 " in order to use it.",
1537 sym->name, &sym->declared_at, symstd);
1545 /* Resolve a procedure expression, like passing it to a called procedure or as
1546 RHS for a procedure pointer assignment. */
1549 resolve_procedure_expression (gfc_expr* expr)
1553 if (expr->expr_type != EXPR_VARIABLE)
1555 gcc_assert (expr->symtree);
1557 sym = expr->symtree->n.sym;
1559 if (sym->attr.intrinsic)
1560 resolve_intrinsic (sym, &expr->where);
1562 if (sym->attr.flavor != FL_PROCEDURE
1563 || (sym->attr.function && sym->result == sym))
1566 /* A non-RECURSIVE procedure that is used as procedure expression within its
1567 own body is in danger of being called recursively. */
1568 if (is_illegal_recursion (sym, gfc_current_ns))
1569 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1570 " itself recursively. Declare it RECURSIVE or use"
1571 " -frecursive", sym->name, &expr->where);
1577 /* Resolve an actual argument list. Most of the time, this is just
1578 resolving the expressions in the list.
1579 The exception is that we sometimes have to decide whether arguments
1580 that look like procedure arguments are really simple variable
1584 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1585 bool no_formal_args)
1588 gfc_symtree *parent_st;
1590 int save_need_full_assumed_size;
1592 for (; arg; arg = arg->next)
1597 /* Check the label is a valid branching target. */
1600 if (arg->label->defined == ST_LABEL_UNKNOWN)
1602 gfc_error ("Label %d referenced at %L is never defined",
1603 arg->label->value, &arg->label->where);
1610 if (e->expr_type == EXPR_VARIABLE
1611 && e->symtree->n.sym->attr.generic
1613 && count_specific_procs (e) != 1)
1616 if (e->ts.type != BT_PROCEDURE)
1618 save_need_full_assumed_size = need_full_assumed_size;
1619 if (e->expr_type != EXPR_VARIABLE)
1620 need_full_assumed_size = 0;
1621 if (gfc_resolve_expr (e) != SUCCESS)
1623 need_full_assumed_size = save_need_full_assumed_size;
1627 /* See if the expression node should really be a variable reference. */
1629 sym = e->symtree->n.sym;
1631 if (sym->attr.flavor == FL_PROCEDURE
1632 || sym->attr.intrinsic
1633 || sym->attr.external)
1637 /* If a procedure is not already determined to be something else
1638 check if it is intrinsic. */
1639 if (!sym->attr.intrinsic
1640 && !(sym->attr.external || sym->attr.use_assoc
1641 || sym->attr.if_source == IFSRC_IFBODY)
1642 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1643 sym->attr.intrinsic = 1;
1645 if (sym->attr.proc == PROC_ST_FUNCTION)
1647 gfc_error ("Statement function '%s' at %L is not allowed as an "
1648 "actual argument", sym->name, &e->where);
1651 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1652 sym->attr.subroutine);
1653 if (sym->attr.intrinsic && actual_ok == 0)
1655 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1656 "actual argument", sym->name, &e->where);
1659 if (sym->attr.contained && !sym->attr.use_assoc
1660 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1662 if (gfc_notify_std (GFC_STD_F2008,
1663 "Fortran 2008: Internal procedure '%s' is"
1664 " used as actual argument at %L",
1665 sym->name, &e->where) == FAILURE)
1669 if (sym->attr.elemental && !sym->attr.intrinsic)
1671 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1672 "allowed as an actual argument at %L", sym->name,
1676 /* Check if a generic interface has a specific procedure
1677 with the same name before emitting an error. */
1678 if (sym->attr.generic && count_specific_procs (e) != 1)
1681 /* Just in case a specific was found for the expression. */
1682 sym = e->symtree->n.sym;
1684 /* If the symbol is the function that names the current (or
1685 parent) scope, then we really have a variable reference. */
1687 if (gfc_is_function_return_value (sym, sym->ns))
1690 /* If all else fails, see if we have a specific intrinsic. */
1691 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1693 gfc_intrinsic_sym *isym;
1695 isym = gfc_find_function (sym->name);
1696 if (isym == NULL || !isym->specific)
1698 gfc_error ("Unable to find a specific INTRINSIC procedure "
1699 "for the reference '%s' at %L", sym->name,
1704 sym->attr.intrinsic = 1;
1705 sym->attr.function = 1;
1708 if (gfc_resolve_expr (e) == FAILURE)
1713 /* See if the name is a module procedure in a parent unit. */
1715 if (was_declared (sym) || sym->ns->parent == NULL)
1718 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1720 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1724 if (parent_st == NULL)
1727 sym = parent_st->n.sym;
1728 e->symtree = parent_st; /* Point to the right thing. */
1730 if (sym->attr.flavor == FL_PROCEDURE
1731 || sym->attr.intrinsic
1732 || sym->attr.external)
1734 if (gfc_resolve_expr (e) == FAILURE)
1740 e->expr_type = EXPR_VARIABLE;
1742 if (sym->as != NULL)
1744 e->rank = sym->as->rank;
1745 e->ref = gfc_get_ref ();
1746 e->ref->type = REF_ARRAY;
1747 e->ref->u.ar.type = AR_FULL;
1748 e->ref->u.ar.as = sym->as;
1751 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1752 primary.c (match_actual_arg). If above code determines that it
1753 is a variable instead, it needs to be resolved as it was not
1754 done at the beginning of this function. */
1755 save_need_full_assumed_size = need_full_assumed_size;
1756 if (e->expr_type != EXPR_VARIABLE)
1757 need_full_assumed_size = 0;
1758 if (gfc_resolve_expr (e) != SUCCESS)
1760 need_full_assumed_size = save_need_full_assumed_size;
1763 /* Check argument list functions %VAL, %LOC and %REF. There is
1764 nothing to do for %REF. */
1765 if (arg->name && arg->name[0] == '%')
1767 if (strncmp ("%VAL", arg->name, 4) == 0)
1769 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1771 gfc_error ("By-value argument at %L is not of numeric "
1778 gfc_error ("By-value argument at %L cannot be an array or "
1779 "an array section", &e->where);
1783 /* Intrinsics are still PROC_UNKNOWN here. However,
1784 since same file external procedures are not resolvable
1785 in gfortran, it is a good deal easier to leave them to
1787 if (ptype != PROC_UNKNOWN
1788 && ptype != PROC_DUMMY
1789 && ptype != PROC_EXTERNAL
1790 && ptype != PROC_MODULE)
1792 gfc_error ("By-value argument at %L is not allowed "
1793 "in this context", &e->where);
1798 /* Statement functions have already been excluded above. */
1799 else if (strncmp ("%LOC", arg->name, 4) == 0
1800 && e->ts.type == BT_PROCEDURE)
1802 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1804 gfc_error ("Passing internal procedure at %L by location "
1805 "not allowed", &e->where);
1811 /* Fortran 2008, C1237. */
1812 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1813 && gfc_has_ultimate_pointer (e))
1815 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1816 "component", &e->where);
1825 /* Do the checks of the actual argument list that are specific to elemental
1826 procedures. If called with c == NULL, we have a function, otherwise if
1827 expr == NULL, we have a subroutine. */
1830 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1832 gfc_actual_arglist *arg0;
1833 gfc_actual_arglist *arg;
1834 gfc_symbol *esym = NULL;
1835 gfc_intrinsic_sym *isym = NULL;
1837 gfc_intrinsic_arg *iformal = NULL;
1838 gfc_formal_arglist *eformal = NULL;
1839 bool formal_optional = false;
1840 bool set_by_optional = false;
1844 /* Is this an elemental procedure? */
1845 if (expr && expr->value.function.actual != NULL)
1847 if (expr->value.function.esym != NULL
1848 && expr->value.function.esym->attr.elemental)
1850 arg0 = expr->value.function.actual;
1851 esym = expr->value.function.esym;
1853 else if (expr->value.function.isym != NULL
1854 && expr->value.function.isym->elemental)
1856 arg0 = expr->value.function.actual;
1857 isym = expr->value.function.isym;
1862 else if (c && c->ext.actual != NULL)
1864 arg0 = c->ext.actual;
1866 if (c->resolved_sym)
1867 esym = c->resolved_sym;
1869 esym = c->symtree->n.sym;
1872 if (!esym->attr.elemental)
1878 /* The rank of an elemental is the rank of its array argument(s). */
1879 for (arg = arg0; arg; arg = arg->next)
1881 if (arg->expr != NULL && arg->expr->rank > 0)
1883 rank = arg->expr->rank;
1884 if (arg->expr->expr_type == EXPR_VARIABLE
1885 && arg->expr->symtree->n.sym->attr.optional)
1886 set_by_optional = true;
1888 /* Function specific; set the result rank and shape. */
1892 if (!expr->shape && arg->expr->shape)
1894 expr->shape = gfc_get_shape (rank);
1895 for (i = 0; i < rank; i++)
1896 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1903 /* If it is an array, it shall not be supplied as an actual argument
1904 to an elemental procedure unless an array of the same rank is supplied
1905 as an actual argument corresponding to a nonoptional dummy argument of
1906 that elemental procedure(12.4.1.5). */
1907 formal_optional = false;
1909 iformal = isym->formal;
1911 eformal = esym->formal;
1913 for (arg = arg0; arg; arg = arg->next)
1917 if (eformal->sym && eformal->sym->attr.optional)
1918 formal_optional = true;
1919 eformal = eformal->next;
1921 else if (isym && iformal)
1923 if (iformal->optional)
1924 formal_optional = true;
1925 iformal = iformal->next;
1928 formal_optional = true;
1930 if (pedantic && arg->expr != NULL
1931 && arg->expr->expr_type == EXPR_VARIABLE
1932 && arg->expr->symtree->n.sym->attr.optional
1935 && (set_by_optional || arg->expr->rank != rank)
1936 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1938 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1939 "MISSING, it cannot be the actual argument of an "
1940 "ELEMENTAL procedure unless there is a non-optional "
1941 "argument with the same rank (12.4.1.5)",
1942 arg->expr->symtree->n.sym->name, &arg->expr->where);
1947 for (arg = arg0; arg; arg = arg->next)
1949 if (arg->expr == NULL || arg->expr->rank == 0)
1952 /* Being elemental, the last upper bound of an assumed size array
1953 argument must be present. */
1954 if (resolve_assumed_size_actual (arg->expr))
1957 /* Elemental procedure's array actual arguments must conform. */
1960 if (gfc_check_conformance (arg->expr, e,
1961 "elemental procedure") == FAILURE)
1968 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1969 is an array, the intent inout/out variable needs to be also an array. */
1970 if (rank > 0 && esym && expr == NULL)
1971 for (eformal = esym->formal, arg = arg0; arg && eformal;
1972 arg = arg->next, eformal = eformal->next)
1973 if ((eformal->sym->attr.intent == INTENT_OUT
1974 || eformal->sym->attr.intent == INTENT_INOUT)
1975 && arg->expr && arg->expr->rank == 0)
1977 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1978 "ELEMENTAL subroutine '%s' is a scalar, but another "
1979 "actual argument is an array", &arg->expr->where,
1980 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1981 : "INOUT", eformal->sym->name, esym->name);
1988 /* This function does the checking of references to global procedures
1989 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1990 77 and 95 standards. It checks for a gsymbol for the name, making
1991 one if it does not already exist. If it already exists, then the
1992 reference being resolved must correspond to the type of gsymbol.
1993 Otherwise, the new symbol is equipped with the attributes of the
1994 reference. The corresponding code that is called in creating
1995 global entities is parse.c.
1997 In addition, for all but -std=legacy, the gsymbols are used to
1998 check the interfaces of external procedures from the same file.
1999 The namespace of the gsymbol is resolved and then, once this is
2000 done the interface is checked. */
2004 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2006 if (!gsym_ns->proc_name->attr.recursive)
2009 if (sym->ns == gsym_ns)
2012 if (sym->ns->parent && sym->ns->parent == gsym_ns)
2019 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
2021 if (gsym_ns->entries)
2023 gfc_entry_list *entry = gsym_ns->entries;
2025 for (; entry; entry = entry->next)
2027 if (strcmp (sym->name, entry->sym->name) == 0)
2029 if (strcmp (gsym_ns->proc_name->name,
2030 sym->ns->proc_name->name) == 0)
2034 && strcmp (gsym_ns->proc_name->name,
2035 sym->ns->parent->proc_name->name) == 0)
2044 resolve_global_procedure (gfc_symbol *sym, locus *where,
2045 gfc_actual_arglist **actual, int sub)
2049 enum gfc_symbol_type type;
2051 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2053 gsym = gfc_get_gsymbol (sym->name);
2055 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2056 gfc_global_used (gsym, where);
2058 if (gfc_option.flag_whole_file
2059 && (sym->attr.if_source == IFSRC_UNKNOWN
2060 || sym->attr.if_source == IFSRC_IFBODY)
2061 && gsym->type != GSYM_UNKNOWN
2063 && gsym->ns->resolved != -1
2064 && gsym->ns->proc_name
2065 && not_in_recursive (sym, gsym->ns)
2066 && not_entry_self_reference (sym, gsym->ns))
2068 gfc_symbol *def_sym;
2070 /* Resolve the gsymbol namespace if needed. */
2071 if (!gsym->ns->resolved)
2073 gfc_dt_list *old_dt_list;
2074 struct gfc_omp_saved_state old_omp_state;
2076 /* Stash away derived types so that the backend_decls do not
2078 old_dt_list = gfc_derived_types;
2079 gfc_derived_types = NULL;
2080 /* And stash away openmp state. */
2081 gfc_omp_save_and_clear_state (&old_omp_state);
2083 gfc_resolve (gsym->ns);
2085 /* Store the new derived types with the global namespace. */
2086 if (gfc_derived_types)
2087 gsym->ns->derived_types = gfc_derived_types;
2089 /* Restore the derived types of this namespace. */
2090 gfc_derived_types = old_dt_list;
2091 /* And openmp state. */
2092 gfc_omp_restore_state (&old_omp_state);
2095 /* Make sure that translation for the gsymbol occurs before
2096 the procedure currently being resolved. */
2097 ns = gfc_global_ns_list;
2098 for (; ns && ns != gsym->ns; ns = ns->sibling)
2100 if (ns->sibling == gsym->ns)
2102 ns->sibling = gsym->ns->sibling;
2103 gsym->ns->sibling = gfc_global_ns_list;
2104 gfc_global_ns_list = gsym->ns;
2109 def_sym = gsym->ns->proc_name;
2110 if (def_sym->attr.entry_master)
2112 gfc_entry_list *entry;
2113 for (entry = gsym->ns->entries; entry; entry = entry->next)
2114 if (strcmp (entry->sym->name, sym->name) == 0)
2116 def_sym = entry->sym;
2121 /* Differences in constant character lengths. */
2122 if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2124 long int l1 = 0, l2 = 0;
2125 gfc_charlen *cl1 = sym->ts.u.cl;
2126 gfc_charlen *cl2 = def_sym->ts.u.cl;
2129 && cl1->length != NULL
2130 && cl1->length->expr_type == EXPR_CONSTANT)
2131 l1 = mpz_get_si (cl1->length->value.integer);
2134 && cl2->length != NULL
2135 && cl2->length->expr_type == EXPR_CONSTANT)
2136 l2 = mpz_get_si (cl2->length->value.integer);
2138 if (l1 && l2 && l1 != l2)
2139 gfc_error ("Character length mismatch in return type of "
2140 "function '%s' at %L (%ld/%ld)", sym->name,
2141 &sym->declared_at, l1, l2);
2144 /* Type mismatch of function return type and expected type. */
2145 if (sym->attr.function
2146 && !gfc_compare_types (&sym->ts, &def_sym->ts))
2147 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2148 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2149 gfc_typename (&def_sym->ts));
2151 if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2153 gfc_formal_arglist *arg = def_sym->formal;
2154 for ( ; arg; arg = arg->next)
2157 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2158 else if (arg->sym->attr.allocatable
2159 || arg->sym->attr.asynchronous
2160 || arg->sym->attr.optional
2161 || arg->sym->attr.pointer
2162 || arg->sym->attr.target
2163 || arg->sym->attr.value
2164 || arg->sym->attr.volatile_)
2166 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2167 "has an attribute that requires an explicit "
2168 "interface for this procedure", arg->sym->name,
2169 sym->name, &sym->declared_at);
2172 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2173 else if (arg->sym && arg->sym->as
2174 && arg->sym->as->type == AS_ASSUMED_SHAPE)
2176 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2177 "argument '%s' must have an explicit interface",
2178 sym->name, &sym->declared_at, arg->sym->name);
2181 /* F2008, 12.4.2.2 (2c) */
2182 else if (arg->sym->attr.codimension)
2184 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2185 "'%s' must have an explicit interface",
2186 sym->name, &sym->declared_at, arg->sym->name);
2189 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2190 else if (false) /* TODO: is a parametrized derived type */
2192 gfc_error ("Procedure '%s' at %L with parametrized derived "
2193 "type argument '%s' must have an explicit "
2194 "interface", sym->name, &sym->declared_at,
2198 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2199 else if (arg->sym->ts.type == BT_CLASS)
2201 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2202 "argument '%s' must have an explicit interface",
2203 sym->name, &sym->declared_at, arg->sym->name);
2208 if (def_sym->attr.function)
2210 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2211 if (def_sym->as && def_sym->as->rank
2212 && (!sym->as || sym->as->rank != def_sym->as->rank))
2213 gfc_error ("The reference to function '%s' at %L either needs an "
2214 "explicit INTERFACE or the rank is incorrect", sym->name,
2217 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2218 if ((def_sym->result->attr.pointer
2219 || def_sym->result->attr.allocatable)
2220 && (sym->attr.if_source != IFSRC_IFBODY
2221 || def_sym->result->attr.pointer
2222 != sym->result->attr.pointer
2223 || def_sym->result->attr.allocatable
2224 != sym->result->attr.allocatable))
2225 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2226 "result must have an explicit interface", sym->name,
2229 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2230 if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2231 && def_sym->ts.type == BT_CHARACTER && def_sym->ts.u.cl->length != NULL)
2233 gfc_charlen *cl = sym->ts.u.cl;
2235 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2236 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2238 gfc_error ("Nonconstant character-length function '%s' at %L "
2239 "must have an explicit interface", sym->name,
2245 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2246 if (def_sym->attr.elemental && !sym->attr.elemental)
2248 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2249 "interface", sym->name, &sym->declared_at);
2252 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2253 if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2255 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2256 "an explicit interface", sym->name, &sym->declared_at);
2259 if (gfc_option.flag_whole_file == 1
2260 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2261 && !(gfc_option.warn_std & GFC_STD_GNU)))
2262 gfc_errors_to_warnings (1);
2264 if (sym->attr.if_source != IFSRC_IFBODY)
2265 gfc_procedure_use (def_sym, actual, where);
2267 gfc_errors_to_warnings (0);
2270 if (gsym->type == GSYM_UNKNOWN)
2273 gsym->where = *where;
2280 /************* Function resolution *************/
2282 /* Resolve a function call known to be generic.
2283 Section 14.1.2.4.1. */
2286 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2290 if (sym->attr.generic)
2292 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2295 expr->value.function.name = s->name;
2296 expr->value.function.esym = s;
2298 if (s->ts.type != BT_UNKNOWN)
2300 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2301 expr->ts = s->result->ts;
2304 expr->rank = s->as->rank;
2305 else if (s->result != NULL && s->result->as != NULL)
2306 expr->rank = s->result->as->rank;
2308 gfc_set_sym_referenced (expr->value.function.esym);
2313 /* TODO: Need to search for elemental references in generic
2317 if (sym->attr.intrinsic)
2318 return gfc_intrinsic_func_interface (expr, 0);
2325 resolve_generic_f (gfc_expr *expr)
2329 gfc_interface *intr = NULL;
2331 sym = expr->symtree->n.sym;
2335 m = resolve_generic_f0 (expr, sym);
2338 else if (m == MATCH_ERROR)
2343 for (intr = sym->generic; intr; intr = intr->next)
2344 if (intr->sym->attr.flavor == FL_DERIVED)
2347 if (sym->ns->parent == NULL)
2349 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2353 if (!generic_sym (sym))
2357 /* Last ditch attempt. See if the reference is to an intrinsic
2358 that possesses a matching interface. 14.1.2.4 */
2359 if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
2361 gfc_error ("There is no specific function for the generic '%s' "
2362 "at %L", expr->symtree->n.sym->name, &expr->where);
2368 if (gfc_convert_to_structure_constructor (expr, intr->sym, NULL, NULL,
2371 return resolve_structure_cons (expr, 0);
2374 m = gfc_intrinsic_func_interface (expr, 0);
2379 gfc_error ("Generic function '%s' at %L is not consistent with a "
2380 "specific intrinsic interface", expr->symtree->n.sym->name,
2387 /* Resolve a function call known to be specific. */
2390 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2394 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2396 if (sym->attr.dummy)
2398 sym->attr.proc = PROC_DUMMY;
2402 sym->attr.proc = PROC_EXTERNAL;
2406 if (sym->attr.proc == PROC_MODULE
2407 || sym->attr.proc == PROC_ST_FUNCTION
2408 || sym->attr.proc == PROC_INTERNAL)
2411 if (sym->attr.intrinsic)
2413 m = gfc_intrinsic_func_interface (expr, 1);
2417 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2418 "with an intrinsic", sym->name, &expr->where);
2426 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2429 expr->ts = sym->result->ts;
2432 expr->value.function.name = sym->name;
2433 expr->value.function.esym = sym;
2434 if (sym->as != NULL)
2435 expr->rank = sym->as->rank;
2442 resolve_specific_f (gfc_expr *expr)
2447 sym = expr->symtree->n.sym;
2451 m = resolve_specific_f0 (sym, expr);
2454 if (m == MATCH_ERROR)
2457 if (sym->ns->parent == NULL)
2460 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2466 gfc_error ("Unable to resolve the specific function '%s' at %L",
2467 expr->symtree->n.sym->name, &expr->where);
2473 /* Resolve a procedure call not known to be generic nor specific. */
2476 resolve_unknown_f (gfc_expr *expr)
2481 sym = expr->symtree->n.sym;
2483 if (sym->attr.dummy)
2485 sym->attr.proc = PROC_DUMMY;
2486 expr->value.function.name = sym->name;
2490 /* See if we have an intrinsic function reference. */
2492 if (gfc_is_intrinsic (sym, 0, expr->where))
2494 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2499 /* The reference is to an external name. */
2501 sym->attr.proc = PROC_EXTERNAL;
2502 expr->value.function.name = sym->name;
2503 expr->value.function.esym = expr->symtree->n.sym;
2505 if (sym->as != NULL)
2506 expr->rank = sym->as->rank;
2508 /* Type of the expression is either the type of the symbol or the
2509 default type of the symbol. */
2512 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2514 if (sym->ts.type != BT_UNKNOWN)
2518 ts = gfc_get_default_type (sym->name, sym->ns);
2520 if (ts->type == BT_UNKNOWN)
2522 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2523 sym->name, &expr->where);
2534 /* Return true, if the symbol is an external procedure. */
2536 is_external_proc (gfc_symbol *sym)
2538 if (!sym->attr.dummy && !sym->attr.contained
2539 && !(sym->attr.intrinsic
2540 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2541 && sym->attr.proc != PROC_ST_FUNCTION
2542 && !sym->attr.proc_pointer
2543 && !sym->attr.use_assoc
2551 /* Figure out if a function reference is pure or not. Also set the name
2552 of the function for a potential error message. Return nonzero if the
2553 function is PURE, zero if not. */
2555 pure_stmt_function (gfc_expr *, gfc_symbol *);
2558 pure_function (gfc_expr *e, const char **name)
2564 if (e->symtree != NULL
2565 && e->symtree->n.sym != NULL
2566 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2567 return pure_stmt_function (e, e->symtree->n.sym);
2569 if (e->value.function.esym)
2571 pure = gfc_pure (e->value.function.esym);
2572 *name = e->value.function.esym->name;
2574 else if (e->value.function.isym)
2576 pure = e->value.function.isym->pure
2577 || e->value.function.isym->elemental;
2578 *name = e->value.function.isym->name;
2582 /* Implicit functions are not pure. */
2584 *name = e->value.function.name;
2592 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2593 int *f ATTRIBUTE_UNUSED)
2597 /* Don't bother recursing into other statement functions
2598 since they will be checked individually for purity. */
2599 if (e->expr_type != EXPR_FUNCTION
2601 || e->symtree->n.sym == sym
2602 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2605 return pure_function (e, &name) ? false : true;
2610 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2612 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2617 is_scalar_expr_ptr (gfc_expr *expr)
2619 gfc_try retval = SUCCESS;
2624 /* See if we have a gfc_ref, which means we have a substring, array
2625 reference, or a component. */
2626 if (expr->ref != NULL)
2629 while (ref->next != NULL)
2635 if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
2636 || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
2641 if (ref->u.ar.type == AR_ELEMENT)
2643 else if (ref->u.ar.type == AR_FULL)
2645 /* The user can give a full array if the array is of size 1. */
2646 if (ref->u.ar.as != NULL
2647 && ref->u.ar.as->rank == 1
2648 && ref->u.ar.as->type == AS_EXPLICIT
2649 && ref->u.ar.as->lower[0] != NULL
2650 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2651 && ref->u.ar.as->upper[0] != NULL
2652 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2654 /* If we have a character string, we need to check if
2655 its length is one. */
2656 if (expr->ts.type == BT_CHARACTER)
2658 if (expr->ts.u.cl == NULL
2659 || expr->ts.u.cl->length == NULL
2660 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2666 /* We have constant lower and upper bounds. If the
2667 difference between is 1, it can be considered a
2669 FIXME: Use gfc_dep_compare_expr instead. */
2670 start = (int) mpz_get_si
2671 (ref->u.ar.as->lower[0]->value.integer);
2672 end = (int) mpz_get_si
2673 (ref->u.ar.as->upper[0]->value.integer);
2674 if (end - start + 1 != 1)
2689 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2691 /* Character string. Make sure it's of length 1. */
2692 if (expr->ts.u.cl == NULL
2693 || expr->ts.u.cl->length == NULL
2694 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2697 else if (expr->rank != 0)
2704 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2705 and, in the case of c_associated, set the binding label based on
2709 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2710 gfc_symbol **new_sym)
2712 char name[GFC_MAX_SYMBOL_LEN + 1];
2713 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2714 int optional_arg = 0;
2715 gfc_try retval = SUCCESS;
2716 gfc_symbol *args_sym;
2717 gfc_typespec *arg_ts;
2718 symbol_attribute arg_attr;
2720 if (args->expr->expr_type == EXPR_CONSTANT
2721 || args->expr->expr_type == EXPR_OP
2722 || args->expr->expr_type == EXPR_NULL)
2724 gfc_error ("Argument to '%s' at %L is not a variable",
2725 sym->name, &(args->expr->where));
2729 args_sym = args->expr->symtree->n.sym;
2731 /* The typespec for the actual arg should be that stored in the expr
2732 and not necessarily that of the expr symbol (args_sym), because
2733 the actual expression could be a part-ref of the expr symbol. */
2734 arg_ts = &(args->expr->ts);
2735 arg_attr = gfc_expr_attr (args->expr);
2737 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2739 /* If the user gave two args then they are providing something for
2740 the optional arg (the second cptr). Therefore, set the name and
2741 binding label to the c_associated for two cptrs. Otherwise,
2742 set c_associated to expect one cptr. */
2746 sprintf (name, "%s_2", sym->name);
2747 sprintf (binding_label, "%s_2", sym->binding_label);
2753 sprintf (name, "%s_1", sym->name);
2754 sprintf (binding_label, "%s_1", sym->binding_label);
2758 /* Get a new symbol for the version of c_associated that
2760 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2762 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2763 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2765 sprintf (name, "%s", sym->name);
2766 sprintf (binding_label, "%s", sym->binding_label);
2768 /* Error check the call. */
2769 if (args->next != NULL)
2771 gfc_error_now ("More actual than formal arguments in '%s' "
2772 "call at %L", name, &(args->expr->where));
2775 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2780 /* Make sure we have either the target or pointer attribute. */
2781 if (!arg_attr.target && !arg_attr.pointer)
2783 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2784 "a TARGET or an associated pointer",
2786 sym->name, &(args->expr->where));
2790 if (gfc_is_coindexed (args->expr))
2792 gfc_error_now ("Coindexed argument not permitted"
2793 " in '%s' call at %L", name,
2794 &(args->expr->where));
2798 /* Follow references to make sure there are no array
2800 seen_section = false;
2802 for (ref=args->expr->ref; ref; ref = ref->next)
2804 if (ref->type == REF_ARRAY)
2806 if (ref->u.ar.type == AR_SECTION)
2807 seen_section = true;
2809 if (ref->u.ar.type != AR_ELEMENT)
2812 for (r = ref->next; r; r=r->next)
2813 if (r->type == REF_COMPONENT)
2815 gfc_error_now ("Array section not permitted"
2816 " in '%s' call at %L", name,
2817 &(args->expr->where));
2825 if (seen_section && retval == SUCCESS)
2826 gfc_warning ("Array section in '%s' call at %L", name,
2827 &(args->expr->where));
2829 /* See if we have interoperable type and type param. */
2830 if (gfc_verify_c_interop (arg_ts) == SUCCESS
2831 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2833 if (args_sym->attr.target == 1)
2835 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2836 has the target attribute and is interoperable. */
2837 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2838 allocatable variable that has the TARGET attribute and
2839 is not an array of zero size. */
2840 if (args_sym->attr.allocatable == 1)
2842 if (args_sym->attr.dimension != 0
2843 && (args_sym->as && args_sym->as->rank == 0))
2845 gfc_error_now ("Allocatable variable '%s' used as a "
2846 "parameter to '%s' at %L must not be "
2847 "an array of zero size",
2848 args_sym->name, sym->name,
2849 &(args->expr->where));
2855 /* A non-allocatable target variable with C
2856 interoperable type and type parameters must be
2858 if (args_sym && args_sym->attr.dimension)
2860 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2862 gfc_error ("Assumed-shape array '%s' at %L "
2863 "cannot be an argument to the "
2864 "procedure '%s' because "
2865 "it is not C interoperable",
2867 &(args->expr->where), sym->name);
2870 else if (args_sym->as->type == AS_DEFERRED)
2872 gfc_error ("Deferred-shape array '%s' at %L "
2873 "cannot be an argument to the "
2874 "procedure '%s' because "
2875 "it is not C interoperable",
2877 &(args->expr->where), sym->name);
2882 /* Make sure it's not a character string. Arrays of
2883 any type should be ok if the variable is of a C
2884 interoperable type. */
2885 if (arg_ts->type == BT_CHARACTER)
2886 if (arg_ts->u.cl != NULL
2887 && (arg_ts->u.cl->length == NULL
2888 || arg_ts->u.cl->length->expr_type
2891 (arg_ts->u.cl->length->value.integer, 1)
2893 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2895 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2896 "at %L must have a length of 1",
2897 args_sym->name, sym->name,
2898 &(args->expr->where));
2903 else if (arg_attr.pointer
2904 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2906 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2908 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2909 "associated scalar POINTER", args_sym->name,
2910 sym->name, &(args->expr->where));
2916 /* The parameter is not required to be C interoperable. If it
2917 is not C interoperable, it must be a nonpolymorphic scalar
2918 with no length type parameters. It still must have either
2919 the pointer or target attribute, and it can be
2920 allocatable (but must be allocated when c_loc is called). */
2921 if (args->expr->rank != 0
2922 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2924 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2925 "scalar", args_sym->name, sym->name,
2926 &(args->expr->where));
2929 else if (arg_ts->type == BT_CHARACTER
2930 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2932 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2933 "%L must have a length of 1",
2934 args_sym->name, sym->name,
2935 &(args->expr->where));
2938 else if (arg_ts->type == BT_CLASS)
2940 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2941 "polymorphic", args_sym->name, sym->name,
2942 &(args->expr->where));
2947 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2949 if (args_sym->attr.flavor != FL_PROCEDURE)
2951 /* TODO: Update this error message to allow for procedure
2952 pointers once they are implemented. */
2953 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2955 args_sym->name, sym->name,
2956 &(args->expr->where));
2959 else if (args_sym->attr.is_bind_c != 1)
2961 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2963 args_sym->name, sym->name,
2964 &(args->expr->where));
2969 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2974 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2975 "iso_c_binding function: '%s'!\n", sym->name);
2982 /* Resolve a function call, which means resolving the arguments, then figuring
2983 out which entity the name refers to. */
2986 resolve_function (gfc_expr *expr)
2988 gfc_actual_arglist *arg;
2993 procedure_type p = PROC_INTRINSIC;
2994 bool no_formal_args;
2998 sym = expr->symtree->n.sym;
3000 /* If this is a procedure pointer component, it has already been resolved. */
3001 if (gfc_is_proc_ptr_comp (expr, NULL))
3004 if (sym && sym->attr.intrinsic
3005 && resolve_intrinsic (sym, &expr->where) == FAILURE)
3008 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
3010 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
3014 /* If this ia a deferred TBP with an abstract interface (which may
3015 of course be referenced), expr->value.function.esym will be set. */
3016 if (sym && sym->attr.abstract && !expr->value.function.esym)
3018 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3019 sym->name, &expr->where);
3023 /* Switch off assumed size checking and do this again for certain kinds
3024 of procedure, once the procedure itself is resolved. */
3025 need_full_assumed_size++;
3027 if (expr->symtree && expr->symtree->n.sym)
3028 p = expr->symtree->n.sym->attr.proc;
3030 if (expr->value.function.isym && expr->value.function.isym->inquiry)
3031 inquiry_argument = true;
3032 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
3034 if (resolve_actual_arglist (expr->value.function.actual,
3035 p, no_formal_args) == FAILURE)
3037 inquiry_argument = false;
3041 inquiry_argument = false;
3043 /* Need to setup the call to the correct c_associated, depending on
3044 the number of cptrs to user gives to compare. */
3045 if (sym && sym->attr.is_iso_c == 1)
3047 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
3051 /* Get the symtree for the new symbol (resolved func).
3052 the old one will be freed later, when it's no longer used. */
3053 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
3056 /* Resume assumed_size checking. */
3057 need_full_assumed_size--;
3059 /* If the procedure is external, check for usage. */
3060 if (sym && is_external_proc (sym))
3061 resolve_global_procedure (sym, &expr->where,
3062 &expr->value.function.actual, 0);
3064 if (sym && sym->ts.type == BT_CHARACTER
3066 && sym->ts.u.cl->length == NULL
3068 && !sym->ts.deferred
3069 && expr->value.function.esym == NULL
3070 && !sym->attr.contained)
3072 /* Internal procedures are taken care of in resolve_contained_fntype. */
3073 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
3074 "be used at %L since it is not a dummy argument",
3075 sym->name, &expr->where);
3079 /* See if function is already resolved. */
3081 if (expr->value.function.name != NULL)
3083 if (expr->ts.type == BT_UNKNOWN)
3089 /* Apply the rules of section 14.1.2. */
3091 switch (procedure_kind (sym))
3094 t = resolve_generic_f (expr);
3097 case PTYPE_SPECIFIC:
3098 t = resolve_specific_f (expr);
3102 t = resolve_unknown_f (expr);
3106 gfc_internal_error ("resolve_function(): bad function type");
3110 /* If the expression is still a function (it might have simplified),
3111 then we check to see if we are calling an elemental function. */
3113 if (expr->expr_type != EXPR_FUNCTION)
3116 temp = need_full_assumed_size;
3117 need_full_assumed_size = 0;
3119 if (resolve_elemental_actual (expr, NULL) == FAILURE)
3122 if (omp_workshare_flag
3123 && expr->value.function.esym
3124 && ! gfc_elemental (expr->value.function.esym))
3126 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3127 "in WORKSHARE construct", expr->value.function.esym->name,
3132 #define GENERIC_ID expr->value.function.isym->id
3133 else if (expr->value.function.actual != NULL
3134 && expr->value.function.isym != NULL
3135 && GENERIC_ID != GFC_ISYM_LBOUND
3136 && GENERIC_ID != GFC_ISYM_LEN
3137 && GENERIC_ID != GFC_ISYM_LOC
3138 && GENERIC_ID != GFC_ISYM_PRESENT)
3140 /* Array intrinsics must also have the last upper bound of an
3141 assumed size array argument. UBOUND and SIZE have to be
3142 excluded from the check if the second argument is anything
3145 for (arg = expr->value.function.actual; arg; arg = arg->next)
3147 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3148 && arg->next != NULL && arg->next->expr)
3150 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3153 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3156 if ((int)mpz_get_si (arg->next->expr->value.integer)
3161 if (arg->expr != NULL
3162 && arg->expr->rank > 0
3163 && resolve_assumed_size_actual (arg->expr))
3169 need_full_assumed_size = temp;
3172 if (!pure_function (expr, &name) && name)
3176 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3177 "FORALL %s", name, &expr->where,
3178 forall_flag == 2 ? "mask" : "block");
3181 else if (do_concurrent_flag)
3183 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3184 "DO CONCURRENT %s", name, &expr->where,
3185 do_concurrent_flag == 2 ? "mask" : "block");
3188 else if (gfc_pure (NULL))
3190 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3191 "procedure within a PURE procedure", name, &expr->where);
3195 if (gfc_implicit_pure (NULL))
3196 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3199 /* Functions without the RECURSIVE attribution are not allowed to
3200 * call themselves. */
3201 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3204 esym = expr->value.function.esym;
3206 if (is_illegal_recursion (esym, gfc_current_ns))
3208 if (esym->attr.entry && esym->ns->entries)
3209 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3210 " function '%s' is not RECURSIVE",
3211 esym->name, &expr->where, esym->ns->entries->sym->name);
3213 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3214 " is not RECURSIVE", esym->name, &expr->where);
3220 /* Character lengths of use associated functions may contains references to
3221 symbols not referenced from the current program unit otherwise. Make sure
3222 those symbols are marked as referenced. */
3224 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3225 && expr->value.function.esym->attr.use_assoc)
3227 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3230 /* Make sure that the expression has a typespec that works. */
3231 if (expr->ts.type == BT_UNKNOWN)
3233 if (expr->symtree->n.sym->result
3234 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3235 && !expr->symtree->n.sym->result->attr.proc_pointer)
3236 expr->ts = expr->symtree->n.sym->result->ts;
3243 /************* Subroutine resolution *************/
3246 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3252 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3253 sym->name, &c->loc);
3254 else if (do_concurrent_flag)
3255 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3256 "PURE", sym->name, &c->loc);
3257 else if (gfc_pure (NULL))
3258 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3261 if (gfc_implicit_pure (NULL))
3262 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3267 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3271 if (sym->attr.generic)
3273 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3276 c->resolved_sym = s;
3277 pure_subroutine (c, s);
3281 /* TODO: Need to search for elemental references in generic interface. */
3284 if (sym->attr.intrinsic)
3285 return gfc_intrinsic_sub_interface (c, 0);
3292 resolve_generic_s (gfc_code *c)
3297 sym = c->symtree->n.sym;
3301 m = resolve_generic_s0 (c, sym);
3304 else if (m == MATCH_ERROR)
3308 if (sym->ns->parent == NULL)
3310 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3314 if (!generic_sym (sym))
3318 /* Last ditch attempt. See if the reference is to an intrinsic
3319 that possesses a matching interface. 14.1.2.4 */
3320 sym = c->symtree->n.sym;
3322 if (!gfc_is_intrinsic (sym, 1, c->loc))
3324 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3325 sym->name, &c->loc);
3329 m = gfc_intrinsic_sub_interface (c, 0);
3333 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3334 "intrinsic subroutine interface", sym->name, &c->loc);
3340 /* Set the name and binding label of the subroutine symbol in the call
3341 expression represented by 'c' to include the type and kind of the
3342 second parameter. This function is for resolving the appropriate
3343 version of c_f_pointer() and c_f_procpointer(). For example, a
3344 call to c_f_pointer() for a default integer pointer could have a
3345 name of c_f_pointer_i4. If no second arg exists, which is an error
3346 for these two functions, it defaults to the generic symbol's name
3347 and binding label. */
3350 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3351 char *name, char *binding_label)
3353 gfc_expr *arg = NULL;
3357 /* The second arg of c_f_pointer and c_f_procpointer determines
3358 the type and kind for the procedure name. */
3359 arg = c->ext.actual->next->expr;
3363 /* Set up the name to have the given symbol's name,
3364 plus the type and kind. */
3365 /* a derived type is marked with the type letter 'u' */
3366 if (arg->ts.type == BT_DERIVED)
3369 kind = 0; /* set the kind as 0 for now */
3373 type = gfc_type_letter (arg->ts.type);
3374 kind = arg->ts.kind;
3377 if (arg->ts.type == BT_CHARACTER)
3378 /* Kind info for character strings not needed. */
3381 sprintf (name, "%s_%c%d", sym->name, type, kind);
3382 /* Set up the binding label as the given symbol's label plus
3383 the type and kind. */
3384 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
3388 /* If the second arg is missing, set the name and label as
3389 was, cause it should at least be found, and the missing
3390 arg error will be caught by compare_parameters(). */
3391 sprintf (name, "%s", sym->name);
3392 sprintf (binding_label, "%s", sym->binding_label);
3399 /* Resolve a generic version of the iso_c_binding procedure given
3400 (sym) to the specific one based on the type and kind of the
3401 argument(s). Currently, this function resolves c_f_pointer() and
3402 c_f_procpointer based on the type and kind of the second argument
3403 (FPTR). Other iso_c_binding procedures aren't specially handled.
3404 Upon successfully exiting, c->resolved_sym will hold the resolved
3405 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3409 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3411 gfc_symbol *new_sym;
3412 /* this is fine, since we know the names won't use the max */
3413 char name[GFC_MAX_SYMBOL_LEN + 1];
3414 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
3415 /* default to success; will override if find error */
3416 match m = MATCH_YES;
3418 /* Make sure the actual arguments are in the necessary order (based on the
3419 formal args) before resolving. */
3420 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3422 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3423 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3425 set_name_and_label (c, sym, name, binding_label);
3427 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3429 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3431 /* Make sure we got a third arg if the second arg has non-zero
3432 rank. We must also check that the type and rank are
3433 correct since we short-circuit this check in
3434 gfc_procedure_use() (called above to sort actual args). */
3435 if (c->ext.actual->next->expr->rank != 0)
3437 if(c->ext.actual->next->next == NULL
3438 || c->ext.actual->next->next->expr == NULL)
3441 gfc_error ("Missing SHAPE parameter for call to %s "
3442 "at %L", sym->name, &(c->loc));
3444 else if (c->ext.actual->next->next->expr->ts.type
3446 || c->ext.actual->next->next->expr->rank != 1)
3449 gfc_error ("SHAPE parameter for call to %s at %L must "
3450 "be a rank 1 INTEGER array", sym->name,
3457 if (m != MATCH_ERROR)
3459 /* the 1 means to add the optional arg to formal list */
3460 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3462 /* for error reporting, say it's declared where the original was */
3463 new_sym->declared_at = sym->declared_at;
3468 /* no differences for c_loc or c_funloc */
3472 /* set the resolved symbol */
3473 if (m != MATCH_ERROR)
3474 c->resolved_sym = new_sym;
3476 c->resolved_sym = sym;
3482 /* Resolve a subroutine call known to be specific. */
3485 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3489 if(sym->attr.is_iso_c)
3491 m = gfc_iso_c_sub_interface (c,sym);
3495 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3497 if (sym->attr.dummy)
3499 sym->attr.proc = PROC_DUMMY;
3503 sym->attr.proc = PROC_EXTERNAL;
3507 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3510 if (sym->attr.intrinsic)
3512 m = gfc_intrinsic_sub_interface (c, 1);
3516 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3517 "with an intrinsic", sym->name, &c->loc);
3525 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3527 c->resolved_sym = sym;
3528 pure_subroutine (c, sym);
3535 resolve_specific_s (gfc_code *c)
3540 sym = c->symtree->n.sym;
3544 m = resolve_specific_s0 (c, sym);
3547 if (m == MATCH_ERROR)
3550 if (sym->ns->parent == NULL)
3553 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3559 sym = c->symtree->n.sym;
3560 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3561 sym->name, &c->loc);
3567 /* Resolve a subroutine call not known to be generic nor specific. */
3570 resolve_unknown_s (gfc_code *c)
3574 sym = c->symtree->n.sym;
3576 if (sym->attr.dummy)
3578 sym->attr.proc = PROC_DUMMY;
3582 /* See if we have an intrinsic function reference. */
3584 if (gfc_is_intrinsic (sym, 1, c->loc))
3586 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3591 /* The reference is to an external name. */
3594 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3596 c->resolved_sym = sym;
3598 pure_subroutine (c, sym);
3604 /* Resolve a subroutine call. Although it was tempting to use the same code
3605 for functions, subroutines and functions are stored differently and this
3606 makes things awkward. */
3609 resolve_call (gfc_code *c)
3612 procedure_type ptype = PROC_INTRINSIC;
3613 gfc_symbol *csym, *sym;
3614 bool no_formal_args;
3616 csym = c->symtree ? c->symtree->n.sym : NULL;
3618 if (csym && csym->ts.type != BT_UNKNOWN)
3620 gfc_error ("'%s' at %L has a type, which is not consistent with "
3621 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3625 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3628 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3629 sym = st ? st->n.sym : NULL;
3630 if (sym && csym != sym
3631 && sym->ns == gfc_current_ns
3632 && sym->attr.flavor == FL_PROCEDURE
3633 && sym->attr.contained)
3636 if (csym->attr.generic)
3637 c->symtree->n.sym = sym;
3640 csym = c->symtree->n.sym;
3644 /* If this ia a deferred TBP with an abstract interface
3645 (which may of course be referenced), c->expr1 will be set. */
3646 if (csym && csym->attr.abstract && !c->expr1)
3648 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3649 csym->name, &c->loc);
3653 /* Subroutines without the RECURSIVE attribution are not allowed to
3654 * call themselves. */
3655 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3657 if (csym->attr.entry && csym->ns->entries)
3658 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3659 " subroutine '%s' is not RECURSIVE",
3660 csym->name, &c->loc, csym->ns->entries->sym->name);
3662 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3663 " is not RECURSIVE", csym->name, &c->loc);
3668 /* Switch off assumed size checking and do this again for certain kinds
3669 of procedure, once the procedure itself is resolved. */
3670 need_full_assumed_size++;
3673 ptype = csym->attr.proc;
3675 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3676 if (resolve_actual_arglist (c->ext.actual, ptype,
3677 no_formal_args) == FAILURE)
3680 /* Resume assumed_size checking. */
3681 need_full_assumed_size--;
3683 /* If external, check for usage. */
3684 if (csym && is_external_proc (csym))
3685 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3688 if (c->resolved_sym == NULL)
3690 c->resolved_isym = NULL;
3691 switch (procedure_kind (csym))
3694 t = resolve_generic_s (c);
3697 case PTYPE_SPECIFIC:
3698 t = resolve_specific_s (c);
3702 t = resolve_unknown_s (c);
3706 gfc_internal_error ("resolve_subroutine(): bad function type");
3710 /* Some checks of elemental subroutine actual arguments. */
3711 if (resolve_elemental_actual (NULL, c) == FAILURE)
3718 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3719 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3720 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3721 if their shapes do not match. If either op1->shape or op2->shape is
3722 NULL, return SUCCESS. */
3725 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3732 if (op1->shape != NULL && op2->shape != NULL)
3734 for (i = 0; i < op1->rank; i++)
3736 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3738 gfc_error ("Shapes for operands at %L and %L are not conformable",
3739 &op1->where, &op2->where);
3750 /* Resolve an operator expression node. This can involve replacing the
3751 operation with a user defined function call. */
3754 resolve_operator (gfc_expr *e)
3756 gfc_expr *op1, *op2;
3758 bool dual_locus_error;
3761 /* Resolve all subnodes-- give them types. */
3763 switch (e->value.op.op)
3766 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3769 /* Fall through... */
3772 case INTRINSIC_UPLUS:
3773 case INTRINSIC_UMINUS:
3774 case INTRINSIC_PARENTHESES:
3775 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3780 /* Typecheck the new node. */
3782 op1 = e->value.op.op1;
3783 op2 = e->value.op.op2;
3784 dual_locus_error = false;
3786 if ((op1 && op1->expr_type == EXPR_NULL)
3787 || (op2 && op2->expr_type == EXPR_NULL))
3789 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3793 switch (e->value.op.op)
3795 case INTRINSIC_UPLUS:
3796 case INTRINSIC_UMINUS:
3797 if (op1->ts.type == BT_INTEGER
3798 || op1->ts.type == BT_REAL
3799 || op1->ts.type == BT_COMPLEX)
3805 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3806 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3809 case INTRINSIC_PLUS:
3810 case INTRINSIC_MINUS:
3811 case INTRINSIC_TIMES:
3812 case INTRINSIC_DIVIDE:
3813 case INTRINSIC_POWER:
3814 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3816 gfc_type_convert_binary (e, 1);
3821 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3822 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3823 gfc_typename (&op2->ts));
3826 case INTRINSIC_CONCAT:
3827 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3828 && op1->ts.kind == op2->ts.kind)
3830 e->ts.type = BT_CHARACTER;
3831 e->ts.kind = op1->ts.kind;
3836 _("Operands of string concatenation operator at %%L are %s/%s"),
3837 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3843 case INTRINSIC_NEQV:
3844 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3846 e->ts.type = BT_LOGICAL;
3847 e->ts.kind = gfc_kind_max (op1, op2);
3848 if (op1->ts.kind < e->ts.kind)
3849 gfc_convert_type (op1, &e->ts, 2);
3850 else if (op2->ts.kind < e->ts.kind)
3851 gfc_convert_type (op2, &e->ts, 2);
3855 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3856 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3857 gfc_typename (&op2->ts));
3862 if (op1->ts.type == BT_LOGICAL)
3864 e->ts.type = BT_LOGICAL;
3865 e->ts.kind = op1->ts.kind;
3869 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3870 gfc_typename (&op1->ts));
3874 case INTRINSIC_GT_OS:
3876 case INTRINSIC_GE_OS:
3878 case INTRINSIC_LT_OS:
3880 case INTRINSIC_LE_OS:
3881 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3883 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3887 /* Fall through... */
3890 case INTRINSIC_EQ_OS:
3892 case INTRINSIC_NE_OS:
3893 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3894 && op1->ts.kind == op2->ts.kind)
3896 e->ts.type = BT_LOGICAL;
3897 e->ts.kind = gfc_default_logical_kind;
3901 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3903 gfc_type_convert_binary (e, 1);
3905 e->ts.type = BT_LOGICAL;
3906 e->ts.kind = gfc_default_logical_kind;
3910 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3912 _("Logicals at %%L must be compared with %s instead of %s"),
3913 (e->value.op.op == INTRINSIC_EQ
3914 || e->value.op.op == INTRINSIC_EQ_OS)
3915 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3918 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3919 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3920 gfc_typename (&op2->ts));
3924 case INTRINSIC_USER:
3925 if (e->value.op.uop->op == NULL)
3926 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3927 else if (op2 == NULL)
3928 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3929 e->value.op.uop->name, gfc_typename (&op1->ts));
3932 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3933 e->value.op.uop->name, gfc_typename (&op1->ts),
3934 gfc_typename (&op2->ts));
3935 e->value.op.uop->op->sym->attr.referenced = 1;
3940 case INTRINSIC_PARENTHESES:
3942 if (e->ts.type == BT_CHARACTER)
3943 e->ts.u.cl = op1->ts.u.cl;
3947 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3950 /* Deal with arrayness of an operand through an operator. */
3954 switch (e->value.op.op)
3956 case INTRINSIC_PLUS:
3957 case INTRINSIC_MINUS:
3958 case INTRINSIC_TIMES:
3959 case INTRINSIC_DIVIDE:
3960 case INTRINSIC_POWER:
3961 case INTRINSIC_CONCAT:
3965 case INTRINSIC_NEQV:
3967 case INTRINSIC_EQ_OS:
3969 case INTRINSIC_NE_OS:
3971 case INTRINSIC_GT_OS:
3973 case INTRINSIC_GE_OS:
3975 case INTRINSIC_LT_OS:
3977 case INTRINSIC_LE_OS:
3979 if (op1->rank == 0 && op2->rank == 0)
3982 if (op1->rank == 0 && op2->rank != 0)
3984 e->rank = op2->rank;
3986 if (e->shape == NULL)
3987 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3990 if (op1->rank != 0 && op2->rank == 0)
3992 e->rank = op1->rank;
3994 if (e->shape == NULL)
3995 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3998 if (op1->rank != 0 && op2->rank != 0)
4000 if (op1->rank == op2->rank)
4002 e->rank = op1->rank;
4003 if (e->shape == NULL)
4005 t = compare_shapes (op1, op2);
4009 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4014 /* Allow higher level expressions to work. */
4017 /* Try user-defined operators, and otherwise throw an error. */
4018 dual_locus_error = true;
4020 _("Inconsistent ranks for operator at %%L and %%L"));
4027 case INTRINSIC_PARENTHESES:
4029 case INTRINSIC_UPLUS:
4030 case INTRINSIC_UMINUS:
4031 /* Simply copy arrayness attribute */
4032 e->rank = op1->rank;
4034 if (e->shape == NULL)
4035 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4043 /* Attempt to simplify the expression. */
4046 t = gfc_simplify_expr (e, 0);
4047 /* Some calls do not succeed in simplification and return FAILURE
4048 even though there is no error; e.g. variable references to
4049 PARAMETER arrays. */
4050 if (!gfc_is_constant_expr (e))
4058 match m = gfc_extend_expr (e);
4061 if (m == MATCH_ERROR)
4065 if (dual_locus_error)
4066 gfc_error (msg, &op1->where, &op2->where);
4068 gfc_error (msg, &e->where);
4074 /************** Array resolution subroutines **************/
4077 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
4080 /* Compare two integer expressions. */
4083 compare_bound (gfc_expr *a, gfc_expr *b)
4087 if (a == NULL || a->expr_type != EXPR_CONSTANT
4088 || b == NULL || b->expr_type != EXPR_CONSTANT)
4091 /* If either of the types isn't INTEGER, we must have
4092 raised an error earlier. */
4094 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
4097 i = mpz_cmp (a->value.integer, b->value.integer);
4107 /* Compare an integer expression with an integer. */
4110 compare_bound_int (gfc_expr *a, int b)
4114 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4117 if (a->ts.type != BT_INTEGER)
4118 gfc_internal_error ("compare_bound_int(): Bad expression");
4120 i = mpz_cmp_si (a->value.integer, b);
4130 /* Compare an integer expression with a mpz_t. */
4133 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4137 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4140 if (a->ts.type != BT_INTEGER)
4141 gfc_internal_error ("compare_bound_int(): Bad expression");
4143 i = mpz_cmp (a->value.integer, b);
4153 /* Compute the last value of a sequence given by a triplet.
4154 Return 0 if it wasn't able to compute the last value, or if the
4155 sequence if empty, and 1 otherwise. */
4158 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4159 gfc_expr *stride, mpz_t last)
4163 if (start == NULL || start->expr_type != EXPR_CONSTANT
4164 || end == NULL || end->expr_type != EXPR_CONSTANT
4165 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4168 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4169 || (stride != NULL && stride->ts.type != BT_INTEGER))
4172 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
4174 if (compare_bound (start, end) == CMP_GT)
4176 mpz_set (last, end->value.integer);
4180 if (compare_bound_int (stride, 0) == CMP_GT)
4182 /* Stride is positive */
4183 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4188 /* Stride is negative */
4189 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4194 mpz_sub (rem, end->value.integer, start->value.integer);
4195 mpz_tdiv_r (rem, rem, stride->value.integer);
4196 mpz_sub (last, end->value.integer, rem);
4203 /* Compare a single dimension of an array reference to the array
4207 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4211 if (ar->dimen_type[i] == DIMEN_STAR)
4213 gcc_assert (ar->stride[i] == NULL);
4214 /* This implies [*] as [*:] and [*:3] are not possible. */
4215 if (ar->start[i] == NULL)
4217 gcc_assert (ar->end[i] == NULL);
4222 /* Given start, end and stride values, calculate the minimum and
4223 maximum referenced indexes. */
4225 switch (ar->dimen_type[i])
4228 case DIMEN_THIS_IMAGE:
4233 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4236 gfc_warning ("Array reference at %L is out of bounds "
4237 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4238 mpz_get_si (ar->start[i]->value.integer),
4239 mpz_get_si (as->lower[i]->value.integer), i+1);
4241 gfc_warning ("Array reference at %L is out of bounds "
4242 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4243 mpz_get_si (ar->start[i]->value.integer),
4244 mpz_get_si (as->lower[i]->value.integer),
4248 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4251 gfc_warning ("Array reference at %L is out of bounds "
4252 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4253 mpz_get_si (ar->start[i]->value.integer),
4254 mpz_get_si (as->upper[i]->value.integer), i+1);
4256 gfc_warning ("Array reference at %L is out of bounds "
4257 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4258 mpz_get_si (ar->start[i]->value.integer),
4259 mpz_get_si (as->upper[i]->value.integer),
4268 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4269 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4271 comparison comp_start_end = compare_bound (AR_START, AR_END);
4273 /* Check for zero stride, which is not allowed. */
4274 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4276 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4280 /* if start == len || (stride > 0 && start < len)
4281 || (stride < 0 && start > len),
4282 then the array section contains at least one element. In this
4283 case, there is an out-of-bounds access if
4284 (start < lower || start > upper). */
4285 if (compare_bound (AR_START, AR_END) == CMP_EQ
4286 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4287 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4288 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4289 && comp_start_end == CMP_GT))
4291 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4293 gfc_warning ("Lower array reference at %L is out of bounds "
4294 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4295 mpz_get_si (AR_START->value.integer),
4296 mpz_get_si (as->lower[i]->value.integer), i+1);
4299 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4301 gfc_warning ("Lower array reference at %L is out of bounds "
4302 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4303 mpz_get_si (AR_START->value.integer),
4304 mpz_get_si (as->upper[i]->value.integer), i+1);
4309 /* If we can compute the highest index of the array section,
4310 then it also has to be between lower and upper. */
4311 mpz_init (last_value);
4312 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4315 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4317 gfc_warning ("Upper array reference at %L is out of bounds "
4318 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4319 mpz_get_si (last_value),
4320 mpz_get_si (as->lower[i]->value.integer), i+1);
4321 mpz_clear (last_value);
4324 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4326 gfc_warning ("Upper array reference at %L is out of bounds "
4327 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4328 mpz_get_si (last_value),
4329 mpz_get_si (as->upper[i]->value.integer), i+1);
4330 mpz_clear (last_value);
4334 mpz_clear (last_value);
4342 gfc_internal_error ("check_dimension(): Bad array reference");
4349 /* Compare an array reference with an array specification. */
4352 compare_spec_to_ref (gfc_array_ref *ar)
4359 /* TODO: Full array sections are only allowed as actual parameters. */
4360 if (as->type == AS_ASSUMED_SIZE
4361 && (/*ar->type == AR_FULL
4362 ||*/ (ar->type == AR_SECTION
4363 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4365 gfc_error ("Rightmost upper bound of assumed size array section "
4366 "not specified at %L", &ar->where);
4370 if (ar->type == AR_FULL)
4373 if (as->rank != ar->dimen)
4375 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4376 &ar->where, ar->dimen, as->rank);
4380 /* ar->codimen == 0 is a local array. */
4381 if (as->corank != ar->codimen && ar->codimen != 0)
4383 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4384 &ar->where, ar->codimen, as->corank);
4388 for (i = 0; i < as->rank; i++)
4389 if (check_dimension (i, ar, as) == FAILURE)
4392 /* Local access has no coarray spec. */
4393 if (ar->codimen != 0)
4394 for (i = as->rank; i < as->rank + as->corank; i++)
4396 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
4397 && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
4399 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4400 i + 1 - as->rank, &ar->where);
4403 if (check_dimension (i, ar, as) == FAILURE)
4411 /* Resolve one part of an array index. */
4414 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4415 int force_index_integer_kind)
4422 if (gfc_resolve_expr (index) == FAILURE)
4425 if (check_scalar && index->rank != 0)
4427 gfc_error ("Array index at %L must be scalar", &index->where);
4431 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4433 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4434 &index->where, gfc_basic_typename (index->ts.type));
4438 if (index->ts.type == BT_REAL)
4439 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
4440 &index->where) == FAILURE)
4443 if ((index->ts.kind != gfc_index_integer_kind
4444 && force_index_integer_kind)
4445 || index->ts.type != BT_INTEGER)
4448 ts.type = BT_INTEGER;
4449 ts.kind = gfc_index_integer_kind;
4451 gfc_convert_type_warn (index, &ts, 2, 0);
4457 /* Resolve one part of an array index. */
4460 gfc_resolve_index (gfc_expr *index, int check_scalar)
4462 return gfc_resolve_index_1 (index, check_scalar, 1);
4465 /* Resolve a dim argument to an intrinsic function. */
4468 gfc_resolve_dim_arg (gfc_expr *dim)
4473 if (gfc_resolve_expr (dim) == FAILURE)
4478 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4483 if (dim->ts.type != BT_INTEGER)
4485 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4489 if (dim->ts.kind != gfc_index_integer_kind)
4494 ts.type = BT_INTEGER;
4495 ts.kind = gfc_index_integer_kind;
4497 gfc_convert_type_warn (dim, &ts, 2, 0);
4503 /* Given an expression that contains array references, update those array
4504 references to point to the right array specifications. While this is
4505 filled in during matching, this information is difficult to save and load
4506 in a module, so we take care of it here.
4508 The idea here is that the original array reference comes from the
4509 base symbol. We traverse the list of reference structures, setting
4510 the stored reference to references. Component references can
4511 provide an additional array specification. */
4514 find_array_spec (gfc_expr *e)
4520 if (e->symtree->n.sym->ts.type == BT_CLASS)
4521 as = CLASS_DATA (e->symtree->n.sym)->as;
4523 as = e->symtree->n.sym->as;
4525 for (ref = e->ref; ref; ref = ref->next)
4530 gfc_internal_error ("find_array_spec(): Missing spec");
4537 c = ref->u.c.component;
4538 if (c->attr.dimension)
4541 gfc_internal_error ("find_array_spec(): unused as(1)");
4552 gfc_internal_error ("find_array_spec(): unused as(2)");
4556 /* Resolve an array reference. */
4559 resolve_array_ref (gfc_array_ref *ar)
4561 int i, check_scalar;
4564 for (i = 0; i < ar->dimen + ar->codimen; i++)
4566 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4568 /* Do not force gfc_index_integer_kind for the start. We can
4569 do fine with any integer kind. This avoids temporary arrays
4570 created for indexing with a vector. */
4571 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4573 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4575 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4580 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4584 ar->dimen_type[i] = DIMEN_ELEMENT;
4588 ar->dimen_type[i] = DIMEN_VECTOR;
4589 if (e->expr_type == EXPR_VARIABLE
4590 && e->symtree->n.sym->ts.type == BT_DERIVED)
4591 ar->start[i] = gfc_get_parentheses (e);
4595 gfc_error ("Array index at %L is an array of rank %d",
4596 &ar->c_where[i], e->rank);
4600 /* Fill in the upper bound, which may be lower than the
4601 specified one for something like a(2:10:5), which is
4602 identical to a(2:7:5). Only relevant for strides not equal
4603 to one. Don't try a division by zero. */
4604 if (ar->dimen_type[i] == DIMEN_RANGE
4605 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4606 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
4607 && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
4611 if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4613 if (ar->end[i] == NULL)
4616 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4618 mpz_set (ar->end[i]->value.integer, end);
4620 else if (ar->end[i]->ts.type == BT_INTEGER
4621 && ar->end[i]->expr_type == EXPR_CONSTANT)
4623 mpz_set (ar->end[i]->value.integer, end);
4634 if (ar->type == AR_FULL)
4636 if (ar->as->rank == 0)
4637 ar->type = AR_ELEMENT;
4639 /* Make sure array is the same as array(:,:), this way
4640 we don't need to special case all the time. */
4641 ar->dimen = ar->as->rank;
4642 for (i = 0; i < ar->dimen; i++)
4644 ar->dimen_type[i] = DIMEN_RANGE;
4646 gcc_assert (ar->start[i] == NULL);
4647 gcc_assert (ar->end[i] == NULL);
4648 gcc_assert (ar->stride[i] == NULL);
4652 /* If the reference type is unknown, figure out what kind it is. */
4654 if (ar->type == AR_UNKNOWN)
4656 ar->type = AR_ELEMENT;
4657 for (i = 0; i < ar->dimen; i++)
4658 if (ar->dimen_type[i] == DIMEN_RANGE
4659 || ar->dimen_type[i] == DIMEN_VECTOR)
4661 ar->type = AR_SECTION;
4666 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4669 if (ar->as->corank && ar->codimen == 0)
4672 ar->codimen = ar->as->corank;
4673 for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
4674 ar->dimen_type[n] = DIMEN_THIS_IMAGE;
4682 resolve_substring (gfc_ref *ref)
4684 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4686 if (ref->u.ss.start != NULL)
4688 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4691 if (ref->u.ss.start->ts.type != BT_INTEGER)
4693 gfc_error ("Substring start index at %L must be of type INTEGER",
4694 &ref->u.ss.start->where);
4698 if (ref->u.ss.start->rank != 0)
4700 gfc_error ("Substring start index at %L must be scalar",
4701 &ref->u.ss.start->where);
4705 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4706 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4707 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4709 gfc_error ("Substring start index at %L is less than one",
4710 &ref->u.ss.start->where);
4715 if (ref->u.ss.end != NULL)
4717 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4720 if (ref->u.ss.end->ts.type != BT_INTEGER)
4722 gfc_error ("Substring end index at %L must be of type INTEGER",
4723 &ref->u.ss.end->where);
4727 if (ref->u.ss.end->rank != 0)
4729 gfc_error ("Substring end index at %L must be scalar",
4730 &ref->u.ss.end->where);
4734 if (ref->u.ss.length != NULL
4735 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4736 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4737 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4739 gfc_error ("Substring end index at %L exceeds the string length",
4740 &ref->u.ss.start->where);
4744 if (compare_bound_mpz_t (ref->u.ss.end,
4745 gfc_integer_kinds[k].huge) == CMP_GT
4746 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4747 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4749 gfc_error ("Substring end index at %L is too large",
4750 &ref->u.ss.end->where);
4759 /* This function supplies missing substring charlens. */
4762 gfc_resolve_substring_charlen (gfc_expr *e)
4765 gfc_expr *start, *end;
4767 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4768 if (char_ref->type == REF_SUBSTRING)
4774 gcc_assert (char_ref->next == NULL);
4778 if (e->ts.u.cl->length)
4779 gfc_free_expr (e->ts.u.cl->length);
4780 else if (e->expr_type == EXPR_VARIABLE
4781 && e->symtree->n.sym->attr.dummy)
4785 e->ts.type = BT_CHARACTER;
4786 e->ts.kind = gfc_default_character_kind;
4789 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4791 if (char_ref->u.ss.start)
4792 start = gfc_copy_expr (char_ref->u.ss.start);
4794 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4796 if (char_ref->u.ss.end)
4797 end = gfc_copy_expr (char_ref->u.ss.end);
4798 else if (e->expr_type == EXPR_VARIABLE)
4799 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4806 /* Length = (end - start +1). */
4807 e->ts.u.cl->length = gfc_subtract (end, start);
4808 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4809 gfc_get_int_expr (gfc_default_integer_kind,
4812 e->ts.u.cl->length->ts.type = BT_INTEGER;
4813 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4815 /* Make sure that the length is simplified. */
4816 gfc_simplify_expr (e->ts.u.cl->length, 1);
4817 gfc_resolve_expr (e->ts.u.cl->length);
4821 /* Resolve subtype references. */
4824 resolve_ref (gfc_expr *expr)
4826 int current_part_dimension, n_components, seen_part_dimension;
4829 for (ref = expr->ref; ref; ref = ref->next)
4830 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4832 find_array_spec (expr);
4836 for (ref = expr->ref; ref; ref = ref->next)
4840 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4848 if (resolve_substring (ref) == FAILURE)
4853 /* Check constraints on part references. */
4855 current_part_dimension = 0;
4856 seen_part_dimension = 0;
4859 for (ref = expr->ref; ref; ref = ref->next)
4864 switch (ref->u.ar.type)
4867 /* Coarray scalar. */
4868 if (ref->u.ar.as->rank == 0)
4870 current_part_dimension = 0;
4875 current_part_dimension = 1;
4879 current_part_dimension = 0;
4883 gfc_internal_error ("resolve_ref(): Bad array reference");
4889 if (current_part_dimension || seen_part_dimension)
4892 if (ref->u.c.component->attr.pointer
4893 || ref->u.c.component->attr.proc_pointer)
4895 gfc_error ("Component to the right of a part reference "
4896 "with nonzero rank must not have the POINTER "
4897 "attribute at %L", &expr->where);
4900 else if (ref->u.c.component->attr.allocatable)
4902 gfc_error ("Component to the right of a part reference "
4903 "with nonzero rank must not have the ALLOCATABLE "
4904 "attribute at %L", &expr->where);
4916 if (((ref->type == REF_COMPONENT && n_components > 1)
4917 || ref->next == NULL)
4918 && current_part_dimension
4919 && seen_part_dimension)
4921 gfc_error ("Two or more part references with nonzero rank must "
4922 "not be specified at %L", &expr->where);
4926 if (ref->type == REF_COMPONENT)
4928 if (current_part_dimension)
4929 seen_part_dimension = 1;
4931 /* reset to make sure */
4932 current_part_dimension = 0;
4940 /* Given an expression, determine its shape. This is easier than it sounds.
4941 Leaves the shape array NULL if it is not possible to determine the shape. */
4944 expression_shape (gfc_expr *e)
4946 mpz_t array[GFC_MAX_DIMENSIONS];
4949 if (e->rank == 0 || e->shape != NULL)
4952 for (i = 0; i < e->rank; i++)
4953 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4956 e->shape = gfc_get_shape (e->rank);
4958 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4963 for (i--; i >= 0; i--)
4964 mpz_clear (array[i]);
4968 /* Given a variable expression node, compute the rank of the expression by
4969 examining the base symbol and any reference structures it may have. */
4972 expression_rank (gfc_expr *e)
4977 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4978 could lead to serious confusion... */
4979 gcc_assert (e->expr_type != EXPR_COMPCALL);
4983 if (e->expr_type == EXPR_ARRAY)
4985 /* Constructors can have a rank different from one via RESHAPE(). */
4987 if (e->symtree == NULL)
4993 e->rank = (e->symtree->n.sym->as == NULL)
4994 ? 0 : e->symtree->n.sym->as->rank;
5000 for (ref = e->ref; ref; ref = ref->next)
5002 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
5003 && ref->u.c.component->attr.function && !ref->next)
5004 rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
5006 if (ref->type != REF_ARRAY)
5009 if (ref->u.ar.type == AR_FULL)
5011 rank = ref->u.ar.as->rank;
5015 if (ref->u.ar.type == AR_SECTION)
5017 /* Figure out the rank of the section. */
5019 gfc_internal_error ("expression_rank(): Two array specs");
5021 for (i = 0; i < ref->u.ar.dimen; i++)
5022 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
5023 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
5033 expression_shape (e);
5037 /* Resolve a variable expression. */
5040 resolve_variable (gfc_expr *e)
5047 if (e->symtree == NULL)
5049 sym = e->symtree->n.sym;
5051 /* If this is an associate-name, it may be parsed with an array reference
5052 in error even though the target is scalar. Fail directly in this case. */
5053 if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
5056 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
5057 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
5059 /* On the other hand, the parser may not have known this is an array;
5060 in this case, we have to add a FULL reference. */
5061 if (sym->assoc && sym->attr.dimension && !e->ref)
5063 e->ref = gfc_get_ref ();
5064 e->ref->type = REF_ARRAY;
5065 e->ref->u.ar.type = AR_FULL;
5066 e->ref->u.ar.dimen = 0;
5069 if (e->ref && resolve_ref (e) == FAILURE)
5072 if (sym->attr.flavor == FL_PROCEDURE
5073 && (!sym->attr.function
5074 || (sym->attr.function && sym->result
5075 && sym->result->attr.proc_pointer
5076 && !sym->result->attr.function)))
5078 e->ts.type = BT_PROCEDURE;
5079 goto resolve_procedure;
5082 if (sym->ts.type != BT_UNKNOWN)
5083 gfc_variable_attr (e, &e->ts);
5086 /* Must be a simple variable reference. */
5087 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
5092 if (check_assumed_size_reference (sym, e))
5095 /* Deal with forward references to entries during resolve_code, to
5096 satisfy, at least partially, 12.5.2.5. */
5097 if (gfc_current_ns->entries
5098 && current_entry_id == sym->entry_id
5101 && cs_base->current->op != EXEC_ENTRY)
5103 gfc_entry_list *entry;
5104 gfc_formal_arglist *formal;
5108 /* If the symbol is a dummy... */
5109 if (sym->attr.dummy && sym->ns == gfc_current_ns)
5111 entry = gfc_current_ns->entries;
5114 /* ...test if the symbol is a parameter of previous entries. */
5115 for (; entry && entry->id <= current_entry_id; entry = entry->next)
5116 for (formal = entry->sym->formal; formal; formal = formal->next)
5118 if (formal->sym && sym->name == formal->sym->name)
5122 /* If it has not been seen as a dummy, this is an error. */
5125 if (specification_expr)
5126 gfc_error ("Variable '%s', used in a specification expression"
5127 ", is referenced at %L before the ENTRY statement "
5128 "in which it is a parameter",
5129 sym->name, &cs_base->current->loc);
5131 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5132 "statement in which it is a parameter",
5133 sym->name, &cs_base->current->loc);
5138 /* Now do the same check on the specification expressions. */
5139 specification_expr = 1;
5140 if (sym->ts.type == BT_CHARACTER
5141 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
5145 for (n = 0; n < sym->as->rank; n++)
5147 specification_expr = 1;
5148 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
5150 specification_expr = 1;
5151 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
5154 specification_expr = 0;
5157 /* Update the symbol's entry level. */
5158 sym->entry_id = current_entry_id + 1;
5161 /* If a symbol has been host_associated mark it. This is used latter,
5162 to identify if aliasing is possible via host association. */
5163 if (sym->attr.flavor == FL_VARIABLE
5164 && gfc_current_ns->parent
5165 && (gfc_current_ns->parent == sym->ns
5166 || (gfc_current_ns->parent->parent
5167 && gfc_current_ns->parent->parent == sym->ns)))
5168 sym->attr.host_assoc = 1;
5171 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
5174 /* F2008, C617 and C1229. */
5175 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5176 && gfc_is_coindexed (e))
5178 gfc_ref *ref, *ref2 = NULL;
5180 for (ref = e->ref; ref; ref = ref->next)
5182 if (ref->type == REF_COMPONENT)
5184 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5188 for ( ; ref; ref = ref->next)
5189 if (ref->type == REF_COMPONENT)
5192 /* Expression itself is not coindexed object. */
5193 if (ref && e->ts.type == BT_CLASS)
5195 gfc_error ("Polymorphic subobject of coindexed object at %L",
5200 /* Expression itself is coindexed object. */
5204 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5205 for ( ; c; c = c->next)
5206 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5208 gfc_error ("Coindexed object with polymorphic allocatable "
5209 "subcomponent at %L", &e->where);
5220 /* Checks to see that the correct symbol has been host associated.
5221 The only situation where this arises is that in which a twice
5222 contained function is parsed after the host association is made.
5223 Therefore, on detecting this, change the symbol in the expression
5224 and convert the array reference into an actual arglist if the old
5225 symbol is a variable. */
5227 check_host_association (gfc_expr *e)
5229 gfc_symbol *sym, *old_sym;
5233 gfc_actual_arglist *arg, *tail = NULL;
5234 bool retval = e->expr_type == EXPR_FUNCTION;
5236 /* If the expression is the result of substitution in
5237 interface.c(gfc_extend_expr) because there is no way in
5238 which the host association can be wrong. */
5239 if (e->symtree == NULL
5240 || e->symtree->n.sym == NULL
5241 || e->user_operator)
5244 old_sym = e->symtree->n.sym;
5246 if (gfc_current_ns->parent
5247 && old_sym->ns != gfc_current_ns)
5249 /* Use the 'USE' name so that renamed module symbols are
5250 correctly handled. */
5251 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5253 if (sym && old_sym != sym
5254 && sym->ts.type == old_sym->ts.type
5255 && sym->attr.flavor == FL_PROCEDURE
5256 && sym->attr.contained)
5258 /* Clear the shape, since it might not be valid. */
5259 gfc_free_shape (&e->shape, e->rank);
5261 /* Give the expression the right symtree! */
5262 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5263 gcc_assert (st != NULL);
5265 if (old_sym->attr.flavor == FL_PROCEDURE
5266 || e->expr_type == EXPR_FUNCTION)
5268 /* Original was function so point to the new symbol, since
5269 the actual argument list is already attached to the
5271 e->value.function.esym = NULL;
5276 /* Original was variable so convert array references into
5277 an actual arglist. This does not need any checking now
5278 since resolve_function will take care of it. */
5279 e->value.function.actual = NULL;
5280 e->expr_type = EXPR_FUNCTION;
5283 /* Ambiguity will not arise if the array reference is not
5284 the last reference. */
5285 for (ref = e->ref; ref; ref = ref->next)
5286 if (ref->type == REF_ARRAY && ref->next == NULL)
5289 gcc_assert (ref->type == REF_ARRAY);
5291 /* Grab the start expressions from the array ref and
5292 copy them into actual arguments. */
5293 for (n = 0; n < ref->u.ar.dimen; n++)
5295 arg = gfc_get_actual_arglist ();
5296 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5297 if (e->value.function.actual == NULL)
5298 tail = e->value.function.actual = arg;
5306 /* Dump the reference list and set the rank. */
5307 gfc_free_ref_list (e->ref);
5309 e->rank = sym->as ? sym->as->rank : 0;
5312 gfc_resolve_expr (e);
5316 /* This might have changed! */
5317 return e->expr_type == EXPR_FUNCTION;
5322 gfc_resolve_character_operator (gfc_expr *e)
5324 gfc_expr *op1 = e->value.op.op1;
5325 gfc_expr *op2 = e->value.op.op2;
5326 gfc_expr *e1 = NULL;
5327 gfc_expr *e2 = NULL;
5329 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5331 if (op1->ts.u.cl && op1->ts.u.cl->length)
5332 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5333 else if (op1->expr_type == EXPR_CONSTANT)
5334 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5335 op1->value.character.length);
5337 if (op2->ts.u.cl && op2->ts.u.cl->length)
5338 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5339 else if (op2->expr_type == EXPR_CONSTANT)
5340 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5341 op2->value.character.length);
5343 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5348 e->ts.u.cl->length = gfc_add (e1, e2);
5349 e->ts.u.cl->length->ts.type = BT_INTEGER;
5350 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5351 gfc_simplify_expr (e->ts.u.cl->length, 0);
5352 gfc_resolve_expr (e->ts.u.cl->length);
5358 /* Ensure that an character expression has a charlen and, if possible, a
5359 length expression. */
5362 fixup_charlen (gfc_expr *e)
5364 /* The cases fall through so that changes in expression type and the need
5365 for multiple fixes are picked up. In all circumstances, a charlen should
5366 be available for the middle end to hang a backend_decl on. */
5367 switch (e->expr_type)
5370 gfc_resolve_character_operator (e);
5373 if (e->expr_type == EXPR_ARRAY)
5374 gfc_resolve_character_array_constructor (e);
5376 case EXPR_SUBSTRING:
5377 if (!e->ts.u.cl && e->ref)
5378 gfc_resolve_substring_charlen (e);
5382 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5389 /* Update an actual argument to include the passed-object for type-bound
5390 procedures at the right position. */
5392 static gfc_actual_arglist*
5393 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5396 gcc_assert (argpos > 0);
5400 gfc_actual_arglist* result;
5402 result = gfc_get_actual_arglist ();
5406 result->name = name;
5412 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5414 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5419 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5422 extract_compcall_passed_object (gfc_expr* e)
5426 gcc_assert (e->expr_type == EXPR_COMPCALL);
5428 if (e->value.compcall.base_object)
5429 po = gfc_copy_expr (e->value.compcall.base_object);
5432 po = gfc_get_expr ();
5433 po->expr_type = EXPR_VARIABLE;
5434 po->symtree = e->symtree;
5435 po->ref = gfc_copy_ref (e->ref);
5436 po->where = e->where;
5439 if (gfc_resolve_expr (po) == FAILURE)
5446 /* Update the arglist of an EXPR_COMPCALL expression to include the
5450 update_compcall_arglist (gfc_expr* e)
5453 gfc_typebound_proc* tbp;
5455 tbp = e->value.compcall.tbp;
5460 po = extract_compcall_passed_object (e);
5464 if (tbp->nopass || e->value.compcall.ignore_pass)
5470 gcc_assert (tbp->pass_arg_num > 0);
5471 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5479 /* Extract the passed object from a PPC call (a copy of it). */
5482 extract_ppc_passed_object (gfc_expr *e)
5487 po = gfc_get_expr ();
5488 po->expr_type = EXPR_VARIABLE;
5489 po->symtree = e->symtree;
5490 po->ref = gfc_copy_ref (e->ref);
5491 po->where = e->where;
5493 /* Remove PPC reference. */
5495 while ((*ref)->next)
5496 ref = &(*ref)->next;
5497 gfc_free_ref_list (*ref);
5500 if (gfc_resolve_expr (po) == FAILURE)
5507 /* Update the actual arglist of a procedure pointer component to include the
5511 update_ppc_arglist (gfc_expr* e)
5515 gfc_typebound_proc* tb;
5517 if (!gfc_is_proc_ptr_comp (e, &ppc))
5524 else if (tb->nopass)
5527 po = extract_ppc_passed_object (e);
5534 gfc_error ("Passed-object at %L must be scalar", &e->where);
5539 if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
5541 gfc_error ("Base object for procedure-pointer component call at %L is of"
5542 " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name);
5546 gcc_assert (tb->pass_arg_num > 0);
5547 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5555 /* Check that the object a TBP is called on is valid, i.e. it must not be
5556 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5559 check_typebound_baseobject (gfc_expr* e)
5562 gfc_try return_value = FAILURE;
5564 base = extract_compcall_passed_object (e);
5568 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5571 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5573 gfc_error ("Base object for type-bound procedure call at %L is of"
5574 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5578 /* F08:C1230. If the procedure called is NOPASS,
5579 the base object must be scalar. */
5580 if (e->value.compcall.tbp->nopass && base->rank > 0)
5582 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5583 " be scalar", &e->where);
5587 return_value = SUCCESS;
5590 gfc_free_expr (base);
5591 return return_value;
5595 /* Resolve a call to a type-bound procedure, either function or subroutine,
5596 statically from the data in an EXPR_COMPCALL expression. The adapted
5597 arglist and the target-procedure symtree are returned. */
5600 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5601 gfc_actual_arglist** actual)
5603 gcc_assert (e->expr_type == EXPR_COMPCALL);
5604 gcc_assert (!e->value.compcall.tbp->is_generic);
5606 /* Update the actual arglist for PASS. */
5607 if (update_compcall_arglist (e) == FAILURE)
5610 *actual = e->value.compcall.actual;
5611 *target = e->value.compcall.tbp->u.specific;
5613 gfc_free_ref_list (e->ref);
5615 e->value.compcall.actual = NULL;
5621 /* Get the ultimate declared type from an expression. In addition,
5622 return the last class/derived type reference and the copy of the
5625 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5628 gfc_symbol *declared;
5635 *new_ref = gfc_copy_ref (e->ref);
5637 for (ref = e->ref; ref; ref = ref->next)
5639 if (ref->type != REF_COMPONENT)
5642 if (ref->u.c.component->ts.type == BT_CLASS
5643 || ref->u.c.component->ts.type == BT_DERIVED)
5645 declared = ref->u.c.component->ts.u.derived;
5651 if (declared == NULL)
5652 declared = e->symtree->n.sym->ts.u.derived;
5658 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5659 which of the specific bindings (if any) matches the arglist and transform
5660 the expression into a call of that binding. */
5663 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5665 gfc_typebound_proc* genproc;
5666 const char* genname;
5668 gfc_symbol *derived;
5670 gcc_assert (e->expr_type == EXPR_COMPCALL);
5671 genname = e->value.compcall.name;
5672 genproc = e->value.compcall.tbp;
5674 if (!genproc->is_generic)
5677 /* Try the bindings on this type and in the inheritance hierarchy. */
5678 for (; genproc; genproc = genproc->overridden)
5682 gcc_assert (genproc->is_generic);
5683 for (g = genproc->u.generic; g; g = g->next)
5686 gfc_actual_arglist* args;
5689 gcc_assert (g->specific);
5691 if (g->specific->error)
5694 target = g->specific->u.specific->n.sym;
5696 /* Get the right arglist by handling PASS/NOPASS. */
5697 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5698 if (!g->specific->nopass)
5701 po = extract_compcall_passed_object (e);
5705 gcc_assert (g->specific->pass_arg_num > 0);
5706 gcc_assert (!g->specific->error);
5707 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5708 g->specific->pass_arg);
5710 resolve_actual_arglist (args, target->attr.proc,
5711 is_external_proc (target) && !target->formal);
5713 /* Check if this arglist matches the formal. */
5714 matches = gfc_arglist_matches_symbol (&args, target);
5716 /* Clean up and break out of the loop if we've found it. */
5717 gfc_free_actual_arglist (args);
5720 e->value.compcall.tbp = g->specific;
5721 genname = g->specific_st->name;
5722 /* Pass along the name for CLASS methods, where the vtab
5723 procedure pointer component has to be referenced. */
5731 /* Nothing matching found! */
5732 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5733 " '%s' at %L", genname, &e->where);
5737 /* Make sure that we have the right specific instance for the name. */
5738 derived = get_declared_from_expr (NULL, NULL, e);
5740 st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
5742 e->value.compcall.tbp = st->n.tb;
5748 /* Resolve a call to a type-bound subroutine. */
5751 resolve_typebound_call (gfc_code* c, const char **name)
5753 gfc_actual_arglist* newactual;
5754 gfc_symtree* target;
5756 /* Check that's really a SUBROUTINE. */
5757 if (!c->expr1->value.compcall.tbp->subroutine)
5759 gfc_error ("'%s' at %L should be a SUBROUTINE",
5760 c->expr1->value.compcall.name, &c->loc);
5764 if (check_typebound_baseobject (c->expr1) == FAILURE)
5767 /* Pass along the name for CLASS methods, where the vtab
5768 procedure pointer component has to be referenced. */
5770 *name = c->expr1->value.compcall.name;
5772 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5775 /* Transform into an ordinary EXEC_CALL for now. */
5777 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5780 c->ext.actual = newactual;
5781 c->symtree = target;
5782 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5784 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5786 gfc_free_expr (c->expr1);
5787 c->expr1 = gfc_get_expr ();
5788 c->expr1->expr_type = EXPR_FUNCTION;
5789 c->expr1->symtree = target;
5790 c->expr1->where = c->loc;
5792 return resolve_call (c);
5796 /* Resolve a component-call expression. */
5798 resolve_compcall (gfc_expr* e, const char **name)
5800 gfc_actual_arglist* newactual;
5801 gfc_symtree* target;
5803 /* Check that's really a FUNCTION. */
5804 if (!e->value.compcall.tbp->function)
5806 gfc_error ("'%s' at %L should be a FUNCTION",
5807 e->value.compcall.name, &e->where);
5811 /* These must not be assign-calls! */
5812 gcc_assert (!e->value.compcall.assign);
5814 if (check_typebound_baseobject (e) == FAILURE)
5817 /* Pass along the name for CLASS methods, where the vtab
5818 procedure pointer component has to be referenced. */
5820 *name = e->value.compcall.name;
5822 if (resolve_typebound_generic_call (e, name) == FAILURE)
5824 gcc_assert (!e->value.compcall.tbp->is_generic);
5826 /* Take the rank from the function's symbol. */
5827 if (e->value.compcall.tbp->u.specific->n.sym->as)
5828 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5830 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5831 arglist to the TBP's binding target. */
5833 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5836 e->value.function.actual = newactual;
5837 e->value.function.name = NULL;
5838 e->value.function.esym = target->n.sym;
5839 e->value.function.isym = NULL;
5840 e->symtree = target;
5841 e->ts = target->n.sym->ts;
5842 e->expr_type = EXPR_FUNCTION;
5844 /* Resolution is not necessary if this is a class subroutine; this
5845 function only has to identify the specific proc. Resolution of
5846 the call will be done next in resolve_typebound_call. */
5847 return gfc_resolve_expr (e);
5852 /* Resolve a typebound function, or 'method'. First separate all
5853 the non-CLASS references by calling resolve_compcall directly. */
5856 resolve_typebound_function (gfc_expr* e)
5858 gfc_symbol *declared;
5870 /* Deal with typebound operators for CLASS objects. */
5871 expr = e->value.compcall.base_object;
5872 overridable = !e->value.compcall.tbp->non_overridable;
5873 if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
5875 /* Since the typebound operators are generic, we have to ensure
5876 that any delays in resolution are corrected and that the vtab
5879 declared = ts.u.derived;
5880 c = gfc_find_component (declared, "_vptr", true, true);
5881 if (c->ts.u.derived == NULL)
5882 c->ts.u.derived = gfc_find_derived_vtab (declared);
5884 if (resolve_compcall (e, &name) == FAILURE)
5887 /* Use the generic name if it is there. */
5888 name = name ? name : e->value.function.esym->name;
5889 e->symtree = expr->symtree;
5890 e->ref = gfc_copy_ref (expr->ref);
5891 gfc_add_vptr_component (e);
5892 gfc_add_component_ref (e, name);
5893 e->value.function.esym = NULL;
5898 return resolve_compcall (e, NULL);
5900 if (resolve_ref (e) == FAILURE)
5903 /* Get the CLASS declared type. */
5904 declared = get_declared_from_expr (&class_ref, &new_ref, e);
5906 /* Weed out cases of the ultimate component being a derived type. */
5907 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5908 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5910 gfc_free_ref_list (new_ref);
5911 return resolve_compcall (e, NULL);
5914 c = gfc_find_component (declared, "_data", true, true);
5915 declared = c->ts.u.derived;
5917 /* Treat the call as if it is a typebound procedure, in order to roll
5918 out the correct name for the specific function. */
5919 if (resolve_compcall (e, &name) == FAILURE)
5925 /* Convert the expression to a procedure pointer component call. */
5926 e->value.function.esym = NULL;
5932 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5933 gfc_add_vptr_component (e);
5934 gfc_add_component_ref (e, name);
5936 /* Recover the typespec for the expression. This is really only
5937 necessary for generic procedures, where the additional call
5938 to gfc_add_component_ref seems to throw the collection of the
5939 correct typespec. */
5946 /* Resolve a typebound subroutine, or 'method'. First separate all
5947 the non-CLASS references by calling resolve_typebound_call
5951 resolve_typebound_subroutine (gfc_code *code)
5953 gfc_symbol *declared;
5963 st = code->expr1->symtree;
5965 /* Deal with typebound operators for CLASS objects. */
5966 expr = code->expr1->value.compcall.base_object;
5967 overridable = !code->expr1->value.compcall.tbp->non_overridable;
5968 if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
5970 /* Since the typebound operators are generic, we have to ensure
5971 that any delays in resolution are corrected and that the vtab
5973 declared = expr->ts.u.derived;
5974 c = gfc_find_component (declared, "_vptr", true, true);
5975 if (c->ts.u.derived == NULL)
5976 c->ts.u.derived = gfc_find_derived_vtab (declared);
5978 if (resolve_typebound_call (code, &name) == FAILURE)
5981 /* Use the generic name if it is there. */
5982 name = name ? name : code->expr1->value.function.esym->name;
5983 code->expr1->symtree = expr->symtree;
5984 code->expr1->ref = gfc_copy_ref (expr->ref);
5985 gfc_add_vptr_component (code->expr1);
5986 gfc_add_component_ref (code->expr1, name);
5987 code->expr1->value.function.esym = NULL;
5992 return resolve_typebound_call (code, NULL);
5994 if (resolve_ref (code->expr1) == FAILURE)
5997 /* Get the CLASS declared type. */
5998 get_declared_from_expr (&class_ref, &new_ref, code->expr1);
6000 /* Weed out cases of the ultimate component being a derived type. */
6001 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
6002 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
6004 gfc_free_ref_list (new_ref);
6005 return resolve_typebound_call (code, NULL);
6008 if (resolve_typebound_call (code, &name) == FAILURE)
6010 ts = code->expr1->ts;
6014 /* Convert the expression to a procedure pointer component call. */
6015 code->expr1->value.function.esym = NULL;
6016 code->expr1->symtree = st;
6019 code->expr1->ref = new_ref;
6021 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6022 gfc_add_vptr_component (code->expr1);
6023 gfc_add_component_ref (code->expr1, 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. */
6029 code->expr1->ts = ts;
6036 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6039 resolve_ppc_call (gfc_code* c)
6041 gfc_component *comp;
6044 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
6047 c->resolved_sym = c->expr1->symtree->n.sym;
6048 c->expr1->expr_type = EXPR_VARIABLE;
6050 if (!comp->attr.subroutine)
6051 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
6053 if (resolve_ref (c->expr1) == FAILURE)
6056 if (update_ppc_arglist (c->expr1) == FAILURE)
6059 c->ext.actual = c->expr1->value.compcall.actual;
6061 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
6062 comp->formal == NULL) == FAILURE)
6065 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
6071 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6074 resolve_expr_ppc (gfc_expr* e)
6076 gfc_component *comp;
6079 b = gfc_is_proc_ptr_comp (e, &comp);
6082 /* Convert to EXPR_FUNCTION. */
6083 e->expr_type = EXPR_FUNCTION;
6084 e->value.function.isym = NULL;
6085 e->value.function.actual = e->value.compcall.actual;
6087 if (comp->as != NULL)
6088 e->rank = comp->as->rank;
6090 if (!comp->attr.function)
6091 gfc_add_function (&comp->attr, comp->name, &e->where);
6093 if (resolve_ref (e) == FAILURE)
6096 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
6097 comp->formal == NULL) == FAILURE)
6100 if (update_ppc_arglist (e) == FAILURE)
6103 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
6110 gfc_is_expandable_expr (gfc_expr *e)
6112 gfc_constructor *con;
6114 if (e->expr_type == EXPR_ARRAY)
6116 /* Traverse the constructor looking for variables that are flavor
6117 parameter. Parameters must be expanded since they are fully used at
6119 con = gfc_constructor_first (e->value.constructor);
6120 for (; con; con = gfc_constructor_next (con))
6122 if (con->expr->expr_type == EXPR_VARIABLE
6123 && con->expr->symtree
6124 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6125 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
6127 if (con->expr->expr_type == EXPR_ARRAY
6128 && gfc_is_expandable_expr (con->expr))
6136 /* Resolve an expression. That is, make sure that types of operands agree
6137 with their operators, intrinsic operators are converted to function calls
6138 for overloaded types and unresolved function references are resolved. */
6141 gfc_resolve_expr (gfc_expr *e)
6149 /* inquiry_argument only applies to variables. */
6150 inquiry_save = inquiry_argument;
6151 if (e->expr_type != EXPR_VARIABLE)
6152 inquiry_argument = false;
6154 switch (e->expr_type)
6157 t = resolve_operator (e);
6163 if (check_host_association (e))
6164 t = resolve_function (e);
6167 t = resolve_variable (e);
6169 expression_rank (e);
6172 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6173 && e->ref->type != REF_SUBSTRING)
6174 gfc_resolve_substring_charlen (e);
6179 t = resolve_typebound_function (e);
6182 case EXPR_SUBSTRING:
6183 t = resolve_ref (e);
6192 t = resolve_expr_ppc (e);
6197 if (resolve_ref (e) == FAILURE)
6200 t = gfc_resolve_array_constructor (e);
6201 /* Also try to expand a constructor. */
6204 expression_rank (e);
6205 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6206 gfc_expand_constructor (e, false);
6209 /* This provides the opportunity for the length of constructors with
6210 character valued function elements to propagate the string length
6211 to the expression. */
6212 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6214 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6215 here rather then add a duplicate test for it above. */
6216 gfc_expand_constructor (e, false);
6217 t = gfc_resolve_character_array_constructor (e);
6222 case EXPR_STRUCTURE:
6223 t = resolve_ref (e);
6227 t = resolve_structure_cons (e, 0);
6231 t = gfc_simplify_expr (e, 0);
6235 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6238 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6241 inquiry_argument = inquiry_save;
6247 /* Resolve an expression from an iterator. They must be scalar and have
6248 INTEGER or (optionally) REAL type. */
6251 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6252 const char *name_msgid)
6254 if (gfc_resolve_expr (expr) == FAILURE)
6257 if (expr->rank != 0)
6259 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6263 if (expr->ts.type != BT_INTEGER)
6265 if (expr->ts.type == BT_REAL)
6268 return gfc_notify_std (GFC_STD_F95_DEL,
6269 "Deleted feature: %s at %L must be integer",
6270 _(name_msgid), &expr->where);
6273 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6280 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6288 /* Resolve the expressions in an iterator structure. If REAL_OK is
6289 false allow only INTEGER type iterators, otherwise allow REAL types. */
6292 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6294 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6298 if (gfc_check_vardef_context (iter->var, false, false, _("iterator variable"))
6302 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6303 "Start expression in DO loop") == FAILURE)
6306 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6307 "End expression in DO loop") == FAILURE)
6310 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6311 "Step expression in DO loop") == FAILURE)
6314 if (iter->step->expr_type == EXPR_CONSTANT)
6316 if ((iter->step->ts.type == BT_INTEGER
6317 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6318 || (iter->step->ts.type == BT_REAL
6319 && mpfr_sgn (iter->step->value.real) == 0))
6321 gfc_error ("Step expression in DO loop at %L cannot be zero",
6322 &iter->step->where);
6327 /* Convert start, end, and step to the same type as var. */
6328 if (iter->start->ts.kind != iter->var->ts.kind
6329 || iter->start->ts.type != iter->var->ts.type)
6330 gfc_convert_type (iter->start, &iter->var->ts, 2);
6332 if (iter->end->ts.kind != iter->var->ts.kind
6333 || iter->end->ts.type != iter->var->ts.type)
6334 gfc_convert_type (iter->end, &iter->var->ts, 2);
6336 if (iter->step->ts.kind != iter->var->ts.kind
6337 || iter->step->ts.type != iter->var->ts.type)
6338 gfc_convert_type (iter->step, &iter->var->ts, 2);
6340 if (iter->start->expr_type == EXPR_CONSTANT
6341 && iter->end->expr_type == EXPR_CONSTANT
6342 && iter->step->expr_type == EXPR_CONSTANT)
6345 if (iter->start->ts.type == BT_INTEGER)
6347 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6348 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6352 sgn = mpfr_sgn (iter->step->value.real);
6353 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6355 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6356 gfc_warning ("DO loop at %L will be executed zero times",
6357 &iter->step->where);
6364 /* Traversal function for find_forall_index. f == 2 signals that
6365 that variable itself is not to be checked - only the references. */
6368 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6370 if (expr->expr_type != EXPR_VARIABLE)
6373 /* A scalar assignment */
6374 if (!expr->ref || *f == 1)
6376 if (expr->symtree->n.sym == sym)
6388 /* Check whether the FORALL index appears in the expression or not.
6389 Returns SUCCESS if SYM is found in EXPR. */
6392 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6394 if (gfc_traverse_expr (expr, sym, forall_index, f))
6401 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6402 to be a scalar INTEGER variable. The subscripts and stride are scalar
6403 INTEGERs, and if stride is a constant it must be nonzero.
6404 Furthermore "A subscript or stride in a forall-triplet-spec shall
6405 not contain a reference to any index-name in the
6406 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6409 resolve_forall_iterators (gfc_forall_iterator *it)
6411 gfc_forall_iterator *iter, *iter2;
6413 for (iter = it; iter; iter = iter->next)
6415 if (gfc_resolve_expr (iter->var) == SUCCESS
6416 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6417 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6420 if (gfc_resolve_expr (iter->start) == SUCCESS
6421 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6422 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6423 &iter->start->where);
6424 if (iter->var->ts.kind != iter->start->ts.kind)
6425 gfc_convert_type (iter->start, &iter->var->ts, 1);
6427 if (gfc_resolve_expr (iter->end) == SUCCESS
6428 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6429 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6431 if (iter->var->ts.kind != iter->end->ts.kind)
6432 gfc_convert_type (iter->end, &iter->var->ts, 1);
6434 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6436 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6437 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6438 &iter->stride->where, "INTEGER");
6440 if (iter->stride->expr_type == EXPR_CONSTANT
6441 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6442 gfc_error ("FORALL stride expression at %L cannot be zero",
6443 &iter->stride->where);
6445 if (iter->var->ts.kind != iter->stride->ts.kind)
6446 gfc_convert_type (iter->stride, &iter->var->ts, 1);
6449 for (iter = it; iter; iter = iter->next)
6450 for (iter2 = iter; iter2; iter2 = iter2->next)
6452 if (find_forall_index (iter2->start,
6453 iter->var->symtree->n.sym, 0) == SUCCESS
6454 || find_forall_index (iter2->end,
6455 iter->var->symtree->n.sym, 0) == SUCCESS
6456 || find_forall_index (iter2->stride,
6457 iter->var->symtree->n.sym, 0) == SUCCESS)
6458 gfc_error ("FORALL index '%s' may not appear in triplet "
6459 "specification at %L", iter->var->symtree->name,
6460 &iter2->start->where);
6465 /* Given a pointer to a symbol that is a derived type, see if it's
6466 inaccessible, i.e. if it's defined in another module and the components are
6467 PRIVATE. The search is recursive if necessary. Returns zero if no
6468 inaccessible components are found, nonzero otherwise. */
6471 derived_inaccessible (gfc_symbol *sym)
6475 if (sym->attr.use_assoc && sym->attr.private_comp)
6478 for (c = sym->components; c; c = c->next)
6480 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6488 /* Resolve the argument of a deallocate expression. The expression must be
6489 a pointer or a full array. */
6492 resolve_deallocate_expr (gfc_expr *e)
6494 symbol_attribute attr;
6495 int allocatable, pointer;
6500 if (gfc_resolve_expr (e) == FAILURE)
6503 if (e->expr_type != EXPR_VARIABLE)
6506 sym = e->symtree->n.sym;
6508 if (sym->ts.type == BT_CLASS)
6510 allocatable = CLASS_DATA (sym)->attr.allocatable;
6511 pointer = CLASS_DATA (sym)->attr.class_pointer;
6515 allocatable = sym->attr.allocatable;
6516 pointer = sym->attr.pointer;
6518 for (ref = e->ref; ref; ref = ref->next)
6523 if (ref->u.ar.type != AR_FULL
6524 && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
6525 && ref->u.ar.codimen && gfc_ref_this_image (ref)))
6530 c = ref->u.c.component;
6531 if (c->ts.type == BT_CLASS)
6533 allocatable = CLASS_DATA (c)->attr.allocatable;
6534 pointer = CLASS_DATA (c)->attr.class_pointer;
6538 allocatable = c->attr.allocatable;
6539 pointer = c->attr.pointer;
6549 attr = gfc_expr_attr (e);
6551 if (allocatable == 0 && attr.pointer == 0)
6554 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6560 if (gfc_is_coindexed (e))
6562 gfc_error ("Coindexed allocatable object at %L", &e->where);
6567 && gfc_check_vardef_context (e, true, true, _("DEALLOCATE object"))
6570 if (gfc_check_vardef_context (e, false, true, _("DEALLOCATE object"))
6578 /* Returns true if the expression e contains a reference to the symbol sym. */
6580 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6582 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6589 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6591 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6595 /* Given the expression node e for an allocatable/pointer of derived type to be
6596 allocated, get the expression node to be initialized afterwards (needed for
6597 derived types with default initializers, and derived types with allocatable
6598 components that need nullification.) */
6601 gfc_expr_to_initialize (gfc_expr *e)
6607 result = gfc_copy_expr (e);
6609 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6610 for (ref = result->ref; ref; ref = ref->next)
6611 if (ref->type == REF_ARRAY && ref->next == NULL)
6613 ref->u.ar.type = AR_FULL;
6615 for (i = 0; i < ref->u.ar.dimen; i++)
6616 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6621 gfc_free_shape (&result->shape, result->rank);
6623 /* Recalculate rank, shape, etc. */
6624 gfc_resolve_expr (result);
6629 /* If the last ref of an expression is an array ref, return a copy of the
6630 expression with that one removed. Otherwise, a copy of the original
6631 expression. This is used for allocate-expressions and pointer assignment
6632 LHS, where there may be an array specification that needs to be stripped
6633 off when using gfc_check_vardef_context. */
6636 remove_last_array_ref (gfc_expr* e)
6641 e2 = gfc_copy_expr (e);
6642 for (r = &e2->ref; *r; r = &(*r)->next)
6643 if ((*r)->type == REF_ARRAY && !(*r)->next)
6645 gfc_free_ref_list (*r);
6654 /* Used in resolve_allocate_expr to check that a allocation-object and
6655 a source-expr are conformable. This does not catch all possible
6656 cases; in particular a runtime checking is needed. */
6659 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6662 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6664 /* First compare rank. */
6665 if (tail && e1->rank != tail->u.ar.as->rank)
6667 gfc_error ("Source-expr at %L must be scalar or have the "
6668 "same rank as the allocate-object at %L",
6669 &e1->where, &e2->where);
6680 for (i = 0; i < e1->rank; i++)
6682 if (tail->u.ar.end[i])
6684 mpz_set (s, tail->u.ar.end[i]->value.integer);
6685 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6686 mpz_add_ui (s, s, 1);
6690 mpz_set (s, tail->u.ar.start[i]->value.integer);
6693 if (mpz_cmp (e1->shape[i], s) != 0)
6695 gfc_error ("Source-expr at %L and allocate-object at %L must "
6696 "have the same shape", &e1->where, &e2->where);
6709 /* Resolve the expression in an ALLOCATE statement, doing the additional
6710 checks to see whether the expression is OK or not. The expression must
6711 have a trailing array reference that gives the size of the array. */
6714 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6716 int i, pointer, allocatable, dimension, is_abstract;
6719 symbol_attribute attr;
6720 gfc_ref *ref, *ref2;
6723 gfc_symbol *sym = NULL;
6728 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6729 checking of coarrays. */
6730 for (ref = e->ref; ref; ref = ref->next)
6731 if (ref->next == NULL)
6734 if (ref && ref->type == REF_ARRAY)
6735 ref->u.ar.in_allocate = true;
6737 if (gfc_resolve_expr (e) == FAILURE)
6740 /* Make sure the expression is allocatable or a pointer. If it is
6741 pointer, the next-to-last reference must be a pointer. */
6745 sym = e->symtree->n.sym;
6747 /* Check whether ultimate component is abstract and CLASS. */
6750 if (e->expr_type != EXPR_VARIABLE)
6753 attr = gfc_expr_attr (e);
6754 pointer = attr.pointer;
6755 dimension = attr.dimension;
6756 codimension = attr.codimension;
6760 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
6762 allocatable = CLASS_DATA (sym)->attr.allocatable;
6763 pointer = CLASS_DATA (sym)->attr.class_pointer;
6764 dimension = CLASS_DATA (sym)->attr.dimension;
6765 codimension = CLASS_DATA (sym)->attr.codimension;
6766 is_abstract = CLASS_DATA (sym)->attr.abstract;
6770 allocatable = sym->attr.allocatable;
6771 pointer = sym->attr.pointer;
6772 dimension = sym->attr.dimension;
6773 codimension = sym->attr.codimension;
6778 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6783 if (ref->u.ar.codimen > 0)
6786 for (n = ref->u.ar.dimen;
6787 n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
6788 if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
6795 if (ref->next != NULL)
6803 gfc_error ("Coindexed allocatable object at %L",
6808 c = ref->u.c.component;
6809 if (c->ts.type == BT_CLASS)
6811 allocatable = CLASS_DATA (c)->attr.allocatable;
6812 pointer = CLASS_DATA (c)->attr.class_pointer;
6813 dimension = CLASS_DATA (c)->attr.dimension;
6814 codimension = CLASS_DATA (c)->attr.codimension;
6815 is_abstract = CLASS_DATA (c)->attr.abstract;
6819 allocatable = c->attr.allocatable;
6820 pointer = c->attr.pointer;
6821 dimension = c->attr.dimension;
6822 codimension = c->attr.codimension;
6823 is_abstract = c->attr.abstract;
6835 if (allocatable == 0 && pointer == 0)
6837 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6842 /* Some checks for the SOURCE tag. */
6845 /* Check F03:C631. */
6846 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6848 gfc_error ("Type of entity at %L is type incompatible with "
6849 "source-expr at %L", &e->where, &code->expr3->where);
6853 /* Check F03:C632 and restriction following Note 6.18. */
6854 if (code->expr3->rank > 0
6855 && conformable_arrays (code->expr3, e) == FAILURE)
6858 /* Check F03:C633. */
6859 if (code->expr3->ts.kind != e->ts.kind)
6861 gfc_error ("The allocate-object at %L and the source-expr at %L "
6862 "shall have the same kind type parameter",
6863 &e->where, &code->expr3->where);
6867 /* Check F2008, C642. */
6868 if (code->expr3->ts.type == BT_DERIVED
6869 && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
6870 || (code->expr3->ts.u.derived->from_intmod
6871 == INTMOD_ISO_FORTRAN_ENV
6872 && code->expr3->ts.u.derived->intmod_sym_id
6873 == ISOFORTRAN_LOCK_TYPE)))
6875 gfc_error ("The source-expr at %L shall neither be of type "
6876 "LOCK_TYPE nor have a LOCK_TYPE component if "
6877 "allocate-object at %L is a coarray",
6878 &code->expr3->where, &e->where);
6883 /* Check F08:C629. */
6884 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
6887 gcc_assert (e->ts.type == BT_CLASS);
6888 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6889 "type-spec or source-expr", sym->name, &e->where);
6893 /* In the variable definition context checks, gfc_expr_attr is used
6894 on the expression. This is fooled by the array specification
6895 present in e, thus we have to eliminate that one temporarily. */
6896 e2 = remove_last_array_ref (e);
6898 if (t == SUCCESS && pointer)
6899 t = gfc_check_vardef_context (e2, true, true, _("ALLOCATE object"));
6901 t = gfc_check_vardef_context (e2, false, true, _("ALLOCATE object"));
6906 if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
6907 && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
6909 /* For class arrays, the initialization with SOURCE is done
6910 using _copy and trans_call. It is convenient to exploit that
6911 when the allocated type is different from the declared type but
6912 no SOURCE exists by setting expr3. */
6913 code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
6915 else if (!code->expr3)
6917 /* Set up default initializer if needed. */
6921 if (code->ext.alloc.ts.type == BT_DERIVED)
6922 ts = code->ext.alloc.ts;
6926 if (ts.type == BT_CLASS)
6927 ts = ts.u.derived->components->ts;
6929 if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
6931 gfc_code *init_st = gfc_get_code ();
6932 init_st->loc = code->loc;
6933 init_st->op = EXEC_INIT_ASSIGN;
6934 init_st->expr1 = gfc_expr_to_initialize (e);
6935 init_st->expr2 = init_e;
6936 init_st->next = code->next;
6937 code->next = init_st;
6940 else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
6942 /* Default initialization via MOLD (non-polymorphic). */
6943 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
6944 gfc_resolve_expr (rhs);
6945 gfc_free_expr (code->expr3);
6949 if (e->ts.type == BT_CLASS)
6951 /* Make sure the vtab symbol is present when
6952 the module variables are generated. */
6953 gfc_typespec ts = e->ts;
6955 ts = code->expr3->ts;
6956 else if (code->ext.alloc.ts.type == BT_DERIVED)
6957 ts = code->ext.alloc.ts;
6958 gfc_find_derived_vtab (ts.u.derived);
6960 e = gfc_expr_to_initialize (e);
6963 if (dimension == 0 && codimension == 0)
6966 /* Make sure the last reference node is an array specifiction. */
6968 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
6969 || (dimension && ref2->u.ar.dimen == 0))
6971 gfc_error ("Array specification required in ALLOCATE statement "
6972 "at %L", &e->where);
6976 /* Make sure that the array section reference makes sense in the
6977 context of an ALLOCATE specification. */
6982 for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
6983 if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
6985 gfc_error ("Coarray specification required in ALLOCATE statement "
6986 "at %L", &e->where);
6990 for (i = 0; i < ar->dimen; i++)
6992 if (ref2->u.ar.type == AR_ELEMENT)
6995 switch (ar->dimen_type[i])
7001 if (ar->start[i] != NULL
7002 && ar->end[i] != NULL
7003 && ar->stride[i] == NULL)
7006 /* Fall Through... */
7011 case DIMEN_THIS_IMAGE:
7012 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7018 for (a = code->ext.alloc.list; a; a = a->next)
7020 sym = a->expr->symtree->n.sym;
7022 /* TODO - check derived type components. */
7023 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
7026 if ((ar->start[i] != NULL
7027 && gfc_find_sym_in_expr (sym, ar->start[i]))
7028 || (ar->end[i] != NULL
7029 && gfc_find_sym_in_expr (sym, ar->end[i])))
7031 gfc_error ("'%s' must not appear in the array specification at "
7032 "%L in the same ALLOCATE statement where it is "
7033 "itself allocated", sym->name, &ar->where);
7039 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
7041 if (ar->dimen_type[i] == DIMEN_ELEMENT
7042 || ar->dimen_type[i] == DIMEN_RANGE)
7044 if (i == (ar->dimen + ar->codimen - 1))
7046 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7047 "statement at %L", &e->where);
7053 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
7054 && ar->stride[i] == NULL)
7057 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7070 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
7072 gfc_expr *stat, *errmsg, *pe, *qe;
7073 gfc_alloc *a, *p, *q;
7076 errmsg = code->expr2;
7078 /* Check the stat variable. */
7081 gfc_check_vardef_context (stat, false, false, _("STAT variable"));
7083 if ((stat->ts.type != BT_INTEGER
7084 && !(stat->ref && (stat->ref->type == REF_ARRAY
7085 || stat->ref->type == REF_COMPONENT)))
7087 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7088 "variable", &stat->where);
7090 for (p = code->ext.alloc.list; p; p = p->next)
7091 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
7093 gfc_ref *ref1, *ref2;
7096 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
7097 ref1 = ref1->next, ref2 = ref2->next)
7099 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7101 if (ref1->u.c.component->name != ref2->u.c.component->name)
7110 gfc_error ("Stat-variable at %L shall not be %sd within "
7111 "the same %s statement", &stat->where, fcn, fcn);
7117 /* Check the errmsg variable. */
7121 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7124 gfc_check_vardef_context (errmsg, false, false, _("ERRMSG variable"));
7126 if ((errmsg->ts.type != BT_CHARACTER
7128 && (errmsg->ref->type == REF_ARRAY
7129 || errmsg->ref->type == REF_COMPONENT)))
7130 || errmsg->rank > 0 )
7131 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7132 "variable", &errmsg->where);
7134 for (p = code->ext.alloc.list; p; p = p->next)
7135 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
7137 gfc_ref *ref1, *ref2;
7140 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
7141 ref1 = ref1->next, ref2 = ref2->next)
7143 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7145 if (ref1->u.c.component->name != ref2->u.c.component->name)
7154 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7155 "the same %s statement", &errmsg->where, fcn, fcn);
7161 /* Check that an allocate-object appears only once in the statement.
7162 FIXME: Checking derived types is disabled. */
7163 for (p = code->ext.alloc.list; p; p = p->next)
7166 for (q = p->next; q; q = q->next)
7169 if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
7171 /* This is a potential collision. */
7172 gfc_ref *pr = pe->ref;
7173 gfc_ref *qr = qe->ref;
7175 /* Follow the references until
7176 a) They start to differ, in which case there is no error;
7177 you can deallocate a%b and a%c in a single statement
7178 b) Both of them stop, which is an error
7179 c) One of them stops, which is also an error. */
7182 if (pr == NULL && qr == NULL)
7184 gfc_error ("Allocate-object at %L also appears at %L",
7185 &pe->where, &qe->where);
7188 else if (pr != NULL && qr == NULL)
7190 gfc_error ("Allocate-object at %L is subobject of"
7191 " object at %L", &pe->where, &qe->where);
7194 else if (pr == NULL && qr != NULL)
7196 gfc_error ("Allocate-object at %L is subobject of"
7197 " object at %L", &qe->where, &pe->where);
7200 /* Here, pr != NULL && qr != NULL */
7201 gcc_assert(pr->type == qr->type);
7202 if (pr->type == REF_ARRAY)
7204 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7206 gcc_assert (qr->type == REF_ARRAY);
7208 if (pr->next && qr->next)
7210 gfc_array_ref *par = &(pr->u.ar);
7211 gfc_array_ref *qar = &(qr->u.ar);
7212 if (gfc_dep_compare_expr (par->start[0],
7213 qar->start[0]) != 0)
7219 if (pr->u.c.component->name != qr->u.c.component->name)
7230 if (strcmp (fcn, "ALLOCATE") == 0)
7232 for (a = code->ext.alloc.list; a; a = a->next)
7233 resolve_allocate_expr (a->expr, code);
7237 for (a = code->ext.alloc.list; a; a = a->next)
7238 resolve_deallocate_expr (a->expr);
7243 /************ SELECT CASE resolution subroutines ************/
7245 /* Callback function for our mergesort variant. Determines interval
7246 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7247 op1 > op2. Assumes we're not dealing with the default case.
7248 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7249 There are nine situations to check. */
7252 compare_cases (const gfc_case *op1, const gfc_case *op2)
7256 if (op1->low == NULL) /* op1 = (:L) */
7258 /* op2 = (:N), so overlap. */
7260 /* op2 = (M:) or (M:N), L < M */
7261 if (op2->low != NULL
7262 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7265 else if (op1->high == NULL) /* op1 = (K:) */
7267 /* op2 = (M:), so overlap. */
7269 /* op2 = (:N) or (M:N), K > N */
7270 if (op2->high != NULL
7271 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7274 else /* op1 = (K:L) */
7276 if (op2->low == NULL) /* op2 = (:N), K > N */
7277 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7279 else if (op2->high == NULL) /* op2 = (M:), L < M */
7280 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7282 else /* op2 = (M:N) */
7286 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7289 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7298 /* Merge-sort a double linked case list, detecting overlap in the
7299 process. LIST is the head of the double linked case list before it
7300 is sorted. Returns the head of the sorted list if we don't see any
7301 overlap, or NULL otherwise. */
7304 check_case_overlap (gfc_case *list)
7306 gfc_case *p, *q, *e, *tail;
7307 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7309 /* If the passed list was empty, return immediately. */
7316 /* Loop unconditionally. The only exit from this loop is a return
7317 statement, when we've finished sorting the case list. */
7324 /* Count the number of merges we do in this pass. */
7327 /* Loop while there exists a merge to be done. */
7332 /* Count this merge. */
7335 /* Cut the list in two pieces by stepping INSIZE places
7336 forward in the list, starting from P. */
7339 for (i = 0; i < insize; i++)
7348 /* Now we have two lists. Merge them! */
7349 while (psize > 0 || (qsize > 0 && q != NULL))
7351 /* See from which the next case to merge comes from. */
7354 /* P is empty so the next case must come from Q. */
7359 else if (qsize == 0 || q == NULL)
7368 cmp = compare_cases (p, q);
7371 /* The whole case range for P is less than the
7379 /* The whole case range for Q is greater than
7380 the case range for P. */
7387 /* The cases overlap, or they are the same
7388 element in the list. Either way, we must
7389 issue an error and get the next case from P. */
7390 /* FIXME: Sort P and Q by line number. */
7391 gfc_error ("CASE label at %L overlaps with CASE "
7392 "label at %L", &p->where, &q->where);
7400 /* Add the next element to the merged list. */
7409 /* P has now stepped INSIZE places along, and so has Q. So
7410 they're the same. */
7415 /* If we have done only one merge or none at all, we've
7416 finished sorting the cases. */
7425 /* Otherwise repeat, merging lists twice the size. */
7431 /* Check to see if an expression is suitable for use in a CASE statement.
7432 Makes sure that all case expressions are scalar constants of the same
7433 type. Return FAILURE if anything is wrong. */
7436 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7438 if (e == NULL) return SUCCESS;
7440 if (e->ts.type != case_expr->ts.type)
7442 gfc_error ("Expression in CASE statement at %L must be of type %s",
7443 &e->where, gfc_basic_typename (case_expr->ts.type));
7447 /* C805 (R808) For a given case-construct, each case-value shall be of
7448 the same type as case-expr. For character type, length differences
7449 are allowed, but the kind type parameters shall be the same. */
7451 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7453 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7454 &e->where, case_expr->ts.kind);
7458 /* Convert the case value kind to that of case expression kind,
7461 if (e->ts.kind != case_expr->ts.kind)
7462 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7466 gfc_error ("Expression in CASE statement at %L must be scalar",
7475 /* Given a completely parsed select statement, we:
7477 - Validate all expressions and code within the SELECT.
7478 - Make sure that the selection expression is not of the wrong type.
7479 - Make sure that no case ranges overlap.
7480 - Eliminate unreachable cases and unreachable code resulting from
7481 removing case labels.
7483 The standard does allow unreachable cases, e.g. CASE (5:3). But
7484 they are a hassle for code generation, and to prevent that, we just
7485 cut them out here. This is not necessary for overlapping cases
7486 because they are illegal and we never even try to generate code.
7488 We have the additional caveat that a SELECT construct could have
7489 been a computed GOTO in the source code. Fortunately we can fairly
7490 easily work around that here: The case_expr for a "real" SELECT CASE
7491 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7492 we have to do is make sure that the case_expr is a scalar integer
7496 resolve_select (gfc_code *code)
7499 gfc_expr *case_expr;
7500 gfc_case *cp, *default_case, *tail, *head;
7501 int seen_unreachable;
7507 if (code->expr1 == NULL)
7509 /* This was actually a computed GOTO statement. */
7510 case_expr = code->expr2;
7511 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7512 gfc_error ("Selection expression in computed GOTO statement "
7513 "at %L must be a scalar integer expression",
7516 /* Further checking is not necessary because this SELECT was built
7517 by the compiler, so it should always be OK. Just move the
7518 case_expr from expr2 to expr so that we can handle computed
7519 GOTOs as normal SELECTs from here on. */
7520 code->expr1 = code->expr2;
7525 case_expr = code->expr1;
7527 type = case_expr->ts.type;
7528 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7530 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7531 &case_expr->where, gfc_typename (&case_expr->ts));
7533 /* Punt. Going on here just produce more garbage error messages. */
7537 /* Raise a warning if an INTEGER case value exceeds the range of
7538 the case-expr. Later, all expressions will be promoted to the
7539 largest kind of all case-labels. */
7541 if (type == BT_INTEGER)
7542 for (body = code->block; body; body = body->block)
7543 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7546 && gfc_check_integer_range (cp->low->value.integer,
7547 case_expr->ts.kind) != ARITH_OK)
7548 gfc_warning ("Expression in CASE statement at %L is "
7549 "not in the range of %s", &cp->low->where,
7550 gfc_typename (&case_expr->ts));
7553 && cp->low != cp->high
7554 && gfc_check_integer_range (cp->high->value.integer,
7555 case_expr->ts.kind) != ARITH_OK)
7556 gfc_warning ("Expression in CASE statement at %L is "
7557 "not in the range of %s", &cp->high->where,
7558 gfc_typename (&case_expr->ts));
7561 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7562 of the SELECT CASE expression and its CASE values. Walk the lists
7563 of case values, and if we find a mismatch, promote case_expr to
7564 the appropriate kind. */
7566 if (type == BT_LOGICAL || type == BT_INTEGER)
7568 for (body = code->block; body; body = body->block)
7570 /* Walk the case label list. */
7571 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7573 /* Intercept the DEFAULT case. It does not have a kind. */
7574 if (cp->low == NULL && cp->high == NULL)
7577 /* Unreachable case ranges are discarded, so ignore. */
7578 if (cp->low != NULL && cp->high != NULL
7579 && cp->low != cp->high
7580 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7584 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7585 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7587 if (cp->high != NULL
7588 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7589 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7594 /* Assume there is no DEFAULT case. */
7595 default_case = NULL;
7600 for (body = code->block; body; body = body->block)
7602 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7604 seen_unreachable = 0;
7606 /* Walk the case label list, making sure that all case labels
7608 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7610 /* Count the number of cases in the whole construct. */
7613 /* Intercept the DEFAULT case. */
7614 if (cp->low == NULL && cp->high == NULL)
7616 if (default_case != NULL)
7618 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7619 "by a second DEFAULT CASE at %L",
7620 &default_case->where, &cp->where);
7631 /* Deal with single value cases and case ranges. Errors are
7632 issued from the validation function. */
7633 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7634 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7640 if (type == BT_LOGICAL
7641 && ((cp->low == NULL || cp->high == NULL)
7642 || cp->low != cp->high))
7644 gfc_error ("Logical range in CASE statement at %L is not "
7645 "allowed", &cp->low->where);
7650 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7653 value = cp->low->value.logical == 0 ? 2 : 1;
7654 if (value & seen_logical)
7656 gfc_error ("Constant logical value in CASE statement "
7657 "is repeated at %L",
7662 seen_logical |= value;
7665 if (cp->low != NULL && cp->high != NULL
7666 && cp->low != cp->high
7667 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7669 if (gfc_option.warn_surprising)
7670 gfc_warning ("Range specification at %L can never "
7671 "be matched", &cp->where);
7673 cp->unreachable = 1;
7674 seen_unreachable = 1;
7678 /* If the case range can be matched, it can also overlap with
7679 other cases. To make sure it does not, we put it in a
7680 double linked list here. We sort that with a merge sort
7681 later on to detect any overlapping cases. */
7685 head->right = head->left = NULL;
7690 tail->right->left = tail;
7697 /* It there was a failure in the previous case label, give up
7698 for this case label list. Continue with the next block. */
7702 /* See if any case labels that are unreachable have been seen.
7703 If so, we eliminate them. This is a bit of a kludge because
7704 the case lists for a single case statement (label) is a
7705 single forward linked lists. */
7706 if (seen_unreachable)
7708 /* Advance until the first case in the list is reachable. */
7709 while (body->ext.block.case_list != NULL
7710 && body->ext.block.case_list->unreachable)
7712 gfc_case *n = body->ext.block.case_list;
7713 body->ext.block.case_list = body->ext.block.case_list->next;
7715 gfc_free_case_list (n);
7718 /* Strip all other unreachable cases. */
7719 if (body->ext.block.case_list)
7721 for (cp = body->ext.block.case_list; cp->next; cp = cp->next)
7723 if (cp->next->unreachable)
7725 gfc_case *n = cp->next;
7726 cp->next = cp->next->next;
7728 gfc_free_case_list (n);
7735 /* See if there were overlapping cases. If the check returns NULL,
7736 there was overlap. In that case we don't do anything. If head
7737 is non-NULL, we prepend the DEFAULT case. The sorted list can
7738 then used during code generation for SELECT CASE constructs with
7739 a case expression of a CHARACTER type. */
7742 head = check_case_overlap (head);
7744 /* Prepend the default_case if it is there. */
7745 if (head != NULL && default_case)
7747 default_case->left = NULL;
7748 default_case->right = head;
7749 head->left = default_case;
7753 /* Eliminate dead blocks that may be the result if we've seen
7754 unreachable case labels for a block. */
7755 for (body = code; body && body->block; body = body->block)
7757 if (body->block->ext.block.case_list == NULL)
7759 /* Cut the unreachable block from the code chain. */
7760 gfc_code *c = body->block;
7761 body->block = c->block;
7763 /* Kill the dead block, but not the blocks below it. */
7765 gfc_free_statements (c);
7769 /* More than two cases is legal but insane for logical selects.
7770 Issue a warning for it. */
7771 if (gfc_option.warn_surprising && type == BT_LOGICAL
7773 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7778 /* Check if a derived type is extensible. */
7781 gfc_type_is_extensible (gfc_symbol *sym)
7783 return !(sym->attr.is_bind_c || sym->attr.sequence);
7787 /* Resolve an associate name: Resolve target and ensure the type-spec is
7788 correct as well as possibly the array-spec. */
7791 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
7795 gcc_assert (sym->assoc);
7796 gcc_assert (sym->attr.flavor == FL_VARIABLE);
7798 /* If this is for SELECT TYPE, the target may not yet be set. In that
7799 case, return. Resolution will be called later manually again when
7801 target = sym->assoc->target;
7804 gcc_assert (!sym->assoc->dangling);
7806 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
7809 /* For variable targets, we get some attributes from the target. */
7810 if (target->expr_type == EXPR_VARIABLE)
7814 gcc_assert (target->symtree);
7815 tsym = target->symtree->n.sym;
7817 sym->attr.asynchronous = tsym->attr.asynchronous;
7818 sym->attr.volatile_ = tsym->attr.volatile_;
7820 sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
7822 if (sym->ts.type == BT_DERIVED && target->symtree->n.sym->ts.type == BT_CLASS)
7823 target->rank = sym->as ? sym->as->rank : 0;
7826 /* Get type if this was not already set. Note that it can be
7827 some other type than the target in case this is a SELECT TYPE
7828 selector! So we must not update when the type is already there. */
7829 if (sym->ts.type == BT_UNKNOWN)
7830 sym->ts = target->ts;
7831 gcc_assert (sym->ts.type != BT_UNKNOWN);
7833 /* See if this is a valid association-to-variable. */
7834 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
7835 && !gfc_has_vector_subscript (target));
7837 /* Finally resolve if this is an array or not. */
7838 if (sym->attr.dimension
7839 && (target->ts.type == BT_CLASS
7840 ? !CLASS_DATA (target)->attr.dimension
7841 : target->rank == 0))
7843 gfc_error ("Associate-name '%s' at %L is used as array",
7844 sym->name, &sym->declared_at);
7845 sym->attr.dimension = 0;
7848 if (target->rank > 0)
7849 sym->attr.dimension = 1;
7851 if (sym->attr.dimension)
7853 sym->as = gfc_get_array_spec ();
7854 sym->as->rank = target->rank;
7855 sym->as->type = AS_DEFERRED;
7857 /* Target must not be coindexed, thus the associate-variable
7859 sym->as->corank = 0;
7864 /* Resolve a SELECT TYPE statement. */
7867 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
7869 gfc_symbol *selector_type;
7870 gfc_code *body, *new_st, *if_st, *tail;
7871 gfc_code *class_is = NULL, *default_case = NULL;
7874 char name[GFC_MAX_SYMBOL_LEN];
7878 ns = code->ext.block.ns;
7881 /* Check for F03:C813. */
7882 if (code->expr1->ts.type != BT_CLASS
7883 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
7885 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7886 "at %L", &code->loc);
7892 if (code->expr1->symtree->n.sym->attr.untyped)
7893 code->expr1->symtree->n.sym->ts = code->expr2->ts;
7894 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
7897 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
7899 /* Loop over TYPE IS / CLASS IS cases. */
7900 for (body = code->block; body; body = body->block)
7902 c = body->ext.block.case_list;
7904 /* Check F03:C815. */
7905 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7906 && !gfc_type_is_extensible (c->ts.u.derived))
7908 gfc_error ("Derived type '%s' at %L must be extensible",
7909 c->ts.u.derived->name, &c->where);
7914 /* Check F03:C816. */
7915 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7916 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
7918 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7919 c->ts.u.derived->name, &c->where, selector_type->name);
7924 /* Intercept the DEFAULT case. */
7925 if (c->ts.type == BT_UNKNOWN)
7927 /* Check F03:C818. */
7930 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7931 "by a second DEFAULT CASE at %L",
7932 &default_case->ext.block.case_list->where, &c->where);
7937 default_case = body;
7944 /* Transform SELECT TYPE statement to BLOCK and associate selector to
7945 target if present. If there are any EXIT statements referring to the
7946 SELECT TYPE construct, this is no problem because the gfc_code
7947 reference stays the same and EXIT is equally possible from the BLOCK
7948 it is changed to. */
7949 code->op = EXEC_BLOCK;
7952 gfc_association_list* assoc;
7954 assoc = gfc_get_association_list ();
7955 assoc->st = code->expr1->symtree;
7956 assoc->target = gfc_copy_expr (code->expr2);
7957 assoc->target->where = code->expr2->where;
7958 /* assoc->variable will be set by resolve_assoc_var. */
7960 code->ext.block.assoc = assoc;
7961 code->expr1->symtree->n.sym->assoc = assoc;
7963 resolve_assoc_var (code->expr1->symtree->n.sym, false);
7966 code->ext.block.assoc = NULL;
7968 /* Add EXEC_SELECT to switch on type. */
7969 new_st = gfc_get_code ();
7970 new_st->op = code->op;
7971 new_st->expr1 = code->expr1;
7972 new_st->expr2 = code->expr2;
7973 new_st->block = code->block;
7974 code->expr1 = code->expr2 = NULL;
7979 ns->code->next = new_st;
7981 code->op = EXEC_SELECT;
7982 gfc_add_vptr_component (code->expr1);
7983 gfc_add_hash_component (code->expr1);
7985 /* Loop over TYPE IS / CLASS IS cases. */
7986 for (body = code->block; body; body = body->block)
7988 c = body->ext.block.case_list;
7990 if (c->ts.type == BT_DERIVED)
7991 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7992 c->ts.u.derived->hash_value);
7994 else if (c->ts.type == BT_UNKNOWN)
7997 /* Associate temporary to selector. This should only be done
7998 when this case is actually true, so build a new ASSOCIATE
7999 that does precisely this here (instead of using the
8002 if (c->ts.type == BT_CLASS)
8003 sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
8005 sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
8006 st = gfc_find_symtree (ns->sym_root, name);
8007 gcc_assert (st->n.sym->assoc);
8008 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
8009 st->n.sym->assoc->target->where = code->expr1->where;
8010 if (c->ts.type == BT_DERIVED)
8011 gfc_add_data_component (st->n.sym->assoc->target);
8013 new_st = gfc_get_code ();
8014 new_st->op = EXEC_BLOCK;
8015 new_st->ext.block.ns = gfc_build_block_ns (ns);
8016 new_st->ext.block.ns->code = body->next;
8017 body->next = new_st;
8019 /* Chain in the new list only if it is marked as dangling. Otherwise
8020 there is a CASE label overlap and this is already used. Just ignore,
8021 the error is diagonsed elsewhere. */
8022 if (st->n.sym->assoc->dangling)
8024 new_st->ext.block.assoc = st->n.sym->assoc;
8025 st->n.sym->assoc->dangling = 0;
8028 resolve_assoc_var (st->n.sym, false);
8031 /* Take out CLASS IS cases for separate treatment. */
8033 while (body && body->block)
8035 if (body->block->ext.block.case_list->ts.type == BT_CLASS)
8037 /* Add to class_is list. */
8038 if (class_is == NULL)
8040 class_is = body->block;
8045 for (tail = class_is; tail->block; tail = tail->block) ;
8046 tail->block = body->block;
8049 /* Remove from EXEC_SELECT list. */
8050 body->block = body->block->block;
8063 /* Add a default case to hold the CLASS IS cases. */
8064 for (tail = code; tail->block; tail = tail->block) ;
8065 tail->block = gfc_get_code ();
8067 tail->op = EXEC_SELECT_TYPE;
8068 tail->ext.block.case_list = gfc_get_case ();
8069 tail->ext.block.case_list->ts.type = BT_UNKNOWN;
8071 default_case = tail;
8074 /* More than one CLASS IS block? */
8075 if (class_is->block)
8079 /* Sort CLASS IS blocks by extension level. */
8083 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
8086 /* F03:C817 (check for doubles). */
8087 if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
8088 == c2->ext.block.case_list->ts.u.derived->hash_value)
8090 gfc_error ("Double CLASS IS block in SELECT TYPE "
8092 &c2->ext.block.case_list->where);
8095 if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
8096 < c2->ext.block.case_list->ts.u.derived->attr.extension)
8099 (*c1)->block = c2->block;
8109 /* Generate IF chain. */
8110 if_st = gfc_get_code ();
8111 if_st->op = EXEC_IF;
8113 for (body = class_is; body; body = body->block)
8115 new_st->block = gfc_get_code ();
8116 new_st = new_st->block;
8117 new_st->op = EXEC_IF;
8118 /* Set up IF condition: Call _gfortran_is_extension_of. */
8119 new_st->expr1 = gfc_get_expr ();
8120 new_st->expr1->expr_type = EXPR_FUNCTION;
8121 new_st->expr1->ts.type = BT_LOGICAL;
8122 new_st->expr1->ts.kind = 4;
8123 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
8124 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
8125 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
8126 /* Set up arguments. */
8127 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
8128 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
8129 new_st->expr1->value.function.actual->expr->where = code->loc;
8130 gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
8131 vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
8132 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
8133 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
8134 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
8135 new_st->next = body->next;
8137 if (default_case->next)
8139 new_st->block = gfc_get_code ();
8140 new_st = new_st->block;
8141 new_st->op = EXEC_IF;
8142 new_st->next = default_case->next;
8145 /* Replace CLASS DEFAULT code by the IF chain. */
8146 default_case->next = if_st;
8149 /* Resolve the internal code. This can not be done earlier because
8150 it requires that the sym->assoc of selectors is set already. */
8151 gfc_current_ns = ns;
8152 gfc_resolve_blocks (code->block, gfc_current_ns);
8153 gfc_current_ns = old_ns;
8155 resolve_select (code);
8159 /* Resolve a transfer statement. This is making sure that:
8160 -- a derived type being transferred has only non-pointer components
8161 -- a derived type being transferred doesn't have private components, unless
8162 it's being transferred from the module where the type was defined
8163 -- we're not trying to transfer a whole assumed size array. */
8166 resolve_transfer (gfc_code *code)
8175 while (exp != NULL && exp->expr_type == EXPR_OP
8176 && exp->value.op.op == INTRINSIC_PARENTHESES)
8177 exp = exp->value.op.op1;
8179 if (exp && exp->expr_type == EXPR_NULL && exp->ts.type == BT_UNKNOWN)
8181 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8182 "MOLD=", &exp->where);
8186 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
8187 && exp->expr_type != EXPR_FUNCTION))
8190 /* If we are reading, the variable will be changed. Note that
8191 code->ext.dt may be NULL if the TRANSFER is related to
8192 an INQUIRE statement -- but in this case, we are not reading, either. */
8193 if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
8194 && gfc_check_vardef_context (exp, false, false, _("item in READ"))
8198 sym = exp->symtree->n.sym;
8201 /* Go to actual component transferred. */
8202 for (ref = exp->ref; ref; ref = ref->next)
8203 if (ref->type == REF_COMPONENT)
8204 ts = &ref->u.c.component->ts;
8206 if (ts->type == BT_CLASS)
8208 /* FIXME: Test for defined input/output. */
8209 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8210 "it is processed by a defined input/output procedure",
8215 if (ts->type == BT_DERIVED)
8217 /* Check that transferred derived type doesn't contain POINTER
8219 if (ts->u.derived->attr.pointer_comp)
8221 gfc_error ("Data transfer element at %L cannot have POINTER "
8222 "components unless it is processed by a defined "
8223 "input/output procedure", &code->loc);
8228 if (ts->u.derived->attr.proc_pointer_comp)
8230 gfc_error ("Data transfer element at %L cannot have "
8231 "procedure pointer components", &code->loc);
8235 if (ts->u.derived->attr.alloc_comp)
8237 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8238 "components unless it is processed by a defined "
8239 "input/output procedure", &code->loc);
8243 if (derived_inaccessible (ts->u.derived))
8245 gfc_error ("Data transfer element at %L cannot have "
8246 "PRIVATE components",&code->loc);
8251 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
8252 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
8254 gfc_error ("Data transfer element at %L cannot be a full reference to "
8255 "an assumed-size array", &code->loc);
8261 /*********** Toplevel code resolution subroutines ***********/
8263 /* Find the set of labels that are reachable from this block. We also
8264 record the last statement in each block. */
8267 find_reachable_labels (gfc_code *block)
8274 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
8276 /* Collect labels in this block. We don't keep those corresponding
8277 to END {IF|SELECT}, these are checked in resolve_branch by going
8278 up through the code_stack. */
8279 for (c = block; c; c = c->next)
8281 if (c->here && c->op != EXEC_END_NESTED_BLOCK)
8282 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8285 /* Merge with labels from parent block. */
8288 gcc_assert (cs_base->prev->reachable_labels);
8289 bitmap_ior_into (cs_base->reachable_labels,
8290 cs_base->prev->reachable_labels);
8296 resolve_lock_unlock (gfc_code *code)
8298 if (code->expr1->ts.type != BT_DERIVED
8299 || code->expr1->expr_type != EXPR_VARIABLE
8300 || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
8301 || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
8302 || code->expr1->rank != 0
8303 || (!gfc_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1)))
8304 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8305 &code->expr1->where);
8309 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8310 || code->expr2->expr_type != EXPR_VARIABLE))
8311 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8312 &code->expr2->where);
8315 && gfc_check_vardef_context (code->expr2, false, false,
8316 _("STAT variable")) == FAILURE)
8321 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8322 || code->expr3->expr_type != EXPR_VARIABLE))
8323 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8324 &code->expr3->where);
8327 && gfc_check_vardef_context (code->expr3, false, false,
8328 _("ERRMSG variable")) == FAILURE)
8331 /* Check ACQUIRED_LOCK. */
8333 && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
8334 || code->expr4->expr_type != EXPR_VARIABLE))
8335 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8336 "variable", &code->expr4->where);
8339 && gfc_check_vardef_context (code->expr4, false, false,
8340 _("ACQUIRED_LOCK variable")) == FAILURE)
8346 resolve_sync (gfc_code *code)
8348 /* Check imageset. The * case matches expr1 == NULL. */
8351 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8352 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8353 "INTEGER expression", &code->expr1->where);
8354 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8355 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8356 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8357 &code->expr1->where);
8358 else if (code->expr1->expr_type == EXPR_ARRAY
8359 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8361 gfc_constructor *cons;
8362 cons = gfc_constructor_first (code->expr1->value.constructor);
8363 for (; cons; cons = gfc_constructor_next (cons))
8364 if (cons->expr->expr_type == EXPR_CONSTANT
8365 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8366 gfc_error ("Imageset argument at %L must between 1 and "
8367 "num_images()", &cons->expr->where);
8373 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8374 || code->expr2->expr_type != EXPR_VARIABLE))
8375 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8376 &code->expr2->where);
8380 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8381 || code->expr3->expr_type != EXPR_VARIABLE))
8382 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8383 &code->expr3->where);
8387 /* Given a branch to a label, see if the branch is conforming.
8388 The code node describes where the branch is located. */
8391 resolve_branch (gfc_st_label *label, gfc_code *code)
8398 /* Step one: is this a valid branching target? */
8400 if (label->defined == ST_LABEL_UNKNOWN)
8402 gfc_error ("Label %d referenced at %L is never defined", label->value,
8407 if (label->defined != ST_LABEL_TARGET)
8409 gfc_error ("Statement at %L is not a valid branch target statement "
8410 "for the branch statement at %L", &label->where, &code->loc);
8414 /* Step two: make sure this branch is not a branch to itself ;-) */
8416 if (code->here == label)
8418 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8422 /* Step three: See if the label is in the same block as the
8423 branching statement. The hard work has been done by setting up
8424 the bitmap reachable_labels. */
8426 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8428 /* Check now whether there is a CRITICAL construct; if so, check
8429 whether the label is still visible outside of the CRITICAL block,
8430 which is invalid. */
8431 for (stack = cs_base; stack; stack = stack->prev)
8433 if (stack->current->op == EXEC_CRITICAL
8434 && bitmap_bit_p (stack->reachable_labels, label->value))
8435 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8436 "label at %L", &code->loc, &label->where);
8437 else if (stack->current->op == EXEC_DO_CONCURRENT
8438 && bitmap_bit_p (stack->reachable_labels, label->value))
8439 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8440 "for label at %L", &code->loc, &label->where);
8446 /* Step four: If we haven't found the label in the bitmap, it may
8447 still be the label of the END of the enclosing block, in which
8448 case we find it by going up the code_stack. */
8450 for (stack = cs_base; stack; stack = stack->prev)
8452 if (stack->current->next && stack->current->next->here == label)
8454 if (stack->current->op == EXEC_CRITICAL)
8456 /* Note: A label at END CRITICAL does not leave the CRITICAL
8457 construct as END CRITICAL is still part of it. */
8458 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8459 " at %L", &code->loc, &label->where);
8462 else if (stack->current->op == EXEC_DO_CONCURRENT)
8464 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8465 "label at %L", &code->loc, &label->where);
8472 gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
8476 /* The label is not in an enclosing block, so illegal. This was
8477 allowed in Fortran 66, so we allow it as extension. No
8478 further checks are necessary in this case. */
8479 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
8480 "as the GOTO statement at %L", &label->where,
8486 /* Check whether EXPR1 has the same shape as EXPR2. */
8489 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
8491 mpz_t shape[GFC_MAX_DIMENSIONS];
8492 mpz_t shape2[GFC_MAX_DIMENSIONS];
8493 gfc_try result = FAILURE;
8496 /* Compare the rank. */
8497 if (expr1->rank != expr2->rank)
8500 /* Compare the size of each dimension. */
8501 for (i=0; i<expr1->rank; i++)
8503 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
8506 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
8509 if (mpz_cmp (shape[i], shape2[i]))
8513 /* When either of the two expression is an assumed size array, we
8514 ignore the comparison of dimension sizes. */
8519 gfc_clear_shape (shape, i);
8520 gfc_clear_shape (shape2, i);
8525 /* Check whether a WHERE assignment target or a WHERE mask expression
8526 has the same shape as the outmost WHERE mask expression. */
8529 resolve_where (gfc_code *code, gfc_expr *mask)
8535 cblock = code->block;
8537 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8538 In case of nested WHERE, only the outmost one is stored. */
8539 if (mask == NULL) /* outmost WHERE */
8541 else /* inner WHERE */
8548 /* Check if the mask-expr has a consistent shape with the
8549 outmost WHERE mask-expr. */
8550 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8551 gfc_error ("WHERE mask at %L has inconsistent shape",
8552 &cblock->expr1->where);
8555 /* the assignment statement of a WHERE statement, or the first
8556 statement in where-body-construct of a WHERE construct */
8557 cnext = cblock->next;
8562 /* WHERE assignment statement */
8565 /* Check shape consistent for WHERE assignment target. */
8566 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8567 gfc_error ("WHERE assignment target at %L has "
8568 "inconsistent shape", &cnext->expr1->where);
8572 case EXEC_ASSIGN_CALL:
8573 resolve_call (cnext);
8574 if (!cnext->resolved_sym->attr.elemental)
8575 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8576 &cnext->ext.actual->expr->where);
8579 /* WHERE or WHERE construct is part of a where-body-construct */
8581 resolve_where (cnext, e);
8585 gfc_error ("Unsupported statement inside WHERE at %L",
8588 /* the next statement within the same where-body-construct */
8589 cnext = cnext->next;
8591 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8592 cblock = cblock->block;
8597 /* Resolve assignment in FORALL construct.
8598 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8599 FORALL index variables. */
8602 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8606 for (n = 0; n < nvar; n++)
8608 gfc_symbol *forall_index;
8610 forall_index = var_expr[n]->symtree->n.sym;
8612 /* Check whether the assignment target is one of the FORALL index
8614 if ((code->expr1->expr_type == EXPR_VARIABLE)
8615 && (code->expr1->symtree->n.sym == forall_index))
8616 gfc_error ("Assignment to a FORALL index variable at %L",
8617 &code->expr1->where);
8620 /* If one of the FORALL index variables doesn't appear in the
8621 assignment variable, then there could be a many-to-one
8622 assignment. Emit a warning rather than an error because the
8623 mask could be resolving this problem. */
8624 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8625 gfc_warning ("The FORALL with index '%s' is not used on the "
8626 "left side of the assignment at %L and so might "
8627 "cause multiple assignment to this object",
8628 var_expr[n]->symtree->name, &code->expr1->where);
8634 /* Resolve WHERE statement in FORALL construct. */
8637 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8638 gfc_expr **var_expr)
8643 cblock = code->block;
8646 /* the assignment statement of a WHERE statement, or the first
8647 statement in where-body-construct of a WHERE construct */
8648 cnext = cblock->next;
8653 /* WHERE assignment statement */
8655 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8658 /* WHERE operator assignment statement */
8659 case EXEC_ASSIGN_CALL:
8660 resolve_call (cnext);
8661 if (!cnext->resolved_sym->attr.elemental)
8662 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8663 &cnext->ext.actual->expr->where);
8666 /* WHERE or WHERE construct is part of a where-body-construct */
8668 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8672 gfc_error ("Unsupported statement inside WHERE at %L",
8675 /* the next statement within the same where-body-construct */
8676 cnext = cnext->next;
8678 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8679 cblock = cblock->block;
8684 /* Traverse the FORALL body to check whether the following errors exist:
8685 1. For assignment, check if a many-to-one assignment happens.
8686 2. For WHERE statement, check the WHERE body to see if there is any
8687 many-to-one assignment. */
8690 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8694 c = code->block->next;
8700 case EXEC_POINTER_ASSIGN:
8701 gfc_resolve_assign_in_forall (c, nvar, var_expr);
8704 case EXEC_ASSIGN_CALL:
8708 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8709 there is no need to handle it here. */
8713 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8718 /* The next statement in the FORALL body. */
8724 /* Counts the number of iterators needed inside a forall construct, including
8725 nested forall constructs. This is used to allocate the needed memory
8726 in gfc_resolve_forall. */
8729 gfc_count_forall_iterators (gfc_code *code)
8731 int max_iters, sub_iters, current_iters;
8732 gfc_forall_iterator *fa;
8734 gcc_assert(code->op == EXEC_FORALL);
8738 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8741 code = code->block->next;
8745 if (code->op == EXEC_FORALL)
8747 sub_iters = gfc_count_forall_iterators (code);
8748 if (sub_iters > max_iters)
8749 max_iters = sub_iters;
8754 return current_iters + max_iters;
8758 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8759 gfc_resolve_forall_body to resolve the FORALL body. */
8762 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8764 static gfc_expr **var_expr;
8765 static int total_var = 0;
8766 static int nvar = 0;
8768 gfc_forall_iterator *fa;
8773 /* Start to resolve a FORALL construct */
8774 if (forall_save == 0)
8776 /* Count the total number of FORALL index in the nested FORALL
8777 construct in order to allocate the VAR_EXPR with proper size. */
8778 total_var = gfc_count_forall_iterators (code);
8780 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8781 var_expr = XCNEWVEC (gfc_expr *, total_var);
8784 /* The information about FORALL iterator, including FORALL index start, end
8785 and stride. The FORALL index can not appear in start, end or stride. */
8786 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8788 /* Check if any outer FORALL index name is the same as the current
8790 for (i = 0; i < nvar; i++)
8792 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8794 gfc_error ("An outer FORALL construct already has an index "
8795 "with this name %L", &fa->var->where);
8799 /* Record the current FORALL index. */
8800 var_expr[nvar] = gfc_copy_expr (fa->var);
8804 /* No memory leak. */
8805 gcc_assert (nvar <= total_var);
8808 /* Resolve the FORALL body. */
8809 gfc_resolve_forall_body (code, nvar, var_expr);
8811 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8812 gfc_resolve_blocks (code->block, ns);
8816 /* Free only the VAR_EXPRs allocated in this frame. */
8817 for (i = nvar; i < tmp; i++)
8818 gfc_free_expr (var_expr[i]);
8822 /* We are in the outermost FORALL construct. */
8823 gcc_assert (forall_save == 0);
8825 /* VAR_EXPR is not needed any more. */
8832 /* Resolve a BLOCK construct statement. */
8835 resolve_block_construct (gfc_code* code)
8837 /* Resolve the BLOCK's namespace. */
8838 gfc_resolve (code->ext.block.ns);
8840 /* For an ASSOCIATE block, the associations (and their targets) are already
8841 resolved during resolve_symbol. */
8845 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8848 static void resolve_code (gfc_code *, gfc_namespace *);
8851 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8855 for (; b; b = b->block)
8857 t = gfc_resolve_expr (b->expr1);
8858 if (gfc_resolve_expr (b->expr2) == FAILURE)
8864 if (t == SUCCESS && b->expr1 != NULL
8865 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
8866 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8873 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
8874 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8879 resolve_branch (b->label1, b);
8883 resolve_block_construct (b);
8887 case EXEC_SELECT_TYPE:
8891 case EXEC_DO_CONCURRENT:
8899 case EXEC_OMP_ATOMIC:
8900 case EXEC_OMP_CRITICAL:
8902 case EXEC_OMP_MASTER:
8903 case EXEC_OMP_ORDERED:
8904 case EXEC_OMP_PARALLEL:
8905 case EXEC_OMP_PARALLEL_DO:
8906 case EXEC_OMP_PARALLEL_SECTIONS:
8907 case EXEC_OMP_PARALLEL_WORKSHARE:
8908 case EXEC_OMP_SECTIONS:
8909 case EXEC_OMP_SINGLE:
8911 case EXEC_OMP_TASKWAIT:
8912 case EXEC_OMP_TASKYIELD:
8913 case EXEC_OMP_WORKSHARE:
8917 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
8920 resolve_code (b->next, ns);
8925 /* Does everything to resolve an ordinary assignment. Returns true
8926 if this is an interface assignment. */
8928 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
8938 if (gfc_extend_assign (code, ns) == SUCCESS)
8942 if (code->op == EXEC_ASSIGN_CALL)
8944 lhs = code->ext.actual->expr;
8945 rhsptr = &code->ext.actual->next->expr;
8949 gfc_actual_arglist* args;
8950 gfc_typebound_proc* tbp;
8952 gcc_assert (code->op == EXEC_COMPCALL);
8954 args = code->expr1->value.compcall.actual;
8956 rhsptr = &args->next->expr;
8958 tbp = code->expr1->value.compcall.tbp;
8959 gcc_assert (!tbp->is_generic);
8962 /* Make a temporary rhs when there is a default initializer
8963 and rhs is the same symbol as the lhs. */
8964 if ((*rhsptr)->expr_type == EXPR_VARIABLE
8965 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
8966 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
8967 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
8968 *rhsptr = gfc_get_parentheses (*rhsptr);
8977 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
8978 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
8979 &code->loc) == FAILURE)
8982 /* Handle the case of a BOZ literal on the RHS. */
8983 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
8986 if (gfc_option.warn_surprising)
8987 gfc_warning ("BOZ literal at %L is bitwise transferred "
8988 "non-integer symbol '%s'", &code->loc,
8989 lhs->symtree->n.sym->name);
8991 if (!gfc_convert_boz (rhs, &lhs->ts))
8993 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
8995 if (rc == ARITH_UNDERFLOW)
8996 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
8997 ". This check can be disabled with the option "
8998 "-fno-range-check", &rhs->where);
8999 else if (rc == ARITH_OVERFLOW)
9000 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9001 ". This check can be disabled with the option "
9002 "-fno-range-check", &rhs->where);
9003 else if (rc == ARITH_NAN)
9004 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9005 ". This check can be disabled with the option "
9006 "-fno-range-check", &rhs->where);
9011 if (lhs->ts.type == BT_CHARACTER
9012 && gfc_option.warn_character_truncation)
9014 if (lhs->ts.u.cl != NULL
9015 && lhs->ts.u.cl->length != NULL
9016 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9017 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
9019 if (rhs->expr_type == EXPR_CONSTANT)
9020 rlen = rhs->value.character.length;
9022 else if (rhs->ts.u.cl != NULL
9023 && rhs->ts.u.cl->length != NULL
9024 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9025 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
9027 if (rlen && llen && rlen > llen)
9028 gfc_warning_now ("CHARACTER expression will be truncated "
9029 "in assignment (%d/%d) at %L",
9030 llen, rlen, &code->loc);
9033 /* Ensure that a vector index expression for the lvalue is evaluated
9034 to a temporary if the lvalue symbol is referenced in it. */
9037 for (ref = lhs->ref; ref; ref= ref->next)
9038 if (ref->type == REF_ARRAY)
9040 for (n = 0; n < ref->u.ar.dimen; n++)
9041 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
9042 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
9043 ref->u.ar.start[n]))
9045 = gfc_get_parentheses (ref->u.ar.start[n]);
9049 if (gfc_pure (NULL))
9051 if (lhs->ts.type == BT_DERIVED
9052 && lhs->expr_type == EXPR_VARIABLE
9053 && lhs->ts.u.derived->attr.pointer_comp
9054 && rhs->expr_type == EXPR_VARIABLE
9055 && (gfc_impure_variable (rhs->symtree->n.sym)
9056 || gfc_is_coindexed (rhs)))
9059 if (gfc_is_coindexed (rhs))
9060 gfc_error ("Coindexed expression at %L is assigned to "
9061 "a derived type variable with a POINTER "
9062 "component in a PURE procedure",
9065 gfc_error ("The impure variable at %L is assigned to "
9066 "a derived type variable with a POINTER "
9067 "component in a PURE procedure (12.6)",
9072 /* Fortran 2008, C1283. */
9073 if (gfc_is_coindexed (lhs))
9075 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9076 "procedure", &rhs->where);
9081 if (gfc_implicit_pure (NULL))
9083 if (lhs->expr_type == EXPR_VARIABLE
9084 && lhs->symtree->n.sym != gfc_current_ns->proc_name
9085 && lhs->symtree->n.sym->ns != gfc_current_ns)
9086 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9088 if (lhs->ts.type == BT_DERIVED
9089 && lhs->expr_type == EXPR_VARIABLE
9090 && lhs->ts.u.derived->attr.pointer_comp
9091 && rhs->expr_type == EXPR_VARIABLE
9092 && (gfc_impure_variable (rhs->symtree->n.sym)
9093 || gfc_is_coindexed (rhs)))
9094 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9096 /* Fortran 2008, C1283. */
9097 if (gfc_is_coindexed (lhs))
9098 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9102 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9103 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9104 if (lhs->ts.type == BT_CLASS)
9106 gfc_error ("Variable must not be polymorphic in assignment at %L",
9111 /* F2008, Section 7.2.1.2. */
9112 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
9114 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9115 "component in assignment at %L", &lhs->where);
9119 gfc_check_assign (lhs, rhs, 1);
9124 /* Given a block of code, recursively resolve everything pointed to by this
9128 resolve_code (gfc_code *code, gfc_namespace *ns)
9130 int omp_workshare_save;
9131 int forall_save, do_concurrent_save;
9135 frame.prev = cs_base;
9139 find_reachable_labels (code);
9141 for (; code; code = code->next)
9143 frame.current = code;
9144 forall_save = forall_flag;
9145 do_concurrent_save = do_concurrent_flag;
9147 if (code->op == EXEC_FORALL)
9150 gfc_resolve_forall (code, ns, forall_save);
9153 else if (code->block)
9155 omp_workshare_save = -1;
9158 case EXEC_OMP_PARALLEL_WORKSHARE:
9159 omp_workshare_save = omp_workshare_flag;
9160 omp_workshare_flag = 1;
9161 gfc_resolve_omp_parallel_blocks (code, ns);
9163 case EXEC_OMP_PARALLEL:
9164 case EXEC_OMP_PARALLEL_DO:
9165 case EXEC_OMP_PARALLEL_SECTIONS:
9167 omp_workshare_save = omp_workshare_flag;
9168 omp_workshare_flag = 0;
9169 gfc_resolve_omp_parallel_blocks (code, ns);
9172 gfc_resolve_omp_do_blocks (code, ns);
9174 case EXEC_SELECT_TYPE:
9175 /* Blocks are handled in resolve_select_type because we have
9176 to transform the SELECT TYPE into ASSOCIATE first. */
9178 case EXEC_DO_CONCURRENT:
9179 do_concurrent_flag = 1;
9180 gfc_resolve_blocks (code->block, ns);
9181 do_concurrent_flag = 2;
9183 case EXEC_OMP_WORKSHARE:
9184 omp_workshare_save = omp_workshare_flag;
9185 omp_workshare_flag = 1;
9188 gfc_resolve_blocks (code->block, ns);
9192 if (omp_workshare_save != -1)
9193 omp_workshare_flag = omp_workshare_save;
9197 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
9198 t = gfc_resolve_expr (code->expr1);
9199 forall_flag = forall_save;
9200 do_concurrent_flag = do_concurrent_save;
9202 if (gfc_resolve_expr (code->expr2) == FAILURE)
9205 if (code->op == EXEC_ALLOCATE
9206 && gfc_resolve_expr (code->expr3) == FAILURE)
9212 case EXEC_END_BLOCK:
9213 case EXEC_END_NESTED_BLOCK:
9217 case EXEC_ERROR_STOP:
9221 case EXEC_ASSIGN_CALL:
9226 case EXEC_SYNC_IMAGES:
9227 case EXEC_SYNC_MEMORY:
9228 resolve_sync (code);
9233 resolve_lock_unlock (code);
9237 /* Keep track of which entry we are up to. */
9238 current_entry_id = code->ext.entry->id;
9242 resolve_where (code, NULL);
9246 if (code->expr1 != NULL)
9248 if (code->expr1->ts.type != BT_INTEGER)
9249 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9250 "INTEGER variable", &code->expr1->where);
9251 else if (code->expr1->symtree->n.sym->attr.assign != 1)
9252 gfc_error ("Variable '%s' has not been assigned a target "
9253 "label at %L", code->expr1->symtree->n.sym->name,
9254 &code->expr1->where);
9257 resolve_branch (code->label1, code);
9261 if (code->expr1 != NULL
9262 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
9263 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9264 "INTEGER return specifier", &code->expr1->where);
9267 case EXEC_INIT_ASSIGN:
9268 case EXEC_END_PROCEDURE:
9275 if (gfc_check_vardef_context (code->expr1, false, false,
9276 _("assignment")) == FAILURE)
9279 if (resolve_ordinary_assign (code, ns))
9281 if (code->op == EXEC_COMPCALL)
9288 case EXEC_LABEL_ASSIGN:
9289 if (code->label1->defined == ST_LABEL_UNKNOWN)
9290 gfc_error ("Label %d referenced at %L is never defined",
9291 code->label1->value, &code->label1->where);
9293 && (code->expr1->expr_type != EXPR_VARIABLE
9294 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
9295 || code->expr1->symtree->n.sym->ts.kind
9296 != gfc_default_integer_kind
9297 || code->expr1->symtree->n.sym->as != NULL))
9298 gfc_error ("ASSIGN statement at %L requires a scalar "
9299 "default INTEGER variable", &code->expr1->where);
9302 case EXEC_POINTER_ASSIGN:
9309 /* This is both a variable definition and pointer assignment
9310 context, so check both of them. For rank remapping, a final
9311 array ref may be present on the LHS and fool gfc_expr_attr
9312 used in gfc_check_vardef_context. Remove it. */
9313 e = remove_last_array_ref (code->expr1);
9314 t = gfc_check_vardef_context (e, true, false,
9315 _("pointer assignment"));
9317 t = gfc_check_vardef_context (e, false, false,
9318 _("pointer assignment"));
9323 gfc_check_pointer_assign (code->expr1, code->expr2);
9327 case EXEC_ARITHMETIC_IF:
9329 && code->expr1->ts.type != BT_INTEGER
9330 && code->expr1->ts.type != BT_REAL)
9331 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9332 "expression", &code->expr1->where);
9334 resolve_branch (code->label1, code);
9335 resolve_branch (code->label2, code);
9336 resolve_branch (code->label3, code);
9340 if (t == SUCCESS && code->expr1 != NULL
9341 && (code->expr1->ts.type != BT_LOGICAL
9342 || code->expr1->rank != 0))
9343 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9344 &code->expr1->where);
9349 resolve_call (code);
9354 resolve_typebound_subroutine (code);
9358 resolve_ppc_call (code);
9362 /* Select is complicated. Also, a SELECT construct could be
9363 a transformed computed GOTO. */
9364 resolve_select (code);
9367 case EXEC_SELECT_TYPE:
9368 resolve_select_type (code, ns);
9372 resolve_block_construct (code);
9376 if (code->ext.iterator != NULL)
9378 gfc_iterator *iter = code->ext.iterator;
9379 if (gfc_resolve_iterator (iter, true) != FAILURE)
9380 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
9385 if (code->expr1 == NULL)
9386 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9388 && (code->expr1->rank != 0
9389 || code->expr1->ts.type != BT_LOGICAL))
9390 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9391 "a scalar LOGICAL expression", &code->expr1->where);
9396 resolve_allocate_deallocate (code, "ALLOCATE");
9400 case EXEC_DEALLOCATE:
9402 resolve_allocate_deallocate (code, "DEALLOCATE");
9407 if (gfc_resolve_open (code->ext.open) == FAILURE)
9410 resolve_branch (code->ext.open->err, code);
9414 if (gfc_resolve_close (code->ext.close) == FAILURE)
9417 resolve_branch (code->ext.close->err, code);
9420 case EXEC_BACKSPACE:
9424 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
9427 resolve_branch (code->ext.filepos->err, code);
9431 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9434 resolve_branch (code->ext.inquire->err, code);
9438 gcc_assert (code->ext.inquire != NULL);
9439 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9442 resolve_branch (code->ext.inquire->err, code);
9446 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
9449 resolve_branch (code->ext.wait->err, code);
9450 resolve_branch (code->ext.wait->end, code);
9451 resolve_branch (code->ext.wait->eor, code);
9456 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
9459 resolve_branch (code->ext.dt->err, code);
9460 resolve_branch (code->ext.dt->end, code);
9461 resolve_branch (code->ext.dt->eor, code);
9465 resolve_transfer (code);
9468 case EXEC_DO_CONCURRENT:
9470 resolve_forall_iterators (code->ext.forall_iterator);
9472 if (code->expr1 != NULL
9473 && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
9474 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9475 "expression", &code->expr1->where);
9478 case EXEC_OMP_ATOMIC:
9479 case EXEC_OMP_BARRIER:
9480 case EXEC_OMP_CRITICAL:
9481 case EXEC_OMP_FLUSH:
9483 case EXEC_OMP_MASTER:
9484 case EXEC_OMP_ORDERED:
9485 case EXEC_OMP_SECTIONS:
9486 case EXEC_OMP_SINGLE:
9487 case EXEC_OMP_TASKWAIT:
9488 case EXEC_OMP_TASKYIELD:
9489 case EXEC_OMP_WORKSHARE:
9490 gfc_resolve_omp_directive (code, ns);
9493 case EXEC_OMP_PARALLEL:
9494 case EXEC_OMP_PARALLEL_DO:
9495 case EXEC_OMP_PARALLEL_SECTIONS:
9496 case EXEC_OMP_PARALLEL_WORKSHARE:
9498 omp_workshare_save = omp_workshare_flag;
9499 omp_workshare_flag = 0;
9500 gfc_resolve_omp_directive (code, ns);
9501 omp_workshare_flag = omp_workshare_save;
9505 gfc_internal_error ("resolve_code(): Bad statement code");
9509 cs_base = frame.prev;
9513 /* Resolve initial values and make sure they are compatible with
9517 resolve_values (gfc_symbol *sym)
9521 if (sym->value == NULL || sym->attr.use_assoc)
9524 if (sym->value->expr_type == EXPR_STRUCTURE)
9525 t= resolve_structure_cons (sym->value, 1);
9527 t = gfc_resolve_expr (sym->value);
9532 gfc_check_assign_symbol (sym, sym->value);
9536 /* Verify the binding labels for common blocks that are BIND(C). The label
9537 for a BIND(C) common block must be identical in all scoping units in which
9538 the common block is declared. Further, the binding label can not collide
9539 with any other global entity in the program. */
9542 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
9544 if (comm_block_tree->n.common->is_bind_c == 1)
9546 gfc_gsymbol *binding_label_gsym;
9547 gfc_gsymbol *comm_name_gsym;
9549 /* See if a global symbol exists by the common block's name. It may
9550 be NULL if the common block is use-associated. */
9551 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
9552 comm_block_tree->n.common->name);
9553 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
9554 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9555 "with the global entity '%s' at %L",
9556 comm_block_tree->n.common->binding_label,
9557 comm_block_tree->n.common->name,
9558 &(comm_block_tree->n.common->where),
9559 comm_name_gsym->name, &(comm_name_gsym->where));
9560 else if (comm_name_gsym != NULL
9561 && strcmp (comm_name_gsym->name,
9562 comm_block_tree->n.common->name) == 0)
9564 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9566 if (comm_name_gsym->binding_label == NULL)
9567 /* No binding label for common block stored yet; save this one. */
9568 comm_name_gsym->binding_label =
9569 comm_block_tree->n.common->binding_label;
9571 if (strcmp (comm_name_gsym->binding_label,
9572 comm_block_tree->n.common->binding_label) != 0)
9574 /* Common block names match but binding labels do not. */
9575 gfc_error ("Binding label '%s' for common block '%s' at %L "
9576 "does not match the binding label '%s' for common "
9578 comm_block_tree->n.common->binding_label,
9579 comm_block_tree->n.common->name,
9580 &(comm_block_tree->n.common->where),
9581 comm_name_gsym->binding_label,
9582 comm_name_gsym->name,
9583 &(comm_name_gsym->where));
9588 /* There is no binding label (NAME="") so we have nothing further to
9589 check and nothing to add as a global symbol for the label. */
9590 if (comm_block_tree->n.common->binding_label[0] == '\0' )
9593 binding_label_gsym =
9594 gfc_find_gsymbol (gfc_gsym_root,
9595 comm_block_tree->n.common->binding_label);
9596 if (binding_label_gsym == NULL)
9598 /* Need to make a global symbol for the binding label to prevent
9599 it from colliding with another. */
9600 binding_label_gsym =
9601 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9602 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9603 binding_label_gsym->type = GSYM_COMMON;
9607 /* If comm_name_gsym is NULL, the name common block is use
9608 associated and the name could be colliding. */
9609 if (binding_label_gsym->type != GSYM_COMMON)
9610 gfc_error ("Binding label '%s' for common block '%s' at %L "
9611 "collides with the global entity '%s' at %L",
9612 comm_block_tree->n.common->binding_label,
9613 comm_block_tree->n.common->name,
9614 &(comm_block_tree->n.common->where),
9615 binding_label_gsym->name,
9616 &(binding_label_gsym->where));
9617 else if (comm_name_gsym != NULL
9618 && (strcmp (binding_label_gsym->name,
9619 comm_name_gsym->binding_label) != 0)
9620 && (strcmp (binding_label_gsym->sym_name,
9621 comm_name_gsym->name) != 0))
9622 gfc_error ("Binding label '%s' for common block '%s' at %L "
9623 "collides with global entity '%s' at %L",
9624 binding_label_gsym->name, binding_label_gsym->sym_name,
9625 &(comm_block_tree->n.common->where),
9626 comm_name_gsym->name, &(comm_name_gsym->where));
9634 /* Verify any BIND(C) derived types in the namespace so we can report errors
9635 for them once, rather than for each variable declared of that type. */
9638 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9640 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9641 && derived_sym->attr.is_bind_c == 1)
9642 verify_bind_c_derived_type (derived_sym);
9648 /* Verify that any binding labels used in a given namespace do not collide
9649 with the names or binding labels of any global symbols. */
9652 gfc_verify_binding_labels (gfc_symbol *sym)
9656 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9657 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
9659 gfc_gsymbol *bind_c_sym;
9661 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9662 if (bind_c_sym != NULL
9663 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9665 if (sym->attr.if_source == IFSRC_DECL
9666 && (bind_c_sym->type != GSYM_SUBROUTINE
9667 && bind_c_sym->type != GSYM_FUNCTION)
9668 && ((sym->attr.contained == 1
9669 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9670 || (sym->attr.use_assoc == 1
9671 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9673 /* Make sure global procedures don't collide with anything. */
9674 gfc_error ("Binding label '%s' at %L collides with the global "
9675 "entity '%s' at %L", sym->binding_label,
9676 &(sym->declared_at), bind_c_sym->name,
9677 &(bind_c_sym->where));
9680 else if (sym->attr.contained == 0
9681 && (sym->attr.if_source == IFSRC_IFBODY
9682 && sym->attr.flavor == FL_PROCEDURE)
9683 && (bind_c_sym->sym_name != NULL
9684 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9686 /* Make sure procedures in interface bodies don't collide. */
9687 gfc_error ("Binding label '%s' in interface body at %L collides "
9688 "with the global entity '%s' at %L",
9690 &(sym->declared_at), bind_c_sym->name,
9691 &(bind_c_sym->where));
9694 else if (sym->attr.contained == 0
9695 && sym->attr.if_source == IFSRC_UNKNOWN)
9696 if ((sym->attr.use_assoc && bind_c_sym->mod_name
9697 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9698 || sym->attr.use_assoc == 0)
9700 gfc_error ("Binding label '%s' at %L collides with global "
9701 "entity '%s' at %L", sym->binding_label,
9702 &(sym->declared_at), bind_c_sym->name,
9703 &(bind_c_sym->where));
9708 /* Clear the binding label to prevent checking multiple times. */
9709 sym->binding_label[0] = '\0';
9711 else if (bind_c_sym == NULL)
9713 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9714 bind_c_sym->where = sym->declared_at;
9715 bind_c_sym->sym_name = sym->name;
9717 if (sym->attr.use_assoc == 1)
9718 bind_c_sym->mod_name = sym->module;
9720 if (sym->ns->proc_name != NULL)
9721 bind_c_sym->mod_name = sym->ns->proc_name->name;
9723 if (sym->attr.contained == 0)
9725 if (sym->attr.subroutine)
9726 bind_c_sym->type = GSYM_SUBROUTINE;
9727 else if (sym->attr.function)
9728 bind_c_sym->type = GSYM_FUNCTION;
9736 /* Resolve an index expression. */
9739 resolve_index_expr (gfc_expr *e)
9741 if (gfc_resolve_expr (e) == FAILURE)
9744 if (gfc_simplify_expr (e, 0) == FAILURE)
9747 if (gfc_specification_expr (e) == FAILURE)
9754 /* Resolve a charlen structure. */
9757 resolve_charlen (gfc_charlen *cl)
9766 specification_expr = 1;
9768 if (resolve_index_expr (cl->length) == FAILURE)
9770 specification_expr = 0;
9774 /* "If the character length parameter value evaluates to a negative
9775 value, the length of character entities declared is zero." */
9776 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9778 if (gfc_option.warn_surprising)
9779 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9780 " the length has been set to zero",
9781 &cl->length->where, i);
9782 gfc_replace_expr (cl->length,
9783 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9786 /* Check that the character length is not too large. */
9787 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9788 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9789 && cl->length->ts.type == BT_INTEGER
9790 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9792 gfc_error ("String length at %L is too large", &cl->length->where);
9800 /* Test for non-constant shape arrays. */
9803 is_non_constant_shape_array (gfc_symbol *sym)
9809 not_constant = false;
9810 if (sym->as != NULL)
9812 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9813 has not been simplified; parameter array references. Do the
9814 simplification now. */
9815 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9817 e = sym->as->lower[i];
9818 if (e && (resolve_index_expr (e) == FAILURE
9819 || !gfc_is_constant_expr (e)))
9820 not_constant = true;
9821 e = sym->as->upper[i];
9822 if (e && (resolve_index_expr (e) == FAILURE
9823 || !gfc_is_constant_expr (e)))
9824 not_constant = true;
9827 return not_constant;
9830 /* Given a symbol and an initialization expression, add code to initialize
9831 the symbol to the function entry. */
9833 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9837 gfc_namespace *ns = sym->ns;
9839 /* Search for the function namespace if this is a contained
9840 function without an explicit result. */
9841 if (sym->attr.function && sym == sym->result
9842 && sym->name != sym->ns->proc_name->name)
9845 for (;ns; ns = ns->sibling)
9846 if (strcmp (ns->proc_name->name, sym->name) == 0)
9852 gfc_free_expr (init);
9856 /* Build an l-value expression for the result. */
9857 lval = gfc_lval_expr_from_sym (sym);
9859 /* Add the code at scope entry. */
9860 init_st = gfc_get_code ();
9861 init_st->next = ns->code;
9864 /* Assign the default initializer to the l-value. */
9865 init_st->loc = sym->declared_at;
9866 init_st->op = EXEC_INIT_ASSIGN;
9867 init_st->expr1 = lval;
9868 init_st->expr2 = init;
9871 /* Assign the default initializer to a derived type variable or result. */
9874 apply_default_init (gfc_symbol *sym)
9876 gfc_expr *init = NULL;
9878 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9881 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
9882 init = gfc_default_initializer (&sym->ts);
9884 if (init == NULL && sym->ts.type != BT_CLASS)
9887 build_init_assign (sym, init);
9888 sym->attr.referenced = 1;
9891 /* Build an initializer for a local integer, real, complex, logical, or
9892 character variable, based on the command line flags finit-local-zero,
9893 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
9894 null if the symbol should not have a default initialization. */
9896 build_default_init_expr (gfc_symbol *sym)
9899 gfc_expr *init_expr;
9902 /* These symbols should never have a default initialization. */
9903 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
9904 || sym->attr.external
9906 || sym->attr.pointer
9907 || sym->attr.in_equivalence
9908 || sym->attr.in_common
9911 || sym->attr.cray_pointee
9912 || sym->attr.cray_pointer)
9915 /* Now we'll try to build an initializer expression. */
9916 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
9919 /* We will only initialize integers, reals, complex, logicals, and
9920 characters, and only if the corresponding command-line flags
9921 were set. Otherwise, we free init_expr and return null. */
9922 switch (sym->ts.type)
9925 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
9926 mpz_set_si (init_expr->value.integer,
9927 gfc_option.flag_init_integer_value);
9930 gfc_free_expr (init_expr);
9936 switch (gfc_option.flag_init_real)
9938 case GFC_INIT_REAL_SNAN:
9939 init_expr->is_snan = 1;
9941 case GFC_INIT_REAL_NAN:
9942 mpfr_set_nan (init_expr->value.real);
9945 case GFC_INIT_REAL_INF:
9946 mpfr_set_inf (init_expr->value.real, 1);
9949 case GFC_INIT_REAL_NEG_INF:
9950 mpfr_set_inf (init_expr->value.real, -1);
9953 case GFC_INIT_REAL_ZERO:
9954 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
9958 gfc_free_expr (init_expr);
9965 switch (gfc_option.flag_init_real)
9967 case GFC_INIT_REAL_SNAN:
9968 init_expr->is_snan = 1;
9970 case GFC_INIT_REAL_NAN:
9971 mpfr_set_nan (mpc_realref (init_expr->value.complex));
9972 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
9975 case GFC_INIT_REAL_INF:
9976 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
9977 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
9980 case GFC_INIT_REAL_NEG_INF:
9981 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
9982 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
9985 case GFC_INIT_REAL_ZERO:
9986 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
9990 gfc_free_expr (init_expr);
9997 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
9998 init_expr->value.logical = 0;
9999 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
10000 init_expr->value.logical = 1;
10003 gfc_free_expr (init_expr);
10009 /* For characters, the length must be constant in order to
10010 create a default initializer. */
10011 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
10012 && sym->ts.u.cl->length
10013 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
10015 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
10016 init_expr->value.character.length = char_len;
10017 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
10018 for (i = 0; i < char_len; i++)
10019 init_expr->value.character.string[i]
10020 = (unsigned char) gfc_option.flag_init_character_value;
10024 gfc_free_expr (init_expr);
10030 gfc_free_expr (init_expr);
10036 /* Add an initialization expression to a local variable. */
10038 apply_default_init_local (gfc_symbol *sym)
10040 gfc_expr *init = NULL;
10042 /* The symbol should be a variable or a function return value. */
10043 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
10044 || (sym->attr.function && sym->result != sym))
10047 /* Try to build the initializer expression. If we can't initialize
10048 this symbol, then init will be NULL. */
10049 init = build_default_init_expr (sym);
10053 /* For saved variables, we don't want to add an initializer at
10054 function entry, so we just add a static initializer. */
10055 if (sym->attr.save || sym->ns->save_all
10056 || gfc_option.flag_max_stack_var_size == 0)
10058 /* Don't clobber an existing initializer! */
10059 gcc_assert (sym->value == NULL);
10064 build_init_assign (sym, init);
10068 /* Resolution of common features of flavors variable and procedure. */
10071 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
10073 /* Avoid double diagnostics for function result symbols. */
10074 if ((sym->result || sym->attr.result) && !sym->attr.dummy
10075 && (sym->ns != gfc_current_ns))
10078 /* Constraints on deferred shape variable. */
10079 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
10081 if (sym->attr.allocatable)
10083 if (sym->attr.dimension)
10085 gfc_error ("Allocatable array '%s' at %L must have "
10086 "a deferred shape", sym->name, &sym->declared_at);
10089 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
10090 "may not be ALLOCATABLE", sym->name,
10091 &sym->declared_at) == FAILURE)
10095 if (sym->attr.pointer && sym->attr.dimension)
10097 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
10098 sym->name, &sym->declared_at);
10104 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
10105 && sym->ts.type != BT_CLASS && !sym->assoc)
10107 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10108 sym->name, &sym->declared_at);
10113 /* Constraints on polymorphic variables. */
10114 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
10117 if (sym->attr.class_ok
10118 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
10120 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10121 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
10122 &sym->declared_at);
10127 /* Assume that use associated symbols were checked in the module ns.
10128 Class-variables that are associate-names are also something special
10129 and excepted from the test. */
10130 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
10132 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10133 "or pointer", sym->name, &sym->declared_at);
10142 /* Additional checks for symbols with flavor variable and derived
10143 type. To be called from resolve_fl_variable. */
10146 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
10148 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
10150 /* Check to see if a derived type is blocked from being host
10151 associated by the presence of another class I symbol in the same
10152 namespace. 14.6.1.3 of the standard and the discussion on
10153 comp.lang.fortran. */
10154 if (sym->ns != sym->ts.u.derived->ns
10155 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
10158 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
10159 if (s && s->attr.generic)
10160 s = gfc_find_dt_in_generic (s);
10161 if (s && s->attr.flavor != FL_DERIVED)
10163 gfc_error ("The type '%s' cannot be host associated at %L "
10164 "because it is blocked by an incompatible object "
10165 "of the same name declared at %L",
10166 sym->ts.u.derived->name, &sym->declared_at,
10172 /* 4th constraint in section 11.3: "If an object of a type for which
10173 component-initialization is specified (R429) appears in the
10174 specification-part of a module and does not have the ALLOCATABLE
10175 or POINTER attribute, the object shall have the SAVE attribute."
10177 The check for initializers is performed with
10178 gfc_has_default_initializer because gfc_default_initializer generates
10179 a hidden default for allocatable components. */
10180 if (!(sym->value || no_init_flag) && sym->ns->proc_name
10181 && sym->ns->proc_name->attr.flavor == FL_MODULE
10182 && !sym->ns->save_all && !sym->attr.save
10183 && !sym->attr.pointer && !sym->attr.allocatable
10184 && gfc_has_default_initializer (sym->ts.u.derived)
10185 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
10186 "module variable '%s' at %L, needed due to "
10187 "the default initialization", sym->name,
10188 &sym->declared_at) == FAILURE)
10191 /* Assign default initializer. */
10192 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
10193 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
10195 sym->value = gfc_default_initializer (&sym->ts);
10202 /* Resolve symbols with flavor variable. */
10205 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
10207 int no_init_flag, automatic_flag;
10209 const char *auto_save_msg;
10211 auto_save_msg = "Automatic object '%s' at %L cannot have the "
10214 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10217 /* Set this flag to check that variables are parameters of all entries.
10218 This check is effected by the call to gfc_resolve_expr through
10219 is_non_constant_shape_array. */
10220 specification_expr = 1;
10222 if (sym->ns->proc_name
10223 && (sym->ns->proc_name->attr.flavor == FL_MODULE
10224 || sym->ns->proc_name->attr.is_main_program)
10225 && !sym->attr.use_assoc
10226 && !sym->attr.allocatable
10227 && !sym->attr.pointer
10228 && is_non_constant_shape_array (sym))
10230 /* The shape of a main program or module array needs to be
10232 gfc_error ("The module or main program array '%s' at %L must "
10233 "have constant shape", sym->name, &sym->declared_at);
10234 specification_expr = 0;
10238 /* Constraints on deferred type parameter. */
10239 if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
10241 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10242 "requires either the pointer or allocatable attribute",
10243 sym->name, &sym->declared_at);
10247 if (sym->ts.type == BT_CHARACTER)
10249 /* Make sure that character string variables with assumed length are
10250 dummy arguments. */
10251 e = sym->ts.u.cl->length;
10252 if (e == NULL && !sym->attr.dummy && !sym->attr.result
10253 && !sym->ts.deferred)
10255 gfc_error ("Entity with assumed character length at %L must be a "
10256 "dummy argument or a PARAMETER", &sym->declared_at);
10260 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
10262 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10266 if (!gfc_is_constant_expr (e)
10267 && !(e->expr_type == EXPR_VARIABLE
10268 && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
10270 if (!sym->attr.use_assoc && sym->ns->proc_name
10271 && (sym->ns->proc_name->attr.flavor == FL_MODULE
10272 || sym->ns->proc_name->attr.is_main_program))
10274 gfc_error ("'%s' at %L must have constant character length "
10275 "in this context", sym->name, &sym->declared_at);
10278 if (sym->attr.in_common)
10280 gfc_error ("COMMON variable '%s' at %L must have constant "
10281 "character length", sym->name, &sym->declared_at);
10287 if (sym->value == NULL && sym->attr.referenced)
10288 apply_default_init_local (sym); /* Try to apply a default initialization. */
10290 /* Determine if the symbol may not have an initializer. */
10291 no_init_flag = automatic_flag = 0;
10292 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
10293 || sym->attr.intrinsic || sym->attr.result)
10295 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
10296 && is_non_constant_shape_array (sym))
10298 no_init_flag = automatic_flag = 1;
10300 /* Also, they must not have the SAVE attribute.
10301 SAVE_IMPLICIT is checked below. */
10302 if (sym->as && sym->attr.codimension)
10304 int corank = sym->as->corank;
10305 sym->as->corank = 0;
10306 no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
10307 sym->as->corank = corank;
10309 if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
10311 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10316 /* Ensure that any initializer is simplified. */
10318 gfc_simplify_expr (sym->value, 1);
10320 /* Reject illegal initializers. */
10321 if (!sym->mark && sym->value)
10323 if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
10324 && CLASS_DATA (sym)->attr.allocatable))
10325 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10326 sym->name, &sym->declared_at);
10327 else if (sym->attr.external)
10328 gfc_error ("External '%s' at %L cannot have an initializer",
10329 sym->name, &sym->declared_at);
10330 else if (sym->attr.dummy
10331 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
10332 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10333 sym->name, &sym->declared_at);
10334 else if (sym->attr.intrinsic)
10335 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10336 sym->name, &sym->declared_at);
10337 else if (sym->attr.result)
10338 gfc_error ("Function result '%s' at %L cannot have an initializer",
10339 sym->name, &sym->declared_at);
10340 else if (automatic_flag)
10341 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10342 sym->name, &sym->declared_at);
10344 goto no_init_error;
10349 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
10350 return resolve_fl_variable_derived (sym, no_init_flag);
10356 /* Resolve a procedure. */
10359 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
10361 gfc_formal_arglist *arg;
10363 if (sym->attr.function
10364 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10367 if (sym->ts.type == BT_CHARACTER)
10369 gfc_charlen *cl = sym->ts.u.cl;
10371 if (cl && cl->length && gfc_is_constant_expr (cl->length)
10372 && resolve_charlen (cl) == FAILURE)
10375 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
10376 && sym->attr.proc == PROC_ST_FUNCTION)
10378 gfc_error ("Character-valued statement function '%s' at %L must "
10379 "have constant length", sym->name, &sym->declared_at);
10384 /* Ensure that derived type for are not of a private type. Internal
10385 module procedures are excluded by 2.2.3.3 - i.e., they are not
10386 externally accessible and can access all the objects accessible in
10388 if (!(sym->ns->parent
10389 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
10390 && gfc_check_symbol_access (sym))
10392 gfc_interface *iface;
10394 for (arg = sym->formal; arg; arg = arg->next)
10397 && arg->sym->ts.type == BT_DERIVED
10398 && !arg->sym->ts.u.derived->attr.use_assoc
10399 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10400 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
10401 "PRIVATE type and cannot be a dummy argument"
10402 " of '%s', which is PUBLIC at %L",
10403 arg->sym->name, sym->name, &sym->declared_at)
10406 /* Stop this message from recurring. */
10407 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10412 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10413 PRIVATE to the containing module. */
10414 for (iface = sym->generic; iface; iface = iface->next)
10416 for (arg = iface->sym->formal; arg; arg = arg->next)
10419 && arg->sym->ts.type == BT_DERIVED
10420 && !arg->sym->ts.u.derived->attr.use_assoc
10421 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10422 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10423 "'%s' in PUBLIC interface '%s' at %L "
10424 "takes dummy arguments of '%s' which is "
10425 "PRIVATE", iface->sym->name, sym->name,
10426 &iface->sym->declared_at,
10427 gfc_typename (&arg->sym->ts)) == FAILURE)
10429 /* Stop this message from recurring. */
10430 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10436 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10437 PRIVATE to the containing module. */
10438 for (iface = sym->generic; iface; iface = iface->next)
10440 for (arg = iface->sym->formal; arg; arg = arg->next)
10443 && arg->sym->ts.type == BT_DERIVED
10444 && !arg->sym->ts.u.derived->attr.use_assoc
10445 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10446 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10447 "'%s' in PUBLIC interface '%s' at %L "
10448 "takes dummy arguments of '%s' which is "
10449 "PRIVATE", iface->sym->name, sym->name,
10450 &iface->sym->declared_at,
10451 gfc_typename (&arg->sym->ts)) == FAILURE)
10453 /* Stop this message from recurring. */
10454 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10461 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10462 && !sym->attr.proc_pointer)
10464 gfc_error ("Function '%s' at %L cannot have an initializer",
10465 sym->name, &sym->declared_at);
10469 /* An external symbol may not have an initializer because it is taken to be
10470 a procedure. Exception: Procedure Pointers. */
10471 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10473 gfc_error ("External object '%s' at %L may not have an initializer",
10474 sym->name, &sym->declared_at);
10478 /* An elemental function is required to return a scalar 12.7.1 */
10479 if (sym->attr.elemental && sym->attr.function && sym->as)
10481 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10482 "result", sym->name, &sym->declared_at);
10483 /* Reset so that the error only occurs once. */
10484 sym->attr.elemental = 0;
10488 if (sym->attr.proc == PROC_ST_FUNCTION
10489 && (sym->attr.allocatable || sym->attr.pointer))
10491 gfc_error ("Statement function '%s' at %L may not have pointer or "
10492 "allocatable attribute", sym->name, &sym->declared_at);
10496 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10497 char-len-param shall not be array-valued, pointer-valued, recursive
10498 or pure. ....snip... A character value of * may only be used in the
10499 following ways: (i) Dummy arg of procedure - dummy associates with
10500 actual length; (ii) To declare a named constant; or (iii) External
10501 function - but length must be declared in calling scoping unit. */
10502 if (sym->attr.function
10503 && sym->ts.type == BT_CHARACTER
10504 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10506 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10507 || (sym->attr.recursive) || (sym->attr.pure))
10509 if (sym->as && sym->as->rank)
10510 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10511 "array-valued", sym->name, &sym->declared_at);
10513 if (sym->attr.pointer)
10514 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10515 "pointer-valued", sym->name, &sym->declared_at);
10517 if (sym->attr.pure)
10518 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10519 "pure", sym->name, &sym->declared_at);
10521 if (sym->attr.recursive)
10522 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10523 "recursive", sym->name, &sym->declared_at);
10528 /* Appendix B.2 of the standard. Contained functions give an
10529 error anyway. Fixed-form is likely to be F77/legacy. Deferred
10530 character length is an F2003 feature. */
10531 if (!sym->attr.contained
10532 && gfc_current_form != FORM_FIXED
10533 && !sym->ts.deferred)
10534 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10535 "CHARACTER(*) function '%s' at %L",
10536 sym->name, &sym->declared_at);
10539 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10541 gfc_formal_arglist *curr_arg;
10542 int has_non_interop_arg = 0;
10544 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10545 sym->common_block) == FAILURE)
10547 /* Clear these to prevent looking at them again if there was an
10549 sym->attr.is_bind_c = 0;
10550 sym->attr.is_c_interop = 0;
10551 sym->ts.is_c_interop = 0;
10555 /* So far, no errors have been found. */
10556 sym->attr.is_c_interop = 1;
10557 sym->ts.is_c_interop = 1;
10560 curr_arg = sym->formal;
10561 while (curr_arg != NULL)
10563 /* Skip implicitly typed dummy args here. */
10564 if (curr_arg->sym->attr.implicit_type == 0)
10565 if (gfc_verify_c_interop_param (curr_arg->sym) == FAILURE)
10566 /* If something is found to fail, record the fact so we
10567 can mark the symbol for the procedure as not being
10568 BIND(C) to try and prevent multiple errors being
10570 has_non_interop_arg = 1;
10572 curr_arg = curr_arg->next;
10575 /* See if any of the arguments were not interoperable and if so, clear
10576 the procedure symbol to prevent duplicate error messages. */
10577 if (has_non_interop_arg != 0)
10579 sym->attr.is_c_interop = 0;
10580 sym->ts.is_c_interop = 0;
10581 sym->attr.is_bind_c = 0;
10585 if (!sym->attr.proc_pointer)
10587 if (sym->attr.save == SAVE_EXPLICIT)
10589 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10590 "in '%s' at %L", sym->name, &sym->declared_at);
10593 if (sym->attr.intent)
10595 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10596 "in '%s' at %L", sym->name, &sym->declared_at);
10599 if (sym->attr.subroutine && sym->attr.result)
10601 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10602 "in '%s' at %L", sym->name, &sym->declared_at);
10605 if (sym->attr.external && sym->attr.function
10606 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10607 || sym->attr.contained))
10609 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10610 "in '%s' at %L", sym->name, &sym->declared_at);
10613 if (strcmp ("ppr@", sym->name) == 0)
10615 gfc_error ("Procedure pointer result '%s' at %L "
10616 "is missing the pointer attribute",
10617 sym->ns->proc_name->name, &sym->declared_at);
10626 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10627 been defined and we now know their defined arguments, check that they fulfill
10628 the requirements of the standard for procedures used as finalizers. */
10631 gfc_resolve_finalizers (gfc_symbol* derived)
10633 gfc_finalizer* list;
10634 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10635 gfc_try result = SUCCESS;
10636 bool seen_scalar = false;
10638 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10641 /* Walk over the list of finalizer-procedures, check them, and if any one
10642 does not fit in with the standard's definition, print an error and remove
10643 it from the list. */
10644 prev_link = &derived->f2k_derived->finalizers;
10645 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10651 /* Skip this finalizer if we already resolved it. */
10652 if (list->proc_tree)
10654 prev_link = &(list->next);
10658 /* Check this exists and is a SUBROUTINE. */
10659 if (!list->proc_sym->attr.subroutine)
10661 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10662 list->proc_sym->name, &list->where);
10666 /* We should have exactly one argument. */
10667 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10669 gfc_error ("FINAL procedure at %L must have exactly one argument",
10673 arg = list->proc_sym->formal->sym;
10675 /* This argument must be of our type. */
10676 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10678 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10679 &arg->declared_at, derived->name);
10683 /* It must neither be a pointer nor allocatable nor optional. */
10684 if (arg->attr.pointer)
10686 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10687 &arg->declared_at);
10690 if (arg->attr.allocatable)
10692 gfc_error ("Argument of FINAL procedure at %L must not be"
10693 " ALLOCATABLE", &arg->declared_at);
10696 if (arg->attr.optional)
10698 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10699 &arg->declared_at);
10703 /* It must not be INTENT(OUT). */
10704 if (arg->attr.intent == INTENT_OUT)
10706 gfc_error ("Argument of FINAL procedure at %L must not be"
10707 " INTENT(OUT)", &arg->declared_at);
10711 /* Warn if the procedure is non-scalar and not assumed shape. */
10712 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10713 && arg->as->type != AS_ASSUMED_SHAPE)
10714 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10715 " shape argument", &arg->declared_at);
10717 /* Check that it does not match in kind and rank with a FINAL procedure
10718 defined earlier. To really loop over the *earlier* declarations,
10719 we need to walk the tail of the list as new ones were pushed at the
10721 /* TODO: Handle kind parameters once they are implemented. */
10722 my_rank = (arg->as ? arg->as->rank : 0);
10723 for (i = list->next; i; i = i->next)
10725 /* Argument list might be empty; that is an error signalled earlier,
10726 but we nevertheless continued resolving. */
10727 if (i->proc_sym->formal)
10729 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10730 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10731 if (i_rank == my_rank)
10733 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10734 " rank (%d) as '%s'",
10735 list->proc_sym->name, &list->where, my_rank,
10736 i->proc_sym->name);
10742 /* Is this the/a scalar finalizer procedure? */
10743 if (!arg->as || arg->as->rank == 0)
10744 seen_scalar = true;
10746 /* Find the symtree for this procedure. */
10747 gcc_assert (!list->proc_tree);
10748 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10750 prev_link = &list->next;
10753 /* Remove wrong nodes immediately from the list so we don't risk any
10754 troubles in the future when they might fail later expectations. */
10758 *prev_link = list->next;
10759 gfc_free_finalizer (i);
10762 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10763 were nodes in the list, must have been for arrays. It is surely a good
10764 idea to have a scalar version there if there's something to finalize. */
10765 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10766 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10767 " defined at %L, suggest also scalar one",
10768 derived->name, &derived->declared_at);
10770 /* TODO: Remove this error when finalization is finished. */
10771 gfc_error ("Finalization at %L is not yet implemented",
10772 &derived->declared_at);
10778 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10781 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10782 const char* generic_name, locus where)
10787 gcc_assert (t1->specific && t2->specific);
10788 gcc_assert (!t1->specific->is_generic);
10789 gcc_assert (!t2->specific->is_generic);
10791 sym1 = t1->specific->u.specific->n.sym;
10792 sym2 = t2->specific->u.specific->n.sym;
10797 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10798 if (sym1->attr.subroutine != sym2->attr.subroutine
10799 || sym1->attr.function != sym2->attr.function)
10801 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10802 " GENERIC '%s' at %L",
10803 sym1->name, sym2->name, generic_name, &where);
10807 /* Compare the interfaces. */
10808 if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
10810 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10811 sym1->name, sym2->name, generic_name, &where);
10819 /* Worker function for resolving a generic procedure binding; this is used to
10820 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10822 The difference between those cases is finding possible inherited bindings
10823 that are overridden, as one has to look for them in tb_sym_root,
10824 tb_uop_root or tb_op, respectively. Thus the caller must already find
10825 the super-type and set p->overridden correctly. */
10828 resolve_tb_generic_targets (gfc_symbol* super_type,
10829 gfc_typebound_proc* p, const char* name)
10831 gfc_tbp_generic* target;
10832 gfc_symtree* first_target;
10833 gfc_symtree* inherited;
10835 gcc_assert (p && p->is_generic);
10837 /* Try to find the specific bindings for the symtrees in our target-list. */
10838 gcc_assert (p->u.generic);
10839 for (target = p->u.generic; target; target = target->next)
10840 if (!target->specific)
10842 gfc_typebound_proc* overridden_tbp;
10843 gfc_tbp_generic* g;
10844 const char* target_name;
10846 target_name = target->specific_st->name;
10848 /* Defined for this type directly. */
10849 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
10851 target->specific = target->specific_st->n.tb;
10852 goto specific_found;
10855 /* Look for an inherited specific binding. */
10858 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
10863 gcc_assert (inherited->n.tb);
10864 target->specific = inherited->n.tb;
10865 goto specific_found;
10869 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
10870 " at %L", target_name, name, &p->where);
10873 /* Once we've found the specific binding, check it is not ambiguous with
10874 other specifics already found or inherited for the same GENERIC. */
10876 gcc_assert (target->specific);
10878 /* This must really be a specific binding! */
10879 if (target->specific->is_generic)
10881 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
10882 " '%s' is GENERIC, too", name, &p->where, target_name);
10886 /* Check those already resolved on this type directly. */
10887 for (g = p->u.generic; g; g = g->next)
10888 if (g != target && g->specific
10889 && check_generic_tbp_ambiguity (target, g, name, p->where)
10893 /* Check for ambiguity with inherited specific targets. */
10894 for (overridden_tbp = p->overridden; overridden_tbp;
10895 overridden_tbp = overridden_tbp->overridden)
10896 if (overridden_tbp->is_generic)
10898 for (g = overridden_tbp->u.generic; g; g = g->next)
10900 gcc_assert (g->specific);
10901 if (check_generic_tbp_ambiguity (target, g,
10902 name, p->where) == FAILURE)
10908 /* If we attempt to "overwrite" a specific binding, this is an error. */
10909 if (p->overridden && !p->overridden->is_generic)
10911 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
10912 " the same name", name, &p->where);
10916 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
10917 all must have the same attributes here. */
10918 first_target = p->u.generic->specific->u.specific;
10919 gcc_assert (first_target);
10920 p->subroutine = first_target->n.sym->attr.subroutine;
10921 p->function = first_target->n.sym->attr.function;
10927 /* Resolve a GENERIC procedure binding for a derived type. */
10930 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
10932 gfc_symbol* super_type;
10934 /* Find the overridden binding if any. */
10935 st->n.tb->overridden = NULL;
10936 super_type = gfc_get_derived_super_type (derived);
10939 gfc_symtree* overridden;
10940 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
10943 if (overridden && overridden->n.tb)
10944 st->n.tb->overridden = overridden->n.tb;
10947 /* Resolve using worker function. */
10948 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
10952 /* Retrieve the target-procedure of an operator binding and do some checks in
10953 common for intrinsic and user-defined type-bound operators. */
10956 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
10958 gfc_symbol* target_proc;
10960 gcc_assert (target->specific && !target->specific->is_generic);
10961 target_proc = target->specific->u.specific->n.sym;
10962 gcc_assert (target_proc);
10964 /* All operator bindings must have a passed-object dummy argument. */
10965 if (target->specific->nopass)
10967 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
10971 return target_proc;
10975 /* Resolve a type-bound intrinsic operator. */
10978 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
10979 gfc_typebound_proc* p)
10981 gfc_symbol* super_type;
10982 gfc_tbp_generic* target;
10984 /* If there's already an error here, do nothing (but don't fail again). */
10988 /* Operators should always be GENERIC bindings. */
10989 gcc_assert (p->is_generic);
10991 /* Look for an overridden binding. */
10992 super_type = gfc_get_derived_super_type (derived);
10993 if (super_type && super_type->f2k_derived)
10994 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
10997 p->overridden = NULL;
10999 /* Resolve general GENERIC properties using worker function. */
11000 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
11003 /* Check the targets to be procedures of correct interface. */
11004 for (target = p->u.generic; target; target = target->next)
11006 gfc_symbol* target_proc;
11008 target_proc = get_checked_tb_operator_target (target, p->where);
11012 if (!gfc_check_operator_interface (target_proc, op, p->where))
11024 /* Resolve a type-bound user operator (tree-walker callback). */
11026 static gfc_symbol* resolve_bindings_derived;
11027 static gfc_try resolve_bindings_result;
11029 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
11032 resolve_typebound_user_op (gfc_symtree* stree)
11034 gfc_symbol* super_type;
11035 gfc_tbp_generic* target;
11037 gcc_assert (stree && stree->n.tb);
11039 if (stree->n.tb->error)
11042 /* Operators should always be GENERIC bindings. */
11043 gcc_assert (stree->n.tb->is_generic);
11045 /* Find overridden procedure, if any. */
11046 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11047 if (super_type && super_type->f2k_derived)
11049 gfc_symtree* overridden;
11050 overridden = gfc_find_typebound_user_op (super_type, NULL,
11051 stree->name, true, NULL);
11053 if (overridden && overridden->n.tb)
11054 stree->n.tb->overridden = overridden->n.tb;
11057 stree->n.tb->overridden = NULL;
11059 /* Resolve basically using worker function. */
11060 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
11064 /* Check the targets to be functions of correct interface. */
11065 for (target = stree->n.tb->u.generic; target; target = target->next)
11067 gfc_symbol* target_proc;
11069 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
11073 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
11080 resolve_bindings_result = FAILURE;
11081 stree->n.tb->error = 1;
11085 /* Resolve the type-bound procedures for a derived type. */
11088 resolve_typebound_procedure (gfc_symtree* stree)
11092 gfc_symbol* me_arg;
11093 gfc_symbol* super_type;
11094 gfc_component* comp;
11096 gcc_assert (stree);
11098 /* Undefined specific symbol from GENERIC target definition. */
11102 if (stree->n.tb->error)
11105 /* If this is a GENERIC binding, use that routine. */
11106 if (stree->n.tb->is_generic)
11108 if (resolve_typebound_generic (resolve_bindings_derived, stree)
11114 /* Get the target-procedure to check it. */
11115 gcc_assert (!stree->n.tb->is_generic);
11116 gcc_assert (stree->n.tb->u.specific);
11117 proc = stree->n.tb->u.specific->n.sym;
11118 where = stree->n.tb->where;
11120 /* Default access should already be resolved from the parser. */
11121 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
11123 /* It should be a module procedure or an external procedure with explicit
11124 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
11125 if ((!proc->attr.subroutine && !proc->attr.function)
11126 || (proc->attr.proc != PROC_MODULE
11127 && proc->attr.if_source != IFSRC_IFBODY)
11128 || (proc->attr.abstract && !stree->n.tb->deferred))
11130 gfc_error ("'%s' must be a module procedure or an external procedure with"
11131 " an explicit interface at %L", proc->name, &where);
11134 stree->n.tb->subroutine = proc->attr.subroutine;
11135 stree->n.tb->function = proc->attr.function;
11137 /* Find the super-type of the current derived type. We could do this once and
11138 store in a global if speed is needed, but as long as not I believe this is
11139 more readable and clearer. */
11140 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11142 /* If PASS, resolve and check arguments if not already resolved / loaded
11143 from a .mod file. */
11144 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
11146 if (stree->n.tb->pass_arg)
11148 gfc_formal_arglist* i;
11150 /* If an explicit passing argument name is given, walk the arg-list
11151 and look for it. */
11154 stree->n.tb->pass_arg_num = 1;
11155 for (i = proc->formal; i; i = i->next)
11157 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
11162 ++stree->n.tb->pass_arg_num;
11167 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11169 proc->name, stree->n.tb->pass_arg, &where,
11170 stree->n.tb->pass_arg);
11176 /* Otherwise, take the first one; there should in fact be at least
11178 stree->n.tb->pass_arg_num = 1;
11181 gfc_error ("Procedure '%s' with PASS at %L must have at"
11182 " least one argument", proc->name, &where);
11185 me_arg = proc->formal->sym;
11188 /* Now check that the argument-type matches and the passed-object
11189 dummy argument is generally fine. */
11191 gcc_assert (me_arg);
11193 if (me_arg->ts.type != BT_CLASS)
11195 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11196 " at %L", proc->name, &where);
11200 if (CLASS_DATA (me_arg)->ts.u.derived
11201 != resolve_bindings_derived)
11203 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11204 " the derived-type '%s'", me_arg->name, proc->name,
11205 me_arg->name, &where, resolve_bindings_derived->name);
11209 gcc_assert (me_arg->ts.type == BT_CLASS);
11210 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
11212 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11213 " scalar", proc->name, &where);
11216 if (CLASS_DATA (me_arg)->attr.allocatable)
11218 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11219 " be ALLOCATABLE", proc->name, &where);
11222 if (CLASS_DATA (me_arg)->attr.class_pointer)
11224 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11225 " be POINTER", proc->name, &where);
11230 /* If we are extending some type, check that we don't override a procedure
11231 flagged NON_OVERRIDABLE. */
11232 stree->n.tb->overridden = NULL;
11235 gfc_symtree* overridden;
11236 overridden = gfc_find_typebound_proc (super_type, NULL,
11237 stree->name, true, NULL);
11241 if (overridden->n.tb)
11242 stree->n.tb->overridden = overridden->n.tb;
11244 if (gfc_check_typebound_override (stree, overridden) == FAILURE)
11249 /* See if there's a name collision with a component directly in this type. */
11250 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11251 if (!strcmp (comp->name, stree->name))
11253 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11255 stree->name, &where, resolve_bindings_derived->name);
11259 /* Try to find a name collision with an inherited component. */
11260 if (super_type && gfc_find_component (super_type, stree->name, true, true))
11262 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11263 " component of '%s'",
11264 stree->name, &where, resolve_bindings_derived->name);
11268 stree->n.tb->error = 0;
11272 resolve_bindings_result = FAILURE;
11273 stree->n.tb->error = 1;
11278 resolve_typebound_procedures (gfc_symbol* derived)
11281 gfc_symbol* super_type;
11283 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11286 super_type = gfc_get_derived_super_type (derived);
11288 resolve_typebound_procedures (super_type);
11290 resolve_bindings_derived = derived;
11291 resolve_bindings_result = SUCCESS;
11293 /* Make sure the vtab has been generated. */
11294 gfc_find_derived_vtab (derived);
11296 if (derived->f2k_derived->tb_sym_root)
11297 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11298 &resolve_typebound_procedure);
11300 if (derived->f2k_derived->tb_uop_root)
11301 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11302 &resolve_typebound_user_op);
11304 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11306 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11307 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11309 resolve_bindings_result = FAILURE;
11312 return resolve_bindings_result;
11316 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11317 to give all identical derived types the same backend_decl. */
11319 add_dt_to_dt_list (gfc_symbol *derived)
11321 gfc_dt_list *dt_list;
11323 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11324 if (derived == dt_list->derived)
11327 dt_list = gfc_get_dt_list ();
11328 dt_list->next = gfc_derived_types;
11329 dt_list->derived = derived;
11330 gfc_derived_types = dt_list;
11334 /* Ensure that a derived-type is really not abstract, meaning that every
11335 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11338 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11343 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11345 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11348 if (st->n.tb && st->n.tb->deferred)
11350 gfc_symtree* overriding;
11351 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11354 gcc_assert (overriding->n.tb);
11355 if (overriding->n.tb->deferred)
11357 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11358 " '%s' is DEFERRED and not overridden",
11359 sub->name, &sub->declared_at, st->name);
11368 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11370 /* The algorithm used here is to recursively travel up the ancestry of sub
11371 and for each ancestor-type, check all bindings. If any of them is
11372 DEFERRED, look it up starting from sub and see if the found (overriding)
11373 binding is not DEFERRED.
11374 This is not the most efficient way to do this, but it should be ok and is
11375 clearer than something sophisticated. */
11377 gcc_assert (ancestor && !sub->attr.abstract);
11379 if (!ancestor->attr.abstract)
11382 /* Walk bindings of this ancestor. */
11383 if (ancestor->f2k_derived)
11386 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11391 /* Find next ancestor type and recurse on it. */
11392 ancestor = gfc_get_derived_super_type (ancestor);
11394 return ensure_not_abstract (sub, ancestor);
11400 /* Resolve the components of a derived type. This does not have to wait until
11401 resolution stage, but can be done as soon as the dt declaration has been
11405 resolve_fl_derived0 (gfc_symbol *sym)
11407 gfc_symbol* super_type;
11410 super_type = gfc_get_derived_super_type (sym);
11413 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11415 gfc_error ("As extending type '%s' at %L has a coarray component, "
11416 "parent type '%s' shall also have one", sym->name,
11417 &sym->declared_at, super_type->name);
11421 /* Ensure the extended type gets resolved before we do. */
11422 if (super_type && resolve_fl_derived0 (super_type) == FAILURE)
11425 /* An ABSTRACT type must be extensible. */
11426 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11428 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11429 sym->name, &sym->declared_at);
11433 for (c = sym->components; c != NULL; c = c->next)
11436 if ((!sym->attr.is_class || c != sym->components)
11437 && c->attr.codimension
11438 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11440 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11441 "deferred shape", c->name, &c->loc);
11446 if (c->attr.codimension && c->ts.type == BT_DERIVED
11447 && c->ts.u.derived->ts.is_iso_c)
11449 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11450 "shall not be a coarray", c->name, &c->loc);
11455 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11456 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11457 || c->attr.allocatable))
11459 gfc_error ("Component '%s' at %L with coarray component "
11460 "shall be a nonpointer, nonallocatable scalar",
11466 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11468 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11469 "is not an array pointer", c->name, &c->loc);
11473 if (c->attr.proc_pointer && c->ts.interface)
11475 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11476 gfc_error ("Interface '%s', used by procedure pointer component "
11477 "'%s' at %L, is declared in a later PROCEDURE statement",
11478 c->ts.interface->name, c->name, &c->loc);
11480 /* Get the attributes from the interface (now resolved). */
11481 if (c->ts.interface->attr.if_source
11482 || c->ts.interface->attr.intrinsic)
11484 gfc_symbol *ifc = c->ts.interface;
11486 if (ifc->formal && !ifc->formal_ns)
11487 resolve_symbol (ifc);
11489 if (ifc->attr.intrinsic)
11490 resolve_intrinsic (ifc, &ifc->declared_at);
11494 c->ts = ifc->result->ts;
11495 c->attr.allocatable = ifc->result->attr.allocatable;
11496 c->attr.pointer = ifc->result->attr.pointer;
11497 c->attr.dimension = ifc->result->attr.dimension;
11498 c->as = gfc_copy_array_spec (ifc->result->as);
11503 c->attr.allocatable = ifc->attr.allocatable;
11504 c->attr.pointer = ifc->attr.pointer;
11505 c->attr.dimension = ifc->attr.dimension;
11506 c->as = gfc_copy_array_spec (ifc->as);
11508 c->ts.interface = ifc;
11509 c->attr.function = ifc->attr.function;
11510 c->attr.subroutine = ifc->attr.subroutine;
11511 gfc_copy_formal_args_ppc (c, ifc);
11513 c->attr.pure = ifc->attr.pure;
11514 c->attr.elemental = ifc->attr.elemental;
11515 c->attr.recursive = ifc->attr.recursive;
11516 c->attr.always_explicit = ifc->attr.always_explicit;
11517 c->attr.ext_attr |= ifc->attr.ext_attr;
11518 /* Replace symbols in array spec. */
11522 for (i = 0; i < c->as->rank; i++)
11524 gfc_expr_replace_comp (c->as->lower[i], c);
11525 gfc_expr_replace_comp (c->as->upper[i], c);
11528 /* Copy char length. */
11529 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11531 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11532 gfc_expr_replace_comp (cl->length, c);
11533 if (cl->length && !cl->resolved
11534 && gfc_resolve_expr (cl->length) == FAILURE)
11539 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11541 gfc_error ("Interface '%s' of procedure pointer component "
11542 "'%s' at %L must be explicit", c->ts.interface->name,
11547 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11549 /* Since PPCs are not implicitly typed, a PPC without an explicit
11550 interface must be a subroutine. */
11551 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11554 /* Procedure pointer components: Check PASS arg. */
11555 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11556 && !sym->attr.vtype)
11558 gfc_symbol* me_arg;
11560 if (c->tb->pass_arg)
11562 gfc_formal_arglist* i;
11564 /* If an explicit passing argument name is given, walk the arg-list
11565 and look for it. */
11568 c->tb->pass_arg_num = 1;
11569 for (i = c->formal; i; i = i->next)
11571 if (!strcmp (i->sym->name, c->tb->pass_arg))
11576 c->tb->pass_arg_num++;
11581 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11582 "at %L has no argument '%s'", c->name,
11583 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11590 /* Otherwise, take the first one; there should in fact be at least
11592 c->tb->pass_arg_num = 1;
11595 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11596 "must have at least one argument",
11601 me_arg = c->formal->sym;
11604 /* Now check that the argument-type matches. */
11605 gcc_assert (me_arg);
11606 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11607 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11608 || (me_arg->ts.type == BT_CLASS
11609 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11611 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11612 " the derived type '%s'", me_arg->name, c->name,
11613 me_arg->name, &c->loc, sym->name);
11618 /* Check for C453. */
11619 if (me_arg->attr.dimension)
11621 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11622 "must be scalar", me_arg->name, c->name, me_arg->name,
11628 if (me_arg->attr.pointer)
11630 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11631 "may not have the POINTER attribute", me_arg->name,
11632 c->name, me_arg->name, &c->loc);
11637 if (me_arg->attr.allocatable)
11639 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11640 "may not be ALLOCATABLE", me_arg->name, c->name,
11641 me_arg->name, &c->loc);
11646 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11647 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11648 " at %L", c->name, &c->loc);
11652 /* Check type-spec if this is not the parent-type component. */
11653 if ((!sym->attr.extension || c != sym->components) && !sym->attr.vtype
11654 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11657 /* If this type is an extension, set the accessibility of the parent
11659 if (super_type && c == sym->components
11660 && strcmp (super_type->name, c->name) == 0)
11661 c->attr.access = super_type->attr.access;
11663 /* If this type is an extension, see if this component has the same name
11664 as an inherited type-bound procedure. */
11665 if (super_type && !sym->attr.is_class
11666 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11668 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11669 " inherited type-bound procedure",
11670 c->name, sym->name, &c->loc);
11674 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
11675 && !c->ts.deferred)
11677 if (c->ts.u.cl->length == NULL
11678 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11679 || !gfc_is_constant_expr (c->ts.u.cl->length))
11681 gfc_error ("Character length of component '%s' needs to "
11682 "be a constant specification expression at %L",
11684 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11689 if (c->ts.type == BT_CHARACTER && c->ts.deferred
11690 && !c->attr.pointer && !c->attr.allocatable)
11692 gfc_error ("Character component '%s' of '%s' at %L with deferred "
11693 "length must be a POINTER or ALLOCATABLE",
11694 c->name, sym->name, &c->loc);
11698 if (c->ts.type == BT_DERIVED
11699 && sym->component_access != ACCESS_PRIVATE
11700 && gfc_check_symbol_access (sym)
11701 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11702 && !c->ts.u.derived->attr.use_assoc
11703 && !gfc_check_symbol_access (c->ts.u.derived)
11704 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11705 "is a PRIVATE type and cannot be a component of "
11706 "'%s', which is PUBLIC at %L", c->name,
11707 sym->name, &sym->declared_at) == FAILURE)
11710 if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
11712 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11713 "type %s", c->name, &c->loc, sym->name);
11717 if (sym->attr.sequence)
11719 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11721 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11722 "not have the SEQUENCE attribute",
11723 c->ts.u.derived->name, &sym->declared_at);
11728 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
11729 c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
11730 else if (c->ts.type == BT_CLASS && c->attr.class_ok
11731 && CLASS_DATA (c)->ts.u.derived->attr.generic)
11732 CLASS_DATA (c)->ts.u.derived
11733 = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
11735 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
11736 && c->attr.pointer && c->ts.u.derived->components == NULL
11737 && !c->ts.u.derived->attr.zero_comp)
11739 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11740 "that has not been declared", c->name, sym->name,
11745 if (c->ts.type == BT_CLASS && c->attr.class_ok
11746 && CLASS_DATA (c)->attr.class_pointer
11747 && CLASS_DATA (c)->ts.u.derived->components == NULL
11748 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11750 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11751 "that has not been declared", c->name, sym->name,
11757 if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE
11758 && (!c->attr.class_ok
11759 || !(CLASS_DATA (c)->attr.class_pointer
11760 || CLASS_DATA (c)->attr.allocatable)))
11762 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11763 "or pointer", c->name, &c->loc);
11767 /* Ensure that all the derived type components are put on the
11768 derived type list; even in formal namespaces, where derived type
11769 pointer components might not have been declared. */
11770 if (c->ts.type == BT_DERIVED
11772 && c->ts.u.derived->components
11774 && sym != c->ts.u.derived)
11775 add_dt_to_dt_list (c->ts.u.derived);
11777 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11778 || c->attr.proc_pointer
11779 || c->attr.allocatable)) == FAILURE)
11783 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11784 all DEFERRED bindings are overridden. */
11785 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11786 && !sym->attr.is_class
11787 && ensure_not_abstract (sym, super_type) == FAILURE)
11790 /* Add derived type to the derived type list. */
11791 add_dt_to_dt_list (sym);
11797 /* The following procedure does the full resolution of a derived type,
11798 including resolution of all type-bound procedures (if present). In contrast
11799 to 'resolve_fl_derived0' this can only be done after the module has been
11800 parsed completely. */
11803 resolve_fl_derived (gfc_symbol *sym)
11805 gfc_symbol *gen_dt = NULL;
11807 if (!sym->attr.is_class)
11808 gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
11809 if (gen_dt && gen_dt->generic && gen_dt->generic->next
11810 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Generic name '%s' of "
11811 "function '%s' at %L being the same name as derived "
11812 "type at %L", sym->name,
11813 gen_dt->generic->sym == sym
11814 ? gen_dt->generic->next->sym->name
11815 : gen_dt->generic->sym->name,
11816 gen_dt->generic->sym == sym
11817 ? &gen_dt->generic->next->sym->declared_at
11818 : &gen_dt->generic->sym->declared_at,
11819 &sym->declared_at) == FAILURE)
11822 if (sym->attr.is_class && sym->ts.u.derived == NULL)
11824 /* Fix up incomplete CLASS symbols. */
11825 gfc_component *data = gfc_find_component (sym, "_data", true, true);
11826 gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
11827 if (vptr->ts.u.derived == NULL)
11829 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
11831 vptr->ts.u.derived = vtab->ts.u.derived;
11835 if (resolve_fl_derived0 (sym) == FAILURE)
11838 /* Resolve the type-bound procedures. */
11839 if (resolve_typebound_procedures (sym) == FAILURE)
11842 /* Resolve the finalizer procedures. */
11843 if (gfc_resolve_finalizers (sym) == FAILURE)
11851 resolve_fl_namelist (gfc_symbol *sym)
11856 for (nl = sym->namelist; nl; nl = nl->next)
11858 /* Check again, the check in match only works if NAMELIST comes
11860 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
11862 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
11863 "allowed", nl->sym->name, sym->name, &sym->declared_at);
11867 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
11868 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
11869 "object '%s' with assumed shape in namelist "
11870 "'%s' at %L", nl->sym->name, sym->name,
11871 &sym->declared_at) == FAILURE)
11874 if (is_non_constant_shape_array (nl->sym)
11875 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
11876 "object '%s' with nonconstant shape in namelist "
11877 "'%s' at %L", nl->sym->name, sym->name,
11878 &sym->declared_at) == FAILURE)
11881 if (nl->sym->ts.type == BT_CHARACTER
11882 && (nl->sym->ts.u.cl->length == NULL
11883 || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
11884 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
11885 "'%s' with nonconstant character length in "
11886 "namelist '%s' at %L", nl->sym->name, sym->name,
11887 &sym->declared_at) == FAILURE)
11890 /* FIXME: Once UDDTIO is implemented, the following can be
11892 if (nl->sym->ts.type == BT_CLASS)
11894 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
11895 "polymorphic and requires a defined input/output "
11896 "procedure", nl->sym->name, sym->name, &sym->declared_at);
11900 if (nl->sym->ts.type == BT_DERIVED
11901 && (nl->sym->ts.u.derived->attr.alloc_comp
11902 || nl->sym->ts.u.derived->attr.pointer_comp))
11904 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
11905 "'%s' in namelist '%s' at %L with ALLOCATABLE "
11906 "or POINTER components", nl->sym->name,
11907 sym->name, &sym->declared_at) == FAILURE)
11910 /* FIXME: Once UDDTIO is implemented, the following can be
11912 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
11913 "ALLOCATABLE or POINTER components and thus requires "
11914 "a defined input/output procedure", nl->sym->name,
11915 sym->name, &sym->declared_at);
11920 /* Reject PRIVATE objects in a PUBLIC namelist. */
11921 if (gfc_check_symbol_access (sym))
11923 for (nl = sym->namelist; nl; nl = nl->next)
11925 if (!nl->sym->attr.use_assoc
11926 && !is_sym_host_assoc (nl->sym, sym->ns)
11927 && !gfc_check_symbol_access (nl->sym))
11929 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
11930 "cannot be member of PUBLIC namelist '%s' at %L",
11931 nl->sym->name, sym->name, &sym->declared_at);
11935 /* Types with private components that came here by USE-association. */
11936 if (nl->sym->ts.type == BT_DERIVED
11937 && derived_inaccessible (nl->sym->ts.u.derived))
11939 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
11940 "components and cannot be member of namelist '%s' at %L",
11941 nl->sym->name, sym->name, &sym->declared_at);
11945 /* Types with private components that are defined in the same module. */
11946 if (nl->sym->ts.type == BT_DERIVED
11947 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
11948 && nl->sym->ts.u.derived->attr.private_comp)
11950 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
11951 "cannot be a member of PUBLIC namelist '%s' at %L",
11952 nl->sym->name, sym->name, &sym->declared_at);
11959 /* 14.1.2 A module or internal procedure represent local entities
11960 of the same type as a namelist member and so are not allowed. */
11961 for (nl = sym->namelist; nl; nl = nl->next)
11963 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
11966 if (nl->sym->attr.function && nl->sym == nl->sym->result)
11967 if ((nl->sym == sym->ns->proc_name)
11969 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
11973 if (nl->sym && nl->sym->name)
11974 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
11975 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
11977 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
11978 "attribute in '%s' at %L", nlsym->name,
11979 &sym->declared_at);
11989 resolve_fl_parameter (gfc_symbol *sym)
11991 /* A parameter array's shape needs to be constant. */
11992 if (sym->as != NULL
11993 && (sym->as->type == AS_DEFERRED
11994 || is_non_constant_shape_array (sym)))
11996 gfc_error ("Parameter array '%s' at %L cannot be automatic "
11997 "or of deferred shape", sym->name, &sym->declared_at);
12001 /* Make sure a parameter that has been implicitly typed still
12002 matches the implicit type, since PARAMETER statements can precede
12003 IMPLICIT statements. */
12004 if (sym->attr.implicit_type
12005 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
12008 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12009 "later IMPLICIT type", sym->name, &sym->declared_at);
12013 /* Make sure the types of derived parameters are consistent. This
12014 type checking is deferred until resolution because the type may
12015 refer to a derived type from the host. */
12016 if (sym->ts.type == BT_DERIVED && sym->value
12017 && !gfc_compare_types (&sym->ts, &sym->value->ts))
12019 gfc_error ("Incompatible derived type in PARAMETER at %L",
12020 &sym->value->where);
12027 /* Do anything necessary to resolve a symbol. Right now, we just
12028 assume that an otherwise unknown symbol is a variable. This sort
12029 of thing commonly happens for symbols in module. */
12032 resolve_symbol (gfc_symbol *sym)
12034 int check_constant, mp_flag;
12035 gfc_symtree *symtree;
12036 gfc_symtree *this_symtree;
12040 if (sym->attr.flavor == FL_UNKNOWN)
12043 /* If we find that a flavorless symbol is an interface in one of the
12044 parent namespaces, find its symtree in this namespace, free the
12045 symbol and set the symtree to point to the interface symbol. */
12046 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
12048 symtree = gfc_find_symtree (ns->sym_root, sym->name);
12049 if (symtree && (symtree->n.sym->generic ||
12050 (symtree->n.sym->attr.flavor == FL_PROCEDURE
12051 && sym->ns->construct_entities)))
12053 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
12055 gfc_release_symbol (sym);
12056 symtree->n.sym->refs++;
12057 this_symtree->n.sym = symtree->n.sym;
12062 /* Otherwise give it a flavor according to such attributes as
12064 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
12065 sym->attr.flavor = FL_VARIABLE;
12068 sym->attr.flavor = FL_PROCEDURE;
12069 if (sym->attr.dimension)
12070 sym->attr.function = 1;
12074 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
12075 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
12077 if (sym->attr.procedure && sym->ts.interface
12078 && sym->attr.if_source != IFSRC_DECL
12079 && resolve_procedure_interface (sym) == FAILURE)
12082 if (sym->attr.is_protected && !sym->attr.proc_pointer
12083 && (sym->attr.procedure || sym->attr.external))
12085 if (sym->attr.external)
12086 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12087 "at %L", &sym->declared_at);
12089 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12090 "at %L", &sym->declared_at);
12097 if (sym->attr.contiguous
12098 && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE
12099 && !sym->attr.pointer)))
12101 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12102 "array pointer or an assumed-shape array", sym->name,
12103 &sym->declared_at);
12107 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
12110 /* Symbols that are module procedures with results (functions) have
12111 the types and array specification copied for type checking in
12112 procedures that call them, as well as for saving to a module
12113 file. These symbols can't stand the scrutiny that their results
12115 mp_flag = (sym->result != NULL && sym->result != sym);
12117 /* Make sure that the intrinsic is consistent with its internal
12118 representation. This needs to be done before assigning a default
12119 type to avoid spurious warnings. */
12120 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
12121 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
12124 /* Resolve associate names. */
12126 resolve_assoc_var (sym, true);
12128 /* Assign default type to symbols that need one and don't have one. */
12129 if (sym->ts.type == BT_UNKNOWN)
12131 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
12132 gfc_set_default_type (sym, 1, NULL);
12134 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
12135 && !sym->attr.function && !sym->attr.subroutine
12136 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
12137 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
12139 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
12141 /* The specific case of an external procedure should emit an error
12142 in the case that there is no implicit type. */
12144 gfc_set_default_type (sym, sym->attr.external, NULL);
12147 /* Result may be in another namespace. */
12148 resolve_symbol (sym->result);
12150 if (!sym->result->attr.proc_pointer)
12152 sym->ts = sym->result->ts;
12153 sym->as = gfc_copy_array_spec (sym->result->as);
12154 sym->attr.dimension = sym->result->attr.dimension;
12155 sym->attr.pointer = sym->result->attr.pointer;
12156 sym->attr.allocatable = sym->result->attr.allocatable;
12157 sym->attr.contiguous = sym->result->attr.contiguous;
12162 else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
12163 gfc_resolve_array_spec (sym->result->as, false);
12165 /* Assumed size arrays and assumed shape arrays must be dummy
12166 arguments. Array-spec's of implied-shape should have been resolved to
12167 AS_EXPLICIT already. */
12171 gcc_assert (sym->as->type != AS_IMPLIED_SHAPE);
12172 if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
12173 || sym->as->type == AS_ASSUMED_SHAPE)
12174 && sym->attr.dummy == 0)
12176 if (sym->as->type == AS_ASSUMED_SIZE)
12177 gfc_error ("Assumed size array at %L must be a dummy argument",
12178 &sym->declared_at);
12180 gfc_error ("Assumed shape array at %L must be a dummy argument",
12181 &sym->declared_at);
12186 /* Make sure symbols with known intent or optional are really dummy
12187 variable. Because of ENTRY statement, this has to be deferred
12188 until resolution time. */
12190 if (!sym->attr.dummy
12191 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
12193 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
12197 if (sym->attr.value && !sym->attr.dummy)
12199 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12200 "it is not a dummy argument", sym->name, &sym->declared_at);
12204 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
12206 gfc_charlen *cl = sym->ts.u.cl;
12207 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
12209 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12210 "attribute must have constant length",
12211 sym->name, &sym->declared_at);
12215 if (sym->ts.is_c_interop
12216 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
12218 gfc_error ("C interoperable character dummy variable '%s' at %L "
12219 "with VALUE attribute must have length one",
12220 sym->name, &sym->declared_at);
12225 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
12226 && sym->ts.u.derived->attr.generic)
12228 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
12229 if (!sym->ts.u.derived)
12231 gfc_error ("The derived type '%s' at %L is of type '%s', "
12232 "which has not been defined", sym->name,
12233 &sym->declared_at, sym->ts.u.derived->name);
12234 sym->ts.type = BT_UNKNOWN;
12239 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12240 do this for something that was implicitly typed because that is handled
12241 in gfc_set_default_type. Handle dummy arguments and procedure
12242 definitions separately. Also, anything that is use associated is not
12243 handled here but instead is handled in the module it is declared in.
12244 Finally, derived type definitions are allowed to be BIND(C) since that
12245 only implies that they're interoperable, and they are checked fully for
12246 interoperability when a variable is declared of that type. */
12247 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
12248 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
12249 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
12251 gfc_try t = SUCCESS;
12253 /* First, make sure the variable is declared at the
12254 module-level scope (J3/04-007, Section 15.3). */
12255 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
12256 sym->attr.in_common == 0)
12258 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12259 "is neither a COMMON block nor declared at the "
12260 "module level scope", sym->name, &(sym->declared_at));
12263 else if (sym->common_head != NULL)
12265 t = verify_com_block_vars_c_interop (sym->common_head);
12269 /* If type() declaration, we need to verify that the components
12270 of the given type are all C interoperable, etc. */
12271 if (sym->ts.type == BT_DERIVED &&
12272 sym->ts.u.derived->attr.is_c_interop != 1)
12274 /* Make sure the user marked the derived type as BIND(C). If
12275 not, call the verify routine. This could print an error
12276 for the derived type more than once if multiple variables
12277 of that type are declared. */
12278 if (sym->ts.u.derived->attr.is_bind_c != 1)
12279 verify_bind_c_derived_type (sym->ts.u.derived);
12283 /* Verify the variable itself as C interoperable if it
12284 is BIND(C). It is not possible for this to succeed if
12285 the verify_bind_c_derived_type failed, so don't have to handle
12286 any error returned by verify_bind_c_derived_type. */
12287 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
12288 sym->common_block);
12293 /* clear the is_bind_c flag to prevent reporting errors more than
12294 once if something failed. */
12295 sym->attr.is_bind_c = 0;
12300 /* If a derived type symbol has reached this point, without its
12301 type being declared, we have an error. Notice that most
12302 conditions that produce undefined derived types have already
12303 been dealt with. However, the likes of:
12304 implicit type(t) (t) ..... call foo (t) will get us here if
12305 the type is not declared in the scope of the implicit
12306 statement. Change the type to BT_UNKNOWN, both because it is so
12307 and to prevent an ICE. */
12308 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
12309 && sym->ts.u.derived->components == NULL
12310 && !sym->ts.u.derived->attr.zero_comp)
12312 gfc_error ("The derived type '%s' at %L is of type '%s', "
12313 "which has not been defined", sym->name,
12314 &sym->declared_at, sym->ts.u.derived->name);
12315 sym->ts.type = BT_UNKNOWN;
12319 /* Make sure that the derived type has been resolved and that the
12320 derived type is visible in the symbol's namespace, if it is a
12321 module function and is not PRIVATE. */
12322 if (sym->ts.type == BT_DERIVED
12323 && sym->ts.u.derived->attr.use_assoc
12324 && sym->ns->proc_name
12325 && sym->ns->proc_name->attr.flavor == FL_MODULE
12326 && resolve_fl_derived (sym->ts.u.derived) == FAILURE)
12329 /* Unless the derived-type declaration is use associated, Fortran 95
12330 does not allow public entries of private derived types.
12331 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12332 161 in 95-006r3. */
12333 if (sym->ts.type == BT_DERIVED
12334 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12335 && !sym->ts.u.derived->attr.use_assoc
12336 && gfc_check_symbol_access (sym)
12337 && !gfc_check_symbol_access (sym->ts.u.derived)
12338 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12339 "of PRIVATE derived type '%s'",
12340 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12341 : "variable", sym->name, &sym->declared_at,
12342 sym->ts.u.derived->name) == FAILURE)
12345 /* F2008, C1302. */
12346 if (sym->ts.type == BT_DERIVED
12347 && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
12348 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
12349 || sym->ts.u.derived->attr.lock_comp)
12350 && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
12352 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
12353 "type LOCK_TYPE must be a coarray", sym->name,
12354 &sym->declared_at);
12358 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12359 default initialization is defined (5.1.2.4.4). */
12360 if (sym->ts.type == BT_DERIVED
12362 && sym->attr.intent == INTENT_OUT
12364 && sym->as->type == AS_ASSUMED_SIZE)
12366 for (c = sym->ts.u.derived->components; c; c = c->next)
12368 if (c->initializer)
12370 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12371 "ASSUMED SIZE and so cannot have a default initializer",
12372 sym->name, &sym->declared_at);
12379 if (sym->ts.type == BT_DERIVED && sym->attr.dummy
12380 && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
12382 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
12383 "INTENT(OUT)", sym->name, &sym->declared_at);
12388 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12389 || sym->attr.codimension)
12390 && (sym->attr.result || sym->result == sym))
12392 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12393 "a coarray component", sym->name, &sym->declared_at);
12398 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12399 && sym->ts.u.derived->ts.is_iso_c)
12401 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12402 "shall not be a coarray", sym->name, &sym->declared_at);
12407 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
12408 && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
12409 || sym->attr.allocatable))
12411 gfc_error ("Variable '%s' at %L with coarray component "
12412 "shall be a nonpointer, nonallocatable scalar",
12413 sym->name, &sym->declared_at);
12417 /* F2008, C526. The function-result case was handled above. */
12418 if (sym->attr.codimension
12419 && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
12420 || sym->ns->save_all
12421 || sym->ns->proc_name->attr.flavor == FL_MODULE
12422 || sym->ns->proc_name->attr.is_main_program
12423 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12425 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
12426 "nor a dummy argument", sym->name, &sym->declared_at);
12429 /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
12430 else if (sym->attr.codimension && !sym->attr.allocatable
12431 && sym->as && sym->as->cotype == AS_DEFERRED)
12433 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12434 "deferred shape", sym->name, &sym->declared_at);
12437 else if (sym->attr.codimension && sym->attr.allocatable
12438 && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
12440 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12441 "deferred shape", sym->name, &sym->declared_at);
12446 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12447 || (sym->attr.codimension && sym->attr.allocatable))
12448 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12450 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12451 "allocatable coarray or have coarray components",
12452 sym->name, &sym->declared_at);
12456 if (sym->attr.codimension && sym->attr.dummy
12457 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12459 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12460 "procedure '%s'", sym->name, &sym->declared_at,
12461 sym->ns->proc_name->name);
12465 switch (sym->attr.flavor)
12468 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12473 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12478 if (resolve_fl_namelist (sym) == FAILURE)
12483 if (resolve_fl_parameter (sym) == FAILURE)
12491 /* Resolve array specifier. Check as well some constraints
12492 on COMMON blocks. */
12494 check_constant = sym->attr.in_common && !sym->attr.pointer;
12496 /* Set the formal_arg_flag so that check_conflict will not throw
12497 an error for host associated variables in the specification
12498 expression for an array_valued function. */
12499 if (sym->attr.function && sym->as)
12500 formal_arg_flag = 1;
12502 gfc_resolve_array_spec (sym->as, check_constant);
12504 formal_arg_flag = 0;
12506 /* Resolve formal namespaces. */
12507 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12508 && !sym->attr.contained && !sym->attr.intrinsic)
12509 gfc_resolve (sym->formal_ns);
12511 /* Make sure the formal namespace is present. */
12512 if (sym->formal && !sym->formal_ns)
12514 gfc_formal_arglist *formal = sym->formal;
12515 while (formal && !formal->sym)
12516 formal = formal->next;
12520 sym->formal_ns = formal->sym->ns;
12521 sym->formal_ns->refs++;
12525 /* Check threadprivate restrictions. */
12526 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12527 && (!sym->attr.in_common
12528 && sym->module == NULL
12529 && (sym->ns->proc_name == NULL
12530 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12531 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12533 /* If we have come this far we can apply default-initializers, as
12534 described in 14.7.5, to those variables that have not already
12535 been assigned one. */
12536 if (sym->ts.type == BT_DERIVED
12537 && sym->ns == gfc_current_ns
12539 && !sym->attr.allocatable
12540 && !sym->attr.alloc_comp)
12542 symbol_attribute *a = &sym->attr;
12544 if ((!a->save && !a->dummy && !a->pointer
12545 && !a->in_common && !a->use_assoc
12546 && (a->referenced || a->result)
12547 && !(a->function && sym != sym->result))
12548 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12549 apply_default_init (sym);
12552 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
12553 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
12554 && !CLASS_DATA (sym)->attr.class_pointer
12555 && !CLASS_DATA (sym)->attr.allocatable)
12556 apply_default_init (sym);
12558 /* If this symbol has a type-spec, check it. */
12559 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12560 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12561 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12567 /************* Resolve DATA statements *************/
12571 gfc_data_value *vnode;
12577 /* Advance the values structure to point to the next value in the data list. */
12580 next_data_value (void)
12582 while (mpz_cmp_ui (values.left, 0) == 0)
12585 if (values.vnode->next == NULL)
12588 values.vnode = values.vnode->next;
12589 mpz_set (values.left, values.vnode->repeat);
12597 check_data_variable (gfc_data_variable *var, locus *where)
12603 ar_type mark = AR_UNKNOWN;
12605 mpz_t section_index[GFC_MAX_DIMENSIONS];
12611 if (gfc_resolve_expr (var->expr) == FAILURE)
12615 mpz_init_set_si (offset, 0);
12618 if (e->expr_type != EXPR_VARIABLE)
12619 gfc_internal_error ("check_data_variable(): Bad expression");
12621 sym = e->symtree->n.sym;
12623 if (sym->ns->is_block_data && !sym->attr.in_common)
12625 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12626 sym->name, &sym->declared_at);
12629 if (e->ref == NULL && sym->as)
12631 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12632 " declaration", sym->name, where);
12636 has_pointer = sym->attr.pointer;
12638 if (gfc_is_coindexed (e))
12640 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name,
12645 for (ref = e->ref; ref; ref = ref->next)
12647 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12651 && ref->type == REF_ARRAY
12652 && ref->u.ar.type != AR_FULL)
12654 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12655 "be a full array", sym->name, where);
12660 if (e->rank == 0 || has_pointer)
12662 mpz_init_set_ui (size, 1);
12669 /* Find the array section reference. */
12670 for (ref = e->ref; ref; ref = ref->next)
12672 if (ref->type != REF_ARRAY)
12674 if (ref->u.ar.type == AR_ELEMENT)
12680 /* Set marks according to the reference pattern. */
12681 switch (ref->u.ar.type)
12689 /* Get the start position of array section. */
12690 gfc_get_section_index (ar, section_index, &offset);
12695 gcc_unreachable ();
12698 if (gfc_array_size (e, &size) == FAILURE)
12700 gfc_error ("Nonconstant array section at %L in DATA statement",
12702 mpz_clear (offset);
12709 while (mpz_cmp_ui (size, 0) > 0)
12711 if (next_data_value () == FAILURE)
12713 gfc_error ("DATA statement at %L has more variables than values",
12719 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12723 /* If we have more than one element left in the repeat count,
12724 and we have more than one element left in the target variable,
12725 then create a range assignment. */
12726 /* FIXME: Only done for full arrays for now, since array sections
12728 if (mark == AR_FULL && ref && ref->next == NULL
12729 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12733 if (mpz_cmp (size, values.left) >= 0)
12735 mpz_init_set (range, values.left);
12736 mpz_sub (size, size, values.left);
12737 mpz_set_ui (values.left, 0);
12741 mpz_init_set (range, size);
12742 mpz_sub (values.left, values.left, size);
12743 mpz_set_ui (size, 0);
12746 t = gfc_assign_data_value (var->expr, values.vnode->expr,
12749 mpz_add (offset, offset, range);
12756 /* Assign initial value to symbol. */
12759 mpz_sub_ui (values.left, values.left, 1);
12760 mpz_sub_ui (size, size, 1);
12762 t = gfc_assign_data_value (var->expr, values.vnode->expr,
12767 if (mark == AR_FULL)
12768 mpz_add_ui (offset, offset, 1);
12770 /* Modify the array section indexes and recalculate the offset
12771 for next element. */
12772 else if (mark == AR_SECTION)
12773 gfc_advance_section (section_index, ar, &offset);
12777 if (mark == AR_SECTION)
12779 for (i = 0; i < ar->dimen; i++)
12780 mpz_clear (section_index[i]);
12784 mpz_clear (offset);
12790 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
12792 /* Iterate over a list of elements in a DATA statement. */
12795 traverse_data_list (gfc_data_variable *var, locus *where)
12798 iterator_stack frame;
12799 gfc_expr *e, *start, *end, *step;
12800 gfc_try retval = SUCCESS;
12802 mpz_init (frame.value);
12805 start = gfc_copy_expr (var->iter.start);
12806 end = gfc_copy_expr (var->iter.end);
12807 step = gfc_copy_expr (var->iter.step);
12809 if (gfc_simplify_expr (start, 1) == FAILURE
12810 || start->expr_type != EXPR_CONSTANT)
12812 gfc_error ("start of implied-do loop at %L could not be "
12813 "simplified to a constant value", &start->where);
12817 if (gfc_simplify_expr (end, 1) == FAILURE
12818 || end->expr_type != EXPR_CONSTANT)
12820 gfc_error ("end of implied-do loop at %L could not be "
12821 "simplified to a constant value", &start->where);
12825 if (gfc_simplify_expr (step, 1) == FAILURE
12826 || step->expr_type != EXPR_CONSTANT)
12828 gfc_error ("step of implied-do loop at %L could not be "
12829 "simplified to a constant value", &start->where);
12834 mpz_set (trip, end->value.integer);
12835 mpz_sub (trip, trip, start->value.integer);
12836 mpz_add (trip, trip, step->value.integer);
12838 mpz_div (trip, trip, step->value.integer);
12840 mpz_set (frame.value, start->value.integer);
12842 frame.prev = iter_stack;
12843 frame.variable = var->iter.var->symtree;
12844 iter_stack = &frame;
12846 while (mpz_cmp_ui (trip, 0) > 0)
12848 if (traverse_data_var (var->list, where) == FAILURE)
12854 e = gfc_copy_expr (var->expr);
12855 if (gfc_simplify_expr (e, 1) == FAILURE)
12862 mpz_add (frame.value, frame.value, step->value.integer);
12864 mpz_sub_ui (trip, trip, 1);
12868 mpz_clear (frame.value);
12871 gfc_free_expr (start);
12872 gfc_free_expr (end);
12873 gfc_free_expr (step);
12875 iter_stack = frame.prev;
12880 /* Type resolve variables in the variable list of a DATA statement. */
12883 traverse_data_var (gfc_data_variable *var, locus *where)
12887 for (; var; var = var->next)
12889 if (var->expr == NULL)
12890 t = traverse_data_list (var, where);
12892 t = check_data_variable (var, where);
12902 /* Resolve the expressions and iterators associated with a data statement.
12903 This is separate from the assignment checking because data lists should
12904 only be resolved once. */
12907 resolve_data_variables (gfc_data_variable *d)
12909 for (; d; d = d->next)
12911 if (d->list == NULL)
12913 if (gfc_resolve_expr (d->expr) == FAILURE)
12918 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
12921 if (resolve_data_variables (d->list) == FAILURE)
12930 /* Resolve a single DATA statement. We implement this by storing a pointer to
12931 the value list into static variables, and then recursively traversing the
12932 variables list, expanding iterators and such. */
12935 resolve_data (gfc_data *d)
12938 if (resolve_data_variables (d->var) == FAILURE)
12941 values.vnode = d->value;
12942 if (d->value == NULL)
12943 mpz_set_ui (values.left, 0);
12945 mpz_set (values.left, d->value->repeat);
12947 if (traverse_data_var (d->var, &d->where) == FAILURE)
12950 /* At this point, we better not have any values left. */
12952 if (next_data_value () == SUCCESS)
12953 gfc_error ("DATA statement at %L has more values than variables",
12958 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
12959 accessed by host or use association, is a dummy argument to a pure function,
12960 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
12961 is storage associated with any such variable, shall not be used in the
12962 following contexts: (clients of this function). */
12964 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
12965 procedure. Returns zero if assignment is OK, nonzero if there is a
12968 gfc_impure_variable (gfc_symbol *sym)
12973 if (sym->attr.use_assoc || sym->attr.in_common)
12976 /* Check if the symbol's ns is inside the pure procedure. */
12977 for (ns = gfc_current_ns; ns; ns = ns->parent)
12981 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
12985 proc = sym->ns->proc_name;
12986 if (sym->attr.dummy && gfc_pure (proc)
12987 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
12989 proc->attr.function))
12992 /* TODO: Sort out what can be storage associated, if anything, and include
12993 it here. In principle equivalences should be scanned but it does not
12994 seem to be possible to storage associate an impure variable this way. */
12999 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13000 current namespace is inside a pure procedure. */
13003 gfc_pure (gfc_symbol *sym)
13005 symbol_attribute attr;
13010 /* Check if the current namespace or one of its parents
13011 belongs to a pure procedure. */
13012 for (ns = gfc_current_ns; ns; ns = ns->parent)
13014 sym = ns->proc_name;
13018 if (attr.flavor == FL_PROCEDURE && attr.pure)
13026 return attr.flavor == FL_PROCEDURE && attr.pure;
13030 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13031 checks if the current namespace is implicitly pure. Note that this
13032 function returns false for a PURE procedure. */
13035 gfc_implicit_pure (gfc_symbol *sym)
13037 symbol_attribute attr;
13041 /* Check if the current namespace is implicit_pure. */
13042 sym = gfc_current_ns->proc_name;
13046 if (attr.flavor == FL_PROCEDURE
13047 && attr.implicit_pure && !attr.pure)
13054 return attr.flavor == FL_PROCEDURE && attr.implicit_pure && !attr.pure;
13058 /* Test whether the current procedure is elemental or not. */
13061 gfc_elemental (gfc_symbol *sym)
13063 symbol_attribute attr;
13066 sym = gfc_current_ns->proc_name;
13071 return attr.flavor == FL_PROCEDURE && attr.elemental;
13075 /* Warn about unused labels. */
13078 warn_unused_fortran_label (gfc_st_label *label)
13083 warn_unused_fortran_label (label->left);
13085 if (label->defined == ST_LABEL_UNKNOWN)
13088 switch (label->referenced)
13090 case ST_LABEL_UNKNOWN:
13091 gfc_warning ("Label %d at %L defined but not used", label->value,
13095 case ST_LABEL_BAD_TARGET:
13096 gfc_warning ("Label %d at %L defined but cannot be used",
13097 label->value, &label->where);
13104 warn_unused_fortran_label (label->right);
13108 /* Returns the sequence type of a symbol or sequence. */
13111 sequence_type (gfc_typespec ts)
13120 if (ts.u.derived->components == NULL)
13121 return SEQ_NONDEFAULT;
13123 result = sequence_type (ts.u.derived->components->ts);
13124 for (c = ts.u.derived->components->next; c; c = c->next)
13125 if (sequence_type (c->ts) != result)
13131 if (ts.kind != gfc_default_character_kind)
13132 return SEQ_NONDEFAULT;
13134 return SEQ_CHARACTER;
13137 if (ts.kind != gfc_default_integer_kind)
13138 return SEQ_NONDEFAULT;
13140 return SEQ_NUMERIC;
13143 if (!(ts.kind == gfc_default_real_kind
13144 || ts.kind == gfc_default_double_kind))
13145 return SEQ_NONDEFAULT;
13147 return SEQ_NUMERIC;
13150 if (ts.kind != gfc_default_complex_kind)
13151 return SEQ_NONDEFAULT;
13153 return SEQ_NUMERIC;
13156 if (ts.kind != gfc_default_logical_kind)
13157 return SEQ_NONDEFAULT;
13159 return SEQ_NUMERIC;
13162 return SEQ_NONDEFAULT;
13167 /* Resolve derived type EQUIVALENCE object. */
13170 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
13172 gfc_component *c = derived->components;
13177 /* Shall not be an object of nonsequence derived type. */
13178 if (!derived->attr.sequence)
13180 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13181 "attribute to be an EQUIVALENCE object", sym->name,
13186 /* Shall not have allocatable components. */
13187 if (derived->attr.alloc_comp)
13189 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13190 "components to be an EQUIVALENCE object",sym->name,
13195 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
13197 gfc_error ("Derived type variable '%s' at %L with default "
13198 "initialization cannot be in EQUIVALENCE with a variable "
13199 "in COMMON", sym->name, &e->where);
13203 for (; c ; c = c->next)
13205 if (c->ts.type == BT_DERIVED
13206 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
13209 /* Shall not be an object of sequence derived type containing a pointer
13210 in the structure. */
13211 if (c->attr.pointer)
13213 gfc_error ("Derived type variable '%s' at %L with pointer "
13214 "component(s) cannot be an EQUIVALENCE object",
13215 sym->name, &e->where);
13223 /* Resolve equivalence object.
13224 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13225 an allocatable array, an object of nonsequence derived type, an object of
13226 sequence derived type containing a pointer at any level of component
13227 selection, an automatic object, a function name, an entry name, a result
13228 name, a named constant, a structure component, or a subobject of any of
13229 the preceding objects. A substring shall not have length zero. A
13230 derived type shall not have components with default initialization nor
13231 shall two objects of an equivalence group be initialized.
13232 Either all or none of the objects shall have an protected attribute.
13233 The simple constraints are done in symbol.c(check_conflict) and the rest
13234 are implemented here. */
13237 resolve_equivalence (gfc_equiv *eq)
13240 gfc_symbol *first_sym;
13243 locus *last_where = NULL;
13244 seq_type eq_type, last_eq_type;
13245 gfc_typespec *last_ts;
13246 int object, cnt_protected;
13249 last_ts = &eq->expr->symtree->n.sym->ts;
13251 first_sym = eq->expr->symtree->n.sym;
13255 for (object = 1; eq; eq = eq->eq, object++)
13259 e->ts = e->symtree->n.sym->ts;
13260 /* match_varspec might not know yet if it is seeing
13261 array reference or substring reference, as it doesn't
13263 if (e->ref && e->ref->type == REF_ARRAY)
13265 gfc_ref *ref = e->ref;
13266 sym = e->symtree->n.sym;
13268 if (sym->attr.dimension)
13270 ref->u.ar.as = sym->as;
13274 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13275 if (e->ts.type == BT_CHARACTER
13277 && ref->type == REF_ARRAY
13278 && ref->u.ar.dimen == 1
13279 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
13280 && ref->u.ar.stride[0] == NULL)
13282 gfc_expr *start = ref->u.ar.start[0];
13283 gfc_expr *end = ref->u.ar.end[0];
13286 /* Optimize away the (:) reference. */
13287 if (start == NULL && end == NULL)
13290 e->ref = ref->next;
13292 e->ref->next = ref->next;
13297 ref->type = REF_SUBSTRING;
13299 start = gfc_get_int_expr (gfc_default_integer_kind,
13301 ref->u.ss.start = start;
13302 if (end == NULL && e->ts.u.cl)
13303 end = gfc_copy_expr (e->ts.u.cl->length);
13304 ref->u.ss.end = end;
13305 ref->u.ss.length = e->ts.u.cl;
13312 /* Any further ref is an error. */
13315 gcc_assert (ref->type == REF_ARRAY);
13316 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13322 if (gfc_resolve_expr (e) == FAILURE)
13325 sym = e->symtree->n.sym;
13327 if (sym->attr.is_protected)
13329 if (cnt_protected > 0 && cnt_protected != object)
13331 gfc_error ("Either all or none of the objects in the "
13332 "EQUIVALENCE set at %L shall have the "
13333 "PROTECTED attribute",
13338 /* Shall not equivalence common block variables in a PURE procedure. */
13339 if (sym->ns->proc_name
13340 && sym->ns->proc_name->attr.pure
13341 && sym->attr.in_common)
13343 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13344 "object in the pure procedure '%s'",
13345 sym->name, &e->where, sym->ns->proc_name->name);
13349 /* Shall not be a named constant. */
13350 if (e->expr_type == EXPR_CONSTANT)
13352 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13353 "object", sym->name, &e->where);
13357 if (e->ts.type == BT_DERIVED
13358 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
13361 /* Check that the types correspond correctly:
13363 A numeric sequence structure may be equivalenced to another sequence
13364 structure, an object of default integer type, default real type, double
13365 precision real type, default logical type such that components of the
13366 structure ultimately only become associated to objects of the same
13367 kind. A character sequence structure may be equivalenced to an object
13368 of default character kind or another character sequence structure.
13369 Other objects may be equivalenced only to objects of the same type and
13370 kind parameters. */
13372 /* Identical types are unconditionally OK. */
13373 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
13374 goto identical_types;
13376 last_eq_type = sequence_type (*last_ts);
13377 eq_type = sequence_type (sym->ts);
13379 /* Since the pair of objects is not of the same type, mixed or
13380 non-default sequences can be rejected. */
13382 msg = "Sequence %s with mixed components in EQUIVALENCE "
13383 "statement at %L with different type objects";
13385 && last_eq_type == SEQ_MIXED
13386 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
13388 || (eq_type == SEQ_MIXED
13389 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13390 &e->where) == FAILURE))
13393 msg = "Non-default type object or sequence %s in EQUIVALENCE "
13394 "statement at %L with objects of different type";
13396 && last_eq_type == SEQ_NONDEFAULT
13397 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
13398 last_where) == FAILURE)
13399 || (eq_type == SEQ_NONDEFAULT
13400 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13401 &e->where) == FAILURE))
13404 msg ="Non-CHARACTER object '%s' in default CHARACTER "
13405 "EQUIVALENCE statement at %L";
13406 if (last_eq_type == SEQ_CHARACTER
13407 && eq_type != SEQ_CHARACTER
13408 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13409 &e->where) == FAILURE)
13412 msg ="Non-NUMERIC object '%s' in default NUMERIC "
13413 "EQUIVALENCE statement at %L";
13414 if (last_eq_type == SEQ_NUMERIC
13415 && eq_type != SEQ_NUMERIC
13416 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13417 &e->where) == FAILURE)
13422 last_where = &e->where;
13427 /* Shall not be an automatic array. */
13428 if (e->ref->type == REF_ARRAY
13429 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
13431 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13432 "an EQUIVALENCE object", sym->name, &e->where);
13439 /* Shall not be a structure component. */
13440 if (r->type == REF_COMPONENT)
13442 gfc_error ("Structure component '%s' at %L cannot be an "
13443 "EQUIVALENCE object",
13444 r->u.c.component->name, &e->where);
13448 /* A substring shall not have length zero. */
13449 if (r->type == REF_SUBSTRING)
13451 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13453 gfc_error ("Substring at %L has length zero",
13454 &r->u.ss.start->where);
13464 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13467 resolve_fntype (gfc_namespace *ns)
13469 gfc_entry_list *el;
13472 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13475 /* If there are any entries, ns->proc_name is the entry master
13476 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13478 sym = ns->entries->sym;
13480 sym = ns->proc_name;
13481 if (sym->result == sym
13482 && sym->ts.type == BT_UNKNOWN
13483 && gfc_set_default_type (sym, 0, NULL) == FAILURE
13484 && !sym->attr.untyped)
13486 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13487 sym->name, &sym->declared_at);
13488 sym->attr.untyped = 1;
13491 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13492 && !sym->attr.contained
13493 && !gfc_check_symbol_access (sym->ts.u.derived)
13494 && gfc_check_symbol_access (sym))
13496 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13497 "%L of PRIVATE type '%s'", sym->name,
13498 &sym->declared_at, sym->ts.u.derived->name);
13502 for (el = ns->entries->next; el; el = el->next)
13504 if (el->sym->result == el->sym
13505 && el->sym->ts.type == BT_UNKNOWN
13506 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13507 && !el->sym->attr.untyped)
13509 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13510 el->sym->name, &el->sym->declared_at);
13511 el->sym->attr.untyped = 1;
13517 /* 12.3.2.1.1 Defined operators. */
13520 check_uop_procedure (gfc_symbol *sym, locus where)
13522 gfc_formal_arglist *formal;
13524 if (!sym->attr.function)
13526 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13527 sym->name, &where);
13531 if (sym->ts.type == BT_CHARACTER
13532 && !(sym->ts.u.cl && sym->ts.u.cl->length)
13533 && !(sym->result && sym->result->ts.u.cl
13534 && sym->result->ts.u.cl->length))
13536 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13537 "character length", sym->name, &where);
13541 formal = sym->formal;
13542 if (!formal || !formal->sym)
13544 gfc_error ("User operator procedure '%s' at %L must have at least "
13545 "one argument", sym->name, &where);
13549 if (formal->sym->attr.intent != INTENT_IN)
13551 gfc_error ("First argument of operator interface at %L must be "
13552 "INTENT(IN)", &where);
13556 if (formal->sym->attr.optional)
13558 gfc_error ("First argument of operator interface at %L cannot be "
13559 "optional", &where);
13563 formal = formal->next;
13564 if (!formal || !formal->sym)
13567 if (formal->sym->attr.intent != INTENT_IN)
13569 gfc_error ("Second argument of operator interface at %L must be "
13570 "INTENT(IN)", &where);
13574 if (formal->sym->attr.optional)
13576 gfc_error ("Second argument of operator interface at %L cannot be "
13577 "optional", &where);
13583 gfc_error ("Operator interface at %L must have, at most, two "
13584 "arguments", &where);
13592 gfc_resolve_uops (gfc_symtree *symtree)
13594 gfc_interface *itr;
13596 if (symtree == NULL)
13599 gfc_resolve_uops (symtree->left);
13600 gfc_resolve_uops (symtree->right);
13602 for (itr = symtree->n.uop->op; itr; itr = itr->next)
13603 check_uop_procedure (itr->sym, itr->sym->declared_at);
13607 /* Examine all of the expressions associated with a program unit,
13608 assign types to all intermediate expressions, make sure that all
13609 assignments are to compatible types and figure out which names
13610 refer to which functions or subroutines. It doesn't check code
13611 block, which is handled by resolve_code. */
13614 resolve_types (gfc_namespace *ns)
13620 gfc_namespace* old_ns = gfc_current_ns;
13622 /* Check that all IMPLICIT types are ok. */
13623 if (!ns->seen_implicit_none)
13626 for (letter = 0; letter != GFC_LETTERS; ++letter)
13627 if (ns->set_flag[letter]
13628 && resolve_typespec_used (&ns->default_type[letter],
13629 &ns->implicit_loc[letter],
13634 gfc_current_ns = ns;
13636 resolve_entries (ns);
13638 resolve_common_vars (ns->blank_common.head, false);
13639 resolve_common_blocks (ns->common_root);
13641 resolve_contained_functions (ns);
13643 if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
13644 && ns->proc_name->attr.if_source == IFSRC_IFBODY)
13645 resolve_formal_arglist (ns->proc_name);
13647 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13649 for (cl = ns->cl_list; cl; cl = cl->next)
13650 resolve_charlen (cl);
13652 gfc_traverse_ns (ns, resolve_symbol);
13654 resolve_fntype (ns);
13656 for (n = ns->contained; n; n = n->sibling)
13658 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13659 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13660 "also be PURE", n->proc_name->name,
13661 &n->proc_name->declared_at);
13667 do_concurrent_flag = 0;
13668 gfc_check_interfaces (ns);
13670 gfc_traverse_ns (ns, resolve_values);
13676 for (d = ns->data; d; d = d->next)
13680 gfc_traverse_ns (ns, gfc_formalize_init_value);
13682 gfc_traverse_ns (ns, gfc_verify_binding_labels);
13684 if (ns->common_root != NULL)
13685 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13687 for (eq = ns->equiv; eq; eq = eq->next)
13688 resolve_equivalence (eq);
13690 /* Warn about unused labels. */
13691 if (warn_unused_label)
13692 warn_unused_fortran_label (ns->st_labels);
13694 gfc_resolve_uops (ns->uop_root);
13696 gfc_current_ns = old_ns;
13700 /* Call resolve_code recursively. */
13703 resolve_codes (gfc_namespace *ns)
13706 bitmap_obstack old_obstack;
13708 if (ns->resolved == 1)
13711 for (n = ns->contained; n; n = n->sibling)
13714 gfc_current_ns = ns;
13716 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13717 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13720 /* Set to an out of range value. */
13721 current_entry_id = -1;
13723 old_obstack = labels_obstack;
13724 bitmap_obstack_initialize (&labels_obstack);
13726 resolve_code (ns->code, ns);
13728 bitmap_obstack_release (&labels_obstack);
13729 labels_obstack = old_obstack;
13733 /* This function is called after a complete program unit has been compiled.
13734 Its purpose is to examine all of the expressions associated with a program
13735 unit, assign types to all intermediate expressions, make sure that all
13736 assignments are to compatible types and figure out which names refer to
13737 which functions or subroutines. */
13740 gfc_resolve (gfc_namespace *ns)
13742 gfc_namespace *old_ns;
13743 code_stack *old_cs_base;
13749 old_ns = gfc_current_ns;
13750 old_cs_base = cs_base;
13752 resolve_types (ns);
13753 resolve_codes (ns);
13755 gfc_current_ns = old_ns;
13756 cs_base = old_cs_base;
13759 gfc_run_passes (ns);