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;
5617 /* If we find a deferred typebound procedure, check for derived types
5618 that an over-riding typebound procedure has not been missed. */
5619 if (e->value.compcall.tbp->deferred
5620 && e->value.compcall.name
5621 && !e->value.compcall.tbp->non_overridable
5622 && e->value.compcall.base_object
5623 && e->value.compcall.base_object->ts.type == BT_DERIVED)
5626 gfc_symbol *derived;
5628 /* Use the derived type of the base_object. */
5629 derived = e->value.compcall.base_object->ts.u.derived;
5632 /* If necessary, go throught the inheritance chain. */
5633 while (!st && derived)
5635 /* Look for the typebound procedure 'name'. */
5636 if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
5637 st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
5638 e->value.compcall.name);
5640 derived = gfc_get_derived_super_type (derived);
5643 /* Now find the specific name in the derived type namespace. */
5644 if (st && st->n.tb && st->n.tb->u.specific)
5645 gfc_find_sym_tree (st->n.tb->u.specific->name,
5646 derived->ns, 1, &st);
5654 /* Get the ultimate declared type from an expression. In addition,
5655 return the last class/derived type reference and the copy of the
5656 reference list. If check_types is set true, derived types are
5657 identified as well as class references. */
5659 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5660 gfc_expr *e, bool check_types)
5662 gfc_symbol *declared;
5669 *new_ref = gfc_copy_ref (e->ref);
5671 for (ref = e->ref; ref; ref = ref->next)
5673 if (ref->type != REF_COMPONENT)
5676 if ((ref->u.c.component->ts.type == BT_CLASS
5677 || (check_types && ref->u.c.component->ts.type == BT_DERIVED))
5678 && ref->u.c.component->attr.flavor != FL_PROCEDURE)
5680 declared = ref->u.c.component->ts.u.derived;
5686 if (declared == NULL)
5687 declared = e->symtree->n.sym->ts.u.derived;
5693 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5694 which of the specific bindings (if any) matches the arglist and transform
5695 the expression into a call of that binding. */
5698 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5700 gfc_typebound_proc* genproc;
5701 const char* genname;
5703 gfc_symbol *derived;
5705 gcc_assert (e->expr_type == EXPR_COMPCALL);
5706 genname = e->value.compcall.name;
5707 genproc = e->value.compcall.tbp;
5709 if (!genproc->is_generic)
5712 /* Try the bindings on this type and in the inheritance hierarchy. */
5713 for (; genproc; genproc = genproc->overridden)
5717 gcc_assert (genproc->is_generic);
5718 for (g = genproc->u.generic; g; g = g->next)
5721 gfc_actual_arglist* args;
5724 gcc_assert (g->specific);
5726 if (g->specific->error)
5729 target = g->specific->u.specific->n.sym;
5731 /* Get the right arglist by handling PASS/NOPASS. */
5732 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5733 if (!g->specific->nopass)
5736 po = extract_compcall_passed_object (e);
5740 gcc_assert (g->specific->pass_arg_num > 0);
5741 gcc_assert (!g->specific->error);
5742 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5743 g->specific->pass_arg);
5745 resolve_actual_arglist (args, target->attr.proc,
5746 is_external_proc (target) && !target->formal);
5748 /* Check if this arglist matches the formal. */
5749 matches = gfc_arglist_matches_symbol (&args, target);
5751 /* Clean up and break out of the loop if we've found it. */
5752 gfc_free_actual_arglist (args);
5755 e->value.compcall.tbp = g->specific;
5756 genname = g->specific_st->name;
5757 /* Pass along the name for CLASS methods, where the vtab
5758 procedure pointer component has to be referenced. */
5766 /* Nothing matching found! */
5767 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5768 " '%s' at %L", genname, &e->where);
5772 /* Make sure that we have the right specific instance for the name. */
5773 derived = get_declared_from_expr (NULL, NULL, e, true);
5775 st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
5777 e->value.compcall.tbp = st->n.tb;
5783 /* Resolve a call to a type-bound subroutine. */
5786 resolve_typebound_call (gfc_code* c, const char **name)
5788 gfc_actual_arglist* newactual;
5789 gfc_symtree* target;
5791 /* Check that's really a SUBROUTINE. */
5792 if (!c->expr1->value.compcall.tbp->subroutine)
5794 gfc_error ("'%s' at %L should be a SUBROUTINE",
5795 c->expr1->value.compcall.name, &c->loc);
5799 if (check_typebound_baseobject (c->expr1) == FAILURE)
5802 /* Pass along the name for CLASS methods, where the vtab
5803 procedure pointer component has to be referenced. */
5805 *name = c->expr1->value.compcall.name;
5807 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5810 /* Transform into an ordinary EXEC_CALL for now. */
5812 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5815 c->ext.actual = newactual;
5816 c->symtree = target;
5817 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5819 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5821 gfc_free_expr (c->expr1);
5822 c->expr1 = gfc_get_expr ();
5823 c->expr1->expr_type = EXPR_FUNCTION;
5824 c->expr1->symtree = target;
5825 c->expr1->where = c->loc;
5827 return resolve_call (c);
5831 /* Resolve a component-call expression. */
5833 resolve_compcall (gfc_expr* e, const char **name)
5835 gfc_actual_arglist* newactual;
5836 gfc_symtree* target;
5838 /* Check that's really a FUNCTION. */
5839 if (!e->value.compcall.tbp->function)
5841 gfc_error ("'%s' at %L should be a FUNCTION",
5842 e->value.compcall.name, &e->where);
5846 /* These must not be assign-calls! */
5847 gcc_assert (!e->value.compcall.assign);
5849 if (check_typebound_baseobject (e) == FAILURE)
5852 /* Pass along the name for CLASS methods, where the vtab
5853 procedure pointer component has to be referenced. */
5855 *name = e->value.compcall.name;
5857 if (resolve_typebound_generic_call (e, name) == FAILURE)
5859 gcc_assert (!e->value.compcall.tbp->is_generic);
5861 /* Take the rank from the function's symbol. */
5862 if (e->value.compcall.tbp->u.specific->n.sym->as)
5863 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5865 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5866 arglist to the TBP's binding target. */
5868 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5871 e->value.function.actual = newactual;
5872 e->value.function.name = NULL;
5873 e->value.function.esym = target->n.sym;
5874 e->value.function.isym = NULL;
5875 e->symtree = target;
5876 e->ts = target->n.sym->ts;
5877 e->expr_type = EXPR_FUNCTION;
5879 /* Resolution is not necessary if this is a class subroutine; this
5880 function only has to identify the specific proc. Resolution of
5881 the call will be done next in resolve_typebound_call. */
5882 return gfc_resolve_expr (e);
5887 /* Resolve a typebound function, or 'method'. First separate all
5888 the non-CLASS references by calling resolve_compcall directly. */
5891 resolve_typebound_function (gfc_expr* e)
5893 gfc_symbol *declared;
5905 /* Deal with typebound operators for CLASS objects. */
5906 expr = e->value.compcall.base_object;
5907 overridable = !e->value.compcall.tbp->non_overridable;
5908 if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
5910 /* If the base_object is not a variable, the corresponding actual
5911 argument expression must be stored in e->base_expression so
5912 that the corresponding tree temporary can be used as the base
5913 object in gfc_conv_procedure_call. */
5914 if (expr->expr_type != EXPR_VARIABLE)
5916 gfc_actual_arglist *args;
5918 for (args= e->value.function.actual; args; args = args->next)
5920 if (expr == args->expr)
5925 /* Since the typebound operators are generic, we have to ensure
5926 that any delays in resolution are corrected and that the vtab
5929 declared = ts.u.derived;
5930 c = gfc_find_component (declared, "_vptr", true, true);
5931 if (c->ts.u.derived == NULL)
5932 c->ts.u.derived = gfc_find_derived_vtab (declared);
5934 if (resolve_compcall (e, &name) == FAILURE)
5937 /* Use the generic name if it is there. */
5938 name = name ? name : e->value.function.esym->name;
5939 e->symtree = expr->symtree;
5940 e->ref = gfc_copy_ref (expr->ref);
5941 get_declared_from_expr (&class_ref, NULL, e, false);
5943 /* Trim away the extraneous references that emerge from nested
5944 use of interface.c (extend_expr). */
5945 if (class_ref && class_ref->next)
5947 gfc_free_ref_list (class_ref->next);
5948 class_ref->next = NULL;
5950 else if (e->ref && !class_ref)
5952 gfc_free_ref_list (e->ref);
5956 gfc_add_vptr_component (e);
5957 gfc_add_component_ref (e, name);
5958 e->value.function.esym = NULL;
5959 if (expr->expr_type != EXPR_VARIABLE)
5960 e->base_expr = expr;
5965 return resolve_compcall (e, NULL);
5967 if (resolve_ref (e) == FAILURE)
5970 /* Get the CLASS declared type. */
5971 declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
5973 /* Weed out cases of the ultimate component being a derived type. */
5974 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5975 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5977 gfc_free_ref_list (new_ref);
5978 return resolve_compcall (e, NULL);
5981 c = gfc_find_component (declared, "_data", true, true);
5982 declared = c->ts.u.derived;
5984 /* Treat the call as if it is a typebound procedure, in order to roll
5985 out the correct name for the specific function. */
5986 if (resolve_compcall (e, &name) == FAILURE)
5992 /* Convert the expression to a procedure pointer component call. */
5993 e->value.function.esym = NULL;
5999 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6000 gfc_add_vptr_component (e);
6001 gfc_add_component_ref (e, name);
6003 /* Recover the typespec for the expression. This is really only
6004 necessary for generic procedures, where the additional call
6005 to gfc_add_component_ref seems to throw the collection of the
6006 correct typespec. */
6013 /* Resolve a typebound subroutine, or 'method'. First separate all
6014 the non-CLASS references by calling resolve_typebound_call
6018 resolve_typebound_subroutine (gfc_code *code)
6020 gfc_symbol *declared;
6030 st = code->expr1->symtree;
6032 /* Deal with typebound operators for CLASS objects. */
6033 expr = code->expr1->value.compcall.base_object;
6034 overridable = !code->expr1->value.compcall.tbp->non_overridable;
6035 if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
6037 /* If the base_object is not a variable, the corresponding actual
6038 argument expression must be stored in e->base_expression so
6039 that the corresponding tree temporary can be used as the base
6040 object in gfc_conv_procedure_call. */
6041 if (expr->expr_type != EXPR_VARIABLE)
6043 gfc_actual_arglist *args;
6045 args= code->expr1->value.function.actual;
6046 for (; args; args = args->next)
6047 if (expr == args->expr)
6051 /* Since the typebound operators are generic, we have to ensure
6052 that any delays in resolution are corrected and that the vtab
6054 declared = expr->ts.u.derived;
6055 c = gfc_find_component (declared, "_vptr", true, true);
6056 if (c->ts.u.derived == NULL)
6057 c->ts.u.derived = gfc_find_derived_vtab (declared);
6059 if (resolve_typebound_call (code, &name) == FAILURE)
6062 /* Use the generic name if it is there. */
6063 name = name ? name : code->expr1->value.function.esym->name;
6064 code->expr1->symtree = expr->symtree;
6065 code->expr1->ref = gfc_copy_ref (expr->ref);
6067 /* Trim away the extraneous references that emerge from nested
6068 use of interface.c (extend_expr). */
6069 get_declared_from_expr (&class_ref, NULL, code->expr1, false);
6070 if (class_ref && class_ref->next)
6072 gfc_free_ref_list (class_ref->next);
6073 class_ref->next = NULL;
6075 else if (code->expr1->ref && !class_ref)
6077 gfc_free_ref_list (code->expr1->ref);
6078 code->expr1->ref = NULL;
6081 /* Now use the procedure in the vtable. */
6082 gfc_add_vptr_component (code->expr1);
6083 gfc_add_component_ref (code->expr1, name);
6084 code->expr1->value.function.esym = NULL;
6085 if (expr->expr_type != EXPR_VARIABLE)
6086 code->expr1->base_expr = expr;
6091 return resolve_typebound_call (code, NULL);
6093 if (resolve_ref (code->expr1) == FAILURE)
6096 /* Get the CLASS declared type. */
6097 get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
6099 /* Weed out cases of the ultimate component being a derived type. */
6100 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
6101 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
6103 gfc_free_ref_list (new_ref);
6104 return resolve_typebound_call (code, NULL);
6107 if (resolve_typebound_call (code, &name) == FAILURE)
6109 ts = code->expr1->ts;
6113 /* Convert the expression to a procedure pointer component call. */
6114 code->expr1->value.function.esym = NULL;
6115 code->expr1->symtree = st;
6118 code->expr1->ref = new_ref;
6120 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6121 gfc_add_vptr_component (code->expr1);
6122 gfc_add_component_ref (code->expr1, name);
6124 /* Recover the typespec for the expression. This is really only
6125 necessary for generic procedures, where the additional call
6126 to gfc_add_component_ref seems to throw the collection of the
6127 correct typespec. */
6128 code->expr1->ts = ts;
6135 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6138 resolve_ppc_call (gfc_code* c)
6140 gfc_component *comp;
6143 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
6146 c->resolved_sym = c->expr1->symtree->n.sym;
6147 c->expr1->expr_type = EXPR_VARIABLE;
6149 if (!comp->attr.subroutine)
6150 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
6152 if (resolve_ref (c->expr1) == FAILURE)
6155 if (update_ppc_arglist (c->expr1) == FAILURE)
6158 c->ext.actual = c->expr1->value.compcall.actual;
6160 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
6161 comp->formal == NULL) == FAILURE)
6164 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
6170 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6173 resolve_expr_ppc (gfc_expr* e)
6175 gfc_component *comp;
6178 b = gfc_is_proc_ptr_comp (e, &comp);
6181 /* Convert to EXPR_FUNCTION. */
6182 e->expr_type = EXPR_FUNCTION;
6183 e->value.function.isym = NULL;
6184 e->value.function.actual = e->value.compcall.actual;
6186 if (comp->as != NULL)
6187 e->rank = comp->as->rank;
6189 if (!comp->attr.function)
6190 gfc_add_function (&comp->attr, comp->name, &e->where);
6192 if (resolve_ref (e) == FAILURE)
6195 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
6196 comp->formal == NULL) == FAILURE)
6199 if (update_ppc_arglist (e) == FAILURE)
6202 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
6209 gfc_is_expandable_expr (gfc_expr *e)
6211 gfc_constructor *con;
6213 if (e->expr_type == EXPR_ARRAY)
6215 /* Traverse the constructor looking for variables that are flavor
6216 parameter. Parameters must be expanded since they are fully used at
6218 con = gfc_constructor_first (e->value.constructor);
6219 for (; con; con = gfc_constructor_next (con))
6221 if (con->expr->expr_type == EXPR_VARIABLE
6222 && con->expr->symtree
6223 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6224 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
6226 if (con->expr->expr_type == EXPR_ARRAY
6227 && gfc_is_expandable_expr (con->expr))
6235 /* Resolve an expression. That is, make sure that types of operands agree
6236 with their operators, intrinsic operators are converted to function calls
6237 for overloaded types and unresolved function references are resolved. */
6240 gfc_resolve_expr (gfc_expr *e)
6248 /* inquiry_argument only applies to variables. */
6249 inquiry_save = inquiry_argument;
6250 if (e->expr_type != EXPR_VARIABLE)
6251 inquiry_argument = false;
6253 switch (e->expr_type)
6256 t = resolve_operator (e);
6262 if (check_host_association (e))
6263 t = resolve_function (e);
6266 t = resolve_variable (e);
6268 expression_rank (e);
6271 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6272 && e->ref->type != REF_SUBSTRING)
6273 gfc_resolve_substring_charlen (e);
6278 t = resolve_typebound_function (e);
6281 case EXPR_SUBSTRING:
6282 t = resolve_ref (e);
6291 t = resolve_expr_ppc (e);
6296 if (resolve_ref (e) == FAILURE)
6299 t = gfc_resolve_array_constructor (e);
6300 /* Also try to expand a constructor. */
6303 expression_rank (e);
6304 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6305 gfc_expand_constructor (e, false);
6308 /* This provides the opportunity for the length of constructors with
6309 character valued function elements to propagate the string length
6310 to the expression. */
6311 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6313 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6314 here rather then add a duplicate test for it above. */
6315 gfc_expand_constructor (e, false);
6316 t = gfc_resolve_character_array_constructor (e);
6321 case EXPR_STRUCTURE:
6322 t = resolve_ref (e);
6326 t = resolve_structure_cons (e, 0);
6330 t = gfc_simplify_expr (e, 0);
6334 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6337 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6340 inquiry_argument = inquiry_save;
6346 /* Resolve an expression from an iterator. They must be scalar and have
6347 INTEGER or (optionally) REAL type. */
6350 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6351 const char *name_msgid)
6353 if (gfc_resolve_expr (expr) == FAILURE)
6356 if (expr->rank != 0)
6358 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6362 if (expr->ts.type != BT_INTEGER)
6364 if (expr->ts.type == BT_REAL)
6367 return gfc_notify_std (GFC_STD_F95_DEL,
6368 "Deleted feature: %s at %L must be integer",
6369 _(name_msgid), &expr->where);
6372 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6379 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6387 /* Resolve the expressions in an iterator structure. If REAL_OK is
6388 false allow only INTEGER type iterators, otherwise allow REAL types. */
6391 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6393 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6397 if (gfc_check_vardef_context (iter->var, false, false, _("iterator variable"))
6401 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6402 "Start expression in DO loop") == FAILURE)
6405 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6406 "End expression in DO loop") == FAILURE)
6409 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6410 "Step expression in DO loop") == FAILURE)
6413 if (iter->step->expr_type == EXPR_CONSTANT)
6415 if ((iter->step->ts.type == BT_INTEGER
6416 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6417 || (iter->step->ts.type == BT_REAL
6418 && mpfr_sgn (iter->step->value.real) == 0))
6420 gfc_error ("Step expression in DO loop at %L cannot be zero",
6421 &iter->step->where);
6426 /* Convert start, end, and step to the same type as var. */
6427 if (iter->start->ts.kind != iter->var->ts.kind
6428 || iter->start->ts.type != iter->var->ts.type)
6429 gfc_convert_type (iter->start, &iter->var->ts, 2);
6431 if (iter->end->ts.kind != iter->var->ts.kind
6432 || iter->end->ts.type != iter->var->ts.type)
6433 gfc_convert_type (iter->end, &iter->var->ts, 2);
6435 if (iter->step->ts.kind != iter->var->ts.kind
6436 || iter->step->ts.type != iter->var->ts.type)
6437 gfc_convert_type (iter->step, &iter->var->ts, 2);
6439 if (iter->start->expr_type == EXPR_CONSTANT
6440 && iter->end->expr_type == EXPR_CONSTANT
6441 && iter->step->expr_type == EXPR_CONSTANT)
6444 if (iter->start->ts.type == BT_INTEGER)
6446 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6447 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6451 sgn = mpfr_sgn (iter->step->value.real);
6452 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6454 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6455 gfc_warning ("DO loop at %L will be executed zero times",
6456 &iter->step->where);
6463 /* Traversal function for find_forall_index. f == 2 signals that
6464 that variable itself is not to be checked - only the references. */
6467 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6469 if (expr->expr_type != EXPR_VARIABLE)
6472 /* A scalar assignment */
6473 if (!expr->ref || *f == 1)
6475 if (expr->symtree->n.sym == sym)
6487 /* Check whether the FORALL index appears in the expression or not.
6488 Returns SUCCESS if SYM is found in EXPR. */
6491 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6493 if (gfc_traverse_expr (expr, sym, forall_index, f))
6500 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6501 to be a scalar INTEGER variable. The subscripts and stride are scalar
6502 INTEGERs, and if stride is a constant it must be nonzero.
6503 Furthermore "A subscript or stride in a forall-triplet-spec shall
6504 not contain a reference to any index-name in the
6505 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6508 resolve_forall_iterators (gfc_forall_iterator *it)
6510 gfc_forall_iterator *iter, *iter2;
6512 for (iter = it; iter; iter = iter->next)
6514 if (gfc_resolve_expr (iter->var) == SUCCESS
6515 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6516 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6519 if (gfc_resolve_expr (iter->start) == SUCCESS
6520 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6521 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6522 &iter->start->where);
6523 if (iter->var->ts.kind != iter->start->ts.kind)
6524 gfc_convert_type (iter->start, &iter->var->ts, 1);
6526 if (gfc_resolve_expr (iter->end) == SUCCESS
6527 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6528 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6530 if (iter->var->ts.kind != iter->end->ts.kind)
6531 gfc_convert_type (iter->end, &iter->var->ts, 1);
6533 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6535 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6536 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6537 &iter->stride->where, "INTEGER");
6539 if (iter->stride->expr_type == EXPR_CONSTANT
6540 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6541 gfc_error ("FORALL stride expression at %L cannot be zero",
6542 &iter->stride->where);
6544 if (iter->var->ts.kind != iter->stride->ts.kind)
6545 gfc_convert_type (iter->stride, &iter->var->ts, 1);
6548 for (iter = it; iter; iter = iter->next)
6549 for (iter2 = iter; iter2; iter2 = iter2->next)
6551 if (find_forall_index (iter2->start,
6552 iter->var->symtree->n.sym, 0) == SUCCESS
6553 || find_forall_index (iter2->end,
6554 iter->var->symtree->n.sym, 0) == SUCCESS
6555 || find_forall_index (iter2->stride,
6556 iter->var->symtree->n.sym, 0) == SUCCESS)
6557 gfc_error ("FORALL index '%s' may not appear in triplet "
6558 "specification at %L", iter->var->symtree->name,
6559 &iter2->start->where);
6564 /* Given a pointer to a symbol that is a derived type, see if it's
6565 inaccessible, i.e. if it's defined in another module and the components are
6566 PRIVATE. The search is recursive if necessary. Returns zero if no
6567 inaccessible components are found, nonzero otherwise. */
6570 derived_inaccessible (gfc_symbol *sym)
6574 if (sym->attr.use_assoc && sym->attr.private_comp)
6577 for (c = sym->components; c; c = c->next)
6579 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6587 /* Resolve the argument of a deallocate expression. The expression must be
6588 a pointer or a full array. */
6591 resolve_deallocate_expr (gfc_expr *e)
6593 symbol_attribute attr;
6594 int allocatable, pointer;
6599 if (gfc_resolve_expr (e) == FAILURE)
6602 if (e->expr_type != EXPR_VARIABLE)
6605 sym = e->symtree->n.sym;
6607 if (sym->ts.type == BT_CLASS)
6609 allocatable = CLASS_DATA (sym)->attr.allocatable;
6610 pointer = CLASS_DATA (sym)->attr.class_pointer;
6614 allocatable = sym->attr.allocatable;
6615 pointer = sym->attr.pointer;
6617 for (ref = e->ref; ref; ref = ref->next)
6622 if (ref->u.ar.type != AR_FULL
6623 && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
6624 && ref->u.ar.codimen && gfc_ref_this_image (ref)))
6629 c = ref->u.c.component;
6630 if (c->ts.type == BT_CLASS)
6632 allocatable = CLASS_DATA (c)->attr.allocatable;
6633 pointer = CLASS_DATA (c)->attr.class_pointer;
6637 allocatable = c->attr.allocatable;
6638 pointer = c->attr.pointer;
6648 attr = gfc_expr_attr (e);
6650 if (allocatable == 0 && attr.pointer == 0)
6653 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6659 if (gfc_is_coindexed (e))
6661 gfc_error ("Coindexed allocatable object at %L", &e->where);
6666 && gfc_check_vardef_context (e, true, true, _("DEALLOCATE object"))
6669 if (gfc_check_vardef_context (e, false, true, _("DEALLOCATE object"))
6677 /* Returns true if the expression e contains a reference to the symbol sym. */
6679 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6681 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6688 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6690 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6694 /* Given the expression node e for an allocatable/pointer of derived type to be
6695 allocated, get the expression node to be initialized afterwards (needed for
6696 derived types with default initializers, and derived types with allocatable
6697 components that need nullification.) */
6700 gfc_expr_to_initialize (gfc_expr *e)
6706 result = gfc_copy_expr (e);
6708 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6709 for (ref = result->ref; ref; ref = ref->next)
6710 if (ref->type == REF_ARRAY && ref->next == NULL)
6712 ref->u.ar.type = AR_FULL;
6714 for (i = 0; i < ref->u.ar.dimen; i++)
6715 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6720 gfc_free_shape (&result->shape, result->rank);
6722 /* Recalculate rank, shape, etc. */
6723 gfc_resolve_expr (result);
6728 /* If the last ref of an expression is an array ref, return a copy of the
6729 expression with that one removed. Otherwise, a copy of the original
6730 expression. This is used for allocate-expressions and pointer assignment
6731 LHS, where there may be an array specification that needs to be stripped
6732 off when using gfc_check_vardef_context. */
6735 remove_last_array_ref (gfc_expr* e)
6740 e2 = gfc_copy_expr (e);
6741 for (r = &e2->ref; *r; r = &(*r)->next)
6742 if ((*r)->type == REF_ARRAY && !(*r)->next)
6744 gfc_free_ref_list (*r);
6753 /* Used in resolve_allocate_expr to check that a allocation-object and
6754 a source-expr are conformable. This does not catch all possible
6755 cases; in particular a runtime checking is needed. */
6758 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6761 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6763 /* First compare rank. */
6764 if (tail && e1->rank != tail->u.ar.as->rank)
6766 gfc_error ("Source-expr at %L must be scalar or have the "
6767 "same rank as the allocate-object at %L",
6768 &e1->where, &e2->where);
6779 for (i = 0; i < e1->rank; i++)
6781 if (tail->u.ar.end[i])
6783 mpz_set (s, tail->u.ar.end[i]->value.integer);
6784 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6785 mpz_add_ui (s, s, 1);
6789 mpz_set (s, tail->u.ar.start[i]->value.integer);
6792 if (mpz_cmp (e1->shape[i], s) != 0)
6794 gfc_error ("Source-expr at %L and allocate-object at %L must "
6795 "have the same shape", &e1->where, &e2->where);
6808 /* Resolve the expression in an ALLOCATE statement, doing the additional
6809 checks to see whether the expression is OK or not. The expression must
6810 have a trailing array reference that gives the size of the array. */
6813 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6815 int i, pointer, allocatable, dimension, is_abstract;
6818 symbol_attribute attr;
6819 gfc_ref *ref, *ref2;
6822 gfc_symbol *sym = NULL;
6827 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6828 checking of coarrays. */
6829 for (ref = e->ref; ref; ref = ref->next)
6830 if (ref->next == NULL)
6833 if (ref && ref->type == REF_ARRAY)
6834 ref->u.ar.in_allocate = true;
6836 if (gfc_resolve_expr (e) == FAILURE)
6839 /* Make sure the expression is allocatable or a pointer. If it is
6840 pointer, the next-to-last reference must be a pointer. */
6844 sym = e->symtree->n.sym;
6846 /* Check whether ultimate component is abstract and CLASS. */
6849 if (e->expr_type != EXPR_VARIABLE)
6852 attr = gfc_expr_attr (e);
6853 pointer = attr.pointer;
6854 dimension = attr.dimension;
6855 codimension = attr.codimension;
6859 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
6861 allocatable = CLASS_DATA (sym)->attr.allocatable;
6862 pointer = CLASS_DATA (sym)->attr.class_pointer;
6863 dimension = CLASS_DATA (sym)->attr.dimension;
6864 codimension = CLASS_DATA (sym)->attr.codimension;
6865 is_abstract = CLASS_DATA (sym)->attr.abstract;
6869 allocatable = sym->attr.allocatable;
6870 pointer = sym->attr.pointer;
6871 dimension = sym->attr.dimension;
6872 codimension = sym->attr.codimension;
6877 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6882 if (ref->u.ar.codimen > 0)
6885 for (n = ref->u.ar.dimen;
6886 n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
6887 if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
6894 if (ref->next != NULL)
6902 gfc_error ("Coindexed allocatable object at %L",
6907 c = ref->u.c.component;
6908 if (c->ts.type == BT_CLASS)
6910 allocatable = CLASS_DATA (c)->attr.allocatable;
6911 pointer = CLASS_DATA (c)->attr.class_pointer;
6912 dimension = CLASS_DATA (c)->attr.dimension;
6913 codimension = CLASS_DATA (c)->attr.codimension;
6914 is_abstract = CLASS_DATA (c)->attr.abstract;
6918 allocatable = c->attr.allocatable;
6919 pointer = c->attr.pointer;
6920 dimension = c->attr.dimension;
6921 codimension = c->attr.codimension;
6922 is_abstract = c->attr.abstract;
6934 if (allocatable == 0 && pointer == 0)
6936 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6941 /* Some checks for the SOURCE tag. */
6944 /* Check F03:C631. */
6945 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6947 gfc_error ("Type of entity at %L is type incompatible with "
6948 "source-expr at %L", &e->where, &code->expr3->where);
6952 /* Check F03:C632 and restriction following Note 6.18. */
6953 if (code->expr3->rank > 0
6954 && conformable_arrays (code->expr3, e) == FAILURE)
6957 /* Check F03:C633. */
6958 if (code->expr3->ts.kind != e->ts.kind)
6960 gfc_error ("The allocate-object at %L and the source-expr at %L "
6961 "shall have the same kind type parameter",
6962 &e->where, &code->expr3->where);
6966 /* Check F2008, C642. */
6967 if (code->expr3->ts.type == BT_DERIVED
6968 && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
6969 || (code->expr3->ts.u.derived->from_intmod
6970 == INTMOD_ISO_FORTRAN_ENV
6971 && code->expr3->ts.u.derived->intmod_sym_id
6972 == ISOFORTRAN_LOCK_TYPE)))
6974 gfc_error ("The source-expr at %L shall neither be of type "
6975 "LOCK_TYPE nor have a LOCK_TYPE component if "
6976 "allocate-object at %L is a coarray",
6977 &code->expr3->where, &e->where);
6982 /* Check F08:C629. */
6983 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
6986 gcc_assert (e->ts.type == BT_CLASS);
6987 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6988 "type-spec or source-expr", sym->name, &e->where);
6992 if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred)
6994 int cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
6995 code->ext.alloc.ts.u.cl->length);
6996 if (cmp == 1 || cmp == -1 || cmp == -3)
6998 gfc_error ("Allocating %s at %L with type-spec requires the same "
6999 "character-length parameter as in the declaration",
7000 sym->name, &e->where);
7005 /* In the variable definition context checks, gfc_expr_attr is used
7006 on the expression. This is fooled by the array specification
7007 present in e, thus we have to eliminate that one temporarily. */
7008 e2 = remove_last_array_ref (e);
7010 if (t == SUCCESS && pointer)
7011 t = gfc_check_vardef_context (e2, true, true, _("ALLOCATE object"));
7013 t = gfc_check_vardef_context (e2, false, true, _("ALLOCATE object"));
7018 if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
7019 && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
7021 /* For class arrays, the initialization with SOURCE is done
7022 using _copy and trans_call. It is convenient to exploit that
7023 when the allocated type is different from the declared type but
7024 no SOURCE exists by setting expr3. */
7025 code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
7027 else if (!code->expr3)
7029 /* Set up default initializer if needed. */
7033 if (code->ext.alloc.ts.type == BT_DERIVED)
7034 ts = code->ext.alloc.ts;
7038 if (ts.type == BT_CLASS)
7039 ts = ts.u.derived->components->ts;
7041 if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
7043 gfc_code *init_st = gfc_get_code ();
7044 init_st->loc = code->loc;
7045 init_st->op = EXEC_INIT_ASSIGN;
7046 init_st->expr1 = gfc_expr_to_initialize (e);
7047 init_st->expr2 = init_e;
7048 init_st->next = code->next;
7049 code->next = init_st;
7052 else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
7054 /* Default initialization via MOLD (non-polymorphic). */
7055 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
7056 gfc_resolve_expr (rhs);
7057 gfc_free_expr (code->expr3);
7061 if (e->ts.type == BT_CLASS)
7063 /* Make sure the vtab symbol is present when
7064 the module variables are generated. */
7065 gfc_typespec ts = e->ts;
7067 ts = code->expr3->ts;
7068 else if (code->ext.alloc.ts.type == BT_DERIVED)
7069 ts = code->ext.alloc.ts;
7070 gfc_find_derived_vtab (ts.u.derived);
7072 e = gfc_expr_to_initialize (e);
7075 if (dimension == 0 && codimension == 0)
7078 /* Make sure the last reference node is an array specifiction. */
7080 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
7081 || (dimension && ref2->u.ar.dimen == 0))
7083 gfc_error ("Array specification required in ALLOCATE statement "
7084 "at %L", &e->where);
7088 /* Make sure that the array section reference makes sense in the
7089 context of an ALLOCATE specification. */
7094 for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
7095 if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
7097 gfc_error ("Coarray specification required in ALLOCATE statement "
7098 "at %L", &e->where);
7102 for (i = 0; i < ar->dimen; i++)
7104 if (ref2->u.ar.type == AR_ELEMENT)
7107 switch (ar->dimen_type[i])
7113 if (ar->start[i] != NULL
7114 && ar->end[i] != NULL
7115 && ar->stride[i] == NULL)
7118 /* Fall Through... */
7123 case DIMEN_THIS_IMAGE:
7124 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7130 for (a = code->ext.alloc.list; a; a = a->next)
7132 sym = a->expr->symtree->n.sym;
7134 /* TODO - check derived type components. */
7135 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
7138 if ((ar->start[i] != NULL
7139 && gfc_find_sym_in_expr (sym, ar->start[i]))
7140 || (ar->end[i] != NULL
7141 && gfc_find_sym_in_expr (sym, ar->end[i])))
7143 gfc_error ("'%s' must not appear in the array specification at "
7144 "%L in the same ALLOCATE statement where it is "
7145 "itself allocated", sym->name, &ar->where);
7151 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
7153 if (ar->dimen_type[i] == DIMEN_ELEMENT
7154 || ar->dimen_type[i] == DIMEN_RANGE)
7156 if (i == (ar->dimen + ar->codimen - 1))
7158 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7159 "statement at %L", &e->where);
7165 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
7166 && ar->stride[i] == NULL)
7169 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7182 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
7184 gfc_expr *stat, *errmsg, *pe, *qe;
7185 gfc_alloc *a, *p, *q;
7188 errmsg = code->expr2;
7190 /* Check the stat variable. */
7193 gfc_check_vardef_context (stat, false, false, _("STAT variable"));
7195 if ((stat->ts.type != BT_INTEGER
7196 && !(stat->ref && (stat->ref->type == REF_ARRAY
7197 || stat->ref->type == REF_COMPONENT)))
7199 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7200 "variable", &stat->where);
7202 for (p = code->ext.alloc.list; p; p = p->next)
7203 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
7205 gfc_ref *ref1, *ref2;
7208 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
7209 ref1 = ref1->next, ref2 = ref2->next)
7211 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7213 if (ref1->u.c.component->name != ref2->u.c.component->name)
7222 gfc_error ("Stat-variable at %L shall not be %sd within "
7223 "the same %s statement", &stat->where, fcn, fcn);
7229 /* Check the errmsg variable. */
7233 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7236 gfc_check_vardef_context (errmsg, false, false, _("ERRMSG variable"));
7238 if ((errmsg->ts.type != BT_CHARACTER
7240 && (errmsg->ref->type == REF_ARRAY
7241 || errmsg->ref->type == REF_COMPONENT)))
7242 || errmsg->rank > 0 )
7243 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7244 "variable", &errmsg->where);
7246 for (p = code->ext.alloc.list; p; p = p->next)
7247 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
7249 gfc_ref *ref1, *ref2;
7252 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
7253 ref1 = ref1->next, ref2 = ref2->next)
7255 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7257 if (ref1->u.c.component->name != ref2->u.c.component->name)
7266 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7267 "the same %s statement", &errmsg->where, fcn, fcn);
7273 /* Check that an allocate-object appears only once in the statement.
7274 FIXME: Checking derived types is disabled. */
7275 for (p = code->ext.alloc.list; p; p = p->next)
7278 for (q = p->next; q; q = q->next)
7281 if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
7283 /* This is a potential collision. */
7284 gfc_ref *pr = pe->ref;
7285 gfc_ref *qr = qe->ref;
7287 /* Follow the references until
7288 a) They start to differ, in which case there is no error;
7289 you can deallocate a%b and a%c in a single statement
7290 b) Both of them stop, which is an error
7291 c) One of them stops, which is also an error. */
7294 if (pr == NULL && qr == NULL)
7296 gfc_error ("Allocate-object at %L also appears at %L",
7297 &pe->where, &qe->where);
7300 else if (pr != NULL && qr == NULL)
7302 gfc_error ("Allocate-object at %L is subobject of"
7303 " object at %L", &pe->where, &qe->where);
7306 else if (pr == NULL && qr != NULL)
7308 gfc_error ("Allocate-object at %L is subobject of"
7309 " object at %L", &qe->where, &pe->where);
7312 /* Here, pr != NULL && qr != NULL */
7313 gcc_assert(pr->type == qr->type);
7314 if (pr->type == REF_ARRAY)
7316 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7318 gcc_assert (qr->type == REF_ARRAY);
7320 if (pr->next && qr->next)
7322 gfc_array_ref *par = &(pr->u.ar);
7323 gfc_array_ref *qar = &(qr->u.ar);
7324 if (gfc_dep_compare_expr (par->start[0],
7325 qar->start[0]) != 0)
7331 if (pr->u.c.component->name != qr->u.c.component->name)
7342 if (strcmp (fcn, "ALLOCATE") == 0)
7344 for (a = code->ext.alloc.list; a; a = a->next)
7345 resolve_allocate_expr (a->expr, code);
7349 for (a = code->ext.alloc.list; a; a = a->next)
7350 resolve_deallocate_expr (a->expr);
7355 /************ SELECT CASE resolution subroutines ************/
7357 /* Callback function for our mergesort variant. Determines interval
7358 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7359 op1 > op2. Assumes we're not dealing with the default case.
7360 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7361 There are nine situations to check. */
7364 compare_cases (const gfc_case *op1, const gfc_case *op2)
7368 if (op1->low == NULL) /* op1 = (:L) */
7370 /* op2 = (:N), so overlap. */
7372 /* op2 = (M:) or (M:N), L < M */
7373 if (op2->low != NULL
7374 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7377 else if (op1->high == NULL) /* op1 = (K:) */
7379 /* op2 = (M:), so overlap. */
7381 /* op2 = (:N) or (M:N), K > N */
7382 if (op2->high != NULL
7383 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7386 else /* op1 = (K:L) */
7388 if (op2->low == NULL) /* op2 = (:N), K > N */
7389 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7391 else if (op2->high == NULL) /* op2 = (M:), L < M */
7392 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7394 else /* op2 = (M:N) */
7398 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7401 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7410 /* Merge-sort a double linked case list, detecting overlap in the
7411 process. LIST is the head of the double linked case list before it
7412 is sorted. Returns the head of the sorted list if we don't see any
7413 overlap, or NULL otherwise. */
7416 check_case_overlap (gfc_case *list)
7418 gfc_case *p, *q, *e, *tail;
7419 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7421 /* If the passed list was empty, return immediately. */
7428 /* Loop unconditionally. The only exit from this loop is a return
7429 statement, when we've finished sorting the case list. */
7436 /* Count the number of merges we do in this pass. */
7439 /* Loop while there exists a merge to be done. */
7444 /* Count this merge. */
7447 /* Cut the list in two pieces by stepping INSIZE places
7448 forward in the list, starting from P. */
7451 for (i = 0; i < insize; i++)
7460 /* Now we have two lists. Merge them! */
7461 while (psize > 0 || (qsize > 0 && q != NULL))
7463 /* See from which the next case to merge comes from. */
7466 /* P is empty so the next case must come from Q. */
7471 else if (qsize == 0 || q == NULL)
7480 cmp = compare_cases (p, q);
7483 /* The whole case range for P is less than the
7491 /* The whole case range for Q is greater than
7492 the case range for P. */
7499 /* The cases overlap, or they are the same
7500 element in the list. Either way, we must
7501 issue an error and get the next case from P. */
7502 /* FIXME: Sort P and Q by line number. */
7503 gfc_error ("CASE label at %L overlaps with CASE "
7504 "label at %L", &p->where, &q->where);
7512 /* Add the next element to the merged list. */
7521 /* P has now stepped INSIZE places along, and so has Q. So
7522 they're the same. */
7527 /* If we have done only one merge or none at all, we've
7528 finished sorting the cases. */
7537 /* Otherwise repeat, merging lists twice the size. */
7543 /* Check to see if an expression is suitable for use in a CASE statement.
7544 Makes sure that all case expressions are scalar constants of the same
7545 type. Return FAILURE if anything is wrong. */
7548 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7550 if (e == NULL) return SUCCESS;
7552 if (e->ts.type != case_expr->ts.type)
7554 gfc_error ("Expression in CASE statement at %L must be of type %s",
7555 &e->where, gfc_basic_typename (case_expr->ts.type));
7559 /* C805 (R808) For a given case-construct, each case-value shall be of
7560 the same type as case-expr. For character type, length differences
7561 are allowed, but the kind type parameters shall be the same. */
7563 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7565 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7566 &e->where, case_expr->ts.kind);
7570 /* Convert the case value kind to that of case expression kind,
7573 if (e->ts.kind != case_expr->ts.kind)
7574 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7578 gfc_error ("Expression in CASE statement at %L must be scalar",
7587 /* Given a completely parsed select statement, we:
7589 - Validate all expressions and code within the SELECT.
7590 - Make sure that the selection expression is not of the wrong type.
7591 - Make sure that no case ranges overlap.
7592 - Eliminate unreachable cases and unreachable code resulting from
7593 removing case labels.
7595 The standard does allow unreachable cases, e.g. CASE (5:3). But
7596 they are a hassle for code generation, and to prevent that, we just
7597 cut them out here. This is not necessary for overlapping cases
7598 because they are illegal and we never even try to generate code.
7600 We have the additional caveat that a SELECT construct could have
7601 been a computed GOTO in the source code. Fortunately we can fairly
7602 easily work around that here: The case_expr for a "real" SELECT CASE
7603 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7604 we have to do is make sure that the case_expr is a scalar integer
7608 resolve_select (gfc_code *code)
7611 gfc_expr *case_expr;
7612 gfc_case *cp, *default_case, *tail, *head;
7613 int seen_unreachable;
7619 if (code->expr1 == NULL)
7621 /* This was actually a computed GOTO statement. */
7622 case_expr = code->expr2;
7623 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7624 gfc_error ("Selection expression in computed GOTO statement "
7625 "at %L must be a scalar integer expression",
7628 /* Further checking is not necessary because this SELECT was built
7629 by the compiler, so it should always be OK. Just move the
7630 case_expr from expr2 to expr so that we can handle computed
7631 GOTOs as normal SELECTs from here on. */
7632 code->expr1 = code->expr2;
7637 case_expr = code->expr1;
7639 type = case_expr->ts.type;
7640 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7642 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7643 &case_expr->where, gfc_typename (&case_expr->ts));
7645 /* Punt. Going on here just produce more garbage error messages. */
7649 /* Raise a warning if an INTEGER case value exceeds the range of
7650 the case-expr. Later, all expressions will be promoted to the
7651 largest kind of all case-labels. */
7653 if (type == BT_INTEGER)
7654 for (body = code->block; body; body = body->block)
7655 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7658 && gfc_check_integer_range (cp->low->value.integer,
7659 case_expr->ts.kind) != ARITH_OK)
7660 gfc_warning ("Expression in CASE statement at %L is "
7661 "not in the range of %s", &cp->low->where,
7662 gfc_typename (&case_expr->ts));
7665 && cp->low != cp->high
7666 && gfc_check_integer_range (cp->high->value.integer,
7667 case_expr->ts.kind) != ARITH_OK)
7668 gfc_warning ("Expression in CASE statement at %L is "
7669 "not in the range of %s", &cp->high->where,
7670 gfc_typename (&case_expr->ts));
7673 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7674 of the SELECT CASE expression and its CASE values. Walk the lists
7675 of case values, and if we find a mismatch, promote case_expr to
7676 the appropriate kind. */
7678 if (type == BT_LOGICAL || type == BT_INTEGER)
7680 for (body = code->block; body; body = body->block)
7682 /* Walk the case label list. */
7683 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7685 /* Intercept the DEFAULT case. It does not have a kind. */
7686 if (cp->low == NULL && cp->high == NULL)
7689 /* Unreachable case ranges are discarded, so ignore. */
7690 if (cp->low != NULL && cp->high != NULL
7691 && cp->low != cp->high
7692 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7696 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7697 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7699 if (cp->high != NULL
7700 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7701 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7706 /* Assume there is no DEFAULT case. */
7707 default_case = NULL;
7712 for (body = code->block; body; body = body->block)
7714 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7716 seen_unreachable = 0;
7718 /* Walk the case label list, making sure that all case labels
7720 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7722 /* Count the number of cases in the whole construct. */
7725 /* Intercept the DEFAULT case. */
7726 if (cp->low == NULL && cp->high == NULL)
7728 if (default_case != NULL)
7730 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7731 "by a second DEFAULT CASE at %L",
7732 &default_case->where, &cp->where);
7743 /* Deal with single value cases and case ranges. Errors are
7744 issued from the validation function. */
7745 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7746 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7752 if (type == BT_LOGICAL
7753 && ((cp->low == NULL || cp->high == NULL)
7754 || cp->low != cp->high))
7756 gfc_error ("Logical range in CASE statement at %L is not "
7757 "allowed", &cp->low->where);
7762 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7765 value = cp->low->value.logical == 0 ? 2 : 1;
7766 if (value & seen_logical)
7768 gfc_error ("Constant logical value in CASE statement "
7769 "is repeated at %L",
7774 seen_logical |= value;
7777 if (cp->low != NULL && cp->high != NULL
7778 && cp->low != cp->high
7779 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7781 if (gfc_option.warn_surprising)
7782 gfc_warning ("Range specification at %L can never "
7783 "be matched", &cp->where);
7785 cp->unreachable = 1;
7786 seen_unreachable = 1;
7790 /* If the case range can be matched, it can also overlap with
7791 other cases. To make sure it does not, we put it in a
7792 double linked list here. We sort that with a merge sort
7793 later on to detect any overlapping cases. */
7797 head->right = head->left = NULL;
7802 tail->right->left = tail;
7809 /* It there was a failure in the previous case label, give up
7810 for this case label list. Continue with the next block. */
7814 /* See if any case labels that are unreachable have been seen.
7815 If so, we eliminate them. This is a bit of a kludge because
7816 the case lists for a single case statement (label) is a
7817 single forward linked lists. */
7818 if (seen_unreachable)
7820 /* Advance until the first case in the list is reachable. */
7821 while (body->ext.block.case_list != NULL
7822 && body->ext.block.case_list->unreachable)
7824 gfc_case *n = body->ext.block.case_list;
7825 body->ext.block.case_list = body->ext.block.case_list->next;
7827 gfc_free_case_list (n);
7830 /* Strip all other unreachable cases. */
7831 if (body->ext.block.case_list)
7833 for (cp = body->ext.block.case_list; cp->next; cp = cp->next)
7835 if (cp->next->unreachable)
7837 gfc_case *n = cp->next;
7838 cp->next = cp->next->next;
7840 gfc_free_case_list (n);
7847 /* See if there were overlapping cases. If the check returns NULL,
7848 there was overlap. In that case we don't do anything. If head
7849 is non-NULL, we prepend the DEFAULT case. The sorted list can
7850 then used during code generation for SELECT CASE constructs with
7851 a case expression of a CHARACTER type. */
7854 head = check_case_overlap (head);
7856 /* Prepend the default_case if it is there. */
7857 if (head != NULL && default_case)
7859 default_case->left = NULL;
7860 default_case->right = head;
7861 head->left = default_case;
7865 /* Eliminate dead blocks that may be the result if we've seen
7866 unreachable case labels for a block. */
7867 for (body = code; body && body->block; body = body->block)
7869 if (body->block->ext.block.case_list == NULL)
7871 /* Cut the unreachable block from the code chain. */
7872 gfc_code *c = body->block;
7873 body->block = c->block;
7875 /* Kill the dead block, but not the blocks below it. */
7877 gfc_free_statements (c);
7881 /* More than two cases is legal but insane for logical selects.
7882 Issue a warning for it. */
7883 if (gfc_option.warn_surprising && type == BT_LOGICAL
7885 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7890 /* Check if a derived type is extensible. */
7893 gfc_type_is_extensible (gfc_symbol *sym)
7895 return !(sym->attr.is_bind_c || sym->attr.sequence);
7899 /* Resolve an associate name: Resolve target and ensure the type-spec is
7900 correct as well as possibly the array-spec. */
7903 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
7907 gcc_assert (sym->assoc);
7908 gcc_assert (sym->attr.flavor == FL_VARIABLE);
7910 /* If this is for SELECT TYPE, the target may not yet be set. In that
7911 case, return. Resolution will be called later manually again when
7913 target = sym->assoc->target;
7916 gcc_assert (!sym->assoc->dangling);
7918 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
7921 /* For variable targets, we get some attributes from the target. */
7922 if (target->expr_type == EXPR_VARIABLE)
7926 gcc_assert (target->symtree);
7927 tsym = target->symtree->n.sym;
7929 sym->attr.asynchronous = tsym->attr.asynchronous;
7930 sym->attr.volatile_ = tsym->attr.volatile_;
7932 if (tsym->ts.type == BT_CLASS)
7933 sym->attr.target = tsym->attr.target || CLASS_DATA (tsym)->attr.pointer;
7935 sym->attr.target = tsym->attr.target || tsym->attr.pointer;
7937 if (sym->ts.type == BT_DERIVED && tsym->ts.type == BT_CLASS)
7938 target->rank = sym->as ? sym->as->rank : 0;
7941 /* Get type if this was not already set. Note that it can be
7942 some other type than the target in case this is a SELECT TYPE
7943 selector! So we must not update when the type is already there. */
7944 if (sym->ts.type == BT_UNKNOWN)
7945 sym->ts = target->ts;
7946 gcc_assert (sym->ts.type != BT_UNKNOWN);
7948 /* See if this is a valid association-to-variable. */
7949 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
7950 && !gfc_has_vector_subscript (target));
7952 /* Finally resolve if this is an array or not. */
7953 if (sym->attr.dimension
7954 && (target->ts.type == BT_CLASS
7955 ? !CLASS_DATA (target)->attr.dimension
7956 : target->rank == 0))
7958 gfc_error ("Associate-name '%s' at %L is used as array",
7959 sym->name, &sym->declared_at);
7960 sym->attr.dimension = 0;
7963 if (target->rank > 0)
7964 sym->attr.dimension = 1;
7966 if (sym->attr.dimension)
7968 sym->as = gfc_get_array_spec ();
7969 sym->as->rank = target->rank;
7970 sym->as->type = AS_DEFERRED;
7972 /* Target must not be coindexed, thus the associate-variable
7974 sym->as->corank = 0;
7979 /* Resolve a SELECT TYPE statement. */
7982 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
7984 gfc_symbol *selector_type;
7985 gfc_code *body, *new_st, *if_st, *tail;
7986 gfc_code *class_is = NULL, *default_case = NULL;
7989 char name[GFC_MAX_SYMBOL_LEN];
7993 ns = code->ext.block.ns;
7996 /* Check for F03:C813. */
7997 if (code->expr1->ts.type != BT_CLASS
7998 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
8000 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8001 "at %L", &code->loc);
8005 if (!code->expr1->symtree->n.sym->attr.class_ok)
8010 if (code->expr1->symtree->n.sym->attr.untyped)
8011 code->expr1->symtree->n.sym->ts = code->expr2->ts;
8012 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
8015 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
8017 /* Loop over TYPE IS / CLASS IS cases. */
8018 for (body = code->block; body; body = body->block)
8020 c = body->ext.block.case_list;
8022 /* Check F03:C815. */
8023 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8024 && !gfc_type_is_extensible (c->ts.u.derived))
8026 gfc_error ("Derived type '%s' at %L must be extensible",
8027 c->ts.u.derived->name, &c->where);
8032 /* Check F03:C816. */
8033 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8034 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
8036 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
8037 c->ts.u.derived->name, &c->where, selector_type->name);
8042 /* Intercept the DEFAULT case. */
8043 if (c->ts.type == BT_UNKNOWN)
8045 /* Check F03:C818. */
8048 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8049 "by a second DEFAULT CASE at %L",
8050 &default_case->ext.block.case_list->where, &c->where);
8055 default_case = body;
8062 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8063 target if present. If there are any EXIT statements referring to the
8064 SELECT TYPE construct, this is no problem because the gfc_code
8065 reference stays the same and EXIT is equally possible from the BLOCK
8066 it is changed to. */
8067 code->op = EXEC_BLOCK;
8070 gfc_association_list* assoc;
8072 assoc = gfc_get_association_list ();
8073 assoc->st = code->expr1->symtree;
8074 assoc->target = gfc_copy_expr (code->expr2);
8075 assoc->target->where = code->expr2->where;
8076 /* assoc->variable will be set by resolve_assoc_var. */
8078 code->ext.block.assoc = assoc;
8079 code->expr1->symtree->n.sym->assoc = assoc;
8081 resolve_assoc_var (code->expr1->symtree->n.sym, false);
8084 code->ext.block.assoc = NULL;
8086 /* Add EXEC_SELECT to switch on type. */
8087 new_st = gfc_get_code ();
8088 new_st->op = code->op;
8089 new_st->expr1 = code->expr1;
8090 new_st->expr2 = code->expr2;
8091 new_st->block = code->block;
8092 code->expr1 = code->expr2 = NULL;
8097 ns->code->next = new_st;
8099 code->op = EXEC_SELECT;
8100 gfc_add_vptr_component (code->expr1);
8101 gfc_add_hash_component (code->expr1);
8103 /* Loop over TYPE IS / CLASS IS cases. */
8104 for (body = code->block; body; body = body->block)
8106 c = body->ext.block.case_list;
8108 if (c->ts.type == BT_DERIVED)
8109 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
8110 c->ts.u.derived->hash_value);
8112 else if (c->ts.type == BT_UNKNOWN)
8115 /* Associate temporary to selector. This should only be done
8116 when this case is actually true, so build a new ASSOCIATE
8117 that does precisely this here (instead of using the
8120 if (c->ts.type == BT_CLASS)
8121 sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
8123 sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
8124 st = gfc_find_symtree (ns->sym_root, name);
8125 gcc_assert (st->n.sym->assoc);
8126 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
8127 st->n.sym->assoc->target->where = code->expr1->where;
8128 if (c->ts.type == BT_DERIVED)
8129 gfc_add_data_component (st->n.sym->assoc->target);
8131 new_st = gfc_get_code ();
8132 new_st->op = EXEC_BLOCK;
8133 new_st->ext.block.ns = gfc_build_block_ns (ns);
8134 new_st->ext.block.ns->code = body->next;
8135 body->next = new_st;
8137 /* Chain in the new list only if it is marked as dangling. Otherwise
8138 there is a CASE label overlap and this is already used. Just ignore,
8139 the error is diagonsed elsewhere. */
8140 if (st->n.sym->assoc->dangling)
8142 new_st->ext.block.assoc = st->n.sym->assoc;
8143 st->n.sym->assoc->dangling = 0;
8146 resolve_assoc_var (st->n.sym, false);
8149 /* Take out CLASS IS cases for separate treatment. */
8151 while (body && body->block)
8153 if (body->block->ext.block.case_list->ts.type == BT_CLASS)
8155 /* Add to class_is list. */
8156 if (class_is == NULL)
8158 class_is = body->block;
8163 for (tail = class_is; tail->block; tail = tail->block) ;
8164 tail->block = body->block;
8167 /* Remove from EXEC_SELECT list. */
8168 body->block = body->block->block;
8181 /* Add a default case to hold the CLASS IS cases. */
8182 for (tail = code; tail->block; tail = tail->block) ;
8183 tail->block = gfc_get_code ();
8185 tail->op = EXEC_SELECT_TYPE;
8186 tail->ext.block.case_list = gfc_get_case ();
8187 tail->ext.block.case_list->ts.type = BT_UNKNOWN;
8189 default_case = tail;
8192 /* More than one CLASS IS block? */
8193 if (class_is->block)
8197 /* Sort CLASS IS blocks by extension level. */
8201 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
8204 /* F03:C817 (check for doubles). */
8205 if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
8206 == c2->ext.block.case_list->ts.u.derived->hash_value)
8208 gfc_error ("Double CLASS IS block in SELECT TYPE "
8210 &c2->ext.block.case_list->where);
8213 if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
8214 < c2->ext.block.case_list->ts.u.derived->attr.extension)
8217 (*c1)->block = c2->block;
8227 /* Generate IF chain. */
8228 if_st = gfc_get_code ();
8229 if_st->op = EXEC_IF;
8231 for (body = class_is; body; body = body->block)
8233 new_st->block = gfc_get_code ();
8234 new_st = new_st->block;
8235 new_st->op = EXEC_IF;
8236 /* Set up IF condition: Call _gfortran_is_extension_of. */
8237 new_st->expr1 = gfc_get_expr ();
8238 new_st->expr1->expr_type = EXPR_FUNCTION;
8239 new_st->expr1->ts.type = BT_LOGICAL;
8240 new_st->expr1->ts.kind = 4;
8241 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
8242 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
8243 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
8244 /* Set up arguments. */
8245 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
8246 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
8247 new_st->expr1->value.function.actual->expr->where = code->loc;
8248 gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
8249 vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
8250 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
8251 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
8252 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
8253 new_st->next = body->next;
8255 if (default_case->next)
8257 new_st->block = gfc_get_code ();
8258 new_st = new_st->block;
8259 new_st->op = EXEC_IF;
8260 new_st->next = default_case->next;
8263 /* Replace CLASS DEFAULT code by the IF chain. */
8264 default_case->next = if_st;
8267 /* Resolve the internal code. This can not be done earlier because
8268 it requires that the sym->assoc of selectors is set already. */
8269 gfc_current_ns = ns;
8270 gfc_resolve_blocks (code->block, gfc_current_ns);
8271 gfc_current_ns = old_ns;
8273 resolve_select (code);
8277 /* Resolve a transfer statement. This is making sure that:
8278 -- a derived type being transferred has only non-pointer components
8279 -- a derived type being transferred doesn't have private components, unless
8280 it's being transferred from the module where the type was defined
8281 -- we're not trying to transfer a whole assumed size array. */
8284 resolve_transfer (gfc_code *code)
8293 while (exp != NULL && exp->expr_type == EXPR_OP
8294 && exp->value.op.op == INTRINSIC_PARENTHESES)
8295 exp = exp->value.op.op1;
8297 if (exp && exp->expr_type == EXPR_NULL && exp->ts.type == BT_UNKNOWN)
8299 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8300 "MOLD=", &exp->where);
8304 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
8305 && exp->expr_type != EXPR_FUNCTION))
8308 /* If we are reading, the variable will be changed. Note that
8309 code->ext.dt may be NULL if the TRANSFER is related to
8310 an INQUIRE statement -- but in this case, we are not reading, either. */
8311 if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
8312 && gfc_check_vardef_context (exp, false, false, _("item in READ"))
8316 sym = exp->symtree->n.sym;
8319 /* Go to actual component transferred. */
8320 for (ref = exp->ref; ref; ref = ref->next)
8321 if (ref->type == REF_COMPONENT)
8322 ts = &ref->u.c.component->ts;
8324 if (ts->type == BT_CLASS)
8326 /* FIXME: Test for defined input/output. */
8327 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8328 "it is processed by a defined input/output procedure",
8333 if (ts->type == BT_DERIVED)
8335 /* Check that transferred derived type doesn't contain POINTER
8337 if (ts->u.derived->attr.pointer_comp)
8339 gfc_error ("Data transfer element at %L cannot have POINTER "
8340 "components unless it is processed by a defined "
8341 "input/output procedure", &code->loc);
8346 if (ts->u.derived->attr.proc_pointer_comp)
8348 gfc_error ("Data transfer element at %L cannot have "
8349 "procedure pointer components", &code->loc);
8353 if (ts->u.derived->attr.alloc_comp)
8355 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8356 "components unless it is processed by a defined "
8357 "input/output procedure", &code->loc);
8361 if (derived_inaccessible (ts->u.derived))
8363 gfc_error ("Data transfer element at %L cannot have "
8364 "PRIVATE components",&code->loc);
8369 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
8370 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
8372 gfc_error ("Data transfer element at %L cannot be a full reference to "
8373 "an assumed-size array", &code->loc);
8379 /*********** Toplevel code resolution subroutines ***********/
8381 /* Find the set of labels that are reachable from this block. We also
8382 record the last statement in each block. */
8385 find_reachable_labels (gfc_code *block)
8392 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
8394 /* Collect labels in this block. We don't keep those corresponding
8395 to END {IF|SELECT}, these are checked in resolve_branch by going
8396 up through the code_stack. */
8397 for (c = block; c; c = c->next)
8399 if (c->here && c->op != EXEC_END_NESTED_BLOCK)
8400 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8403 /* Merge with labels from parent block. */
8406 gcc_assert (cs_base->prev->reachable_labels);
8407 bitmap_ior_into (cs_base->reachable_labels,
8408 cs_base->prev->reachable_labels);
8414 resolve_lock_unlock (gfc_code *code)
8416 if (code->expr1->ts.type != BT_DERIVED
8417 || code->expr1->expr_type != EXPR_VARIABLE
8418 || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
8419 || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
8420 || code->expr1->rank != 0
8421 || (!gfc_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1)))
8422 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8423 &code->expr1->where);
8427 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8428 || code->expr2->expr_type != EXPR_VARIABLE))
8429 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8430 &code->expr2->where);
8433 && gfc_check_vardef_context (code->expr2, false, false,
8434 _("STAT variable")) == FAILURE)
8439 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8440 || code->expr3->expr_type != EXPR_VARIABLE))
8441 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8442 &code->expr3->where);
8445 && gfc_check_vardef_context (code->expr3, false, false,
8446 _("ERRMSG variable")) == FAILURE)
8449 /* Check ACQUIRED_LOCK. */
8451 && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
8452 || code->expr4->expr_type != EXPR_VARIABLE))
8453 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8454 "variable", &code->expr4->where);
8457 && gfc_check_vardef_context (code->expr4, false, false,
8458 _("ACQUIRED_LOCK variable")) == FAILURE)
8464 resolve_sync (gfc_code *code)
8466 /* Check imageset. The * case matches expr1 == NULL. */
8469 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8470 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8471 "INTEGER expression", &code->expr1->where);
8472 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8473 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8474 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8475 &code->expr1->where);
8476 else if (code->expr1->expr_type == EXPR_ARRAY
8477 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8479 gfc_constructor *cons;
8480 cons = gfc_constructor_first (code->expr1->value.constructor);
8481 for (; cons; cons = gfc_constructor_next (cons))
8482 if (cons->expr->expr_type == EXPR_CONSTANT
8483 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8484 gfc_error ("Imageset argument at %L must between 1 and "
8485 "num_images()", &cons->expr->where);
8491 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8492 || code->expr2->expr_type != EXPR_VARIABLE))
8493 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8494 &code->expr2->where);
8498 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8499 || code->expr3->expr_type != EXPR_VARIABLE))
8500 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8501 &code->expr3->where);
8505 /* Given a branch to a label, see if the branch is conforming.
8506 The code node describes where the branch is located. */
8509 resolve_branch (gfc_st_label *label, gfc_code *code)
8516 /* Step one: is this a valid branching target? */
8518 if (label->defined == ST_LABEL_UNKNOWN)
8520 gfc_error ("Label %d referenced at %L is never defined", label->value,
8525 if (label->defined != ST_LABEL_TARGET)
8527 gfc_error ("Statement at %L is not a valid branch target statement "
8528 "for the branch statement at %L", &label->where, &code->loc);
8532 /* Step two: make sure this branch is not a branch to itself ;-) */
8534 if (code->here == label)
8536 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8540 /* Step three: See if the label is in the same block as the
8541 branching statement. The hard work has been done by setting up
8542 the bitmap reachable_labels. */
8544 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8546 /* Check now whether there is a CRITICAL construct; if so, check
8547 whether the label is still visible outside of the CRITICAL block,
8548 which is invalid. */
8549 for (stack = cs_base; stack; stack = stack->prev)
8551 if (stack->current->op == EXEC_CRITICAL
8552 && bitmap_bit_p (stack->reachable_labels, label->value))
8553 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8554 "label at %L", &code->loc, &label->where);
8555 else if (stack->current->op == EXEC_DO_CONCURRENT
8556 && bitmap_bit_p (stack->reachable_labels, label->value))
8557 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8558 "for label at %L", &code->loc, &label->where);
8564 /* Step four: If we haven't found the label in the bitmap, it may
8565 still be the label of the END of the enclosing block, in which
8566 case we find it by going up the code_stack. */
8568 for (stack = cs_base; stack; stack = stack->prev)
8570 if (stack->current->next && stack->current->next->here == label)
8572 if (stack->current->op == EXEC_CRITICAL)
8574 /* Note: A label at END CRITICAL does not leave the CRITICAL
8575 construct as END CRITICAL is still part of it. */
8576 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8577 " at %L", &code->loc, &label->where);
8580 else if (stack->current->op == EXEC_DO_CONCURRENT)
8582 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8583 "label at %L", &code->loc, &label->where);
8590 gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
8594 /* The label is not in an enclosing block, so illegal. This was
8595 allowed in Fortran 66, so we allow it as extension. No
8596 further checks are necessary in this case. */
8597 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
8598 "as the GOTO statement at %L", &label->where,
8604 /* Check whether EXPR1 has the same shape as EXPR2. */
8607 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
8609 mpz_t shape[GFC_MAX_DIMENSIONS];
8610 mpz_t shape2[GFC_MAX_DIMENSIONS];
8611 gfc_try result = FAILURE;
8614 /* Compare the rank. */
8615 if (expr1->rank != expr2->rank)
8618 /* Compare the size of each dimension. */
8619 for (i=0; i<expr1->rank; i++)
8621 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
8624 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
8627 if (mpz_cmp (shape[i], shape2[i]))
8631 /* When either of the two expression is an assumed size array, we
8632 ignore the comparison of dimension sizes. */
8637 gfc_clear_shape (shape, i);
8638 gfc_clear_shape (shape2, i);
8643 /* Check whether a WHERE assignment target or a WHERE mask expression
8644 has the same shape as the outmost WHERE mask expression. */
8647 resolve_where (gfc_code *code, gfc_expr *mask)
8653 cblock = code->block;
8655 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8656 In case of nested WHERE, only the outmost one is stored. */
8657 if (mask == NULL) /* outmost WHERE */
8659 else /* inner WHERE */
8666 /* Check if the mask-expr has a consistent shape with the
8667 outmost WHERE mask-expr. */
8668 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8669 gfc_error ("WHERE mask at %L has inconsistent shape",
8670 &cblock->expr1->where);
8673 /* the assignment statement of a WHERE statement, or the first
8674 statement in where-body-construct of a WHERE construct */
8675 cnext = cblock->next;
8680 /* WHERE assignment statement */
8683 /* Check shape consistent for WHERE assignment target. */
8684 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8685 gfc_error ("WHERE assignment target at %L has "
8686 "inconsistent shape", &cnext->expr1->where);
8690 case EXEC_ASSIGN_CALL:
8691 resolve_call (cnext);
8692 if (!cnext->resolved_sym->attr.elemental)
8693 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8694 &cnext->ext.actual->expr->where);
8697 /* WHERE or WHERE construct is part of a where-body-construct */
8699 resolve_where (cnext, e);
8703 gfc_error ("Unsupported statement inside WHERE at %L",
8706 /* the next statement within the same where-body-construct */
8707 cnext = cnext->next;
8709 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8710 cblock = cblock->block;
8715 /* Resolve assignment in FORALL construct.
8716 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8717 FORALL index variables. */
8720 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8724 for (n = 0; n < nvar; n++)
8726 gfc_symbol *forall_index;
8728 forall_index = var_expr[n]->symtree->n.sym;
8730 /* Check whether the assignment target is one of the FORALL index
8732 if ((code->expr1->expr_type == EXPR_VARIABLE)
8733 && (code->expr1->symtree->n.sym == forall_index))
8734 gfc_error ("Assignment to a FORALL index variable at %L",
8735 &code->expr1->where);
8738 /* If one of the FORALL index variables doesn't appear in the
8739 assignment variable, then there could be a many-to-one
8740 assignment. Emit a warning rather than an error because the
8741 mask could be resolving this problem. */
8742 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8743 gfc_warning ("The FORALL with index '%s' is not used on the "
8744 "left side of the assignment at %L and so might "
8745 "cause multiple assignment to this object",
8746 var_expr[n]->symtree->name, &code->expr1->where);
8752 /* Resolve WHERE statement in FORALL construct. */
8755 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8756 gfc_expr **var_expr)
8761 cblock = code->block;
8764 /* the assignment statement of a WHERE statement, or the first
8765 statement in where-body-construct of a WHERE construct */
8766 cnext = cblock->next;
8771 /* WHERE assignment statement */
8773 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8776 /* WHERE operator assignment statement */
8777 case EXEC_ASSIGN_CALL:
8778 resolve_call (cnext);
8779 if (!cnext->resolved_sym->attr.elemental)
8780 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8781 &cnext->ext.actual->expr->where);
8784 /* WHERE or WHERE construct is part of a where-body-construct */
8786 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8790 gfc_error ("Unsupported statement inside WHERE at %L",
8793 /* the next statement within the same where-body-construct */
8794 cnext = cnext->next;
8796 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8797 cblock = cblock->block;
8802 /* Traverse the FORALL body to check whether the following errors exist:
8803 1. For assignment, check if a many-to-one assignment happens.
8804 2. For WHERE statement, check the WHERE body to see if there is any
8805 many-to-one assignment. */
8808 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8812 c = code->block->next;
8818 case EXEC_POINTER_ASSIGN:
8819 gfc_resolve_assign_in_forall (c, nvar, var_expr);
8822 case EXEC_ASSIGN_CALL:
8826 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8827 there is no need to handle it here. */
8831 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8836 /* The next statement in the FORALL body. */
8842 /* Counts the number of iterators needed inside a forall construct, including
8843 nested forall constructs. This is used to allocate the needed memory
8844 in gfc_resolve_forall. */
8847 gfc_count_forall_iterators (gfc_code *code)
8849 int max_iters, sub_iters, current_iters;
8850 gfc_forall_iterator *fa;
8852 gcc_assert(code->op == EXEC_FORALL);
8856 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8859 code = code->block->next;
8863 if (code->op == EXEC_FORALL)
8865 sub_iters = gfc_count_forall_iterators (code);
8866 if (sub_iters > max_iters)
8867 max_iters = sub_iters;
8872 return current_iters + max_iters;
8876 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8877 gfc_resolve_forall_body to resolve the FORALL body. */
8880 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8882 static gfc_expr **var_expr;
8883 static int total_var = 0;
8884 static int nvar = 0;
8886 gfc_forall_iterator *fa;
8891 /* Start to resolve a FORALL construct */
8892 if (forall_save == 0)
8894 /* Count the total number of FORALL index in the nested FORALL
8895 construct in order to allocate the VAR_EXPR with proper size. */
8896 total_var = gfc_count_forall_iterators (code);
8898 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8899 var_expr = XCNEWVEC (gfc_expr *, total_var);
8902 /* The information about FORALL iterator, including FORALL index start, end
8903 and stride. The FORALL index can not appear in start, end or stride. */
8904 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8906 /* Check if any outer FORALL index name is the same as the current
8908 for (i = 0; i < nvar; i++)
8910 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8912 gfc_error ("An outer FORALL construct already has an index "
8913 "with this name %L", &fa->var->where);
8917 /* Record the current FORALL index. */
8918 var_expr[nvar] = gfc_copy_expr (fa->var);
8922 /* No memory leak. */
8923 gcc_assert (nvar <= total_var);
8926 /* Resolve the FORALL body. */
8927 gfc_resolve_forall_body (code, nvar, var_expr);
8929 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8930 gfc_resolve_blocks (code->block, ns);
8934 /* Free only the VAR_EXPRs allocated in this frame. */
8935 for (i = nvar; i < tmp; i++)
8936 gfc_free_expr (var_expr[i]);
8940 /* We are in the outermost FORALL construct. */
8941 gcc_assert (forall_save == 0);
8943 /* VAR_EXPR is not needed any more. */
8950 /* Resolve a BLOCK construct statement. */
8953 resolve_block_construct (gfc_code* code)
8955 /* Resolve the BLOCK's namespace. */
8956 gfc_resolve (code->ext.block.ns);
8958 /* For an ASSOCIATE block, the associations (and their targets) are already
8959 resolved during resolve_symbol. */
8963 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8966 static void resolve_code (gfc_code *, gfc_namespace *);
8969 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8973 for (; b; b = b->block)
8975 t = gfc_resolve_expr (b->expr1);
8976 if (gfc_resolve_expr (b->expr2) == FAILURE)
8982 if (t == SUCCESS && b->expr1 != NULL
8983 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
8984 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8991 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
8992 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8997 resolve_branch (b->label1, b);
9001 resolve_block_construct (b);
9005 case EXEC_SELECT_TYPE:
9009 case EXEC_DO_CONCURRENT:
9017 case EXEC_OMP_ATOMIC:
9018 case EXEC_OMP_CRITICAL:
9020 case EXEC_OMP_MASTER:
9021 case EXEC_OMP_ORDERED:
9022 case EXEC_OMP_PARALLEL:
9023 case EXEC_OMP_PARALLEL_DO:
9024 case EXEC_OMP_PARALLEL_SECTIONS:
9025 case EXEC_OMP_PARALLEL_WORKSHARE:
9026 case EXEC_OMP_SECTIONS:
9027 case EXEC_OMP_SINGLE:
9029 case EXEC_OMP_TASKWAIT:
9030 case EXEC_OMP_TASKYIELD:
9031 case EXEC_OMP_WORKSHARE:
9035 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9038 resolve_code (b->next, ns);
9043 /* Does everything to resolve an ordinary assignment. Returns true
9044 if this is an interface assignment. */
9046 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
9056 if (gfc_extend_assign (code, ns) == SUCCESS)
9060 if (code->op == EXEC_ASSIGN_CALL)
9062 lhs = code->ext.actual->expr;
9063 rhsptr = &code->ext.actual->next->expr;
9067 gfc_actual_arglist* args;
9068 gfc_typebound_proc* tbp;
9070 gcc_assert (code->op == EXEC_COMPCALL);
9072 args = code->expr1->value.compcall.actual;
9074 rhsptr = &args->next->expr;
9076 tbp = code->expr1->value.compcall.tbp;
9077 gcc_assert (!tbp->is_generic);
9080 /* Make a temporary rhs when there is a default initializer
9081 and rhs is the same symbol as the lhs. */
9082 if ((*rhsptr)->expr_type == EXPR_VARIABLE
9083 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
9084 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
9085 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
9086 *rhsptr = gfc_get_parentheses (*rhsptr);
9095 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
9096 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9097 &code->loc) == FAILURE)
9100 /* Handle the case of a BOZ literal on the RHS. */
9101 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
9104 if (gfc_option.warn_surprising)
9105 gfc_warning ("BOZ literal at %L is bitwise transferred "
9106 "non-integer symbol '%s'", &code->loc,
9107 lhs->symtree->n.sym->name);
9109 if (!gfc_convert_boz (rhs, &lhs->ts))
9111 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
9113 if (rc == ARITH_UNDERFLOW)
9114 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9115 ". This check can be disabled with the option "
9116 "-fno-range-check", &rhs->where);
9117 else if (rc == ARITH_OVERFLOW)
9118 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9119 ". This check can be disabled with the option "
9120 "-fno-range-check", &rhs->where);
9121 else if (rc == ARITH_NAN)
9122 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9123 ". This check can be disabled with the option "
9124 "-fno-range-check", &rhs->where);
9129 if (lhs->ts.type == BT_CHARACTER
9130 && gfc_option.warn_character_truncation)
9132 if (lhs->ts.u.cl != NULL
9133 && lhs->ts.u.cl->length != NULL
9134 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9135 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
9137 if (rhs->expr_type == EXPR_CONSTANT)
9138 rlen = rhs->value.character.length;
9140 else if (rhs->ts.u.cl != NULL
9141 && rhs->ts.u.cl->length != NULL
9142 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9143 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
9145 if (rlen && llen && rlen > llen)
9146 gfc_warning_now ("CHARACTER expression will be truncated "
9147 "in assignment (%d/%d) at %L",
9148 llen, rlen, &code->loc);
9151 /* Ensure that a vector index expression for the lvalue is evaluated
9152 to a temporary if the lvalue symbol is referenced in it. */
9155 for (ref = lhs->ref; ref; ref= ref->next)
9156 if (ref->type == REF_ARRAY)
9158 for (n = 0; n < ref->u.ar.dimen; n++)
9159 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
9160 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
9161 ref->u.ar.start[n]))
9163 = gfc_get_parentheses (ref->u.ar.start[n]);
9167 if (gfc_pure (NULL))
9169 if (lhs->ts.type == BT_DERIVED
9170 && lhs->expr_type == EXPR_VARIABLE
9171 && lhs->ts.u.derived->attr.pointer_comp
9172 && rhs->expr_type == EXPR_VARIABLE
9173 && (gfc_impure_variable (rhs->symtree->n.sym)
9174 || gfc_is_coindexed (rhs)))
9177 if (gfc_is_coindexed (rhs))
9178 gfc_error ("Coindexed expression at %L is assigned to "
9179 "a derived type variable with a POINTER "
9180 "component in a PURE procedure",
9183 gfc_error ("The impure variable at %L is assigned to "
9184 "a derived type variable with a POINTER "
9185 "component in a PURE procedure (12.6)",
9190 /* Fortran 2008, C1283. */
9191 if (gfc_is_coindexed (lhs))
9193 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9194 "procedure", &rhs->where);
9199 if (gfc_implicit_pure (NULL))
9201 if (lhs->expr_type == EXPR_VARIABLE
9202 && lhs->symtree->n.sym != gfc_current_ns->proc_name
9203 && lhs->symtree->n.sym->ns != gfc_current_ns)
9204 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9206 if (lhs->ts.type == BT_DERIVED
9207 && lhs->expr_type == EXPR_VARIABLE
9208 && lhs->ts.u.derived->attr.pointer_comp
9209 && rhs->expr_type == EXPR_VARIABLE
9210 && (gfc_impure_variable (rhs->symtree->n.sym)
9211 || gfc_is_coindexed (rhs)))
9212 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9214 /* Fortran 2008, C1283. */
9215 if (gfc_is_coindexed (lhs))
9216 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9220 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9221 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9222 if (lhs->ts.type == BT_CLASS)
9224 gfc_error ("Variable must not be polymorphic in intrinsic assignment at "
9225 "%L - check that there is a matching specific subroutine "
9226 "for '=' operator", &lhs->where);
9230 /* F2008, Section 7.2.1.2. */
9231 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
9233 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9234 "component in assignment at %L", &lhs->where);
9238 gfc_check_assign (lhs, rhs, 1);
9243 /* Given a block of code, recursively resolve everything pointed to by this
9247 resolve_code (gfc_code *code, gfc_namespace *ns)
9249 int omp_workshare_save;
9250 int forall_save, do_concurrent_save;
9254 frame.prev = cs_base;
9258 find_reachable_labels (code);
9260 for (; code; code = code->next)
9262 frame.current = code;
9263 forall_save = forall_flag;
9264 do_concurrent_save = do_concurrent_flag;
9266 if (code->op == EXEC_FORALL)
9269 gfc_resolve_forall (code, ns, forall_save);
9272 else if (code->block)
9274 omp_workshare_save = -1;
9277 case EXEC_OMP_PARALLEL_WORKSHARE:
9278 omp_workshare_save = omp_workshare_flag;
9279 omp_workshare_flag = 1;
9280 gfc_resolve_omp_parallel_blocks (code, ns);
9282 case EXEC_OMP_PARALLEL:
9283 case EXEC_OMP_PARALLEL_DO:
9284 case EXEC_OMP_PARALLEL_SECTIONS:
9286 omp_workshare_save = omp_workshare_flag;
9287 omp_workshare_flag = 0;
9288 gfc_resolve_omp_parallel_blocks (code, ns);
9291 gfc_resolve_omp_do_blocks (code, ns);
9293 case EXEC_SELECT_TYPE:
9294 /* Blocks are handled in resolve_select_type because we have
9295 to transform the SELECT TYPE into ASSOCIATE first. */
9297 case EXEC_DO_CONCURRENT:
9298 do_concurrent_flag = 1;
9299 gfc_resolve_blocks (code->block, ns);
9300 do_concurrent_flag = 2;
9302 case EXEC_OMP_WORKSHARE:
9303 omp_workshare_save = omp_workshare_flag;
9304 omp_workshare_flag = 1;
9307 gfc_resolve_blocks (code->block, ns);
9311 if (omp_workshare_save != -1)
9312 omp_workshare_flag = omp_workshare_save;
9316 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
9317 t = gfc_resolve_expr (code->expr1);
9318 forall_flag = forall_save;
9319 do_concurrent_flag = do_concurrent_save;
9321 if (gfc_resolve_expr (code->expr2) == FAILURE)
9324 if (code->op == EXEC_ALLOCATE
9325 && gfc_resolve_expr (code->expr3) == FAILURE)
9331 case EXEC_END_BLOCK:
9332 case EXEC_END_NESTED_BLOCK:
9336 case EXEC_ERROR_STOP:
9340 case EXEC_ASSIGN_CALL:
9345 case EXEC_SYNC_IMAGES:
9346 case EXEC_SYNC_MEMORY:
9347 resolve_sync (code);
9352 resolve_lock_unlock (code);
9356 /* Keep track of which entry we are up to. */
9357 current_entry_id = code->ext.entry->id;
9361 resolve_where (code, NULL);
9365 if (code->expr1 != NULL)
9367 if (code->expr1->ts.type != BT_INTEGER)
9368 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9369 "INTEGER variable", &code->expr1->where);
9370 else if (code->expr1->symtree->n.sym->attr.assign != 1)
9371 gfc_error ("Variable '%s' has not been assigned a target "
9372 "label at %L", code->expr1->symtree->n.sym->name,
9373 &code->expr1->where);
9376 resolve_branch (code->label1, code);
9380 if (code->expr1 != NULL
9381 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
9382 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9383 "INTEGER return specifier", &code->expr1->where);
9386 case EXEC_INIT_ASSIGN:
9387 case EXEC_END_PROCEDURE:
9394 if (gfc_check_vardef_context (code->expr1, false, false,
9395 _("assignment")) == FAILURE)
9398 if (resolve_ordinary_assign (code, ns))
9400 if (code->op == EXEC_COMPCALL)
9407 case EXEC_LABEL_ASSIGN:
9408 if (code->label1->defined == ST_LABEL_UNKNOWN)
9409 gfc_error ("Label %d referenced at %L is never defined",
9410 code->label1->value, &code->label1->where);
9412 && (code->expr1->expr_type != EXPR_VARIABLE
9413 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
9414 || code->expr1->symtree->n.sym->ts.kind
9415 != gfc_default_integer_kind
9416 || code->expr1->symtree->n.sym->as != NULL))
9417 gfc_error ("ASSIGN statement at %L requires a scalar "
9418 "default INTEGER variable", &code->expr1->where);
9421 case EXEC_POINTER_ASSIGN:
9428 /* This is both a variable definition and pointer assignment
9429 context, so check both of them. For rank remapping, a final
9430 array ref may be present on the LHS and fool gfc_expr_attr
9431 used in gfc_check_vardef_context. Remove it. */
9432 e = remove_last_array_ref (code->expr1);
9433 t = gfc_check_vardef_context (e, true, false,
9434 _("pointer assignment"));
9436 t = gfc_check_vardef_context (e, false, false,
9437 _("pointer assignment"));
9442 gfc_check_pointer_assign (code->expr1, code->expr2);
9446 case EXEC_ARITHMETIC_IF:
9448 && code->expr1->ts.type != BT_INTEGER
9449 && code->expr1->ts.type != BT_REAL)
9450 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9451 "expression", &code->expr1->where);
9453 resolve_branch (code->label1, code);
9454 resolve_branch (code->label2, code);
9455 resolve_branch (code->label3, code);
9459 if (t == SUCCESS && code->expr1 != NULL
9460 && (code->expr1->ts.type != BT_LOGICAL
9461 || code->expr1->rank != 0))
9462 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9463 &code->expr1->where);
9468 resolve_call (code);
9473 resolve_typebound_subroutine (code);
9477 resolve_ppc_call (code);
9481 /* Select is complicated. Also, a SELECT construct could be
9482 a transformed computed GOTO. */
9483 resolve_select (code);
9486 case EXEC_SELECT_TYPE:
9487 resolve_select_type (code, ns);
9491 resolve_block_construct (code);
9495 if (code->ext.iterator != NULL)
9497 gfc_iterator *iter = code->ext.iterator;
9498 if (gfc_resolve_iterator (iter, true) != FAILURE)
9499 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
9504 if (code->expr1 == NULL)
9505 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9507 && (code->expr1->rank != 0
9508 || code->expr1->ts.type != BT_LOGICAL))
9509 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9510 "a scalar LOGICAL expression", &code->expr1->where);
9515 resolve_allocate_deallocate (code, "ALLOCATE");
9519 case EXEC_DEALLOCATE:
9521 resolve_allocate_deallocate (code, "DEALLOCATE");
9526 if (gfc_resolve_open (code->ext.open) == FAILURE)
9529 resolve_branch (code->ext.open->err, code);
9533 if (gfc_resolve_close (code->ext.close) == FAILURE)
9536 resolve_branch (code->ext.close->err, code);
9539 case EXEC_BACKSPACE:
9543 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
9546 resolve_branch (code->ext.filepos->err, code);
9550 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9553 resolve_branch (code->ext.inquire->err, code);
9557 gcc_assert (code->ext.inquire != NULL);
9558 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9561 resolve_branch (code->ext.inquire->err, code);
9565 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
9568 resolve_branch (code->ext.wait->err, code);
9569 resolve_branch (code->ext.wait->end, code);
9570 resolve_branch (code->ext.wait->eor, code);
9575 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
9578 resolve_branch (code->ext.dt->err, code);
9579 resolve_branch (code->ext.dt->end, code);
9580 resolve_branch (code->ext.dt->eor, code);
9584 resolve_transfer (code);
9587 case EXEC_DO_CONCURRENT:
9589 resolve_forall_iterators (code->ext.forall_iterator);
9591 if (code->expr1 != NULL
9592 && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
9593 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9594 "expression", &code->expr1->where);
9597 case EXEC_OMP_ATOMIC:
9598 case EXEC_OMP_BARRIER:
9599 case EXEC_OMP_CRITICAL:
9600 case EXEC_OMP_FLUSH:
9602 case EXEC_OMP_MASTER:
9603 case EXEC_OMP_ORDERED:
9604 case EXEC_OMP_SECTIONS:
9605 case EXEC_OMP_SINGLE:
9606 case EXEC_OMP_TASKWAIT:
9607 case EXEC_OMP_TASKYIELD:
9608 case EXEC_OMP_WORKSHARE:
9609 gfc_resolve_omp_directive (code, ns);
9612 case EXEC_OMP_PARALLEL:
9613 case EXEC_OMP_PARALLEL_DO:
9614 case EXEC_OMP_PARALLEL_SECTIONS:
9615 case EXEC_OMP_PARALLEL_WORKSHARE:
9617 omp_workshare_save = omp_workshare_flag;
9618 omp_workshare_flag = 0;
9619 gfc_resolve_omp_directive (code, ns);
9620 omp_workshare_flag = omp_workshare_save;
9624 gfc_internal_error ("resolve_code(): Bad statement code");
9628 cs_base = frame.prev;
9632 /* Resolve initial values and make sure they are compatible with
9636 resolve_values (gfc_symbol *sym)
9640 if (sym->value == NULL || sym->attr.use_assoc)
9643 if (sym->value->expr_type == EXPR_STRUCTURE)
9644 t= resolve_structure_cons (sym->value, 1);
9646 t = gfc_resolve_expr (sym->value);
9651 gfc_check_assign_symbol (sym, sym->value);
9655 /* Verify the binding labels for common blocks that are BIND(C). The label
9656 for a BIND(C) common block must be identical in all scoping units in which
9657 the common block is declared. Further, the binding label can not collide
9658 with any other global entity in the program. */
9661 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
9663 if (comm_block_tree->n.common->is_bind_c == 1)
9665 gfc_gsymbol *binding_label_gsym;
9666 gfc_gsymbol *comm_name_gsym;
9668 /* See if a global symbol exists by the common block's name. It may
9669 be NULL if the common block is use-associated. */
9670 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
9671 comm_block_tree->n.common->name);
9672 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
9673 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9674 "with the global entity '%s' at %L",
9675 comm_block_tree->n.common->binding_label,
9676 comm_block_tree->n.common->name,
9677 &(comm_block_tree->n.common->where),
9678 comm_name_gsym->name, &(comm_name_gsym->where));
9679 else if (comm_name_gsym != NULL
9680 && strcmp (comm_name_gsym->name,
9681 comm_block_tree->n.common->name) == 0)
9683 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9685 if (comm_name_gsym->binding_label == NULL)
9686 /* No binding label for common block stored yet; save this one. */
9687 comm_name_gsym->binding_label =
9688 comm_block_tree->n.common->binding_label;
9690 if (strcmp (comm_name_gsym->binding_label,
9691 comm_block_tree->n.common->binding_label) != 0)
9693 /* Common block names match but binding labels do not. */
9694 gfc_error ("Binding label '%s' for common block '%s' at %L "
9695 "does not match the binding label '%s' for common "
9697 comm_block_tree->n.common->binding_label,
9698 comm_block_tree->n.common->name,
9699 &(comm_block_tree->n.common->where),
9700 comm_name_gsym->binding_label,
9701 comm_name_gsym->name,
9702 &(comm_name_gsym->where));
9707 /* There is no binding label (NAME="") so we have nothing further to
9708 check and nothing to add as a global symbol for the label. */
9709 if (comm_block_tree->n.common->binding_label[0] == '\0' )
9712 binding_label_gsym =
9713 gfc_find_gsymbol (gfc_gsym_root,
9714 comm_block_tree->n.common->binding_label);
9715 if (binding_label_gsym == NULL)
9717 /* Need to make a global symbol for the binding label to prevent
9718 it from colliding with another. */
9719 binding_label_gsym =
9720 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9721 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9722 binding_label_gsym->type = GSYM_COMMON;
9726 /* If comm_name_gsym is NULL, the name common block is use
9727 associated and the name could be colliding. */
9728 if (binding_label_gsym->type != GSYM_COMMON)
9729 gfc_error ("Binding label '%s' for common block '%s' at %L "
9730 "collides with the global entity '%s' at %L",
9731 comm_block_tree->n.common->binding_label,
9732 comm_block_tree->n.common->name,
9733 &(comm_block_tree->n.common->where),
9734 binding_label_gsym->name,
9735 &(binding_label_gsym->where));
9736 else if (comm_name_gsym != NULL
9737 && (strcmp (binding_label_gsym->name,
9738 comm_name_gsym->binding_label) != 0)
9739 && (strcmp (binding_label_gsym->sym_name,
9740 comm_name_gsym->name) != 0))
9741 gfc_error ("Binding label '%s' for common block '%s' at %L "
9742 "collides with global entity '%s' at %L",
9743 binding_label_gsym->name, binding_label_gsym->sym_name,
9744 &(comm_block_tree->n.common->where),
9745 comm_name_gsym->name, &(comm_name_gsym->where));
9753 /* Verify any BIND(C) derived types in the namespace so we can report errors
9754 for them once, rather than for each variable declared of that type. */
9757 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9759 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9760 && derived_sym->attr.is_bind_c == 1)
9761 verify_bind_c_derived_type (derived_sym);
9767 /* Verify that any binding labels used in a given namespace do not collide
9768 with the names or binding labels of any global symbols. */
9771 gfc_verify_binding_labels (gfc_symbol *sym)
9775 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9776 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
9778 gfc_gsymbol *bind_c_sym;
9780 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9781 if (bind_c_sym != NULL
9782 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9784 if (sym->attr.if_source == IFSRC_DECL
9785 && (bind_c_sym->type != GSYM_SUBROUTINE
9786 && bind_c_sym->type != GSYM_FUNCTION)
9787 && ((sym->attr.contained == 1
9788 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9789 || (sym->attr.use_assoc == 1
9790 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9792 /* Make sure global procedures don't collide with anything. */
9793 gfc_error ("Binding label '%s' at %L collides with the global "
9794 "entity '%s' at %L", sym->binding_label,
9795 &(sym->declared_at), bind_c_sym->name,
9796 &(bind_c_sym->where));
9799 else if (sym->attr.contained == 0
9800 && (sym->attr.if_source == IFSRC_IFBODY
9801 && sym->attr.flavor == FL_PROCEDURE)
9802 && (bind_c_sym->sym_name != NULL
9803 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9805 /* Make sure procedures in interface bodies don't collide. */
9806 gfc_error ("Binding label '%s' in interface body at %L collides "
9807 "with the global entity '%s' at %L",
9809 &(sym->declared_at), bind_c_sym->name,
9810 &(bind_c_sym->where));
9813 else if (sym->attr.contained == 0
9814 && sym->attr.if_source == IFSRC_UNKNOWN)
9815 if ((sym->attr.use_assoc && bind_c_sym->mod_name
9816 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9817 || sym->attr.use_assoc == 0)
9819 gfc_error ("Binding label '%s' at %L collides with global "
9820 "entity '%s' at %L", sym->binding_label,
9821 &(sym->declared_at), bind_c_sym->name,
9822 &(bind_c_sym->where));
9827 /* Clear the binding label to prevent checking multiple times. */
9828 sym->binding_label[0] = '\0';
9830 else if (bind_c_sym == NULL)
9832 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9833 bind_c_sym->where = sym->declared_at;
9834 bind_c_sym->sym_name = sym->name;
9836 if (sym->attr.use_assoc == 1)
9837 bind_c_sym->mod_name = sym->module;
9839 if (sym->ns->proc_name != NULL)
9840 bind_c_sym->mod_name = sym->ns->proc_name->name;
9842 if (sym->attr.contained == 0)
9844 if (sym->attr.subroutine)
9845 bind_c_sym->type = GSYM_SUBROUTINE;
9846 else if (sym->attr.function)
9847 bind_c_sym->type = GSYM_FUNCTION;
9855 /* Resolve an index expression. */
9858 resolve_index_expr (gfc_expr *e)
9860 if (gfc_resolve_expr (e) == FAILURE)
9863 if (gfc_simplify_expr (e, 0) == FAILURE)
9866 if (gfc_specification_expr (e) == FAILURE)
9873 /* Resolve a charlen structure. */
9876 resolve_charlen (gfc_charlen *cl)
9885 specification_expr = 1;
9887 if (resolve_index_expr (cl->length) == FAILURE)
9889 specification_expr = 0;
9893 /* "If the character length parameter value evaluates to a negative
9894 value, the length of character entities declared is zero." */
9895 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9897 if (gfc_option.warn_surprising)
9898 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9899 " the length has been set to zero",
9900 &cl->length->where, i);
9901 gfc_replace_expr (cl->length,
9902 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9905 /* Check that the character length is not too large. */
9906 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9907 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9908 && cl->length->ts.type == BT_INTEGER
9909 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9911 gfc_error ("String length at %L is too large", &cl->length->where);
9919 /* Test for non-constant shape arrays. */
9922 is_non_constant_shape_array (gfc_symbol *sym)
9928 not_constant = false;
9929 if (sym->as != NULL)
9931 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9932 has not been simplified; parameter array references. Do the
9933 simplification now. */
9934 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9936 e = sym->as->lower[i];
9937 if (e && (resolve_index_expr (e) == FAILURE
9938 || !gfc_is_constant_expr (e)))
9939 not_constant = true;
9940 e = sym->as->upper[i];
9941 if (e && (resolve_index_expr (e) == FAILURE
9942 || !gfc_is_constant_expr (e)))
9943 not_constant = true;
9946 return not_constant;
9949 /* Given a symbol and an initialization expression, add code to initialize
9950 the symbol to the function entry. */
9952 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9956 gfc_namespace *ns = sym->ns;
9958 /* Search for the function namespace if this is a contained
9959 function without an explicit result. */
9960 if (sym->attr.function && sym == sym->result
9961 && sym->name != sym->ns->proc_name->name)
9964 for (;ns; ns = ns->sibling)
9965 if (strcmp (ns->proc_name->name, sym->name) == 0)
9971 gfc_free_expr (init);
9975 /* Build an l-value expression for the result. */
9976 lval = gfc_lval_expr_from_sym (sym);
9978 /* Add the code at scope entry. */
9979 init_st = gfc_get_code ();
9980 init_st->next = ns->code;
9983 /* Assign the default initializer to the l-value. */
9984 init_st->loc = sym->declared_at;
9985 init_st->op = EXEC_INIT_ASSIGN;
9986 init_st->expr1 = lval;
9987 init_st->expr2 = init;
9990 /* Assign the default initializer to a derived type variable or result. */
9993 apply_default_init (gfc_symbol *sym)
9995 gfc_expr *init = NULL;
9997 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
10000 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
10001 init = gfc_default_initializer (&sym->ts);
10003 if (init == NULL && sym->ts.type != BT_CLASS)
10006 build_init_assign (sym, init);
10007 sym->attr.referenced = 1;
10010 /* Build an initializer for a local integer, real, complex, logical, or
10011 character variable, based on the command line flags finit-local-zero,
10012 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10013 null if the symbol should not have a default initialization. */
10015 build_default_init_expr (gfc_symbol *sym)
10018 gfc_expr *init_expr;
10021 /* These symbols should never have a default initialization. */
10022 if (sym->attr.allocatable
10023 || sym->attr.external
10025 || sym->attr.pointer
10026 || sym->attr.in_equivalence
10027 || sym->attr.in_common
10030 || sym->attr.cray_pointee
10031 || sym->attr.cray_pointer)
10034 /* Now we'll try to build an initializer expression. */
10035 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
10036 &sym->declared_at);
10038 /* We will only initialize integers, reals, complex, logicals, and
10039 characters, and only if the corresponding command-line flags
10040 were set. Otherwise, we free init_expr and return null. */
10041 switch (sym->ts.type)
10044 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
10045 mpz_set_si (init_expr->value.integer,
10046 gfc_option.flag_init_integer_value);
10049 gfc_free_expr (init_expr);
10055 switch (gfc_option.flag_init_real)
10057 case GFC_INIT_REAL_SNAN:
10058 init_expr->is_snan = 1;
10059 /* Fall through. */
10060 case GFC_INIT_REAL_NAN:
10061 mpfr_set_nan (init_expr->value.real);
10064 case GFC_INIT_REAL_INF:
10065 mpfr_set_inf (init_expr->value.real, 1);
10068 case GFC_INIT_REAL_NEG_INF:
10069 mpfr_set_inf (init_expr->value.real, -1);
10072 case GFC_INIT_REAL_ZERO:
10073 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
10077 gfc_free_expr (init_expr);
10084 switch (gfc_option.flag_init_real)
10086 case GFC_INIT_REAL_SNAN:
10087 init_expr->is_snan = 1;
10088 /* Fall through. */
10089 case GFC_INIT_REAL_NAN:
10090 mpfr_set_nan (mpc_realref (init_expr->value.complex));
10091 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
10094 case GFC_INIT_REAL_INF:
10095 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
10096 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
10099 case GFC_INIT_REAL_NEG_INF:
10100 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
10101 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
10104 case GFC_INIT_REAL_ZERO:
10105 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
10109 gfc_free_expr (init_expr);
10116 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
10117 init_expr->value.logical = 0;
10118 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
10119 init_expr->value.logical = 1;
10122 gfc_free_expr (init_expr);
10128 /* For characters, the length must be constant in order to
10129 create a default initializer. */
10130 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
10131 && sym->ts.u.cl->length
10132 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
10134 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
10135 init_expr->value.character.length = char_len;
10136 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
10137 for (i = 0; i < char_len; i++)
10138 init_expr->value.character.string[i]
10139 = (unsigned char) gfc_option.flag_init_character_value;
10143 gfc_free_expr (init_expr);
10149 gfc_free_expr (init_expr);
10155 /* Add an initialization expression to a local variable. */
10157 apply_default_init_local (gfc_symbol *sym)
10159 gfc_expr *init = NULL;
10161 /* The symbol should be a variable or a function return value. */
10162 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
10163 || (sym->attr.function && sym->result != sym))
10166 /* Try to build the initializer expression. If we can't initialize
10167 this symbol, then init will be NULL. */
10168 init = build_default_init_expr (sym);
10172 /* For saved variables, we don't want to add an initializer at
10173 function entry, so we just add a static initializer. */
10174 if (sym->attr.save || sym->ns->save_all
10175 || gfc_option.flag_max_stack_var_size == 0)
10177 /* Don't clobber an existing initializer! */
10178 gcc_assert (sym->value == NULL);
10183 build_init_assign (sym, init);
10187 /* Resolution of common features of flavors variable and procedure. */
10190 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
10192 gfc_array_spec *as;
10194 /* Avoid double diagnostics for function result symbols. */
10195 if ((sym->result || sym->attr.result) && !sym->attr.dummy
10196 && (sym->ns != gfc_current_ns))
10199 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
10200 as = CLASS_DATA (sym)->as;
10204 /* Constraints on deferred shape variable. */
10205 if (as == NULL || as->type != AS_DEFERRED)
10207 bool pointer, allocatable, dimension;
10209 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
10211 pointer = CLASS_DATA (sym)->attr.class_pointer;
10212 allocatable = CLASS_DATA (sym)->attr.allocatable;
10213 dimension = CLASS_DATA (sym)->attr.dimension;
10217 pointer = sym->attr.pointer;
10218 allocatable = sym->attr.allocatable;
10219 dimension = sym->attr.dimension;
10226 gfc_error ("Allocatable array '%s' at %L must have "
10227 "a deferred shape", sym->name, &sym->declared_at);
10230 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
10231 "may not be ALLOCATABLE", sym->name,
10232 &sym->declared_at) == FAILURE)
10236 if (pointer && dimension)
10238 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
10239 sym->name, &sym->declared_at);
10245 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
10246 && sym->ts.type != BT_CLASS && !sym->assoc)
10248 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10249 sym->name, &sym->declared_at);
10254 /* Constraints on polymorphic variables. */
10255 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
10258 if (sym->attr.class_ok
10259 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
10261 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10262 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
10263 &sym->declared_at);
10268 /* Assume that use associated symbols were checked in the module ns.
10269 Class-variables that are associate-names are also something special
10270 and excepted from the test. */
10271 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
10273 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10274 "or pointer", sym->name, &sym->declared_at);
10283 /* Additional checks for symbols with flavor variable and derived
10284 type. To be called from resolve_fl_variable. */
10287 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
10289 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
10291 /* Check to see if a derived type is blocked from being host
10292 associated by the presence of another class I symbol in the same
10293 namespace. 14.6.1.3 of the standard and the discussion on
10294 comp.lang.fortran. */
10295 if (sym->ns != sym->ts.u.derived->ns
10296 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
10299 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
10300 if (s && s->attr.generic)
10301 s = gfc_find_dt_in_generic (s);
10302 if (s && s->attr.flavor != FL_DERIVED)
10304 gfc_error ("The type '%s' cannot be host associated at %L "
10305 "because it is blocked by an incompatible object "
10306 "of the same name declared at %L",
10307 sym->ts.u.derived->name, &sym->declared_at,
10313 /* 4th constraint in section 11.3: "If an object of a type for which
10314 component-initialization is specified (R429) appears in the
10315 specification-part of a module and does not have the ALLOCATABLE
10316 or POINTER attribute, the object shall have the SAVE attribute."
10318 The check for initializers is performed with
10319 gfc_has_default_initializer because gfc_default_initializer generates
10320 a hidden default for allocatable components. */
10321 if (!(sym->value || no_init_flag) && sym->ns->proc_name
10322 && sym->ns->proc_name->attr.flavor == FL_MODULE
10323 && !sym->ns->save_all && !sym->attr.save
10324 && !sym->attr.pointer && !sym->attr.allocatable
10325 && gfc_has_default_initializer (sym->ts.u.derived)
10326 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
10327 "module variable '%s' at %L, needed due to "
10328 "the default initialization", sym->name,
10329 &sym->declared_at) == FAILURE)
10332 /* Assign default initializer. */
10333 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
10334 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
10336 sym->value = gfc_default_initializer (&sym->ts);
10343 /* Resolve symbols with flavor variable. */
10346 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
10348 int no_init_flag, automatic_flag;
10350 const char *auto_save_msg;
10352 auto_save_msg = "Automatic object '%s' at %L cannot have the "
10355 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10358 /* Set this flag to check that variables are parameters of all entries.
10359 This check is effected by the call to gfc_resolve_expr through
10360 is_non_constant_shape_array. */
10361 specification_expr = 1;
10363 if (sym->ns->proc_name
10364 && (sym->ns->proc_name->attr.flavor == FL_MODULE
10365 || sym->ns->proc_name->attr.is_main_program)
10366 && !sym->attr.use_assoc
10367 && !sym->attr.allocatable
10368 && !sym->attr.pointer
10369 && is_non_constant_shape_array (sym))
10371 /* The shape of a main program or module array needs to be
10373 gfc_error ("The module or main program array '%s' at %L must "
10374 "have constant shape", sym->name, &sym->declared_at);
10375 specification_expr = 0;
10379 /* Constraints on deferred type parameter. */
10380 if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
10382 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10383 "requires either the pointer or allocatable attribute",
10384 sym->name, &sym->declared_at);
10388 if (sym->ts.type == BT_CHARACTER)
10390 /* Make sure that character string variables with assumed length are
10391 dummy arguments. */
10392 e = sym->ts.u.cl->length;
10393 if (e == NULL && !sym->attr.dummy && !sym->attr.result
10394 && !sym->ts.deferred)
10396 gfc_error ("Entity with assumed character length at %L must be a "
10397 "dummy argument or a PARAMETER", &sym->declared_at);
10401 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
10403 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10407 if (!gfc_is_constant_expr (e)
10408 && !(e->expr_type == EXPR_VARIABLE
10409 && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
10411 if (!sym->attr.use_assoc && sym->ns->proc_name
10412 && (sym->ns->proc_name->attr.flavor == FL_MODULE
10413 || sym->ns->proc_name->attr.is_main_program))
10415 gfc_error ("'%s' at %L must have constant character length "
10416 "in this context", sym->name, &sym->declared_at);
10419 if (sym->attr.in_common)
10421 gfc_error ("COMMON variable '%s' at %L must have constant "
10422 "character length", sym->name, &sym->declared_at);
10428 if (sym->value == NULL && sym->attr.referenced)
10429 apply_default_init_local (sym); /* Try to apply a default initialization. */
10431 /* Determine if the symbol may not have an initializer. */
10432 no_init_flag = automatic_flag = 0;
10433 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
10434 || sym->attr.intrinsic || sym->attr.result)
10436 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
10437 && is_non_constant_shape_array (sym))
10439 no_init_flag = automatic_flag = 1;
10441 /* Also, they must not have the SAVE attribute.
10442 SAVE_IMPLICIT is checked below. */
10443 if (sym->as && sym->attr.codimension)
10445 int corank = sym->as->corank;
10446 sym->as->corank = 0;
10447 no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
10448 sym->as->corank = corank;
10450 if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
10452 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10457 /* Ensure that any initializer is simplified. */
10459 gfc_simplify_expr (sym->value, 1);
10461 /* Reject illegal initializers. */
10462 if (!sym->mark && sym->value)
10464 if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
10465 && CLASS_DATA (sym)->attr.allocatable))
10466 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10467 sym->name, &sym->declared_at);
10468 else if (sym->attr.external)
10469 gfc_error ("External '%s' at %L cannot have an initializer",
10470 sym->name, &sym->declared_at);
10471 else if (sym->attr.dummy
10472 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
10473 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10474 sym->name, &sym->declared_at);
10475 else if (sym->attr.intrinsic)
10476 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10477 sym->name, &sym->declared_at);
10478 else if (sym->attr.result)
10479 gfc_error ("Function result '%s' at %L cannot have an initializer",
10480 sym->name, &sym->declared_at);
10481 else if (automatic_flag)
10482 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10483 sym->name, &sym->declared_at);
10485 goto no_init_error;
10490 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
10491 return resolve_fl_variable_derived (sym, no_init_flag);
10497 /* Resolve a procedure. */
10500 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
10502 gfc_formal_arglist *arg;
10504 if (sym->attr.function
10505 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10508 if (sym->ts.type == BT_CHARACTER)
10510 gfc_charlen *cl = sym->ts.u.cl;
10512 if (cl && cl->length && gfc_is_constant_expr (cl->length)
10513 && resolve_charlen (cl) == FAILURE)
10516 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
10517 && sym->attr.proc == PROC_ST_FUNCTION)
10519 gfc_error ("Character-valued statement function '%s' at %L must "
10520 "have constant length", sym->name, &sym->declared_at);
10525 /* Ensure that derived type for are not of a private type. Internal
10526 module procedures are excluded by 2.2.3.3 - i.e., they are not
10527 externally accessible and can access all the objects accessible in
10529 if (!(sym->ns->parent
10530 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
10531 && gfc_check_symbol_access (sym))
10533 gfc_interface *iface;
10535 for (arg = sym->formal; arg; arg = arg->next)
10538 && arg->sym->ts.type == BT_DERIVED
10539 && !arg->sym->ts.u.derived->attr.use_assoc
10540 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10541 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
10542 "PRIVATE type and cannot be a dummy argument"
10543 " of '%s', which is PUBLIC at %L",
10544 arg->sym->name, sym->name, &sym->declared_at)
10547 /* Stop this message from recurring. */
10548 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10553 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10554 PRIVATE to the containing module. */
10555 for (iface = sym->generic; iface; iface = iface->next)
10557 for (arg = iface->sym->formal; arg; arg = arg->next)
10560 && arg->sym->ts.type == BT_DERIVED
10561 && !arg->sym->ts.u.derived->attr.use_assoc
10562 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10563 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10564 "'%s' in PUBLIC interface '%s' at %L "
10565 "takes dummy arguments of '%s' which is "
10566 "PRIVATE", iface->sym->name, sym->name,
10567 &iface->sym->declared_at,
10568 gfc_typename (&arg->sym->ts)) == FAILURE)
10570 /* Stop this message from recurring. */
10571 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10577 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10578 PRIVATE to the containing module. */
10579 for (iface = sym->generic; iface; iface = iface->next)
10581 for (arg = iface->sym->formal; arg; arg = arg->next)
10584 && arg->sym->ts.type == BT_DERIVED
10585 && !arg->sym->ts.u.derived->attr.use_assoc
10586 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10587 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10588 "'%s' in PUBLIC interface '%s' at %L "
10589 "takes dummy arguments of '%s' which is "
10590 "PRIVATE", iface->sym->name, sym->name,
10591 &iface->sym->declared_at,
10592 gfc_typename (&arg->sym->ts)) == FAILURE)
10594 /* Stop this message from recurring. */
10595 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10602 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10603 && !sym->attr.proc_pointer)
10605 gfc_error ("Function '%s' at %L cannot have an initializer",
10606 sym->name, &sym->declared_at);
10610 /* An external symbol may not have an initializer because it is taken to be
10611 a procedure. Exception: Procedure Pointers. */
10612 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10614 gfc_error ("External object '%s' at %L may not have an initializer",
10615 sym->name, &sym->declared_at);
10619 /* An elemental function is required to return a scalar 12.7.1 */
10620 if (sym->attr.elemental && sym->attr.function && sym->as)
10622 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10623 "result", sym->name, &sym->declared_at);
10624 /* Reset so that the error only occurs once. */
10625 sym->attr.elemental = 0;
10629 if (sym->attr.proc == PROC_ST_FUNCTION
10630 && (sym->attr.allocatable || sym->attr.pointer))
10632 gfc_error ("Statement function '%s' at %L may not have pointer or "
10633 "allocatable attribute", sym->name, &sym->declared_at);
10637 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10638 char-len-param shall not be array-valued, pointer-valued, recursive
10639 or pure. ....snip... A character value of * may only be used in the
10640 following ways: (i) Dummy arg of procedure - dummy associates with
10641 actual length; (ii) To declare a named constant; or (iii) External
10642 function - but length must be declared in calling scoping unit. */
10643 if (sym->attr.function
10644 && sym->ts.type == BT_CHARACTER
10645 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10647 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10648 || (sym->attr.recursive) || (sym->attr.pure))
10650 if (sym->as && sym->as->rank)
10651 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10652 "array-valued", sym->name, &sym->declared_at);
10654 if (sym->attr.pointer)
10655 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10656 "pointer-valued", sym->name, &sym->declared_at);
10658 if (sym->attr.pure)
10659 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10660 "pure", sym->name, &sym->declared_at);
10662 if (sym->attr.recursive)
10663 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10664 "recursive", sym->name, &sym->declared_at);
10669 /* Appendix B.2 of the standard. Contained functions give an
10670 error anyway. Fixed-form is likely to be F77/legacy. Deferred
10671 character length is an F2003 feature. */
10672 if (!sym->attr.contained
10673 && gfc_current_form != FORM_FIXED
10674 && !sym->ts.deferred)
10675 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10676 "CHARACTER(*) function '%s' at %L",
10677 sym->name, &sym->declared_at);
10680 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10682 gfc_formal_arglist *curr_arg;
10683 int has_non_interop_arg = 0;
10685 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10686 sym->common_block) == FAILURE)
10688 /* Clear these to prevent looking at them again if there was an
10690 sym->attr.is_bind_c = 0;
10691 sym->attr.is_c_interop = 0;
10692 sym->ts.is_c_interop = 0;
10696 /* So far, no errors have been found. */
10697 sym->attr.is_c_interop = 1;
10698 sym->ts.is_c_interop = 1;
10701 curr_arg = sym->formal;
10702 while (curr_arg != NULL)
10704 /* Skip implicitly typed dummy args here. */
10705 if (curr_arg->sym->attr.implicit_type == 0)
10706 if (gfc_verify_c_interop_param (curr_arg->sym) == FAILURE)
10707 /* If something is found to fail, record the fact so we
10708 can mark the symbol for the procedure as not being
10709 BIND(C) to try and prevent multiple errors being
10711 has_non_interop_arg = 1;
10713 curr_arg = curr_arg->next;
10716 /* See if any of the arguments were not interoperable and if so, clear
10717 the procedure symbol to prevent duplicate error messages. */
10718 if (has_non_interop_arg != 0)
10720 sym->attr.is_c_interop = 0;
10721 sym->ts.is_c_interop = 0;
10722 sym->attr.is_bind_c = 0;
10726 if (!sym->attr.proc_pointer)
10728 if (sym->attr.save == SAVE_EXPLICIT)
10730 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10731 "in '%s' at %L", sym->name, &sym->declared_at);
10734 if (sym->attr.intent)
10736 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10737 "in '%s' at %L", sym->name, &sym->declared_at);
10740 if (sym->attr.subroutine && sym->attr.result)
10742 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10743 "in '%s' at %L", sym->name, &sym->declared_at);
10746 if (sym->attr.external && sym->attr.function
10747 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10748 || sym->attr.contained))
10750 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10751 "in '%s' at %L", sym->name, &sym->declared_at);
10754 if (strcmp ("ppr@", sym->name) == 0)
10756 gfc_error ("Procedure pointer result '%s' at %L "
10757 "is missing the pointer attribute",
10758 sym->ns->proc_name->name, &sym->declared_at);
10767 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10768 been defined and we now know their defined arguments, check that they fulfill
10769 the requirements of the standard for procedures used as finalizers. */
10772 gfc_resolve_finalizers (gfc_symbol* derived)
10774 gfc_finalizer* list;
10775 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10776 gfc_try result = SUCCESS;
10777 bool seen_scalar = false;
10779 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10782 /* Walk over the list of finalizer-procedures, check them, and if any one
10783 does not fit in with the standard's definition, print an error and remove
10784 it from the list. */
10785 prev_link = &derived->f2k_derived->finalizers;
10786 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10792 /* Skip this finalizer if we already resolved it. */
10793 if (list->proc_tree)
10795 prev_link = &(list->next);
10799 /* Check this exists and is a SUBROUTINE. */
10800 if (!list->proc_sym->attr.subroutine)
10802 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10803 list->proc_sym->name, &list->where);
10807 /* We should have exactly one argument. */
10808 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10810 gfc_error ("FINAL procedure at %L must have exactly one argument",
10814 arg = list->proc_sym->formal->sym;
10816 /* This argument must be of our type. */
10817 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10819 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10820 &arg->declared_at, derived->name);
10824 /* It must neither be a pointer nor allocatable nor optional. */
10825 if (arg->attr.pointer)
10827 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10828 &arg->declared_at);
10831 if (arg->attr.allocatable)
10833 gfc_error ("Argument of FINAL procedure at %L must not be"
10834 " ALLOCATABLE", &arg->declared_at);
10837 if (arg->attr.optional)
10839 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10840 &arg->declared_at);
10844 /* It must not be INTENT(OUT). */
10845 if (arg->attr.intent == INTENT_OUT)
10847 gfc_error ("Argument of FINAL procedure at %L must not be"
10848 " INTENT(OUT)", &arg->declared_at);
10852 /* Warn if the procedure is non-scalar and not assumed shape. */
10853 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10854 && arg->as->type != AS_ASSUMED_SHAPE)
10855 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10856 " shape argument", &arg->declared_at);
10858 /* Check that it does not match in kind and rank with a FINAL procedure
10859 defined earlier. To really loop over the *earlier* declarations,
10860 we need to walk the tail of the list as new ones were pushed at the
10862 /* TODO: Handle kind parameters once they are implemented. */
10863 my_rank = (arg->as ? arg->as->rank : 0);
10864 for (i = list->next; i; i = i->next)
10866 /* Argument list might be empty; that is an error signalled earlier,
10867 but we nevertheless continued resolving. */
10868 if (i->proc_sym->formal)
10870 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10871 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10872 if (i_rank == my_rank)
10874 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10875 " rank (%d) as '%s'",
10876 list->proc_sym->name, &list->where, my_rank,
10877 i->proc_sym->name);
10883 /* Is this the/a scalar finalizer procedure? */
10884 if (!arg->as || arg->as->rank == 0)
10885 seen_scalar = true;
10887 /* Find the symtree for this procedure. */
10888 gcc_assert (!list->proc_tree);
10889 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10891 prev_link = &list->next;
10894 /* Remove wrong nodes immediately from the list so we don't risk any
10895 troubles in the future when they might fail later expectations. */
10899 *prev_link = list->next;
10900 gfc_free_finalizer (i);
10903 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10904 were nodes in the list, must have been for arrays. It is surely a good
10905 idea to have a scalar version there if there's something to finalize. */
10906 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10907 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10908 " defined at %L, suggest also scalar one",
10909 derived->name, &derived->declared_at);
10911 /* TODO: Remove this error when finalization is finished. */
10912 gfc_error ("Finalization at %L is not yet implemented",
10913 &derived->declared_at);
10919 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10922 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10923 const char* generic_name, locus where)
10928 gcc_assert (t1->specific && t2->specific);
10929 gcc_assert (!t1->specific->is_generic);
10930 gcc_assert (!t2->specific->is_generic);
10932 sym1 = t1->specific->u.specific->n.sym;
10933 sym2 = t2->specific->u.specific->n.sym;
10938 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10939 if (sym1->attr.subroutine != sym2->attr.subroutine
10940 || sym1->attr.function != sym2->attr.function)
10942 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10943 " GENERIC '%s' at %L",
10944 sym1->name, sym2->name, generic_name, &where);
10948 /* Compare the interfaces. */
10949 if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
10951 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10952 sym1->name, sym2->name, generic_name, &where);
10960 /* Worker function for resolving a generic procedure binding; this is used to
10961 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10963 The difference between those cases is finding possible inherited bindings
10964 that are overridden, as one has to look for them in tb_sym_root,
10965 tb_uop_root or tb_op, respectively. Thus the caller must already find
10966 the super-type and set p->overridden correctly. */
10969 resolve_tb_generic_targets (gfc_symbol* super_type,
10970 gfc_typebound_proc* p, const char* name)
10972 gfc_tbp_generic* target;
10973 gfc_symtree* first_target;
10974 gfc_symtree* inherited;
10976 gcc_assert (p && p->is_generic);
10978 /* Try to find the specific bindings for the symtrees in our target-list. */
10979 gcc_assert (p->u.generic);
10980 for (target = p->u.generic; target; target = target->next)
10981 if (!target->specific)
10983 gfc_typebound_proc* overridden_tbp;
10984 gfc_tbp_generic* g;
10985 const char* target_name;
10987 target_name = target->specific_st->name;
10989 /* Defined for this type directly. */
10990 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
10992 target->specific = target->specific_st->n.tb;
10993 goto specific_found;
10996 /* Look for an inherited specific binding. */
10999 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
11004 gcc_assert (inherited->n.tb);
11005 target->specific = inherited->n.tb;
11006 goto specific_found;
11010 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11011 " at %L", target_name, name, &p->where);
11014 /* Once we've found the specific binding, check it is not ambiguous with
11015 other specifics already found or inherited for the same GENERIC. */
11017 gcc_assert (target->specific);
11019 /* This must really be a specific binding! */
11020 if (target->specific->is_generic)
11022 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11023 " '%s' is GENERIC, too", name, &p->where, target_name);
11027 /* Check those already resolved on this type directly. */
11028 for (g = p->u.generic; g; g = g->next)
11029 if (g != target && g->specific
11030 && check_generic_tbp_ambiguity (target, g, name, p->where)
11034 /* Check for ambiguity with inherited specific targets. */
11035 for (overridden_tbp = p->overridden; overridden_tbp;
11036 overridden_tbp = overridden_tbp->overridden)
11037 if (overridden_tbp->is_generic)
11039 for (g = overridden_tbp->u.generic; g; g = g->next)
11041 gcc_assert (g->specific);
11042 if (check_generic_tbp_ambiguity (target, g,
11043 name, p->where) == FAILURE)
11049 /* If we attempt to "overwrite" a specific binding, this is an error. */
11050 if (p->overridden && !p->overridden->is_generic)
11052 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11053 " the same name", name, &p->where);
11057 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11058 all must have the same attributes here. */
11059 first_target = p->u.generic->specific->u.specific;
11060 gcc_assert (first_target);
11061 p->subroutine = first_target->n.sym->attr.subroutine;
11062 p->function = first_target->n.sym->attr.function;
11068 /* Resolve a GENERIC procedure binding for a derived type. */
11071 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
11073 gfc_symbol* super_type;
11075 /* Find the overridden binding if any. */
11076 st->n.tb->overridden = NULL;
11077 super_type = gfc_get_derived_super_type (derived);
11080 gfc_symtree* overridden;
11081 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
11084 if (overridden && overridden->n.tb)
11085 st->n.tb->overridden = overridden->n.tb;
11088 /* Resolve using worker function. */
11089 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
11093 /* Retrieve the target-procedure of an operator binding and do some checks in
11094 common for intrinsic and user-defined type-bound operators. */
11097 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
11099 gfc_symbol* target_proc;
11101 gcc_assert (target->specific && !target->specific->is_generic);
11102 target_proc = target->specific->u.specific->n.sym;
11103 gcc_assert (target_proc);
11105 /* All operator bindings must have a passed-object dummy argument. */
11106 if (target->specific->nopass)
11108 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
11112 return target_proc;
11116 /* Resolve a type-bound intrinsic operator. */
11119 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
11120 gfc_typebound_proc* p)
11122 gfc_symbol* super_type;
11123 gfc_tbp_generic* target;
11125 /* If there's already an error here, do nothing (but don't fail again). */
11129 /* Operators should always be GENERIC bindings. */
11130 gcc_assert (p->is_generic);
11132 /* Look for an overridden binding. */
11133 super_type = gfc_get_derived_super_type (derived);
11134 if (super_type && super_type->f2k_derived)
11135 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
11138 p->overridden = NULL;
11140 /* Resolve general GENERIC properties using worker function. */
11141 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
11144 /* Check the targets to be procedures of correct interface. */
11145 for (target = p->u.generic; target; target = target->next)
11147 gfc_symbol* target_proc;
11149 target_proc = get_checked_tb_operator_target (target, p->where);
11153 if (!gfc_check_operator_interface (target_proc, op, p->where))
11165 /* Resolve a type-bound user operator (tree-walker callback). */
11167 static gfc_symbol* resolve_bindings_derived;
11168 static gfc_try resolve_bindings_result;
11170 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
11173 resolve_typebound_user_op (gfc_symtree* stree)
11175 gfc_symbol* super_type;
11176 gfc_tbp_generic* target;
11178 gcc_assert (stree && stree->n.tb);
11180 if (stree->n.tb->error)
11183 /* Operators should always be GENERIC bindings. */
11184 gcc_assert (stree->n.tb->is_generic);
11186 /* Find overridden procedure, if any. */
11187 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11188 if (super_type && super_type->f2k_derived)
11190 gfc_symtree* overridden;
11191 overridden = gfc_find_typebound_user_op (super_type, NULL,
11192 stree->name, true, NULL);
11194 if (overridden && overridden->n.tb)
11195 stree->n.tb->overridden = overridden->n.tb;
11198 stree->n.tb->overridden = NULL;
11200 /* Resolve basically using worker function. */
11201 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
11205 /* Check the targets to be functions of correct interface. */
11206 for (target = stree->n.tb->u.generic; target; target = target->next)
11208 gfc_symbol* target_proc;
11210 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
11214 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
11221 resolve_bindings_result = FAILURE;
11222 stree->n.tb->error = 1;
11226 /* Resolve the type-bound procedures for a derived type. */
11229 resolve_typebound_procedure (gfc_symtree* stree)
11233 gfc_symbol* me_arg;
11234 gfc_symbol* super_type;
11235 gfc_component* comp;
11237 gcc_assert (stree);
11239 /* Undefined specific symbol from GENERIC target definition. */
11243 if (stree->n.tb->error)
11246 /* If this is a GENERIC binding, use that routine. */
11247 if (stree->n.tb->is_generic)
11249 if (resolve_typebound_generic (resolve_bindings_derived, stree)
11255 /* Get the target-procedure to check it. */
11256 gcc_assert (!stree->n.tb->is_generic);
11257 gcc_assert (stree->n.tb->u.specific);
11258 proc = stree->n.tb->u.specific->n.sym;
11259 where = stree->n.tb->where;
11261 /* Default access should already be resolved from the parser. */
11262 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
11264 /* It should be a module procedure or an external procedure with explicit
11265 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
11266 if ((!proc->attr.subroutine && !proc->attr.function)
11267 || (proc->attr.proc != PROC_MODULE
11268 && proc->attr.if_source != IFSRC_IFBODY)
11269 || (proc->attr.abstract && !stree->n.tb->deferred))
11271 gfc_error ("'%s' must be a module procedure or an external procedure with"
11272 " an explicit interface at %L", proc->name, &where);
11275 stree->n.tb->subroutine = proc->attr.subroutine;
11276 stree->n.tb->function = proc->attr.function;
11278 /* Find the super-type of the current derived type. We could do this once and
11279 store in a global if speed is needed, but as long as not I believe this is
11280 more readable and clearer. */
11281 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11283 /* If PASS, resolve and check arguments if not already resolved / loaded
11284 from a .mod file. */
11285 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
11287 if (stree->n.tb->pass_arg)
11289 gfc_formal_arglist* i;
11291 /* If an explicit passing argument name is given, walk the arg-list
11292 and look for it. */
11295 stree->n.tb->pass_arg_num = 1;
11296 for (i = proc->formal; i; i = i->next)
11298 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
11303 ++stree->n.tb->pass_arg_num;
11308 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11310 proc->name, stree->n.tb->pass_arg, &where,
11311 stree->n.tb->pass_arg);
11317 /* Otherwise, take the first one; there should in fact be at least
11319 stree->n.tb->pass_arg_num = 1;
11322 gfc_error ("Procedure '%s' with PASS at %L must have at"
11323 " least one argument", proc->name, &where);
11326 me_arg = proc->formal->sym;
11329 /* Now check that the argument-type matches and the passed-object
11330 dummy argument is generally fine. */
11332 gcc_assert (me_arg);
11334 if (me_arg->ts.type != BT_CLASS)
11336 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11337 " at %L", proc->name, &where);
11341 if (CLASS_DATA (me_arg)->ts.u.derived
11342 != resolve_bindings_derived)
11344 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11345 " the derived-type '%s'", me_arg->name, proc->name,
11346 me_arg->name, &where, resolve_bindings_derived->name);
11350 gcc_assert (me_arg->ts.type == BT_CLASS);
11351 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
11353 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11354 " scalar", proc->name, &where);
11357 if (CLASS_DATA (me_arg)->attr.allocatable)
11359 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11360 " be ALLOCATABLE", proc->name, &where);
11363 if (CLASS_DATA (me_arg)->attr.class_pointer)
11365 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11366 " be POINTER", proc->name, &where);
11371 /* If we are extending some type, check that we don't override a procedure
11372 flagged NON_OVERRIDABLE. */
11373 stree->n.tb->overridden = NULL;
11376 gfc_symtree* overridden;
11377 overridden = gfc_find_typebound_proc (super_type, NULL,
11378 stree->name, true, NULL);
11382 if (overridden->n.tb)
11383 stree->n.tb->overridden = overridden->n.tb;
11385 if (gfc_check_typebound_override (stree, overridden) == FAILURE)
11390 /* See if there's a name collision with a component directly in this type. */
11391 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11392 if (!strcmp (comp->name, stree->name))
11394 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11396 stree->name, &where, resolve_bindings_derived->name);
11400 /* Try to find a name collision with an inherited component. */
11401 if (super_type && gfc_find_component (super_type, stree->name, true, true))
11403 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11404 " component of '%s'",
11405 stree->name, &where, resolve_bindings_derived->name);
11409 stree->n.tb->error = 0;
11413 resolve_bindings_result = FAILURE;
11414 stree->n.tb->error = 1;
11419 resolve_typebound_procedures (gfc_symbol* derived)
11422 gfc_symbol* super_type;
11424 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11427 super_type = gfc_get_derived_super_type (derived);
11429 resolve_typebound_procedures (super_type);
11431 resolve_bindings_derived = derived;
11432 resolve_bindings_result = SUCCESS;
11434 /* Make sure the vtab has been generated. */
11435 gfc_find_derived_vtab (derived);
11437 if (derived->f2k_derived->tb_sym_root)
11438 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11439 &resolve_typebound_procedure);
11441 if (derived->f2k_derived->tb_uop_root)
11442 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11443 &resolve_typebound_user_op);
11445 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11447 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11448 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11450 resolve_bindings_result = FAILURE;
11453 return resolve_bindings_result;
11457 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11458 to give all identical derived types the same backend_decl. */
11460 add_dt_to_dt_list (gfc_symbol *derived)
11462 gfc_dt_list *dt_list;
11464 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11465 if (derived == dt_list->derived)
11468 dt_list = gfc_get_dt_list ();
11469 dt_list->next = gfc_derived_types;
11470 dt_list->derived = derived;
11471 gfc_derived_types = dt_list;
11475 /* Ensure that a derived-type is really not abstract, meaning that every
11476 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11479 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11484 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11486 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11489 if (st->n.tb && st->n.tb->deferred)
11491 gfc_symtree* overriding;
11492 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11495 gcc_assert (overriding->n.tb);
11496 if (overriding->n.tb->deferred)
11498 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11499 " '%s' is DEFERRED and not overridden",
11500 sub->name, &sub->declared_at, st->name);
11509 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11511 /* The algorithm used here is to recursively travel up the ancestry of sub
11512 and for each ancestor-type, check all bindings. If any of them is
11513 DEFERRED, look it up starting from sub and see if the found (overriding)
11514 binding is not DEFERRED.
11515 This is not the most efficient way to do this, but it should be ok and is
11516 clearer than something sophisticated. */
11518 gcc_assert (ancestor && !sub->attr.abstract);
11520 if (!ancestor->attr.abstract)
11523 /* Walk bindings of this ancestor. */
11524 if (ancestor->f2k_derived)
11527 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11532 /* Find next ancestor type and recurse on it. */
11533 ancestor = gfc_get_derived_super_type (ancestor);
11535 return ensure_not_abstract (sub, ancestor);
11541 /* Resolve the components of a derived type. This does not have to wait until
11542 resolution stage, but can be done as soon as the dt declaration has been
11546 resolve_fl_derived0 (gfc_symbol *sym)
11548 gfc_symbol* super_type;
11551 super_type = gfc_get_derived_super_type (sym);
11554 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11556 gfc_error ("As extending type '%s' at %L has a coarray component, "
11557 "parent type '%s' shall also have one", sym->name,
11558 &sym->declared_at, super_type->name);
11562 /* Ensure the extended type gets resolved before we do. */
11563 if (super_type && resolve_fl_derived0 (super_type) == FAILURE)
11566 /* An ABSTRACT type must be extensible. */
11567 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11569 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11570 sym->name, &sym->declared_at);
11574 c = (sym->attr.is_class) ? sym->components->ts.u.derived->components
11577 for ( ; c != NULL; c = c->next)
11579 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
11580 if (c->ts.type == BT_CHARACTER && c->ts.deferred)
11582 gfc_error ("Deferred-length character component '%s' at %L is not "
11583 "yet supported", c->name, &c->loc);
11588 if ((!sym->attr.is_class || c != sym->components)
11589 && c->attr.codimension
11590 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11592 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11593 "deferred shape", c->name, &c->loc);
11598 if (c->attr.codimension && c->ts.type == BT_DERIVED
11599 && c->ts.u.derived->ts.is_iso_c)
11601 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11602 "shall not be a coarray", c->name, &c->loc);
11607 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11608 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11609 || c->attr.allocatable))
11611 gfc_error ("Component '%s' at %L with coarray component "
11612 "shall be a nonpointer, nonallocatable scalar",
11618 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11620 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11621 "is not an array pointer", c->name, &c->loc);
11625 if (c->attr.proc_pointer && c->ts.interface)
11627 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11628 gfc_error ("Interface '%s', used by procedure pointer component "
11629 "'%s' at %L, is declared in a later PROCEDURE statement",
11630 c->ts.interface->name, c->name, &c->loc);
11632 /* Get the attributes from the interface (now resolved). */
11633 if (c->ts.interface->attr.if_source
11634 || c->ts.interface->attr.intrinsic)
11636 gfc_symbol *ifc = c->ts.interface;
11638 if (ifc->formal && !ifc->formal_ns)
11639 resolve_symbol (ifc);
11641 if (ifc->attr.intrinsic)
11642 resolve_intrinsic (ifc, &ifc->declared_at);
11646 c->ts = ifc->result->ts;
11647 c->attr.allocatable = ifc->result->attr.allocatable;
11648 c->attr.pointer = ifc->result->attr.pointer;
11649 c->attr.dimension = ifc->result->attr.dimension;
11650 c->as = gfc_copy_array_spec (ifc->result->as);
11655 c->attr.allocatable = ifc->attr.allocatable;
11656 c->attr.pointer = ifc->attr.pointer;
11657 c->attr.dimension = ifc->attr.dimension;
11658 c->as = gfc_copy_array_spec (ifc->as);
11660 c->ts.interface = ifc;
11661 c->attr.function = ifc->attr.function;
11662 c->attr.subroutine = ifc->attr.subroutine;
11663 gfc_copy_formal_args_ppc (c, ifc);
11665 c->attr.pure = ifc->attr.pure;
11666 c->attr.elemental = ifc->attr.elemental;
11667 c->attr.recursive = ifc->attr.recursive;
11668 c->attr.always_explicit = ifc->attr.always_explicit;
11669 c->attr.ext_attr |= ifc->attr.ext_attr;
11670 /* Replace symbols in array spec. */
11674 for (i = 0; i < c->as->rank; i++)
11676 gfc_expr_replace_comp (c->as->lower[i], c);
11677 gfc_expr_replace_comp (c->as->upper[i], c);
11680 /* Copy char length. */
11681 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11683 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11684 gfc_expr_replace_comp (cl->length, c);
11685 if (cl->length && !cl->resolved
11686 && gfc_resolve_expr (cl->length) == FAILURE)
11691 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11693 gfc_error ("Interface '%s' of procedure pointer component "
11694 "'%s' at %L must be explicit", c->ts.interface->name,
11699 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11701 /* Since PPCs are not implicitly typed, a PPC without an explicit
11702 interface must be a subroutine. */
11703 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11706 /* Procedure pointer components: Check PASS arg. */
11707 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11708 && !sym->attr.vtype)
11710 gfc_symbol* me_arg;
11712 if (c->tb->pass_arg)
11714 gfc_formal_arglist* i;
11716 /* If an explicit passing argument name is given, walk the arg-list
11717 and look for it. */
11720 c->tb->pass_arg_num = 1;
11721 for (i = c->formal; i; i = i->next)
11723 if (!strcmp (i->sym->name, c->tb->pass_arg))
11728 c->tb->pass_arg_num++;
11733 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11734 "at %L has no argument '%s'", c->name,
11735 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11742 /* Otherwise, take the first one; there should in fact be at least
11744 c->tb->pass_arg_num = 1;
11747 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11748 "must have at least one argument",
11753 me_arg = c->formal->sym;
11756 /* Now check that the argument-type matches. */
11757 gcc_assert (me_arg);
11758 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11759 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11760 || (me_arg->ts.type == BT_CLASS
11761 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11763 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11764 " the derived type '%s'", me_arg->name, c->name,
11765 me_arg->name, &c->loc, sym->name);
11770 /* Check for C453. */
11771 if (me_arg->attr.dimension)
11773 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11774 "must be scalar", me_arg->name, c->name, me_arg->name,
11780 if (me_arg->attr.pointer)
11782 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11783 "may not have the POINTER attribute", me_arg->name,
11784 c->name, me_arg->name, &c->loc);
11789 if (me_arg->attr.allocatable)
11791 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11792 "may not be ALLOCATABLE", me_arg->name, c->name,
11793 me_arg->name, &c->loc);
11798 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11799 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11800 " at %L", c->name, &c->loc);
11804 /* Check type-spec if this is not the parent-type component. */
11805 if (((sym->attr.is_class
11806 && (!sym->components->ts.u.derived->attr.extension
11807 || c != sym->components->ts.u.derived->components))
11808 || (!sym->attr.is_class
11809 && (!sym->attr.extension || c != sym->components)))
11810 && !sym->attr.vtype
11811 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11814 /* If this type is an extension, set the accessibility of the parent
11817 && ((sym->attr.is_class
11818 && c == sym->components->ts.u.derived->components)
11819 || (!sym->attr.is_class && c == sym->components))
11820 && strcmp (super_type->name, c->name) == 0)
11821 c->attr.access = super_type->attr.access;
11823 /* If this type is an extension, see if this component has the same name
11824 as an inherited type-bound procedure. */
11825 if (super_type && !sym->attr.is_class
11826 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11828 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11829 " inherited type-bound procedure",
11830 c->name, sym->name, &c->loc);
11834 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
11835 && !c->ts.deferred)
11837 if (c->ts.u.cl->length == NULL
11838 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11839 || !gfc_is_constant_expr (c->ts.u.cl->length))
11841 gfc_error ("Character length of component '%s' needs to "
11842 "be a constant specification expression at %L",
11844 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11849 if (c->ts.type == BT_CHARACTER && c->ts.deferred
11850 && !c->attr.pointer && !c->attr.allocatable)
11852 gfc_error ("Character component '%s' of '%s' at %L with deferred "
11853 "length must be a POINTER or ALLOCATABLE",
11854 c->name, sym->name, &c->loc);
11858 if (c->ts.type == BT_DERIVED
11859 && sym->component_access != ACCESS_PRIVATE
11860 && gfc_check_symbol_access (sym)
11861 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11862 && !c->ts.u.derived->attr.use_assoc
11863 && !gfc_check_symbol_access (c->ts.u.derived)
11864 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11865 "is a PRIVATE type and cannot be a component of "
11866 "'%s', which is PUBLIC at %L", c->name,
11867 sym->name, &sym->declared_at) == FAILURE)
11870 if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
11872 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11873 "type %s", c->name, &c->loc, sym->name);
11877 if (sym->attr.sequence)
11879 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11881 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11882 "not have the SEQUENCE attribute",
11883 c->ts.u.derived->name, &sym->declared_at);
11888 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
11889 c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
11890 else if (c->ts.type == BT_CLASS && c->attr.class_ok
11891 && CLASS_DATA (c)->ts.u.derived->attr.generic)
11892 CLASS_DATA (c)->ts.u.derived
11893 = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
11895 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
11896 && c->attr.pointer && c->ts.u.derived->components == NULL
11897 && !c->ts.u.derived->attr.zero_comp)
11899 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11900 "that has not been declared", c->name, sym->name,
11905 if (c->ts.type == BT_CLASS && c->attr.class_ok
11906 && CLASS_DATA (c)->attr.class_pointer
11907 && CLASS_DATA (c)->ts.u.derived->components == NULL
11908 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11910 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11911 "that has not been declared", c->name, sym->name,
11917 if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE
11918 && (!c->attr.class_ok
11919 || !(CLASS_DATA (c)->attr.class_pointer
11920 || CLASS_DATA (c)->attr.allocatable)))
11922 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11923 "or pointer", c->name, &c->loc);
11927 /* Ensure that all the derived type components are put on the
11928 derived type list; even in formal namespaces, where derived type
11929 pointer components might not have been declared. */
11930 if (c->ts.type == BT_DERIVED
11932 && c->ts.u.derived->components
11934 && sym != c->ts.u.derived)
11935 add_dt_to_dt_list (c->ts.u.derived);
11937 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11938 || c->attr.proc_pointer
11939 || c->attr.allocatable)) == FAILURE)
11943 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11944 all DEFERRED bindings are overridden. */
11945 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11946 && !sym->attr.is_class
11947 && ensure_not_abstract (sym, super_type) == FAILURE)
11950 /* Add derived type to the derived type list. */
11951 add_dt_to_dt_list (sym);
11957 /* The following procedure does the full resolution of a derived type,
11958 including resolution of all type-bound procedures (if present). In contrast
11959 to 'resolve_fl_derived0' this can only be done after the module has been
11960 parsed completely. */
11963 resolve_fl_derived (gfc_symbol *sym)
11965 gfc_symbol *gen_dt = NULL;
11967 if (!sym->attr.is_class)
11968 gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
11969 if (gen_dt && gen_dt->generic && gen_dt->generic->next
11970 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Generic name '%s' of "
11971 "function '%s' at %L being the same name as derived "
11972 "type at %L", sym->name,
11973 gen_dt->generic->sym == sym
11974 ? gen_dt->generic->next->sym->name
11975 : gen_dt->generic->sym->name,
11976 gen_dt->generic->sym == sym
11977 ? &gen_dt->generic->next->sym->declared_at
11978 : &gen_dt->generic->sym->declared_at,
11979 &sym->declared_at) == FAILURE)
11982 if (sym->attr.is_class && sym->ts.u.derived == NULL)
11984 /* Fix up incomplete CLASS symbols. */
11985 gfc_component *data = gfc_find_component (sym, "_data", true, true);
11986 gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
11987 if (vptr->ts.u.derived == NULL)
11989 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
11991 vptr->ts.u.derived = vtab->ts.u.derived;
11995 if (resolve_fl_derived0 (sym) == FAILURE)
11998 /* Resolve the type-bound procedures. */
11999 if (resolve_typebound_procedures (sym) == FAILURE)
12002 /* Resolve the finalizer procedures. */
12003 if (gfc_resolve_finalizers (sym) == FAILURE)
12011 resolve_fl_namelist (gfc_symbol *sym)
12016 for (nl = sym->namelist; nl; nl = nl->next)
12018 /* Check again, the check in match only works if NAMELIST comes
12020 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
12022 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12023 "allowed", nl->sym->name, sym->name, &sym->declared_at);
12027 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
12028 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
12029 "object '%s' with assumed shape in namelist "
12030 "'%s' at %L", nl->sym->name, sym->name,
12031 &sym->declared_at) == FAILURE)
12034 if (is_non_constant_shape_array (nl->sym)
12035 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
12036 "object '%s' with nonconstant shape in namelist "
12037 "'%s' at %L", nl->sym->name, sym->name,
12038 &sym->declared_at) == FAILURE)
12041 if (nl->sym->ts.type == BT_CHARACTER
12042 && (nl->sym->ts.u.cl->length == NULL
12043 || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
12044 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
12045 "'%s' with nonconstant character length in "
12046 "namelist '%s' at %L", nl->sym->name, sym->name,
12047 &sym->declared_at) == FAILURE)
12050 /* FIXME: Once UDDTIO is implemented, the following can be
12052 if (nl->sym->ts.type == BT_CLASS)
12054 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12055 "polymorphic and requires a defined input/output "
12056 "procedure", nl->sym->name, sym->name, &sym->declared_at);
12060 if (nl->sym->ts.type == BT_DERIVED
12061 && (nl->sym->ts.u.derived->attr.alloc_comp
12062 || nl->sym->ts.u.derived->attr.pointer_comp))
12064 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
12065 "'%s' in namelist '%s' at %L with ALLOCATABLE "
12066 "or POINTER components", nl->sym->name,
12067 sym->name, &sym->declared_at) == FAILURE)
12070 /* FIXME: Once UDDTIO is implemented, the following can be
12072 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12073 "ALLOCATABLE or POINTER components and thus requires "
12074 "a defined input/output procedure", nl->sym->name,
12075 sym->name, &sym->declared_at);
12080 /* Reject PRIVATE objects in a PUBLIC namelist. */
12081 if (gfc_check_symbol_access (sym))
12083 for (nl = sym->namelist; nl; nl = nl->next)
12085 if (!nl->sym->attr.use_assoc
12086 && !is_sym_host_assoc (nl->sym, sym->ns)
12087 && !gfc_check_symbol_access (nl->sym))
12089 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12090 "cannot be member of PUBLIC namelist '%s' at %L",
12091 nl->sym->name, sym->name, &sym->declared_at);
12095 /* Types with private components that came here by USE-association. */
12096 if (nl->sym->ts.type == BT_DERIVED
12097 && derived_inaccessible (nl->sym->ts.u.derived))
12099 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12100 "components and cannot be member of namelist '%s' at %L",
12101 nl->sym->name, sym->name, &sym->declared_at);
12105 /* Types with private components that are defined in the same module. */
12106 if (nl->sym->ts.type == BT_DERIVED
12107 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
12108 && nl->sym->ts.u.derived->attr.private_comp)
12110 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12111 "cannot be a member of PUBLIC namelist '%s' at %L",
12112 nl->sym->name, sym->name, &sym->declared_at);
12119 /* 14.1.2 A module or internal procedure represent local entities
12120 of the same type as a namelist member and so are not allowed. */
12121 for (nl = sym->namelist; nl; nl = nl->next)
12123 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
12126 if (nl->sym->attr.function && nl->sym == nl->sym->result)
12127 if ((nl->sym == sym->ns->proc_name)
12129 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
12133 if (nl->sym && nl->sym->name)
12134 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
12135 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
12137 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12138 "attribute in '%s' at %L", nlsym->name,
12139 &sym->declared_at);
12149 resolve_fl_parameter (gfc_symbol *sym)
12151 /* A parameter array's shape needs to be constant. */
12152 if (sym->as != NULL
12153 && (sym->as->type == AS_DEFERRED
12154 || is_non_constant_shape_array (sym)))
12156 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12157 "or of deferred shape", sym->name, &sym->declared_at);
12161 /* Make sure a parameter that has been implicitly typed still
12162 matches the implicit type, since PARAMETER statements can precede
12163 IMPLICIT statements. */
12164 if (sym->attr.implicit_type
12165 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
12168 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12169 "later IMPLICIT type", sym->name, &sym->declared_at);
12173 /* Make sure the types of derived parameters are consistent. This
12174 type checking is deferred until resolution because the type may
12175 refer to a derived type from the host. */
12176 if (sym->ts.type == BT_DERIVED && sym->value
12177 && !gfc_compare_types (&sym->ts, &sym->value->ts))
12179 gfc_error ("Incompatible derived type in PARAMETER at %L",
12180 &sym->value->where);
12187 /* Do anything necessary to resolve a symbol. Right now, we just
12188 assume that an otherwise unknown symbol is a variable. This sort
12189 of thing commonly happens for symbols in module. */
12192 resolve_symbol (gfc_symbol *sym)
12194 int check_constant, mp_flag;
12195 gfc_symtree *symtree;
12196 gfc_symtree *this_symtree;
12199 symbol_attribute class_attr;
12200 gfc_array_spec *as;
12202 if (sym->attr.flavor == FL_UNKNOWN)
12205 /* If we find that a flavorless symbol is an interface in one of the
12206 parent namespaces, find its symtree in this namespace, free the
12207 symbol and set the symtree to point to the interface symbol. */
12208 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
12210 symtree = gfc_find_symtree (ns->sym_root, sym->name);
12211 if (symtree && (symtree->n.sym->generic ||
12212 (symtree->n.sym->attr.flavor == FL_PROCEDURE
12213 && sym->ns->construct_entities)))
12215 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
12217 gfc_release_symbol (sym);
12218 symtree->n.sym->refs++;
12219 this_symtree->n.sym = symtree->n.sym;
12224 /* Otherwise give it a flavor according to such attributes as
12226 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
12227 sym->attr.flavor = FL_VARIABLE;
12230 sym->attr.flavor = FL_PROCEDURE;
12231 if (sym->attr.dimension)
12232 sym->attr.function = 1;
12236 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
12237 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
12239 if (sym->attr.procedure && sym->ts.interface
12240 && sym->attr.if_source != IFSRC_DECL
12241 && resolve_procedure_interface (sym) == FAILURE)
12244 if (sym->attr.is_protected && !sym->attr.proc_pointer
12245 && (sym->attr.procedure || sym->attr.external))
12247 if (sym->attr.external)
12248 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12249 "at %L", &sym->declared_at);
12251 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12252 "at %L", &sym->declared_at);
12257 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
12260 /* Symbols that are module procedures with results (functions) have
12261 the types and array specification copied for type checking in
12262 procedures that call them, as well as for saving to a module
12263 file. These symbols can't stand the scrutiny that their results
12265 mp_flag = (sym->result != NULL && sym->result != sym);
12267 /* Make sure that the intrinsic is consistent with its internal
12268 representation. This needs to be done before assigning a default
12269 type to avoid spurious warnings. */
12270 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
12271 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
12274 /* Resolve associate names. */
12276 resolve_assoc_var (sym, true);
12278 /* Assign default type to symbols that need one and don't have one. */
12279 if (sym->ts.type == BT_UNKNOWN)
12281 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
12283 gfc_set_default_type (sym, 1, NULL);
12286 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
12287 && !sym->attr.function && !sym->attr.subroutine
12288 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
12289 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
12291 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
12293 /* The specific case of an external procedure should emit an error
12294 in the case that there is no implicit type. */
12296 gfc_set_default_type (sym, sym->attr.external, NULL);
12299 /* Result may be in another namespace. */
12300 resolve_symbol (sym->result);
12302 if (!sym->result->attr.proc_pointer)
12304 sym->ts = sym->result->ts;
12305 sym->as = gfc_copy_array_spec (sym->result->as);
12306 sym->attr.dimension = sym->result->attr.dimension;
12307 sym->attr.pointer = sym->result->attr.pointer;
12308 sym->attr.allocatable = sym->result->attr.allocatable;
12309 sym->attr.contiguous = sym->result->attr.contiguous;
12314 else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
12315 gfc_resolve_array_spec (sym->result->as, false);
12317 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
12319 as = CLASS_DATA (sym)->as;
12320 class_attr = CLASS_DATA (sym)->attr;
12321 class_attr.pointer = class_attr.class_pointer;
12325 class_attr = sym->attr;
12330 if (sym->attr.contiguous
12331 && (!class_attr.dimension
12332 || (as->type != AS_ASSUMED_SHAPE && !class_attr.pointer)))
12334 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12335 "array pointer or an assumed-shape array", sym->name,
12336 &sym->declared_at);
12340 /* Assumed size arrays and assumed shape arrays must be dummy
12341 arguments. Array-spec's of implied-shape should have been resolved to
12342 AS_EXPLICIT already. */
12346 gcc_assert (as->type != AS_IMPLIED_SHAPE);
12347 if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
12348 || as->type == AS_ASSUMED_SHAPE)
12349 && sym->attr.dummy == 0)
12351 if (as->type == AS_ASSUMED_SIZE)
12352 gfc_error ("Assumed size array at %L must be a dummy argument",
12353 &sym->declared_at);
12355 gfc_error ("Assumed shape array at %L must be a dummy argument",
12356 &sym->declared_at);
12361 /* Make sure symbols with known intent or optional are really dummy
12362 variable. Because of ENTRY statement, this has to be deferred
12363 until resolution time. */
12365 if (!sym->attr.dummy
12366 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
12368 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
12372 if (sym->attr.value && !sym->attr.dummy)
12374 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12375 "it is not a dummy argument", sym->name, &sym->declared_at);
12379 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
12381 gfc_charlen *cl = sym->ts.u.cl;
12382 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
12384 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12385 "attribute must have constant length",
12386 sym->name, &sym->declared_at);
12390 if (sym->ts.is_c_interop
12391 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
12393 gfc_error ("C interoperable character dummy variable '%s' at %L "
12394 "with VALUE attribute must have length one",
12395 sym->name, &sym->declared_at);
12400 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
12401 && sym->ts.u.derived->attr.generic)
12403 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
12404 if (!sym->ts.u.derived)
12406 gfc_error ("The derived type '%s' at %L is of type '%s', "
12407 "which has not been defined", sym->name,
12408 &sym->declared_at, sym->ts.u.derived->name);
12409 sym->ts.type = BT_UNKNOWN;
12414 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12415 do this for something that was implicitly typed because that is handled
12416 in gfc_set_default_type. Handle dummy arguments and procedure
12417 definitions separately. Also, anything that is use associated is not
12418 handled here but instead is handled in the module it is declared in.
12419 Finally, derived type definitions are allowed to be BIND(C) since that
12420 only implies that they're interoperable, and they are checked fully for
12421 interoperability when a variable is declared of that type. */
12422 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
12423 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
12424 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
12426 gfc_try t = SUCCESS;
12428 /* First, make sure the variable is declared at the
12429 module-level scope (J3/04-007, Section 15.3). */
12430 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
12431 sym->attr.in_common == 0)
12433 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12434 "is neither a COMMON block nor declared at the "
12435 "module level scope", sym->name, &(sym->declared_at));
12438 else if (sym->common_head != NULL)
12440 t = verify_com_block_vars_c_interop (sym->common_head);
12444 /* If type() declaration, we need to verify that the components
12445 of the given type are all C interoperable, etc. */
12446 if (sym->ts.type == BT_DERIVED &&
12447 sym->ts.u.derived->attr.is_c_interop != 1)
12449 /* Make sure the user marked the derived type as BIND(C). If
12450 not, call the verify routine. This could print an error
12451 for the derived type more than once if multiple variables
12452 of that type are declared. */
12453 if (sym->ts.u.derived->attr.is_bind_c != 1)
12454 verify_bind_c_derived_type (sym->ts.u.derived);
12458 /* Verify the variable itself as C interoperable if it
12459 is BIND(C). It is not possible for this to succeed if
12460 the verify_bind_c_derived_type failed, so don't have to handle
12461 any error returned by verify_bind_c_derived_type. */
12462 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
12463 sym->common_block);
12468 /* clear the is_bind_c flag to prevent reporting errors more than
12469 once if something failed. */
12470 sym->attr.is_bind_c = 0;
12475 /* If a derived type symbol has reached this point, without its
12476 type being declared, we have an error. Notice that most
12477 conditions that produce undefined derived types have already
12478 been dealt with. However, the likes of:
12479 implicit type(t) (t) ..... call foo (t) will get us here if
12480 the type is not declared in the scope of the implicit
12481 statement. Change the type to BT_UNKNOWN, both because it is so
12482 and to prevent an ICE. */
12483 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
12484 && sym->ts.u.derived->components == NULL
12485 && !sym->ts.u.derived->attr.zero_comp)
12487 gfc_error ("The derived type '%s' at %L is of type '%s', "
12488 "which has not been defined", sym->name,
12489 &sym->declared_at, sym->ts.u.derived->name);
12490 sym->ts.type = BT_UNKNOWN;
12494 /* Make sure that the derived type has been resolved and that the
12495 derived type is visible in the symbol's namespace, if it is a
12496 module function and is not PRIVATE. */
12497 if (sym->ts.type == BT_DERIVED
12498 && sym->ts.u.derived->attr.use_assoc
12499 && sym->ns->proc_name
12500 && sym->ns->proc_name->attr.flavor == FL_MODULE
12501 && resolve_fl_derived (sym->ts.u.derived) == FAILURE)
12504 /* Unless the derived-type declaration is use associated, Fortran 95
12505 does not allow public entries of private derived types.
12506 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12507 161 in 95-006r3. */
12508 if (sym->ts.type == BT_DERIVED
12509 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12510 && !sym->ts.u.derived->attr.use_assoc
12511 && gfc_check_symbol_access (sym)
12512 && !gfc_check_symbol_access (sym->ts.u.derived)
12513 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12514 "of PRIVATE derived type '%s'",
12515 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12516 : "variable", sym->name, &sym->declared_at,
12517 sym->ts.u.derived->name) == FAILURE)
12520 /* F2008, C1302. */
12521 if (sym->ts.type == BT_DERIVED
12522 && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
12523 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
12524 || sym->ts.u.derived->attr.lock_comp)
12525 && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
12527 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
12528 "type LOCK_TYPE must be a coarray", sym->name,
12529 &sym->declared_at);
12533 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12534 default initialization is defined (5.1.2.4.4). */
12535 if (sym->ts.type == BT_DERIVED
12537 && sym->attr.intent == INTENT_OUT
12539 && sym->as->type == AS_ASSUMED_SIZE)
12541 for (c = sym->ts.u.derived->components; c; c = c->next)
12543 if (c->initializer)
12545 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12546 "ASSUMED SIZE and so cannot have a default initializer",
12547 sym->name, &sym->declared_at);
12554 if (sym->ts.type == BT_DERIVED && sym->attr.dummy
12555 && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
12557 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
12558 "INTENT(OUT)", sym->name, &sym->declared_at);
12563 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12564 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12565 && CLASS_DATA (sym)->attr.coarray_comp))
12566 || class_attr.codimension)
12567 && (sym->attr.result || sym->result == sym))
12569 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12570 "a coarray component", sym->name, &sym->declared_at);
12575 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12576 && sym->ts.u.derived->ts.is_iso_c)
12578 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12579 "shall not be a coarray", sym->name, &sym->declared_at);
12584 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12585 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12586 && CLASS_DATA (sym)->attr.coarray_comp))
12587 && (class_attr.codimension || class_attr.pointer || class_attr.dimension
12588 || class_attr.allocatable))
12590 gfc_error ("Variable '%s' at %L with coarray component "
12591 "shall be a nonpointer, nonallocatable scalar",
12592 sym->name, &sym->declared_at);
12596 /* F2008, C526. The function-result case was handled above. */
12597 if (class_attr.codimension
12598 && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
12599 || sym->attr.select_type_temporary
12600 || sym->ns->save_all
12601 || sym->ns->proc_name->attr.flavor == FL_MODULE
12602 || sym->ns->proc_name->attr.is_main_program
12603 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12605 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
12606 "nor a dummy argument", sym->name, &sym->declared_at);
12610 else if (class_attr.codimension && !sym->attr.select_type_temporary
12611 && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
12613 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12614 "deferred shape", sym->name, &sym->declared_at);
12617 else if (class_attr.codimension && class_attr.allocatable && as
12618 && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
12620 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12621 "deferred shape", sym->name, &sym->declared_at);
12626 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12627 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12628 && CLASS_DATA (sym)->attr.coarray_comp))
12629 || (class_attr.codimension && class_attr.allocatable))
12630 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12632 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12633 "allocatable coarray or have coarray components",
12634 sym->name, &sym->declared_at);
12638 if (class_attr.codimension && sym->attr.dummy
12639 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12641 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12642 "procedure '%s'", sym->name, &sym->declared_at,
12643 sym->ns->proc_name->name);
12647 switch (sym->attr.flavor)
12650 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12655 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12660 if (resolve_fl_namelist (sym) == FAILURE)
12665 if (resolve_fl_parameter (sym) == FAILURE)
12673 /* Resolve array specifier. Check as well some constraints
12674 on COMMON blocks. */
12676 check_constant = sym->attr.in_common && !sym->attr.pointer;
12678 /* Set the formal_arg_flag so that check_conflict will not throw
12679 an error for host associated variables in the specification
12680 expression for an array_valued function. */
12681 if (sym->attr.function && sym->as)
12682 formal_arg_flag = 1;
12684 gfc_resolve_array_spec (sym->as, check_constant);
12686 formal_arg_flag = 0;
12688 /* Resolve formal namespaces. */
12689 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12690 && !sym->attr.contained && !sym->attr.intrinsic)
12691 gfc_resolve (sym->formal_ns);
12693 /* Make sure the formal namespace is present. */
12694 if (sym->formal && !sym->formal_ns)
12696 gfc_formal_arglist *formal = sym->formal;
12697 while (formal && !formal->sym)
12698 formal = formal->next;
12702 sym->formal_ns = formal->sym->ns;
12703 sym->formal_ns->refs++;
12707 /* Check threadprivate restrictions. */
12708 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12709 && (!sym->attr.in_common
12710 && sym->module == NULL
12711 && (sym->ns->proc_name == NULL
12712 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12713 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12715 /* If we have come this far we can apply default-initializers, as
12716 described in 14.7.5, to those variables that have not already
12717 been assigned one. */
12718 if (sym->ts.type == BT_DERIVED
12719 && sym->ns == gfc_current_ns
12721 && !sym->attr.allocatable
12722 && !sym->attr.alloc_comp)
12724 symbol_attribute *a = &sym->attr;
12726 if ((!a->save && !a->dummy && !a->pointer
12727 && !a->in_common && !a->use_assoc
12728 && (a->referenced || a->result)
12729 && !(a->function && sym != sym->result))
12730 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12731 apply_default_init (sym);
12734 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
12735 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
12736 && !CLASS_DATA (sym)->attr.class_pointer
12737 && !CLASS_DATA (sym)->attr.allocatable)
12738 apply_default_init (sym);
12740 /* If this symbol has a type-spec, check it. */
12741 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12742 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12743 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12749 /************* Resolve DATA statements *************/
12753 gfc_data_value *vnode;
12759 /* Advance the values structure to point to the next value in the data list. */
12762 next_data_value (void)
12764 while (mpz_cmp_ui (values.left, 0) == 0)
12767 if (values.vnode->next == NULL)
12770 values.vnode = values.vnode->next;
12771 mpz_set (values.left, values.vnode->repeat);
12779 check_data_variable (gfc_data_variable *var, locus *where)
12785 ar_type mark = AR_UNKNOWN;
12787 mpz_t section_index[GFC_MAX_DIMENSIONS];
12793 if (gfc_resolve_expr (var->expr) == FAILURE)
12797 mpz_init_set_si (offset, 0);
12800 if (e->expr_type != EXPR_VARIABLE)
12801 gfc_internal_error ("check_data_variable(): Bad expression");
12803 sym = e->symtree->n.sym;
12805 if (sym->ns->is_block_data && !sym->attr.in_common)
12807 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12808 sym->name, &sym->declared_at);
12811 if (e->ref == NULL && sym->as)
12813 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12814 " declaration", sym->name, where);
12818 has_pointer = sym->attr.pointer;
12820 if (gfc_is_coindexed (e))
12822 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name,
12827 for (ref = e->ref; ref; ref = ref->next)
12829 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12833 && ref->type == REF_ARRAY
12834 && ref->u.ar.type != AR_FULL)
12836 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12837 "be a full array", sym->name, where);
12842 if (e->rank == 0 || has_pointer)
12844 mpz_init_set_ui (size, 1);
12851 /* Find the array section reference. */
12852 for (ref = e->ref; ref; ref = ref->next)
12854 if (ref->type != REF_ARRAY)
12856 if (ref->u.ar.type == AR_ELEMENT)
12862 /* Set marks according to the reference pattern. */
12863 switch (ref->u.ar.type)
12871 /* Get the start position of array section. */
12872 gfc_get_section_index (ar, section_index, &offset);
12877 gcc_unreachable ();
12880 if (gfc_array_size (e, &size) == FAILURE)
12882 gfc_error ("Nonconstant array section at %L in DATA statement",
12884 mpz_clear (offset);
12891 while (mpz_cmp_ui (size, 0) > 0)
12893 if (next_data_value () == FAILURE)
12895 gfc_error ("DATA statement at %L has more variables than values",
12901 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12905 /* If we have more than one element left in the repeat count,
12906 and we have more than one element left in the target variable,
12907 then create a range assignment. */
12908 /* FIXME: Only done for full arrays for now, since array sections
12910 if (mark == AR_FULL && ref && ref->next == NULL
12911 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12915 if (mpz_cmp (size, values.left) >= 0)
12917 mpz_init_set (range, values.left);
12918 mpz_sub (size, size, values.left);
12919 mpz_set_ui (values.left, 0);
12923 mpz_init_set (range, size);
12924 mpz_sub (values.left, values.left, size);
12925 mpz_set_ui (size, 0);
12928 t = gfc_assign_data_value (var->expr, values.vnode->expr,
12931 mpz_add (offset, offset, range);
12938 /* Assign initial value to symbol. */
12941 mpz_sub_ui (values.left, values.left, 1);
12942 mpz_sub_ui (size, size, 1);
12944 t = gfc_assign_data_value (var->expr, values.vnode->expr,
12949 if (mark == AR_FULL)
12950 mpz_add_ui (offset, offset, 1);
12952 /* Modify the array section indexes and recalculate the offset
12953 for next element. */
12954 else if (mark == AR_SECTION)
12955 gfc_advance_section (section_index, ar, &offset);
12959 if (mark == AR_SECTION)
12961 for (i = 0; i < ar->dimen; i++)
12962 mpz_clear (section_index[i]);
12966 mpz_clear (offset);
12972 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
12974 /* Iterate over a list of elements in a DATA statement. */
12977 traverse_data_list (gfc_data_variable *var, locus *where)
12980 iterator_stack frame;
12981 gfc_expr *e, *start, *end, *step;
12982 gfc_try retval = SUCCESS;
12984 mpz_init (frame.value);
12987 start = gfc_copy_expr (var->iter.start);
12988 end = gfc_copy_expr (var->iter.end);
12989 step = gfc_copy_expr (var->iter.step);
12991 if (gfc_simplify_expr (start, 1) == FAILURE
12992 || start->expr_type != EXPR_CONSTANT)
12994 gfc_error ("start of implied-do loop at %L could not be "
12995 "simplified to a constant value", &start->where);
12999 if (gfc_simplify_expr (end, 1) == FAILURE
13000 || end->expr_type != EXPR_CONSTANT)
13002 gfc_error ("end of implied-do loop at %L could not be "
13003 "simplified to a constant value", &start->where);
13007 if (gfc_simplify_expr (step, 1) == FAILURE
13008 || step->expr_type != EXPR_CONSTANT)
13010 gfc_error ("step of implied-do loop at %L could not be "
13011 "simplified to a constant value", &start->where);
13016 mpz_set (trip, end->value.integer);
13017 mpz_sub (trip, trip, start->value.integer);
13018 mpz_add (trip, trip, step->value.integer);
13020 mpz_div (trip, trip, step->value.integer);
13022 mpz_set (frame.value, start->value.integer);
13024 frame.prev = iter_stack;
13025 frame.variable = var->iter.var->symtree;
13026 iter_stack = &frame;
13028 while (mpz_cmp_ui (trip, 0) > 0)
13030 if (traverse_data_var (var->list, where) == FAILURE)
13036 e = gfc_copy_expr (var->expr);
13037 if (gfc_simplify_expr (e, 1) == FAILURE)
13044 mpz_add (frame.value, frame.value, step->value.integer);
13046 mpz_sub_ui (trip, trip, 1);
13050 mpz_clear (frame.value);
13053 gfc_free_expr (start);
13054 gfc_free_expr (end);
13055 gfc_free_expr (step);
13057 iter_stack = frame.prev;
13062 /* Type resolve variables in the variable list of a DATA statement. */
13065 traverse_data_var (gfc_data_variable *var, locus *where)
13069 for (; var; var = var->next)
13071 if (var->expr == NULL)
13072 t = traverse_data_list (var, where);
13074 t = check_data_variable (var, where);
13084 /* Resolve the expressions and iterators associated with a data statement.
13085 This is separate from the assignment checking because data lists should
13086 only be resolved once. */
13089 resolve_data_variables (gfc_data_variable *d)
13091 for (; d; d = d->next)
13093 if (d->list == NULL)
13095 if (gfc_resolve_expr (d->expr) == FAILURE)
13100 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
13103 if (resolve_data_variables (d->list) == FAILURE)
13112 /* Resolve a single DATA statement. We implement this by storing a pointer to
13113 the value list into static variables, and then recursively traversing the
13114 variables list, expanding iterators and such. */
13117 resolve_data (gfc_data *d)
13120 if (resolve_data_variables (d->var) == FAILURE)
13123 values.vnode = d->value;
13124 if (d->value == NULL)
13125 mpz_set_ui (values.left, 0);
13127 mpz_set (values.left, d->value->repeat);
13129 if (traverse_data_var (d->var, &d->where) == FAILURE)
13132 /* At this point, we better not have any values left. */
13134 if (next_data_value () == SUCCESS)
13135 gfc_error ("DATA statement at %L has more values than variables",
13140 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13141 accessed by host or use association, is a dummy argument to a pure function,
13142 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13143 is storage associated with any such variable, shall not be used in the
13144 following contexts: (clients of this function). */
13146 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13147 procedure. Returns zero if assignment is OK, nonzero if there is a
13150 gfc_impure_variable (gfc_symbol *sym)
13155 if (sym->attr.use_assoc || sym->attr.in_common)
13158 /* Check if the symbol's ns is inside the pure procedure. */
13159 for (ns = gfc_current_ns; ns; ns = ns->parent)
13163 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
13167 proc = sym->ns->proc_name;
13168 if (sym->attr.dummy && gfc_pure (proc)
13169 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
13171 proc->attr.function))
13174 /* TODO: Sort out what can be storage associated, if anything, and include
13175 it here. In principle equivalences should be scanned but it does not
13176 seem to be possible to storage associate an impure variable this way. */
13181 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13182 current namespace is inside a pure procedure. */
13185 gfc_pure (gfc_symbol *sym)
13187 symbol_attribute attr;
13192 /* Check if the current namespace or one of its parents
13193 belongs to a pure procedure. */
13194 for (ns = gfc_current_ns; ns; ns = ns->parent)
13196 sym = ns->proc_name;
13200 if (attr.flavor == FL_PROCEDURE && attr.pure)
13208 return attr.flavor == FL_PROCEDURE && attr.pure;
13212 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13213 checks if the current namespace is implicitly pure. Note that this
13214 function returns false for a PURE procedure. */
13217 gfc_implicit_pure (gfc_symbol *sym)
13223 /* Check if the current procedure is implicit_pure. Walk up
13224 the procedure list until we find a procedure. */
13225 for (ns = gfc_current_ns; ns; ns = ns->parent)
13227 sym = ns->proc_name;
13231 if (sym->attr.flavor == FL_PROCEDURE)
13236 return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
13237 && !sym->attr.pure;
13241 /* Test whether the current procedure is elemental or not. */
13244 gfc_elemental (gfc_symbol *sym)
13246 symbol_attribute attr;
13249 sym = gfc_current_ns->proc_name;
13254 return attr.flavor == FL_PROCEDURE && attr.elemental;
13258 /* Warn about unused labels. */
13261 warn_unused_fortran_label (gfc_st_label *label)
13266 warn_unused_fortran_label (label->left);
13268 if (label->defined == ST_LABEL_UNKNOWN)
13271 switch (label->referenced)
13273 case ST_LABEL_UNKNOWN:
13274 gfc_warning ("Label %d at %L defined but not used", label->value,
13278 case ST_LABEL_BAD_TARGET:
13279 gfc_warning ("Label %d at %L defined but cannot be used",
13280 label->value, &label->where);
13287 warn_unused_fortran_label (label->right);
13291 /* Returns the sequence type of a symbol or sequence. */
13294 sequence_type (gfc_typespec ts)
13303 if (ts.u.derived->components == NULL)
13304 return SEQ_NONDEFAULT;
13306 result = sequence_type (ts.u.derived->components->ts);
13307 for (c = ts.u.derived->components->next; c; c = c->next)
13308 if (sequence_type (c->ts) != result)
13314 if (ts.kind != gfc_default_character_kind)
13315 return SEQ_NONDEFAULT;
13317 return SEQ_CHARACTER;
13320 if (ts.kind != gfc_default_integer_kind)
13321 return SEQ_NONDEFAULT;
13323 return SEQ_NUMERIC;
13326 if (!(ts.kind == gfc_default_real_kind
13327 || ts.kind == gfc_default_double_kind))
13328 return SEQ_NONDEFAULT;
13330 return SEQ_NUMERIC;
13333 if (ts.kind != gfc_default_complex_kind)
13334 return SEQ_NONDEFAULT;
13336 return SEQ_NUMERIC;
13339 if (ts.kind != gfc_default_logical_kind)
13340 return SEQ_NONDEFAULT;
13342 return SEQ_NUMERIC;
13345 return SEQ_NONDEFAULT;
13350 /* Resolve derived type EQUIVALENCE object. */
13353 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
13355 gfc_component *c = derived->components;
13360 /* Shall not be an object of nonsequence derived type. */
13361 if (!derived->attr.sequence)
13363 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13364 "attribute to be an EQUIVALENCE object", sym->name,
13369 /* Shall not have allocatable components. */
13370 if (derived->attr.alloc_comp)
13372 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13373 "components to be an EQUIVALENCE object",sym->name,
13378 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
13380 gfc_error ("Derived type variable '%s' at %L with default "
13381 "initialization cannot be in EQUIVALENCE with a variable "
13382 "in COMMON", sym->name, &e->where);
13386 for (; c ; c = c->next)
13388 if (c->ts.type == BT_DERIVED
13389 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
13392 /* Shall not be an object of sequence derived type containing a pointer
13393 in the structure. */
13394 if (c->attr.pointer)
13396 gfc_error ("Derived type variable '%s' at %L with pointer "
13397 "component(s) cannot be an EQUIVALENCE object",
13398 sym->name, &e->where);
13406 /* Resolve equivalence object.
13407 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13408 an allocatable array, an object of nonsequence derived type, an object of
13409 sequence derived type containing a pointer at any level of component
13410 selection, an automatic object, a function name, an entry name, a result
13411 name, a named constant, a structure component, or a subobject of any of
13412 the preceding objects. A substring shall not have length zero. A
13413 derived type shall not have components with default initialization nor
13414 shall two objects of an equivalence group be initialized.
13415 Either all or none of the objects shall have an protected attribute.
13416 The simple constraints are done in symbol.c(check_conflict) and the rest
13417 are implemented here. */
13420 resolve_equivalence (gfc_equiv *eq)
13423 gfc_symbol *first_sym;
13426 locus *last_where = NULL;
13427 seq_type eq_type, last_eq_type;
13428 gfc_typespec *last_ts;
13429 int object, cnt_protected;
13432 last_ts = &eq->expr->symtree->n.sym->ts;
13434 first_sym = eq->expr->symtree->n.sym;
13438 for (object = 1; eq; eq = eq->eq, object++)
13442 e->ts = e->symtree->n.sym->ts;
13443 /* match_varspec might not know yet if it is seeing
13444 array reference or substring reference, as it doesn't
13446 if (e->ref && e->ref->type == REF_ARRAY)
13448 gfc_ref *ref = e->ref;
13449 sym = e->symtree->n.sym;
13451 if (sym->attr.dimension)
13453 ref->u.ar.as = sym->as;
13457 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13458 if (e->ts.type == BT_CHARACTER
13460 && ref->type == REF_ARRAY
13461 && ref->u.ar.dimen == 1
13462 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
13463 && ref->u.ar.stride[0] == NULL)
13465 gfc_expr *start = ref->u.ar.start[0];
13466 gfc_expr *end = ref->u.ar.end[0];
13469 /* Optimize away the (:) reference. */
13470 if (start == NULL && end == NULL)
13473 e->ref = ref->next;
13475 e->ref->next = ref->next;
13480 ref->type = REF_SUBSTRING;
13482 start = gfc_get_int_expr (gfc_default_integer_kind,
13484 ref->u.ss.start = start;
13485 if (end == NULL && e->ts.u.cl)
13486 end = gfc_copy_expr (e->ts.u.cl->length);
13487 ref->u.ss.end = end;
13488 ref->u.ss.length = e->ts.u.cl;
13495 /* Any further ref is an error. */
13498 gcc_assert (ref->type == REF_ARRAY);
13499 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13505 if (gfc_resolve_expr (e) == FAILURE)
13508 sym = e->symtree->n.sym;
13510 if (sym->attr.is_protected)
13512 if (cnt_protected > 0 && cnt_protected != object)
13514 gfc_error ("Either all or none of the objects in the "
13515 "EQUIVALENCE set at %L shall have the "
13516 "PROTECTED attribute",
13521 /* Shall not equivalence common block variables in a PURE procedure. */
13522 if (sym->ns->proc_name
13523 && sym->ns->proc_name->attr.pure
13524 && sym->attr.in_common)
13526 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13527 "object in the pure procedure '%s'",
13528 sym->name, &e->where, sym->ns->proc_name->name);
13532 /* Shall not be a named constant. */
13533 if (e->expr_type == EXPR_CONSTANT)
13535 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13536 "object", sym->name, &e->where);
13540 if (e->ts.type == BT_DERIVED
13541 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
13544 /* Check that the types correspond correctly:
13546 A numeric sequence structure may be equivalenced to another sequence
13547 structure, an object of default integer type, default real type, double
13548 precision real type, default logical type such that components of the
13549 structure ultimately only become associated to objects of the same
13550 kind. A character sequence structure may be equivalenced to an object
13551 of default character kind or another character sequence structure.
13552 Other objects may be equivalenced only to objects of the same type and
13553 kind parameters. */
13555 /* Identical types are unconditionally OK. */
13556 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
13557 goto identical_types;
13559 last_eq_type = sequence_type (*last_ts);
13560 eq_type = sequence_type (sym->ts);
13562 /* Since the pair of objects is not of the same type, mixed or
13563 non-default sequences can be rejected. */
13565 msg = "Sequence %s with mixed components in EQUIVALENCE "
13566 "statement at %L with different type objects";
13568 && last_eq_type == SEQ_MIXED
13569 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
13571 || (eq_type == SEQ_MIXED
13572 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13573 &e->where) == FAILURE))
13576 msg = "Non-default type object or sequence %s in EQUIVALENCE "
13577 "statement at %L with objects of different type";
13579 && last_eq_type == SEQ_NONDEFAULT
13580 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
13581 last_where) == FAILURE)
13582 || (eq_type == SEQ_NONDEFAULT
13583 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13584 &e->where) == FAILURE))
13587 msg ="Non-CHARACTER object '%s' in default CHARACTER "
13588 "EQUIVALENCE statement at %L";
13589 if (last_eq_type == SEQ_CHARACTER
13590 && eq_type != SEQ_CHARACTER
13591 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13592 &e->where) == FAILURE)
13595 msg ="Non-NUMERIC object '%s' in default NUMERIC "
13596 "EQUIVALENCE statement at %L";
13597 if (last_eq_type == SEQ_NUMERIC
13598 && eq_type != SEQ_NUMERIC
13599 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13600 &e->where) == FAILURE)
13605 last_where = &e->where;
13610 /* Shall not be an automatic array. */
13611 if (e->ref->type == REF_ARRAY
13612 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
13614 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13615 "an EQUIVALENCE object", sym->name, &e->where);
13622 /* Shall not be a structure component. */
13623 if (r->type == REF_COMPONENT)
13625 gfc_error ("Structure component '%s' at %L cannot be an "
13626 "EQUIVALENCE object",
13627 r->u.c.component->name, &e->where);
13631 /* A substring shall not have length zero. */
13632 if (r->type == REF_SUBSTRING)
13634 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13636 gfc_error ("Substring at %L has length zero",
13637 &r->u.ss.start->where);
13647 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13650 resolve_fntype (gfc_namespace *ns)
13652 gfc_entry_list *el;
13655 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13658 /* If there are any entries, ns->proc_name is the entry master
13659 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13661 sym = ns->entries->sym;
13663 sym = ns->proc_name;
13664 if (sym->result == sym
13665 && sym->ts.type == BT_UNKNOWN
13666 && gfc_set_default_type (sym, 0, NULL) == FAILURE
13667 && !sym->attr.untyped)
13669 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13670 sym->name, &sym->declared_at);
13671 sym->attr.untyped = 1;
13674 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13675 && !sym->attr.contained
13676 && !gfc_check_symbol_access (sym->ts.u.derived)
13677 && gfc_check_symbol_access (sym))
13679 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13680 "%L of PRIVATE type '%s'", sym->name,
13681 &sym->declared_at, sym->ts.u.derived->name);
13685 for (el = ns->entries->next; el; el = el->next)
13687 if (el->sym->result == el->sym
13688 && el->sym->ts.type == BT_UNKNOWN
13689 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13690 && !el->sym->attr.untyped)
13692 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13693 el->sym->name, &el->sym->declared_at);
13694 el->sym->attr.untyped = 1;
13700 /* 12.3.2.1.1 Defined operators. */
13703 check_uop_procedure (gfc_symbol *sym, locus where)
13705 gfc_formal_arglist *formal;
13707 if (!sym->attr.function)
13709 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13710 sym->name, &where);
13714 if (sym->ts.type == BT_CHARACTER
13715 && !(sym->ts.u.cl && sym->ts.u.cl->length)
13716 && !(sym->result && sym->result->ts.u.cl
13717 && sym->result->ts.u.cl->length))
13719 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13720 "character length", sym->name, &where);
13724 formal = sym->formal;
13725 if (!formal || !formal->sym)
13727 gfc_error ("User operator procedure '%s' at %L must have at least "
13728 "one argument", sym->name, &where);
13732 if (formal->sym->attr.intent != INTENT_IN)
13734 gfc_error ("First argument of operator interface at %L must be "
13735 "INTENT(IN)", &where);
13739 if (formal->sym->attr.optional)
13741 gfc_error ("First argument of operator interface at %L cannot be "
13742 "optional", &where);
13746 formal = formal->next;
13747 if (!formal || !formal->sym)
13750 if (formal->sym->attr.intent != INTENT_IN)
13752 gfc_error ("Second argument of operator interface at %L must be "
13753 "INTENT(IN)", &where);
13757 if (formal->sym->attr.optional)
13759 gfc_error ("Second argument of operator interface at %L cannot be "
13760 "optional", &where);
13766 gfc_error ("Operator interface at %L must have, at most, two "
13767 "arguments", &where);
13775 gfc_resolve_uops (gfc_symtree *symtree)
13777 gfc_interface *itr;
13779 if (symtree == NULL)
13782 gfc_resolve_uops (symtree->left);
13783 gfc_resolve_uops (symtree->right);
13785 for (itr = symtree->n.uop->op; itr; itr = itr->next)
13786 check_uop_procedure (itr->sym, itr->sym->declared_at);
13790 /* Examine all of the expressions associated with a program unit,
13791 assign types to all intermediate expressions, make sure that all
13792 assignments are to compatible types and figure out which names
13793 refer to which functions or subroutines. It doesn't check code
13794 block, which is handled by resolve_code. */
13797 resolve_types (gfc_namespace *ns)
13803 gfc_namespace* old_ns = gfc_current_ns;
13805 /* Check that all IMPLICIT types are ok. */
13806 if (!ns->seen_implicit_none)
13809 for (letter = 0; letter != GFC_LETTERS; ++letter)
13810 if (ns->set_flag[letter]
13811 && resolve_typespec_used (&ns->default_type[letter],
13812 &ns->implicit_loc[letter],
13817 gfc_current_ns = ns;
13819 resolve_entries (ns);
13821 resolve_common_vars (ns->blank_common.head, false);
13822 resolve_common_blocks (ns->common_root);
13824 resolve_contained_functions (ns);
13826 if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
13827 && ns->proc_name->attr.if_source == IFSRC_IFBODY)
13828 resolve_formal_arglist (ns->proc_name);
13830 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13832 for (cl = ns->cl_list; cl; cl = cl->next)
13833 resolve_charlen (cl);
13835 gfc_traverse_ns (ns, resolve_symbol);
13837 resolve_fntype (ns);
13839 for (n = ns->contained; n; n = n->sibling)
13841 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13842 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13843 "also be PURE", n->proc_name->name,
13844 &n->proc_name->declared_at);
13850 do_concurrent_flag = 0;
13851 gfc_check_interfaces (ns);
13853 gfc_traverse_ns (ns, resolve_values);
13859 for (d = ns->data; d; d = d->next)
13863 gfc_traverse_ns (ns, gfc_formalize_init_value);
13865 gfc_traverse_ns (ns, gfc_verify_binding_labels);
13867 if (ns->common_root != NULL)
13868 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13870 for (eq = ns->equiv; eq; eq = eq->next)
13871 resolve_equivalence (eq);
13873 /* Warn about unused labels. */
13874 if (warn_unused_label)
13875 warn_unused_fortran_label (ns->st_labels);
13877 gfc_resolve_uops (ns->uop_root);
13879 gfc_current_ns = old_ns;
13883 /* Call resolve_code recursively. */
13886 resolve_codes (gfc_namespace *ns)
13889 bitmap_obstack old_obstack;
13891 if (ns->resolved == 1)
13894 for (n = ns->contained; n; n = n->sibling)
13897 gfc_current_ns = ns;
13899 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13900 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13903 /* Set to an out of range value. */
13904 current_entry_id = -1;
13906 old_obstack = labels_obstack;
13907 bitmap_obstack_initialize (&labels_obstack);
13909 resolve_code (ns->code, ns);
13911 bitmap_obstack_release (&labels_obstack);
13912 labels_obstack = old_obstack;
13916 /* This function is called after a complete program unit has been compiled.
13917 Its purpose is to examine all of the expressions associated with a program
13918 unit, assign types to all intermediate expressions, make sure that all
13919 assignments are to compatible types and figure out which names refer to
13920 which functions or subroutines. */
13923 gfc_resolve (gfc_namespace *ns)
13925 gfc_namespace *old_ns;
13926 code_stack *old_cs_base;
13932 old_ns = gfc_current_ns;
13933 old_cs_base = cs_base;
13935 resolve_types (ns);
13936 resolve_codes (ns);
13938 gfc_current_ns = old_ns;
13939 cs_base = old_cs_base;
13942 gfc_run_passes (ns);