1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
29 #include "arith.h" /* For gfc_compare_expr(). */
30 #include "dependency.h"
32 #include "target-memory.h" /* for gfc_simplify_transfer */
33 #include "constructor.h"
35 /* Types used in equivalence statements. */
39 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
43 /* Stack to keep track of the nesting of blocks as we move through the
44 code. See resolve_branch() and resolve_code(). */
46 typedef struct code_stack
48 struct gfc_code *head, *current;
49 struct code_stack *prev;
51 /* This bitmap keeps track of the targets valid for a branch from
52 inside this block except for END {IF|SELECT}s of enclosing
54 bitmap reachable_labels;
58 static code_stack *cs_base = NULL;
61 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
63 static int forall_flag;
64 static int do_concurrent_flag;
66 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
68 static int omp_workshare_flag;
70 /* Nonzero if we are processing a formal arglist. The corresponding function
71 resets the flag each time that it is read. */
72 static int formal_arg_flag = 0;
74 /* True if we are resolving a specification expression. */
75 static int specification_expr = 0;
77 /* The id of the last entry seen. */
78 static int current_entry_id;
80 /* We use bitmaps to determine if a branch target is valid. */
81 static bitmap_obstack labels_obstack;
83 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
84 static bool inquiry_argument = false;
87 gfc_is_formal_arg (void)
89 return formal_arg_flag;
92 /* Is the symbol host associated? */
94 is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
96 for (ns = ns->parent; ns; ns = ns->parent)
105 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
106 an ABSTRACT derived-type. If where is not NULL, an error message with that
107 locus is printed, optionally using name. */
110 resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
112 if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
117 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
118 name, where, ts->u.derived->name);
120 gfc_error ("ABSTRACT type '%s' used at %L",
121 ts->u.derived->name, where);
131 static void resolve_symbol (gfc_symbol *sym);
132 static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc);
135 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
138 resolve_procedure_interface (gfc_symbol *sym)
140 if (sym->ts.interface == sym)
142 gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
143 sym->name, &sym->declared_at);
146 if (sym->ts.interface->attr.procedure)
148 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
149 "in a later PROCEDURE statement", sym->ts.interface->name,
150 sym->name, &sym->declared_at);
154 /* Get the attributes from the interface (now resolved). */
155 if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
157 gfc_symbol *ifc = sym->ts.interface;
158 resolve_symbol (ifc);
160 if (ifc->attr.intrinsic)
161 resolve_intrinsic (ifc, &ifc->declared_at);
165 sym->ts = ifc->result->ts;
170 sym->ts.interface = ifc;
171 sym->attr.function = ifc->attr.function;
172 sym->attr.subroutine = ifc->attr.subroutine;
173 gfc_copy_formal_args (sym, ifc);
175 sym->attr.allocatable = ifc->attr.allocatable;
176 sym->attr.pointer = ifc->attr.pointer;
177 sym->attr.pure = ifc->attr.pure;
178 sym->attr.elemental = ifc->attr.elemental;
179 sym->attr.dimension = ifc->attr.dimension;
180 sym->attr.contiguous = ifc->attr.contiguous;
181 sym->attr.recursive = ifc->attr.recursive;
182 sym->attr.always_explicit = ifc->attr.always_explicit;
183 sym->attr.ext_attr |= ifc->attr.ext_attr;
184 sym->attr.is_bind_c = ifc->attr.is_bind_c;
185 /* Copy array spec. */
186 sym->as = gfc_copy_array_spec (ifc->as);
190 for (i = 0; i < sym->as->rank; i++)
192 gfc_expr_replace_symbols (sym->as->lower[i], sym);
193 gfc_expr_replace_symbols (sym->as->upper[i], sym);
196 /* Copy char length. */
197 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
199 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
200 gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
201 if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
202 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
206 else if (sym->ts.interface->name[0] != '\0')
208 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
209 sym->ts.interface->name, sym->name, &sym->declared_at);
217 /* Resolve types of formal argument lists. These have to be done early so that
218 the formal argument lists of module procedures can be copied to the
219 containing module before the individual procedures are resolved
220 individually. We also resolve argument lists of procedures in interface
221 blocks because they are self-contained scoping units.
223 Since a dummy argument cannot be a non-dummy procedure, the only
224 resort left for untyped names are the IMPLICIT types. */
227 resolve_formal_arglist (gfc_symbol *proc)
229 gfc_formal_arglist *f;
233 if (proc->result != NULL)
238 if (gfc_elemental (proc)
239 || sym->attr.pointer || sym->attr.allocatable
240 || (sym->as && sym->as->rank > 0))
242 proc->attr.always_explicit = 1;
243 sym->attr.always_explicit = 1;
248 for (f = proc->formal; f; f = f->next)
254 /* Alternate return placeholder. */
255 if (gfc_elemental (proc))
256 gfc_error ("Alternate return specifier in elemental subroutine "
257 "'%s' at %L is not allowed", proc->name,
259 if (proc->attr.function)
260 gfc_error ("Alternate return specifier in function "
261 "'%s' at %L is not allowed", proc->name,
265 else if (sym->attr.procedure && sym->ts.interface
266 && sym->attr.if_source != IFSRC_DECL)
267 resolve_procedure_interface (sym);
269 if (sym->attr.if_source != IFSRC_UNKNOWN)
270 resolve_formal_arglist (sym);
272 if (sym->attr.subroutine || sym->attr.external)
274 if (sym->attr.flavor == FL_UNKNOWN)
275 gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
279 if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
280 && (!sym->attr.function || sym->result == sym))
281 gfc_set_default_type (sym, 1, sym->ns);
284 gfc_resolve_array_spec (sym->as, 0);
286 /* We can't tell if an array with dimension (:) is assumed or deferred
287 shape until we know if it has the pointer or allocatable attributes.
289 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
290 && !(sym->attr.pointer || sym->attr.allocatable)
291 && sym->attr.flavor != FL_PROCEDURE)
293 sym->as->type = AS_ASSUMED_SHAPE;
294 for (i = 0; i < sym->as->rank; i++)
295 sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
299 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
300 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
301 || sym->attr.optional)
303 proc->attr.always_explicit = 1;
305 proc->result->attr.always_explicit = 1;
308 /* If the flavor is unknown at this point, it has to be a variable.
309 A procedure specification would have already set the type. */
311 if (sym->attr.flavor == FL_UNKNOWN)
312 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
316 if (sym->attr.flavor == FL_PROCEDURE)
321 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
322 "also be PURE", sym->name, &sym->declared_at);
326 else if (!sym->attr.pointer)
328 if (proc->attr.function && sym->attr.intent != INTENT_IN)
331 gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s'"
332 " of pure function '%s' at %L with VALUE "
333 "attribute but without INTENT(IN)",
334 sym->name, proc->name, &sym->declared_at);
336 gfc_error ("Argument '%s' of pure function '%s' at %L must "
337 "be INTENT(IN) or VALUE", sym->name, proc->name,
341 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
344 gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s'"
345 " of pure subroutine '%s' at %L with VALUE "
346 "attribute but without INTENT", sym->name,
347 proc->name, &sym->declared_at);
349 gfc_error ("Argument '%s' of pure subroutine '%s' at %L "
350 "must have its INTENT specified or have the "
351 "VALUE attribute", sym->name, proc->name,
357 if (proc->attr.implicit_pure)
359 if (sym->attr.flavor == FL_PROCEDURE)
362 proc->attr.implicit_pure = 0;
364 else if (!sym->attr.pointer)
366 if (proc->attr.function && sym->attr.intent != INTENT_IN)
367 proc->attr.implicit_pure = 0;
369 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
370 proc->attr.implicit_pure = 0;
374 if (gfc_elemental (proc))
377 if (sym->attr.codimension
378 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
379 && CLASS_DATA (sym)->attr.codimension))
381 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
382 "procedure", sym->name, &sym->declared_at);
386 if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
387 && CLASS_DATA (sym)->as))
389 gfc_error ("Argument '%s' of elemental procedure at %L must "
390 "be scalar", sym->name, &sym->declared_at);
394 if (sym->attr.allocatable
395 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
396 && CLASS_DATA (sym)->attr.allocatable))
398 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
399 "have the ALLOCATABLE attribute", sym->name,
404 if (sym->attr.pointer)
406 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
407 "have the POINTER attribute", sym->name,
412 if (sym->attr.flavor == FL_PROCEDURE)
414 gfc_error ("Dummy procedure '%s' not allowed in elemental "
415 "procedure '%s' at %L", sym->name, proc->name,
420 if (sym->attr.intent == INTENT_UNKNOWN)
422 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
423 "have its INTENT specified", sym->name, proc->name,
429 /* Each dummy shall be specified to be scalar. */
430 if (proc->attr.proc == PROC_ST_FUNCTION)
434 gfc_error ("Argument '%s' of statement function at %L must "
435 "be scalar", sym->name, &sym->declared_at);
439 if (sym->ts.type == BT_CHARACTER)
441 gfc_charlen *cl = sym->ts.u.cl;
442 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
444 gfc_error ("Character-valued argument '%s' of statement "
445 "function at %L must have constant length",
446 sym->name, &sym->declared_at);
456 /* Work function called when searching for symbols that have argument lists
457 associated with them. */
460 find_arglists (gfc_symbol *sym)
462 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
463 || sym->attr.flavor == FL_DERIVED)
466 resolve_formal_arglist (sym);
470 /* Given a namespace, resolve all formal argument lists within the namespace.
474 resolve_formal_arglists (gfc_namespace *ns)
479 gfc_traverse_ns (ns, find_arglists);
484 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
488 /* If this namespace is not a function or an entry master function,
490 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
491 || sym->attr.entry_master)
494 /* Try to find out of what the return type is. */
495 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
497 t = gfc_set_default_type (sym->result, 0, ns);
499 if (t == FAILURE && !sym->result->attr.untyped)
501 if (sym->result == sym)
502 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
503 sym->name, &sym->declared_at);
504 else if (!sym->result->attr.proc_pointer)
505 gfc_error ("Result '%s' of contained function '%s' at %L has "
506 "no IMPLICIT type", sym->result->name, sym->name,
507 &sym->result->declared_at);
508 sym->result->attr.untyped = 1;
512 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
513 type, lists the only ways a character length value of * can be used:
514 dummy arguments of procedures, named constants, and function results
515 in external functions. Internal function results and results of module
516 procedures are not on this list, ergo, not permitted. */
518 if (sym->result->ts.type == BT_CHARACTER)
520 gfc_charlen *cl = sym->result->ts.u.cl;
521 if ((!cl || !cl->length) && !sym->result->ts.deferred)
523 /* See if this is a module-procedure and adapt error message
526 gcc_assert (ns->parent && ns->parent->proc_name);
527 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
529 gfc_error ("Character-valued %s '%s' at %L must not be"
531 module_proc ? _("module procedure")
532 : _("internal function"),
533 sym->name, &sym->declared_at);
539 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
540 introduce duplicates. */
543 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
545 gfc_formal_arglist *f, *new_arglist;
548 for (; new_args != NULL; new_args = new_args->next)
550 new_sym = new_args->sym;
551 /* See if this arg is already in the formal argument list. */
552 for (f = proc->formal; f; f = f->next)
554 if (new_sym == f->sym)
561 /* Add a new argument. Argument order is not important. */
562 new_arglist = gfc_get_formal_arglist ();
563 new_arglist->sym = new_sym;
564 new_arglist->next = proc->formal;
565 proc->formal = new_arglist;
570 /* Flag the arguments that are not present in all entries. */
573 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
575 gfc_formal_arglist *f, *head;
578 for (f = proc->formal; f; f = f->next)
583 for (new_args = head; new_args; new_args = new_args->next)
585 if (new_args->sym == f->sym)
592 f->sym->attr.not_always_present = 1;
597 /* Resolve alternate entry points. If a symbol has multiple entry points we
598 create a new master symbol for the main routine, and turn the existing
599 symbol into an entry point. */
602 resolve_entries (gfc_namespace *ns)
604 gfc_namespace *old_ns;
608 char name[GFC_MAX_SYMBOL_LEN + 1];
609 static int master_count = 0;
611 if (ns->proc_name == NULL)
614 /* No need to do anything if this procedure doesn't have alternate entry
619 /* We may already have resolved alternate entry points. */
620 if (ns->proc_name->attr.entry_master)
623 /* If this isn't a procedure something has gone horribly wrong. */
624 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
626 /* Remember the current namespace. */
627 old_ns = gfc_current_ns;
631 /* Add the main entry point to the list of entry points. */
632 el = gfc_get_entry_list ();
633 el->sym = ns->proc_name;
635 el->next = ns->entries;
637 ns->proc_name->attr.entry = 1;
639 /* If it is a module function, it needs to be in the right namespace
640 so that gfc_get_fake_result_decl can gather up the results. The
641 need for this arose in get_proc_name, where these beasts were
642 left in their own namespace, to keep prior references linked to
643 the entry declaration.*/
644 if (ns->proc_name->attr.function
645 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
648 /* Do the same for entries where the master is not a module
649 procedure. These are retained in the module namespace because
650 of the module procedure declaration. */
651 for (el = el->next; el; el = el->next)
652 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
653 && el->sym->attr.mod_proc)
657 /* Add an entry statement for it. */
664 /* Create a new symbol for the master function. */
665 /* Give the internal function a unique name (within this file).
666 Also include the function name so the user has some hope of figuring
667 out what is going on. */
668 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
669 master_count++, ns->proc_name->name);
670 gfc_get_ha_symbol (name, &proc);
671 gcc_assert (proc != NULL);
673 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
674 if (ns->proc_name->attr.subroutine)
675 gfc_add_subroutine (&proc->attr, proc->name, NULL);
679 gfc_typespec *ts, *fts;
680 gfc_array_spec *as, *fas;
681 gfc_add_function (&proc->attr, proc->name, NULL);
683 fas = ns->entries->sym->as;
684 fas = fas ? fas : ns->entries->sym->result->as;
685 fts = &ns->entries->sym->result->ts;
686 if (fts->type == BT_UNKNOWN)
687 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
688 for (el = ns->entries->next; el; el = el->next)
690 ts = &el->sym->result->ts;
692 as = as ? as : el->sym->result->as;
693 if (ts->type == BT_UNKNOWN)
694 ts = gfc_get_default_type (el->sym->result->name, NULL);
696 if (! gfc_compare_types (ts, fts)
697 || (el->sym->result->attr.dimension
698 != ns->entries->sym->result->attr.dimension)
699 || (el->sym->result->attr.pointer
700 != ns->entries->sym->result->attr.pointer))
702 else if (as && fas && ns->entries->sym->result != el->sym->result
703 && gfc_compare_array_spec (as, fas) == 0)
704 gfc_error ("Function %s at %L has entries with mismatched "
705 "array specifications", ns->entries->sym->name,
706 &ns->entries->sym->declared_at);
707 /* The characteristics need to match and thus both need to have
708 the same string length, i.e. both len=*, or both len=4.
709 Having both len=<variable> is also possible, but difficult to
710 check at compile time. */
711 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
712 && (((ts->u.cl->length && !fts->u.cl->length)
713 ||(!ts->u.cl->length && fts->u.cl->length))
715 && ts->u.cl->length->expr_type
716 != fts->u.cl->length->expr_type)
718 && ts->u.cl->length->expr_type == EXPR_CONSTANT
719 && mpz_cmp (ts->u.cl->length->value.integer,
720 fts->u.cl->length->value.integer) != 0)))
721 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
722 "entries returning variables of different "
723 "string lengths", ns->entries->sym->name,
724 &ns->entries->sym->declared_at);
729 sym = ns->entries->sym->result;
730 /* All result types the same. */
732 if (sym->attr.dimension)
733 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
734 if (sym->attr.pointer)
735 gfc_add_pointer (&proc->attr, NULL);
739 /* Otherwise the result will be passed through a union by
741 proc->attr.mixed_entry_master = 1;
742 for (el = ns->entries; el; el = el->next)
744 sym = el->sym->result;
745 if (sym->attr.dimension)
747 if (el == ns->entries)
748 gfc_error ("FUNCTION result %s can't be an array in "
749 "FUNCTION %s at %L", sym->name,
750 ns->entries->sym->name, &sym->declared_at);
752 gfc_error ("ENTRY result %s can't be an array in "
753 "FUNCTION %s at %L", sym->name,
754 ns->entries->sym->name, &sym->declared_at);
756 else if (sym->attr.pointer)
758 if (el == ns->entries)
759 gfc_error ("FUNCTION result %s can't be a POINTER in "
760 "FUNCTION %s at %L", sym->name,
761 ns->entries->sym->name, &sym->declared_at);
763 gfc_error ("ENTRY result %s can't be a POINTER in "
764 "FUNCTION %s at %L", sym->name,
765 ns->entries->sym->name, &sym->declared_at);
770 if (ts->type == BT_UNKNOWN)
771 ts = gfc_get_default_type (sym->name, NULL);
775 if (ts->kind == gfc_default_integer_kind)
779 if (ts->kind == gfc_default_real_kind
780 || ts->kind == gfc_default_double_kind)
784 if (ts->kind == gfc_default_complex_kind)
788 if (ts->kind == gfc_default_logical_kind)
792 /* We will issue error elsewhere. */
800 if (el == ns->entries)
801 gfc_error ("FUNCTION result %s can't be of type %s "
802 "in FUNCTION %s at %L", sym->name,
803 gfc_typename (ts), ns->entries->sym->name,
806 gfc_error ("ENTRY result %s can't be of type %s "
807 "in FUNCTION %s at %L", sym->name,
808 gfc_typename (ts), ns->entries->sym->name,
815 proc->attr.access = ACCESS_PRIVATE;
816 proc->attr.entry_master = 1;
818 /* Merge all the entry point arguments. */
819 for (el = ns->entries; el; el = el->next)
820 merge_argument_lists (proc, el->sym->formal);
822 /* Check the master formal arguments for any that are not
823 present in all entry points. */
824 for (el = ns->entries; el; el = el->next)
825 check_argument_lists (proc, el->sym->formal);
827 /* Use the master function for the function body. */
828 ns->proc_name = proc;
830 /* Finalize the new symbols. */
831 gfc_commit_symbols ();
833 /* Restore the original namespace. */
834 gfc_current_ns = old_ns;
838 /* Resolve common variables. */
840 resolve_common_vars (gfc_symbol *sym, bool named_common)
842 gfc_symbol *csym = sym;
844 for (; csym; csym = csym->common_next)
846 if (csym->value || csym->attr.data)
848 if (!csym->ns->is_block_data)
849 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
850 "but only in BLOCK DATA initialization is "
851 "allowed", csym->name, &csym->declared_at);
852 else if (!named_common)
853 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
854 "in a blank COMMON but initialization is only "
855 "allowed in named common blocks", csym->name,
859 if (csym->ts.type != BT_DERIVED)
862 if (!(csym->ts.u.derived->attr.sequence
863 || csym->ts.u.derived->attr.is_bind_c))
864 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
865 "has neither the SEQUENCE nor the BIND(C) "
866 "attribute", csym->name, &csym->declared_at);
867 if (csym->ts.u.derived->attr.alloc_comp)
868 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
869 "has an ultimate component that is "
870 "allocatable", csym->name, &csym->declared_at);
871 if (gfc_has_default_initializer (csym->ts.u.derived))
872 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
873 "may not have default initializer", csym->name,
876 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
877 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
881 /* Resolve common blocks. */
883 resolve_common_blocks (gfc_symtree *common_root)
887 if (common_root == NULL)
890 if (common_root->left)
891 resolve_common_blocks (common_root->left);
892 if (common_root->right)
893 resolve_common_blocks (common_root->right);
895 resolve_common_vars (common_root->n.common->head, true);
897 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
901 if (sym->attr.flavor == FL_PARAMETER)
902 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
903 sym->name, &common_root->n.common->where, &sym->declared_at);
905 if (sym->attr.external)
906 gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
907 sym->name, &common_root->n.common->where);
909 if (sym->attr.intrinsic)
910 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
911 sym->name, &common_root->n.common->where);
912 else if (sym->attr.result
913 || gfc_is_function_return_value (sym, gfc_current_ns))
914 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
915 "that is also a function result", sym->name,
916 &common_root->n.common->where);
917 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
918 && sym->attr.proc != PROC_ST_FUNCTION)
919 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
920 "that is also a global procedure", sym->name,
921 &common_root->n.common->where);
925 /* Resolve contained function types. Because contained functions can call one
926 another, they have to be worked out before any of the contained procedures
929 The good news is that if a function doesn't already have a type, the only
930 way it can get one is through an IMPLICIT type or a RESULT variable, because
931 by definition contained functions are contained namespace they're contained
932 in, not in a sibling or parent namespace. */
935 resolve_contained_functions (gfc_namespace *ns)
937 gfc_namespace *child;
940 resolve_formal_arglists (ns);
942 for (child = ns->contained; child; child = child->sibling)
944 /* Resolve alternate entry points first. */
945 resolve_entries (child);
947 /* Then check function return types. */
948 resolve_contained_fntype (child->proc_name, child);
949 for (el = child->entries; el; el = el->next)
950 resolve_contained_fntype (el->sym, child);
955 static gfc_try resolve_fl_derived0 (gfc_symbol *sym);
958 /* Resolve all of the elements of a structure constructor and make sure that
959 the types are correct. The 'init' flag indicates that the given
960 constructor is an initializer. */
963 resolve_structure_cons (gfc_expr *expr, int init)
965 gfc_constructor *cons;
972 if (expr->ts.type == BT_DERIVED)
973 resolve_fl_derived0 (expr->ts.u.derived);
975 cons = gfc_constructor_first (expr->value.constructor);
977 /* See if the user is trying to invoke a structure constructor for one of
978 the iso_c_binding derived types. */
979 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
980 && expr->ts.u.derived->ts.is_iso_c && cons
981 && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
983 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
984 expr->ts.u.derived->name, &(expr->where));
988 /* Return if structure constructor is c_null_(fun)prt. */
989 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
990 && expr->ts.u.derived->ts.is_iso_c && cons
991 && cons->expr && cons->expr->expr_type == EXPR_NULL)
994 /* A constructor may have references if it is the result of substituting a
995 parameter variable. In this case we just pull out the component we
998 comp = expr->ref->u.c.sym->components;
1000 comp = expr->ts.u.derived->components;
1002 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1009 if (gfc_resolve_expr (cons->expr) == FAILURE)
1015 rank = comp->as ? comp->as->rank : 0;
1016 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
1017 && (comp->attr.allocatable || cons->expr->rank))
1019 gfc_error ("The rank of the element in the structure "
1020 "constructor at %L does not match that of the "
1021 "component (%d/%d)", &cons->expr->where,
1022 cons->expr->rank, rank);
1026 /* If we don't have the right type, try to convert it. */
1028 if (!comp->attr.proc_pointer &&
1029 !gfc_compare_types (&cons->expr->ts, &comp->ts))
1032 if (strcmp (comp->name, "_extends") == 0)
1034 /* Can afford to be brutal with the _extends initializer.
1035 The derived type can get lost because it is PRIVATE
1036 but it is not usage constrained by the standard. */
1037 cons->expr->ts = comp->ts;
1040 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1041 gfc_error ("The element in the structure constructor at %L, "
1042 "for pointer component '%s', is %s but should be %s",
1043 &cons->expr->where, comp->name,
1044 gfc_basic_typename (cons->expr->ts.type),
1045 gfc_basic_typename (comp->ts.type));
1047 t = gfc_convert_type (cons->expr, &comp->ts, 1);
1050 /* For strings, the length of the constructor should be the same as
1051 the one of the structure, ensure this if the lengths are known at
1052 compile time and when we are dealing with PARAMETER or structure
1054 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1055 && comp->ts.u.cl->length
1056 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1057 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1058 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1059 && cons->expr->rank != 0
1060 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1061 comp->ts.u.cl->length->value.integer) != 0)
1063 if (cons->expr->expr_type == EXPR_VARIABLE
1064 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1066 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1067 to make use of the gfc_resolve_character_array_constructor
1068 machinery. The expression is later simplified away to
1069 an array of string literals. */
1070 gfc_expr *para = cons->expr;
1071 cons->expr = gfc_get_expr ();
1072 cons->expr->ts = para->ts;
1073 cons->expr->where = para->where;
1074 cons->expr->expr_type = EXPR_ARRAY;
1075 cons->expr->rank = para->rank;
1076 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1077 gfc_constructor_append_expr (&cons->expr->value.constructor,
1078 para, &cons->expr->where);
1080 if (cons->expr->expr_type == EXPR_ARRAY)
1083 p = gfc_constructor_first (cons->expr->value.constructor);
1084 if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
1086 gfc_charlen *cl, *cl2;
1089 for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
1091 if (cl == cons->expr->ts.u.cl)
1099 cl2->next = cl->next;
1101 gfc_free_expr (cl->length);
1105 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1106 cons->expr->ts.u.cl->length_from_typespec = true;
1107 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1108 gfc_resolve_character_array_constructor (cons->expr);
1112 if (cons->expr->expr_type == EXPR_NULL
1113 && !(comp->attr.pointer || comp->attr.allocatable
1114 || comp->attr.proc_pointer
1115 || (comp->ts.type == BT_CLASS
1116 && (CLASS_DATA (comp)->attr.class_pointer
1117 || CLASS_DATA (comp)->attr.allocatable))))
1120 gfc_error ("The NULL in the structure constructor at %L is "
1121 "being applied to component '%s', which is neither "
1122 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1126 if (comp->attr.proc_pointer && comp->ts.interface)
1128 /* Check procedure pointer interface. */
1129 gfc_symbol *s2 = NULL;
1134 if (gfc_is_proc_ptr_comp (cons->expr, &c2))
1136 s2 = c2->ts.interface;
1139 else if (cons->expr->expr_type == EXPR_FUNCTION)
1141 s2 = cons->expr->symtree->n.sym->result;
1142 name = cons->expr->symtree->n.sym->result->name;
1144 else if (cons->expr->expr_type != EXPR_NULL)
1146 s2 = cons->expr->symtree->n.sym;
1147 name = cons->expr->symtree->n.sym->name;
1150 if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
1153 gfc_error ("Interface mismatch for procedure-pointer component "
1154 "'%s' in structure constructor at %L: %s",
1155 comp->name, &cons->expr->where, err);
1160 if (!comp->attr.pointer || comp->attr.proc_pointer
1161 || cons->expr->expr_type == EXPR_NULL)
1164 a = gfc_expr_attr (cons->expr);
1166 if (!a.pointer && !a.target)
1169 gfc_error ("The element in the structure constructor at %L, "
1170 "for pointer component '%s' should be a POINTER or "
1171 "a TARGET", &cons->expr->where, comp->name);
1176 /* F08:C461. Additional checks for pointer initialization. */
1180 gfc_error ("Pointer initialization target at %L "
1181 "must not be ALLOCATABLE ", &cons->expr->where);
1186 gfc_error ("Pointer initialization target at %L "
1187 "must have the SAVE attribute", &cons->expr->where);
1191 /* F2003, C1272 (3). */
1192 if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
1193 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1194 || gfc_is_coindexed (cons->expr)))
1197 gfc_error ("Invalid expression in the structure constructor for "
1198 "pointer component '%s' at %L in PURE procedure",
1199 comp->name, &cons->expr->where);
1202 if (gfc_implicit_pure (NULL)
1203 && cons->expr->expr_type == EXPR_VARIABLE
1204 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1205 || gfc_is_coindexed (cons->expr)))
1206 gfc_current_ns->proc_name->attr.implicit_pure = 0;
1214 /****************** Expression name resolution ******************/
1216 /* Returns 0 if a symbol was not declared with a type or
1217 attribute declaration statement, nonzero otherwise. */
1220 was_declared (gfc_symbol *sym)
1226 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1229 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1230 || a.optional || a.pointer || a.save || a.target || a.volatile_
1231 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1232 || a.asynchronous || a.codimension)
1239 /* Determine if a symbol is generic or not. */
1242 generic_sym (gfc_symbol *sym)
1246 if (sym->attr.generic ||
1247 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1250 if (was_declared (sym) || sym->ns->parent == NULL)
1253 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1260 return generic_sym (s);
1267 /* Determine if a symbol is specific or not. */
1270 specific_sym (gfc_symbol *sym)
1274 if (sym->attr.if_source == IFSRC_IFBODY
1275 || sym->attr.proc == PROC_MODULE
1276 || sym->attr.proc == PROC_INTERNAL
1277 || sym->attr.proc == PROC_ST_FUNCTION
1278 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1279 || sym->attr.external)
1282 if (was_declared (sym) || sym->ns->parent == NULL)
1285 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1287 return (s == NULL) ? 0 : specific_sym (s);
1291 /* Figure out if the procedure is specific, generic or unknown. */
1294 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1298 procedure_kind (gfc_symbol *sym)
1300 if (generic_sym (sym))
1301 return PTYPE_GENERIC;
1303 if (specific_sym (sym))
1304 return PTYPE_SPECIFIC;
1306 return PTYPE_UNKNOWN;
1309 /* Check references to assumed size arrays. The flag need_full_assumed_size
1310 is nonzero when matching actual arguments. */
1312 static int need_full_assumed_size = 0;
1315 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1317 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1320 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1321 What should it be? */
1322 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1323 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1324 && (e->ref->u.ar.type == AR_FULL))
1326 gfc_error ("The upper bound in the last dimension must "
1327 "appear in the reference to the assumed size "
1328 "array '%s' at %L", sym->name, &e->where);
1335 /* Look for bad assumed size array references in argument expressions
1336 of elemental and array valued intrinsic procedures. Since this is
1337 called from procedure resolution functions, it only recurses at
1341 resolve_assumed_size_actual (gfc_expr *e)
1346 switch (e->expr_type)
1349 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1354 if (resolve_assumed_size_actual (e->value.op.op1)
1355 || resolve_assumed_size_actual (e->value.op.op2))
1366 /* Check a generic procedure, passed as an actual argument, to see if
1367 there is a matching specific name. If none, it is an error, and if
1368 more than one, the reference is ambiguous. */
1370 count_specific_procs (gfc_expr *e)
1377 sym = e->symtree->n.sym;
1379 for (p = sym->generic; p; p = p->next)
1380 if (strcmp (sym->name, p->sym->name) == 0)
1382 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1388 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1392 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1393 "argument at %L", sym->name, &e->where);
1399 /* See if a call to sym could possibly be a not allowed RECURSION because of
1400 a missing RECURIVE declaration. This means that either sym is the current
1401 context itself, or sym is the parent of a contained procedure calling its
1402 non-RECURSIVE containing procedure.
1403 This also works if sym is an ENTRY. */
1406 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1408 gfc_symbol* proc_sym;
1409 gfc_symbol* context_proc;
1410 gfc_namespace* real_context;
1412 if (sym->attr.flavor == FL_PROGRAM
1413 || sym->attr.flavor == FL_DERIVED)
1416 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1418 /* If we've got an ENTRY, find real procedure. */
1419 if (sym->attr.entry && sym->ns->entries)
1420 proc_sym = sym->ns->entries->sym;
1424 /* If sym is RECURSIVE, all is well of course. */
1425 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1428 /* Find the context procedure's "real" symbol if it has entries.
1429 We look for a procedure symbol, so recurse on the parents if we don't
1430 find one (like in case of a BLOCK construct). */
1431 for (real_context = context; ; real_context = real_context->parent)
1433 /* We should find something, eventually! */
1434 gcc_assert (real_context);
1436 context_proc = (real_context->entries ? real_context->entries->sym
1437 : real_context->proc_name);
1439 /* In some special cases, there may not be a proc_name, like for this
1441 real(bad_kind()) function foo () ...
1442 when checking the call to bad_kind ().
1443 In these cases, we simply return here and assume that the
1448 if (context_proc->attr.flavor != FL_LABEL)
1452 /* A call from sym's body to itself is recursion, of course. */
1453 if (context_proc == proc_sym)
1456 /* The same is true if context is a contained procedure and sym the
1458 if (context_proc->attr.contained)
1460 gfc_symbol* parent_proc;
1462 gcc_assert (context->parent);
1463 parent_proc = (context->parent->entries ? context->parent->entries->sym
1464 : context->parent->proc_name);
1466 if (parent_proc == proc_sym)
1474 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1475 its typespec and formal argument list. */
1478 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1480 gfc_intrinsic_sym* isym = NULL;
1486 /* Already resolved. */
1487 if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
1490 /* We already know this one is an intrinsic, so we don't call
1491 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1492 gfc_find_subroutine directly to check whether it is a function or
1495 if (sym->intmod_sym_id)
1496 isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
1498 isym = gfc_find_function (sym->name);
1502 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1503 && !sym->attr.implicit_type)
1504 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1505 " ignored", sym->name, &sym->declared_at);
1507 if (!sym->attr.function &&
1508 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1513 else if ((isym = gfc_find_subroutine (sym->name)))
1515 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1517 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1518 " specifier", sym->name, &sym->declared_at);
1522 if (!sym->attr.subroutine &&
1523 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1528 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1533 gfc_copy_formal_args_intr (sym, isym);
1535 /* Check it is actually available in the standard settings. */
1536 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1539 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1540 " available in the current standard settings but %s. Use"
1541 " an appropriate -std=* option or enable -fall-intrinsics"
1542 " in order to use it.",
1543 sym->name, &sym->declared_at, symstd);
1551 /* Resolve a procedure expression, like passing it to a called procedure or as
1552 RHS for a procedure pointer assignment. */
1555 resolve_procedure_expression (gfc_expr* expr)
1559 if (expr->expr_type != EXPR_VARIABLE)
1561 gcc_assert (expr->symtree);
1563 sym = expr->symtree->n.sym;
1565 if (sym->attr.intrinsic)
1566 resolve_intrinsic (sym, &expr->where);
1568 if (sym->attr.flavor != FL_PROCEDURE
1569 || (sym->attr.function && sym->result == sym))
1572 /* A non-RECURSIVE procedure that is used as procedure expression within its
1573 own body is in danger of being called recursively. */
1574 if (is_illegal_recursion (sym, gfc_current_ns))
1575 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1576 " itself recursively. Declare it RECURSIVE or use"
1577 " -frecursive", sym->name, &expr->where);
1584 symbol_as (gfc_symbol *sym)
1586 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
1587 return CLASS_DATA (sym)->as;
1593 /* Resolve an actual argument list. Most of the time, this is just
1594 resolving the expressions in the list.
1595 The exception is that we sometimes have to decide whether arguments
1596 that look like procedure arguments are really simple variable
1600 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1601 bool no_formal_args)
1604 gfc_symtree *parent_st;
1606 int save_need_full_assumed_size;
1608 for (; arg; arg = arg->next)
1613 /* Check the label is a valid branching target. */
1616 if (arg->label->defined == ST_LABEL_UNKNOWN)
1618 gfc_error ("Label %d referenced at %L is never defined",
1619 arg->label->value, &arg->label->where);
1626 if (e->expr_type == EXPR_VARIABLE
1627 && e->symtree->n.sym->attr.generic
1629 && count_specific_procs (e) != 1)
1632 if (e->ts.type != BT_PROCEDURE)
1634 save_need_full_assumed_size = need_full_assumed_size;
1635 if (e->expr_type != EXPR_VARIABLE)
1636 need_full_assumed_size = 0;
1637 if (gfc_resolve_expr (e) != SUCCESS)
1639 need_full_assumed_size = save_need_full_assumed_size;
1643 /* See if the expression node should really be a variable reference. */
1645 sym = e->symtree->n.sym;
1647 if (sym->attr.flavor == FL_PROCEDURE
1648 || sym->attr.intrinsic
1649 || sym->attr.external)
1653 /* If a procedure is not already determined to be something else
1654 check if it is intrinsic. */
1655 if (!sym->attr.intrinsic
1656 && !(sym->attr.external || sym->attr.use_assoc
1657 || sym->attr.if_source == IFSRC_IFBODY)
1658 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1659 sym->attr.intrinsic = 1;
1661 if (sym->attr.proc == PROC_ST_FUNCTION)
1663 gfc_error ("Statement function '%s' at %L is not allowed as an "
1664 "actual argument", sym->name, &e->where);
1667 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1668 sym->attr.subroutine);
1669 if (sym->attr.intrinsic && actual_ok == 0)
1671 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1672 "actual argument", sym->name, &e->where);
1675 if (sym->attr.contained && !sym->attr.use_assoc
1676 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1678 if (gfc_notify_std (GFC_STD_F2008,
1679 "Fortran 2008: Internal procedure '%s' is"
1680 " used as actual argument at %L",
1681 sym->name, &e->where) == FAILURE)
1685 if (sym->attr.elemental && !sym->attr.intrinsic)
1687 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1688 "allowed as an actual argument at %L", sym->name,
1692 /* Check if a generic interface has a specific procedure
1693 with the same name before emitting an error. */
1694 if (sym->attr.generic && count_specific_procs (e) != 1)
1697 /* Just in case a specific was found for the expression. */
1698 sym = e->symtree->n.sym;
1700 /* If the symbol is the function that names the current (or
1701 parent) scope, then we really have a variable reference. */
1703 if (gfc_is_function_return_value (sym, sym->ns))
1706 /* If all else fails, see if we have a specific intrinsic. */
1707 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1709 gfc_intrinsic_sym *isym;
1711 isym = gfc_find_function (sym->name);
1712 if (isym == NULL || !isym->specific)
1714 gfc_error ("Unable to find a specific INTRINSIC procedure "
1715 "for the reference '%s' at %L", sym->name,
1720 sym->attr.intrinsic = 1;
1721 sym->attr.function = 1;
1724 if (gfc_resolve_expr (e) == FAILURE)
1729 /* See if the name is a module procedure in a parent unit. */
1731 if (was_declared (sym) || sym->ns->parent == NULL)
1734 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1736 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1740 if (parent_st == NULL)
1743 sym = parent_st->n.sym;
1744 e->symtree = parent_st; /* Point to the right thing. */
1746 if (sym->attr.flavor == FL_PROCEDURE
1747 || sym->attr.intrinsic
1748 || sym->attr.external)
1750 if (gfc_resolve_expr (e) == FAILURE)
1756 e->expr_type = EXPR_VARIABLE;
1758 if ((sym->as != NULL && sym->ts.type != BT_CLASS)
1759 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
1760 && CLASS_DATA (sym)->as))
1762 e->rank = sym->ts.type == BT_CLASS
1763 ? CLASS_DATA (sym)->as->rank : sym->as->rank;
1764 e->ref = gfc_get_ref ();
1765 e->ref->type = REF_ARRAY;
1766 e->ref->u.ar.type = AR_FULL;
1767 e->ref->u.ar.as = sym->ts.type == BT_CLASS
1768 ? CLASS_DATA (sym)->as : sym->as;
1771 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1772 primary.c (match_actual_arg). If above code determines that it
1773 is a variable instead, it needs to be resolved as it was not
1774 done at the beginning of this function. */
1775 save_need_full_assumed_size = need_full_assumed_size;
1776 if (e->expr_type != EXPR_VARIABLE)
1777 need_full_assumed_size = 0;
1778 if (gfc_resolve_expr (e) != SUCCESS)
1780 need_full_assumed_size = save_need_full_assumed_size;
1783 /* Check argument list functions %VAL, %LOC and %REF. There is
1784 nothing to do for %REF. */
1785 if (arg->name && arg->name[0] == '%')
1787 if (strncmp ("%VAL", arg->name, 4) == 0)
1789 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1791 gfc_error ("By-value argument at %L is not of numeric "
1798 gfc_error ("By-value argument at %L cannot be an array or "
1799 "an array section", &e->where);
1803 /* Intrinsics are still PROC_UNKNOWN here. However,
1804 since same file external procedures are not resolvable
1805 in gfortran, it is a good deal easier to leave them to
1807 if (ptype != PROC_UNKNOWN
1808 && ptype != PROC_DUMMY
1809 && ptype != PROC_EXTERNAL
1810 && ptype != PROC_MODULE)
1812 gfc_error ("By-value argument at %L is not allowed "
1813 "in this context", &e->where);
1818 /* Statement functions have already been excluded above. */
1819 else if (strncmp ("%LOC", arg->name, 4) == 0
1820 && e->ts.type == BT_PROCEDURE)
1822 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1824 gfc_error ("Passing internal procedure at %L by location "
1825 "not allowed", &e->where);
1831 /* Fortran 2008, C1237. */
1832 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1833 && gfc_has_ultimate_pointer (e))
1835 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1836 "component", &e->where);
1845 /* Do the checks of the actual argument list that are specific to elemental
1846 procedures. If called with c == NULL, we have a function, otherwise if
1847 expr == NULL, we have a subroutine. */
1850 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1852 gfc_actual_arglist *arg0;
1853 gfc_actual_arglist *arg;
1854 gfc_symbol *esym = NULL;
1855 gfc_intrinsic_sym *isym = NULL;
1857 gfc_intrinsic_arg *iformal = NULL;
1858 gfc_formal_arglist *eformal = NULL;
1859 bool formal_optional = false;
1860 bool set_by_optional = false;
1864 /* Is this an elemental procedure? */
1865 if (expr && expr->value.function.actual != NULL)
1867 if (expr->value.function.esym != NULL
1868 && expr->value.function.esym->attr.elemental)
1870 arg0 = expr->value.function.actual;
1871 esym = expr->value.function.esym;
1873 else if (expr->value.function.isym != NULL
1874 && expr->value.function.isym->elemental)
1876 arg0 = expr->value.function.actual;
1877 isym = expr->value.function.isym;
1882 else if (c && c->ext.actual != NULL)
1884 arg0 = c->ext.actual;
1886 if (c->resolved_sym)
1887 esym = c->resolved_sym;
1889 esym = c->symtree->n.sym;
1892 if (!esym->attr.elemental)
1898 /* The rank of an elemental is the rank of its array argument(s). */
1899 for (arg = arg0; arg; arg = arg->next)
1901 if (arg->expr != NULL && arg->expr->rank > 0)
1903 rank = arg->expr->rank;
1904 if (arg->expr->expr_type == EXPR_VARIABLE
1905 && arg->expr->symtree->n.sym->attr.optional)
1906 set_by_optional = true;
1908 /* Function specific; set the result rank and shape. */
1912 if (!expr->shape && arg->expr->shape)
1914 expr->shape = gfc_get_shape (rank);
1915 for (i = 0; i < rank; i++)
1916 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1923 /* If it is an array, it shall not be supplied as an actual argument
1924 to an elemental procedure unless an array of the same rank is supplied
1925 as an actual argument corresponding to a nonoptional dummy argument of
1926 that elemental procedure(12.4.1.5). */
1927 formal_optional = false;
1929 iformal = isym->formal;
1931 eformal = esym->formal;
1933 for (arg = arg0; arg; arg = arg->next)
1937 if (eformal->sym && eformal->sym->attr.optional)
1938 formal_optional = true;
1939 eformal = eformal->next;
1941 else if (isym && iformal)
1943 if (iformal->optional)
1944 formal_optional = true;
1945 iformal = iformal->next;
1948 formal_optional = true;
1950 if (pedantic && arg->expr != NULL
1951 && arg->expr->expr_type == EXPR_VARIABLE
1952 && arg->expr->symtree->n.sym->attr.optional
1955 && (set_by_optional || arg->expr->rank != rank)
1956 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1958 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1959 "MISSING, it cannot be the actual argument of an "
1960 "ELEMENTAL procedure unless there is a non-optional "
1961 "argument with the same rank (12.4.1.5)",
1962 arg->expr->symtree->n.sym->name, &arg->expr->where);
1967 for (arg = arg0; arg; arg = arg->next)
1969 if (arg->expr == NULL || arg->expr->rank == 0)
1972 /* Being elemental, the last upper bound of an assumed size array
1973 argument must be present. */
1974 if (resolve_assumed_size_actual (arg->expr))
1977 /* Elemental procedure's array actual arguments must conform. */
1980 if (gfc_check_conformance (arg->expr, e,
1981 "elemental procedure") == FAILURE)
1988 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1989 is an array, the intent inout/out variable needs to be also an array. */
1990 if (rank > 0 && esym && expr == NULL)
1991 for (eformal = esym->formal, arg = arg0; arg && eformal;
1992 arg = arg->next, eformal = eformal->next)
1993 if ((eformal->sym->attr.intent == INTENT_OUT
1994 || eformal->sym->attr.intent == INTENT_INOUT)
1995 && arg->expr && arg->expr->rank == 0)
1997 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1998 "ELEMENTAL subroutine '%s' is a scalar, but another "
1999 "actual argument is an array", &arg->expr->where,
2000 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
2001 : "INOUT", eformal->sym->name, esym->name);
2008 /* This function does the checking of references to global procedures
2009 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2010 77 and 95 standards. It checks for a gsymbol for the name, making
2011 one if it does not already exist. If it already exists, then the
2012 reference being resolved must correspond to the type of gsymbol.
2013 Otherwise, the new symbol is equipped with the attributes of the
2014 reference. The corresponding code that is called in creating
2015 global entities is parse.c.
2017 In addition, for all but -std=legacy, the gsymbols are used to
2018 check the interfaces of external procedures from the same file.
2019 The namespace of the gsymbol is resolved and then, once this is
2020 done the interface is checked. */
2024 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2026 if (!gsym_ns->proc_name->attr.recursive)
2029 if (sym->ns == gsym_ns)
2032 if (sym->ns->parent && sym->ns->parent == gsym_ns)
2039 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
2041 if (gsym_ns->entries)
2043 gfc_entry_list *entry = gsym_ns->entries;
2045 for (; entry; entry = entry->next)
2047 if (strcmp (sym->name, entry->sym->name) == 0)
2049 if (strcmp (gsym_ns->proc_name->name,
2050 sym->ns->proc_name->name) == 0)
2054 && strcmp (gsym_ns->proc_name->name,
2055 sym->ns->parent->proc_name->name) == 0)
2064 resolve_global_procedure (gfc_symbol *sym, locus *where,
2065 gfc_actual_arglist **actual, int sub)
2069 enum gfc_symbol_type type;
2071 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2073 gsym = gfc_get_gsymbol (sym->name);
2075 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2076 gfc_global_used (gsym, where);
2078 if (gfc_option.flag_whole_file
2079 && (sym->attr.if_source == IFSRC_UNKNOWN
2080 || sym->attr.if_source == IFSRC_IFBODY)
2081 && gsym->type != GSYM_UNKNOWN
2083 && gsym->ns->resolved != -1
2084 && gsym->ns->proc_name
2085 && not_in_recursive (sym, gsym->ns)
2086 && not_entry_self_reference (sym, gsym->ns))
2088 gfc_symbol *def_sym;
2090 /* Resolve the gsymbol namespace if needed. */
2091 if (!gsym->ns->resolved)
2093 gfc_dt_list *old_dt_list;
2094 struct gfc_omp_saved_state old_omp_state;
2096 /* Stash away derived types so that the backend_decls do not
2098 old_dt_list = gfc_derived_types;
2099 gfc_derived_types = NULL;
2100 /* And stash away openmp state. */
2101 gfc_omp_save_and_clear_state (&old_omp_state);
2103 gfc_resolve (gsym->ns);
2105 /* Store the new derived types with the global namespace. */
2106 if (gfc_derived_types)
2107 gsym->ns->derived_types = gfc_derived_types;
2109 /* Restore the derived types of this namespace. */
2110 gfc_derived_types = old_dt_list;
2111 /* And openmp state. */
2112 gfc_omp_restore_state (&old_omp_state);
2115 /* Make sure that translation for the gsymbol occurs before
2116 the procedure currently being resolved. */
2117 ns = gfc_global_ns_list;
2118 for (; ns && ns != gsym->ns; ns = ns->sibling)
2120 if (ns->sibling == gsym->ns)
2122 ns->sibling = gsym->ns->sibling;
2123 gsym->ns->sibling = gfc_global_ns_list;
2124 gfc_global_ns_list = gsym->ns;
2129 def_sym = gsym->ns->proc_name;
2130 if (def_sym->attr.entry_master)
2132 gfc_entry_list *entry;
2133 for (entry = gsym->ns->entries; entry; entry = entry->next)
2134 if (strcmp (entry->sym->name, sym->name) == 0)
2136 def_sym = entry->sym;
2141 /* Differences in constant character lengths. */
2142 if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2144 long int l1 = 0, l2 = 0;
2145 gfc_charlen *cl1 = sym->ts.u.cl;
2146 gfc_charlen *cl2 = def_sym->ts.u.cl;
2149 && cl1->length != NULL
2150 && cl1->length->expr_type == EXPR_CONSTANT)
2151 l1 = mpz_get_si (cl1->length->value.integer);
2154 && cl2->length != NULL
2155 && cl2->length->expr_type == EXPR_CONSTANT)
2156 l2 = mpz_get_si (cl2->length->value.integer);
2158 if (l1 && l2 && l1 != l2)
2159 gfc_error ("Character length mismatch in return type of "
2160 "function '%s' at %L (%ld/%ld)", sym->name,
2161 &sym->declared_at, l1, l2);
2164 /* Type mismatch of function return type and expected type. */
2165 if (sym->attr.function
2166 && !gfc_compare_types (&sym->ts, &def_sym->ts))
2167 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2168 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2169 gfc_typename (&def_sym->ts));
2171 if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2173 gfc_formal_arglist *arg = def_sym->formal;
2174 for ( ; arg; arg = arg->next)
2177 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2178 else if (arg->sym->attr.allocatable
2179 || arg->sym->attr.asynchronous
2180 || arg->sym->attr.optional
2181 || arg->sym->attr.pointer
2182 || arg->sym->attr.target
2183 || arg->sym->attr.value
2184 || arg->sym->attr.volatile_)
2186 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2187 "has an attribute that requires an explicit "
2188 "interface for this procedure", arg->sym->name,
2189 sym->name, &sym->declared_at);
2192 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2193 else if (arg->sym && arg->sym->as
2194 && arg->sym->as->type == AS_ASSUMED_SHAPE)
2196 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2197 "argument '%s' must have an explicit interface",
2198 sym->name, &sym->declared_at, arg->sym->name);
2201 /* F2008, 12.4.2.2 (2c) */
2202 else if (arg->sym->attr.codimension)
2204 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2205 "'%s' must have an explicit interface",
2206 sym->name, &sym->declared_at, arg->sym->name);
2209 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2210 else if (false) /* TODO: is a parametrized derived type */
2212 gfc_error ("Procedure '%s' at %L with parametrized derived "
2213 "type argument '%s' must have an explicit "
2214 "interface", sym->name, &sym->declared_at,
2218 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2219 else if (arg->sym->ts.type == BT_CLASS)
2221 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2222 "argument '%s' must have an explicit interface",
2223 sym->name, &sym->declared_at, arg->sym->name);
2228 if (def_sym->attr.function)
2230 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2231 if (def_sym->as && def_sym->as->rank
2232 && (!sym->as || sym->as->rank != def_sym->as->rank))
2233 gfc_error ("The reference to function '%s' at %L either needs an "
2234 "explicit INTERFACE or the rank is incorrect", sym->name,
2237 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2238 if ((def_sym->result->attr.pointer
2239 || def_sym->result->attr.allocatable)
2240 && (sym->attr.if_source != IFSRC_IFBODY
2241 || def_sym->result->attr.pointer
2242 != sym->result->attr.pointer
2243 || def_sym->result->attr.allocatable
2244 != sym->result->attr.allocatable))
2245 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2246 "result must have an explicit interface", sym->name,
2249 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2250 if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2251 && def_sym->ts.type == BT_CHARACTER && def_sym->ts.u.cl->length != NULL)
2253 gfc_charlen *cl = sym->ts.u.cl;
2255 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2256 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2258 gfc_error ("Nonconstant character-length function '%s' at %L "
2259 "must have an explicit interface", sym->name,
2265 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2266 if (def_sym->attr.elemental && !sym->attr.elemental)
2268 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2269 "interface", sym->name, &sym->declared_at);
2272 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2273 if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2275 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2276 "an explicit interface", sym->name, &sym->declared_at);
2279 if (gfc_option.flag_whole_file == 1
2280 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2281 && !(gfc_option.warn_std & GFC_STD_GNU)))
2282 gfc_errors_to_warnings (1);
2284 if (sym->attr.if_source != IFSRC_IFBODY)
2285 gfc_procedure_use (def_sym, actual, where);
2287 gfc_errors_to_warnings (0);
2290 if (gsym->type == GSYM_UNKNOWN)
2293 gsym->where = *where;
2300 /************* Function resolution *************/
2302 /* Resolve a function call known to be generic.
2303 Section 14.1.2.4.1. */
2306 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2310 if (sym->attr.generic)
2312 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2315 expr->value.function.name = s->name;
2316 expr->value.function.esym = s;
2318 if (s->ts.type != BT_UNKNOWN)
2320 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2321 expr->ts = s->result->ts;
2324 expr->rank = s->as->rank;
2325 else if (s->result != NULL && s->result->as != NULL)
2326 expr->rank = s->result->as->rank;
2328 gfc_set_sym_referenced (expr->value.function.esym);
2333 /* TODO: Need to search for elemental references in generic
2337 if (sym->attr.intrinsic)
2338 return gfc_intrinsic_func_interface (expr, 0);
2345 resolve_generic_f (gfc_expr *expr)
2349 gfc_interface *intr = NULL;
2351 sym = expr->symtree->n.sym;
2355 m = resolve_generic_f0 (expr, sym);
2358 else if (m == MATCH_ERROR)
2363 for (intr = sym->generic; intr; intr = intr->next)
2364 if (intr->sym->attr.flavor == FL_DERIVED)
2367 if (sym->ns->parent == NULL)
2369 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2373 if (!generic_sym (sym))
2377 /* Last ditch attempt. See if the reference is to an intrinsic
2378 that possesses a matching interface. 14.1.2.4 */
2379 if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
2381 gfc_error ("There is no specific function for the generic '%s' "
2382 "at %L", expr->symtree->n.sym->name, &expr->where);
2388 if (gfc_convert_to_structure_constructor (expr, intr->sym, NULL, NULL,
2391 return resolve_structure_cons (expr, 0);
2394 m = gfc_intrinsic_func_interface (expr, 0);
2399 gfc_error ("Generic function '%s' at %L is not consistent with a "
2400 "specific intrinsic interface", expr->symtree->n.sym->name,
2407 /* Resolve a function call known to be specific. */
2410 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2414 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2416 if (sym->attr.dummy)
2418 sym->attr.proc = PROC_DUMMY;
2422 sym->attr.proc = PROC_EXTERNAL;
2426 if (sym->attr.proc == PROC_MODULE
2427 || sym->attr.proc == PROC_ST_FUNCTION
2428 || sym->attr.proc == PROC_INTERNAL)
2431 if (sym->attr.intrinsic)
2433 m = gfc_intrinsic_func_interface (expr, 1);
2437 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2438 "with an intrinsic", sym->name, &expr->where);
2446 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2449 expr->ts = sym->result->ts;
2452 expr->value.function.name = sym->name;
2453 expr->value.function.esym = sym;
2454 if (sym->as != NULL)
2455 expr->rank = sym->as->rank;
2462 resolve_specific_f (gfc_expr *expr)
2467 sym = expr->symtree->n.sym;
2471 m = resolve_specific_f0 (sym, expr);
2474 if (m == MATCH_ERROR)
2477 if (sym->ns->parent == NULL)
2480 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2486 gfc_error ("Unable to resolve the specific function '%s' at %L",
2487 expr->symtree->n.sym->name, &expr->where);
2493 /* Resolve a procedure call not known to be generic nor specific. */
2496 resolve_unknown_f (gfc_expr *expr)
2501 sym = expr->symtree->n.sym;
2503 if (sym->attr.dummy)
2505 sym->attr.proc = PROC_DUMMY;
2506 expr->value.function.name = sym->name;
2510 /* See if we have an intrinsic function reference. */
2512 if (gfc_is_intrinsic (sym, 0, expr->where))
2514 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2519 /* The reference is to an external name. */
2521 sym->attr.proc = PROC_EXTERNAL;
2522 expr->value.function.name = sym->name;
2523 expr->value.function.esym = expr->symtree->n.sym;
2525 if (sym->as != NULL)
2526 expr->rank = sym->as->rank;
2528 /* Type of the expression is either the type of the symbol or the
2529 default type of the symbol. */
2532 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2534 if (sym->ts.type != BT_UNKNOWN)
2538 ts = gfc_get_default_type (sym->name, sym->ns);
2540 if (ts->type == BT_UNKNOWN)
2542 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2543 sym->name, &expr->where);
2554 /* Return true, if the symbol is an external procedure. */
2556 is_external_proc (gfc_symbol *sym)
2558 if (!sym->attr.dummy && !sym->attr.contained
2559 && !(sym->attr.intrinsic
2560 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2561 && sym->attr.proc != PROC_ST_FUNCTION
2562 && !sym->attr.proc_pointer
2563 && !sym->attr.use_assoc
2571 /* Figure out if a function reference is pure or not. Also set the name
2572 of the function for a potential error message. Return nonzero if the
2573 function is PURE, zero if not. */
2575 pure_stmt_function (gfc_expr *, gfc_symbol *);
2578 pure_function (gfc_expr *e, const char **name)
2584 if (e->symtree != NULL
2585 && e->symtree->n.sym != NULL
2586 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2587 return pure_stmt_function (e, e->symtree->n.sym);
2589 if (e->value.function.esym)
2591 pure = gfc_pure (e->value.function.esym);
2592 *name = e->value.function.esym->name;
2594 else if (e->value.function.isym)
2596 pure = e->value.function.isym->pure
2597 || e->value.function.isym->elemental;
2598 *name = e->value.function.isym->name;
2602 /* Implicit functions are not pure. */
2604 *name = e->value.function.name;
2612 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2613 int *f ATTRIBUTE_UNUSED)
2617 /* Don't bother recursing into other statement functions
2618 since they will be checked individually for purity. */
2619 if (e->expr_type != EXPR_FUNCTION
2621 || e->symtree->n.sym == sym
2622 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2625 return pure_function (e, &name) ? false : true;
2630 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2632 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2637 is_scalar_expr_ptr (gfc_expr *expr)
2639 gfc_try retval = SUCCESS;
2644 /* See if we have a gfc_ref, which means we have a substring, array
2645 reference, or a component. */
2646 if (expr->ref != NULL)
2649 while (ref->next != NULL)
2655 if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
2656 || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
2661 if (ref->u.ar.type == AR_ELEMENT)
2663 else if (ref->u.ar.type == AR_FULL)
2665 /* The user can give a full array if the array is of size 1. */
2666 if (ref->u.ar.as != NULL
2667 && ref->u.ar.as->rank == 1
2668 && ref->u.ar.as->type == AS_EXPLICIT
2669 && ref->u.ar.as->lower[0] != NULL
2670 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2671 && ref->u.ar.as->upper[0] != NULL
2672 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2674 /* If we have a character string, we need to check if
2675 its length is one. */
2676 if (expr->ts.type == BT_CHARACTER)
2678 if (expr->ts.u.cl == NULL
2679 || expr->ts.u.cl->length == NULL
2680 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2686 /* We have constant lower and upper bounds. If the
2687 difference between is 1, it can be considered a
2689 FIXME: Use gfc_dep_compare_expr instead. */
2690 start = (int) mpz_get_si
2691 (ref->u.ar.as->lower[0]->value.integer);
2692 end = (int) mpz_get_si
2693 (ref->u.ar.as->upper[0]->value.integer);
2694 if (end - start + 1 != 1)
2709 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2711 /* Character string. Make sure it's of length 1. */
2712 if (expr->ts.u.cl == NULL
2713 || expr->ts.u.cl->length == NULL
2714 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2717 else if (expr->rank != 0)
2724 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2725 and, in the case of c_associated, set the binding label based on
2729 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2730 gfc_symbol **new_sym)
2732 char name[GFC_MAX_SYMBOL_LEN + 1];
2733 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2734 int optional_arg = 0;
2735 gfc_try retval = SUCCESS;
2736 gfc_symbol *args_sym;
2737 gfc_typespec *arg_ts;
2738 symbol_attribute arg_attr;
2740 if (args->expr->expr_type == EXPR_CONSTANT
2741 || args->expr->expr_type == EXPR_OP
2742 || args->expr->expr_type == EXPR_NULL)
2744 gfc_error ("Argument to '%s' at %L is not a variable",
2745 sym->name, &(args->expr->where));
2749 args_sym = args->expr->symtree->n.sym;
2751 /* The typespec for the actual arg should be that stored in the expr
2752 and not necessarily that of the expr symbol (args_sym), because
2753 the actual expression could be a part-ref of the expr symbol. */
2754 arg_ts = &(args->expr->ts);
2755 arg_attr = gfc_expr_attr (args->expr);
2757 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2759 /* If the user gave two args then they are providing something for
2760 the optional arg (the second cptr). Therefore, set the name and
2761 binding label to the c_associated for two cptrs. Otherwise,
2762 set c_associated to expect one cptr. */
2766 sprintf (name, "%s_2", sym->name);
2767 sprintf (binding_label, "%s_2", sym->binding_label);
2773 sprintf (name, "%s_1", sym->name);
2774 sprintf (binding_label, "%s_1", sym->binding_label);
2778 /* Get a new symbol for the version of c_associated that
2780 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2782 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2783 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2785 sprintf (name, "%s", sym->name);
2786 sprintf (binding_label, "%s", sym->binding_label);
2788 /* Error check the call. */
2789 if (args->next != NULL)
2791 gfc_error_now ("More actual than formal arguments in '%s' "
2792 "call at %L", name, &(args->expr->where));
2795 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2800 /* Make sure we have either the target or pointer attribute. */
2801 if (!arg_attr.target && !arg_attr.pointer)
2803 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2804 "a TARGET or an associated pointer",
2806 sym->name, &(args->expr->where));
2810 if (gfc_is_coindexed (args->expr))
2812 gfc_error_now ("Coindexed argument not permitted"
2813 " in '%s' call at %L", name,
2814 &(args->expr->where));
2818 /* Follow references to make sure there are no array
2820 seen_section = false;
2822 for (ref=args->expr->ref; ref; ref = ref->next)
2824 if (ref->type == REF_ARRAY)
2826 if (ref->u.ar.type == AR_SECTION)
2827 seen_section = true;
2829 if (ref->u.ar.type != AR_ELEMENT)
2832 for (r = ref->next; r; r=r->next)
2833 if (r->type == REF_COMPONENT)
2835 gfc_error_now ("Array section not permitted"
2836 " in '%s' call at %L", name,
2837 &(args->expr->where));
2845 if (seen_section && retval == SUCCESS)
2846 gfc_warning ("Array section in '%s' call at %L", name,
2847 &(args->expr->where));
2849 /* See if we have interoperable type and type param. */
2850 if (gfc_verify_c_interop (arg_ts) == SUCCESS
2851 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2853 if (args_sym->attr.target == 1)
2855 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2856 has the target attribute and is interoperable. */
2857 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2858 allocatable variable that has the TARGET attribute and
2859 is not an array of zero size. */
2860 if (args_sym->attr.allocatable == 1)
2862 if (args_sym->attr.dimension != 0
2863 && (args_sym->as && args_sym->as->rank == 0))
2865 gfc_error_now ("Allocatable variable '%s' used as a "
2866 "parameter to '%s' at %L must not be "
2867 "an array of zero size",
2868 args_sym->name, sym->name,
2869 &(args->expr->where));
2875 /* A non-allocatable target variable with C
2876 interoperable type and type parameters must be
2878 if (args_sym && args_sym->attr.dimension)
2880 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2882 gfc_error ("Assumed-shape array '%s' at %L "
2883 "cannot be an argument to the "
2884 "procedure '%s' because "
2885 "it is not C interoperable",
2887 &(args->expr->where), sym->name);
2890 else if (args_sym->as->type == AS_DEFERRED)
2892 gfc_error ("Deferred-shape array '%s' at %L "
2893 "cannot be an argument to the "
2894 "procedure '%s' because "
2895 "it is not C interoperable",
2897 &(args->expr->where), sym->name);
2902 /* Make sure it's not a character string. Arrays of
2903 any type should be ok if the variable is of a C
2904 interoperable type. */
2905 if (arg_ts->type == BT_CHARACTER)
2906 if (arg_ts->u.cl != NULL
2907 && (arg_ts->u.cl->length == NULL
2908 || arg_ts->u.cl->length->expr_type
2911 (arg_ts->u.cl->length->value.integer, 1)
2913 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2915 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2916 "at %L must have a length of 1",
2917 args_sym->name, sym->name,
2918 &(args->expr->where));
2923 else if (arg_attr.pointer
2924 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2926 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2928 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2929 "associated scalar POINTER", args_sym->name,
2930 sym->name, &(args->expr->where));
2936 /* The parameter is not required to be C interoperable. If it
2937 is not C interoperable, it must be a nonpolymorphic scalar
2938 with no length type parameters. It still must have either
2939 the pointer or target attribute, and it can be
2940 allocatable (but must be allocated when c_loc is called). */
2941 if (args->expr->rank != 0
2942 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2944 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2945 "scalar", args_sym->name, sym->name,
2946 &(args->expr->where));
2949 else if (arg_ts->type == BT_CHARACTER
2950 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2952 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2953 "%L must have a length of 1",
2954 args_sym->name, sym->name,
2955 &(args->expr->where));
2958 else if (arg_ts->type == BT_CLASS)
2960 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2961 "polymorphic", args_sym->name, sym->name,
2962 &(args->expr->where));
2967 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2969 if (args_sym->attr.flavor != FL_PROCEDURE)
2971 /* TODO: Update this error message to allow for procedure
2972 pointers once they are implemented. */
2973 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2975 args_sym->name, sym->name,
2976 &(args->expr->where));
2979 else if (args_sym->attr.is_bind_c != 1)
2981 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2983 args_sym->name, sym->name,
2984 &(args->expr->where));
2989 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2994 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2995 "iso_c_binding function: '%s'!\n", sym->name);
3002 /* Resolve a function call, which means resolving the arguments, then figuring
3003 out which entity the name refers to. */
3006 resolve_function (gfc_expr *expr)
3008 gfc_actual_arglist *arg;
3013 procedure_type p = PROC_INTRINSIC;
3014 bool no_formal_args;
3018 sym = expr->symtree->n.sym;
3020 /* If this is a procedure pointer component, it has already been resolved. */
3021 if (gfc_is_proc_ptr_comp (expr, NULL))
3024 if (sym && sym->attr.intrinsic
3025 && resolve_intrinsic (sym, &expr->where) == FAILURE)
3028 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
3030 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
3034 /* If this ia a deferred TBP with an abstract interface (which may
3035 of course be referenced), expr->value.function.esym will be set. */
3036 if (sym && sym->attr.abstract && !expr->value.function.esym)
3038 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3039 sym->name, &expr->where);
3043 /* Switch off assumed size checking and do this again for certain kinds
3044 of procedure, once the procedure itself is resolved. */
3045 need_full_assumed_size++;
3047 if (expr->symtree && expr->symtree->n.sym)
3048 p = expr->symtree->n.sym->attr.proc;
3050 if (expr->value.function.isym && expr->value.function.isym->inquiry)
3051 inquiry_argument = true;
3052 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
3054 if (resolve_actual_arglist (expr->value.function.actual,
3055 p, no_formal_args) == FAILURE)
3057 inquiry_argument = false;
3061 inquiry_argument = false;
3063 /* Need to setup the call to the correct c_associated, depending on
3064 the number of cptrs to user gives to compare. */
3065 if (sym && sym->attr.is_iso_c == 1)
3067 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
3071 /* Get the symtree for the new symbol (resolved func).
3072 the old one will be freed later, when it's no longer used. */
3073 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
3076 /* Resume assumed_size checking. */
3077 need_full_assumed_size--;
3079 /* If the procedure is external, check for usage. */
3080 if (sym && is_external_proc (sym))
3081 resolve_global_procedure (sym, &expr->where,
3082 &expr->value.function.actual, 0);
3084 if (sym && sym->ts.type == BT_CHARACTER
3086 && sym->ts.u.cl->length == NULL
3088 && !sym->ts.deferred
3089 && expr->value.function.esym == NULL
3090 && !sym->attr.contained)
3092 /* Internal procedures are taken care of in resolve_contained_fntype. */
3093 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
3094 "be used at %L since it is not a dummy argument",
3095 sym->name, &expr->where);
3099 /* See if function is already resolved. */
3101 if (expr->value.function.name != NULL)
3103 if (expr->ts.type == BT_UNKNOWN)
3109 /* Apply the rules of section 14.1.2. */
3111 switch (procedure_kind (sym))
3114 t = resolve_generic_f (expr);
3117 case PTYPE_SPECIFIC:
3118 t = resolve_specific_f (expr);
3122 t = resolve_unknown_f (expr);
3126 gfc_internal_error ("resolve_function(): bad function type");
3130 /* If the expression is still a function (it might have simplified),
3131 then we check to see if we are calling an elemental function. */
3133 if (expr->expr_type != EXPR_FUNCTION)
3136 temp = need_full_assumed_size;
3137 need_full_assumed_size = 0;
3139 if (resolve_elemental_actual (expr, NULL) == FAILURE)
3142 if (omp_workshare_flag
3143 && expr->value.function.esym
3144 && ! gfc_elemental (expr->value.function.esym))
3146 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3147 "in WORKSHARE construct", expr->value.function.esym->name,
3152 #define GENERIC_ID expr->value.function.isym->id
3153 else if (expr->value.function.actual != NULL
3154 && expr->value.function.isym != NULL
3155 && GENERIC_ID != GFC_ISYM_LBOUND
3156 && GENERIC_ID != GFC_ISYM_LEN
3157 && GENERIC_ID != GFC_ISYM_LOC
3158 && GENERIC_ID != GFC_ISYM_PRESENT)
3160 /* Array intrinsics must also have the last upper bound of an
3161 assumed size array argument. UBOUND and SIZE have to be
3162 excluded from the check if the second argument is anything
3165 for (arg = expr->value.function.actual; arg; arg = arg->next)
3167 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3168 && arg->next != NULL && arg->next->expr)
3170 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3173 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3176 if ((int)mpz_get_si (arg->next->expr->value.integer)
3181 if (arg->expr != NULL
3182 && arg->expr->rank > 0
3183 && resolve_assumed_size_actual (arg->expr))
3189 need_full_assumed_size = temp;
3192 if (!pure_function (expr, &name) && name)
3196 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3197 "FORALL %s", name, &expr->where,
3198 forall_flag == 2 ? "mask" : "block");
3201 else if (do_concurrent_flag)
3203 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3204 "DO CONCURRENT %s", name, &expr->where,
3205 do_concurrent_flag == 2 ? "mask" : "block");
3208 else if (gfc_pure (NULL))
3210 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3211 "procedure within a PURE procedure", name, &expr->where);
3215 if (gfc_implicit_pure (NULL))
3216 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3219 /* Functions without the RECURSIVE attribution are not allowed to
3220 * call themselves. */
3221 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3224 esym = expr->value.function.esym;
3226 if (is_illegal_recursion (esym, gfc_current_ns))
3228 if (esym->attr.entry && esym->ns->entries)
3229 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3230 " function '%s' is not RECURSIVE",
3231 esym->name, &expr->where, esym->ns->entries->sym->name);
3233 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3234 " is not RECURSIVE", esym->name, &expr->where);
3240 /* Character lengths of use associated functions may contains references to
3241 symbols not referenced from the current program unit otherwise. Make sure
3242 those symbols are marked as referenced. */
3244 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3245 && expr->value.function.esym->attr.use_assoc)
3247 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3250 /* Make sure that the expression has a typespec that works. */
3251 if (expr->ts.type == BT_UNKNOWN)
3253 if (expr->symtree->n.sym->result
3254 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3255 && !expr->symtree->n.sym->result->attr.proc_pointer)
3256 expr->ts = expr->symtree->n.sym->result->ts;
3263 /************* Subroutine resolution *************/
3266 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3272 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3273 sym->name, &c->loc);
3274 else if (do_concurrent_flag)
3275 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3276 "PURE", sym->name, &c->loc);
3277 else if (gfc_pure (NULL))
3278 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3281 if (gfc_implicit_pure (NULL))
3282 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3287 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3291 if (sym->attr.generic)
3293 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3296 c->resolved_sym = s;
3297 pure_subroutine (c, s);
3301 /* TODO: Need to search for elemental references in generic interface. */
3304 if (sym->attr.intrinsic)
3305 return gfc_intrinsic_sub_interface (c, 0);
3312 resolve_generic_s (gfc_code *c)
3317 sym = c->symtree->n.sym;
3321 m = resolve_generic_s0 (c, sym);
3324 else if (m == MATCH_ERROR)
3328 if (sym->ns->parent == NULL)
3330 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3334 if (!generic_sym (sym))
3338 /* Last ditch attempt. See if the reference is to an intrinsic
3339 that possesses a matching interface. 14.1.2.4 */
3340 sym = c->symtree->n.sym;
3342 if (!gfc_is_intrinsic (sym, 1, c->loc))
3344 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3345 sym->name, &c->loc);
3349 m = gfc_intrinsic_sub_interface (c, 0);
3353 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3354 "intrinsic subroutine interface", sym->name, &c->loc);
3360 /* Set the name and binding label of the subroutine symbol in the call
3361 expression represented by 'c' to include the type and kind of the
3362 second parameter. This function is for resolving the appropriate
3363 version of c_f_pointer() and c_f_procpointer(). For example, a
3364 call to c_f_pointer() for a default integer pointer could have a
3365 name of c_f_pointer_i4. If no second arg exists, which is an error
3366 for these two functions, it defaults to the generic symbol's name
3367 and binding label. */
3370 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3371 char *name, char *binding_label)
3373 gfc_expr *arg = NULL;
3377 /* The second arg of c_f_pointer and c_f_procpointer determines
3378 the type and kind for the procedure name. */
3379 arg = c->ext.actual->next->expr;
3383 /* Set up the name to have the given symbol's name,
3384 plus the type and kind. */
3385 /* a derived type is marked with the type letter 'u' */
3386 if (arg->ts.type == BT_DERIVED)
3389 kind = 0; /* set the kind as 0 for now */
3393 type = gfc_type_letter (arg->ts.type);
3394 kind = arg->ts.kind;
3397 if (arg->ts.type == BT_CHARACTER)
3398 /* Kind info for character strings not needed. */
3401 sprintf (name, "%s_%c%d", sym->name, type, kind);
3402 /* Set up the binding label as the given symbol's label plus
3403 the type and kind. */
3404 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
3408 /* If the second arg is missing, set the name and label as
3409 was, cause it should at least be found, and the missing
3410 arg error will be caught by compare_parameters(). */
3411 sprintf (name, "%s", sym->name);
3412 sprintf (binding_label, "%s", sym->binding_label);
3419 /* Resolve a generic version of the iso_c_binding procedure given
3420 (sym) to the specific one based on the type and kind of the
3421 argument(s). Currently, this function resolves c_f_pointer() and
3422 c_f_procpointer based on the type and kind of the second argument
3423 (FPTR). Other iso_c_binding procedures aren't specially handled.
3424 Upon successfully exiting, c->resolved_sym will hold the resolved
3425 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3429 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3431 gfc_symbol *new_sym;
3432 /* this is fine, since we know the names won't use the max */
3433 char name[GFC_MAX_SYMBOL_LEN + 1];
3434 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
3435 /* default to success; will override if find error */
3436 match m = MATCH_YES;
3438 /* Make sure the actual arguments are in the necessary order (based on the
3439 formal args) before resolving. */
3440 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3442 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3443 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3445 set_name_and_label (c, sym, name, binding_label);
3447 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3449 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3451 /* Make sure we got a third arg if the second arg has non-zero
3452 rank. We must also check that the type and rank are
3453 correct since we short-circuit this check in
3454 gfc_procedure_use() (called above to sort actual args). */
3455 if (c->ext.actual->next->expr->rank != 0)
3457 if(c->ext.actual->next->next == NULL
3458 || c->ext.actual->next->next->expr == NULL)
3461 gfc_error ("Missing SHAPE parameter for call to %s "
3462 "at %L", sym->name, &(c->loc));
3464 else if (c->ext.actual->next->next->expr->ts.type
3466 || c->ext.actual->next->next->expr->rank != 1)
3469 gfc_error ("SHAPE parameter for call to %s at %L must "
3470 "be a rank 1 INTEGER array", sym->name,
3477 if (m != MATCH_ERROR)
3479 /* the 1 means to add the optional arg to formal list */
3480 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3482 /* for error reporting, say it's declared where the original was */
3483 new_sym->declared_at = sym->declared_at;
3488 /* no differences for c_loc or c_funloc */
3492 /* set the resolved symbol */
3493 if (m != MATCH_ERROR)
3494 c->resolved_sym = new_sym;
3496 c->resolved_sym = sym;
3502 /* Resolve a subroutine call known to be specific. */
3505 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3509 if(sym->attr.is_iso_c)
3511 m = gfc_iso_c_sub_interface (c,sym);
3515 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3517 if (sym->attr.dummy)
3519 sym->attr.proc = PROC_DUMMY;
3523 sym->attr.proc = PROC_EXTERNAL;
3527 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3530 if (sym->attr.intrinsic)
3532 m = gfc_intrinsic_sub_interface (c, 1);
3536 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3537 "with an intrinsic", sym->name, &c->loc);
3545 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3547 c->resolved_sym = sym;
3548 pure_subroutine (c, sym);
3555 resolve_specific_s (gfc_code *c)
3560 sym = c->symtree->n.sym;
3564 m = resolve_specific_s0 (c, sym);
3567 if (m == MATCH_ERROR)
3570 if (sym->ns->parent == NULL)
3573 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3579 sym = c->symtree->n.sym;
3580 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3581 sym->name, &c->loc);
3587 /* Resolve a subroutine call not known to be generic nor specific. */
3590 resolve_unknown_s (gfc_code *c)
3594 sym = c->symtree->n.sym;
3596 if (sym->attr.dummy)
3598 sym->attr.proc = PROC_DUMMY;
3602 /* See if we have an intrinsic function reference. */
3604 if (gfc_is_intrinsic (sym, 1, c->loc))
3606 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3611 /* The reference is to an external name. */
3614 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3616 c->resolved_sym = sym;
3618 pure_subroutine (c, sym);
3624 /* Resolve a subroutine call. Although it was tempting to use the same code
3625 for functions, subroutines and functions are stored differently and this
3626 makes things awkward. */
3629 resolve_call (gfc_code *c)
3632 procedure_type ptype = PROC_INTRINSIC;
3633 gfc_symbol *csym, *sym;
3634 bool no_formal_args;
3636 csym = c->symtree ? c->symtree->n.sym : NULL;
3638 if (csym && csym->ts.type != BT_UNKNOWN)
3640 gfc_error ("'%s' at %L has a type, which is not consistent with "
3641 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3645 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3648 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3649 sym = st ? st->n.sym : NULL;
3650 if (sym && csym != sym
3651 && sym->ns == gfc_current_ns
3652 && sym->attr.flavor == FL_PROCEDURE
3653 && sym->attr.contained)
3656 if (csym->attr.generic)
3657 c->symtree->n.sym = sym;
3660 csym = c->symtree->n.sym;
3664 /* If this ia a deferred TBP with an abstract interface
3665 (which may of course be referenced), c->expr1 will be set. */
3666 if (csym && csym->attr.abstract && !c->expr1)
3668 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3669 csym->name, &c->loc);
3673 /* Subroutines without the RECURSIVE attribution are not allowed to
3674 * call themselves. */
3675 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3677 if (csym->attr.entry && csym->ns->entries)
3678 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3679 " subroutine '%s' is not RECURSIVE",
3680 csym->name, &c->loc, csym->ns->entries->sym->name);
3682 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3683 " is not RECURSIVE", csym->name, &c->loc);
3688 /* Switch off assumed size checking and do this again for certain kinds
3689 of procedure, once the procedure itself is resolved. */
3690 need_full_assumed_size++;
3693 ptype = csym->attr.proc;
3695 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3696 if (resolve_actual_arglist (c->ext.actual, ptype,
3697 no_formal_args) == FAILURE)
3700 /* Resume assumed_size checking. */
3701 need_full_assumed_size--;
3703 /* If external, check for usage. */
3704 if (csym && is_external_proc (csym))
3705 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3708 if (c->resolved_sym == NULL)
3710 c->resolved_isym = NULL;
3711 switch (procedure_kind (csym))
3714 t = resolve_generic_s (c);
3717 case PTYPE_SPECIFIC:
3718 t = resolve_specific_s (c);
3722 t = resolve_unknown_s (c);
3726 gfc_internal_error ("resolve_subroutine(): bad function type");
3730 /* Some checks of elemental subroutine actual arguments. */
3731 if (resolve_elemental_actual (NULL, c) == FAILURE)
3738 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3739 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3740 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3741 if their shapes do not match. If either op1->shape or op2->shape is
3742 NULL, return SUCCESS. */
3745 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3752 if (op1->shape != NULL && op2->shape != NULL)
3754 for (i = 0; i < op1->rank; i++)
3756 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3758 gfc_error ("Shapes for operands at %L and %L are not conformable",
3759 &op1->where, &op2->where);
3770 /* Resolve an operator expression node. This can involve replacing the
3771 operation with a user defined function call. */
3774 resolve_operator (gfc_expr *e)
3776 gfc_expr *op1, *op2;
3778 bool dual_locus_error;
3781 /* Resolve all subnodes-- give them types. */
3783 switch (e->value.op.op)
3786 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3789 /* Fall through... */
3792 case INTRINSIC_UPLUS:
3793 case INTRINSIC_UMINUS:
3794 case INTRINSIC_PARENTHESES:
3795 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3800 /* Typecheck the new node. */
3802 op1 = e->value.op.op1;
3803 op2 = e->value.op.op2;
3804 dual_locus_error = false;
3806 if ((op1 && op1->expr_type == EXPR_NULL)
3807 || (op2 && op2->expr_type == EXPR_NULL))
3809 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3813 switch (e->value.op.op)
3815 case INTRINSIC_UPLUS:
3816 case INTRINSIC_UMINUS:
3817 if (op1->ts.type == BT_INTEGER
3818 || op1->ts.type == BT_REAL
3819 || op1->ts.type == BT_COMPLEX)
3825 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3826 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3829 case INTRINSIC_PLUS:
3830 case INTRINSIC_MINUS:
3831 case INTRINSIC_TIMES:
3832 case INTRINSIC_DIVIDE:
3833 case INTRINSIC_POWER:
3834 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3836 gfc_type_convert_binary (e, 1);
3841 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3842 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3843 gfc_typename (&op2->ts));
3846 case INTRINSIC_CONCAT:
3847 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3848 && op1->ts.kind == op2->ts.kind)
3850 e->ts.type = BT_CHARACTER;
3851 e->ts.kind = op1->ts.kind;
3856 _("Operands of string concatenation operator at %%L are %s/%s"),
3857 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3863 case INTRINSIC_NEQV:
3864 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3866 e->ts.type = BT_LOGICAL;
3867 e->ts.kind = gfc_kind_max (op1, op2);
3868 if (op1->ts.kind < e->ts.kind)
3869 gfc_convert_type (op1, &e->ts, 2);
3870 else if (op2->ts.kind < e->ts.kind)
3871 gfc_convert_type (op2, &e->ts, 2);
3875 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3876 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3877 gfc_typename (&op2->ts));
3882 if (op1->ts.type == BT_LOGICAL)
3884 e->ts.type = BT_LOGICAL;
3885 e->ts.kind = op1->ts.kind;
3889 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3890 gfc_typename (&op1->ts));
3894 case INTRINSIC_GT_OS:
3896 case INTRINSIC_GE_OS:
3898 case INTRINSIC_LT_OS:
3900 case INTRINSIC_LE_OS:
3901 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3903 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3907 /* Fall through... */
3910 case INTRINSIC_EQ_OS:
3912 case INTRINSIC_NE_OS:
3913 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3914 && op1->ts.kind == op2->ts.kind)
3916 e->ts.type = BT_LOGICAL;
3917 e->ts.kind = gfc_default_logical_kind;
3921 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3923 gfc_type_convert_binary (e, 1);
3925 e->ts.type = BT_LOGICAL;
3926 e->ts.kind = gfc_default_logical_kind;
3930 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3932 _("Logicals at %%L must be compared with %s instead of %s"),
3933 (e->value.op.op == INTRINSIC_EQ
3934 || e->value.op.op == INTRINSIC_EQ_OS)
3935 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3938 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3939 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3940 gfc_typename (&op2->ts));
3944 case INTRINSIC_USER:
3945 if (e->value.op.uop->op == NULL)
3946 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3947 else if (op2 == NULL)
3948 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3949 e->value.op.uop->name, gfc_typename (&op1->ts));
3952 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3953 e->value.op.uop->name, gfc_typename (&op1->ts),
3954 gfc_typename (&op2->ts));
3955 e->value.op.uop->op->sym->attr.referenced = 1;
3960 case INTRINSIC_PARENTHESES:
3962 if (e->ts.type == BT_CHARACTER)
3963 e->ts.u.cl = op1->ts.u.cl;
3967 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3970 /* Deal with arrayness of an operand through an operator. */
3974 switch (e->value.op.op)
3976 case INTRINSIC_PLUS:
3977 case INTRINSIC_MINUS:
3978 case INTRINSIC_TIMES:
3979 case INTRINSIC_DIVIDE:
3980 case INTRINSIC_POWER:
3981 case INTRINSIC_CONCAT:
3985 case INTRINSIC_NEQV:
3987 case INTRINSIC_EQ_OS:
3989 case INTRINSIC_NE_OS:
3991 case INTRINSIC_GT_OS:
3993 case INTRINSIC_GE_OS:
3995 case INTRINSIC_LT_OS:
3997 case INTRINSIC_LE_OS:
3999 if (op1->rank == 0 && op2->rank == 0)
4002 if (op1->rank == 0 && op2->rank != 0)
4004 e->rank = op2->rank;
4006 if (e->shape == NULL)
4007 e->shape = gfc_copy_shape (op2->shape, op2->rank);
4010 if (op1->rank != 0 && op2->rank == 0)
4012 e->rank = op1->rank;
4014 if (e->shape == NULL)
4015 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4018 if (op1->rank != 0 && op2->rank != 0)
4020 if (op1->rank == op2->rank)
4022 e->rank = op1->rank;
4023 if (e->shape == NULL)
4025 t = compare_shapes (op1, op2);
4029 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4034 /* Allow higher level expressions to work. */
4037 /* Try user-defined operators, and otherwise throw an error. */
4038 dual_locus_error = true;
4040 _("Inconsistent ranks for operator at %%L and %%L"));
4047 case INTRINSIC_PARENTHESES:
4049 case INTRINSIC_UPLUS:
4050 case INTRINSIC_UMINUS:
4051 /* Simply copy arrayness attribute */
4052 e->rank = op1->rank;
4054 if (e->shape == NULL)
4055 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4063 /* Attempt to simplify the expression. */
4066 t = gfc_simplify_expr (e, 0);
4067 /* Some calls do not succeed in simplification and return FAILURE
4068 even though there is no error; e.g. variable references to
4069 PARAMETER arrays. */
4070 if (!gfc_is_constant_expr (e))
4078 match m = gfc_extend_expr (e);
4081 if (m == MATCH_ERROR)
4085 if (dual_locus_error)
4086 gfc_error (msg, &op1->where, &op2->where);
4088 gfc_error (msg, &e->where);
4094 /************** Array resolution subroutines **************/
4097 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
4100 /* Compare two integer expressions. */
4103 compare_bound (gfc_expr *a, gfc_expr *b)
4107 if (a == NULL || a->expr_type != EXPR_CONSTANT
4108 || b == NULL || b->expr_type != EXPR_CONSTANT)
4111 /* If either of the types isn't INTEGER, we must have
4112 raised an error earlier. */
4114 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
4117 i = mpz_cmp (a->value.integer, b->value.integer);
4127 /* Compare an integer expression with an integer. */
4130 compare_bound_int (gfc_expr *a, int b)
4134 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4137 if (a->ts.type != BT_INTEGER)
4138 gfc_internal_error ("compare_bound_int(): Bad expression");
4140 i = mpz_cmp_si (a->value.integer, b);
4150 /* Compare an integer expression with a mpz_t. */
4153 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4157 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4160 if (a->ts.type != BT_INTEGER)
4161 gfc_internal_error ("compare_bound_int(): Bad expression");
4163 i = mpz_cmp (a->value.integer, b);
4173 /* Compute the last value of a sequence given by a triplet.
4174 Return 0 if it wasn't able to compute the last value, or if the
4175 sequence if empty, and 1 otherwise. */
4178 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4179 gfc_expr *stride, mpz_t last)
4183 if (start == NULL || start->expr_type != EXPR_CONSTANT
4184 || end == NULL || end->expr_type != EXPR_CONSTANT
4185 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4188 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4189 || (stride != NULL && stride->ts.type != BT_INTEGER))
4192 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
4194 if (compare_bound (start, end) == CMP_GT)
4196 mpz_set (last, end->value.integer);
4200 if (compare_bound_int (stride, 0) == CMP_GT)
4202 /* Stride is positive */
4203 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4208 /* Stride is negative */
4209 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4214 mpz_sub (rem, end->value.integer, start->value.integer);
4215 mpz_tdiv_r (rem, rem, stride->value.integer);
4216 mpz_sub (last, end->value.integer, rem);
4223 /* Compare a single dimension of an array reference to the array
4227 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4231 if (ar->dimen_type[i] == DIMEN_STAR)
4233 gcc_assert (ar->stride[i] == NULL);
4234 /* This implies [*] as [*:] and [*:3] are not possible. */
4235 if (ar->start[i] == NULL)
4237 gcc_assert (ar->end[i] == NULL);
4242 /* Given start, end and stride values, calculate the minimum and
4243 maximum referenced indexes. */
4245 switch (ar->dimen_type[i])
4248 case DIMEN_THIS_IMAGE:
4253 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4256 gfc_warning ("Array reference at %L is out of bounds "
4257 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4258 mpz_get_si (ar->start[i]->value.integer),
4259 mpz_get_si (as->lower[i]->value.integer), i+1);
4261 gfc_warning ("Array reference at %L is out of bounds "
4262 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4263 mpz_get_si (ar->start[i]->value.integer),
4264 mpz_get_si (as->lower[i]->value.integer),
4268 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4271 gfc_warning ("Array reference at %L is out of bounds "
4272 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4273 mpz_get_si (ar->start[i]->value.integer),
4274 mpz_get_si (as->upper[i]->value.integer), i+1);
4276 gfc_warning ("Array reference at %L is out of bounds "
4277 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4278 mpz_get_si (ar->start[i]->value.integer),
4279 mpz_get_si (as->upper[i]->value.integer),
4288 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4289 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4291 comparison comp_start_end = compare_bound (AR_START, AR_END);
4293 /* Check for zero stride, which is not allowed. */
4294 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4296 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4300 /* if start == len || (stride > 0 && start < len)
4301 || (stride < 0 && start > len),
4302 then the array section contains at least one element. In this
4303 case, there is an out-of-bounds access if
4304 (start < lower || start > upper). */
4305 if (compare_bound (AR_START, AR_END) == CMP_EQ
4306 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4307 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4308 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4309 && comp_start_end == CMP_GT))
4311 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4313 gfc_warning ("Lower array reference at %L is out of bounds "
4314 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4315 mpz_get_si (AR_START->value.integer),
4316 mpz_get_si (as->lower[i]->value.integer), i+1);
4319 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4321 gfc_warning ("Lower array reference at %L is out of bounds "
4322 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4323 mpz_get_si (AR_START->value.integer),
4324 mpz_get_si (as->upper[i]->value.integer), i+1);
4329 /* If we can compute the highest index of the array section,
4330 then it also has to be between lower and upper. */
4331 mpz_init (last_value);
4332 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4335 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4337 gfc_warning ("Upper array reference at %L is out of bounds "
4338 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4339 mpz_get_si (last_value),
4340 mpz_get_si (as->lower[i]->value.integer), i+1);
4341 mpz_clear (last_value);
4344 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4346 gfc_warning ("Upper array reference at %L is out of bounds "
4347 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4348 mpz_get_si (last_value),
4349 mpz_get_si (as->upper[i]->value.integer), i+1);
4350 mpz_clear (last_value);
4354 mpz_clear (last_value);
4362 gfc_internal_error ("check_dimension(): Bad array reference");
4369 /* Compare an array reference with an array specification. */
4372 compare_spec_to_ref (gfc_array_ref *ar)
4379 /* TODO: Full array sections are only allowed as actual parameters. */
4380 if (as->type == AS_ASSUMED_SIZE
4381 && (/*ar->type == AR_FULL
4382 ||*/ (ar->type == AR_SECTION
4383 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4385 gfc_error ("Rightmost upper bound of assumed size array section "
4386 "not specified at %L", &ar->where);
4390 if (ar->type == AR_FULL)
4393 if (as->rank != ar->dimen)
4395 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4396 &ar->where, ar->dimen, as->rank);
4400 /* ar->codimen == 0 is a local array. */
4401 if (as->corank != ar->codimen && ar->codimen != 0)
4403 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4404 &ar->where, ar->codimen, as->corank);
4408 for (i = 0; i < as->rank; i++)
4409 if (check_dimension (i, ar, as) == FAILURE)
4412 /* Local access has no coarray spec. */
4413 if (ar->codimen != 0)
4414 for (i = as->rank; i < as->rank + as->corank; i++)
4416 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
4417 && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
4419 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4420 i + 1 - as->rank, &ar->where);
4423 if (check_dimension (i, ar, as) == FAILURE)
4431 /* Resolve one part of an array index. */
4434 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4435 int force_index_integer_kind)
4442 if (gfc_resolve_expr (index) == FAILURE)
4445 if (check_scalar && index->rank != 0)
4447 gfc_error ("Array index at %L must be scalar", &index->where);
4451 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4453 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4454 &index->where, gfc_basic_typename (index->ts.type));
4458 if (index->ts.type == BT_REAL)
4459 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
4460 &index->where) == FAILURE)
4463 if ((index->ts.kind != gfc_index_integer_kind
4464 && force_index_integer_kind)
4465 || index->ts.type != BT_INTEGER)
4468 ts.type = BT_INTEGER;
4469 ts.kind = gfc_index_integer_kind;
4471 gfc_convert_type_warn (index, &ts, 2, 0);
4477 /* Resolve one part of an array index. */
4480 gfc_resolve_index (gfc_expr *index, int check_scalar)
4482 return gfc_resolve_index_1 (index, check_scalar, 1);
4485 /* Resolve a dim argument to an intrinsic function. */
4488 gfc_resolve_dim_arg (gfc_expr *dim)
4493 if (gfc_resolve_expr (dim) == FAILURE)
4498 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4503 if (dim->ts.type != BT_INTEGER)
4505 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4509 if (dim->ts.kind != gfc_index_integer_kind)
4514 ts.type = BT_INTEGER;
4515 ts.kind = gfc_index_integer_kind;
4517 gfc_convert_type_warn (dim, &ts, 2, 0);
4523 /* Given an expression that contains array references, update those array
4524 references to point to the right array specifications. While this is
4525 filled in during matching, this information is difficult to save and load
4526 in a module, so we take care of it here.
4528 The idea here is that the original array reference comes from the
4529 base symbol. We traverse the list of reference structures, setting
4530 the stored reference to references. Component references can
4531 provide an additional array specification. */
4534 find_array_spec (gfc_expr *e)
4540 if (e->symtree->n.sym->ts.type == BT_CLASS)
4541 as = CLASS_DATA (e->symtree->n.sym)->as;
4543 as = e->symtree->n.sym->as;
4545 for (ref = e->ref; ref; ref = ref->next)
4550 gfc_internal_error ("find_array_spec(): Missing spec");
4557 c = ref->u.c.component;
4558 if (c->attr.dimension)
4561 gfc_internal_error ("find_array_spec(): unused as(1)");
4572 gfc_internal_error ("find_array_spec(): unused as(2)");
4576 /* Resolve an array reference. */
4579 resolve_array_ref (gfc_array_ref *ar)
4581 int i, check_scalar;
4584 for (i = 0; i < ar->dimen + ar->codimen; i++)
4586 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4588 /* Do not force gfc_index_integer_kind for the start. We can
4589 do fine with any integer kind. This avoids temporary arrays
4590 created for indexing with a vector. */
4591 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4593 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4595 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4600 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4604 ar->dimen_type[i] = DIMEN_ELEMENT;
4608 ar->dimen_type[i] = DIMEN_VECTOR;
4609 if (e->expr_type == EXPR_VARIABLE
4610 && e->symtree->n.sym->ts.type == BT_DERIVED)
4611 ar->start[i] = gfc_get_parentheses (e);
4615 gfc_error ("Array index at %L is an array of rank %d",
4616 &ar->c_where[i], e->rank);
4620 /* Fill in the upper bound, which may be lower than the
4621 specified one for something like a(2:10:5), which is
4622 identical to a(2:7:5). Only relevant for strides not equal
4623 to one. Don't try a division by zero. */
4624 if (ar->dimen_type[i] == DIMEN_RANGE
4625 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4626 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
4627 && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
4631 if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4633 if (ar->end[i] == NULL)
4636 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4638 mpz_set (ar->end[i]->value.integer, end);
4640 else if (ar->end[i]->ts.type == BT_INTEGER
4641 && ar->end[i]->expr_type == EXPR_CONSTANT)
4643 mpz_set (ar->end[i]->value.integer, end);
4654 if (ar->type == AR_FULL)
4656 if (ar->as->rank == 0)
4657 ar->type = AR_ELEMENT;
4659 /* Make sure array is the same as array(:,:), this way
4660 we don't need to special case all the time. */
4661 ar->dimen = ar->as->rank;
4662 for (i = 0; i < ar->dimen; i++)
4664 ar->dimen_type[i] = DIMEN_RANGE;
4666 gcc_assert (ar->start[i] == NULL);
4667 gcc_assert (ar->end[i] == NULL);
4668 gcc_assert (ar->stride[i] == NULL);
4672 /* If the reference type is unknown, figure out what kind it is. */
4674 if (ar->type == AR_UNKNOWN)
4676 ar->type = AR_ELEMENT;
4677 for (i = 0; i < ar->dimen; i++)
4678 if (ar->dimen_type[i] == DIMEN_RANGE
4679 || ar->dimen_type[i] == DIMEN_VECTOR)
4681 ar->type = AR_SECTION;
4686 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4689 if (ar->as->corank && ar->codimen == 0)
4692 ar->codimen = ar->as->corank;
4693 for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
4694 ar->dimen_type[n] = DIMEN_THIS_IMAGE;
4702 resolve_substring (gfc_ref *ref)
4704 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4706 if (ref->u.ss.start != NULL)
4708 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4711 if (ref->u.ss.start->ts.type != BT_INTEGER)
4713 gfc_error ("Substring start index at %L must be of type INTEGER",
4714 &ref->u.ss.start->where);
4718 if (ref->u.ss.start->rank != 0)
4720 gfc_error ("Substring start index at %L must be scalar",
4721 &ref->u.ss.start->where);
4725 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4726 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4727 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4729 gfc_error ("Substring start index at %L is less than one",
4730 &ref->u.ss.start->where);
4735 if (ref->u.ss.end != NULL)
4737 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4740 if (ref->u.ss.end->ts.type != BT_INTEGER)
4742 gfc_error ("Substring end index at %L must be of type INTEGER",
4743 &ref->u.ss.end->where);
4747 if (ref->u.ss.end->rank != 0)
4749 gfc_error ("Substring end index at %L must be scalar",
4750 &ref->u.ss.end->where);
4754 if (ref->u.ss.length != NULL
4755 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4756 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4757 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4759 gfc_error ("Substring end index at %L exceeds the string length",
4760 &ref->u.ss.start->where);
4764 if (compare_bound_mpz_t (ref->u.ss.end,
4765 gfc_integer_kinds[k].huge) == CMP_GT
4766 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4767 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4769 gfc_error ("Substring end index at %L is too large",
4770 &ref->u.ss.end->where);
4779 /* This function supplies missing substring charlens. */
4782 gfc_resolve_substring_charlen (gfc_expr *e)
4785 gfc_expr *start, *end;
4787 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4788 if (char_ref->type == REF_SUBSTRING)
4794 gcc_assert (char_ref->next == NULL);
4798 if (e->ts.u.cl->length)
4799 gfc_free_expr (e->ts.u.cl->length);
4800 else if (e->expr_type == EXPR_VARIABLE
4801 && e->symtree->n.sym->attr.dummy)
4805 e->ts.type = BT_CHARACTER;
4806 e->ts.kind = gfc_default_character_kind;
4809 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4811 if (char_ref->u.ss.start)
4812 start = gfc_copy_expr (char_ref->u.ss.start);
4814 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4816 if (char_ref->u.ss.end)
4817 end = gfc_copy_expr (char_ref->u.ss.end);
4818 else if (e->expr_type == EXPR_VARIABLE)
4819 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4826 /* Length = (end - start +1). */
4827 e->ts.u.cl->length = gfc_subtract (end, start);
4828 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4829 gfc_get_int_expr (gfc_default_integer_kind,
4832 e->ts.u.cl->length->ts.type = BT_INTEGER;
4833 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4835 /* Make sure that the length is simplified. */
4836 gfc_simplify_expr (e->ts.u.cl->length, 1);
4837 gfc_resolve_expr (e->ts.u.cl->length);
4841 /* Resolve subtype references. */
4844 resolve_ref (gfc_expr *expr)
4846 int current_part_dimension, n_components, seen_part_dimension;
4849 for (ref = expr->ref; ref; ref = ref->next)
4850 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4852 find_array_spec (expr);
4856 for (ref = expr->ref; ref; ref = ref->next)
4860 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4868 if (resolve_substring (ref) == FAILURE)
4873 /* Check constraints on part references. */
4875 current_part_dimension = 0;
4876 seen_part_dimension = 0;
4879 for (ref = expr->ref; ref; ref = ref->next)
4884 switch (ref->u.ar.type)
4887 /* Coarray scalar. */
4888 if (ref->u.ar.as->rank == 0)
4890 current_part_dimension = 0;
4895 current_part_dimension = 1;
4899 current_part_dimension = 0;
4903 gfc_internal_error ("resolve_ref(): Bad array reference");
4909 if (current_part_dimension || seen_part_dimension)
4912 if (ref->u.c.component->attr.pointer
4913 || ref->u.c.component->attr.proc_pointer)
4915 gfc_error ("Component to the right of a part reference "
4916 "with nonzero rank must not have the POINTER "
4917 "attribute at %L", &expr->where);
4920 else if (ref->u.c.component->attr.allocatable)
4922 gfc_error ("Component to the right of a part reference "
4923 "with nonzero rank must not have the ALLOCATABLE "
4924 "attribute at %L", &expr->where);
4936 if (((ref->type == REF_COMPONENT && n_components > 1)
4937 || ref->next == NULL)
4938 && current_part_dimension
4939 && seen_part_dimension)
4941 gfc_error ("Two or more part references with nonzero rank must "
4942 "not be specified at %L", &expr->where);
4946 if (ref->type == REF_COMPONENT)
4948 if (current_part_dimension)
4949 seen_part_dimension = 1;
4951 /* reset to make sure */
4952 current_part_dimension = 0;
4960 /* Given an expression, determine its shape. This is easier than it sounds.
4961 Leaves the shape array NULL if it is not possible to determine the shape. */
4964 expression_shape (gfc_expr *e)
4966 mpz_t array[GFC_MAX_DIMENSIONS];
4969 if (e->rank == 0 || e->shape != NULL)
4972 for (i = 0; i < e->rank; i++)
4973 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4976 e->shape = gfc_get_shape (e->rank);
4978 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4983 for (i--; i >= 0; i--)
4984 mpz_clear (array[i]);
4988 /* Given a variable expression node, compute the rank of the expression by
4989 examining the base symbol and any reference structures it may have. */
4992 expression_rank (gfc_expr *e)
4997 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4998 could lead to serious confusion... */
4999 gcc_assert (e->expr_type != EXPR_COMPCALL);
5003 if (e->expr_type == EXPR_ARRAY)
5005 /* Constructors can have a rank different from one via RESHAPE(). */
5007 if (e->symtree == NULL)
5013 e->rank = (e->symtree->n.sym->as == NULL)
5014 ? 0 : e->symtree->n.sym->as->rank;
5020 for (ref = e->ref; ref; ref = ref->next)
5022 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
5023 && ref->u.c.component->attr.function && !ref->next)
5024 rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
5026 if (ref->type != REF_ARRAY)
5029 if (ref->u.ar.type == AR_FULL)
5031 rank = ref->u.ar.as->rank;
5035 if (ref->u.ar.type == AR_SECTION)
5037 /* Figure out the rank of the section. */
5039 gfc_internal_error ("expression_rank(): Two array specs");
5041 for (i = 0; i < ref->u.ar.dimen; i++)
5042 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
5043 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
5053 expression_shape (e);
5057 /* Resolve a variable expression. */
5060 resolve_variable (gfc_expr *e)
5067 if (e->symtree == NULL)
5069 sym = e->symtree->n.sym;
5071 /* If this is an associate-name, it may be parsed with an array reference
5072 in error even though the target is scalar. Fail directly in this case. */
5073 if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
5076 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
5077 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
5079 /* On the other hand, the parser may not have known this is an array;
5080 in this case, we have to add a FULL reference. */
5081 if (sym->assoc && sym->attr.dimension && !e->ref)
5083 e->ref = gfc_get_ref ();
5084 e->ref->type = REF_ARRAY;
5085 e->ref->u.ar.type = AR_FULL;
5086 e->ref->u.ar.dimen = 0;
5089 if (e->ref && resolve_ref (e) == FAILURE)
5092 if (sym->attr.flavor == FL_PROCEDURE
5093 && (!sym->attr.function
5094 || (sym->attr.function && sym->result
5095 && sym->result->attr.proc_pointer
5096 && !sym->result->attr.function)))
5098 e->ts.type = BT_PROCEDURE;
5099 goto resolve_procedure;
5102 if (sym->ts.type != BT_UNKNOWN)
5103 gfc_variable_attr (e, &e->ts);
5106 /* Must be a simple variable reference. */
5107 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
5112 if (check_assumed_size_reference (sym, e))
5115 /* Deal with forward references to entries during resolve_code, to
5116 satisfy, at least partially, 12.5.2.5. */
5117 if (gfc_current_ns->entries
5118 && current_entry_id == sym->entry_id
5121 && cs_base->current->op != EXEC_ENTRY)
5123 gfc_entry_list *entry;
5124 gfc_formal_arglist *formal;
5128 /* If the symbol is a dummy... */
5129 if (sym->attr.dummy && sym->ns == gfc_current_ns)
5131 entry = gfc_current_ns->entries;
5134 /* ...test if the symbol is a parameter of previous entries. */
5135 for (; entry && entry->id <= current_entry_id; entry = entry->next)
5136 for (formal = entry->sym->formal; formal; formal = formal->next)
5138 if (formal->sym && sym->name == formal->sym->name)
5142 /* If it has not been seen as a dummy, this is an error. */
5145 if (specification_expr)
5146 gfc_error ("Variable '%s', used in a specification expression"
5147 ", is referenced at %L before the ENTRY statement "
5148 "in which it is a parameter",
5149 sym->name, &cs_base->current->loc);
5151 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5152 "statement in which it is a parameter",
5153 sym->name, &cs_base->current->loc);
5158 /* Now do the same check on the specification expressions. */
5159 specification_expr = 1;
5160 if (sym->ts.type == BT_CHARACTER
5161 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
5165 for (n = 0; n < sym->as->rank; n++)
5167 specification_expr = 1;
5168 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
5170 specification_expr = 1;
5171 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
5174 specification_expr = 0;
5177 /* Update the symbol's entry level. */
5178 sym->entry_id = current_entry_id + 1;
5181 /* If a symbol has been host_associated mark it. This is used latter,
5182 to identify if aliasing is possible via host association. */
5183 if (sym->attr.flavor == FL_VARIABLE
5184 && gfc_current_ns->parent
5185 && (gfc_current_ns->parent == sym->ns
5186 || (gfc_current_ns->parent->parent
5187 && gfc_current_ns->parent->parent == sym->ns)))
5188 sym->attr.host_assoc = 1;
5191 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
5194 /* F2008, C617 and C1229. */
5195 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5196 && gfc_is_coindexed (e))
5198 gfc_ref *ref, *ref2 = NULL;
5200 for (ref = e->ref; ref; ref = ref->next)
5202 if (ref->type == REF_COMPONENT)
5204 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5208 for ( ; ref; ref = ref->next)
5209 if (ref->type == REF_COMPONENT)
5212 /* Expression itself is not coindexed object. */
5213 if (ref && e->ts.type == BT_CLASS)
5215 gfc_error ("Polymorphic subobject of coindexed object at %L",
5220 /* Expression itself is coindexed object. */
5224 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5225 for ( ; c; c = c->next)
5226 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5228 gfc_error ("Coindexed object with polymorphic allocatable "
5229 "subcomponent at %L", &e->where);
5240 /* Checks to see that the correct symbol has been host associated.
5241 The only situation where this arises is that in which a twice
5242 contained function is parsed after the host association is made.
5243 Therefore, on detecting this, change the symbol in the expression
5244 and convert the array reference into an actual arglist if the old
5245 symbol is a variable. */
5247 check_host_association (gfc_expr *e)
5249 gfc_symbol *sym, *old_sym;
5253 gfc_actual_arglist *arg, *tail = NULL;
5254 bool retval = e->expr_type == EXPR_FUNCTION;
5256 /* If the expression is the result of substitution in
5257 interface.c(gfc_extend_expr) because there is no way in
5258 which the host association can be wrong. */
5259 if (e->symtree == NULL
5260 || e->symtree->n.sym == NULL
5261 || e->user_operator)
5264 old_sym = e->symtree->n.sym;
5266 if (gfc_current_ns->parent
5267 && old_sym->ns != gfc_current_ns)
5269 /* Use the 'USE' name so that renamed module symbols are
5270 correctly handled. */
5271 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5273 if (sym && old_sym != sym
5274 && sym->ts.type == old_sym->ts.type
5275 && sym->attr.flavor == FL_PROCEDURE
5276 && sym->attr.contained)
5278 /* Clear the shape, since it might not be valid. */
5279 gfc_free_shape (&e->shape, e->rank);
5281 /* Give the expression the right symtree! */
5282 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5283 gcc_assert (st != NULL);
5285 if (old_sym->attr.flavor == FL_PROCEDURE
5286 || e->expr_type == EXPR_FUNCTION)
5288 /* Original was function so point to the new symbol, since
5289 the actual argument list is already attached to the
5291 e->value.function.esym = NULL;
5296 /* Original was variable so convert array references into
5297 an actual arglist. This does not need any checking now
5298 since resolve_function will take care of it. */
5299 e->value.function.actual = NULL;
5300 e->expr_type = EXPR_FUNCTION;
5303 /* Ambiguity will not arise if the array reference is not
5304 the last reference. */
5305 for (ref = e->ref; ref; ref = ref->next)
5306 if (ref->type == REF_ARRAY && ref->next == NULL)
5309 gcc_assert (ref->type == REF_ARRAY);
5311 /* Grab the start expressions from the array ref and
5312 copy them into actual arguments. */
5313 for (n = 0; n < ref->u.ar.dimen; n++)
5315 arg = gfc_get_actual_arglist ();
5316 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5317 if (e->value.function.actual == NULL)
5318 tail = e->value.function.actual = arg;
5326 /* Dump the reference list and set the rank. */
5327 gfc_free_ref_list (e->ref);
5329 e->rank = sym->as ? sym->as->rank : 0;
5332 gfc_resolve_expr (e);
5336 /* This might have changed! */
5337 return e->expr_type == EXPR_FUNCTION;
5342 gfc_resolve_character_operator (gfc_expr *e)
5344 gfc_expr *op1 = e->value.op.op1;
5345 gfc_expr *op2 = e->value.op.op2;
5346 gfc_expr *e1 = NULL;
5347 gfc_expr *e2 = NULL;
5349 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5351 if (op1->ts.u.cl && op1->ts.u.cl->length)
5352 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5353 else if (op1->expr_type == EXPR_CONSTANT)
5354 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5355 op1->value.character.length);
5357 if (op2->ts.u.cl && op2->ts.u.cl->length)
5358 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5359 else if (op2->expr_type == EXPR_CONSTANT)
5360 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5361 op2->value.character.length);
5363 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5368 e->ts.u.cl->length = gfc_add (e1, e2);
5369 e->ts.u.cl->length->ts.type = BT_INTEGER;
5370 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5371 gfc_simplify_expr (e->ts.u.cl->length, 0);
5372 gfc_resolve_expr (e->ts.u.cl->length);
5378 /* Ensure that an character expression has a charlen and, if possible, a
5379 length expression. */
5382 fixup_charlen (gfc_expr *e)
5384 /* The cases fall through so that changes in expression type and the need
5385 for multiple fixes are picked up. In all circumstances, a charlen should
5386 be available for the middle end to hang a backend_decl on. */
5387 switch (e->expr_type)
5390 gfc_resolve_character_operator (e);
5393 if (e->expr_type == EXPR_ARRAY)
5394 gfc_resolve_character_array_constructor (e);
5396 case EXPR_SUBSTRING:
5397 if (!e->ts.u.cl && e->ref)
5398 gfc_resolve_substring_charlen (e);
5402 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5409 /* Update an actual argument to include the passed-object for type-bound
5410 procedures at the right position. */
5412 static gfc_actual_arglist*
5413 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5416 gcc_assert (argpos > 0);
5420 gfc_actual_arglist* result;
5422 result = gfc_get_actual_arglist ();
5426 result->name = name;
5432 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5434 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5439 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5442 extract_compcall_passed_object (gfc_expr* e)
5446 gcc_assert (e->expr_type == EXPR_COMPCALL);
5448 if (e->value.compcall.base_object)
5449 po = gfc_copy_expr (e->value.compcall.base_object);
5452 po = gfc_get_expr ();
5453 po->expr_type = EXPR_VARIABLE;
5454 po->symtree = e->symtree;
5455 po->ref = gfc_copy_ref (e->ref);
5456 po->where = e->where;
5459 if (gfc_resolve_expr (po) == FAILURE)
5466 /* Update the arglist of an EXPR_COMPCALL expression to include the
5470 update_compcall_arglist (gfc_expr* e)
5473 gfc_typebound_proc* tbp;
5475 tbp = e->value.compcall.tbp;
5480 po = extract_compcall_passed_object (e);
5484 if (tbp->nopass || e->value.compcall.ignore_pass)
5490 gcc_assert (tbp->pass_arg_num > 0);
5491 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5499 /* Extract the passed object from a PPC call (a copy of it). */
5502 extract_ppc_passed_object (gfc_expr *e)
5507 po = gfc_get_expr ();
5508 po->expr_type = EXPR_VARIABLE;
5509 po->symtree = e->symtree;
5510 po->ref = gfc_copy_ref (e->ref);
5511 po->where = e->where;
5513 /* Remove PPC reference. */
5515 while ((*ref)->next)
5516 ref = &(*ref)->next;
5517 gfc_free_ref_list (*ref);
5520 if (gfc_resolve_expr (po) == FAILURE)
5527 /* Update the actual arglist of a procedure pointer component to include the
5531 update_ppc_arglist (gfc_expr* e)
5535 gfc_typebound_proc* tb;
5537 if (!gfc_is_proc_ptr_comp (e, &ppc))
5544 else if (tb->nopass)
5547 po = extract_ppc_passed_object (e);
5554 gfc_error ("Passed-object at %L must be scalar", &e->where);
5559 if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
5561 gfc_error ("Base object for procedure-pointer component call at %L is of"
5562 " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name);
5566 gcc_assert (tb->pass_arg_num > 0);
5567 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5575 /* Check that the object a TBP is called on is valid, i.e. it must not be
5576 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5579 check_typebound_baseobject (gfc_expr* e)
5582 gfc_try return_value = FAILURE;
5584 base = extract_compcall_passed_object (e);
5588 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5591 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5593 gfc_error ("Base object for type-bound procedure call at %L is of"
5594 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5598 /* F08:C1230. If the procedure called is NOPASS,
5599 the base object must be scalar. */
5600 if (e->value.compcall.tbp->nopass && base->rank > 0)
5602 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5603 " be scalar", &e->where);
5607 return_value = SUCCESS;
5610 gfc_free_expr (base);
5611 return return_value;
5615 /* Resolve a call to a type-bound procedure, either function or subroutine,
5616 statically from the data in an EXPR_COMPCALL expression. The adapted
5617 arglist and the target-procedure symtree are returned. */
5620 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5621 gfc_actual_arglist** actual)
5623 gcc_assert (e->expr_type == EXPR_COMPCALL);
5624 gcc_assert (!e->value.compcall.tbp->is_generic);
5626 /* Update the actual arglist for PASS. */
5627 if (update_compcall_arglist (e) == FAILURE)
5630 *actual = e->value.compcall.actual;
5631 *target = e->value.compcall.tbp->u.specific;
5633 gfc_free_ref_list (e->ref);
5635 e->value.compcall.actual = NULL;
5637 /* If we find a deferred typebound procedure, check for derived types
5638 that an over-riding typebound procedure has not been missed. */
5639 if (e->value.compcall.tbp->deferred
5640 && e->value.compcall.name
5641 && !e->value.compcall.tbp->non_overridable
5642 && e->value.compcall.base_object
5643 && e->value.compcall.base_object->ts.type == BT_DERIVED)
5646 gfc_symbol *derived;
5648 /* Use the derived type of the base_object. */
5649 derived = e->value.compcall.base_object->ts.u.derived;
5652 /* If necessary, go throught the inheritance chain. */
5653 while (!st && derived)
5655 /* Look for the typebound procedure 'name'. */
5656 if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
5657 st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
5658 e->value.compcall.name);
5660 derived = gfc_get_derived_super_type (derived);
5663 /* Now find the specific name in the derived type namespace. */
5664 if (st && st->n.tb && st->n.tb->u.specific)
5665 gfc_find_sym_tree (st->n.tb->u.specific->name,
5666 derived->ns, 1, &st);
5674 /* Get the ultimate declared type from an expression. In addition,
5675 return the last class/derived type reference and the copy of the
5676 reference list. If check_types is set true, derived types are
5677 identified as well as class references. */
5679 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5680 gfc_expr *e, bool check_types)
5682 gfc_symbol *declared;
5689 *new_ref = gfc_copy_ref (e->ref);
5691 for (ref = e->ref; ref; ref = ref->next)
5693 if (ref->type != REF_COMPONENT)
5696 if ((ref->u.c.component->ts.type == BT_CLASS
5697 || (check_types && ref->u.c.component->ts.type == BT_DERIVED))
5698 && ref->u.c.component->attr.flavor != FL_PROCEDURE)
5700 declared = ref->u.c.component->ts.u.derived;
5706 if (declared == NULL)
5707 declared = e->symtree->n.sym->ts.u.derived;
5713 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5714 which of the specific bindings (if any) matches the arglist and transform
5715 the expression into a call of that binding. */
5718 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5720 gfc_typebound_proc* genproc;
5721 const char* genname;
5723 gfc_symbol *derived;
5725 gcc_assert (e->expr_type == EXPR_COMPCALL);
5726 genname = e->value.compcall.name;
5727 genproc = e->value.compcall.tbp;
5729 if (!genproc->is_generic)
5732 /* Try the bindings on this type and in the inheritance hierarchy. */
5733 for (; genproc; genproc = genproc->overridden)
5737 gcc_assert (genproc->is_generic);
5738 for (g = genproc->u.generic; g; g = g->next)
5741 gfc_actual_arglist* args;
5744 gcc_assert (g->specific);
5746 if (g->specific->error)
5749 target = g->specific->u.specific->n.sym;
5751 /* Get the right arglist by handling PASS/NOPASS. */
5752 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5753 if (!g->specific->nopass)
5756 po = extract_compcall_passed_object (e);
5760 gcc_assert (g->specific->pass_arg_num > 0);
5761 gcc_assert (!g->specific->error);
5762 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5763 g->specific->pass_arg);
5765 resolve_actual_arglist (args, target->attr.proc,
5766 is_external_proc (target) && !target->formal);
5768 /* Check if this arglist matches the formal. */
5769 matches = gfc_arglist_matches_symbol (&args, target);
5771 /* Clean up and break out of the loop if we've found it. */
5772 gfc_free_actual_arglist (args);
5775 e->value.compcall.tbp = g->specific;
5776 genname = g->specific_st->name;
5777 /* Pass along the name for CLASS methods, where the vtab
5778 procedure pointer component has to be referenced. */
5786 /* Nothing matching found! */
5787 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5788 " '%s' at %L", genname, &e->where);
5792 /* Make sure that we have the right specific instance for the name. */
5793 derived = get_declared_from_expr (NULL, NULL, e, true);
5795 st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
5797 e->value.compcall.tbp = st->n.tb;
5803 /* Resolve a call to a type-bound subroutine. */
5806 resolve_typebound_call (gfc_code* c, const char **name)
5808 gfc_actual_arglist* newactual;
5809 gfc_symtree* target;
5811 /* Check that's really a SUBROUTINE. */
5812 if (!c->expr1->value.compcall.tbp->subroutine)
5814 gfc_error ("'%s' at %L should be a SUBROUTINE",
5815 c->expr1->value.compcall.name, &c->loc);
5819 if (check_typebound_baseobject (c->expr1) == FAILURE)
5822 /* Pass along the name for CLASS methods, where the vtab
5823 procedure pointer component has to be referenced. */
5825 *name = c->expr1->value.compcall.name;
5827 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5830 /* Transform into an ordinary EXEC_CALL for now. */
5832 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5835 c->ext.actual = newactual;
5836 c->symtree = target;
5837 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5839 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5841 gfc_free_expr (c->expr1);
5842 c->expr1 = gfc_get_expr ();
5843 c->expr1->expr_type = EXPR_FUNCTION;
5844 c->expr1->symtree = target;
5845 c->expr1->where = c->loc;
5847 return resolve_call (c);
5851 /* Resolve a component-call expression. */
5853 resolve_compcall (gfc_expr* e, const char **name)
5855 gfc_actual_arglist* newactual;
5856 gfc_symtree* target;
5858 /* Check that's really a FUNCTION. */
5859 if (!e->value.compcall.tbp->function)
5861 gfc_error ("'%s' at %L should be a FUNCTION",
5862 e->value.compcall.name, &e->where);
5866 /* These must not be assign-calls! */
5867 gcc_assert (!e->value.compcall.assign);
5869 if (check_typebound_baseobject (e) == FAILURE)
5872 /* Pass along the name for CLASS methods, where the vtab
5873 procedure pointer component has to be referenced. */
5875 *name = e->value.compcall.name;
5877 if (resolve_typebound_generic_call (e, name) == FAILURE)
5879 gcc_assert (!e->value.compcall.tbp->is_generic);
5881 /* Take the rank from the function's symbol. */
5882 if (e->value.compcall.tbp->u.specific->n.sym->as)
5883 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5885 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5886 arglist to the TBP's binding target. */
5888 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5891 e->value.function.actual = newactual;
5892 e->value.function.name = NULL;
5893 e->value.function.esym = target->n.sym;
5894 e->value.function.isym = NULL;
5895 e->symtree = target;
5896 e->ts = target->n.sym->ts;
5897 e->expr_type = EXPR_FUNCTION;
5899 /* Resolution is not necessary if this is a class subroutine; this
5900 function only has to identify the specific proc. Resolution of
5901 the call will be done next in resolve_typebound_call. */
5902 return gfc_resolve_expr (e);
5907 /* Resolve a typebound function, or 'method'. First separate all
5908 the non-CLASS references by calling resolve_compcall directly. */
5911 resolve_typebound_function (gfc_expr* e)
5913 gfc_symbol *declared;
5925 /* Deal with typebound operators for CLASS objects. */
5926 expr = e->value.compcall.base_object;
5927 overridable = !e->value.compcall.tbp->non_overridable;
5928 if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
5930 /* If the base_object is not a variable, the corresponding actual
5931 argument expression must be stored in e->base_expression so
5932 that the corresponding tree temporary can be used as the base
5933 object in gfc_conv_procedure_call. */
5934 if (expr->expr_type != EXPR_VARIABLE)
5936 gfc_actual_arglist *args;
5938 for (args= e->value.function.actual; args; args = args->next)
5940 if (expr == args->expr)
5945 /* Since the typebound operators are generic, we have to ensure
5946 that any delays in resolution are corrected and that the vtab
5949 declared = ts.u.derived;
5950 c = gfc_find_component (declared, "_vptr", true, true);
5951 if (c->ts.u.derived == NULL)
5952 c->ts.u.derived = gfc_find_derived_vtab (declared);
5954 if (resolve_compcall (e, &name) == FAILURE)
5957 /* Use the generic name if it is there. */
5958 name = name ? name : e->value.function.esym->name;
5959 e->symtree = expr->symtree;
5960 e->ref = gfc_copy_ref (expr->ref);
5961 get_declared_from_expr (&class_ref, NULL, e, false);
5963 /* Trim away the extraneous references that emerge from nested
5964 use of interface.c (extend_expr). */
5965 if (class_ref && class_ref->next)
5967 gfc_free_ref_list (class_ref->next);
5968 class_ref->next = NULL;
5970 else if (e->ref && !class_ref)
5972 gfc_free_ref_list (e->ref);
5976 gfc_add_vptr_component (e);
5977 gfc_add_component_ref (e, name);
5978 e->value.function.esym = NULL;
5979 if (expr->expr_type != EXPR_VARIABLE)
5980 e->base_expr = expr;
5985 return resolve_compcall (e, NULL);
5987 if (resolve_ref (e) == FAILURE)
5990 /* Get the CLASS declared type. */
5991 declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
5993 /* Weed out cases of the ultimate component being a derived type. */
5994 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5995 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5997 gfc_free_ref_list (new_ref);
5998 return resolve_compcall (e, NULL);
6001 c = gfc_find_component (declared, "_data", true, true);
6002 declared = c->ts.u.derived;
6004 /* Treat the call as if it is a typebound procedure, in order to roll
6005 out the correct name for the specific function. */
6006 if (resolve_compcall (e, &name) == FAILURE)
6012 /* Convert the expression to a procedure pointer component call. */
6013 e->value.function.esym = NULL;
6019 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6020 gfc_add_vptr_component (e);
6021 gfc_add_component_ref (e, name);
6023 /* Recover the typespec for the expression. This is really only
6024 necessary for generic procedures, where the additional call
6025 to gfc_add_component_ref seems to throw the collection of the
6026 correct typespec. */
6033 /* Resolve a typebound subroutine, or 'method'. First separate all
6034 the non-CLASS references by calling resolve_typebound_call
6038 resolve_typebound_subroutine (gfc_code *code)
6040 gfc_symbol *declared;
6050 st = code->expr1->symtree;
6052 /* Deal with typebound operators for CLASS objects. */
6053 expr = code->expr1->value.compcall.base_object;
6054 overridable = !code->expr1->value.compcall.tbp->non_overridable;
6055 if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
6057 /* If the base_object is not a variable, the corresponding actual
6058 argument expression must be stored in e->base_expression so
6059 that the corresponding tree temporary can be used as the base
6060 object in gfc_conv_procedure_call. */
6061 if (expr->expr_type != EXPR_VARIABLE)
6063 gfc_actual_arglist *args;
6065 args= code->expr1->value.function.actual;
6066 for (; args; args = args->next)
6067 if (expr == args->expr)
6071 /* Since the typebound operators are generic, we have to ensure
6072 that any delays in resolution are corrected and that the vtab
6074 declared = expr->ts.u.derived;
6075 c = gfc_find_component (declared, "_vptr", true, true);
6076 if (c->ts.u.derived == NULL)
6077 c->ts.u.derived = gfc_find_derived_vtab (declared);
6079 if (resolve_typebound_call (code, &name) == FAILURE)
6082 /* Use the generic name if it is there. */
6083 name = name ? name : code->expr1->value.function.esym->name;
6084 code->expr1->symtree = expr->symtree;
6085 code->expr1->ref = gfc_copy_ref (expr->ref);
6087 /* Trim away the extraneous references that emerge from nested
6088 use of interface.c (extend_expr). */
6089 get_declared_from_expr (&class_ref, NULL, code->expr1, false);
6090 if (class_ref && class_ref->next)
6092 gfc_free_ref_list (class_ref->next);
6093 class_ref->next = NULL;
6095 else if (code->expr1->ref && !class_ref)
6097 gfc_free_ref_list (code->expr1->ref);
6098 code->expr1->ref = NULL;
6101 /* Now use the procedure in the vtable. */
6102 gfc_add_vptr_component (code->expr1);
6103 gfc_add_component_ref (code->expr1, name);
6104 code->expr1->value.function.esym = NULL;
6105 if (expr->expr_type != EXPR_VARIABLE)
6106 code->expr1->base_expr = expr;
6111 return resolve_typebound_call (code, NULL);
6113 if (resolve_ref (code->expr1) == FAILURE)
6116 /* Get the CLASS declared type. */
6117 get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
6119 /* Weed out cases of the ultimate component being a derived type. */
6120 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
6121 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
6123 gfc_free_ref_list (new_ref);
6124 return resolve_typebound_call (code, NULL);
6127 if (resolve_typebound_call (code, &name) == FAILURE)
6129 ts = code->expr1->ts;
6133 /* Convert the expression to a procedure pointer component call. */
6134 code->expr1->value.function.esym = NULL;
6135 code->expr1->symtree = st;
6138 code->expr1->ref = new_ref;
6140 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6141 gfc_add_vptr_component (code->expr1);
6142 gfc_add_component_ref (code->expr1, name);
6144 /* Recover the typespec for the expression. This is really only
6145 necessary for generic procedures, where the additional call
6146 to gfc_add_component_ref seems to throw the collection of the
6147 correct typespec. */
6148 code->expr1->ts = ts;
6155 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6158 resolve_ppc_call (gfc_code* c)
6160 gfc_component *comp;
6163 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
6166 c->resolved_sym = c->expr1->symtree->n.sym;
6167 c->expr1->expr_type = EXPR_VARIABLE;
6169 if (!comp->attr.subroutine)
6170 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
6172 if (resolve_ref (c->expr1) == FAILURE)
6175 if (update_ppc_arglist (c->expr1) == FAILURE)
6178 c->ext.actual = c->expr1->value.compcall.actual;
6180 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
6181 comp->formal == NULL) == FAILURE)
6184 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
6190 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6193 resolve_expr_ppc (gfc_expr* e)
6195 gfc_component *comp;
6198 b = gfc_is_proc_ptr_comp (e, &comp);
6201 /* Convert to EXPR_FUNCTION. */
6202 e->expr_type = EXPR_FUNCTION;
6203 e->value.function.isym = NULL;
6204 e->value.function.actual = e->value.compcall.actual;
6206 if (comp->as != NULL)
6207 e->rank = comp->as->rank;
6209 if (!comp->attr.function)
6210 gfc_add_function (&comp->attr, comp->name, &e->where);
6212 if (resolve_ref (e) == FAILURE)
6215 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
6216 comp->formal == NULL) == FAILURE)
6219 if (update_ppc_arglist (e) == FAILURE)
6222 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
6229 gfc_is_expandable_expr (gfc_expr *e)
6231 gfc_constructor *con;
6233 if (e->expr_type == EXPR_ARRAY)
6235 /* Traverse the constructor looking for variables that are flavor
6236 parameter. Parameters must be expanded since they are fully used at
6238 con = gfc_constructor_first (e->value.constructor);
6239 for (; con; con = gfc_constructor_next (con))
6241 if (con->expr->expr_type == EXPR_VARIABLE
6242 && con->expr->symtree
6243 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6244 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
6246 if (con->expr->expr_type == EXPR_ARRAY
6247 && gfc_is_expandable_expr (con->expr))
6255 /* Resolve an expression. That is, make sure that types of operands agree
6256 with their operators, intrinsic operators are converted to function calls
6257 for overloaded types and unresolved function references are resolved. */
6260 gfc_resolve_expr (gfc_expr *e)
6268 /* inquiry_argument only applies to variables. */
6269 inquiry_save = inquiry_argument;
6270 if (e->expr_type != EXPR_VARIABLE)
6271 inquiry_argument = false;
6273 switch (e->expr_type)
6276 t = resolve_operator (e);
6282 if (check_host_association (e))
6283 t = resolve_function (e);
6286 t = resolve_variable (e);
6288 expression_rank (e);
6291 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6292 && e->ref->type != REF_SUBSTRING)
6293 gfc_resolve_substring_charlen (e);
6298 t = resolve_typebound_function (e);
6301 case EXPR_SUBSTRING:
6302 t = resolve_ref (e);
6311 t = resolve_expr_ppc (e);
6316 if (resolve_ref (e) == FAILURE)
6319 t = gfc_resolve_array_constructor (e);
6320 /* Also try to expand a constructor. */
6323 expression_rank (e);
6324 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6325 gfc_expand_constructor (e, false);
6328 /* This provides the opportunity for the length of constructors with
6329 character valued function elements to propagate the string length
6330 to the expression. */
6331 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6333 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6334 here rather then add a duplicate test for it above. */
6335 gfc_expand_constructor (e, false);
6336 t = gfc_resolve_character_array_constructor (e);
6341 case EXPR_STRUCTURE:
6342 t = resolve_ref (e);
6346 t = resolve_structure_cons (e, 0);
6350 t = gfc_simplify_expr (e, 0);
6354 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6357 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6360 inquiry_argument = inquiry_save;
6366 /* Resolve an expression from an iterator. They must be scalar and have
6367 INTEGER or (optionally) REAL type. */
6370 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6371 const char *name_msgid)
6373 if (gfc_resolve_expr (expr) == FAILURE)
6376 if (expr->rank != 0)
6378 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6382 if (expr->ts.type != BT_INTEGER)
6384 if (expr->ts.type == BT_REAL)
6387 return gfc_notify_std (GFC_STD_F95_DEL,
6388 "Deleted feature: %s at %L must be integer",
6389 _(name_msgid), &expr->where);
6392 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6399 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6407 /* Resolve the expressions in an iterator structure. If REAL_OK is
6408 false allow only INTEGER type iterators, otherwise allow REAL types. */
6411 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6413 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6417 if (gfc_check_vardef_context (iter->var, false, false, _("iterator variable"))
6421 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6422 "Start expression in DO loop") == FAILURE)
6425 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6426 "End expression in DO loop") == FAILURE)
6429 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6430 "Step expression in DO loop") == FAILURE)
6433 if (iter->step->expr_type == EXPR_CONSTANT)
6435 if ((iter->step->ts.type == BT_INTEGER
6436 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6437 || (iter->step->ts.type == BT_REAL
6438 && mpfr_sgn (iter->step->value.real) == 0))
6440 gfc_error ("Step expression in DO loop at %L cannot be zero",
6441 &iter->step->where);
6446 /* Convert start, end, and step to the same type as var. */
6447 if (iter->start->ts.kind != iter->var->ts.kind
6448 || iter->start->ts.type != iter->var->ts.type)
6449 gfc_convert_type (iter->start, &iter->var->ts, 2);
6451 if (iter->end->ts.kind != iter->var->ts.kind
6452 || iter->end->ts.type != iter->var->ts.type)
6453 gfc_convert_type (iter->end, &iter->var->ts, 2);
6455 if (iter->step->ts.kind != iter->var->ts.kind
6456 || iter->step->ts.type != iter->var->ts.type)
6457 gfc_convert_type (iter->step, &iter->var->ts, 2);
6459 if (iter->start->expr_type == EXPR_CONSTANT
6460 && iter->end->expr_type == EXPR_CONSTANT
6461 && iter->step->expr_type == EXPR_CONSTANT)
6464 if (iter->start->ts.type == BT_INTEGER)
6466 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6467 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6471 sgn = mpfr_sgn (iter->step->value.real);
6472 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6474 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6475 gfc_warning ("DO loop at %L will be executed zero times",
6476 &iter->step->where);
6483 /* Traversal function for find_forall_index. f == 2 signals that
6484 that variable itself is not to be checked - only the references. */
6487 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6489 if (expr->expr_type != EXPR_VARIABLE)
6492 /* A scalar assignment */
6493 if (!expr->ref || *f == 1)
6495 if (expr->symtree->n.sym == sym)
6507 /* Check whether the FORALL index appears in the expression or not.
6508 Returns SUCCESS if SYM is found in EXPR. */
6511 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6513 if (gfc_traverse_expr (expr, sym, forall_index, f))
6520 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6521 to be a scalar INTEGER variable. The subscripts and stride are scalar
6522 INTEGERs, and if stride is a constant it must be nonzero.
6523 Furthermore "A subscript or stride in a forall-triplet-spec shall
6524 not contain a reference to any index-name in the
6525 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6528 resolve_forall_iterators (gfc_forall_iterator *it)
6530 gfc_forall_iterator *iter, *iter2;
6532 for (iter = it; iter; iter = iter->next)
6534 if (gfc_resolve_expr (iter->var) == SUCCESS
6535 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6536 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6539 if (gfc_resolve_expr (iter->start) == SUCCESS
6540 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6541 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6542 &iter->start->where);
6543 if (iter->var->ts.kind != iter->start->ts.kind)
6544 gfc_convert_type (iter->start, &iter->var->ts, 1);
6546 if (gfc_resolve_expr (iter->end) == SUCCESS
6547 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6548 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6550 if (iter->var->ts.kind != iter->end->ts.kind)
6551 gfc_convert_type (iter->end, &iter->var->ts, 1);
6553 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6555 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6556 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6557 &iter->stride->where, "INTEGER");
6559 if (iter->stride->expr_type == EXPR_CONSTANT
6560 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6561 gfc_error ("FORALL stride expression at %L cannot be zero",
6562 &iter->stride->where);
6564 if (iter->var->ts.kind != iter->stride->ts.kind)
6565 gfc_convert_type (iter->stride, &iter->var->ts, 1);
6568 for (iter = it; iter; iter = iter->next)
6569 for (iter2 = iter; iter2; iter2 = iter2->next)
6571 if (find_forall_index (iter2->start,
6572 iter->var->symtree->n.sym, 0) == SUCCESS
6573 || find_forall_index (iter2->end,
6574 iter->var->symtree->n.sym, 0) == SUCCESS
6575 || find_forall_index (iter2->stride,
6576 iter->var->symtree->n.sym, 0) == SUCCESS)
6577 gfc_error ("FORALL index '%s' may not appear in triplet "
6578 "specification at %L", iter->var->symtree->name,
6579 &iter2->start->where);
6584 /* Given a pointer to a symbol that is a derived type, see if it's
6585 inaccessible, i.e. if it's defined in another module and the components are
6586 PRIVATE. The search is recursive if necessary. Returns zero if no
6587 inaccessible components are found, nonzero otherwise. */
6590 derived_inaccessible (gfc_symbol *sym)
6594 if (sym->attr.use_assoc && sym->attr.private_comp)
6597 for (c = sym->components; c; c = c->next)
6599 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6607 /* Resolve the argument of a deallocate expression. The expression must be
6608 a pointer or a full array. */
6611 resolve_deallocate_expr (gfc_expr *e)
6613 symbol_attribute attr;
6614 int allocatable, pointer;
6619 if (gfc_resolve_expr (e) == FAILURE)
6622 if (e->expr_type != EXPR_VARIABLE)
6625 sym = e->symtree->n.sym;
6627 if (sym->ts.type == BT_CLASS)
6629 allocatable = CLASS_DATA (sym)->attr.allocatable;
6630 pointer = CLASS_DATA (sym)->attr.class_pointer;
6634 allocatable = sym->attr.allocatable;
6635 pointer = sym->attr.pointer;
6637 for (ref = e->ref; ref; ref = ref->next)
6642 if (ref->u.ar.type != AR_FULL
6643 && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
6644 && ref->u.ar.codimen && gfc_ref_this_image (ref)))
6649 c = ref->u.c.component;
6650 if (c->ts.type == BT_CLASS)
6652 allocatable = CLASS_DATA (c)->attr.allocatable;
6653 pointer = CLASS_DATA (c)->attr.class_pointer;
6657 allocatable = c->attr.allocatable;
6658 pointer = c->attr.pointer;
6668 attr = gfc_expr_attr (e);
6670 if (allocatable == 0 && attr.pointer == 0)
6673 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6679 if (gfc_is_coindexed (e))
6681 gfc_error ("Coindexed allocatable object at %L", &e->where);
6686 && gfc_check_vardef_context (e, true, true, _("DEALLOCATE object"))
6689 if (gfc_check_vardef_context (e, false, true, _("DEALLOCATE object"))
6697 /* Returns true if the expression e contains a reference to the symbol sym. */
6699 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6701 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6708 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6710 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6714 /* Given the expression node e for an allocatable/pointer of derived type to be
6715 allocated, get the expression node to be initialized afterwards (needed for
6716 derived types with default initializers, and derived types with allocatable
6717 components that need nullification.) */
6720 gfc_expr_to_initialize (gfc_expr *e)
6726 result = gfc_copy_expr (e);
6728 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6729 for (ref = result->ref; ref; ref = ref->next)
6730 if (ref->type == REF_ARRAY && ref->next == NULL)
6732 ref->u.ar.type = AR_FULL;
6734 for (i = 0; i < ref->u.ar.dimen; i++)
6735 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6740 gfc_free_shape (&result->shape, result->rank);
6742 /* Recalculate rank, shape, etc. */
6743 gfc_resolve_expr (result);
6748 /* If the last ref of an expression is an array ref, return a copy of the
6749 expression with that one removed. Otherwise, a copy of the original
6750 expression. This is used for allocate-expressions and pointer assignment
6751 LHS, where there may be an array specification that needs to be stripped
6752 off when using gfc_check_vardef_context. */
6755 remove_last_array_ref (gfc_expr* e)
6760 e2 = gfc_copy_expr (e);
6761 for (r = &e2->ref; *r; r = &(*r)->next)
6762 if ((*r)->type == REF_ARRAY && !(*r)->next)
6764 gfc_free_ref_list (*r);
6773 /* Used in resolve_allocate_expr to check that a allocation-object and
6774 a source-expr are conformable. This does not catch all possible
6775 cases; in particular a runtime checking is needed. */
6778 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6781 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6783 /* First compare rank. */
6784 if (tail && e1->rank != tail->u.ar.as->rank)
6786 gfc_error ("Source-expr at %L must be scalar or have the "
6787 "same rank as the allocate-object at %L",
6788 &e1->where, &e2->where);
6799 for (i = 0; i < e1->rank; i++)
6801 if (tail->u.ar.end[i])
6803 mpz_set (s, tail->u.ar.end[i]->value.integer);
6804 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6805 mpz_add_ui (s, s, 1);
6809 mpz_set (s, tail->u.ar.start[i]->value.integer);
6812 if (mpz_cmp (e1->shape[i], s) != 0)
6814 gfc_error ("Source-expr at %L and allocate-object at %L must "
6815 "have the same shape", &e1->where, &e2->where);
6828 /* Resolve the expression in an ALLOCATE statement, doing the additional
6829 checks to see whether the expression is OK or not. The expression must
6830 have a trailing array reference that gives the size of the array. */
6833 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6835 int i, pointer, allocatable, dimension, is_abstract;
6838 symbol_attribute attr;
6839 gfc_ref *ref, *ref2;
6842 gfc_symbol *sym = NULL;
6847 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6848 checking of coarrays. */
6849 for (ref = e->ref; ref; ref = ref->next)
6850 if (ref->next == NULL)
6853 if (ref && ref->type == REF_ARRAY)
6854 ref->u.ar.in_allocate = true;
6856 if (gfc_resolve_expr (e) == FAILURE)
6859 /* Make sure the expression is allocatable or a pointer. If it is
6860 pointer, the next-to-last reference must be a pointer. */
6864 sym = e->symtree->n.sym;
6866 /* Check whether ultimate component is abstract and CLASS. */
6869 if (e->expr_type != EXPR_VARIABLE)
6872 attr = gfc_expr_attr (e);
6873 pointer = attr.pointer;
6874 dimension = attr.dimension;
6875 codimension = attr.codimension;
6879 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
6881 allocatable = CLASS_DATA (sym)->attr.allocatable;
6882 pointer = CLASS_DATA (sym)->attr.class_pointer;
6883 dimension = CLASS_DATA (sym)->attr.dimension;
6884 codimension = CLASS_DATA (sym)->attr.codimension;
6885 is_abstract = CLASS_DATA (sym)->attr.abstract;
6889 allocatable = sym->attr.allocatable;
6890 pointer = sym->attr.pointer;
6891 dimension = sym->attr.dimension;
6892 codimension = sym->attr.codimension;
6897 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6902 if (ref->u.ar.codimen > 0)
6905 for (n = ref->u.ar.dimen;
6906 n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
6907 if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
6914 if (ref->next != NULL)
6922 gfc_error ("Coindexed allocatable object at %L",
6927 c = ref->u.c.component;
6928 if (c->ts.type == BT_CLASS)
6930 allocatable = CLASS_DATA (c)->attr.allocatable;
6931 pointer = CLASS_DATA (c)->attr.class_pointer;
6932 dimension = CLASS_DATA (c)->attr.dimension;
6933 codimension = CLASS_DATA (c)->attr.codimension;
6934 is_abstract = CLASS_DATA (c)->attr.abstract;
6938 allocatable = c->attr.allocatable;
6939 pointer = c->attr.pointer;
6940 dimension = c->attr.dimension;
6941 codimension = c->attr.codimension;
6942 is_abstract = c->attr.abstract;
6954 if (allocatable == 0 && pointer == 0)
6956 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6961 /* Some checks for the SOURCE tag. */
6964 /* Check F03:C631. */
6965 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6967 gfc_error ("Type of entity at %L is type incompatible with "
6968 "source-expr at %L", &e->where, &code->expr3->where);
6972 /* Check F03:C632 and restriction following Note 6.18. */
6973 if (code->expr3->rank > 0
6974 && conformable_arrays (code->expr3, e) == FAILURE)
6977 /* Check F03:C633. */
6978 if (code->expr3->ts.kind != e->ts.kind)
6980 gfc_error ("The allocate-object at %L and the source-expr at %L "
6981 "shall have the same kind type parameter",
6982 &e->where, &code->expr3->where);
6986 /* Check F2008, C642. */
6987 if (code->expr3->ts.type == BT_DERIVED
6988 && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
6989 || (code->expr3->ts.u.derived->from_intmod
6990 == INTMOD_ISO_FORTRAN_ENV
6991 && code->expr3->ts.u.derived->intmod_sym_id
6992 == ISOFORTRAN_LOCK_TYPE)))
6994 gfc_error ("The source-expr at %L shall neither be of type "
6995 "LOCK_TYPE nor have a LOCK_TYPE component if "
6996 "allocate-object at %L is a coarray",
6997 &code->expr3->where, &e->where);
7002 /* Check F08:C629. */
7003 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
7006 gcc_assert (e->ts.type == BT_CLASS);
7007 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7008 "type-spec or source-expr", sym->name, &e->where);
7012 if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred)
7014 int cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
7015 code->ext.alloc.ts.u.cl->length);
7016 if (cmp == 1 || cmp == -1 || cmp == -3)
7018 gfc_error ("Allocating %s at %L with type-spec requires the same "
7019 "character-length parameter as in the declaration",
7020 sym->name, &e->where);
7025 /* In the variable definition context checks, gfc_expr_attr is used
7026 on the expression. This is fooled by the array specification
7027 present in e, thus we have to eliminate that one temporarily. */
7028 e2 = remove_last_array_ref (e);
7030 if (t == SUCCESS && pointer)
7031 t = gfc_check_vardef_context (e2, true, true, _("ALLOCATE object"));
7033 t = gfc_check_vardef_context (e2, false, true, _("ALLOCATE object"));
7038 if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
7039 && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
7041 /* For class arrays, the initialization with SOURCE is done
7042 using _copy and trans_call. It is convenient to exploit that
7043 when the allocated type is different from the declared type but
7044 no SOURCE exists by setting expr3. */
7045 code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
7047 else if (!code->expr3)
7049 /* Set up default initializer if needed. */
7053 if (code->ext.alloc.ts.type == BT_DERIVED)
7054 ts = code->ext.alloc.ts;
7058 if (ts.type == BT_CLASS)
7059 ts = ts.u.derived->components->ts;
7061 if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
7063 gfc_code *init_st = gfc_get_code ();
7064 init_st->loc = code->loc;
7065 init_st->op = EXEC_INIT_ASSIGN;
7066 init_st->expr1 = gfc_expr_to_initialize (e);
7067 init_st->expr2 = init_e;
7068 init_st->next = code->next;
7069 code->next = init_st;
7072 else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
7074 /* Default initialization via MOLD (non-polymorphic). */
7075 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
7076 gfc_resolve_expr (rhs);
7077 gfc_free_expr (code->expr3);
7081 if (e->ts.type == BT_CLASS)
7083 /* Make sure the vtab symbol is present when
7084 the module variables are generated. */
7085 gfc_typespec ts = e->ts;
7087 ts = code->expr3->ts;
7088 else if (code->ext.alloc.ts.type == BT_DERIVED)
7089 ts = code->ext.alloc.ts;
7090 gfc_find_derived_vtab (ts.u.derived);
7092 e = gfc_expr_to_initialize (e);
7095 if (dimension == 0 && codimension == 0)
7098 /* Make sure the last reference node is an array specifiction. */
7100 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
7101 || (dimension && ref2->u.ar.dimen == 0))
7103 gfc_error ("Array specification required in ALLOCATE statement "
7104 "at %L", &e->where);
7108 /* Make sure that the array section reference makes sense in the
7109 context of an ALLOCATE specification. */
7114 for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
7115 if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
7117 gfc_error ("Coarray specification required in ALLOCATE statement "
7118 "at %L", &e->where);
7122 for (i = 0; i < ar->dimen; i++)
7124 if (ref2->u.ar.type == AR_ELEMENT)
7127 switch (ar->dimen_type[i])
7133 if (ar->start[i] != NULL
7134 && ar->end[i] != NULL
7135 && ar->stride[i] == NULL)
7138 /* Fall Through... */
7143 case DIMEN_THIS_IMAGE:
7144 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7150 for (a = code->ext.alloc.list; a; a = a->next)
7152 sym = a->expr->symtree->n.sym;
7154 /* TODO - check derived type components. */
7155 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
7158 if ((ar->start[i] != NULL
7159 && gfc_find_sym_in_expr (sym, ar->start[i]))
7160 || (ar->end[i] != NULL
7161 && gfc_find_sym_in_expr (sym, ar->end[i])))
7163 gfc_error ("'%s' must not appear in the array specification at "
7164 "%L in the same ALLOCATE statement where it is "
7165 "itself allocated", sym->name, &ar->where);
7171 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
7173 if (ar->dimen_type[i] == DIMEN_ELEMENT
7174 || ar->dimen_type[i] == DIMEN_RANGE)
7176 if (i == (ar->dimen + ar->codimen - 1))
7178 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7179 "statement at %L", &e->where);
7185 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
7186 && ar->stride[i] == NULL)
7189 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7202 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
7204 gfc_expr *stat, *errmsg, *pe, *qe;
7205 gfc_alloc *a, *p, *q;
7208 errmsg = code->expr2;
7210 /* Check the stat variable. */
7213 gfc_check_vardef_context (stat, false, false, _("STAT variable"));
7215 if ((stat->ts.type != BT_INTEGER
7216 && !(stat->ref && (stat->ref->type == REF_ARRAY
7217 || stat->ref->type == REF_COMPONENT)))
7219 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7220 "variable", &stat->where);
7222 for (p = code->ext.alloc.list; p; p = p->next)
7223 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
7225 gfc_ref *ref1, *ref2;
7228 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
7229 ref1 = ref1->next, ref2 = ref2->next)
7231 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7233 if (ref1->u.c.component->name != ref2->u.c.component->name)
7242 gfc_error ("Stat-variable at %L shall not be %sd within "
7243 "the same %s statement", &stat->where, fcn, fcn);
7249 /* Check the errmsg variable. */
7253 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7256 gfc_check_vardef_context (errmsg, false, false, _("ERRMSG variable"));
7258 if ((errmsg->ts.type != BT_CHARACTER
7260 && (errmsg->ref->type == REF_ARRAY
7261 || errmsg->ref->type == REF_COMPONENT)))
7262 || errmsg->rank > 0 )
7263 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7264 "variable", &errmsg->where);
7266 for (p = code->ext.alloc.list; p; p = p->next)
7267 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
7269 gfc_ref *ref1, *ref2;
7272 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
7273 ref1 = ref1->next, ref2 = ref2->next)
7275 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7277 if (ref1->u.c.component->name != ref2->u.c.component->name)
7286 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7287 "the same %s statement", &errmsg->where, fcn, fcn);
7293 /* Check that an allocate-object appears only once in the statement.
7294 FIXME: Checking derived types is disabled. */
7295 for (p = code->ext.alloc.list; p; p = p->next)
7298 for (q = p->next; q; q = q->next)
7301 if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
7303 /* This is a potential collision. */
7304 gfc_ref *pr = pe->ref;
7305 gfc_ref *qr = qe->ref;
7307 /* Follow the references until
7308 a) They start to differ, in which case there is no error;
7309 you can deallocate a%b and a%c in a single statement
7310 b) Both of them stop, which is an error
7311 c) One of them stops, which is also an error. */
7314 if (pr == NULL && qr == NULL)
7316 gfc_error ("Allocate-object at %L also appears at %L",
7317 &pe->where, &qe->where);
7320 else if (pr != NULL && qr == NULL)
7322 gfc_error ("Allocate-object at %L is subobject of"
7323 " object at %L", &pe->where, &qe->where);
7326 else if (pr == NULL && qr != NULL)
7328 gfc_error ("Allocate-object at %L is subobject of"
7329 " object at %L", &qe->where, &pe->where);
7332 /* Here, pr != NULL && qr != NULL */
7333 gcc_assert(pr->type == qr->type);
7334 if (pr->type == REF_ARRAY)
7336 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7338 gcc_assert (qr->type == REF_ARRAY);
7340 if (pr->next && qr->next)
7342 gfc_array_ref *par = &(pr->u.ar);
7343 gfc_array_ref *qar = &(qr->u.ar);
7344 if (gfc_dep_compare_expr (par->start[0],
7345 qar->start[0]) != 0)
7351 if (pr->u.c.component->name != qr->u.c.component->name)
7362 if (strcmp (fcn, "ALLOCATE") == 0)
7364 for (a = code->ext.alloc.list; a; a = a->next)
7365 resolve_allocate_expr (a->expr, code);
7369 for (a = code->ext.alloc.list; a; a = a->next)
7370 resolve_deallocate_expr (a->expr);
7375 /************ SELECT CASE resolution subroutines ************/
7377 /* Callback function for our mergesort variant. Determines interval
7378 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7379 op1 > op2. Assumes we're not dealing with the default case.
7380 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7381 There are nine situations to check. */
7384 compare_cases (const gfc_case *op1, const gfc_case *op2)
7388 if (op1->low == NULL) /* op1 = (:L) */
7390 /* op2 = (:N), so overlap. */
7392 /* op2 = (M:) or (M:N), L < M */
7393 if (op2->low != NULL
7394 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7397 else if (op1->high == NULL) /* op1 = (K:) */
7399 /* op2 = (M:), so overlap. */
7401 /* op2 = (:N) or (M:N), K > N */
7402 if (op2->high != NULL
7403 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7406 else /* op1 = (K:L) */
7408 if (op2->low == NULL) /* op2 = (:N), K > N */
7409 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7411 else if (op2->high == NULL) /* op2 = (M:), L < M */
7412 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7414 else /* op2 = (M:N) */
7418 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7421 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7430 /* Merge-sort a double linked case list, detecting overlap in the
7431 process. LIST is the head of the double linked case list before it
7432 is sorted. Returns the head of the sorted list if we don't see any
7433 overlap, or NULL otherwise. */
7436 check_case_overlap (gfc_case *list)
7438 gfc_case *p, *q, *e, *tail;
7439 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7441 /* If the passed list was empty, return immediately. */
7448 /* Loop unconditionally. The only exit from this loop is a return
7449 statement, when we've finished sorting the case list. */
7456 /* Count the number of merges we do in this pass. */
7459 /* Loop while there exists a merge to be done. */
7464 /* Count this merge. */
7467 /* Cut the list in two pieces by stepping INSIZE places
7468 forward in the list, starting from P. */
7471 for (i = 0; i < insize; i++)
7480 /* Now we have two lists. Merge them! */
7481 while (psize > 0 || (qsize > 0 && q != NULL))
7483 /* See from which the next case to merge comes from. */
7486 /* P is empty so the next case must come from Q. */
7491 else if (qsize == 0 || q == NULL)
7500 cmp = compare_cases (p, q);
7503 /* The whole case range for P is less than the
7511 /* The whole case range for Q is greater than
7512 the case range for P. */
7519 /* The cases overlap, or they are the same
7520 element in the list. Either way, we must
7521 issue an error and get the next case from P. */
7522 /* FIXME: Sort P and Q by line number. */
7523 gfc_error ("CASE label at %L overlaps with CASE "
7524 "label at %L", &p->where, &q->where);
7532 /* Add the next element to the merged list. */
7541 /* P has now stepped INSIZE places along, and so has Q. So
7542 they're the same. */
7547 /* If we have done only one merge or none at all, we've
7548 finished sorting the cases. */
7557 /* Otherwise repeat, merging lists twice the size. */
7563 /* Check to see if an expression is suitable for use in a CASE statement.
7564 Makes sure that all case expressions are scalar constants of the same
7565 type. Return FAILURE if anything is wrong. */
7568 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7570 if (e == NULL) return SUCCESS;
7572 if (e->ts.type != case_expr->ts.type)
7574 gfc_error ("Expression in CASE statement at %L must be of type %s",
7575 &e->where, gfc_basic_typename (case_expr->ts.type));
7579 /* C805 (R808) For a given case-construct, each case-value shall be of
7580 the same type as case-expr. For character type, length differences
7581 are allowed, but the kind type parameters shall be the same. */
7583 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7585 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7586 &e->where, case_expr->ts.kind);
7590 /* Convert the case value kind to that of case expression kind,
7593 if (e->ts.kind != case_expr->ts.kind)
7594 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7598 gfc_error ("Expression in CASE statement at %L must be scalar",
7607 /* Given a completely parsed select statement, we:
7609 - Validate all expressions and code within the SELECT.
7610 - Make sure that the selection expression is not of the wrong type.
7611 - Make sure that no case ranges overlap.
7612 - Eliminate unreachable cases and unreachable code resulting from
7613 removing case labels.
7615 The standard does allow unreachable cases, e.g. CASE (5:3). But
7616 they are a hassle for code generation, and to prevent that, we just
7617 cut them out here. This is not necessary for overlapping cases
7618 because they are illegal and we never even try to generate code.
7620 We have the additional caveat that a SELECT construct could have
7621 been a computed GOTO in the source code. Fortunately we can fairly
7622 easily work around that here: The case_expr for a "real" SELECT CASE
7623 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7624 we have to do is make sure that the case_expr is a scalar integer
7628 resolve_select (gfc_code *code)
7631 gfc_expr *case_expr;
7632 gfc_case *cp, *default_case, *tail, *head;
7633 int seen_unreachable;
7639 if (code->expr1 == NULL)
7641 /* This was actually a computed GOTO statement. */
7642 case_expr = code->expr2;
7643 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7644 gfc_error ("Selection expression in computed GOTO statement "
7645 "at %L must be a scalar integer expression",
7648 /* Further checking is not necessary because this SELECT was built
7649 by the compiler, so it should always be OK. Just move the
7650 case_expr from expr2 to expr so that we can handle computed
7651 GOTOs as normal SELECTs from here on. */
7652 code->expr1 = code->expr2;
7657 case_expr = code->expr1;
7659 type = case_expr->ts.type;
7660 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7662 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7663 &case_expr->where, gfc_typename (&case_expr->ts));
7665 /* Punt. Going on here just produce more garbage error messages. */
7669 /* Raise a warning if an INTEGER case value exceeds the range of
7670 the case-expr. Later, all expressions will be promoted to the
7671 largest kind of all case-labels. */
7673 if (type == BT_INTEGER)
7674 for (body = code->block; body; body = body->block)
7675 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7678 && gfc_check_integer_range (cp->low->value.integer,
7679 case_expr->ts.kind) != ARITH_OK)
7680 gfc_warning ("Expression in CASE statement at %L is "
7681 "not in the range of %s", &cp->low->where,
7682 gfc_typename (&case_expr->ts));
7685 && cp->low != cp->high
7686 && gfc_check_integer_range (cp->high->value.integer,
7687 case_expr->ts.kind) != ARITH_OK)
7688 gfc_warning ("Expression in CASE statement at %L is "
7689 "not in the range of %s", &cp->high->where,
7690 gfc_typename (&case_expr->ts));
7693 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7694 of the SELECT CASE expression and its CASE values. Walk the lists
7695 of case values, and if we find a mismatch, promote case_expr to
7696 the appropriate kind. */
7698 if (type == BT_LOGICAL || type == BT_INTEGER)
7700 for (body = code->block; body; body = body->block)
7702 /* Walk the case label list. */
7703 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7705 /* Intercept the DEFAULT case. It does not have a kind. */
7706 if (cp->low == NULL && cp->high == NULL)
7709 /* Unreachable case ranges are discarded, so ignore. */
7710 if (cp->low != NULL && cp->high != NULL
7711 && cp->low != cp->high
7712 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7716 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7717 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7719 if (cp->high != NULL
7720 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7721 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7726 /* Assume there is no DEFAULT case. */
7727 default_case = NULL;
7732 for (body = code->block; body; body = body->block)
7734 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7736 seen_unreachable = 0;
7738 /* Walk the case label list, making sure that all case labels
7740 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7742 /* Count the number of cases in the whole construct. */
7745 /* Intercept the DEFAULT case. */
7746 if (cp->low == NULL && cp->high == NULL)
7748 if (default_case != NULL)
7750 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7751 "by a second DEFAULT CASE at %L",
7752 &default_case->where, &cp->where);
7763 /* Deal with single value cases and case ranges. Errors are
7764 issued from the validation function. */
7765 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7766 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7772 if (type == BT_LOGICAL
7773 && ((cp->low == NULL || cp->high == NULL)
7774 || cp->low != cp->high))
7776 gfc_error ("Logical range in CASE statement at %L is not "
7777 "allowed", &cp->low->where);
7782 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7785 value = cp->low->value.logical == 0 ? 2 : 1;
7786 if (value & seen_logical)
7788 gfc_error ("Constant logical value in CASE statement "
7789 "is repeated at %L",
7794 seen_logical |= value;
7797 if (cp->low != NULL && cp->high != NULL
7798 && cp->low != cp->high
7799 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7801 if (gfc_option.warn_surprising)
7802 gfc_warning ("Range specification at %L can never "
7803 "be matched", &cp->where);
7805 cp->unreachable = 1;
7806 seen_unreachable = 1;
7810 /* If the case range can be matched, it can also overlap with
7811 other cases. To make sure it does not, we put it in a
7812 double linked list here. We sort that with a merge sort
7813 later on to detect any overlapping cases. */
7817 head->right = head->left = NULL;
7822 tail->right->left = tail;
7829 /* It there was a failure in the previous case label, give up
7830 for this case label list. Continue with the next block. */
7834 /* See if any case labels that are unreachable have been seen.
7835 If so, we eliminate them. This is a bit of a kludge because
7836 the case lists for a single case statement (label) is a
7837 single forward linked lists. */
7838 if (seen_unreachable)
7840 /* Advance until the first case in the list is reachable. */
7841 while (body->ext.block.case_list != NULL
7842 && body->ext.block.case_list->unreachable)
7844 gfc_case *n = body->ext.block.case_list;
7845 body->ext.block.case_list = body->ext.block.case_list->next;
7847 gfc_free_case_list (n);
7850 /* Strip all other unreachable cases. */
7851 if (body->ext.block.case_list)
7853 for (cp = body->ext.block.case_list; cp->next; cp = cp->next)
7855 if (cp->next->unreachable)
7857 gfc_case *n = cp->next;
7858 cp->next = cp->next->next;
7860 gfc_free_case_list (n);
7867 /* See if there were overlapping cases. If the check returns NULL,
7868 there was overlap. In that case we don't do anything. If head
7869 is non-NULL, we prepend the DEFAULT case. The sorted list can
7870 then used during code generation for SELECT CASE constructs with
7871 a case expression of a CHARACTER type. */
7874 head = check_case_overlap (head);
7876 /* Prepend the default_case if it is there. */
7877 if (head != NULL && default_case)
7879 default_case->left = NULL;
7880 default_case->right = head;
7881 head->left = default_case;
7885 /* Eliminate dead blocks that may be the result if we've seen
7886 unreachable case labels for a block. */
7887 for (body = code; body && body->block; body = body->block)
7889 if (body->block->ext.block.case_list == NULL)
7891 /* Cut the unreachable block from the code chain. */
7892 gfc_code *c = body->block;
7893 body->block = c->block;
7895 /* Kill the dead block, but not the blocks below it. */
7897 gfc_free_statements (c);
7901 /* More than two cases is legal but insane for logical selects.
7902 Issue a warning for it. */
7903 if (gfc_option.warn_surprising && type == BT_LOGICAL
7905 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7910 /* Check if a derived type is extensible. */
7913 gfc_type_is_extensible (gfc_symbol *sym)
7915 return !(sym->attr.is_bind_c || sym->attr.sequence);
7919 /* Resolve an associate name: Resolve target and ensure the type-spec is
7920 correct as well as possibly the array-spec. */
7923 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
7927 gcc_assert (sym->assoc);
7928 gcc_assert (sym->attr.flavor == FL_VARIABLE);
7930 /* If this is for SELECT TYPE, the target may not yet be set. In that
7931 case, return. Resolution will be called later manually again when
7933 target = sym->assoc->target;
7936 gcc_assert (!sym->assoc->dangling);
7938 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
7941 /* For variable targets, we get some attributes from the target. */
7942 if (target->expr_type == EXPR_VARIABLE)
7946 gcc_assert (target->symtree);
7947 tsym = target->symtree->n.sym;
7949 sym->attr.asynchronous = tsym->attr.asynchronous;
7950 sym->attr.volatile_ = tsym->attr.volatile_;
7952 sym->attr.target = tsym->attr.target
7953 || gfc_expr_attr (target).pointer;
7956 /* Get type if this was not already set. Note that it can be
7957 some other type than the target in case this is a SELECT TYPE
7958 selector! So we must not update when the type is already there. */
7959 if (sym->ts.type == BT_UNKNOWN)
7960 sym->ts = target->ts;
7961 gcc_assert (sym->ts.type != BT_UNKNOWN);
7963 /* See if this is a valid association-to-variable. */
7964 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
7965 && !gfc_has_vector_subscript (target));
7967 /* Finally resolve if this is an array or not. */
7968 if (sym->attr.dimension && target->rank == 0)
7970 gfc_error ("Associate-name '%s' at %L is used as array",
7971 sym->name, &sym->declared_at);
7972 sym->attr.dimension = 0;
7975 if (target->rank > 0)
7976 sym->attr.dimension = 1;
7978 if (sym->attr.dimension)
7980 sym->as = gfc_get_array_spec ();
7981 sym->as->rank = target->rank;
7982 sym->as->type = AS_DEFERRED;
7984 /* Target must not be coindexed, thus the associate-variable
7986 sym->as->corank = 0;
7991 /* Resolve a SELECT TYPE statement. */
7994 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
7996 gfc_symbol *selector_type;
7997 gfc_code *body, *new_st, *if_st, *tail;
7998 gfc_code *class_is = NULL, *default_case = NULL;
8001 char name[GFC_MAX_SYMBOL_LEN];
8005 ns = code->ext.block.ns;
8008 /* Check for F03:C813. */
8009 if (code->expr1->ts.type != BT_CLASS
8010 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
8012 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8013 "at %L", &code->loc);
8017 if (!code->expr1->symtree->n.sym->attr.class_ok)
8022 if (code->expr1->symtree->n.sym->attr.untyped)
8023 code->expr1->symtree->n.sym->ts = code->expr2->ts;
8024 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
8027 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
8029 /* Loop over TYPE IS / CLASS IS cases. */
8030 for (body = code->block; body; body = body->block)
8032 c = body->ext.block.case_list;
8034 /* Check F03:C815. */
8035 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8036 && !gfc_type_is_extensible (c->ts.u.derived))
8038 gfc_error ("Derived type '%s' at %L must be extensible",
8039 c->ts.u.derived->name, &c->where);
8044 /* Check F03:C816. */
8045 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8046 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
8048 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
8049 c->ts.u.derived->name, &c->where, selector_type->name);
8054 /* Intercept the DEFAULT case. */
8055 if (c->ts.type == BT_UNKNOWN)
8057 /* Check F03:C818. */
8060 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8061 "by a second DEFAULT CASE at %L",
8062 &default_case->ext.block.case_list->where, &c->where);
8067 default_case = body;
8074 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8075 target if present. If there are any EXIT statements referring to the
8076 SELECT TYPE construct, this is no problem because the gfc_code
8077 reference stays the same and EXIT is equally possible from the BLOCK
8078 it is changed to. */
8079 code->op = EXEC_BLOCK;
8082 gfc_association_list* assoc;
8084 assoc = gfc_get_association_list ();
8085 assoc->st = code->expr1->symtree;
8086 assoc->target = gfc_copy_expr (code->expr2);
8087 assoc->target->where = code->expr2->where;
8088 /* assoc->variable will be set by resolve_assoc_var. */
8090 code->ext.block.assoc = assoc;
8091 code->expr1->symtree->n.sym->assoc = assoc;
8093 resolve_assoc_var (code->expr1->symtree->n.sym, false);
8096 code->ext.block.assoc = NULL;
8098 /* Add EXEC_SELECT to switch on type. */
8099 new_st = gfc_get_code ();
8100 new_st->op = code->op;
8101 new_st->expr1 = code->expr1;
8102 new_st->expr2 = code->expr2;
8103 new_st->block = code->block;
8104 code->expr1 = code->expr2 = NULL;
8109 ns->code->next = new_st;
8111 code->op = EXEC_SELECT;
8112 gfc_add_vptr_component (code->expr1);
8113 gfc_add_hash_component (code->expr1);
8115 /* Loop over TYPE IS / CLASS IS cases. */
8116 for (body = code->block; body; body = body->block)
8118 c = body->ext.block.case_list;
8120 if (c->ts.type == BT_DERIVED)
8121 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
8122 c->ts.u.derived->hash_value);
8124 else if (c->ts.type == BT_UNKNOWN)
8127 /* Associate temporary to selector. This should only be done
8128 when this case is actually true, so build a new ASSOCIATE
8129 that does precisely this here (instead of using the
8132 if (c->ts.type == BT_CLASS)
8133 sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
8135 sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
8136 st = gfc_find_symtree (ns->sym_root, name);
8137 gcc_assert (st->n.sym->assoc);
8138 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
8139 st->n.sym->assoc->target->where = code->expr1->where;
8140 if (c->ts.type == BT_DERIVED)
8141 gfc_add_data_component (st->n.sym->assoc->target);
8143 new_st = gfc_get_code ();
8144 new_st->op = EXEC_BLOCK;
8145 new_st->ext.block.ns = gfc_build_block_ns (ns);
8146 new_st->ext.block.ns->code = body->next;
8147 body->next = new_st;
8149 /* Chain in the new list only if it is marked as dangling. Otherwise
8150 there is a CASE label overlap and this is already used. Just ignore,
8151 the error is diagonsed elsewhere. */
8152 if (st->n.sym->assoc->dangling)
8154 new_st->ext.block.assoc = st->n.sym->assoc;
8155 st->n.sym->assoc->dangling = 0;
8158 resolve_assoc_var (st->n.sym, false);
8161 /* Take out CLASS IS cases for separate treatment. */
8163 while (body && body->block)
8165 if (body->block->ext.block.case_list->ts.type == BT_CLASS)
8167 /* Add to class_is list. */
8168 if (class_is == NULL)
8170 class_is = body->block;
8175 for (tail = class_is; tail->block; tail = tail->block) ;
8176 tail->block = body->block;
8179 /* Remove from EXEC_SELECT list. */
8180 body->block = body->block->block;
8193 /* Add a default case to hold the CLASS IS cases. */
8194 for (tail = code; tail->block; tail = tail->block) ;
8195 tail->block = gfc_get_code ();
8197 tail->op = EXEC_SELECT_TYPE;
8198 tail->ext.block.case_list = gfc_get_case ();
8199 tail->ext.block.case_list->ts.type = BT_UNKNOWN;
8201 default_case = tail;
8204 /* More than one CLASS IS block? */
8205 if (class_is->block)
8209 /* Sort CLASS IS blocks by extension level. */
8213 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
8216 /* F03:C817 (check for doubles). */
8217 if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
8218 == c2->ext.block.case_list->ts.u.derived->hash_value)
8220 gfc_error ("Double CLASS IS block in SELECT TYPE "
8222 &c2->ext.block.case_list->where);
8225 if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
8226 < c2->ext.block.case_list->ts.u.derived->attr.extension)
8229 (*c1)->block = c2->block;
8239 /* Generate IF chain. */
8240 if_st = gfc_get_code ();
8241 if_st->op = EXEC_IF;
8243 for (body = class_is; body; body = body->block)
8245 new_st->block = gfc_get_code ();
8246 new_st = new_st->block;
8247 new_st->op = EXEC_IF;
8248 /* Set up IF condition: Call _gfortran_is_extension_of. */
8249 new_st->expr1 = gfc_get_expr ();
8250 new_st->expr1->expr_type = EXPR_FUNCTION;
8251 new_st->expr1->ts.type = BT_LOGICAL;
8252 new_st->expr1->ts.kind = 4;
8253 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
8254 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
8255 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
8256 /* Set up arguments. */
8257 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
8258 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
8259 new_st->expr1->value.function.actual->expr->where = code->loc;
8260 gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
8261 vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
8262 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
8263 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
8264 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
8265 new_st->next = body->next;
8267 if (default_case->next)
8269 new_st->block = gfc_get_code ();
8270 new_st = new_st->block;
8271 new_st->op = EXEC_IF;
8272 new_st->next = default_case->next;
8275 /* Replace CLASS DEFAULT code by the IF chain. */
8276 default_case->next = if_st;
8279 /* Resolve the internal code. This can not be done earlier because
8280 it requires that the sym->assoc of selectors is set already. */
8281 gfc_current_ns = ns;
8282 gfc_resolve_blocks (code->block, gfc_current_ns);
8283 gfc_current_ns = old_ns;
8285 resolve_select (code);
8289 /* Resolve a transfer statement. This is making sure that:
8290 -- a derived type being transferred has only non-pointer components
8291 -- a derived type being transferred doesn't have private components, unless
8292 it's being transferred from the module where the type was defined
8293 -- we're not trying to transfer a whole assumed size array. */
8296 resolve_transfer (gfc_code *code)
8305 while (exp != NULL && exp->expr_type == EXPR_OP
8306 && exp->value.op.op == INTRINSIC_PARENTHESES)
8307 exp = exp->value.op.op1;
8309 if (exp && exp->expr_type == EXPR_NULL && exp->ts.type == BT_UNKNOWN)
8311 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8312 "MOLD=", &exp->where);
8316 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
8317 && exp->expr_type != EXPR_FUNCTION))
8320 /* If we are reading, the variable will be changed. Note that
8321 code->ext.dt may be NULL if the TRANSFER is related to
8322 an INQUIRE statement -- but in this case, we are not reading, either. */
8323 if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
8324 && gfc_check_vardef_context (exp, false, false, _("item in READ"))
8328 sym = exp->symtree->n.sym;
8331 /* Go to actual component transferred. */
8332 for (ref = exp->ref; ref; ref = ref->next)
8333 if (ref->type == REF_COMPONENT)
8334 ts = &ref->u.c.component->ts;
8336 if (ts->type == BT_CLASS)
8338 /* FIXME: Test for defined input/output. */
8339 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8340 "it is processed by a defined input/output procedure",
8345 if (ts->type == BT_DERIVED)
8347 /* Check that transferred derived type doesn't contain POINTER
8349 if (ts->u.derived->attr.pointer_comp)
8351 gfc_error ("Data transfer element at %L cannot have POINTER "
8352 "components unless it is processed by a defined "
8353 "input/output procedure", &code->loc);
8358 if (ts->u.derived->attr.proc_pointer_comp)
8360 gfc_error ("Data transfer element at %L cannot have "
8361 "procedure pointer components", &code->loc);
8365 if (ts->u.derived->attr.alloc_comp)
8367 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8368 "components unless it is processed by a defined "
8369 "input/output procedure", &code->loc);
8373 if (derived_inaccessible (ts->u.derived))
8375 gfc_error ("Data transfer element at %L cannot have "
8376 "PRIVATE components",&code->loc);
8381 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
8382 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
8384 gfc_error ("Data transfer element at %L cannot be a full reference to "
8385 "an assumed-size array", &code->loc);
8391 /*********** Toplevel code resolution subroutines ***********/
8393 /* Find the set of labels that are reachable from this block. We also
8394 record the last statement in each block. */
8397 find_reachable_labels (gfc_code *block)
8404 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
8406 /* Collect labels in this block. We don't keep those corresponding
8407 to END {IF|SELECT}, these are checked in resolve_branch by going
8408 up through the code_stack. */
8409 for (c = block; c; c = c->next)
8411 if (c->here && c->op != EXEC_END_NESTED_BLOCK)
8412 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8415 /* Merge with labels from parent block. */
8418 gcc_assert (cs_base->prev->reachable_labels);
8419 bitmap_ior_into (cs_base->reachable_labels,
8420 cs_base->prev->reachable_labels);
8426 resolve_lock_unlock (gfc_code *code)
8428 if (code->expr1->ts.type != BT_DERIVED
8429 || code->expr1->expr_type != EXPR_VARIABLE
8430 || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
8431 || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
8432 || code->expr1->rank != 0
8433 || (!gfc_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1)))
8434 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8435 &code->expr1->where);
8439 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8440 || code->expr2->expr_type != EXPR_VARIABLE))
8441 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8442 &code->expr2->where);
8445 && gfc_check_vardef_context (code->expr2, false, false,
8446 _("STAT variable")) == FAILURE)
8451 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8452 || code->expr3->expr_type != EXPR_VARIABLE))
8453 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8454 &code->expr3->where);
8457 && gfc_check_vardef_context (code->expr3, false, false,
8458 _("ERRMSG variable")) == FAILURE)
8461 /* Check ACQUIRED_LOCK. */
8463 && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
8464 || code->expr4->expr_type != EXPR_VARIABLE))
8465 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8466 "variable", &code->expr4->where);
8469 && gfc_check_vardef_context (code->expr4, false, false,
8470 _("ACQUIRED_LOCK variable")) == FAILURE)
8476 resolve_sync (gfc_code *code)
8478 /* Check imageset. The * case matches expr1 == NULL. */
8481 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8482 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8483 "INTEGER expression", &code->expr1->where);
8484 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8485 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8486 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8487 &code->expr1->where);
8488 else if (code->expr1->expr_type == EXPR_ARRAY
8489 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8491 gfc_constructor *cons;
8492 cons = gfc_constructor_first (code->expr1->value.constructor);
8493 for (; cons; cons = gfc_constructor_next (cons))
8494 if (cons->expr->expr_type == EXPR_CONSTANT
8495 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8496 gfc_error ("Imageset argument at %L must between 1 and "
8497 "num_images()", &cons->expr->where);
8503 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8504 || code->expr2->expr_type != EXPR_VARIABLE))
8505 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8506 &code->expr2->where);
8510 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8511 || code->expr3->expr_type != EXPR_VARIABLE))
8512 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8513 &code->expr3->where);
8517 /* Given a branch to a label, see if the branch is conforming.
8518 The code node describes where the branch is located. */
8521 resolve_branch (gfc_st_label *label, gfc_code *code)
8528 /* Step one: is this a valid branching target? */
8530 if (label->defined == ST_LABEL_UNKNOWN)
8532 gfc_error ("Label %d referenced at %L is never defined", label->value,
8537 if (label->defined != ST_LABEL_TARGET)
8539 gfc_error ("Statement at %L is not a valid branch target statement "
8540 "for the branch statement at %L", &label->where, &code->loc);
8544 /* Step two: make sure this branch is not a branch to itself ;-) */
8546 if (code->here == label)
8548 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8552 /* Step three: See if the label is in the same block as the
8553 branching statement. The hard work has been done by setting up
8554 the bitmap reachable_labels. */
8556 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8558 /* Check now whether there is a CRITICAL construct; if so, check
8559 whether the label is still visible outside of the CRITICAL block,
8560 which is invalid. */
8561 for (stack = cs_base; stack; stack = stack->prev)
8563 if (stack->current->op == EXEC_CRITICAL
8564 && bitmap_bit_p (stack->reachable_labels, label->value))
8565 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8566 "label at %L", &code->loc, &label->where);
8567 else if (stack->current->op == EXEC_DO_CONCURRENT
8568 && bitmap_bit_p (stack->reachable_labels, label->value))
8569 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8570 "for label at %L", &code->loc, &label->where);
8576 /* Step four: If we haven't found the label in the bitmap, it may
8577 still be the label of the END of the enclosing block, in which
8578 case we find it by going up the code_stack. */
8580 for (stack = cs_base; stack; stack = stack->prev)
8582 if (stack->current->next && stack->current->next->here == label)
8584 if (stack->current->op == EXEC_CRITICAL)
8586 /* Note: A label at END CRITICAL does not leave the CRITICAL
8587 construct as END CRITICAL is still part of it. */
8588 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8589 " at %L", &code->loc, &label->where);
8592 else if (stack->current->op == EXEC_DO_CONCURRENT)
8594 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8595 "label at %L", &code->loc, &label->where);
8602 gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
8606 /* The label is not in an enclosing block, so illegal. This was
8607 allowed in Fortran 66, so we allow it as extension. No
8608 further checks are necessary in this case. */
8609 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
8610 "as the GOTO statement at %L", &label->where,
8616 /* Check whether EXPR1 has the same shape as EXPR2. */
8619 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
8621 mpz_t shape[GFC_MAX_DIMENSIONS];
8622 mpz_t shape2[GFC_MAX_DIMENSIONS];
8623 gfc_try result = FAILURE;
8626 /* Compare the rank. */
8627 if (expr1->rank != expr2->rank)
8630 /* Compare the size of each dimension. */
8631 for (i=0; i<expr1->rank; i++)
8633 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
8636 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
8639 if (mpz_cmp (shape[i], shape2[i]))
8643 /* When either of the two expression is an assumed size array, we
8644 ignore the comparison of dimension sizes. */
8649 gfc_clear_shape (shape, i);
8650 gfc_clear_shape (shape2, i);
8655 /* Check whether a WHERE assignment target or a WHERE mask expression
8656 has the same shape as the outmost WHERE mask expression. */
8659 resolve_where (gfc_code *code, gfc_expr *mask)
8665 cblock = code->block;
8667 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8668 In case of nested WHERE, only the outmost one is stored. */
8669 if (mask == NULL) /* outmost WHERE */
8671 else /* inner WHERE */
8678 /* Check if the mask-expr has a consistent shape with the
8679 outmost WHERE mask-expr. */
8680 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8681 gfc_error ("WHERE mask at %L has inconsistent shape",
8682 &cblock->expr1->where);
8685 /* the assignment statement of a WHERE statement, or the first
8686 statement in where-body-construct of a WHERE construct */
8687 cnext = cblock->next;
8692 /* WHERE assignment statement */
8695 /* Check shape consistent for WHERE assignment target. */
8696 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8697 gfc_error ("WHERE assignment target at %L has "
8698 "inconsistent shape", &cnext->expr1->where);
8702 case EXEC_ASSIGN_CALL:
8703 resolve_call (cnext);
8704 if (!cnext->resolved_sym->attr.elemental)
8705 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8706 &cnext->ext.actual->expr->where);
8709 /* WHERE or WHERE construct is part of a where-body-construct */
8711 resolve_where (cnext, e);
8715 gfc_error ("Unsupported statement inside WHERE at %L",
8718 /* the next statement within the same where-body-construct */
8719 cnext = cnext->next;
8721 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8722 cblock = cblock->block;
8727 /* Resolve assignment in FORALL construct.
8728 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8729 FORALL index variables. */
8732 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8736 for (n = 0; n < nvar; n++)
8738 gfc_symbol *forall_index;
8740 forall_index = var_expr[n]->symtree->n.sym;
8742 /* Check whether the assignment target is one of the FORALL index
8744 if ((code->expr1->expr_type == EXPR_VARIABLE)
8745 && (code->expr1->symtree->n.sym == forall_index))
8746 gfc_error ("Assignment to a FORALL index variable at %L",
8747 &code->expr1->where);
8750 /* If one of the FORALL index variables doesn't appear in the
8751 assignment variable, then there could be a many-to-one
8752 assignment. Emit a warning rather than an error because the
8753 mask could be resolving this problem. */
8754 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8755 gfc_warning ("The FORALL with index '%s' is not used on the "
8756 "left side of the assignment at %L and so might "
8757 "cause multiple assignment to this object",
8758 var_expr[n]->symtree->name, &code->expr1->where);
8764 /* Resolve WHERE statement in FORALL construct. */
8767 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8768 gfc_expr **var_expr)
8773 cblock = code->block;
8776 /* the assignment statement of a WHERE statement, or the first
8777 statement in where-body-construct of a WHERE construct */
8778 cnext = cblock->next;
8783 /* WHERE assignment statement */
8785 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8788 /* WHERE operator assignment statement */
8789 case EXEC_ASSIGN_CALL:
8790 resolve_call (cnext);
8791 if (!cnext->resolved_sym->attr.elemental)
8792 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8793 &cnext->ext.actual->expr->where);
8796 /* WHERE or WHERE construct is part of a where-body-construct */
8798 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8802 gfc_error ("Unsupported statement inside WHERE at %L",
8805 /* the next statement within the same where-body-construct */
8806 cnext = cnext->next;
8808 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8809 cblock = cblock->block;
8814 /* Traverse the FORALL body to check whether the following errors exist:
8815 1. For assignment, check if a many-to-one assignment happens.
8816 2. For WHERE statement, check the WHERE body to see if there is any
8817 many-to-one assignment. */
8820 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8824 c = code->block->next;
8830 case EXEC_POINTER_ASSIGN:
8831 gfc_resolve_assign_in_forall (c, nvar, var_expr);
8834 case EXEC_ASSIGN_CALL:
8838 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8839 there is no need to handle it here. */
8843 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8848 /* The next statement in the FORALL body. */
8854 /* Counts the number of iterators needed inside a forall construct, including
8855 nested forall constructs. This is used to allocate the needed memory
8856 in gfc_resolve_forall. */
8859 gfc_count_forall_iterators (gfc_code *code)
8861 int max_iters, sub_iters, current_iters;
8862 gfc_forall_iterator *fa;
8864 gcc_assert(code->op == EXEC_FORALL);
8868 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8871 code = code->block->next;
8875 if (code->op == EXEC_FORALL)
8877 sub_iters = gfc_count_forall_iterators (code);
8878 if (sub_iters > max_iters)
8879 max_iters = sub_iters;
8884 return current_iters + max_iters;
8888 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8889 gfc_resolve_forall_body to resolve the FORALL body. */
8892 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8894 static gfc_expr **var_expr;
8895 static int total_var = 0;
8896 static int nvar = 0;
8898 gfc_forall_iterator *fa;
8903 /* Start to resolve a FORALL construct */
8904 if (forall_save == 0)
8906 /* Count the total number of FORALL index in the nested FORALL
8907 construct in order to allocate the VAR_EXPR with proper size. */
8908 total_var = gfc_count_forall_iterators (code);
8910 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8911 var_expr = XCNEWVEC (gfc_expr *, total_var);
8914 /* The information about FORALL iterator, including FORALL index start, end
8915 and stride. The FORALL index can not appear in start, end or stride. */
8916 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8918 /* Check if any outer FORALL index name is the same as the current
8920 for (i = 0; i < nvar; i++)
8922 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8924 gfc_error ("An outer FORALL construct already has an index "
8925 "with this name %L", &fa->var->where);
8929 /* Record the current FORALL index. */
8930 var_expr[nvar] = gfc_copy_expr (fa->var);
8934 /* No memory leak. */
8935 gcc_assert (nvar <= total_var);
8938 /* Resolve the FORALL body. */
8939 gfc_resolve_forall_body (code, nvar, var_expr);
8941 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8942 gfc_resolve_blocks (code->block, ns);
8946 /* Free only the VAR_EXPRs allocated in this frame. */
8947 for (i = nvar; i < tmp; i++)
8948 gfc_free_expr (var_expr[i]);
8952 /* We are in the outermost FORALL construct. */
8953 gcc_assert (forall_save == 0);
8955 /* VAR_EXPR is not needed any more. */
8962 /* Resolve a BLOCK construct statement. */
8965 resolve_block_construct (gfc_code* code)
8967 /* Resolve the BLOCK's namespace. */
8968 gfc_resolve (code->ext.block.ns);
8970 /* For an ASSOCIATE block, the associations (and their targets) are already
8971 resolved during resolve_symbol. */
8975 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8978 static void resolve_code (gfc_code *, gfc_namespace *);
8981 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8985 for (; b; b = b->block)
8987 t = gfc_resolve_expr (b->expr1);
8988 if (gfc_resolve_expr (b->expr2) == FAILURE)
8994 if (t == SUCCESS && b->expr1 != NULL
8995 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
8996 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9003 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
9004 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9009 resolve_branch (b->label1, b);
9013 resolve_block_construct (b);
9017 case EXEC_SELECT_TYPE:
9021 case EXEC_DO_CONCURRENT:
9029 case EXEC_OMP_ATOMIC:
9030 case EXEC_OMP_CRITICAL:
9032 case EXEC_OMP_MASTER:
9033 case EXEC_OMP_ORDERED:
9034 case EXEC_OMP_PARALLEL:
9035 case EXEC_OMP_PARALLEL_DO:
9036 case EXEC_OMP_PARALLEL_SECTIONS:
9037 case EXEC_OMP_PARALLEL_WORKSHARE:
9038 case EXEC_OMP_SECTIONS:
9039 case EXEC_OMP_SINGLE:
9041 case EXEC_OMP_TASKWAIT:
9042 case EXEC_OMP_TASKYIELD:
9043 case EXEC_OMP_WORKSHARE:
9047 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9050 resolve_code (b->next, ns);
9055 /* Does everything to resolve an ordinary assignment. Returns true
9056 if this is an interface assignment. */
9058 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
9068 if (gfc_extend_assign (code, ns) == SUCCESS)
9072 if (code->op == EXEC_ASSIGN_CALL)
9074 lhs = code->ext.actual->expr;
9075 rhsptr = &code->ext.actual->next->expr;
9079 gfc_actual_arglist* args;
9080 gfc_typebound_proc* tbp;
9082 gcc_assert (code->op == EXEC_COMPCALL);
9084 args = code->expr1->value.compcall.actual;
9086 rhsptr = &args->next->expr;
9088 tbp = code->expr1->value.compcall.tbp;
9089 gcc_assert (!tbp->is_generic);
9092 /* Make a temporary rhs when there is a default initializer
9093 and rhs is the same symbol as the lhs. */
9094 if ((*rhsptr)->expr_type == EXPR_VARIABLE
9095 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
9096 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
9097 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
9098 *rhsptr = gfc_get_parentheses (*rhsptr);
9107 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
9108 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9109 &code->loc) == FAILURE)
9112 /* Handle the case of a BOZ literal on the RHS. */
9113 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
9116 if (gfc_option.warn_surprising)
9117 gfc_warning ("BOZ literal at %L is bitwise transferred "
9118 "non-integer symbol '%s'", &code->loc,
9119 lhs->symtree->n.sym->name);
9121 if (!gfc_convert_boz (rhs, &lhs->ts))
9123 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
9125 if (rc == ARITH_UNDERFLOW)
9126 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9127 ". This check can be disabled with the option "
9128 "-fno-range-check", &rhs->where);
9129 else if (rc == ARITH_OVERFLOW)
9130 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9131 ". This check can be disabled with the option "
9132 "-fno-range-check", &rhs->where);
9133 else if (rc == ARITH_NAN)
9134 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9135 ". This check can be disabled with the option "
9136 "-fno-range-check", &rhs->where);
9141 if (lhs->ts.type == BT_CHARACTER
9142 && gfc_option.warn_character_truncation)
9144 if (lhs->ts.u.cl != NULL
9145 && lhs->ts.u.cl->length != NULL
9146 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9147 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
9149 if (rhs->expr_type == EXPR_CONSTANT)
9150 rlen = rhs->value.character.length;
9152 else if (rhs->ts.u.cl != NULL
9153 && rhs->ts.u.cl->length != NULL
9154 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9155 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
9157 if (rlen && llen && rlen > llen)
9158 gfc_warning_now ("CHARACTER expression will be truncated "
9159 "in assignment (%d/%d) at %L",
9160 llen, rlen, &code->loc);
9163 /* Ensure that a vector index expression for the lvalue is evaluated
9164 to a temporary if the lvalue symbol is referenced in it. */
9167 for (ref = lhs->ref; ref; ref= ref->next)
9168 if (ref->type == REF_ARRAY)
9170 for (n = 0; n < ref->u.ar.dimen; n++)
9171 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
9172 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
9173 ref->u.ar.start[n]))
9175 = gfc_get_parentheses (ref->u.ar.start[n]);
9179 if (gfc_pure (NULL))
9181 if (lhs->ts.type == BT_DERIVED
9182 && lhs->expr_type == EXPR_VARIABLE
9183 && lhs->ts.u.derived->attr.pointer_comp
9184 && rhs->expr_type == EXPR_VARIABLE
9185 && (gfc_impure_variable (rhs->symtree->n.sym)
9186 || gfc_is_coindexed (rhs)))
9189 if (gfc_is_coindexed (rhs))
9190 gfc_error ("Coindexed expression at %L is assigned to "
9191 "a derived type variable with a POINTER "
9192 "component in a PURE procedure",
9195 gfc_error ("The impure variable at %L is assigned to "
9196 "a derived type variable with a POINTER "
9197 "component in a PURE procedure (12.6)",
9202 /* Fortran 2008, C1283. */
9203 if (gfc_is_coindexed (lhs))
9205 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9206 "procedure", &rhs->where);
9211 if (gfc_implicit_pure (NULL))
9213 if (lhs->expr_type == EXPR_VARIABLE
9214 && lhs->symtree->n.sym != gfc_current_ns->proc_name
9215 && lhs->symtree->n.sym->ns != gfc_current_ns)
9216 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9218 if (lhs->ts.type == BT_DERIVED
9219 && lhs->expr_type == EXPR_VARIABLE
9220 && lhs->ts.u.derived->attr.pointer_comp
9221 && rhs->expr_type == EXPR_VARIABLE
9222 && (gfc_impure_variable (rhs->symtree->n.sym)
9223 || gfc_is_coindexed (rhs)))
9224 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9226 /* Fortran 2008, C1283. */
9227 if (gfc_is_coindexed (lhs))
9228 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9232 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9233 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9234 if (lhs->ts.type == BT_CLASS)
9236 gfc_error ("Variable must not be polymorphic in intrinsic assignment at "
9237 "%L - check that there is a matching specific subroutine "
9238 "for '=' operator", &lhs->where);
9242 /* F2008, Section 7.2.1.2. */
9243 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
9245 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9246 "component in assignment at %L", &lhs->where);
9250 gfc_check_assign (lhs, rhs, 1);
9255 /* Given a block of code, recursively resolve everything pointed to by this
9259 resolve_code (gfc_code *code, gfc_namespace *ns)
9261 int omp_workshare_save;
9262 int forall_save, do_concurrent_save;
9266 frame.prev = cs_base;
9270 find_reachable_labels (code);
9272 for (; code; code = code->next)
9274 frame.current = code;
9275 forall_save = forall_flag;
9276 do_concurrent_save = do_concurrent_flag;
9278 if (code->op == EXEC_FORALL)
9281 gfc_resolve_forall (code, ns, forall_save);
9284 else if (code->block)
9286 omp_workshare_save = -1;
9289 case EXEC_OMP_PARALLEL_WORKSHARE:
9290 omp_workshare_save = omp_workshare_flag;
9291 omp_workshare_flag = 1;
9292 gfc_resolve_omp_parallel_blocks (code, ns);
9294 case EXEC_OMP_PARALLEL:
9295 case EXEC_OMP_PARALLEL_DO:
9296 case EXEC_OMP_PARALLEL_SECTIONS:
9298 omp_workshare_save = omp_workshare_flag;
9299 omp_workshare_flag = 0;
9300 gfc_resolve_omp_parallel_blocks (code, ns);
9303 gfc_resolve_omp_do_blocks (code, ns);
9305 case EXEC_SELECT_TYPE:
9306 /* Blocks are handled in resolve_select_type because we have
9307 to transform the SELECT TYPE into ASSOCIATE first. */
9309 case EXEC_DO_CONCURRENT:
9310 do_concurrent_flag = 1;
9311 gfc_resolve_blocks (code->block, ns);
9312 do_concurrent_flag = 2;
9314 case EXEC_OMP_WORKSHARE:
9315 omp_workshare_save = omp_workshare_flag;
9316 omp_workshare_flag = 1;
9319 gfc_resolve_blocks (code->block, ns);
9323 if (omp_workshare_save != -1)
9324 omp_workshare_flag = omp_workshare_save;
9328 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
9329 t = gfc_resolve_expr (code->expr1);
9330 forall_flag = forall_save;
9331 do_concurrent_flag = do_concurrent_save;
9333 if (gfc_resolve_expr (code->expr2) == FAILURE)
9336 if (code->op == EXEC_ALLOCATE
9337 && gfc_resolve_expr (code->expr3) == FAILURE)
9343 case EXEC_END_BLOCK:
9344 case EXEC_END_NESTED_BLOCK:
9348 case EXEC_ERROR_STOP:
9352 case EXEC_ASSIGN_CALL:
9357 case EXEC_SYNC_IMAGES:
9358 case EXEC_SYNC_MEMORY:
9359 resolve_sync (code);
9364 resolve_lock_unlock (code);
9368 /* Keep track of which entry we are up to. */
9369 current_entry_id = code->ext.entry->id;
9373 resolve_where (code, NULL);
9377 if (code->expr1 != NULL)
9379 if (code->expr1->ts.type != BT_INTEGER)
9380 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9381 "INTEGER variable", &code->expr1->where);
9382 else if (code->expr1->symtree->n.sym->attr.assign != 1)
9383 gfc_error ("Variable '%s' has not been assigned a target "
9384 "label at %L", code->expr1->symtree->n.sym->name,
9385 &code->expr1->where);
9388 resolve_branch (code->label1, code);
9392 if (code->expr1 != NULL
9393 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
9394 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9395 "INTEGER return specifier", &code->expr1->where);
9398 case EXEC_INIT_ASSIGN:
9399 case EXEC_END_PROCEDURE:
9406 if (gfc_check_vardef_context (code->expr1, false, false,
9407 _("assignment")) == FAILURE)
9410 if (resolve_ordinary_assign (code, ns))
9412 if (code->op == EXEC_COMPCALL)
9419 case EXEC_LABEL_ASSIGN:
9420 if (code->label1->defined == ST_LABEL_UNKNOWN)
9421 gfc_error ("Label %d referenced at %L is never defined",
9422 code->label1->value, &code->label1->where);
9424 && (code->expr1->expr_type != EXPR_VARIABLE
9425 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
9426 || code->expr1->symtree->n.sym->ts.kind
9427 != gfc_default_integer_kind
9428 || code->expr1->symtree->n.sym->as != NULL))
9429 gfc_error ("ASSIGN statement at %L requires a scalar "
9430 "default INTEGER variable", &code->expr1->where);
9433 case EXEC_POINTER_ASSIGN:
9440 /* This is both a variable definition and pointer assignment
9441 context, so check both of them. For rank remapping, a final
9442 array ref may be present on the LHS and fool gfc_expr_attr
9443 used in gfc_check_vardef_context. Remove it. */
9444 e = remove_last_array_ref (code->expr1);
9445 t = gfc_check_vardef_context (e, true, false,
9446 _("pointer assignment"));
9448 t = gfc_check_vardef_context (e, false, false,
9449 _("pointer assignment"));
9454 gfc_check_pointer_assign (code->expr1, code->expr2);
9458 case EXEC_ARITHMETIC_IF:
9460 && code->expr1->ts.type != BT_INTEGER
9461 && code->expr1->ts.type != BT_REAL)
9462 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9463 "expression", &code->expr1->where);
9465 resolve_branch (code->label1, code);
9466 resolve_branch (code->label2, code);
9467 resolve_branch (code->label3, code);
9471 if (t == SUCCESS && code->expr1 != NULL
9472 && (code->expr1->ts.type != BT_LOGICAL
9473 || code->expr1->rank != 0))
9474 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9475 &code->expr1->where);
9480 resolve_call (code);
9485 resolve_typebound_subroutine (code);
9489 resolve_ppc_call (code);
9493 /* Select is complicated. Also, a SELECT construct could be
9494 a transformed computed GOTO. */
9495 resolve_select (code);
9498 case EXEC_SELECT_TYPE:
9499 resolve_select_type (code, ns);
9503 resolve_block_construct (code);
9507 if (code->ext.iterator != NULL)
9509 gfc_iterator *iter = code->ext.iterator;
9510 if (gfc_resolve_iterator (iter, true) != FAILURE)
9511 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
9516 if (code->expr1 == NULL)
9517 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9519 && (code->expr1->rank != 0
9520 || code->expr1->ts.type != BT_LOGICAL))
9521 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9522 "a scalar LOGICAL expression", &code->expr1->where);
9527 resolve_allocate_deallocate (code, "ALLOCATE");
9531 case EXEC_DEALLOCATE:
9533 resolve_allocate_deallocate (code, "DEALLOCATE");
9538 if (gfc_resolve_open (code->ext.open) == FAILURE)
9541 resolve_branch (code->ext.open->err, code);
9545 if (gfc_resolve_close (code->ext.close) == FAILURE)
9548 resolve_branch (code->ext.close->err, code);
9551 case EXEC_BACKSPACE:
9555 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
9558 resolve_branch (code->ext.filepos->err, code);
9562 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9565 resolve_branch (code->ext.inquire->err, code);
9569 gcc_assert (code->ext.inquire != NULL);
9570 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9573 resolve_branch (code->ext.inquire->err, code);
9577 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
9580 resolve_branch (code->ext.wait->err, code);
9581 resolve_branch (code->ext.wait->end, code);
9582 resolve_branch (code->ext.wait->eor, code);
9587 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
9590 resolve_branch (code->ext.dt->err, code);
9591 resolve_branch (code->ext.dt->end, code);
9592 resolve_branch (code->ext.dt->eor, code);
9596 resolve_transfer (code);
9599 case EXEC_DO_CONCURRENT:
9601 resolve_forall_iterators (code->ext.forall_iterator);
9603 if (code->expr1 != NULL
9604 && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
9605 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9606 "expression", &code->expr1->where);
9609 case EXEC_OMP_ATOMIC:
9610 case EXEC_OMP_BARRIER:
9611 case EXEC_OMP_CRITICAL:
9612 case EXEC_OMP_FLUSH:
9614 case EXEC_OMP_MASTER:
9615 case EXEC_OMP_ORDERED:
9616 case EXEC_OMP_SECTIONS:
9617 case EXEC_OMP_SINGLE:
9618 case EXEC_OMP_TASKWAIT:
9619 case EXEC_OMP_TASKYIELD:
9620 case EXEC_OMP_WORKSHARE:
9621 gfc_resolve_omp_directive (code, ns);
9624 case EXEC_OMP_PARALLEL:
9625 case EXEC_OMP_PARALLEL_DO:
9626 case EXEC_OMP_PARALLEL_SECTIONS:
9627 case EXEC_OMP_PARALLEL_WORKSHARE:
9629 omp_workshare_save = omp_workshare_flag;
9630 omp_workshare_flag = 0;
9631 gfc_resolve_omp_directive (code, ns);
9632 omp_workshare_flag = omp_workshare_save;
9636 gfc_internal_error ("resolve_code(): Bad statement code");
9640 cs_base = frame.prev;
9644 /* Resolve initial values and make sure they are compatible with
9648 resolve_values (gfc_symbol *sym)
9652 if (sym->value == NULL)
9655 if (sym->value->expr_type == EXPR_STRUCTURE)
9656 t= resolve_structure_cons (sym->value, 1);
9658 t = gfc_resolve_expr (sym->value);
9663 gfc_check_assign_symbol (sym, sym->value);
9667 /* Verify the binding labels for common blocks that are BIND(C). The label
9668 for a BIND(C) common block must be identical in all scoping units in which
9669 the common block is declared. Further, the binding label can not collide
9670 with any other global entity in the program. */
9673 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
9675 if (comm_block_tree->n.common->is_bind_c == 1)
9677 gfc_gsymbol *binding_label_gsym;
9678 gfc_gsymbol *comm_name_gsym;
9680 /* See if a global symbol exists by the common block's name. It may
9681 be NULL if the common block is use-associated. */
9682 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
9683 comm_block_tree->n.common->name);
9684 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
9685 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9686 "with the global entity '%s' at %L",
9687 comm_block_tree->n.common->binding_label,
9688 comm_block_tree->n.common->name,
9689 &(comm_block_tree->n.common->where),
9690 comm_name_gsym->name, &(comm_name_gsym->where));
9691 else if (comm_name_gsym != NULL
9692 && strcmp (comm_name_gsym->name,
9693 comm_block_tree->n.common->name) == 0)
9695 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9697 if (comm_name_gsym->binding_label == NULL)
9698 /* No binding label for common block stored yet; save this one. */
9699 comm_name_gsym->binding_label =
9700 comm_block_tree->n.common->binding_label;
9702 if (strcmp (comm_name_gsym->binding_label,
9703 comm_block_tree->n.common->binding_label) != 0)
9705 /* Common block names match but binding labels do not. */
9706 gfc_error ("Binding label '%s' for common block '%s' at %L "
9707 "does not match the binding label '%s' for common "
9709 comm_block_tree->n.common->binding_label,
9710 comm_block_tree->n.common->name,
9711 &(comm_block_tree->n.common->where),
9712 comm_name_gsym->binding_label,
9713 comm_name_gsym->name,
9714 &(comm_name_gsym->where));
9719 /* There is no binding label (NAME="") so we have nothing further to
9720 check and nothing to add as a global symbol for the label. */
9721 if (comm_block_tree->n.common->binding_label[0] == '\0' )
9724 binding_label_gsym =
9725 gfc_find_gsymbol (gfc_gsym_root,
9726 comm_block_tree->n.common->binding_label);
9727 if (binding_label_gsym == NULL)
9729 /* Need to make a global symbol for the binding label to prevent
9730 it from colliding with another. */
9731 binding_label_gsym =
9732 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9733 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9734 binding_label_gsym->type = GSYM_COMMON;
9738 /* If comm_name_gsym is NULL, the name common block is use
9739 associated and the name could be colliding. */
9740 if (binding_label_gsym->type != GSYM_COMMON)
9741 gfc_error ("Binding label '%s' for common block '%s' at %L "
9742 "collides with the global entity '%s' at %L",
9743 comm_block_tree->n.common->binding_label,
9744 comm_block_tree->n.common->name,
9745 &(comm_block_tree->n.common->where),
9746 binding_label_gsym->name,
9747 &(binding_label_gsym->where));
9748 else if (comm_name_gsym != NULL
9749 && (strcmp (binding_label_gsym->name,
9750 comm_name_gsym->binding_label) != 0)
9751 && (strcmp (binding_label_gsym->sym_name,
9752 comm_name_gsym->name) != 0))
9753 gfc_error ("Binding label '%s' for common block '%s' at %L "
9754 "collides with global entity '%s' at %L",
9755 binding_label_gsym->name, binding_label_gsym->sym_name,
9756 &(comm_block_tree->n.common->where),
9757 comm_name_gsym->name, &(comm_name_gsym->where));
9765 /* Verify any BIND(C) derived types in the namespace so we can report errors
9766 for them once, rather than for each variable declared of that type. */
9769 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9771 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9772 && derived_sym->attr.is_bind_c == 1)
9773 verify_bind_c_derived_type (derived_sym);
9779 /* Verify that any binding labels used in a given namespace do not collide
9780 with the names or binding labels of any global symbols. */
9783 gfc_verify_binding_labels (gfc_symbol *sym)
9787 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9788 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
9790 gfc_gsymbol *bind_c_sym;
9792 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9793 if (bind_c_sym != NULL
9794 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9796 if (sym->attr.if_source == IFSRC_DECL
9797 && (bind_c_sym->type != GSYM_SUBROUTINE
9798 && bind_c_sym->type != GSYM_FUNCTION)
9799 && ((sym->attr.contained == 1
9800 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9801 || (sym->attr.use_assoc == 1
9802 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9804 /* Make sure global procedures don't collide with anything. */
9805 gfc_error ("Binding label '%s' at %L collides with the global "
9806 "entity '%s' at %L", sym->binding_label,
9807 &(sym->declared_at), bind_c_sym->name,
9808 &(bind_c_sym->where));
9811 else if (sym->attr.contained == 0
9812 && (sym->attr.if_source == IFSRC_IFBODY
9813 && sym->attr.flavor == FL_PROCEDURE)
9814 && (bind_c_sym->sym_name != NULL
9815 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9817 /* Make sure procedures in interface bodies don't collide. */
9818 gfc_error ("Binding label '%s' in interface body at %L collides "
9819 "with the global entity '%s' at %L",
9821 &(sym->declared_at), bind_c_sym->name,
9822 &(bind_c_sym->where));
9825 else if (sym->attr.contained == 0
9826 && sym->attr.if_source == IFSRC_UNKNOWN)
9827 if ((sym->attr.use_assoc && bind_c_sym->mod_name
9828 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9829 || sym->attr.use_assoc == 0)
9831 gfc_error ("Binding label '%s' at %L collides with global "
9832 "entity '%s' at %L", sym->binding_label,
9833 &(sym->declared_at), bind_c_sym->name,
9834 &(bind_c_sym->where));
9839 /* Clear the binding label to prevent checking multiple times. */
9840 sym->binding_label[0] = '\0';
9842 else if (bind_c_sym == NULL)
9844 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9845 bind_c_sym->where = sym->declared_at;
9846 bind_c_sym->sym_name = sym->name;
9848 if (sym->attr.use_assoc == 1)
9849 bind_c_sym->mod_name = sym->module;
9851 if (sym->ns->proc_name != NULL)
9852 bind_c_sym->mod_name = sym->ns->proc_name->name;
9854 if (sym->attr.contained == 0)
9856 if (sym->attr.subroutine)
9857 bind_c_sym->type = GSYM_SUBROUTINE;
9858 else if (sym->attr.function)
9859 bind_c_sym->type = GSYM_FUNCTION;
9867 /* Resolve an index expression. */
9870 resolve_index_expr (gfc_expr *e)
9872 if (gfc_resolve_expr (e) == FAILURE)
9875 if (gfc_simplify_expr (e, 0) == FAILURE)
9878 if (gfc_specification_expr (e) == FAILURE)
9885 /* Resolve a charlen structure. */
9888 resolve_charlen (gfc_charlen *cl)
9897 specification_expr = 1;
9899 if (resolve_index_expr (cl->length) == FAILURE)
9901 specification_expr = 0;
9905 /* "If the character length parameter value evaluates to a negative
9906 value, the length of character entities declared is zero." */
9907 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9909 if (gfc_option.warn_surprising)
9910 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9911 " the length has been set to zero",
9912 &cl->length->where, i);
9913 gfc_replace_expr (cl->length,
9914 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9917 /* Check that the character length is not too large. */
9918 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9919 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9920 && cl->length->ts.type == BT_INTEGER
9921 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9923 gfc_error ("String length at %L is too large", &cl->length->where);
9931 /* Test for non-constant shape arrays. */
9934 is_non_constant_shape_array (gfc_symbol *sym)
9940 not_constant = false;
9941 if (sym->as != NULL)
9943 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9944 has not been simplified; parameter array references. Do the
9945 simplification now. */
9946 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9948 e = sym->as->lower[i];
9949 if (e && (resolve_index_expr (e) == FAILURE
9950 || !gfc_is_constant_expr (e)))
9951 not_constant = true;
9952 e = sym->as->upper[i];
9953 if (e && (resolve_index_expr (e) == FAILURE
9954 || !gfc_is_constant_expr (e)))
9955 not_constant = true;
9958 return not_constant;
9961 /* Given a symbol and an initialization expression, add code to initialize
9962 the symbol to the function entry. */
9964 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9968 gfc_namespace *ns = sym->ns;
9970 /* Search for the function namespace if this is a contained
9971 function without an explicit result. */
9972 if (sym->attr.function && sym == sym->result
9973 && sym->name != sym->ns->proc_name->name)
9976 for (;ns; ns = ns->sibling)
9977 if (strcmp (ns->proc_name->name, sym->name) == 0)
9983 gfc_free_expr (init);
9987 /* Build an l-value expression for the result. */
9988 lval = gfc_lval_expr_from_sym (sym);
9990 /* Add the code at scope entry. */
9991 init_st = gfc_get_code ();
9992 init_st->next = ns->code;
9995 /* Assign the default initializer to the l-value. */
9996 init_st->loc = sym->declared_at;
9997 init_st->op = EXEC_INIT_ASSIGN;
9998 init_st->expr1 = lval;
9999 init_st->expr2 = init;
10002 /* Assign the default initializer to a derived type variable or result. */
10005 apply_default_init (gfc_symbol *sym)
10007 gfc_expr *init = NULL;
10009 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
10012 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
10013 init = gfc_default_initializer (&sym->ts);
10015 if (init == NULL && sym->ts.type != BT_CLASS)
10018 build_init_assign (sym, init);
10019 sym->attr.referenced = 1;
10022 /* Build an initializer for a local integer, real, complex, logical, or
10023 character variable, based on the command line flags finit-local-zero,
10024 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10025 null if the symbol should not have a default initialization. */
10027 build_default_init_expr (gfc_symbol *sym)
10030 gfc_expr *init_expr;
10033 /* These symbols should never have a default initialization. */
10034 if (sym->attr.allocatable
10035 || sym->attr.external
10037 || sym->attr.pointer
10038 || sym->attr.in_equivalence
10039 || sym->attr.in_common
10042 || sym->attr.cray_pointee
10043 || sym->attr.cray_pointer)
10046 /* Now we'll try to build an initializer expression. */
10047 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
10048 &sym->declared_at);
10050 /* We will only initialize integers, reals, complex, logicals, and
10051 characters, and only if the corresponding command-line flags
10052 were set. Otherwise, we free init_expr and return null. */
10053 switch (sym->ts.type)
10056 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
10057 mpz_set_si (init_expr->value.integer,
10058 gfc_option.flag_init_integer_value);
10061 gfc_free_expr (init_expr);
10067 switch (gfc_option.flag_init_real)
10069 case GFC_INIT_REAL_SNAN:
10070 init_expr->is_snan = 1;
10071 /* Fall through. */
10072 case GFC_INIT_REAL_NAN:
10073 mpfr_set_nan (init_expr->value.real);
10076 case GFC_INIT_REAL_INF:
10077 mpfr_set_inf (init_expr->value.real, 1);
10080 case GFC_INIT_REAL_NEG_INF:
10081 mpfr_set_inf (init_expr->value.real, -1);
10084 case GFC_INIT_REAL_ZERO:
10085 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
10089 gfc_free_expr (init_expr);
10096 switch (gfc_option.flag_init_real)
10098 case GFC_INIT_REAL_SNAN:
10099 init_expr->is_snan = 1;
10100 /* Fall through. */
10101 case GFC_INIT_REAL_NAN:
10102 mpfr_set_nan (mpc_realref (init_expr->value.complex));
10103 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
10106 case GFC_INIT_REAL_INF:
10107 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
10108 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
10111 case GFC_INIT_REAL_NEG_INF:
10112 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
10113 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
10116 case GFC_INIT_REAL_ZERO:
10117 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
10121 gfc_free_expr (init_expr);
10128 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
10129 init_expr->value.logical = 0;
10130 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
10131 init_expr->value.logical = 1;
10134 gfc_free_expr (init_expr);
10140 /* For characters, the length must be constant in order to
10141 create a default initializer. */
10142 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
10143 && sym->ts.u.cl->length
10144 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
10146 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
10147 init_expr->value.character.length = char_len;
10148 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
10149 for (i = 0; i < char_len; i++)
10150 init_expr->value.character.string[i]
10151 = (unsigned char) gfc_option.flag_init_character_value;
10155 gfc_free_expr (init_expr);
10158 if (!init_expr && gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
10159 && sym->ts.u.cl->length)
10161 gfc_actual_arglist *arg;
10162 init_expr = gfc_get_expr ();
10163 init_expr->where = sym->declared_at;
10164 init_expr->ts = sym->ts;
10165 init_expr->expr_type = EXPR_FUNCTION;
10166 init_expr->value.function.isym =
10167 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT);
10168 init_expr->value.function.name = "repeat";
10169 arg = gfc_get_actual_arglist ();
10170 arg->expr = gfc_get_character_expr (sym->ts.kind, &sym->declared_at,
10172 arg->expr->value.character.string[0]
10173 = gfc_option.flag_init_character_value;
10174 arg->next = gfc_get_actual_arglist ();
10175 arg->next->expr = gfc_copy_expr (sym->ts.u.cl->length);
10176 init_expr->value.function.actual = arg;
10181 gfc_free_expr (init_expr);
10187 /* Add an initialization expression to a local variable. */
10189 apply_default_init_local (gfc_symbol *sym)
10191 gfc_expr *init = NULL;
10193 /* The symbol should be a variable or a function return value. */
10194 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
10195 || (sym->attr.function && sym->result != sym))
10198 /* Try to build the initializer expression. If we can't initialize
10199 this symbol, then init will be NULL. */
10200 init = build_default_init_expr (sym);
10204 /* For saved variables, we don't want to add an initializer at function
10205 entry, so we just add a static initializer. Note that automatic variables
10206 are stack allocated even with -fno-automatic. */
10207 if (sym->attr.save || sym->ns->save_all
10208 || (gfc_option.flag_max_stack_var_size == 0
10209 && (!sym->attr.dimension || !is_non_constant_shape_array (sym))))
10211 /* Don't clobber an existing initializer! */
10212 gcc_assert (sym->value == NULL);
10217 build_init_assign (sym, init);
10221 /* Resolution of common features of flavors variable and procedure. */
10224 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
10226 gfc_array_spec *as;
10228 /* Avoid double diagnostics for function result symbols. */
10229 if ((sym->result || sym->attr.result) && !sym->attr.dummy
10230 && (sym->ns != gfc_current_ns))
10233 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
10234 as = CLASS_DATA (sym)->as;
10238 /* Constraints on deferred shape variable. */
10239 if (as == NULL || as->type != AS_DEFERRED)
10241 bool pointer, allocatable, dimension;
10243 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
10245 pointer = CLASS_DATA (sym)->attr.class_pointer;
10246 allocatable = CLASS_DATA (sym)->attr.allocatable;
10247 dimension = CLASS_DATA (sym)->attr.dimension;
10251 pointer = sym->attr.pointer;
10252 allocatable = sym->attr.allocatable;
10253 dimension = sym->attr.dimension;
10260 gfc_error ("Allocatable array '%s' at %L must have "
10261 "a deferred shape", sym->name, &sym->declared_at);
10264 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
10265 "may not be ALLOCATABLE", sym->name,
10266 &sym->declared_at) == FAILURE)
10270 if (pointer && dimension)
10272 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
10273 sym->name, &sym->declared_at);
10279 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
10280 && sym->ts.type != BT_CLASS && !sym->assoc)
10282 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10283 sym->name, &sym->declared_at);
10288 /* Constraints on polymorphic variables. */
10289 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
10292 if (sym->attr.class_ok
10293 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
10295 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10296 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
10297 &sym->declared_at);
10302 /* Assume that use associated symbols were checked in the module ns.
10303 Class-variables that are associate-names are also something special
10304 and excepted from the test. */
10305 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
10307 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10308 "or pointer", sym->name, &sym->declared_at);
10317 /* Additional checks for symbols with flavor variable and derived
10318 type. To be called from resolve_fl_variable. */
10321 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
10323 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
10325 /* Check to see if a derived type is blocked from being host
10326 associated by the presence of another class I symbol in the same
10327 namespace. 14.6.1.3 of the standard and the discussion on
10328 comp.lang.fortran. */
10329 if (sym->ns != sym->ts.u.derived->ns
10330 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
10333 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
10334 if (s && s->attr.generic)
10335 s = gfc_find_dt_in_generic (s);
10336 if (s && s->attr.flavor != FL_DERIVED)
10338 gfc_error ("The type '%s' cannot be host associated at %L "
10339 "because it is blocked by an incompatible object "
10340 "of the same name declared at %L",
10341 sym->ts.u.derived->name, &sym->declared_at,
10347 /* 4th constraint in section 11.3: "If an object of a type for which
10348 component-initialization is specified (R429) appears in the
10349 specification-part of a module and does not have the ALLOCATABLE
10350 or POINTER attribute, the object shall have the SAVE attribute."
10352 The check for initializers is performed with
10353 gfc_has_default_initializer because gfc_default_initializer generates
10354 a hidden default for allocatable components. */
10355 if (!(sym->value || no_init_flag) && sym->ns->proc_name
10356 && sym->ns->proc_name->attr.flavor == FL_MODULE
10357 && !sym->ns->save_all && !sym->attr.save
10358 && !sym->attr.pointer && !sym->attr.allocatable
10359 && gfc_has_default_initializer (sym->ts.u.derived)
10360 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
10361 "module variable '%s' at %L, needed due to "
10362 "the default initialization", sym->name,
10363 &sym->declared_at) == FAILURE)
10366 /* Assign default initializer. */
10367 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
10368 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
10370 sym->value = gfc_default_initializer (&sym->ts);
10377 /* Resolve symbols with flavor variable. */
10380 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
10382 int no_init_flag, automatic_flag;
10384 const char *auto_save_msg;
10386 auto_save_msg = "Automatic object '%s' at %L cannot have the "
10389 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10392 /* Set this flag to check that variables are parameters of all entries.
10393 This check is effected by the call to gfc_resolve_expr through
10394 is_non_constant_shape_array. */
10395 specification_expr = 1;
10397 if (sym->ns->proc_name
10398 && (sym->ns->proc_name->attr.flavor == FL_MODULE
10399 || sym->ns->proc_name->attr.is_main_program)
10400 && !sym->attr.use_assoc
10401 && !sym->attr.allocatable
10402 && !sym->attr.pointer
10403 && is_non_constant_shape_array (sym))
10405 /* The shape of a main program or module array needs to be
10407 gfc_error ("The module or main program array '%s' at %L must "
10408 "have constant shape", sym->name, &sym->declared_at);
10409 specification_expr = 0;
10413 /* Constraints on deferred type parameter. */
10414 if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
10416 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10417 "requires either the pointer or allocatable attribute",
10418 sym->name, &sym->declared_at);
10422 if (sym->ts.type == BT_CHARACTER)
10424 /* Make sure that character string variables with assumed length are
10425 dummy arguments. */
10426 e = sym->ts.u.cl->length;
10427 if (e == NULL && !sym->attr.dummy && !sym->attr.result
10428 && !sym->ts.deferred)
10430 gfc_error ("Entity with assumed character length at %L must be a "
10431 "dummy argument or a PARAMETER", &sym->declared_at);
10435 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
10437 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10441 if (!gfc_is_constant_expr (e)
10442 && !(e->expr_type == EXPR_VARIABLE
10443 && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
10445 if (!sym->attr.use_assoc && sym->ns->proc_name
10446 && (sym->ns->proc_name->attr.flavor == FL_MODULE
10447 || sym->ns->proc_name->attr.is_main_program))
10449 gfc_error ("'%s' at %L must have constant character length "
10450 "in this context", sym->name, &sym->declared_at);
10453 if (sym->attr.in_common)
10455 gfc_error ("COMMON variable '%s' at %L must have constant "
10456 "character length", sym->name, &sym->declared_at);
10462 if (sym->value == NULL && sym->attr.referenced)
10463 apply_default_init_local (sym); /* Try to apply a default initialization. */
10465 /* Determine if the symbol may not have an initializer. */
10466 no_init_flag = automatic_flag = 0;
10467 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
10468 || sym->attr.intrinsic || sym->attr.result)
10470 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
10471 && is_non_constant_shape_array (sym))
10473 no_init_flag = automatic_flag = 1;
10475 /* Also, they must not have the SAVE attribute.
10476 SAVE_IMPLICIT is checked below. */
10477 if (sym->as && sym->attr.codimension)
10479 int corank = sym->as->corank;
10480 sym->as->corank = 0;
10481 no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
10482 sym->as->corank = corank;
10484 if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
10486 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10491 /* Ensure that any initializer is simplified. */
10493 gfc_simplify_expr (sym->value, 1);
10495 /* Reject illegal initializers. */
10496 if (!sym->mark && sym->value)
10498 if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
10499 && CLASS_DATA (sym)->attr.allocatable))
10500 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10501 sym->name, &sym->declared_at);
10502 else if (sym->attr.external)
10503 gfc_error ("External '%s' at %L cannot have an initializer",
10504 sym->name, &sym->declared_at);
10505 else if (sym->attr.dummy
10506 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
10507 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10508 sym->name, &sym->declared_at);
10509 else if (sym->attr.intrinsic)
10510 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10511 sym->name, &sym->declared_at);
10512 else if (sym->attr.result)
10513 gfc_error ("Function result '%s' at %L cannot have an initializer",
10514 sym->name, &sym->declared_at);
10515 else if (automatic_flag)
10516 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10517 sym->name, &sym->declared_at);
10519 goto no_init_error;
10524 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
10525 return resolve_fl_variable_derived (sym, no_init_flag);
10531 /* Resolve a procedure. */
10534 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
10536 gfc_formal_arglist *arg;
10538 if (sym->attr.function
10539 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10542 if (sym->ts.type == BT_CHARACTER)
10544 gfc_charlen *cl = sym->ts.u.cl;
10546 if (cl && cl->length && gfc_is_constant_expr (cl->length)
10547 && resolve_charlen (cl) == FAILURE)
10550 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
10551 && sym->attr.proc == PROC_ST_FUNCTION)
10553 gfc_error ("Character-valued statement function '%s' at %L must "
10554 "have constant length", sym->name, &sym->declared_at);
10559 /* Ensure that derived type for are not of a private type. Internal
10560 module procedures are excluded by 2.2.3.3 - i.e., they are not
10561 externally accessible and can access all the objects accessible in
10563 if (!(sym->ns->parent
10564 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
10565 && gfc_check_symbol_access (sym))
10567 gfc_interface *iface;
10569 for (arg = sym->formal; arg; arg = arg->next)
10572 && arg->sym->ts.type == BT_DERIVED
10573 && !arg->sym->ts.u.derived->attr.use_assoc
10574 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10575 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
10576 "PRIVATE type and cannot be a dummy argument"
10577 " of '%s', which is PUBLIC at %L",
10578 arg->sym->name, sym->name, &sym->declared_at)
10581 /* Stop this message from recurring. */
10582 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10587 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10588 PRIVATE to the containing module. */
10589 for (iface = sym->generic; iface; iface = iface->next)
10591 for (arg = iface->sym->formal; arg; arg = arg->next)
10594 && arg->sym->ts.type == BT_DERIVED
10595 && !arg->sym->ts.u.derived->attr.use_assoc
10596 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10597 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10598 "'%s' in PUBLIC interface '%s' at %L "
10599 "takes dummy arguments of '%s' which is "
10600 "PRIVATE", iface->sym->name, sym->name,
10601 &iface->sym->declared_at,
10602 gfc_typename (&arg->sym->ts)) == FAILURE)
10604 /* Stop this message from recurring. */
10605 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10611 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10612 PRIVATE to the containing module. */
10613 for (iface = sym->generic; iface; iface = iface->next)
10615 for (arg = iface->sym->formal; arg; arg = arg->next)
10618 && arg->sym->ts.type == BT_DERIVED
10619 && !arg->sym->ts.u.derived->attr.use_assoc
10620 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10621 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10622 "'%s' in PUBLIC interface '%s' at %L "
10623 "takes dummy arguments of '%s' which is "
10624 "PRIVATE", iface->sym->name, sym->name,
10625 &iface->sym->declared_at,
10626 gfc_typename (&arg->sym->ts)) == FAILURE)
10628 /* Stop this message from recurring. */
10629 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10636 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10637 && !sym->attr.proc_pointer)
10639 gfc_error ("Function '%s' at %L cannot have an initializer",
10640 sym->name, &sym->declared_at);
10644 /* An external symbol may not have an initializer because it is taken to be
10645 a procedure. Exception: Procedure Pointers. */
10646 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10648 gfc_error ("External object '%s' at %L may not have an initializer",
10649 sym->name, &sym->declared_at);
10653 /* An elemental function is required to return a scalar 12.7.1 */
10654 if (sym->attr.elemental && sym->attr.function && sym->as)
10656 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10657 "result", sym->name, &sym->declared_at);
10658 /* Reset so that the error only occurs once. */
10659 sym->attr.elemental = 0;
10663 if (sym->attr.proc == PROC_ST_FUNCTION
10664 && (sym->attr.allocatable || sym->attr.pointer))
10666 gfc_error ("Statement function '%s' at %L may not have pointer or "
10667 "allocatable attribute", sym->name, &sym->declared_at);
10671 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10672 char-len-param shall not be array-valued, pointer-valued, recursive
10673 or pure. ....snip... A character value of * may only be used in the
10674 following ways: (i) Dummy arg of procedure - dummy associates with
10675 actual length; (ii) To declare a named constant; or (iii) External
10676 function - but length must be declared in calling scoping unit. */
10677 if (sym->attr.function
10678 && sym->ts.type == BT_CHARACTER
10679 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10681 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10682 || (sym->attr.recursive) || (sym->attr.pure))
10684 if (sym->as && sym->as->rank)
10685 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10686 "array-valued", sym->name, &sym->declared_at);
10688 if (sym->attr.pointer)
10689 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10690 "pointer-valued", sym->name, &sym->declared_at);
10692 if (sym->attr.pure)
10693 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10694 "pure", sym->name, &sym->declared_at);
10696 if (sym->attr.recursive)
10697 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10698 "recursive", sym->name, &sym->declared_at);
10703 /* Appendix B.2 of the standard. Contained functions give an
10704 error anyway. Fixed-form is likely to be F77/legacy. Deferred
10705 character length is an F2003 feature. */
10706 if (!sym->attr.contained
10707 && gfc_current_form != FORM_FIXED
10708 && !sym->ts.deferred)
10709 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10710 "CHARACTER(*) function '%s' at %L",
10711 sym->name, &sym->declared_at);
10714 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10716 gfc_formal_arglist *curr_arg;
10717 int has_non_interop_arg = 0;
10719 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10720 sym->common_block) == FAILURE)
10722 /* Clear these to prevent looking at them again if there was an
10724 sym->attr.is_bind_c = 0;
10725 sym->attr.is_c_interop = 0;
10726 sym->ts.is_c_interop = 0;
10730 /* So far, no errors have been found. */
10731 sym->attr.is_c_interop = 1;
10732 sym->ts.is_c_interop = 1;
10735 curr_arg = sym->formal;
10736 while (curr_arg != NULL)
10738 /* Skip implicitly typed dummy args here. */
10739 if (curr_arg->sym->attr.implicit_type == 0)
10740 if (gfc_verify_c_interop_param (curr_arg->sym) == FAILURE)
10741 /* If something is found to fail, record the fact so we
10742 can mark the symbol for the procedure as not being
10743 BIND(C) to try and prevent multiple errors being
10745 has_non_interop_arg = 1;
10747 curr_arg = curr_arg->next;
10750 /* See if any of the arguments were not interoperable and if so, clear
10751 the procedure symbol to prevent duplicate error messages. */
10752 if (has_non_interop_arg != 0)
10754 sym->attr.is_c_interop = 0;
10755 sym->ts.is_c_interop = 0;
10756 sym->attr.is_bind_c = 0;
10760 if (!sym->attr.proc_pointer)
10762 if (sym->attr.save == SAVE_EXPLICIT)
10764 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10765 "in '%s' at %L", sym->name, &sym->declared_at);
10768 if (sym->attr.intent)
10770 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10771 "in '%s' at %L", sym->name, &sym->declared_at);
10774 if (sym->attr.subroutine && sym->attr.result)
10776 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10777 "in '%s' at %L", sym->name, &sym->declared_at);
10780 if (sym->attr.external && sym->attr.function
10781 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10782 || sym->attr.contained))
10784 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10785 "in '%s' at %L", sym->name, &sym->declared_at);
10788 if (strcmp ("ppr@", sym->name) == 0)
10790 gfc_error ("Procedure pointer result '%s' at %L "
10791 "is missing the pointer attribute",
10792 sym->ns->proc_name->name, &sym->declared_at);
10801 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10802 been defined and we now know their defined arguments, check that they fulfill
10803 the requirements of the standard for procedures used as finalizers. */
10806 gfc_resolve_finalizers (gfc_symbol* derived)
10808 gfc_finalizer* list;
10809 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10810 gfc_try result = SUCCESS;
10811 bool seen_scalar = false;
10813 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10816 /* Walk over the list of finalizer-procedures, check them, and if any one
10817 does not fit in with the standard's definition, print an error and remove
10818 it from the list. */
10819 prev_link = &derived->f2k_derived->finalizers;
10820 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10826 /* Skip this finalizer if we already resolved it. */
10827 if (list->proc_tree)
10829 prev_link = &(list->next);
10833 /* Check this exists and is a SUBROUTINE. */
10834 if (!list->proc_sym->attr.subroutine)
10836 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10837 list->proc_sym->name, &list->where);
10841 /* We should have exactly one argument. */
10842 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10844 gfc_error ("FINAL procedure at %L must have exactly one argument",
10848 arg = list->proc_sym->formal->sym;
10850 /* This argument must be of our type. */
10851 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10853 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10854 &arg->declared_at, derived->name);
10858 /* It must neither be a pointer nor allocatable nor optional. */
10859 if (arg->attr.pointer)
10861 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10862 &arg->declared_at);
10865 if (arg->attr.allocatable)
10867 gfc_error ("Argument of FINAL procedure at %L must not be"
10868 " ALLOCATABLE", &arg->declared_at);
10871 if (arg->attr.optional)
10873 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10874 &arg->declared_at);
10878 /* It must not be INTENT(OUT). */
10879 if (arg->attr.intent == INTENT_OUT)
10881 gfc_error ("Argument of FINAL procedure at %L must not be"
10882 " INTENT(OUT)", &arg->declared_at);
10886 /* Warn if the procedure is non-scalar and not assumed shape. */
10887 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10888 && arg->as->type != AS_ASSUMED_SHAPE)
10889 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10890 " shape argument", &arg->declared_at);
10892 /* Check that it does not match in kind and rank with a FINAL procedure
10893 defined earlier. To really loop over the *earlier* declarations,
10894 we need to walk the tail of the list as new ones were pushed at the
10896 /* TODO: Handle kind parameters once they are implemented. */
10897 my_rank = (arg->as ? arg->as->rank : 0);
10898 for (i = list->next; i; i = i->next)
10900 /* Argument list might be empty; that is an error signalled earlier,
10901 but we nevertheless continued resolving. */
10902 if (i->proc_sym->formal)
10904 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10905 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10906 if (i_rank == my_rank)
10908 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10909 " rank (%d) as '%s'",
10910 list->proc_sym->name, &list->where, my_rank,
10911 i->proc_sym->name);
10917 /* Is this the/a scalar finalizer procedure? */
10918 if (!arg->as || arg->as->rank == 0)
10919 seen_scalar = true;
10921 /* Find the symtree for this procedure. */
10922 gcc_assert (!list->proc_tree);
10923 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10925 prev_link = &list->next;
10928 /* Remove wrong nodes immediately from the list so we don't risk any
10929 troubles in the future when they might fail later expectations. */
10933 *prev_link = list->next;
10934 gfc_free_finalizer (i);
10937 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10938 were nodes in the list, must have been for arrays. It is surely a good
10939 idea to have a scalar version there if there's something to finalize. */
10940 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10941 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10942 " defined at %L, suggest also scalar one",
10943 derived->name, &derived->declared_at);
10945 /* TODO: Remove this error when finalization is finished. */
10946 gfc_error ("Finalization at %L is not yet implemented",
10947 &derived->declared_at);
10953 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10956 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10957 const char* generic_name, locus where)
10962 gcc_assert (t1->specific && t2->specific);
10963 gcc_assert (!t1->specific->is_generic);
10964 gcc_assert (!t2->specific->is_generic);
10966 sym1 = t1->specific->u.specific->n.sym;
10967 sym2 = t2->specific->u.specific->n.sym;
10972 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10973 if (sym1->attr.subroutine != sym2->attr.subroutine
10974 || sym1->attr.function != sym2->attr.function)
10976 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10977 " GENERIC '%s' at %L",
10978 sym1->name, sym2->name, generic_name, &where);
10982 /* Compare the interfaces. */
10983 if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
10985 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10986 sym1->name, sym2->name, generic_name, &where);
10994 /* Worker function for resolving a generic procedure binding; this is used to
10995 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10997 The difference between those cases is finding possible inherited bindings
10998 that are overridden, as one has to look for them in tb_sym_root,
10999 tb_uop_root or tb_op, respectively. Thus the caller must already find
11000 the super-type and set p->overridden correctly. */
11003 resolve_tb_generic_targets (gfc_symbol* super_type,
11004 gfc_typebound_proc* p, const char* name)
11006 gfc_tbp_generic* target;
11007 gfc_symtree* first_target;
11008 gfc_symtree* inherited;
11010 gcc_assert (p && p->is_generic);
11012 /* Try to find the specific bindings for the symtrees in our target-list. */
11013 gcc_assert (p->u.generic);
11014 for (target = p->u.generic; target; target = target->next)
11015 if (!target->specific)
11017 gfc_typebound_proc* overridden_tbp;
11018 gfc_tbp_generic* g;
11019 const char* target_name;
11021 target_name = target->specific_st->name;
11023 /* Defined for this type directly. */
11024 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
11026 target->specific = target->specific_st->n.tb;
11027 goto specific_found;
11030 /* Look for an inherited specific binding. */
11033 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
11038 gcc_assert (inherited->n.tb);
11039 target->specific = inherited->n.tb;
11040 goto specific_found;
11044 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11045 " at %L", target_name, name, &p->where);
11048 /* Once we've found the specific binding, check it is not ambiguous with
11049 other specifics already found or inherited for the same GENERIC. */
11051 gcc_assert (target->specific);
11053 /* This must really be a specific binding! */
11054 if (target->specific->is_generic)
11056 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11057 " '%s' is GENERIC, too", name, &p->where, target_name);
11061 /* Check those already resolved on this type directly. */
11062 for (g = p->u.generic; g; g = g->next)
11063 if (g != target && g->specific
11064 && check_generic_tbp_ambiguity (target, g, name, p->where)
11068 /* Check for ambiguity with inherited specific targets. */
11069 for (overridden_tbp = p->overridden; overridden_tbp;
11070 overridden_tbp = overridden_tbp->overridden)
11071 if (overridden_tbp->is_generic)
11073 for (g = overridden_tbp->u.generic; g; g = g->next)
11075 gcc_assert (g->specific);
11076 if (check_generic_tbp_ambiguity (target, g,
11077 name, p->where) == FAILURE)
11083 /* If we attempt to "overwrite" a specific binding, this is an error. */
11084 if (p->overridden && !p->overridden->is_generic)
11086 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11087 " the same name", name, &p->where);
11091 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11092 all must have the same attributes here. */
11093 first_target = p->u.generic->specific->u.specific;
11094 gcc_assert (first_target);
11095 p->subroutine = first_target->n.sym->attr.subroutine;
11096 p->function = first_target->n.sym->attr.function;
11102 /* Resolve a GENERIC procedure binding for a derived type. */
11105 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
11107 gfc_symbol* super_type;
11109 /* Find the overridden binding if any. */
11110 st->n.tb->overridden = NULL;
11111 super_type = gfc_get_derived_super_type (derived);
11114 gfc_symtree* overridden;
11115 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
11118 if (overridden && overridden->n.tb)
11119 st->n.tb->overridden = overridden->n.tb;
11122 /* Resolve using worker function. */
11123 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
11127 /* Retrieve the target-procedure of an operator binding and do some checks in
11128 common for intrinsic and user-defined type-bound operators. */
11131 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
11133 gfc_symbol* target_proc;
11135 gcc_assert (target->specific && !target->specific->is_generic);
11136 target_proc = target->specific->u.specific->n.sym;
11137 gcc_assert (target_proc);
11139 /* All operator bindings must have a passed-object dummy argument. */
11140 if (target->specific->nopass)
11142 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
11146 return target_proc;
11150 /* Resolve a type-bound intrinsic operator. */
11153 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
11154 gfc_typebound_proc* p)
11156 gfc_symbol* super_type;
11157 gfc_tbp_generic* target;
11159 /* If there's already an error here, do nothing (but don't fail again). */
11163 /* Operators should always be GENERIC bindings. */
11164 gcc_assert (p->is_generic);
11166 /* Look for an overridden binding. */
11167 super_type = gfc_get_derived_super_type (derived);
11168 if (super_type && super_type->f2k_derived)
11169 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
11172 p->overridden = NULL;
11174 /* Resolve general GENERIC properties using worker function. */
11175 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
11178 /* Check the targets to be procedures of correct interface. */
11179 for (target = p->u.generic; target; target = target->next)
11181 gfc_symbol* target_proc;
11183 target_proc = get_checked_tb_operator_target (target, p->where);
11187 if (!gfc_check_operator_interface (target_proc, op, p->where))
11199 /* Resolve a type-bound user operator (tree-walker callback). */
11201 static gfc_symbol* resolve_bindings_derived;
11202 static gfc_try resolve_bindings_result;
11204 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
11207 resolve_typebound_user_op (gfc_symtree* stree)
11209 gfc_symbol* super_type;
11210 gfc_tbp_generic* target;
11212 gcc_assert (stree && stree->n.tb);
11214 if (stree->n.tb->error)
11217 /* Operators should always be GENERIC bindings. */
11218 gcc_assert (stree->n.tb->is_generic);
11220 /* Find overridden procedure, if any. */
11221 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11222 if (super_type && super_type->f2k_derived)
11224 gfc_symtree* overridden;
11225 overridden = gfc_find_typebound_user_op (super_type, NULL,
11226 stree->name, true, NULL);
11228 if (overridden && overridden->n.tb)
11229 stree->n.tb->overridden = overridden->n.tb;
11232 stree->n.tb->overridden = NULL;
11234 /* Resolve basically using worker function. */
11235 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
11239 /* Check the targets to be functions of correct interface. */
11240 for (target = stree->n.tb->u.generic; target; target = target->next)
11242 gfc_symbol* target_proc;
11244 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
11248 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
11255 resolve_bindings_result = FAILURE;
11256 stree->n.tb->error = 1;
11260 /* Resolve the type-bound procedures for a derived type. */
11263 resolve_typebound_procedure (gfc_symtree* stree)
11267 gfc_symbol* me_arg;
11268 gfc_symbol* super_type;
11269 gfc_component* comp;
11271 gcc_assert (stree);
11273 /* Undefined specific symbol from GENERIC target definition. */
11277 if (stree->n.tb->error)
11280 /* If this is a GENERIC binding, use that routine. */
11281 if (stree->n.tb->is_generic)
11283 if (resolve_typebound_generic (resolve_bindings_derived, stree)
11289 /* Get the target-procedure to check it. */
11290 gcc_assert (!stree->n.tb->is_generic);
11291 gcc_assert (stree->n.tb->u.specific);
11292 proc = stree->n.tb->u.specific->n.sym;
11293 where = stree->n.tb->where;
11295 /* Default access should already be resolved from the parser. */
11296 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
11298 /* It should be a module procedure or an external procedure with explicit
11299 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
11300 if ((!proc->attr.subroutine && !proc->attr.function)
11301 || (proc->attr.proc != PROC_MODULE
11302 && proc->attr.if_source != IFSRC_IFBODY)
11303 || (proc->attr.abstract && !stree->n.tb->deferred))
11305 gfc_error ("'%s' must be a module procedure or an external procedure with"
11306 " an explicit interface at %L", proc->name, &where);
11309 stree->n.tb->subroutine = proc->attr.subroutine;
11310 stree->n.tb->function = proc->attr.function;
11312 /* Find the super-type of the current derived type. We could do this once and
11313 store in a global if speed is needed, but as long as not I believe this is
11314 more readable and clearer. */
11315 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11317 /* If PASS, resolve and check arguments if not already resolved / loaded
11318 from a .mod file. */
11319 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
11321 if (stree->n.tb->pass_arg)
11323 gfc_formal_arglist* i;
11325 /* If an explicit passing argument name is given, walk the arg-list
11326 and look for it. */
11329 stree->n.tb->pass_arg_num = 1;
11330 for (i = proc->formal; i; i = i->next)
11332 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
11337 ++stree->n.tb->pass_arg_num;
11342 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11344 proc->name, stree->n.tb->pass_arg, &where,
11345 stree->n.tb->pass_arg);
11351 /* Otherwise, take the first one; there should in fact be at least
11353 stree->n.tb->pass_arg_num = 1;
11356 gfc_error ("Procedure '%s' with PASS at %L must have at"
11357 " least one argument", proc->name, &where);
11360 me_arg = proc->formal->sym;
11363 /* Now check that the argument-type matches and the passed-object
11364 dummy argument is generally fine. */
11366 gcc_assert (me_arg);
11368 if (me_arg->ts.type != BT_CLASS)
11370 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11371 " at %L", proc->name, &where);
11375 if (CLASS_DATA (me_arg)->ts.u.derived
11376 != resolve_bindings_derived)
11378 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11379 " the derived-type '%s'", me_arg->name, proc->name,
11380 me_arg->name, &where, resolve_bindings_derived->name);
11384 gcc_assert (me_arg->ts.type == BT_CLASS);
11385 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
11387 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11388 " scalar", proc->name, &where);
11391 if (CLASS_DATA (me_arg)->attr.allocatable)
11393 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11394 " be ALLOCATABLE", proc->name, &where);
11397 if (CLASS_DATA (me_arg)->attr.class_pointer)
11399 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11400 " be POINTER", proc->name, &where);
11405 /* If we are extending some type, check that we don't override a procedure
11406 flagged NON_OVERRIDABLE. */
11407 stree->n.tb->overridden = NULL;
11410 gfc_symtree* overridden;
11411 overridden = gfc_find_typebound_proc (super_type, NULL,
11412 stree->name, true, NULL);
11416 if (overridden->n.tb)
11417 stree->n.tb->overridden = overridden->n.tb;
11419 if (gfc_check_typebound_override (stree, overridden) == FAILURE)
11424 /* See if there's a name collision with a component directly in this type. */
11425 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11426 if (!strcmp (comp->name, stree->name))
11428 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11430 stree->name, &where, resolve_bindings_derived->name);
11434 /* Try to find a name collision with an inherited component. */
11435 if (super_type && gfc_find_component (super_type, stree->name, true, true))
11437 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11438 " component of '%s'",
11439 stree->name, &where, resolve_bindings_derived->name);
11443 stree->n.tb->error = 0;
11447 resolve_bindings_result = FAILURE;
11448 stree->n.tb->error = 1;
11453 resolve_typebound_procedures (gfc_symbol* derived)
11456 gfc_symbol* super_type;
11458 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11461 super_type = gfc_get_derived_super_type (derived);
11463 resolve_typebound_procedures (super_type);
11465 resolve_bindings_derived = derived;
11466 resolve_bindings_result = SUCCESS;
11468 /* Make sure the vtab has been generated. */
11469 gfc_find_derived_vtab (derived);
11471 if (derived->f2k_derived->tb_sym_root)
11472 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11473 &resolve_typebound_procedure);
11475 if (derived->f2k_derived->tb_uop_root)
11476 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11477 &resolve_typebound_user_op);
11479 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11481 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11482 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11484 resolve_bindings_result = FAILURE;
11487 return resolve_bindings_result;
11491 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11492 to give all identical derived types the same backend_decl. */
11494 add_dt_to_dt_list (gfc_symbol *derived)
11496 gfc_dt_list *dt_list;
11498 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11499 if (derived == dt_list->derived)
11502 dt_list = gfc_get_dt_list ();
11503 dt_list->next = gfc_derived_types;
11504 dt_list->derived = derived;
11505 gfc_derived_types = dt_list;
11509 /* Ensure that a derived-type is really not abstract, meaning that every
11510 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11513 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11518 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11520 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11523 if (st->n.tb && st->n.tb->deferred)
11525 gfc_symtree* overriding;
11526 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11529 gcc_assert (overriding->n.tb);
11530 if (overriding->n.tb->deferred)
11532 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11533 " '%s' is DEFERRED and not overridden",
11534 sub->name, &sub->declared_at, st->name);
11543 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11545 /* The algorithm used here is to recursively travel up the ancestry of sub
11546 and for each ancestor-type, check all bindings. If any of them is
11547 DEFERRED, look it up starting from sub and see if the found (overriding)
11548 binding is not DEFERRED.
11549 This is not the most efficient way to do this, but it should be ok and is
11550 clearer than something sophisticated. */
11552 gcc_assert (ancestor && !sub->attr.abstract);
11554 if (!ancestor->attr.abstract)
11557 /* Walk bindings of this ancestor. */
11558 if (ancestor->f2k_derived)
11561 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11566 /* Find next ancestor type and recurse on it. */
11567 ancestor = gfc_get_derived_super_type (ancestor);
11569 return ensure_not_abstract (sub, ancestor);
11575 /* Resolve the components of a derived type. This does not have to wait until
11576 resolution stage, but can be done as soon as the dt declaration has been
11580 resolve_fl_derived0 (gfc_symbol *sym)
11582 gfc_symbol* super_type;
11585 super_type = gfc_get_derived_super_type (sym);
11588 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11590 gfc_error ("As extending type '%s' at %L has a coarray component, "
11591 "parent type '%s' shall also have one", sym->name,
11592 &sym->declared_at, super_type->name);
11596 /* Ensure the extended type gets resolved before we do. */
11597 if (super_type && resolve_fl_derived0 (super_type) == FAILURE)
11600 /* An ABSTRACT type must be extensible. */
11601 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11603 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11604 sym->name, &sym->declared_at);
11608 c = (sym->attr.is_class) ? sym->components->ts.u.derived->components
11611 for ( ; c != NULL; c = c->next)
11613 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
11614 if (c->ts.type == BT_CHARACTER && c->ts.deferred)
11616 gfc_error ("Deferred-length character component '%s' at %L is not "
11617 "yet supported", c->name, &c->loc);
11622 if ((!sym->attr.is_class || c != sym->components)
11623 && c->attr.codimension
11624 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11626 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11627 "deferred shape", c->name, &c->loc);
11632 if (c->attr.codimension && c->ts.type == BT_DERIVED
11633 && c->ts.u.derived->ts.is_iso_c)
11635 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11636 "shall not be a coarray", c->name, &c->loc);
11641 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11642 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11643 || c->attr.allocatable))
11645 gfc_error ("Component '%s' at %L with coarray component "
11646 "shall be a nonpointer, nonallocatable scalar",
11652 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11654 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11655 "is not an array pointer", c->name, &c->loc);
11659 if (c->attr.proc_pointer && c->ts.interface)
11661 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11662 gfc_error ("Interface '%s', used by procedure pointer component "
11663 "'%s' at %L, is declared in a later PROCEDURE statement",
11664 c->ts.interface->name, c->name, &c->loc);
11666 /* Get the attributes from the interface (now resolved). */
11667 if (c->ts.interface->attr.if_source
11668 || c->ts.interface->attr.intrinsic)
11670 gfc_symbol *ifc = c->ts.interface;
11672 if (ifc->formal && !ifc->formal_ns)
11673 resolve_symbol (ifc);
11675 if (ifc->attr.intrinsic)
11676 resolve_intrinsic (ifc, &ifc->declared_at);
11680 c->ts = ifc->result->ts;
11681 c->attr.allocatable = ifc->result->attr.allocatable;
11682 c->attr.pointer = ifc->result->attr.pointer;
11683 c->attr.dimension = ifc->result->attr.dimension;
11684 c->as = gfc_copy_array_spec (ifc->result->as);
11689 c->attr.allocatable = ifc->attr.allocatable;
11690 c->attr.pointer = ifc->attr.pointer;
11691 c->attr.dimension = ifc->attr.dimension;
11692 c->as = gfc_copy_array_spec (ifc->as);
11694 c->ts.interface = ifc;
11695 c->attr.function = ifc->attr.function;
11696 c->attr.subroutine = ifc->attr.subroutine;
11697 gfc_copy_formal_args_ppc (c, ifc);
11699 c->attr.pure = ifc->attr.pure;
11700 c->attr.elemental = ifc->attr.elemental;
11701 c->attr.recursive = ifc->attr.recursive;
11702 c->attr.always_explicit = ifc->attr.always_explicit;
11703 c->attr.ext_attr |= ifc->attr.ext_attr;
11704 /* Replace symbols in array spec. */
11708 for (i = 0; i < c->as->rank; i++)
11710 gfc_expr_replace_comp (c->as->lower[i], c);
11711 gfc_expr_replace_comp (c->as->upper[i], c);
11714 /* Copy char length. */
11715 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11717 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11718 gfc_expr_replace_comp (cl->length, c);
11719 if (cl->length && !cl->resolved
11720 && gfc_resolve_expr (cl->length) == FAILURE)
11725 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11727 gfc_error ("Interface '%s' of procedure pointer component "
11728 "'%s' at %L must be explicit", c->ts.interface->name,
11733 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11735 /* Since PPCs are not implicitly typed, a PPC without an explicit
11736 interface must be a subroutine. */
11737 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11740 /* Procedure pointer components: Check PASS arg. */
11741 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11742 && !sym->attr.vtype)
11744 gfc_symbol* me_arg;
11746 if (c->tb->pass_arg)
11748 gfc_formal_arglist* i;
11750 /* If an explicit passing argument name is given, walk the arg-list
11751 and look for it. */
11754 c->tb->pass_arg_num = 1;
11755 for (i = c->formal; i; i = i->next)
11757 if (!strcmp (i->sym->name, c->tb->pass_arg))
11762 c->tb->pass_arg_num++;
11767 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11768 "at %L has no argument '%s'", c->name,
11769 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11776 /* Otherwise, take the first one; there should in fact be at least
11778 c->tb->pass_arg_num = 1;
11781 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11782 "must have at least one argument",
11787 me_arg = c->formal->sym;
11790 /* Now check that the argument-type matches. */
11791 gcc_assert (me_arg);
11792 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11793 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11794 || (me_arg->ts.type == BT_CLASS
11795 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11797 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11798 " the derived type '%s'", me_arg->name, c->name,
11799 me_arg->name, &c->loc, sym->name);
11804 /* Check for C453. */
11805 if (me_arg->attr.dimension)
11807 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11808 "must be scalar", me_arg->name, c->name, me_arg->name,
11814 if (me_arg->attr.pointer)
11816 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11817 "may not have the POINTER attribute", me_arg->name,
11818 c->name, me_arg->name, &c->loc);
11823 if (me_arg->attr.allocatable)
11825 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11826 "may not be ALLOCATABLE", me_arg->name, c->name,
11827 me_arg->name, &c->loc);
11832 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11833 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11834 " at %L", c->name, &c->loc);
11838 /* Check type-spec if this is not the parent-type component. */
11839 if (((sym->attr.is_class
11840 && (!sym->components->ts.u.derived->attr.extension
11841 || c != sym->components->ts.u.derived->components))
11842 || (!sym->attr.is_class
11843 && (!sym->attr.extension || c != sym->components)))
11844 && !sym->attr.vtype
11845 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11848 /* If this type is an extension, set the accessibility of the parent
11851 && ((sym->attr.is_class
11852 && c == sym->components->ts.u.derived->components)
11853 || (!sym->attr.is_class && c == sym->components))
11854 && strcmp (super_type->name, c->name) == 0)
11855 c->attr.access = super_type->attr.access;
11857 /* If this type is an extension, see if this component has the same name
11858 as an inherited type-bound procedure. */
11859 if (super_type && !sym->attr.is_class
11860 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11862 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11863 " inherited type-bound procedure",
11864 c->name, sym->name, &c->loc);
11868 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
11869 && !c->ts.deferred)
11871 if (c->ts.u.cl->length == NULL
11872 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11873 || !gfc_is_constant_expr (c->ts.u.cl->length))
11875 gfc_error ("Character length of component '%s' needs to "
11876 "be a constant specification expression at %L",
11878 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11883 if (c->ts.type == BT_CHARACTER && c->ts.deferred
11884 && !c->attr.pointer && !c->attr.allocatable)
11886 gfc_error ("Character component '%s' of '%s' at %L with deferred "
11887 "length must be a POINTER or ALLOCATABLE",
11888 c->name, sym->name, &c->loc);
11892 if (c->ts.type == BT_DERIVED
11893 && sym->component_access != ACCESS_PRIVATE
11894 && gfc_check_symbol_access (sym)
11895 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11896 && !c->ts.u.derived->attr.use_assoc
11897 && !gfc_check_symbol_access (c->ts.u.derived)
11898 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11899 "is a PRIVATE type and cannot be a component of "
11900 "'%s', which is PUBLIC at %L", c->name,
11901 sym->name, &sym->declared_at) == FAILURE)
11904 if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
11906 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11907 "type %s", c->name, &c->loc, sym->name);
11911 if (sym->attr.sequence)
11913 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11915 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11916 "not have the SEQUENCE attribute",
11917 c->ts.u.derived->name, &sym->declared_at);
11922 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
11923 c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
11924 else if (c->ts.type == BT_CLASS && c->attr.class_ok
11925 && CLASS_DATA (c)->ts.u.derived->attr.generic)
11926 CLASS_DATA (c)->ts.u.derived
11927 = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
11929 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
11930 && c->attr.pointer && c->ts.u.derived->components == NULL
11931 && !c->ts.u.derived->attr.zero_comp)
11933 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11934 "that has not been declared", c->name, sym->name,
11939 if (c->ts.type == BT_CLASS && c->attr.class_ok
11940 && CLASS_DATA (c)->attr.class_pointer
11941 && CLASS_DATA (c)->ts.u.derived->components == NULL
11942 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11944 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11945 "that has not been declared", c->name, sym->name,
11951 if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE
11952 && (!c->attr.class_ok
11953 || !(CLASS_DATA (c)->attr.class_pointer
11954 || CLASS_DATA (c)->attr.allocatable)))
11956 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11957 "or pointer", c->name, &c->loc);
11961 /* Ensure that all the derived type components are put on the
11962 derived type list; even in formal namespaces, where derived type
11963 pointer components might not have been declared. */
11964 if (c->ts.type == BT_DERIVED
11966 && c->ts.u.derived->components
11968 && sym != c->ts.u.derived)
11969 add_dt_to_dt_list (c->ts.u.derived);
11971 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11972 || c->attr.proc_pointer
11973 || c->attr.allocatable)) == FAILURE)
11977 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11978 all DEFERRED bindings are overridden. */
11979 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11980 && !sym->attr.is_class
11981 && ensure_not_abstract (sym, super_type) == FAILURE)
11984 /* Add derived type to the derived type list. */
11985 add_dt_to_dt_list (sym);
11991 /* The following procedure does the full resolution of a derived type,
11992 including resolution of all type-bound procedures (if present). In contrast
11993 to 'resolve_fl_derived0' this can only be done after the module has been
11994 parsed completely. */
11997 resolve_fl_derived (gfc_symbol *sym)
11999 gfc_symbol *gen_dt = NULL;
12001 if (!sym->attr.is_class)
12002 gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
12003 if (gen_dt && gen_dt->generic && gen_dt->generic->next
12004 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Generic name '%s' of "
12005 "function '%s' at %L being the same name as derived "
12006 "type at %L", sym->name,
12007 gen_dt->generic->sym == sym
12008 ? gen_dt->generic->next->sym->name
12009 : gen_dt->generic->sym->name,
12010 gen_dt->generic->sym == sym
12011 ? &gen_dt->generic->next->sym->declared_at
12012 : &gen_dt->generic->sym->declared_at,
12013 &sym->declared_at) == FAILURE)
12016 if (sym->attr.is_class && sym->ts.u.derived == NULL)
12018 /* Fix up incomplete CLASS symbols. */
12019 gfc_component *data = gfc_find_component (sym, "_data", true, true);
12020 gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
12021 if (vptr->ts.u.derived == NULL)
12023 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
12025 vptr->ts.u.derived = vtab->ts.u.derived;
12029 if (resolve_fl_derived0 (sym) == FAILURE)
12032 /* Resolve the type-bound procedures. */
12033 if (resolve_typebound_procedures (sym) == FAILURE)
12036 /* Resolve the finalizer procedures. */
12037 if (gfc_resolve_finalizers (sym) == FAILURE)
12045 resolve_fl_namelist (gfc_symbol *sym)
12050 for (nl = sym->namelist; nl; nl = nl->next)
12052 /* Check again, the check in match only works if NAMELIST comes
12054 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
12056 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12057 "allowed", nl->sym->name, sym->name, &sym->declared_at);
12061 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
12062 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
12063 "object '%s' with assumed shape in namelist "
12064 "'%s' at %L", nl->sym->name, sym->name,
12065 &sym->declared_at) == FAILURE)
12068 if (is_non_constant_shape_array (nl->sym)
12069 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
12070 "object '%s' with nonconstant shape in namelist "
12071 "'%s' at %L", nl->sym->name, sym->name,
12072 &sym->declared_at) == FAILURE)
12075 if (nl->sym->ts.type == BT_CHARACTER
12076 && (nl->sym->ts.u.cl->length == NULL
12077 || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
12078 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
12079 "'%s' with nonconstant character length in "
12080 "namelist '%s' at %L", nl->sym->name, sym->name,
12081 &sym->declared_at) == FAILURE)
12084 /* FIXME: Once UDDTIO is implemented, the following can be
12086 if (nl->sym->ts.type == BT_CLASS)
12088 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12089 "polymorphic and requires a defined input/output "
12090 "procedure", nl->sym->name, sym->name, &sym->declared_at);
12094 if (nl->sym->ts.type == BT_DERIVED
12095 && (nl->sym->ts.u.derived->attr.alloc_comp
12096 || nl->sym->ts.u.derived->attr.pointer_comp))
12098 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
12099 "'%s' in namelist '%s' at %L with ALLOCATABLE "
12100 "or POINTER components", nl->sym->name,
12101 sym->name, &sym->declared_at) == FAILURE)
12104 /* FIXME: Once UDDTIO is implemented, the following can be
12106 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12107 "ALLOCATABLE or POINTER components and thus requires "
12108 "a defined input/output procedure", nl->sym->name,
12109 sym->name, &sym->declared_at);
12114 /* Reject PRIVATE objects in a PUBLIC namelist. */
12115 if (gfc_check_symbol_access (sym))
12117 for (nl = sym->namelist; nl; nl = nl->next)
12119 if (!nl->sym->attr.use_assoc
12120 && !is_sym_host_assoc (nl->sym, sym->ns)
12121 && !gfc_check_symbol_access (nl->sym))
12123 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12124 "cannot be member of PUBLIC namelist '%s' at %L",
12125 nl->sym->name, sym->name, &sym->declared_at);
12129 /* Types with private components that came here by USE-association. */
12130 if (nl->sym->ts.type == BT_DERIVED
12131 && derived_inaccessible (nl->sym->ts.u.derived))
12133 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12134 "components and cannot be member of namelist '%s' at %L",
12135 nl->sym->name, sym->name, &sym->declared_at);
12139 /* Types with private components that are defined in the same module. */
12140 if (nl->sym->ts.type == BT_DERIVED
12141 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
12142 && nl->sym->ts.u.derived->attr.private_comp)
12144 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12145 "cannot be a member of PUBLIC namelist '%s' at %L",
12146 nl->sym->name, sym->name, &sym->declared_at);
12153 /* 14.1.2 A module or internal procedure represent local entities
12154 of the same type as a namelist member and so are not allowed. */
12155 for (nl = sym->namelist; nl; nl = nl->next)
12157 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
12160 if (nl->sym->attr.function && nl->sym == nl->sym->result)
12161 if ((nl->sym == sym->ns->proc_name)
12163 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
12167 if (nl->sym && nl->sym->name)
12168 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
12169 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
12171 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12172 "attribute in '%s' at %L", nlsym->name,
12173 &sym->declared_at);
12183 resolve_fl_parameter (gfc_symbol *sym)
12185 /* A parameter array's shape needs to be constant. */
12186 if (sym->as != NULL
12187 && (sym->as->type == AS_DEFERRED
12188 || is_non_constant_shape_array (sym)))
12190 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12191 "or of deferred shape", sym->name, &sym->declared_at);
12195 /* Make sure a parameter that has been implicitly typed still
12196 matches the implicit type, since PARAMETER statements can precede
12197 IMPLICIT statements. */
12198 if (sym->attr.implicit_type
12199 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
12202 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12203 "later IMPLICIT type", sym->name, &sym->declared_at);
12207 /* Make sure the types of derived parameters are consistent. This
12208 type checking is deferred until resolution because the type may
12209 refer to a derived type from the host. */
12210 if (sym->ts.type == BT_DERIVED
12211 && !gfc_compare_types (&sym->ts, &sym->value->ts))
12213 gfc_error ("Incompatible derived type in PARAMETER at %L",
12214 &sym->value->where);
12221 /* Do anything necessary to resolve a symbol. Right now, we just
12222 assume that an otherwise unknown symbol is a variable. This sort
12223 of thing commonly happens for symbols in module. */
12226 resolve_symbol (gfc_symbol *sym)
12228 int check_constant, mp_flag;
12229 gfc_symtree *symtree;
12230 gfc_symtree *this_symtree;
12233 symbol_attribute class_attr;
12234 gfc_array_spec *as;
12236 if (sym->attr.flavor == FL_UNKNOWN)
12239 /* If we find that a flavorless symbol is an interface in one of the
12240 parent namespaces, find its symtree in this namespace, free the
12241 symbol and set the symtree to point to the interface symbol. */
12242 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
12244 symtree = gfc_find_symtree (ns->sym_root, sym->name);
12245 if (symtree && (symtree->n.sym->generic ||
12246 (symtree->n.sym->attr.flavor == FL_PROCEDURE
12247 && sym->ns->construct_entities)))
12249 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
12251 gfc_release_symbol (sym);
12252 symtree->n.sym->refs++;
12253 this_symtree->n.sym = symtree->n.sym;
12258 /* Otherwise give it a flavor according to such attributes as
12260 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
12261 sym->attr.flavor = FL_VARIABLE;
12264 sym->attr.flavor = FL_PROCEDURE;
12265 if (sym->attr.dimension)
12266 sym->attr.function = 1;
12270 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
12271 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
12273 if (sym->attr.procedure && sym->ts.interface
12274 && sym->attr.if_source != IFSRC_DECL
12275 && resolve_procedure_interface (sym) == FAILURE)
12278 if (sym->attr.is_protected && !sym->attr.proc_pointer
12279 && (sym->attr.procedure || sym->attr.external))
12281 if (sym->attr.external)
12282 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12283 "at %L", &sym->declared_at);
12285 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12286 "at %L", &sym->declared_at);
12291 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
12294 /* Symbols that are module procedures with results (functions) have
12295 the types and array specification copied for type checking in
12296 procedures that call them, as well as for saving to a module
12297 file. These symbols can't stand the scrutiny that their results
12299 mp_flag = (sym->result != NULL && sym->result != sym);
12301 /* Make sure that the intrinsic is consistent with its internal
12302 representation. This needs to be done before assigning a default
12303 type to avoid spurious warnings. */
12304 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
12305 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
12308 /* Resolve associate names. */
12310 resolve_assoc_var (sym, true);
12312 /* Assign default type to symbols that need one and don't have one. */
12313 if (sym->ts.type == BT_UNKNOWN)
12315 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
12317 gfc_set_default_type (sym, 1, NULL);
12320 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
12321 && !sym->attr.function && !sym->attr.subroutine
12322 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
12323 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
12325 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
12327 /* The specific case of an external procedure should emit an error
12328 in the case that there is no implicit type. */
12330 gfc_set_default_type (sym, sym->attr.external, NULL);
12333 /* Result may be in another namespace. */
12334 resolve_symbol (sym->result);
12336 if (!sym->result->attr.proc_pointer)
12338 sym->ts = sym->result->ts;
12339 sym->as = gfc_copy_array_spec (sym->result->as);
12340 sym->attr.dimension = sym->result->attr.dimension;
12341 sym->attr.pointer = sym->result->attr.pointer;
12342 sym->attr.allocatable = sym->result->attr.allocatable;
12343 sym->attr.contiguous = sym->result->attr.contiguous;
12348 else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
12349 gfc_resolve_array_spec (sym->result->as, false);
12351 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
12353 as = CLASS_DATA (sym)->as;
12354 class_attr = CLASS_DATA (sym)->attr;
12355 class_attr.pointer = class_attr.class_pointer;
12359 class_attr = sym->attr;
12364 if (sym->attr.contiguous
12365 && (!class_attr.dimension
12366 || (as->type != AS_ASSUMED_SHAPE && !class_attr.pointer)))
12368 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12369 "array pointer or an assumed-shape array", sym->name,
12370 &sym->declared_at);
12374 /* Assumed size arrays and assumed shape arrays must be dummy
12375 arguments. Array-spec's of implied-shape should have been resolved to
12376 AS_EXPLICIT already. */
12380 gcc_assert (as->type != AS_IMPLIED_SHAPE);
12381 if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
12382 || as->type == AS_ASSUMED_SHAPE)
12383 && sym->attr.dummy == 0)
12385 if (as->type == AS_ASSUMED_SIZE)
12386 gfc_error ("Assumed size array at %L must be a dummy argument",
12387 &sym->declared_at);
12389 gfc_error ("Assumed shape array at %L must be a dummy argument",
12390 &sym->declared_at);
12395 /* Make sure symbols with known intent or optional are really dummy
12396 variable. Because of ENTRY statement, this has to be deferred
12397 until resolution time. */
12399 if (!sym->attr.dummy
12400 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
12402 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
12406 if (sym->attr.value && !sym->attr.dummy)
12408 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12409 "it is not a dummy argument", sym->name, &sym->declared_at);
12413 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
12415 gfc_charlen *cl = sym->ts.u.cl;
12416 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
12418 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12419 "attribute must have constant length",
12420 sym->name, &sym->declared_at);
12424 if (sym->ts.is_c_interop
12425 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
12427 gfc_error ("C interoperable character dummy variable '%s' at %L "
12428 "with VALUE attribute must have length one",
12429 sym->name, &sym->declared_at);
12434 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
12435 && sym->ts.u.derived->attr.generic)
12437 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
12438 if (!sym->ts.u.derived)
12440 gfc_error ("The derived type '%s' at %L is of type '%s', "
12441 "which has not been defined", sym->name,
12442 &sym->declared_at, sym->ts.u.derived->name);
12443 sym->ts.type = BT_UNKNOWN;
12448 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12449 do this for something that was implicitly typed because that is handled
12450 in gfc_set_default_type. Handle dummy arguments and procedure
12451 definitions separately. Also, anything that is use associated is not
12452 handled here but instead is handled in the module it is declared in.
12453 Finally, derived type definitions are allowed to be BIND(C) since that
12454 only implies that they're interoperable, and they are checked fully for
12455 interoperability when a variable is declared of that type. */
12456 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
12457 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
12458 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
12460 gfc_try t = SUCCESS;
12462 /* First, make sure the variable is declared at the
12463 module-level scope (J3/04-007, Section 15.3). */
12464 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
12465 sym->attr.in_common == 0)
12467 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12468 "is neither a COMMON block nor declared at the "
12469 "module level scope", sym->name, &(sym->declared_at));
12472 else if (sym->common_head != NULL)
12474 t = verify_com_block_vars_c_interop (sym->common_head);
12478 /* If type() declaration, we need to verify that the components
12479 of the given type are all C interoperable, etc. */
12480 if (sym->ts.type == BT_DERIVED &&
12481 sym->ts.u.derived->attr.is_c_interop != 1)
12483 /* Make sure the user marked the derived type as BIND(C). If
12484 not, call the verify routine. This could print an error
12485 for the derived type more than once if multiple variables
12486 of that type are declared. */
12487 if (sym->ts.u.derived->attr.is_bind_c != 1)
12488 verify_bind_c_derived_type (sym->ts.u.derived);
12492 /* Verify the variable itself as C interoperable if it
12493 is BIND(C). It is not possible for this to succeed if
12494 the verify_bind_c_derived_type failed, so don't have to handle
12495 any error returned by verify_bind_c_derived_type. */
12496 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
12497 sym->common_block);
12502 /* clear the is_bind_c flag to prevent reporting errors more than
12503 once if something failed. */
12504 sym->attr.is_bind_c = 0;
12509 /* If a derived type symbol has reached this point, without its
12510 type being declared, we have an error. Notice that most
12511 conditions that produce undefined derived types have already
12512 been dealt with. However, the likes of:
12513 implicit type(t) (t) ..... call foo (t) will get us here if
12514 the type is not declared in the scope of the implicit
12515 statement. Change the type to BT_UNKNOWN, both because it is so
12516 and to prevent an ICE. */
12517 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
12518 && sym->ts.u.derived->components == NULL
12519 && !sym->ts.u.derived->attr.zero_comp)
12521 gfc_error ("The derived type '%s' at %L is of type '%s', "
12522 "which has not been defined", sym->name,
12523 &sym->declared_at, sym->ts.u.derived->name);
12524 sym->ts.type = BT_UNKNOWN;
12528 /* Make sure that the derived type has been resolved and that the
12529 derived type is visible in the symbol's namespace, if it is a
12530 module function and is not PRIVATE. */
12531 if (sym->ts.type == BT_DERIVED
12532 && sym->ts.u.derived->attr.use_assoc
12533 && sym->ns->proc_name
12534 && sym->ns->proc_name->attr.flavor == FL_MODULE
12535 && resolve_fl_derived (sym->ts.u.derived) == FAILURE)
12538 /* Unless the derived-type declaration is use associated, Fortran 95
12539 does not allow public entries of private derived types.
12540 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12541 161 in 95-006r3. */
12542 if (sym->ts.type == BT_DERIVED
12543 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12544 && !sym->ts.u.derived->attr.use_assoc
12545 && gfc_check_symbol_access (sym)
12546 && !gfc_check_symbol_access (sym->ts.u.derived)
12547 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12548 "of PRIVATE derived type '%s'",
12549 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12550 : "variable", sym->name, &sym->declared_at,
12551 sym->ts.u.derived->name) == FAILURE)
12554 /* F2008, C1302. */
12555 if (sym->ts.type == BT_DERIVED
12556 && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
12557 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
12558 || sym->ts.u.derived->attr.lock_comp)
12559 && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
12561 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
12562 "type LOCK_TYPE must be a coarray", sym->name,
12563 &sym->declared_at);
12567 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12568 default initialization is defined (5.1.2.4.4). */
12569 if (sym->ts.type == BT_DERIVED
12571 && sym->attr.intent == INTENT_OUT
12573 && sym->as->type == AS_ASSUMED_SIZE)
12575 for (c = sym->ts.u.derived->components; c; c = c->next)
12577 if (c->initializer)
12579 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12580 "ASSUMED SIZE and so cannot have a default initializer",
12581 sym->name, &sym->declared_at);
12588 if (sym->ts.type == BT_DERIVED && sym->attr.dummy
12589 && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
12591 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
12592 "INTENT(OUT)", sym->name, &sym->declared_at);
12597 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12598 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12599 && CLASS_DATA (sym)->attr.coarray_comp))
12600 || class_attr.codimension)
12601 && (sym->attr.result || sym->result == sym))
12603 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12604 "a coarray component", sym->name, &sym->declared_at);
12609 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12610 && sym->ts.u.derived->ts.is_iso_c)
12612 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12613 "shall not be a coarray", sym->name, &sym->declared_at);
12618 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12619 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12620 && CLASS_DATA (sym)->attr.coarray_comp))
12621 && (class_attr.codimension || class_attr.pointer || class_attr.dimension
12622 || class_attr.allocatable))
12624 gfc_error ("Variable '%s' at %L with coarray component "
12625 "shall be a nonpointer, nonallocatable scalar",
12626 sym->name, &sym->declared_at);
12630 /* F2008, C526. The function-result case was handled above. */
12631 if (class_attr.codimension
12632 && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
12633 || sym->attr.select_type_temporary
12634 || sym->ns->save_all
12635 || sym->ns->proc_name->attr.flavor == FL_MODULE
12636 || sym->ns->proc_name->attr.is_main_program
12637 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12639 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
12640 "nor a dummy argument", sym->name, &sym->declared_at);
12644 else if (class_attr.codimension && !sym->attr.select_type_temporary
12645 && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
12647 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12648 "deferred shape", sym->name, &sym->declared_at);
12651 else if (class_attr.codimension && class_attr.allocatable && as
12652 && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
12654 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12655 "deferred shape", sym->name, &sym->declared_at);
12660 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12661 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12662 && CLASS_DATA (sym)->attr.coarray_comp))
12663 || (class_attr.codimension && class_attr.allocatable))
12664 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12666 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12667 "allocatable coarray or have coarray components",
12668 sym->name, &sym->declared_at);
12672 if (class_attr.codimension && sym->attr.dummy
12673 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12675 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12676 "procedure '%s'", sym->name, &sym->declared_at,
12677 sym->ns->proc_name->name);
12681 switch (sym->attr.flavor)
12684 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12689 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12694 if (resolve_fl_namelist (sym) == FAILURE)
12699 if (resolve_fl_parameter (sym) == FAILURE)
12707 /* Resolve array specifier. Check as well some constraints
12708 on COMMON blocks. */
12710 check_constant = sym->attr.in_common && !sym->attr.pointer;
12712 /* Set the formal_arg_flag so that check_conflict will not throw
12713 an error for host associated variables in the specification
12714 expression for an array_valued function. */
12715 if (sym->attr.function && sym->as)
12716 formal_arg_flag = 1;
12718 gfc_resolve_array_spec (sym->as, check_constant);
12720 formal_arg_flag = 0;
12722 /* Resolve formal namespaces. */
12723 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12724 && !sym->attr.contained && !sym->attr.intrinsic)
12725 gfc_resolve (sym->formal_ns);
12727 /* Make sure the formal namespace is present. */
12728 if (sym->formal && !sym->formal_ns)
12730 gfc_formal_arglist *formal = sym->formal;
12731 while (formal && !formal->sym)
12732 formal = formal->next;
12736 sym->formal_ns = formal->sym->ns;
12737 sym->formal_ns->refs++;
12741 /* Check threadprivate restrictions. */
12742 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12743 && (!sym->attr.in_common
12744 && sym->module == NULL
12745 && (sym->ns->proc_name == NULL
12746 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12747 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12749 /* If we have come this far we can apply default-initializers, as
12750 described in 14.7.5, to those variables that have not already
12751 been assigned one. */
12752 if (sym->ts.type == BT_DERIVED
12753 && sym->ns == gfc_current_ns
12755 && !sym->attr.allocatable
12756 && !sym->attr.alloc_comp)
12758 symbol_attribute *a = &sym->attr;
12760 if ((!a->save && !a->dummy && !a->pointer
12761 && !a->in_common && !a->use_assoc
12762 && (a->referenced || a->result)
12763 && !(a->function && sym != sym->result))
12764 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12765 apply_default_init (sym);
12768 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
12769 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
12770 && !CLASS_DATA (sym)->attr.class_pointer
12771 && !CLASS_DATA (sym)->attr.allocatable)
12772 apply_default_init (sym);
12774 /* If this symbol has a type-spec, check it. */
12775 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12776 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12777 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12783 /************* Resolve DATA statements *************/
12787 gfc_data_value *vnode;
12793 /* Advance the values structure to point to the next value in the data list. */
12796 next_data_value (void)
12798 while (mpz_cmp_ui (values.left, 0) == 0)
12801 if (values.vnode->next == NULL)
12804 values.vnode = values.vnode->next;
12805 mpz_set (values.left, values.vnode->repeat);
12813 check_data_variable (gfc_data_variable *var, locus *where)
12819 ar_type mark = AR_UNKNOWN;
12821 mpz_t section_index[GFC_MAX_DIMENSIONS];
12827 if (gfc_resolve_expr (var->expr) == FAILURE)
12831 mpz_init_set_si (offset, 0);
12834 if (e->expr_type != EXPR_VARIABLE)
12835 gfc_internal_error ("check_data_variable(): Bad expression");
12837 sym = e->symtree->n.sym;
12839 if (sym->ns->is_block_data && !sym->attr.in_common)
12841 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12842 sym->name, &sym->declared_at);
12845 if (e->ref == NULL && sym->as)
12847 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12848 " declaration", sym->name, where);
12852 has_pointer = sym->attr.pointer;
12854 if (gfc_is_coindexed (e))
12856 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name,
12861 for (ref = e->ref; ref; ref = ref->next)
12863 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12867 && ref->type == REF_ARRAY
12868 && ref->u.ar.type != AR_FULL)
12870 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12871 "be a full array", sym->name, where);
12876 if (e->rank == 0 || has_pointer)
12878 mpz_init_set_ui (size, 1);
12885 /* Find the array section reference. */
12886 for (ref = e->ref; ref; ref = ref->next)
12888 if (ref->type != REF_ARRAY)
12890 if (ref->u.ar.type == AR_ELEMENT)
12896 /* Set marks according to the reference pattern. */
12897 switch (ref->u.ar.type)
12905 /* Get the start position of array section. */
12906 gfc_get_section_index (ar, section_index, &offset);
12911 gcc_unreachable ();
12914 if (gfc_array_size (e, &size) == FAILURE)
12916 gfc_error ("Nonconstant array section at %L in DATA statement",
12918 mpz_clear (offset);
12925 while (mpz_cmp_ui (size, 0) > 0)
12927 if (next_data_value () == FAILURE)
12929 gfc_error ("DATA statement at %L has more variables than values",
12935 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12939 /* If we have more than one element left in the repeat count,
12940 and we have more than one element left in the target variable,
12941 then create a range assignment. */
12942 /* FIXME: Only done for full arrays for now, since array sections
12944 if (mark == AR_FULL && ref && ref->next == NULL
12945 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12949 if (mpz_cmp (size, values.left) >= 0)
12951 mpz_init_set (range, values.left);
12952 mpz_sub (size, size, values.left);
12953 mpz_set_ui (values.left, 0);
12957 mpz_init_set (range, size);
12958 mpz_sub (values.left, values.left, size);
12959 mpz_set_ui (size, 0);
12962 t = gfc_assign_data_value (var->expr, values.vnode->expr,
12965 mpz_add (offset, offset, range);
12972 /* Assign initial value to symbol. */
12975 mpz_sub_ui (values.left, values.left, 1);
12976 mpz_sub_ui (size, size, 1);
12978 t = gfc_assign_data_value (var->expr, values.vnode->expr,
12983 if (mark == AR_FULL)
12984 mpz_add_ui (offset, offset, 1);
12986 /* Modify the array section indexes and recalculate the offset
12987 for next element. */
12988 else if (mark == AR_SECTION)
12989 gfc_advance_section (section_index, ar, &offset);
12993 if (mark == AR_SECTION)
12995 for (i = 0; i < ar->dimen; i++)
12996 mpz_clear (section_index[i]);
13000 mpz_clear (offset);
13006 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
13008 /* Iterate over a list of elements in a DATA statement. */
13011 traverse_data_list (gfc_data_variable *var, locus *where)
13014 iterator_stack frame;
13015 gfc_expr *e, *start, *end, *step;
13016 gfc_try retval = SUCCESS;
13018 mpz_init (frame.value);
13021 start = gfc_copy_expr (var->iter.start);
13022 end = gfc_copy_expr (var->iter.end);
13023 step = gfc_copy_expr (var->iter.step);
13025 if (gfc_simplify_expr (start, 1) == FAILURE
13026 || start->expr_type != EXPR_CONSTANT)
13028 gfc_error ("start of implied-do loop at %L could not be "
13029 "simplified to a constant value", &start->where);
13033 if (gfc_simplify_expr (end, 1) == FAILURE
13034 || end->expr_type != EXPR_CONSTANT)
13036 gfc_error ("end of implied-do loop at %L could not be "
13037 "simplified to a constant value", &start->where);
13041 if (gfc_simplify_expr (step, 1) == FAILURE
13042 || step->expr_type != EXPR_CONSTANT)
13044 gfc_error ("step of implied-do loop at %L could not be "
13045 "simplified to a constant value", &start->where);
13050 mpz_set (trip, end->value.integer);
13051 mpz_sub (trip, trip, start->value.integer);
13052 mpz_add (trip, trip, step->value.integer);
13054 mpz_div (trip, trip, step->value.integer);
13056 mpz_set (frame.value, start->value.integer);
13058 frame.prev = iter_stack;
13059 frame.variable = var->iter.var->symtree;
13060 iter_stack = &frame;
13062 while (mpz_cmp_ui (trip, 0) > 0)
13064 if (traverse_data_var (var->list, where) == FAILURE)
13070 e = gfc_copy_expr (var->expr);
13071 if (gfc_simplify_expr (e, 1) == FAILURE)
13078 mpz_add (frame.value, frame.value, step->value.integer);
13080 mpz_sub_ui (trip, trip, 1);
13084 mpz_clear (frame.value);
13087 gfc_free_expr (start);
13088 gfc_free_expr (end);
13089 gfc_free_expr (step);
13091 iter_stack = frame.prev;
13096 /* Type resolve variables in the variable list of a DATA statement. */
13099 traverse_data_var (gfc_data_variable *var, locus *where)
13103 for (; var; var = var->next)
13105 if (var->expr == NULL)
13106 t = traverse_data_list (var, where);
13108 t = check_data_variable (var, where);
13118 /* Resolve the expressions and iterators associated with a data statement.
13119 This is separate from the assignment checking because data lists should
13120 only be resolved once. */
13123 resolve_data_variables (gfc_data_variable *d)
13125 for (; d; d = d->next)
13127 if (d->list == NULL)
13129 if (gfc_resolve_expr (d->expr) == FAILURE)
13134 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
13137 if (resolve_data_variables (d->list) == FAILURE)
13146 /* Resolve a single DATA statement. We implement this by storing a pointer to
13147 the value list into static variables, and then recursively traversing the
13148 variables list, expanding iterators and such. */
13151 resolve_data (gfc_data *d)
13154 if (resolve_data_variables (d->var) == FAILURE)
13157 values.vnode = d->value;
13158 if (d->value == NULL)
13159 mpz_set_ui (values.left, 0);
13161 mpz_set (values.left, d->value->repeat);
13163 if (traverse_data_var (d->var, &d->where) == FAILURE)
13166 /* At this point, we better not have any values left. */
13168 if (next_data_value () == SUCCESS)
13169 gfc_error ("DATA statement at %L has more values than variables",
13174 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13175 accessed by host or use association, is a dummy argument to a pure function,
13176 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13177 is storage associated with any such variable, shall not be used in the
13178 following contexts: (clients of this function). */
13180 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13181 procedure. Returns zero if assignment is OK, nonzero if there is a
13184 gfc_impure_variable (gfc_symbol *sym)
13189 if (sym->attr.use_assoc || sym->attr.in_common)
13192 /* Check if the symbol's ns is inside the pure procedure. */
13193 for (ns = gfc_current_ns; ns; ns = ns->parent)
13197 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
13201 proc = sym->ns->proc_name;
13202 if (sym->attr.dummy && gfc_pure (proc)
13203 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
13205 proc->attr.function))
13208 /* TODO: Sort out what can be storage associated, if anything, and include
13209 it here. In principle equivalences should be scanned but it does not
13210 seem to be possible to storage associate an impure variable this way. */
13215 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13216 current namespace is inside a pure procedure. */
13219 gfc_pure (gfc_symbol *sym)
13221 symbol_attribute attr;
13226 /* Check if the current namespace or one of its parents
13227 belongs to a pure procedure. */
13228 for (ns = gfc_current_ns; ns; ns = ns->parent)
13230 sym = ns->proc_name;
13234 if (attr.flavor == FL_PROCEDURE && attr.pure)
13242 return attr.flavor == FL_PROCEDURE && attr.pure;
13246 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13247 checks if the current namespace is implicitly pure. Note that this
13248 function returns false for a PURE procedure. */
13251 gfc_implicit_pure (gfc_symbol *sym)
13257 /* Check if the current procedure is implicit_pure. Walk up
13258 the procedure list until we find a procedure. */
13259 for (ns = gfc_current_ns; ns; ns = ns->parent)
13261 sym = ns->proc_name;
13265 if (sym->attr.flavor == FL_PROCEDURE)
13270 return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
13271 && !sym->attr.pure;
13275 /* Test whether the current procedure is elemental or not. */
13278 gfc_elemental (gfc_symbol *sym)
13280 symbol_attribute attr;
13283 sym = gfc_current_ns->proc_name;
13288 return attr.flavor == FL_PROCEDURE && attr.elemental;
13292 /* Warn about unused labels. */
13295 warn_unused_fortran_label (gfc_st_label *label)
13300 warn_unused_fortran_label (label->left);
13302 if (label->defined == ST_LABEL_UNKNOWN)
13305 switch (label->referenced)
13307 case ST_LABEL_UNKNOWN:
13308 gfc_warning ("Label %d at %L defined but not used", label->value,
13312 case ST_LABEL_BAD_TARGET:
13313 gfc_warning ("Label %d at %L defined but cannot be used",
13314 label->value, &label->where);
13321 warn_unused_fortran_label (label->right);
13325 /* Returns the sequence type of a symbol or sequence. */
13328 sequence_type (gfc_typespec ts)
13337 if (ts.u.derived->components == NULL)
13338 return SEQ_NONDEFAULT;
13340 result = sequence_type (ts.u.derived->components->ts);
13341 for (c = ts.u.derived->components->next; c; c = c->next)
13342 if (sequence_type (c->ts) != result)
13348 if (ts.kind != gfc_default_character_kind)
13349 return SEQ_NONDEFAULT;
13351 return SEQ_CHARACTER;
13354 if (ts.kind != gfc_default_integer_kind)
13355 return SEQ_NONDEFAULT;
13357 return SEQ_NUMERIC;
13360 if (!(ts.kind == gfc_default_real_kind
13361 || ts.kind == gfc_default_double_kind))
13362 return SEQ_NONDEFAULT;
13364 return SEQ_NUMERIC;
13367 if (ts.kind != gfc_default_complex_kind)
13368 return SEQ_NONDEFAULT;
13370 return SEQ_NUMERIC;
13373 if (ts.kind != gfc_default_logical_kind)
13374 return SEQ_NONDEFAULT;
13376 return SEQ_NUMERIC;
13379 return SEQ_NONDEFAULT;
13384 /* Resolve derived type EQUIVALENCE object. */
13387 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
13389 gfc_component *c = derived->components;
13394 /* Shall not be an object of nonsequence derived type. */
13395 if (!derived->attr.sequence)
13397 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13398 "attribute to be an EQUIVALENCE object", sym->name,
13403 /* Shall not have allocatable components. */
13404 if (derived->attr.alloc_comp)
13406 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13407 "components to be an EQUIVALENCE object",sym->name,
13412 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
13414 gfc_error ("Derived type variable '%s' at %L with default "
13415 "initialization cannot be in EQUIVALENCE with a variable "
13416 "in COMMON", sym->name, &e->where);
13420 for (; c ; c = c->next)
13422 if (c->ts.type == BT_DERIVED
13423 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
13426 /* Shall not be an object of sequence derived type containing a pointer
13427 in the structure. */
13428 if (c->attr.pointer)
13430 gfc_error ("Derived type variable '%s' at %L with pointer "
13431 "component(s) cannot be an EQUIVALENCE object",
13432 sym->name, &e->where);
13440 /* Resolve equivalence object.
13441 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13442 an allocatable array, an object of nonsequence derived type, an object of
13443 sequence derived type containing a pointer at any level of component
13444 selection, an automatic object, a function name, an entry name, a result
13445 name, a named constant, a structure component, or a subobject of any of
13446 the preceding objects. A substring shall not have length zero. A
13447 derived type shall not have components with default initialization nor
13448 shall two objects of an equivalence group be initialized.
13449 Either all or none of the objects shall have an protected attribute.
13450 The simple constraints are done in symbol.c(check_conflict) and the rest
13451 are implemented here. */
13454 resolve_equivalence (gfc_equiv *eq)
13457 gfc_symbol *first_sym;
13460 locus *last_where = NULL;
13461 seq_type eq_type, last_eq_type;
13462 gfc_typespec *last_ts;
13463 int object, cnt_protected;
13466 last_ts = &eq->expr->symtree->n.sym->ts;
13468 first_sym = eq->expr->symtree->n.sym;
13472 for (object = 1; eq; eq = eq->eq, object++)
13476 e->ts = e->symtree->n.sym->ts;
13477 /* match_varspec might not know yet if it is seeing
13478 array reference or substring reference, as it doesn't
13480 if (e->ref && e->ref->type == REF_ARRAY)
13482 gfc_ref *ref = e->ref;
13483 sym = e->symtree->n.sym;
13485 if (sym->attr.dimension)
13487 ref->u.ar.as = sym->as;
13491 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13492 if (e->ts.type == BT_CHARACTER
13494 && ref->type == REF_ARRAY
13495 && ref->u.ar.dimen == 1
13496 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
13497 && ref->u.ar.stride[0] == NULL)
13499 gfc_expr *start = ref->u.ar.start[0];
13500 gfc_expr *end = ref->u.ar.end[0];
13503 /* Optimize away the (:) reference. */
13504 if (start == NULL && end == NULL)
13507 e->ref = ref->next;
13509 e->ref->next = ref->next;
13514 ref->type = REF_SUBSTRING;
13516 start = gfc_get_int_expr (gfc_default_integer_kind,
13518 ref->u.ss.start = start;
13519 if (end == NULL && e->ts.u.cl)
13520 end = gfc_copy_expr (e->ts.u.cl->length);
13521 ref->u.ss.end = end;
13522 ref->u.ss.length = e->ts.u.cl;
13529 /* Any further ref is an error. */
13532 gcc_assert (ref->type == REF_ARRAY);
13533 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13539 if (gfc_resolve_expr (e) == FAILURE)
13542 sym = e->symtree->n.sym;
13544 if (sym->attr.is_protected)
13546 if (cnt_protected > 0 && cnt_protected != object)
13548 gfc_error ("Either all or none of the objects in the "
13549 "EQUIVALENCE set at %L shall have the "
13550 "PROTECTED attribute",
13555 /* Shall not equivalence common block variables in a PURE procedure. */
13556 if (sym->ns->proc_name
13557 && sym->ns->proc_name->attr.pure
13558 && sym->attr.in_common)
13560 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13561 "object in the pure procedure '%s'",
13562 sym->name, &e->where, sym->ns->proc_name->name);
13566 /* Shall not be a named constant. */
13567 if (e->expr_type == EXPR_CONSTANT)
13569 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13570 "object", sym->name, &e->where);
13574 if (e->ts.type == BT_DERIVED
13575 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
13578 /* Check that the types correspond correctly:
13580 A numeric sequence structure may be equivalenced to another sequence
13581 structure, an object of default integer type, default real type, double
13582 precision real type, default logical type such that components of the
13583 structure ultimately only become associated to objects of the same
13584 kind. A character sequence structure may be equivalenced to an object
13585 of default character kind or another character sequence structure.
13586 Other objects may be equivalenced only to objects of the same type and
13587 kind parameters. */
13589 /* Identical types are unconditionally OK. */
13590 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
13591 goto identical_types;
13593 last_eq_type = sequence_type (*last_ts);
13594 eq_type = sequence_type (sym->ts);
13596 /* Since the pair of objects is not of the same type, mixed or
13597 non-default sequences can be rejected. */
13599 msg = "Sequence %s with mixed components in EQUIVALENCE "
13600 "statement at %L with different type objects";
13602 && last_eq_type == SEQ_MIXED
13603 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
13605 || (eq_type == SEQ_MIXED
13606 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13607 &e->where) == FAILURE))
13610 msg = "Non-default type object or sequence %s in EQUIVALENCE "
13611 "statement at %L with objects of different type";
13613 && last_eq_type == SEQ_NONDEFAULT
13614 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
13615 last_where) == FAILURE)
13616 || (eq_type == SEQ_NONDEFAULT
13617 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13618 &e->where) == FAILURE))
13621 msg ="Non-CHARACTER object '%s' in default CHARACTER "
13622 "EQUIVALENCE statement at %L";
13623 if (last_eq_type == SEQ_CHARACTER
13624 && eq_type != SEQ_CHARACTER
13625 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13626 &e->where) == FAILURE)
13629 msg ="Non-NUMERIC object '%s' in default NUMERIC "
13630 "EQUIVALENCE statement at %L";
13631 if (last_eq_type == SEQ_NUMERIC
13632 && eq_type != SEQ_NUMERIC
13633 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13634 &e->where) == FAILURE)
13639 last_where = &e->where;
13644 /* Shall not be an automatic array. */
13645 if (e->ref->type == REF_ARRAY
13646 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
13648 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13649 "an EQUIVALENCE object", sym->name, &e->where);
13656 /* Shall not be a structure component. */
13657 if (r->type == REF_COMPONENT)
13659 gfc_error ("Structure component '%s' at %L cannot be an "
13660 "EQUIVALENCE object",
13661 r->u.c.component->name, &e->where);
13665 /* A substring shall not have length zero. */
13666 if (r->type == REF_SUBSTRING)
13668 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13670 gfc_error ("Substring at %L has length zero",
13671 &r->u.ss.start->where);
13681 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13684 resolve_fntype (gfc_namespace *ns)
13686 gfc_entry_list *el;
13689 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13692 /* If there are any entries, ns->proc_name is the entry master
13693 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13695 sym = ns->entries->sym;
13697 sym = ns->proc_name;
13698 if (sym->result == sym
13699 && sym->ts.type == BT_UNKNOWN
13700 && gfc_set_default_type (sym, 0, NULL) == FAILURE
13701 && !sym->attr.untyped)
13703 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13704 sym->name, &sym->declared_at);
13705 sym->attr.untyped = 1;
13708 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13709 && !sym->attr.contained
13710 && !gfc_check_symbol_access (sym->ts.u.derived)
13711 && gfc_check_symbol_access (sym))
13713 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13714 "%L of PRIVATE type '%s'", sym->name,
13715 &sym->declared_at, sym->ts.u.derived->name);
13719 for (el = ns->entries->next; el; el = el->next)
13721 if (el->sym->result == el->sym
13722 && el->sym->ts.type == BT_UNKNOWN
13723 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13724 && !el->sym->attr.untyped)
13726 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13727 el->sym->name, &el->sym->declared_at);
13728 el->sym->attr.untyped = 1;
13734 /* 12.3.2.1.1 Defined operators. */
13737 check_uop_procedure (gfc_symbol *sym, locus where)
13739 gfc_formal_arglist *formal;
13741 if (!sym->attr.function)
13743 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13744 sym->name, &where);
13748 if (sym->ts.type == BT_CHARACTER
13749 && !(sym->ts.u.cl && sym->ts.u.cl->length)
13750 && !(sym->result && sym->result->ts.u.cl
13751 && sym->result->ts.u.cl->length))
13753 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13754 "character length", sym->name, &where);
13758 formal = sym->formal;
13759 if (!formal || !formal->sym)
13761 gfc_error ("User operator procedure '%s' at %L must have at least "
13762 "one argument", sym->name, &where);
13766 if (formal->sym->attr.intent != INTENT_IN)
13768 gfc_error ("First argument of operator interface at %L must be "
13769 "INTENT(IN)", &where);
13773 if (formal->sym->attr.optional)
13775 gfc_error ("First argument of operator interface at %L cannot be "
13776 "optional", &where);
13780 formal = formal->next;
13781 if (!formal || !formal->sym)
13784 if (formal->sym->attr.intent != INTENT_IN)
13786 gfc_error ("Second argument of operator interface at %L must be "
13787 "INTENT(IN)", &where);
13791 if (formal->sym->attr.optional)
13793 gfc_error ("Second argument of operator interface at %L cannot be "
13794 "optional", &where);
13800 gfc_error ("Operator interface at %L must have, at most, two "
13801 "arguments", &where);
13809 gfc_resolve_uops (gfc_symtree *symtree)
13811 gfc_interface *itr;
13813 if (symtree == NULL)
13816 gfc_resolve_uops (symtree->left);
13817 gfc_resolve_uops (symtree->right);
13819 for (itr = symtree->n.uop->op; itr; itr = itr->next)
13820 check_uop_procedure (itr->sym, itr->sym->declared_at);
13824 /* Examine all of the expressions associated with a program unit,
13825 assign types to all intermediate expressions, make sure that all
13826 assignments are to compatible types and figure out which names
13827 refer to which functions or subroutines. It doesn't check code
13828 block, which is handled by resolve_code. */
13831 resolve_types (gfc_namespace *ns)
13837 gfc_namespace* old_ns = gfc_current_ns;
13839 /* Check that all IMPLICIT types are ok. */
13840 if (!ns->seen_implicit_none)
13843 for (letter = 0; letter != GFC_LETTERS; ++letter)
13844 if (ns->set_flag[letter]
13845 && resolve_typespec_used (&ns->default_type[letter],
13846 &ns->implicit_loc[letter],
13851 gfc_current_ns = ns;
13853 resolve_entries (ns);
13855 resolve_common_vars (ns->blank_common.head, false);
13856 resolve_common_blocks (ns->common_root);
13858 resolve_contained_functions (ns);
13860 if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
13861 && ns->proc_name->attr.if_source == IFSRC_IFBODY)
13862 resolve_formal_arglist (ns->proc_name);
13864 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13866 for (cl = ns->cl_list; cl; cl = cl->next)
13867 resolve_charlen (cl);
13869 gfc_traverse_ns (ns, resolve_symbol);
13871 resolve_fntype (ns);
13873 for (n = ns->contained; n; n = n->sibling)
13875 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13876 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13877 "also be PURE", n->proc_name->name,
13878 &n->proc_name->declared_at);
13884 do_concurrent_flag = 0;
13885 gfc_check_interfaces (ns);
13887 gfc_traverse_ns (ns, resolve_values);
13893 for (d = ns->data; d; d = d->next)
13897 gfc_traverse_ns (ns, gfc_formalize_init_value);
13899 gfc_traverse_ns (ns, gfc_verify_binding_labels);
13901 if (ns->common_root != NULL)
13902 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13904 for (eq = ns->equiv; eq; eq = eq->next)
13905 resolve_equivalence (eq);
13907 /* Warn about unused labels. */
13908 if (warn_unused_label)
13909 warn_unused_fortran_label (ns->st_labels);
13911 gfc_resolve_uops (ns->uop_root);
13913 gfc_current_ns = old_ns;
13917 /* Call resolve_code recursively. */
13920 resolve_codes (gfc_namespace *ns)
13923 bitmap_obstack old_obstack;
13925 if (ns->resolved == 1)
13928 for (n = ns->contained; n; n = n->sibling)
13931 gfc_current_ns = ns;
13933 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13934 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13937 /* Set to an out of range value. */
13938 current_entry_id = -1;
13940 old_obstack = labels_obstack;
13941 bitmap_obstack_initialize (&labels_obstack);
13943 resolve_code (ns->code, ns);
13945 bitmap_obstack_release (&labels_obstack);
13946 labels_obstack = old_obstack;
13950 /* This function is called after a complete program unit has been compiled.
13951 Its purpose is to examine all of the expressions associated with a program
13952 unit, assign types to all intermediate expressions, make sure that all
13953 assignments are to compatible types and figure out which names refer to
13954 which functions or subroutines. */
13957 gfc_resolve (gfc_namespace *ns)
13959 gfc_namespace *old_ns;
13960 code_stack *old_cs_base;
13966 old_ns = gfc_current_ns;
13967 old_cs_base = cs_base;
13969 resolve_types (ns);
13970 resolve_codes (ns);
13972 gfc_current_ns = old_ns;
13973 cs_base = old_cs_base;
13976 gfc_run_passes (ns);