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);
10146 if (!init_expr && gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
10147 && sym->ts.u.cl->length)
10149 gfc_actual_arglist *arg;
10150 init_expr = gfc_get_expr ();
10151 init_expr->where = sym->declared_at;
10152 init_expr->ts = sym->ts;
10153 init_expr->expr_type = EXPR_FUNCTION;
10154 init_expr->value.function.isym =
10155 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT);
10156 init_expr->value.function.name = "repeat";
10157 arg = gfc_get_actual_arglist ();
10158 arg->expr = gfc_get_character_expr (sym->ts.kind, &sym->declared_at,
10160 arg->expr->value.character.string[0]
10161 = gfc_option.flag_init_character_value;
10162 arg->next = gfc_get_actual_arglist ();
10163 arg->next->expr = gfc_copy_expr (sym->ts.u.cl->length);
10164 init_expr->value.function.actual = arg;
10169 gfc_free_expr (init_expr);
10175 /* Add an initialization expression to a local variable. */
10177 apply_default_init_local (gfc_symbol *sym)
10179 gfc_expr *init = NULL;
10181 /* The symbol should be a variable or a function return value. */
10182 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
10183 || (sym->attr.function && sym->result != sym))
10186 /* Try to build the initializer expression. If we can't initialize
10187 this symbol, then init will be NULL. */
10188 init = build_default_init_expr (sym);
10192 /* For saved variables, we don't want to add an initializer at function
10193 entry, so we just add a static initializer. Note that automatic variables
10194 are stack allocated even with -fno-automatic. */
10195 if (sym->attr.save || sym->ns->save_all
10196 || (gfc_option.flag_max_stack_var_size == 0
10197 && (!sym->attr.dimension || !is_non_constant_shape_array (sym))))
10199 /* Don't clobber an existing initializer! */
10200 gcc_assert (sym->value == NULL);
10205 build_init_assign (sym, init);
10209 /* Resolution of common features of flavors variable and procedure. */
10212 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
10214 gfc_array_spec *as;
10216 /* Avoid double diagnostics for function result symbols. */
10217 if ((sym->result || sym->attr.result) && !sym->attr.dummy
10218 && (sym->ns != gfc_current_ns))
10221 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
10222 as = CLASS_DATA (sym)->as;
10226 /* Constraints on deferred shape variable. */
10227 if (as == NULL || as->type != AS_DEFERRED)
10229 bool pointer, allocatable, dimension;
10231 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
10233 pointer = CLASS_DATA (sym)->attr.class_pointer;
10234 allocatable = CLASS_DATA (sym)->attr.allocatable;
10235 dimension = CLASS_DATA (sym)->attr.dimension;
10239 pointer = sym->attr.pointer;
10240 allocatable = sym->attr.allocatable;
10241 dimension = sym->attr.dimension;
10248 gfc_error ("Allocatable array '%s' at %L must have "
10249 "a deferred shape", sym->name, &sym->declared_at);
10252 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
10253 "may not be ALLOCATABLE", sym->name,
10254 &sym->declared_at) == FAILURE)
10258 if (pointer && dimension)
10260 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
10261 sym->name, &sym->declared_at);
10267 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
10268 && sym->ts.type != BT_CLASS && !sym->assoc)
10270 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10271 sym->name, &sym->declared_at);
10276 /* Constraints on polymorphic variables. */
10277 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
10280 if (sym->attr.class_ok
10281 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
10283 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10284 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
10285 &sym->declared_at);
10290 /* Assume that use associated symbols were checked in the module ns.
10291 Class-variables that are associate-names are also something special
10292 and excepted from the test. */
10293 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
10295 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10296 "or pointer", sym->name, &sym->declared_at);
10305 /* Additional checks for symbols with flavor variable and derived
10306 type. To be called from resolve_fl_variable. */
10309 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
10311 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
10313 /* Check to see if a derived type is blocked from being host
10314 associated by the presence of another class I symbol in the same
10315 namespace. 14.6.1.3 of the standard and the discussion on
10316 comp.lang.fortran. */
10317 if (sym->ns != sym->ts.u.derived->ns
10318 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
10321 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
10322 if (s && s->attr.generic)
10323 s = gfc_find_dt_in_generic (s);
10324 if (s && s->attr.flavor != FL_DERIVED)
10326 gfc_error ("The type '%s' cannot be host associated at %L "
10327 "because it is blocked by an incompatible object "
10328 "of the same name declared at %L",
10329 sym->ts.u.derived->name, &sym->declared_at,
10335 /* 4th constraint in section 11.3: "If an object of a type for which
10336 component-initialization is specified (R429) appears in the
10337 specification-part of a module and does not have the ALLOCATABLE
10338 or POINTER attribute, the object shall have the SAVE attribute."
10340 The check for initializers is performed with
10341 gfc_has_default_initializer because gfc_default_initializer generates
10342 a hidden default for allocatable components. */
10343 if (!(sym->value || no_init_flag) && sym->ns->proc_name
10344 && sym->ns->proc_name->attr.flavor == FL_MODULE
10345 && !sym->ns->save_all && !sym->attr.save
10346 && !sym->attr.pointer && !sym->attr.allocatable
10347 && gfc_has_default_initializer (sym->ts.u.derived)
10348 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
10349 "module variable '%s' at %L, needed due to "
10350 "the default initialization", sym->name,
10351 &sym->declared_at) == FAILURE)
10354 /* Assign default initializer. */
10355 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
10356 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
10358 sym->value = gfc_default_initializer (&sym->ts);
10365 /* Resolve symbols with flavor variable. */
10368 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
10370 int no_init_flag, automatic_flag;
10372 const char *auto_save_msg;
10374 auto_save_msg = "Automatic object '%s' at %L cannot have the "
10377 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10380 /* Set this flag to check that variables are parameters of all entries.
10381 This check is effected by the call to gfc_resolve_expr through
10382 is_non_constant_shape_array. */
10383 specification_expr = 1;
10385 if (sym->ns->proc_name
10386 && (sym->ns->proc_name->attr.flavor == FL_MODULE
10387 || sym->ns->proc_name->attr.is_main_program)
10388 && !sym->attr.use_assoc
10389 && !sym->attr.allocatable
10390 && !sym->attr.pointer
10391 && is_non_constant_shape_array (sym))
10393 /* The shape of a main program or module array needs to be
10395 gfc_error ("The module or main program array '%s' at %L must "
10396 "have constant shape", sym->name, &sym->declared_at);
10397 specification_expr = 0;
10401 /* Constraints on deferred type parameter. */
10402 if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
10404 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10405 "requires either the pointer or allocatable attribute",
10406 sym->name, &sym->declared_at);
10410 if (sym->ts.type == BT_CHARACTER)
10412 /* Make sure that character string variables with assumed length are
10413 dummy arguments. */
10414 e = sym->ts.u.cl->length;
10415 if (e == NULL && !sym->attr.dummy && !sym->attr.result
10416 && !sym->ts.deferred)
10418 gfc_error ("Entity with assumed character length at %L must be a "
10419 "dummy argument or a PARAMETER", &sym->declared_at);
10423 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
10425 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10429 if (!gfc_is_constant_expr (e)
10430 && !(e->expr_type == EXPR_VARIABLE
10431 && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
10433 if (!sym->attr.use_assoc && sym->ns->proc_name
10434 && (sym->ns->proc_name->attr.flavor == FL_MODULE
10435 || sym->ns->proc_name->attr.is_main_program))
10437 gfc_error ("'%s' at %L must have constant character length "
10438 "in this context", sym->name, &sym->declared_at);
10441 if (sym->attr.in_common)
10443 gfc_error ("COMMON variable '%s' at %L must have constant "
10444 "character length", sym->name, &sym->declared_at);
10450 if (sym->value == NULL && sym->attr.referenced)
10451 apply_default_init_local (sym); /* Try to apply a default initialization. */
10453 /* Determine if the symbol may not have an initializer. */
10454 no_init_flag = automatic_flag = 0;
10455 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
10456 || sym->attr.intrinsic || sym->attr.result)
10458 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
10459 && is_non_constant_shape_array (sym))
10461 no_init_flag = automatic_flag = 1;
10463 /* Also, they must not have the SAVE attribute.
10464 SAVE_IMPLICIT is checked below. */
10465 if (sym->as && sym->attr.codimension)
10467 int corank = sym->as->corank;
10468 sym->as->corank = 0;
10469 no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
10470 sym->as->corank = corank;
10472 if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
10474 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10479 /* Ensure that any initializer is simplified. */
10481 gfc_simplify_expr (sym->value, 1);
10483 /* Reject illegal initializers. */
10484 if (!sym->mark && sym->value)
10486 if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
10487 && CLASS_DATA (sym)->attr.allocatable))
10488 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10489 sym->name, &sym->declared_at);
10490 else if (sym->attr.external)
10491 gfc_error ("External '%s' at %L cannot have an initializer",
10492 sym->name, &sym->declared_at);
10493 else if (sym->attr.dummy
10494 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
10495 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10496 sym->name, &sym->declared_at);
10497 else if (sym->attr.intrinsic)
10498 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10499 sym->name, &sym->declared_at);
10500 else if (sym->attr.result)
10501 gfc_error ("Function result '%s' at %L cannot have an initializer",
10502 sym->name, &sym->declared_at);
10503 else if (automatic_flag)
10504 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10505 sym->name, &sym->declared_at);
10507 goto no_init_error;
10512 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
10513 return resolve_fl_variable_derived (sym, no_init_flag);
10519 /* Resolve a procedure. */
10522 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
10524 gfc_formal_arglist *arg;
10526 if (sym->attr.function
10527 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10530 if (sym->ts.type == BT_CHARACTER)
10532 gfc_charlen *cl = sym->ts.u.cl;
10534 if (cl && cl->length && gfc_is_constant_expr (cl->length)
10535 && resolve_charlen (cl) == FAILURE)
10538 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
10539 && sym->attr.proc == PROC_ST_FUNCTION)
10541 gfc_error ("Character-valued statement function '%s' at %L must "
10542 "have constant length", sym->name, &sym->declared_at);
10547 /* Ensure that derived type for are not of a private type. Internal
10548 module procedures are excluded by 2.2.3.3 - i.e., they are not
10549 externally accessible and can access all the objects accessible in
10551 if (!(sym->ns->parent
10552 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
10553 && gfc_check_symbol_access (sym))
10555 gfc_interface *iface;
10557 for (arg = 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: '%s' is of a "
10564 "PRIVATE type and cannot be a dummy argument"
10565 " of '%s', which is PUBLIC at %L",
10566 arg->sym->name, sym->name, &sym->declared_at)
10569 /* Stop this message from recurring. */
10570 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10575 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10576 PRIVATE to the containing module. */
10577 for (iface = sym->generic; iface; iface = iface->next)
10579 for (arg = iface->sym->formal; arg; arg = arg->next)
10582 && arg->sym->ts.type == BT_DERIVED
10583 && !arg->sym->ts.u.derived->attr.use_assoc
10584 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10585 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10586 "'%s' in PUBLIC interface '%s' at %L "
10587 "takes dummy arguments of '%s' which is "
10588 "PRIVATE", iface->sym->name, sym->name,
10589 &iface->sym->declared_at,
10590 gfc_typename (&arg->sym->ts)) == FAILURE)
10592 /* Stop this message from recurring. */
10593 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10599 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10600 PRIVATE to the containing module. */
10601 for (iface = sym->generic; iface; iface = iface->next)
10603 for (arg = iface->sym->formal; arg; arg = arg->next)
10606 && arg->sym->ts.type == BT_DERIVED
10607 && !arg->sym->ts.u.derived->attr.use_assoc
10608 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10609 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10610 "'%s' in PUBLIC interface '%s' at %L "
10611 "takes dummy arguments of '%s' which is "
10612 "PRIVATE", iface->sym->name, sym->name,
10613 &iface->sym->declared_at,
10614 gfc_typename (&arg->sym->ts)) == FAILURE)
10616 /* Stop this message from recurring. */
10617 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10624 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10625 && !sym->attr.proc_pointer)
10627 gfc_error ("Function '%s' at %L cannot have an initializer",
10628 sym->name, &sym->declared_at);
10632 /* An external symbol may not have an initializer because it is taken to be
10633 a procedure. Exception: Procedure Pointers. */
10634 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10636 gfc_error ("External object '%s' at %L may not have an initializer",
10637 sym->name, &sym->declared_at);
10641 /* An elemental function is required to return a scalar 12.7.1 */
10642 if (sym->attr.elemental && sym->attr.function && sym->as)
10644 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10645 "result", sym->name, &sym->declared_at);
10646 /* Reset so that the error only occurs once. */
10647 sym->attr.elemental = 0;
10651 if (sym->attr.proc == PROC_ST_FUNCTION
10652 && (sym->attr.allocatable || sym->attr.pointer))
10654 gfc_error ("Statement function '%s' at %L may not have pointer or "
10655 "allocatable attribute", sym->name, &sym->declared_at);
10659 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10660 char-len-param shall not be array-valued, pointer-valued, recursive
10661 or pure. ....snip... A character value of * may only be used in the
10662 following ways: (i) Dummy arg of procedure - dummy associates with
10663 actual length; (ii) To declare a named constant; or (iii) External
10664 function - but length must be declared in calling scoping unit. */
10665 if (sym->attr.function
10666 && sym->ts.type == BT_CHARACTER
10667 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10669 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10670 || (sym->attr.recursive) || (sym->attr.pure))
10672 if (sym->as && sym->as->rank)
10673 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10674 "array-valued", sym->name, &sym->declared_at);
10676 if (sym->attr.pointer)
10677 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10678 "pointer-valued", sym->name, &sym->declared_at);
10680 if (sym->attr.pure)
10681 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10682 "pure", sym->name, &sym->declared_at);
10684 if (sym->attr.recursive)
10685 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10686 "recursive", sym->name, &sym->declared_at);
10691 /* Appendix B.2 of the standard. Contained functions give an
10692 error anyway. Fixed-form is likely to be F77/legacy. Deferred
10693 character length is an F2003 feature. */
10694 if (!sym->attr.contained
10695 && gfc_current_form != FORM_FIXED
10696 && !sym->ts.deferred)
10697 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10698 "CHARACTER(*) function '%s' at %L",
10699 sym->name, &sym->declared_at);
10702 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10704 gfc_formal_arglist *curr_arg;
10705 int has_non_interop_arg = 0;
10707 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10708 sym->common_block) == FAILURE)
10710 /* Clear these to prevent looking at them again if there was an
10712 sym->attr.is_bind_c = 0;
10713 sym->attr.is_c_interop = 0;
10714 sym->ts.is_c_interop = 0;
10718 /* So far, no errors have been found. */
10719 sym->attr.is_c_interop = 1;
10720 sym->ts.is_c_interop = 1;
10723 curr_arg = sym->formal;
10724 while (curr_arg != NULL)
10726 /* Skip implicitly typed dummy args here. */
10727 if (curr_arg->sym->attr.implicit_type == 0)
10728 if (gfc_verify_c_interop_param (curr_arg->sym) == FAILURE)
10729 /* If something is found to fail, record the fact so we
10730 can mark the symbol for the procedure as not being
10731 BIND(C) to try and prevent multiple errors being
10733 has_non_interop_arg = 1;
10735 curr_arg = curr_arg->next;
10738 /* See if any of the arguments were not interoperable and if so, clear
10739 the procedure symbol to prevent duplicate error messages. */
10740 if (has_non_interop_arg != 0)
10742 sym->attr.is_c_interop = 0;
10743 sym->ts.is_c_interop = 0;
10744 sym->attr.is_bind_c = 0;
10748 if (!sym->attr.proc_pointer)
10750 if (sym->attr.save == SAVE_EXPLICIT)
10752 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10753 "in '%s' at %L", sym->name, &sym->declared_at);
10756 if (sym->attr.intent)
10758 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10759 "in '%s' at %L", sym->name, &sym->declared_at);
10762 if (sym->attr.subroutine && sym->attr.result)
10764 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10765 "in '%s' at %L", sym->name, &sym->declared_at);
10768 if (sym->attr.external && sym->attr.function
10769 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10770 || sym->attr.contained))
10772 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10773 "in '%s' at %L", sym->name, &sym->declared_at);
10776 if (strcmp ("ppr@", sym->name) == 0)
10778 gfc_error ("Procedure pointer result '%s' at %L "
10779 "is missing the pointer attribute",
10780 sym->ns->proc_name->name, &sym->declared_at);
10789 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10790 been defined and we now know their defined arguments, check that they fulfill
10791 the requirements of the standard for procedures used as finalizers. */
10794 gfc_resolve_finalizers (gfc_symbol* derived)
10796 gfc_finalizer* list;
10797 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10798 gfc_try result = SUCCESS;
10799 bool seen_scalar = false;
10801 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10804 /* Walk over the list of finalizer-procedures, check them, and if any one
10805 does not fit in with the standard's definition, print an error and remove
10806 it from the list. */
10807 prev_link = &derived->f2k_derived->finalizers;
10808 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10814 /* Skip this finalizer if we already resolved it. */
10815 if (list->proc_tree)
10817 prev_link = &(list->next);
10821 /* Check this exists and is a SUBROUTINE. */
10822 if (!list->proc_sym->attr.subroutine)
10824 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10825 list->proc_sym->name, &list->where);
10829 /* We should have exactly one argument. */
10830 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10832 gfc_error ("FINAL procedure at %L must have exactly one argument",
10836 arg = list->proc_sym->formal->sym;
10838 /* This argument must be of our type. */
10839 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10841 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10842 &arg->declared_at, derived->name);
10846 /* It must neither be a pointer nor allocatable nor optional. */
10847 if (arg->attr.pointer)
10849 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10850 &arg->declared_at);
10853 if (arg->attr.allocatable)
10855 gfc_error ("Argument of FINAL procedure at %L must not be"
10856 " ALLOCATABLE", &arg->declared_at);
10859 if (arg->attr.optional)
10861 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10862 &arg->declared_at);
10866 /* It must not be INTENT(OUT). */
10867 if (arg->attr.intent == INTENT_OUT)
10869 gfc_error ("Argument of FINAL procedure at %L must not be"
10870 " INTENT(OUT)", &arg->declared_at);
10874 /* Warn if the procedure is non-scalar and not assumed shape. */
10875 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10876 && arg->as->type != AS_ASSUMED_SHAPE)
10877 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10878 " shape argument", &arg->declared_at);
10880 /* Check that it does not match in kind and rank with a FINAL procedure
10881 defined earlier. To really loop over the *earlier* declarations,
10882 we need to walk the tail of the list as new ones were pushed at the
10884 /* TODO: Handle kind parameters once they are implemented. */
10885 my_rank = (arg->as ? arg->as->rank : 0);
10886 for (i = list->next; i; i = i->next)
10888 /* Argument list might be empty; that is an error signalled earlier,
10889 but we nevertheless continued resolving. */
10890 if (i->proc_sym->formal)
10892 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10893 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10894 if (i_rank == my_rank)
10896 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10897 " rank (%d) as '%s'",
10898 list->proc_sym->name, &list->where, my_rank,
10899 i->proc_sym->name);
10905 /* Is this the/a scalar finalizer procedure? */
10906 if (!arg->as || arg->as->rank == 0)
10907 seen_scalar = true;
10909 /* Find the symtree for this procedure. */
10910 gcc_assert (!list->proc_tree);
10911 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10913 prev_link = &list->next;
10916 /* Remove wrong nodes immediately from the list so we don't risk any
10917 troubles in the future when they might fail later expectations. */
10921 *prev_link = list->next;
10922 gfc_free_finalizer (i);
10925 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10926 were nodes in the list, must have been for arrays. It is surely a good
10927 idea to have a scalar version there if there's something to finalize. */
10928 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10929 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10930 " defined at %L, suggest also scalar one",
10931 derived->name, &derived->declared_at);
10933 /* TODO: Remove this error when finalization is finished. */
10934 gfc_error ("Finalization at %L is not yet implemented",
10935 &derived->declared_at);
10941 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10944 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10945 const char* generic_name, locus where)
10950 gcc_assert (t1->specific && t2->specific);
10951 gcc_assert (!t1->specific->is_generic);
10952 gcc_assert (!t2->specific->is_generic);
10954 sym1 = t1->specific->u.specific->n.sym;
10955 sym2 = t2->specific->u.specific->n.sym;
10960 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10961 if (sym1->attr.subroutine != sym2->attr.subroutine
10962 || sym1->attr.function != sym2->attr.function)
10964 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10965 " GENERIC '%s' at %L",
10966 sym1->name, sym2->name, generic_name, &where);
10970 /* Compare the interfaces. */
10971 if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
10973 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10974 sym1->name, sym2->name, generic_name, &where);
10982 /* Worker function for resolving a generic procedure binding; this is used to
10983 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10985 The difference between those cases is finding possible inherited bindings
10986 that are overridden, as one has to look for them in tb_sym_root,
10987 tb_uop_root or tb_op, respectively. Thus the caller must already find
10988 the super-type and set p->overridden correctly. */
10991 resolve_tb_generic_targets (gfc_symbol* super_type,
10992 gfc_typebound_proc* p, const char* name)
10994 gfc_tbp_generic* target;
10995 gfc_symtree* first_target;
10996 gfc_symtree* inherited;
10998 gcc_assert (p && p->is_generic);
11000 /* Try to find the specific bindings for the symtrees in our target-list. */
11001 gcc_assert (p->u.generic);
11002 for (target = p->u.generic; target; target = target->next)
11003 if (!target->specific)
11005 gfc_typebound_proc* overridden_tbp;
11006 gfc_tbp_generic* g;
11007 const char* target_name;
11009 target_name = target->specific_st->name;
11011 /* Defined for this type directly. */
11012 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
11014 target->specific = target->specific_st->n.tb;
11015 goto specific_found;
11018 /* Look for an inherited specific binding. */
11021 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
11026 gcc_assert (inherited->n.tb);
11027 target->specific = inherited->n.tb;
11028 goto specific_found;
11032 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11033 " at %L", target_name, name, &p->where);
11036 /* Once we've found the specific binding, check it is not ambiguous with
11037 other specifics already found or inherited for the same GENERIC. */
11039 gcc_assert (target->specific);
11041 /* This must really be a specific binding! */
11042 if (target->specific->is_generic)
11044 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11045 " '%s' is GENERIC, too", name, &p->where, target_name);
11049 /* Check those already resolved on this type directly. */
11050 for (g = p->u.generic; g; g = g->next)
11051 if (g != target && g->specific
11052 && check_generic_tbp_ambiguity (target, g, name, p->where)
11056 /* Check for ambiguity with inherited specific targets. */
11057 for (overridden_tbp = p->overridden; overridden_tbp;
11058 overridden_tbp = overridden_tbp->overridden)
11059 if (overridden_tbp->is_generic)
11061 for (g = overridden_tbp->u.generic; g; g = g->next)
11063 gcc_assert (g->specific);
11064 if (check_generic_tbp_ambiguity (target, g,
11065 name, p->where) == FAILURE)
11071 /* If we attempt to "overwrite" a specific binding, this is an error. */
11072 if (p->overridden && !p->overridden->is_generic)
11074 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11075 " the same name", name, &p->where);
11079 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11080 all must have the same attributes here. */
11081 first_target = p->u.generic->specific->u.specific;
11082 gcc_assert (first_target);
11083 p->subroutine = first_target->n.sym->attr.subroutine;
11084 p->function = first_target->n.sym->attr.function;
11090 /* Resolve a GENERIC procedure binding for a derived type. */
11093 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
11095 gfc_symbol* super_type;
11097 /* Find the overridden binding if any. */
11098 st->n.tb->overridden = NULL;
11099 super_type = gfc_get_derived_super_type (derived);
11102 gfc_symtree* overridden;
11103 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
11106 if (overridden && overridden->n.tb)
11107 st->n.tb->overridden = overridden->n.tb;
11110 /* Resolve using worker function. */
11111 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
11115 /* Retrieve the target-procedure of an operator binding and do some checks in
11116 common for intrinsic and user-defined type-bound operators. */
11119 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
11121 gfc_symbol* target_proc;
11123 gcc_assert (target->specific && !target->specific->is_generic);
11124 target_proc = target->specific->u.specific->n.sym;
11125 gcc_assert (target_proc);
11127 /* All operator bindings must have a passed-object dummy argument. */
11128 if (target->specific->nopass)
11130 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
11134 return target_proc;
11138 /* Resolve a type-bound intrinsic operator. */
11141 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
11142 gfc_typebound_proc* p)
11144 gfc_symbol* super_type;
11145 gfc_tbp_generic* target;
11147 /* If there's already an error here, do nothing (but don't fail again). */
11151 /* Operators should always be GENERIC bindings. */
11152 gcc_assert (p->is_generic);
11154 /* Look for an overridden binding. */
11155 super_type = gfc_get_derived_super_type (derived);
11156 if (super_type && super_type->f2k_derived)
11157 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
11160 p->overridden = NULL;
11162 /* Resolve general GENERIC properties using worker function. */
11163 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
11166 /* Check the targets to be procedures of correct interface. */
11167 for (target = p->u.generic; target; target = target->next)
11169 gfc_symbol* target_proc;
11171 target_proc = get_checked_tb_operator_target (target, p->where);
11175 if (!gfc_check_operator_interface (target_proc, op, p->where))
11187 /* Resolve a type-bound user operator (tree-walker callback). */
11189 static gfc_symbol* resolve_bindings_derived;
11190 static gfc_try resolve_bindings_result;
11192 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
11195 resolve_typebound_user_op (gfc_symtree* stree)
11197 gfc_symbol* super_type;
11198 gfc_tbp_generic* target;
11200 gcc_assert (stree && stree->n.tb);
11202 if (stree->n.tb->error)
11205 /* Operators should always be GENERIC bindings. */
11206 gcc_assert (stree->n.tb->is_generic);
11208 /* Find overridden procedure, if any. */
11209 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11210 if (super_type && super_type->f2k_derived)
11212 gfc_symtree* overridden;
11213 overridden = gfc_find_typebound_user_op (super_type, NULL,
11214 stree->name, true, NULL);
11216 if (overridden && overridden->n.tb)
11217 stree->n.tb->overridden = overridden->n.tb;
11220 stree->n.tb->overridden = NULL;
11222 /* Resolve basically using worker function. */
11223 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
11227 /* Check the targets to be functions of correct interface. */
11228 for (target = stree->n.tb->u.generic; target; target = target->next)
11230 gfc_symbol* target_proc;
11232 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
11236 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
11243 resolve_bindings_result = FAILURE;
11244 stree->n.tb->error = 1;
11248 /* Resolve the type-bound procedures for a derived type. */
11251 resolve_typebound_procedure (gfc_symtree* stree)
11255 gfc_symbol* me_arg;
11256 gfc_symbol* super_type;
11257 gfc_component* comp;
11259 gcc_assert (stree);
11261 /* Undefined specific symbol from GENERIC target definition. */
11265 if (stree->n.tb->error)
11268 /* If this is a GENERIC binding, use that routine. */
11269 if (stree->n.tb->is_generic)
11271 if (resolve_typebound_generic (resolve_bindings_derived, stree)
11277 /* Get the target-procedure to check it. */
11278 gcc_assert (!stree->n.tb->is_generic);
11279 gcc_assert (stree->n.tb->u.specific);
11280 proc = stree->n.tb->u.specific->n.sym;
11281 where = stree->n.tb->where;
11283 /* Default access should already be resolved from the parser. */
11284 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
11286 /* It should be a module procedure or an external procedure with explicit
11287 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
11288 if ((!proc->attr.subroutine && !proc->attr.function)
11289 || (proc->attr.proc != PROC_MODULE
11290 && proc->attr.if_source != IFSRC_IFBODY)
11291 || (proc->attr.abstract && !stree->n.tb->deferred))
11293 gfc_error ("'%s' must be a module procedure or an external procedure with"
11294 " an explicit interface at %L", proc->name, &where);
11297 stree->n.tb->subroutine = proc->attr.subroutine;
11298 stree->n.tb->function = proc->attr.function;
11300 /* Find the super-type of the current derived type. We could do this once and
11301 store in a global if speed is needed, but as long as not I believe this is
11302 more readable and clearer. */
11303 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11305 /* If PASS, resolve and check arguments if not already resolved / loaded
11306 from a .mod file. */
11307 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
11309 if (stree->n.tb->pass_arg)
11311 gfc_formal_arglist* i;
11313 /* If an explicit passing argument name is given, walk the arg-list
11314 and look for it. */
11317 stree->n.tb->pass_arg_num = 1;
11318 for (i = proc->formal; i; i = i->next)
11320 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
11325 ++stree->n.tb->pass_arg_num;
11330 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11332 proc->name, stree->n.tb->pass_arg, &where,
11333 stree->n.tb->pass_arg);
11339 /* Otherwise, take the first one; there should in fact be at least
11341 stree->n.tb->pass_arg_num = 1;
11344 gfc_error ("Procedure '%s' with PASS at %L must have at"
11345 " least one argument", proc->name, &where);
11348 me_arg = proc->formal->sym;
11351 /* Now check that the argument-type matches and the passed-object
11352 dummy argument is generally fine. */
11354 gcc_assert (me_arg);
11356 if (me_arg->ts.type != BT_CLASS)
11358 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11359 " at %L", proc->name, &where);
11363 if (CLASS_DATA (me_arg)->ts.u.derived
11364 != resolve_bindings_derived)
11366 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11367 " the derived-type '%s'", me_arg->name, proc->name,
11368 me_arg->name, &where, resolve_bindings_derived->name);
11372 gcc_assert (me_arg->ts.type == BT_CLASS);
11373 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
11375 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11376 " scalar", proc->name, &where);
11379 if (CLASS_DATA (me_arg)->attr.allocatable)
11381 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11382 " be ALLOCATABLE", proc->name, &where);
11385 if (CLASS_DATA (me_arg)->attr.class_pointer)
11387 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11388 " be POINTER", proc->name, &where);
11393 /* If we are extending some type, check that we don't override a procedure
11394 flagged NON_OVERRIDABLE. */
11395 stree->n.tb->overridden = NULL;
11398 gfc_symtree* overridden;
11399 overridden = gfc_find_typebound_proc (super_type, NULL,
11400 stree->name, true, NULL);
11404 if (overridden->n.tb)
11405 stree->n.tb->overridden = overridden->n.tb;
11407 if (gfc_check_typebound_override (stree, overridden) == FAILURE)
11412 /* See if there's a name collision with a component directly in this type. */
11413 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11414 if (!strcmp (comp->name, stree->name))
11416 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11418 stree->name, &where, resolve_bindings_derived->name);
11422 /* Try to find a name collision with an inherited component. */
11423 if (super_type && gfc_find_component (super_type, stree->name, true, true))
11425 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11426 " component of '%s'",
11427 stree->name, &where, resolve_bindings_derived->name);
11431 stree->n.tb->error = 0;
11435 resolve_bindings_result = FAILURE;
11436 stree->n.tb->error = 1;
11441 resolve_typebound_procedures (gfc_symbol* derived)
11444 gfc_symbol* super_type;
11446 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11449 super_type = gfc_get_derived_super_type (derived);
11451 resolve_typebound_procedures (super_type);
11453 resolve_bindings_derived = derived;
11454 resolve_bindings_result = SUCCESS;
11456 /* Make sure the vtab has been generated. */
11457 gfc_find_derived_vtab (derived);
11459 if (derived->f2k_derived->tb_sym_root)
11460 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11461 &resolve_typebound_procedure);
11463 if (derived->f2k_derived->tb_uop_root)
11464 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11465 &resolve_typebound_user_op);
11467 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11469 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11470 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11472 resolve_bindings_result = FAILURE;
11475 return resolve_bindings_result;
11479 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11480 to give all identical derived types the same backend_decl. */
11482 add_dt_to_dt_list (gfc_symbol *derived)
11484 gfc_dt_list *dt_list;
11486 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11487 if (derived == dt_list->derived)
11490 dt_list = gfc_get_dt_list ();
11491 dt_list->next = gfc_derived_types;
11492 dt_list->derived = derived;
11493 gfc_derived_types = dt_list;
11497 /* Ensure that a derived-type is really not abstract, meaning that every
11498 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11501 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11506 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11508 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11511 if (st->n.tb && st->n.tb->deferred)
11513 gfc_symtree* overriding;
11514 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11517 gcc_assert (overriding->n.tb);
11518 if (overriding->n.tb->deferred)
11520 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11521 " '%s' is DEFERRED and not overridden",
11522 sub->name, &sub->declared_at, st->name);
11531 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11533 /* The algorithm used here is to recursively travel up the ancestry of sub
11534 and for each ancestor-type, check all bindings. If any of them is
11535 DEFERRED, look it up starting from sub and see if the found (overriding)
11536 binding is not DEFERRED.
11537 This is not the most efficient way to do this, but it should be ok and is
11538 clearer than something sophisticated. */
11540 gcc_assert (ancestor && !sub->attr.abstract);
11542 if (!ancestor->attr.abstract)
11545 /* Walk bindings of this ancestor. */
11546 if (ancestor->f2k_derived)
11549 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11554 /* Find next ancestor type and recurse on it. */
11555 ancestor = gfc_get_derived_super_type (ancestor);
11557 return ensure_not_abstract (sub, ancestor);
11563 /* Resolve the components of a derived type. This does not have to wait until
11564 resolution stage, but can be done as soon as the dt declaration has been
11568 resolve_fl_derived0 (gfc_symbol *sym)
11570 gfc_symbol* super_type;
11573 super_type = gfc_get_derived_super_type (sym);
11576 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11578 gfc_error ("As extending type '%s' at %L has a coarray component, "
11579 "parent type '%s' shall also have one", sym->name,
11580 &sym->declared_at, super_type->name);
11584 /* Ensure the extended type gets resolved before we do. */
11585 if (super_type && resolve_fl_derived0 (super_type) == FAILURE)
11588 /* An ABSTRACT type must be extensible. */
11589 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11591 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11592 sym->name, &sym->declared_at);
11596 c = (sym->attr.is_class) ? sym->components->ts.u.derived->components
11599 for ( ; c != NULL; c = c->next)
11601 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
11602 if (c->ts.type == BT_CHARACTER && c->ts.deferred)
11604 gfc_error ("Deferred-length character component '%s' at %L is not "
11605 "yet supported", c->name, &c->loc);
11610 if ((!sym->attr.is_class || c != sym->components)
11611 && c->attr.codimension
11612 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11614 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11615 "deferred shape", c->name, &c->loc);
11620 if (c->attr.codimension && c->ts.type == BT_DERIVED
11621 && c->ts.u.derived->ts.is_iso_c)
11623 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11624 "shall not be a coarray", c->name, &c->loc);
11629 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11630 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11631 || c->attr.allocatable))
11633 gfc_error ("Component '%s' at %L with coarray component "
11634 "shall be a nonpointer, nonallocatable scalar",
11640 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11642 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11643 "is not an array pointer", c->name, &c->loc);
11647 if (c->attr.proc_pointer && c->ts.interface)
11649 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11650 gfc_error ("Interface '%s', used by procedure pointer component "
11651 "'%s' at %L, is declared in a later PROCEDURE statement",
11652 c->ts.interface->name, c->name, &c->loc);
11654 /* Get the attributes from the interface (now resolved). */
11655 if (c->ts.interface->attr.if_source
11656 || c->ts.interface->attr.intrinsic)
11658 gfc_symbol *ifc = c->ts.interface;
11660 if (ifc->formal && !ifc->formal_ns)
11661 resolve_symbol (ifc);
11663 if (ifc->attr.intrinsic)
11664 resolve_intrinsic (ifc, &ifc->declared_at);
11668 c->ts = ifc->result->ts;
11669 c->attr.allocatable = ifc->result->attr.allocatable;
11670 c->attr.pointer = ifc->result->attr.pointer;
11671 c->attr.dimension = ifc->result->attr.dimension;
11672 c->as = gfc_copy_array_spec (ifc->result->as);
11677 c->attr.allocatable = ifc->attr.allocatable;
11678 c->attr.pointer = ifc->attr.pointer;
11679 c->attr.dimension = ifc->attr.dimension;
11680 c->as = gfc_copy_array_spec (ifc->as);
11682 c->ts.interface = ifc;
11683 c->attr.function = ifc->attr.function;
11684 c->attr.subroutine = ifc->attr.subroutine;
11685 gfc_copy_formal_args_ppc (c, ifc);
11687 c->attr.pure = ifc->attr.pure;
11688 c->attr.elemental = ifc->attr.elemental;
11689 c->attr.recursive = ifc->attr.recursive;
11690 c->attr.always_explicit = ifc->attr.always_explicit;
11691 c->attr.ext_attr |= ifc->attr.ext_attr;
11692 /* Replace symbols in array spec. */
11696 for (i = 0; i < c->as->rank; i++)
11698 gfc_expr_replace_comp (c->as->lower[i], c);
11699 gfc_expr_replace_comp (c->as->upper[i], c);
11702 /* Copy char length. */
11703 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11705 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11706 gfc_expr_replace_comp (cl->length, c);
11707 if (cl->length && !cl->resolved
11708 && gfc_resolve_expr (cl->length) == FAILURE)
11713 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11715 gfc_error ("Interface '%s' of procedure pointer component "
11716 "'%s' at %L must be explicit", c->ts.interface->name,
11721 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11723 /* Since PPCs are not implicitly typed, a PPC without an explicit
11724 interface must be a subroutine. */
11725 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11728 /* Procedure pointer components: Check PASS arg. */
11729 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11730 && !sym->attr.vtype)
11732 gfc_symbol* me_arg;
11734 if (c->tb->pass_arg)
11736 gfc_formal_arglist* i;
11738 /* If an explicit passing argument name is given, walk the arg-list
11739 and look for it. */
11742 c->tb->pass_arg_num = 1;
11743 for (i = c->formal; i; i = i->next)
11745 if (!strcmp (i->sym->name, c->tb->pass_arg))
11750 c->tb->pass_arg_num++;
11755 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11756 "at %L has no argument '%s'", c->name,
11757 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11764 /* Otherwise, take the first one; there should in fact be at least
11766 c->tb->pass_arg_num = 1;
11769 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11770 "must have at least one argument",
11775 me_arg = c->formal->sym;
11778 /* Now check that the argument-type matches. */
11779 gcc_assert (me_arg);
11780 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11781 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11782 || (me_arg->ts.type == BT_CLASS
11783 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11785 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11786 " the derived type '%s'", me_arg->name, c->name,
11787 me_arg->name, &c->loc, sym->name);
11792 /* Check for C453. */
11793 if (me_arg->attr.dimension)
11795 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11796 "must be scalar", me_arg->name, c->name, me_arg->name,
11802 if (me_arg->attr.pointer)
11804 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11805 "may not have the POINTER attribute", me_arg->name,
11806 c->name, me_arg->name, &c->loc);
11811 if (me_arg->attr.allocatable)
11813 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11814 "may not be ALLOCATABLE", me_arg->name, c->name,
11815 me_arg->name, &c->loc);
11820 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11821 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11822 " at %L", c->name, &c->loc);
11826 /* Check type-spec if this is not the parent-type component. */
11827 if (((sym->attr.is_class
11828 && (!sym->components->ts.u.derived->attr.extension
11829 || c != sym->components->ts.u.derived->components))
11830 || (!sym->attr.is_class
11831 && (!sym->attr.extension || c != sym->components)))
11832 && !sym->attr.vtype
11833 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11836 /* If this type is an extension, set the accessibility of the parent
11839 && ((sym->attr.is_class
11840 && c == sym->components->ts.u.derived->components)
11841 || (!sym->attr.is_class && c == sym->components))
11842 && strcmp (super_type->name, c->name) == 0)
11843 c->attr.access = super_type->attr.access;
11845 /* If this type is an extension, see if this component has the same name
11846 as an inherited type-bound procedure. */
11847 if (super_type && !sym->attr.is_class
11848 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11850 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11851 " inherited type-bound procedure",
11852 c->name, sym->name, &c->loc);
11856 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
11857 && !c->ts.deferred)
11859 if (c->ts.u.cl->length == NULL
11860 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11861 || !gfc_is_constant_expr (c->ts.u.cl->length))
11863 gfc_error ("Character length of component '%s' needs to "
11864 "be a constant specification expression at %L",
11866 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11871 if (c->ts.type == BT_CHARACTER && c->ts.deferred
11872 && !c->attr.pointer && !c->attr.allocatable)
11874 gfc_error ("Character component '%s' of '%s' at %L with deferred "
11875 "length must be a POINTER or ALLOCATABLE",
11876 c->name, sym->name, &c->loc);
11880 if (c->ts.type == BT_DERIVED
11881 && sym->component_access != ACCESS_PRIVATE
11882 && gfc_check_symbol_access (sym)
11883 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11884 && !c->ts.u.derived->attr.use_assoc
11885 && !gfc_check_symbol_access (c->ts.u.derived)
11886 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11887 "is a PRIVATE type and cannot be a component of "
11888 "'%s', which is PUBLIC at %L", c->name,
11889 sym->name, &sym->declared_at) == FAILURE)
11892 if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
11894 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11895 "type %s", c->name, &c->loc, sym->name);
11899 if (sym->attr.sequence)
11901 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11903 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11904 "not have the SEQUENCE attribute",
11905 c->ts.u.derived->name, &sym->declared_at);
11910 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
11911 c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
11912 else if (c->ts.type == BT_CLASS && c->attr.class_ok
11913 && CLASS_DATA (c)->ts.u.derived->attr.generic)
11914 CLASS_DATA (c)->ts.u.derived
11915 = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
11917 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
11918 && c->attr.pointer && c->ts.u.derived->components == NULL
11919 && !c->ts.u.derived->attr.zero_comp)
11921 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11922 "that has not been declared", c->name, sym->name,
11927 if (c->ts.type == BT_CLASS && c->attr.class_ok
11928 && CLASS_DATA (c)->attr.class_pointer
11929 && CLASS_DATA (c)->ts.u.derived->components == NULL
11930 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11932 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11933 "that has not been declared", c->name, sym->name,
11939 if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE
11940 && (!c->attr.class_ok
11941 || !(CLASS_DATA (c)->attr.class_pointer
11942 || CLASS_DATA (c)->attr.allocatable)))
11944 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11945 "or pointer", c->name, &c->loc);
11949 /* Ensure that all the derived type components are put on the
11950 derived type list; even in formal namespaces, where derived type
11951 pointer components might not have been declared. */
11952 if (c->ts.type == BT_DERIVED
11954 && c->ts.u.derived->components
11956 && sym != c->ts.u.derived)
11957 add_dt_to_dt_list (c->ts.u.derived);
11959 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11960 || c->attr.proc_pointer
11961 || c->attr.allocatable)) == FAILURE)
11965 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11966 all DEFERRED bindings are overridden. */
11967 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11968 && !sym->attr.is_class
11969 && ensure_not_abstract (sym, super_type) == FAILURE)
11972 /* Add derived type to the derived type list. */
11973 add_dt_to_dt_list (sym);
11979 /* The following procedure does the full resolution of a derived type,
11980 including resolution of all type-bound procedures (if present). In contrast
11981 to 'resolve_fl_derived0' this can only be done after the module has been
11982 parsed completely. */
11985 resolve_fl_derived (gfc_symbol *sym)
11987 gfc_symbol *gen_dt = NULL;
11989 if (!sym->attr.is_class)
11990 gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
11991 if (gen_dt && gen_dt->generic && gen_dt->generic->next
11992 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Generic name '%s' of "
11993 "function '%s' at %L being the same name as derived "
11994 "type at %L", sym->name,
11995 gen_dt->generic->sym == sym
11996 ? gen_dt->generic->next->sym->name
11997 : gen_dt->generic->sym->name,
11998 gen_dt->generic->sym == sym
11999 ? &gen_dt->generic->next->sym->declared_at
12000 : &gen_dt->generic->sym->declared_at,
12001 &sym->declared_at) == FAILURE)
12004 if (sym->attr.is_class && sym->ts.u.derived == NULL)
12006 /* Fix up incomplete CLASS symbols. */
12007 gfc_component *data = gfc_find_component (sym, "_data", true, true);
12008 gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
12009 if (vptr->ts.u.derived == NULL)
12011 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
12013 vptr->ts.u.derived = vtab->ts.u.derived;
12017 if (resolve_fl_derived0 (sym) == FAILURE)
12020 /* Resolve the type-bound procedures. */
12021 if (resolve_typebound_procedures (sym) == FAILURE)
12024 /* Resolve the finalizer procedures. */
12025 if (gfc_resolve_finalizers (sym) == FAILURE)
12033 resolve_fl_namelist (gfc_symbol *sym)
12038 for (nl = sym->namelist; nl; nl = nl->next)
12040 /* Check again, the check in match only works if NAMELIST comes
12042 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
12044 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12045 "allowed", nl->sym->name, sym->name, &sym->declared_at);
12049 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
12050 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
12051 "object '%s' with assumed shape in namelist "
12052 "'%s' at %L", nl->sym->name, sym->name,
12053 &sym->declared_at) == FAILURE)
12056 if (is_non_constant_shape_array (nl->sym)
12057 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
12058 "object '%s' with nonconstant shape in namelist "
12059 "'%s' at %L", nl->sym->name, sym->name,
12060 &sym->declared_at) == FAILURE)
12063 if (nl->sym->ts.type == BT_CHARACTER
12064 && (nl->sym->ts.u.cl->length == NULL
12065 || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
12066 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
12067 "'%s' with nonconstant character length in "
12068 "namelist '%s' at %L", nl->sym->name, sym->name,
12069 &sym->declared_at) == FAILURE)
12072 /* FIXME: Once UDDTIO is implemented, the following can be
12074 if (nl->sym->ts.type == BT_CLASS)
12076 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12077 "polymorphic and requires a defined input/output "
12078 "procedure", nl->sym->name, sym->name, &sym->declared_at);
12082 if (nl->sym->ts.type == BT_DERIVED
12083 && (nl->sym->ts.u.derived->attr.alloc_comp
12084 || nl->sym->ts.u.derived->attr.pointer_comp))
12086 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
12087 "'%s' in namelist '%s' at %L with ALLOCATABLE "
12088 "or POINTER components", nl->sym->name,
12089 sym->name, &sym->declared_at) == FAILURE)
12092 /* FIXME: Once UDDTIO is implemented, the following can be
12094 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12095 "ALLOCATABLE or POINTER components and thus requires "
12096 "a defined input/output procedure", nl->sym->name,
12097 sym->name, &sym->declared_at);
12102 /* Reject PRIVATE objects in a PUBLIC namelist. */
12103 if (gfc_check_symbol_access (sym))
12105 for (nl = sym->namelist; nl; nl = nl->next)
12107 if (!nl->sym->attr.use_assoc
12108 && !is_sym_host_assoc (nl->sym, sym->ns)
12109 && !gfc_check_symbol_access (nl->sym))
12111 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12112 "cannot be member of PUBLIC namelist '%s' at %L",
12113 nl->sym->name, sym->name, &sym->declared_at);
12117 /* Types with private components that came here by USE-association. */
12118 if (nl->sym->ts.type == BT_DERIVED
12119 && derived_inaccessible (nl->sym->ts.u.derived))
12121 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12122 "components and cannot be member of namelist '%s' at %L",
12123 nl->sym->name, sym->name, &sym->declared_at);
12127 /* Types with private components that are defined in the same module. */
12128 if (nl->sym->ts.type == BT_DERIVED
12129 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
12130 && nl->sym->ts.u.derived->attr.private_comp)
12132 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12133 "cannot be a member of PUBLIC namelist '%s' at %L",
12134 nl->sym->name, sym->name, &sym->declared_at);
12141 /* 14.1.2 A module or internal procedure represent local entities
12142 of the same type as a namelist member and so are not allowed. */
12143 for (nl = sym->namelist; nl; nl = nl->next)
12145 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
12148 if (nl->sym->attr.function && nl->sym == nl->sym->result)
12149 if ((nl->sym == sym->ns->proc_name)
12151 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
12155 if (nl->sym && nl->sym->name)
12156 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
12157 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
12159 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12160 "attribute in '%s' at %L", nlsym->name,
12161 &sym->declared_at);
12171 resolve_fl_parameter (gfc_symbol *sym)
12173 /* A parameter array's shape needs to be constant. */
12174 if (sym->as != NULL
12175 && (sym->as->type == AS_DEFERRED
12176 || is_non_constant_shape_array (sym)))
12178 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12179 "or of deferred shape", sym->name, &sym->declared_at);
12183 /* Make sure a parameter that has been implicitly typed still
12184 matches the implicit type, since PARAMETER statements can precede
12185 IMPLICIT statements. */
12186 if (sym->attr.implicit_type
12187 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
12190 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12191 "later IMPLICIT type", sym->name, &sym->declared_at);
12195 /* Make sure the types of derived parameters are consistent. This
12196 type checking is deferred until resolution because the type may
12197 refer to a derived type from the host. */
12198 if (sym->ts.type == BT_DERIVED && sym->value
12199 && !gfc_compare_types (&sym->ts, &sym->value->ts))
12201 gfc_error ("Incompatible derived type in PARAMETER at %L",
12202 &sym->value->where);
12209 /* Do anything necessary to resolve a symbol. Right now, we just
12210 assume that an otherwise unknown symbol is a variable. This sort
12211 of thing commonly happens for symbols in module. */
12214 resolve_symbol (gfc_symbol *sym)
12216 int check_constant, mp_flag;
12217 gfc_symtree *symtree;
12218 gfc_symtree *this_symtree;
12221 symbol_attribute class_attr;
12222 gfc_array_spec *as;
12224 if (sym->attr.flavor == FL_UNKNOWN)
12227 /* If we find that a flavorless symbol is an interface in one of the
12228 parent namespaces, find its symtree in this namespace, free the
12229 symbol and set the symtree to point to the interface symbol. */
12230 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
12232 symtree = gfc_find_symtree (ns->sym_root, sym->name);
12233 if (symtree && (symtree->n.sym->generic ||
12234 (symtree->n.sym->attr.flavor == FL_PROCEDURE
12235 && sym->ns->construct_entities)))
12237 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
12239 gfc_release_symbol (sym);
12240 symtree->n.sym->refs++;
12241 this_symtree->n.sym = symtree->n.sym;
12246 /* Otherwise give it a flavor according to such attributes as
12248 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
12249 sym->attr.flavor = FL_VARIABLE;
12252 sym->attr.flavor = FL_PROCEDURE;
12253 if (sym->attr.dimension)
12254 sym->attr.function = 1;
12258 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
12259 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
12261 if (sym->attr.procedure && sym->ts.interface
12262 && sym->attr.if_source != IFSRC_DECL
12263 && resolve_procedure_interface (sym) == FAILURE)
12266 if (sym->attr.is_protected && !sym->attr.proc_pointer
12267 && (sym->attr.procedure || sym->attr.external))
12269 if (sym->attr.external)
12270 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12271 "at %L", &sym->declared_at);
12273 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12274 "at %L", &sym->declared_at);
12279 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
12282 /* Symbols that are module procedures with results (functions) have
12283 the types and array specification copied for type checking in
12284 procedures that call them, as well as for saving to a module
12285 file. These symbols can't stand the scrutiny that their results
12287 mp_flag = (sym->result != NULL && sym->result != sym);
12289 /* Make sure that the intrinsic is consistent with its internal
12290 representation. This needs to be done before assigning a default
12291 type to avoid spurious warnings. */
12292 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
12293 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
12296 /* Resolve associate names. */
12298 resolve_assoc_var (sym, true);
12300 /* Assign default type to symbols that need one and don't have one. */
12301 if (sym->ts.type == BT_UNKNOWN)
12303 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
12305 gfc_set_default_type (sym, 1, NULL);
12308 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
12309 && !sym->attr.function && !sym->attr.subroutine
12310 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
12311 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
12313 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
12315 /* The specific case of an external procedure should emit an error
12316 in the case that there is no implicit type. */
12318 gfc_set_default_type (sym, sym->attr.external, NULL);
12321 /* Result may be in another namespace. */
12322 resolve_symbol (sym->result);
12324 if (!sym->result->attr.proc_pointer)
12326 sym->ts = sym->result->ts;
12327 sym->as = gfc_copy_array_spec (sym->result->as);
12328 sym->attr.dimension = sym->result->attr.dimension;
12329 sym->attr.pointer = sym->result->attr.pointer;
12330 sym->attr.allocatable = sym->result->attr.allocatable;
12331 sym->attr.contiguous = sym->result->attr.contiguous;
12336 else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
12337 gfc_resolve_array_spec (sym->result->as, false);
12339 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
12341 as = CLASS_DATA (sym)->as;
12342 class_attr = CLASS_DATA (sym)->attr;
12343 class_attr.pointer = class_attr.class_pointer;
12347 class_attr = sym->attr;
12352 if (sym->attr.contiguous
12353 && (!class_attr.dimension
12354 || (as->type != AS_ASSUMED_SHAPE && !class_attr.pointer)))
12356 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12357 "array pointer or an assumed-shape array", sym->name,
12358 &sym->declared_at);
12362 /* Assumed size arrays and assumed shape arrays must be dummy
12363 arguments. Array-spec's of implied-shape should have been resolved to
12364 AS_EXPLICIT already. */
12368 gcc_assert (as->type != AS_IMPLIED_SHAPE);
12369 if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
12370 || as->type == AS_ASSUMED_SHAPE)
12371 && sym->attr.dummy == 0)
12373 if (as->type == AS_ASSUMED_SIZE)
12374 gfc_error ("Assumed size array at %L must be a dummy argument",
12375 &sym->declared_at);
12377 gfc_error ("Assumed shape array at %L must be a dummy argument",
12378 &sym->declared_at);
12383 /* Make sure symbols with known intent or optional are really dummy
12384 variable. Because of ENTRY statement, this has to be deferred
12385 until resolution time. */
12387 if (!sym->attr.dummy
12388 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
12390 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
12394 if (sym->attr.value && !sym->attr.dummy)
12396 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12397 "it is not a dummy argument", sym->name, &sym->declared_at);
12401 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
12403 gfc_charlen *cl = sym->ts.u.cl;
12404 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
12406 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12407 "attribute must have constant length",
12408 sym->name, &sym->declared_at);
12412 if (sym->ts.is_c_interop
12413 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
12415 gfc_error ("C interoperable character dummy variable '%s' at %L "
12416 "with VALUE attribute must have length one",
12417 sym->name, &sym->declared_at);
12422 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
12423 && sym->ts.u.derived->attr.generic)
12425 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
12426 if (!sym->ts.u.derived)
12428 gfc_error ("The derived type '%s' at %L is of type '%s', "
12429 "which has not been defined", sym->name,
12430 &sym->declared_at, sym->ts.u.derived->name);
12431 sym->ts.type = BT_UNKNOWN;
12436 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12437 do this for something that was implicitly typed because that is handled
12438 in gfc_set_default_type. Handle dummy arguments and procedure
12439 definitions separately. Also, anything that is use associated is not
12440 handled here but instead is handled in the module it is declared in.
12441 Finally, derived type definitions are allowed to be BIND(C) since that
12442 only implies that they're interoperable, and they are checked fully for
12443 interoperability when a variable is declared of that type. */
12444 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
12445 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
12446 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
12448 gfc_try t = SUCCESS;
12450 /* First, make sure the variable is declared at the
12451 module-level scope (J3/04-007, Section 15.3). */
12452 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
12453 sym->attr.in_common == 0)
12455 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12456 "is neither a COMMON block nor declared at the "
12457 "module level scope", sym->name, &(sym->declared_at));
12460 else if (sym->common_head != NULL)
12462 t = verify_com_block_vars_c_interop (sym->common_head);
12466 /* If type() declaration, we need to verify that the components
12467 of the given type are all C interoperable, etc. */
12468 if (sym->ts.type == BT_DERIVED &&
12469 sym->ts.u.derived->attr.is_c_interop != 1)
12471 /* Make sure the user marked the derived type as BIND(C). If
12472 not, call the verify routine. This could print an error
12473 for the derived type more than once if multiple variables
12474 of that type are declared. */
12475 if (sym->ts.u.derived->attr.is_bind_c != 1)
12476 verify_bind_c_derived_type (sym->ts.u.derived);
12480 /* Verify the variable itself as C interoperable if it
12481 is BIND(C). It is not possible for this to succeed if
12482 the verify_bind_c_derived_type failed, so don't have to handle
12483 any error returned by verify_bind_c_derived_type. */
12484 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
12485 sym->common_block);
12490 /* clear the is_bind_c flag to prevent reporting errors more than
12491 once if something failed. */
12492 sym->attr.is_bind_c = 0;
12497 /* If a derived type symbol has reached this point, without its
12498 type being declared, we have an error. Notice that most
12499 conditions that produce undefined derived types have already
12500 been dealt with. However, the likes of:
12501 implicit type(t) (t) ..... call foo (t) will get us here if
12502 the type is not declared in the scope of the implicit
12503 statement. Change the type to BT_UNKNOWN, both because it is so
12504 and to prevent an ICE. */
12505 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
12506 && sym->ts.u.derived->components == NULL
12507 && !sym->ts.u.derived->attr.zero_comp)
12509 gfc_error ("The derived type '%s' at %L is of type '%s', "
12510 "which has not been defined", sym->name,
12511 &sym->declared_at, sym->ts.u.derived->name);
12512 sym->ts.type = BT_UNKNOWN;
12516 /* Make sure that the derived type has been resolved and that the
12517 derived type is visible in the symbol's namespace, if it is a
12518 module function and is not PRIVATE. */
12519 if (sym->ts.type == BT_DERIVED
12520 && sym->ts.u.derived->attr.use_assoc
12521 && sym->ns->proc_name
12522 && sym->ns->proc_name->attr.flavor == FL_MODULE
12523 && resolve_fl_derived (sym->ts.u.derived) == FAILURE)
12526 /* Unless the derived-type declaration is use associated, Fortran 95
12527 does not allow public entries of private derived types.
12528 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12529 161 in 95-006r3. */
12530 if (sym->ts.type == BT_DERIVED
12531 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12532 && !sym->ts.u.derived->attr.use_assoc
12533 && gfc_check_symbol_access (sym)
12534 && !gfc_check_symbol_access (sym->ts.u.derived)
12535 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12536 "of PRIVATE derived type '%s'",
12537 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12538 : "variable", sym->name, &sym->declared_at,
12539 sym->ts.u.derived->name) == FAILURE)
12542 /* F2008, C1302. */
12543 if (sym->ts.type == BT_DERIVED
12544 && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
12545 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
12546 || sym->ts.u.derived->attr.lock_comp)
12547 && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
12549 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
12550 "type LOCK_TYPE must be a coarray", sym->name,
12551 &sym->declared_at);
12555 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12556 default initialization is defined (5.1.2.4.4). */
12557 if (sym->ts.type == BT_DERIVED
12559 && sym->attr.intent == INTENT_OUT
12561 && sym->as->type == AS_ASSUMED_SIZE)
12563 for (c = sym->ts.u.derived->components; c; c = c->next)
12565 if (c->initializer)
12567 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12568 "ASSUMED SIZE and so cannot have a default initializer",
12569 sym->name, &sym->declared_at);
12576 if (sym->ts.type == BT_DERIVED && sym->attr.dummy
12577 && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
12579 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
12580 "INTENT(OUT)", sym->name, &sym->declared_at);
12585 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12586 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12587 && CLASS_DATA (sym)->attr.coarray_comp))
12588 || class_attr.codimension)
12589 && (sym->attr.result || sym->result == sym))
12591 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12592 "a coarray component", sym->name, &sym->declared_at);
12597 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12598 && sym->ts.u.derived->ts.is_iso_c)
12600 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12601 "shall not be a coarray", sym->name, &sym->declared_at);
12606 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12607 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12608 && CLASS_DATA (sym)->attr.coarray_comp))
12609 && (class_attr.codimension || class_attr.pointer || class_attr.dimension
12610 || class_attr.allocatable))
12612 gfc_error ("Variable '%s' at %L with coarray component "
12613 "shall be a nonpointer, nonallocatable scalar",
12614 sym->name, &sym->declared_at);
12618 /* F2008, C526. The function-result case was handled above. */
12619 if (class_attr.codimension
12620 && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
12621 || sym->attr.select_type_temporary
12622 || sym->ns->save_all
12623 || sym->ns->proc_name->attr.flavor == FL_MODULE
12624 || sym->ns->proc_name->attr.is_main_program
12625 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12627 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
12628 "nor a dummy argument", sym->name, &sym->declared_at);
12632 else if (class_attr.codimension && !sym->attr.select_type_temporary
12633 && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
12635 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12636 "deferred shape", sym->name, &sym->declared_at);
12639 else if (class_attr.codimension && class_attr.allocatable && as
12640 && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
12642 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12643 "deferred shape", sym->name, &sym->declared_at);
12648 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12649 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12650 && CLASS_DATA (sym)->attr.coarray_comp))
12651 || (class_attr.codimension && class_attr.allocatable))
12652 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12654 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12655 "allocatable coarray or have coarray components",
12656 sym->name, &sym->declared_at);
12660 if (class_attr.codimension && sym->attr.dummy
12661 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12663 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12664 "procedure '%s'", sym->name, &sym->declared_at,
12665 sym->ns->proc_name->name);
12669 switch (sym->attr.flavor)
12672 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12677 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12682 if (resolve_fl_namelist (sym) == FAILURE)
12687 if (resolve_fl_parameter (sym) == FAILURE)
12695 /* Resolve array specifier. Check as well some constraints
12696 on COMMON blocks. */
12698 check_constant = sym->attr.in_common && !sym->attr.pointer;
12700 /* Set the formal_arg_flag so that check_conflict will not throw
12701 an error for host associated variables in the specification
12702 expression for an array_valued function. */
12703 if (sym->attr.function && sym->as)
12704 formal_arg_flag = 1;
12706 gfc_resolve_array_spec (sym->as, check_constant);
12708 formal_arg_flag = 0;
12710 /* Resolve formal namespaces. */
12711 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12712 && !sym->attr.contained && !sym->attr.intrinsic)
12713 gfc_resolve (sym->formal_ns);
12715 /* Make sure the formal namespace is present. */
12716 if (sym->formal && !sym->formal_ns)
12718 gfc_formal_arglist *formal = sym->formal;
12719 while (formal && !formal->sym)
12720 formal = formal->next;
12724 sym->formal_ns = formal->sym->ns;
12725 sym->formal_ns->refs++;
12729 /* Check threadprivate restrictions. */
12730 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12731 && (!sym->attr.in_common
12732 && sym->module == NULL
12733 && (sym->ns->proc_name == NULL
12734 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12735 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12737 /* If we have come this far we can apply default-initializers, as
12738 described in 14.7.5, to those variables that have not already
12739 been assigned one. */
12740 if (sym->ts.type == BT_DERIVED
12741 && sym->ns == gfc_current_ns
12743 && !sym->attr.allocatable
12744 && !sym->attr.alloc_comp)
12746 symbol_attribute *a = &sym->attr;
12748 if ((!a->save && !a->dummy && !a->pointer
12749 && !a->in_common && !a->use_assoc
12750 && (a->referenced || a->result)
12751 && !(a->function && sym != sym->result))
12752 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12753 apply_default_init (sym);
12756 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
12757 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
12758 && !CLASS_DATA (sym)->attr.class_pointer
12759 && !CLASS_DATA (sym)->attr.allocatable)
12760 apply_default_init (sym);
12762 /* If this symbol has a type-spec, check it. */
12763 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12764 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12765 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12771 /************* Resolve DATA statements *************/
12775 gfc_data_value *vnode;
12781 /* Advance the values structure to point to the next value in the data list. */
12784 next_data_value (void)
12786 while (mpz_cmp_ui (values.left, 0) == 0)
12789 if (values.vnode->next == NULL)
12792 values.vnode = values.vnode->next;
12793 mpz_set (values.left, values.vnode->repeat);
12801 check_data_variable (gfc_data_variable *var, locus *where)
12807 ar_type mark = AR_UNKNOWN;
12809 mpz_t section_index[GFC_MAX_DIMENSIONS];
12815 if (gfc_resolve_expr (var->expr) == FAILURE)
12819 mpz_init_set_si (offset, 0);
12822 if (e->expr_type != EXPR_VARIABLE)
12823 gfc_internal_error ("check_data_variable(): Bad expression");
12825 sym = e->symtree->n.sym;
12827 if (sym->ns->is_block_data && !sym->attr.in_common)
12829 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12830 sym->name, &sym->declared_at);
12833 if (e->ref == NULL && sym->as)
12835 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12836 " declaration", sym->name, where);
12840 has_pointer = sym->attr.pointer;
12842 if (gfc_is_coindexed (e))
12844 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name,
12849 for (ref = e->ref; ref; ref = ref->next)
12851 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12855 && ref->type == REF_ARRAY
12856 && ref->u.ar.type != AR_FULL)
12858 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12859 "be a full array", sym->name, where);
12864 if (e->rank == 0 || has_pointer)
12866 mpz_init_set_ui (size, 1);
12873 /* Find the array section reference. */
12874 for (ref = e->ref; ref; ref = ref->next)
12876 if (ref->type != REF_ARRAY)
12878 if (ref->u.ar.type == AR_ELEMENT)
12884 /* Set marks according to the reference pattern. */
12885 switch (ref->u.ar.type)
12893 /* Get the start position of array section. */
12894 gfc_get_section_index (ar, section_index, &offset);
12899 gcc_unreachable ();
12902 if (gfc_array_size (e, &size) == FAILURE)
12904 gfc_error ("Nonconstant array section at %L in DATA statement",
12906 mpz_clear (offset);
12913 while (mpz_cmp_ui (size, 0) > 0)
12915 if (next_data_value () == FAILURE)
12917 gfc_error ("DATA statement at %L has more variables than values",
12923 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12927 /* If we have more than one element left in the repeat count,
12928 and we have more than one element left in the target variable,
12929 then create a range assignment. */
12930 /* FIXME: Only done for full arrays for now, since array sections
12932 if (mark == AR_FULL && ref && ref->next == NULL
12933 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12937 if (mpz_cmp (size, values.left) >= 0)
12939 mpz_init_set (range, values.left);
12940 mpz_sub (size, size, values.left);
12941 mpz_set_ui (values.left, 0);
12945 mpz_init_set (range, size);
12946 mpz_sub (values.left, values.left, size);
12947 mpz_set_ui (size, 0);
12950 t = gfc_assign_data_value (var->expr, values.vnode->expr,
12953 mpz_add (offset, offset, range);
12960 /* Assign initial value to symbol. */
12963 mpz_sub_ui (values.left, values.left, 1);
12964 mpz_sub_ui (size, size, 1);
12966 t = gfc_assign_data_value (var->expr, values.vnode->expr,
12971 if (mark == AR_FULL)
12972 mpz_add_ui (offset, offset, 1);
12974 /* Modify the array section indexes and recalculate the offset
12975 for next element. */
12976 else if (mark == AR_SECTION)
12977 gfc_advance_section (section_index, ar, &offset);
12981 if (mark == AR_SECTION)
12983 for (i = 0; i < ar->dimen; i++)
12984 mpz_clear (section_index[i]);
12988 mpz_clear (offset);
12994 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
12996 /* Iterate over a list of elements in a DATA statement. */
12999 traverse_data_list (gfc_data_variable *var, locus *where)
13002 iterator_stack frame;
13003 gfc_expr *e, *start, *end, *step;
13004 gfc_try retval = SUCCESS;
13006 mpz_init (frame.value);
13009 start = gfc_copy_expr (var->iter.start);
13010 end = gfc_copy_expr (var->iter.end);
13011 step = gfc_copy_expr (var->iter.step);
13013 if (gfc_simplify_expr (start, 1) == FAILURE
13014 || start->expr_type != EXPR_CONSTANT)
13016 gfc_error ("start of implied-do loop at %L could not be "
13017 "simplified to a constant value", &start->where);
13021 if (gfc_simplify_expr (end, 1) == FAILURE
13022 || end->expr_type != EXPR_CONSTANT)
13024 gfc_error ("end of implied-do loop at %L could not be "
13025 "simplified to a constant value", &start->where);
13029 if (gfc_simplify_expr (step, 1) == FAILURE
13030 || step->expr_type != EXPR_CONSTANT)
13032 gfc_error ("step of implied-do loop at %L could not be "
13033 "simplified to a constant value", &start->where);
13038 mpz_set (trip, end->value.integer);
13039 mpz_sub (trip, trip, start->value.integer);
13040 mpz_add (trip, trip, step->value.integer);
13042 mpz_div (trip, trip, step->value.integer);
13044 mpz_set (frame.value, start->value.integer);
13046 frame.prev = iter_stack;
13047 frame.variable = var->iter.var->symtree;
13048 iter_stack = &frame;
13050 while (mpz_cmp_ui (trip, 0) > 0)
13052 if (traverse_data_var (var->list, where) == FAILURE)
13058 e = gfc_copy_expr (var->expr);
13059 if (gfc_simplify_expr (e, 1) == FAILURE)
13066 mpz_add (frame.value, frame.value, step->value.integer);
13068 mpz_sub_ui (trip, trip, 1);
13072 mpz_clear (frame.value);
13075 gfc_free_expr (start);
13076 gfc_free_expr (end);
13077 gfc_free_expr (step);
13079 iter_stack = frame.prev;
13084 /* Type resolve variables in the variable list of a DATA statement. */
13087 traverse_data_var (gfc_data_variable *var, locus *where)
13091 for (; var; var = var->next)
13093 if (var->expr == NULL)
13094 t = traverse_data_list (var, where);
13096 t = check_data_variable (var, where);
13106 /* Resolve the expressions and iterators associated with a data statement.
13107 This is separate from the assignment checking because data lists should
13108 only be resolved once. */
13111 resolve_data_variables (gfc_data_variable *d)
13113 for (; d; d = d->next)
13115 if (d->list == NULL)
13117 if (gfc_resolve_expr (d->expr) == FAILURE)
13122 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
13125 if (resolve_data_variables (d->list) == FAILURE)
13134 /* Resolve a single DATA statement. We implement this by storing a pointer to
13135 the value list into static variables, and then recursively traversing the
13136 variables list, expanding iterators and such. */
13139 resolve_data (gfc_data *d)
13142 if (resolve_data_variables (d->var) == FAILURE)
13145 values.vnode = d->value;
13146 if (d->value == NULL)
13147 mpz_set_ui (values.left, 0);
13149 mpz_set (values.left, d->value->repeat);
13151 if (traverse_data_var (d->var, &d->where) == FAILURE)
13154 /* At this point, we better not have any values left. */
13156 if (next_data_value () == SUCCESS)
13157 gfc_error ("DATA statement at %L has more values than variables",
13162 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13163 accessed by host or use association, is a dummy argument to a pure function,
13164 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13165 is storage associated with any such variable, shall not be used in the
13166 following contexts: (clients of this function). */
13168 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13169 procedure. Returns zero if assignment is OK, nonzero if there is a
13172 gfc_impure_variable (gfc_symbol *sym)
13177 if (sym->attr.use_assoc || sym->attr.in_common)
13180 /* Check if the symbol's ns is inside the pure procedure. */
13181 for (ns = gfc_current_ns; ns; ns = ns->parent)
13185 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
13189 proc = sym->ns->proc_name;
13190 if (sym->attr.dummy && gfc_pure (proc)
13191 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
13193 proc->attr.function))
13196 /* TODO: Sort out what can be storage associated, if anything, and include
13197 it here. In principle equivalences should be scanned but it does not
13198 seem to be possible to storage associate an impure variable this way. */
13203 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13204 current namespace is inside a pure procedure. */
13207 gfc_pure (gfc_symbol *sym)
13209 symbol_attribute attr;
13214 /* Check if the current namespace or one of its parents
13215 belongs to a pure procedure. */
13216 for (ns = gfc_current_ns; ns; ns = ns->parent)
13218 sym = ns->proc_name;
13222 if (attr.flavor == FL_PROCEDURE && attr.pure)
13230 return attr.flavor == FL_PROCEDURE && attr.pure;
13234 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13235 checks if the current namespace is implicitly pure. Note that this
13236 function returns false for a PURE procedure. */
13239 gfc_implicit_pure (gfc_symbol *sym)
13245 /* Check if the current procedure is implicit_pure. Walk up
13246 the procedure list until we find a procedure. */
13247 for (ns = gfc_current_ns; ns; ns = ns->parent)
13249 sym = ns->proc_name;
13253 if (sym->attr.flavor == FL_PROCEDURE)
13258 return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
13259 && !sym->attr.pure;
13263 /* Test whether the current procedure is elemental or not. */
13266 gfc_elemental (gfc_symbol *sym)
13268 symbol_attribute attr;
13271 sym = gfc_current_ns->proc_name;
13276 return attr.flavor == FL_PROCEDURE && attr.elemental;
13280 /* Warn about unused labels. */
13283 warn_unused_fortran_label (gfc_st_label *label)
13288 warn_unused_fortran_label (label->left);
13290 if (label->defined == ST_LABEL_UNKNOWN)
13293 switch (label->referenced)
13295 case ST_LABEL_UNKNOWN:
13296 gfc_warning ("Label %d at %L defined but not used", label->value,
13300 case ST_LABEL_BAD_TARGET:
13301 gfc_warning ("Label %d at %L defined but cannot be used",
13302 label->value, &label->where);
13309 warn_unused_fortran_label (label->right);
13313 /* Returns the sequence type of a symbol or sequence. */
13316 sequence_type (gfc_typespec ts)
13325 if (ts.u.derived->components == NULL)
13326 return SEQ_NONDEFAULT;
13328 result = sequence_type (ts.u.derived->components->ts);
13329 for (c = ts.u.derived->components->next; c; c = c->next)
13330 if (sequence_type (c->ts) != result)
13336 if (ts.kind != gfc_default_character_kind)
13337 return SEQ_NONDEFAULT;
13339 return SEQ_CHARACTER;
13342 if (ts.kind != gfc_default_integer_kind)
13343 return SEQ_NONDEFAULT;
13345 return SEQ_NUMERIC;
13348 if (!(ts.kind == gfc_default_real_kind
13349 || ts.kind == gfc_default_double_kind))
13350 return SEQ_NONDEFAULT;
13352 return SEQ_NUMERIC;
13355 if (ts.kind != gfc_default_complex_kind)
13356 return SEQ_NONDEFAULT;
13358 return SEQ_NUMERIC;
13361 if (ts.kind != gfc_default_logical_kind)
13362 return SEQ_NONDEFAULT;
13364 return SEQ_NUMERIC;
13367 return SEQ_NONDEFAULT;
13372 /* Resolve derived type EQUIVALENCE object. */
13375 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
13377 gfc_component *c = derived->components;
13382 /* Shall not be an object of nonsequence derived type. */
13383 if (!derived->attr.sequence)
13385 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13386 "attribute to be an EQUIVALENCE object", sym->name,
13391 /* Shall not have allocatable components. */
13392 if (derived->attr.alloc_comp)
13394 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13395 "components to be an EQUIVALENCE object",sym->name,
13400 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
13402 gfc_error ("Derived type variable '%s' at %L with default "
13403 "initialization cannot be in EQUIVALENCE with a variable "
13404 "in COMMON", sym->name, &e->where);
13408 for (; c ; c = c->next)
13410 if (c->ts.type == BT_DERIVED
13411 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
13414 /* Shall not be an object of sequence derived type containing a pointer
13415 in the structure. */
13416 if (c->attr.pointer)
13418 gfc_error ("Derived type variable '%s' at %L with pointer "
13419 "component(s) cannot be an EQUIVALENCE object",
13420 sym->name, &e->where);
13428 /* Resolve equivalence object.
13429 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13430 an allocatable array, an object of nonsequence derived type, an object of
13431 sequence derived type containing a pointer at any level of component
13432 selection, an automatic object, a function name, an entry name, a result
13433 name, a named constant, a structure component, or a subobject of any of
13434 the preceding objects. A substring shall not have length zero. A
13435 derived type shall not have components with default initialization nor
13436 shall two objects of an equivalence group be initialized.
13437 Either all or none of the objects shall have an protected attribute.
13438 The simple constraints are done in symbol.c(check_conflict) and the rest
13439 are implemented here. */
13442 resolve_equivalence (gfc_equiv *eq)
13445 gfc_symbol *first_sym;
13448 locus *last_where = NULL;
13449 seq_type eq_type, last_eq_type;
13450 gfc_typespec *last_ts;
13451 int object, cnt_protected;
13454 last_ts = &eq->expr->symtree->n.sym->ts;
13456 first_sym = eq->expr->symtree->n.sym;
13460 for (object = 1; eq; eq = eq->eq, object++)
13464 e->ts = e->symtree->n.sym->ts;
13465 /* match_varspec might not know yet if it is seeing
13466 array reference or substring reference, as it doesn't
13468 if (e->ref && e->ref->type == REF_ARRAY)
13470 gfc_ref *ref = e->ref;
13471 sym = e->symtree->n.sym;
13473 if (sym->attr.dimension)
13475 ref->u.ar.as = sym->as;
13479 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13480 if (e->ts.type == BT_CHARACTER
13482 && ref->type == REF_ARRAY
13483 && ref->u.ar.dimen == 1
13484 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
13485 && ref->u.ar.stride[0] == NULL)
13487 gfc_expr *start = ref->u.ar.start[0];
13488 gfc_expr *end = ref->u.ar.end[0];
13491 /* Optimize away the (:) reference. */
13492 if (start == NULL && end == NULL)
13495 e->ref = ref->next;
13497 e->ref->next = ref->next;
13502 ref->type = REF_SUBSTRING;
13504 start = gfc_get_int_expr (gfc_default_integer_kind,
13506 ref->u.ss.start = start;
13507 if (end == NULL && e->ts.u.cl)
13508 end = gfc_copy_expr (e->ts.u.cl->length);
13509 ref->u.ss.end = end;
13510 ref->u.ss.length = e->ts.u.cl;
13517 /* Any further ref is an error. */
13520 gcc_assert (ref->type == REF_ARRAY);
13521 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13527 if (gfc_resolve_expr (e) == FAILURE)
13530 sym = e->symtree->n.sym;
13532 if (sym->attr.is_protected)
13534 if (cnt_protected > 0 && cnt_protected != object)
13536 gfc_error ("Either all or none of the objects in the "
13537 "EQUIVALENCE set at %L shall have the "
13538 "PROTECTED attribute",
13543 /* Shall not equivalence common block variables in a PURE procedure. */
13544 if (sym->ns->proc_name
13545 && sym->ns->proc_name->attr.pure
13546 && sym->attr.in_common)
13548 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13549 "object in the pure procedure '%s'",
13550 sym->name, &e->where, sym->ns->proc_name->name);
13554 /* Shall not be a named constant. */
13555 if (e->expr_type == EXPR_CONSTANT)
13557 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13558 "object", sym->name, &e->where);
13562 if (e->ts.type == BT_DERIVED
13563 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
13566 /* Check that the types correspond correctly:
13568 A numeric sequence structure may be equivalenced to another sequence
13569 structure, an object of default integer type, default real type, double
13570 precision real type, default logical type such that components of the
13571 structure ultimately only become associated to objects of the same
13572 kind. A character sequence structure may be equivalenced to an object
13573 of default character kind or another character sequence structure.
13574 Other objects may be equivalenced only to objects of the same type and
13575 kind parameters. */
13577 /* Identical types are unconditionally OK. */
13578 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
13579 goto identical_types;
13581 last_eq_type = sequence_type (*last_ts);
13582 eq_type = sequence_type (sym->ts);
13584 /* Since the pair of objects is not of the same type, mixed or
13585 non-default sequences can be rejected. */
13587 msg = "Sequence %s with mixed components in EQUIVALENCE "
13588 "statement at %L with different type objects";
13590 && last_eq_type == SEQ_MIXED
13591 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
13593 || (eq_type == SEQ_MIXED
13594 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13595 &e->where) == FAILURE))
13598 msg = "Non-default type object or sequence %s in EQUIVALENCE "
13599 "statement at %L with objects of different type";
13601 && last_eq_type == SEQ_NONDEFAULT
13602 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
13603 last_where) == FAILURE)
13604 || (eq_type == SEQ_NONDEFAULT
13605 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13606 &e->where) == FAILURE))
13609 msg ="Non-CHARACTER object '%s' in default CHARACTER "
13610 "EQUIVALENCE statement at %L";
13611 if (last_eq_type == SEQ_CHARACTER
13612 && eq_type != SEQ_CHARACTER
13613 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13614 &e->where) == FAILURE)
13617 msg ="Non-NUMERIC object '%s' in default NUMERIC "
13618 "EQUIVALENCE statement at %L";
13619 if (last_eq_type == SEQ_NUMERIC
13620 && eq_type != SEQ_NUMERIC
13621 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13622 &e->where) == FAILURE)
13627 last_where = &e->where;
13632 /* Shall not be an automatic array. */
13633 if (e->ref->type == REF_ARRAY
13634 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
13636 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13637 "an EQUIVALENCE object", sym->name, &e->where);
13644 /* Shall not be a structure component. */
13645 if (r->type == REF_COMPONENT)
13647 gfc_error ("Structure component '%s' at %L cannot be an "
13648 "EQUIVALENCE object",
13649 r->u.c.component->name, &e->where);
13653 /* A substring shall not have length zero. */
13654 if (r->type == REF_SUBSTRING)
13656 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13658 gfc_error ("Substring at %L has length zero",
13659 &r->u.ss.start->where);
13669 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13672 resolve_fntype (gfc_namespace *ns)
13674 gfc_entry_list *el;
13677 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13680 /* If there are any entries, ns->proc_name is the entry master
13681 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13683 sym = ns->entries->sym;
13685 sym = ns->proc_name;
13686 if (sym->result == sym
13687 && sym->ts.type == BT_UNKNOWN
13688 && gfc_set_default_type (sym, 0, NULL) == FAILURE
13689 && !sym->attr.untyped)
13691 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13692 sym->name, &sym->declared_at);
13693 sym->attr.untyped = 1;
13696 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13697 && !sym->attr.contained
13698 && !gfc_check_symbol_access (sym->ts.u.derived)
13699 && gfc_check_symbol_access (sym))
13701 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13702 "%L of PRIVATE type '%s'", sym->name,
13703 &sym->declared_at, sym->ts.u.derived->name);
13707 for (el = ns->entries->next; el; el = el->next)
13709 if (el->sym->result == el->sym
13710 && el->sym->ts.type == BT_UNKNOWN
13711 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13712 && !el->sym->attr.untyped)
13714 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13715 el->sym->name, &el->sym->declared_at);
13716 el->sym->attr.untyped = 1;
13722 /* 12.3.2.1.1 Defined operators. */
13725 check_uop_procedure (gfc_symbol *sym, locus where)
13727 gfc_formal_arglist *formal;
13729 if (!sym->attr.function)
13731 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13732 sym->name, &where);
13736 if (sym->ts.type == BT_CHARACTER
13737 && !(sym->ts.u.cl && sym->ts.u.cl->length)
13738 && !(sym->result && sym->result->ts.u.cl
13739 && sym->result->ts.u.cl->length))
13741 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13742 "character length", sym->name, &where);
13746 formal = sym->formal;
13747 if (!formal || !formal->sym)
13749 gfc_error ("User operator procedure '%s' at %L must have at least "
13750 "one argument", sym->name, &where);
13754 if (formal->sym->attr.intent != INTENT_IN)
13756 gfc_error ("First argument of operator interface at %L must be "
13757 "INTENT(IN)", &where);
13761 if (formal->sym->attr.optional)
13763 gfc_error ("First argument of operator interface at %L cannot be "
13764 "optional", &where);
13768 formal = formal->next;
13769 if (!formal || !formal->sym)
13772 if (formal->sym->attr.intent != INTENT_IN)
13774 gfc_error ("Second argument of operator interface at %L must be "
13775 "INTENT(IN)", &where);
13779 if (formal->sym->attr.optional)
13781 gfc_error ("Second argument of operator interface at %L cannot be "
13782 "optional", &where);
13788 gfc_error ("Operator interface at %L must have, at most, two "
13789 "arguments", &where);
13797 gfc_resolve_uops (gfc_symtree *symtree)
13799 gfc_interface *itr;
13801 if (symtree == NULL)
13804 gfc_resolve_uops (symtree->left);
13805 gfc_resolve_uops (symtree->right);
13807 for (itr = symtree->n.uop->op; itr; itr = itr->next)
13808 check_uop_procedure (itr->sym, itr->sym->declared_at);
13812 /* Examine all of the expressions associated with a program unit,
13813 assign types to all intermediate expressions, make sure that all
13814 assignments are to compatible types and figure out which names
13815 refer to which functions or subroutines. It doesn't check code
13816 block, which is handled by resolve_code. */
13819 resolve_types (gfc_namespace *ns)
13825 gfc_namespace* old_ns = gfc_current_ns;
13827 /* Check that all IMPLICIT types are ok. */
13828 if (!ns->seen_implicit_none)
13831 for (letter = 0; letter != GFC_LETTERS; ++letter)
13832 if (ns->set_flag[letter]
13833 && resolve_typespec_used (&ns->default_type[letter],
13834 &ns->implicit_loc[letter],
13839 gfc_current_ns = ns;
13841 resolve_entries (ns);
13843 resolve_common_vars (ns->blank_common.head, false);
13844 resolve_common_blocks (ns->common_root);
13846 resolve_contained_functions (ns);
13848 if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
13849 && ns->proc_name->attr.if_source == IFSRC_IFBODY)
13850 resolve_formal_arglist (ns->proc_name);
13852 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13854 for (cl = ns->cl_list; cl; cl = cl->next)
13855 resolve_charlen (cl);
13857 gfc_traverse_ns (ns, resolve_symbol);
13859 resolve_fntype (ns);
13861 for (n = ns->contained; n; n = n->sibling)
13863 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13864 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13865 "also be PURE", n->proc_name->name,
13866 &n->proc_name->declared_at);
13872 do_concurrent_flag = 0;
13873 gfc_check_interfaces (ns);
13875 gfc_traverse_ns (ns, resolve_values);
13881 for (d = ns->data; d; d = d->next)
13885 gfc_traverse_ns (ns, gfc_formalize_init_value);
13887 gfc_traverse_ns (ns, gfc_verify_binding_labels);
13889 if (ns->common_root != NULL)
13890 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13892 for (eq = ns->equiv; eq; eq = eq->next)
13893 resolve_equivalence (eq);
13895 /* Warn about unused labels. */
13896 if (warn_unused_label)
13897 warn_unused_fortran_label (ns->st_labels);
13899 gfc_resolve_uops (ns->uop_root);
13901 gfc_current_ns = old_ns;
13905 /* Call resolve_code recursively. */
13908 resolve_codes (gfc_namespace *ns)
13911 bitmap_obstack old_obstack;
13913 if (ns->resolved == 1)
13916 for (n = ns->contained; n; n = n->sibling)
13919 gfc_current_ns = ns;
13921 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13922 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13925 /* Set to an out of range value. */
13926 current_entry_id = -1;
13928 old_obstack = labels_obstack;
13929 bitmap_obstack_initialize (&labels_obstack);
13931 resolve_code (ns->code, ns);
13933 bitmap_obstack_release (&labels_obstack);
13934 labels_obstack = old_obstack;
13938 /* This function is called after a complete program unit has been compiled.
13939 Its purpose is to examine all of the expressions associated with a program
13940 unit, assign types to all intermediate expressions, make sure that all
13941 assignments are to compatible types and figure out which names refer to
13942 which functions or subroutines. */
13945 gfc_resolve (gfc_namespace *ns)
13947 gfc_namespace *old_ns;
13948 code_stack *old_cs_base;
13954 old_ns = gfc_current_ns;
13955 old_cs_base = cs_base;
13957 resolve_types (ns);
13958 resolve_codes (ns);
13960 gfc_current_ns = old_ns;
13961 cs_base = old_cs_base;
13964 gfc_run_passes (ns);