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)
1760 e->rank = sym->as->rank;
1761 e->ref = gfc_get_ref ();
1762 e->ref->type = REF_ARRAY;
1763 e->ref->u.ar.type = AR_FULL;
1764 e->ref->u.ar.as = sym->as;
1767 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1768 primary.c (match_actual_arg). If above code determines that it
1769 is a variable instead, it needs to be resolved as it was not
1770 done at the beginning of this function. */
1771 save_need_full_assumed_size = need_full_assumed_size;
1772 if (e->expr_type != EXPR_VARIABLE)
1773 need_full_assumed_size = 0;
1774 if (gfc_resolve_expr (e) != SUCCESS)
1776 need_full_assumed_size = save_need_full_assumed_size;
1779 /* Check argument list functions %VAL, %LOC and %REF. There is
1780 nothing to do for %REF. */
1781 if (arg->name && arg->name[0] == '%')
1783 if (strncmp ("%VAL", arg->name, 4) == 0)
1785 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1787 gfc_error ("By-value argument at %L is not of numeric "
1794 gfc_error ("By-value argument at %L cannot be an array or "
1795 "an array section", &e->where);
1799 /* Intrinsics are still PROC_UNKNOWN here. However,
1800 since same file external procedures are not resolvable
1801 in gfortran, it is a good deal easier to leave them to
1803 if (ptype != PROC_UNKNOWN
1804 && ptype != PROC_DUMMY
1805 && ptype != PROC_EXTERNAL
1806 && ptype != PROC_MODULE)
1808 gfc_error ("By-value argument at %L is not allowed "
1809 "in this context", &e->where);
1814 /* Statement functions have already been excluded above. */
1815 else if (strncmp ("%LOC", arg->name, 4) == 0
1816 && e->ts.type == BT_PROCEDURE)
1818 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1820 gfc_error ("Passing internal procedure at %L by location "
1821 "not allowed", &e->where);
1827 /* Fortran 2008, C1237. */
1828 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1829 && gfc_has_ultimate_pointer (e))
1831 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1832 "component", &e->where);
1841 /* Do the checks of the actual argument list that are specific to elemental
1842 procedures. If called with c == NULL, we have a function, otherwise if
1843 expr == NULL, we have a subroutine. */
1846 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1848 gfc_actual_arglist *arg0;
1849 gfc_actual_arglist *arg;
1850 gfc_symbol *esym = NULL;
1851 gfc_intrinsic_sym *isym = NULL;
1853 gfc_intrinsic_arg *iformal = NULL;
1854 gfc_formal_arglist *eformal = NULL;
1855 bool formal_optional = false;
1856 bool set_by_optional = false;
1860 /* Is this an elemental procedure? */
1861 if (expr && expr->value.function.actual != NULL)
1863 if (expr->value.function.esym != NULL
1864 && expr->value.function.esym->attr.elemental)
1866 arg0 = expr->value.function.actual;
1867 esym = expr->value.function.esym;
1869 else if (expr->value.function.isym != NULL
1870 && expr->value.function.isym->elemental)
1872 arg0 = expr->value.function.actual;
1873 isym = expr->value.function.isym;
1878 else if (c && c->ext.actual != NULL)
1880 arg0 = c->ext.actual;
1882 if (c->resolved_sym)
1883 esym = c->resolved_sym;
1885 esym = c->symtree->n.sym;
1888 if (!esym->attr.elemental)
1894 /* The rank of an elemental is the rank of its array argument(s). */
1895 for (arg = arg0; arg; arg = arg->next)
1897 if (arg->expr != NULL && arg->expr->rank > 0)
1899 rank = arg->expr->rank;
1900 if (arg->expr->expr_type == EXPR_VARIABLE
1901 && arg->expr->symtree->n.sym->attr.optional)
1902 set_by_optional = true;
1904 /* Function specific; set the result rank and shape. */
1908 if (!expr->shape && arg->expr->shape)
1910 expr->shape = gfc_get_shape (rank);
1911 for (i = 0; i < rank; i++)
1912 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1919 /* If it is an array, it shall not be supplied as an actual argument
1920 to an elemental procedure unless an array of the same rank is supplied
1921 as an actual argument corresponding to a nonoptional dummy argument of
1922 that elemental procedure(12.4.1.5). */
1923 formal_optional = false;
1925 iformal = isym->formal;
1927 eformal = esym->formal;
1929 for (arg = arg0; arg; arg = arg->next)
1933 if (eformal->sym && eformal->sym->attr.optional)
1934 formal_optional = true;
1935 eformal = eformal->next;
1937 else if (isym && iformal)
1939 if (iformal->optional)
1940 formal_optional = true;
1941 iformal = iformal->next;
1944 formal_optional = true;
1946 if (pedantic && arg->expr != NULL
1947 && arg->expr->expr_type == EXPR_VARIABLE
1948 && arg->expr->symtree->n.sym->attr.optional
1951 && (set_by_optional || arg->expr->rank != rank)
1952 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1954 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1955 "MISSING, it cannot be the actual argument of an "
1956 "ELEMENTAL procedure unless there is a non-optional "
1957 "argument with the same rank (12.4.1.5)",
1958 arg->expr->symtree->n.sym->name, &arg->expr->where);
1963 for (arg = arg0; arg; arg = arg->next)
1965 if (arg->expr == NULL || arg->expr->rank == 0)
1968 /* Being elemental, the last upper bound of an assumed size array
1969 argument must be present. */
1970 if (resolve_assumed_size_actual (arg->expr))
1973 /* Elemental procedure's array actual arguments must conform. */
1976 if (gfc_check_conformance (arg->expr, e,
1977 "elemental procedure") == FAILURE)
1984 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1985 is an array, the intent inout/out variable needs to be also an array. */
1986 if (rank > 0 && esym && expr == NULL)
1987 for (eformal = esym->formal, arg = arg0; arg && eformal;
1988 arg = arg->next, eformal = eformal->next)
1989 if ((eformal->sym->attr.intent == INTENT_OUT
1990 || eformal->sym->attr.intent == INTENT_INOUT)
1991 && arg->expr && arg->expr->rank == 0)
1993 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1994 "ELEMENTAL subroutine '%s' is a scalar, but another "
1995 "actual argument is an array", &arg->expr->where,
1996 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1997 : "INOUT", eformal->sym->name, esym->name);
2004 /* This function does the checking of references to global procedures
2005 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2006 77 and 95 standards. It checks for a gsymbol for the name, making
2007 one if it does not already exist. If it already exists, then the
2008 reference being resolved must correspond to the type of gsymbol.
2009 Otherwise, the new symbol is equipped with the attributes of the
2010 reference. The corresponding code that is called in creating
2011 global entities is parse.c.
2013 In addition, for all but -std=legacy, the gsymbols are used to
2014 check the interfaces of external procedures from the same file.
2015 The namespace of the gsymbol is resolved and then, once this is
2016 done the interface is checked. */
2020 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2022 if (!gsym_ns->proc_name->attr.recursive)
2025 if (sym->ns == gsym_ns)
2028 if (sym->ns->parent && sym->ns->parent == gsym_ns)
2035 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
2037 if (gsym_ns->entries)
2039 gfc_entry_list *entry = gsym_ns->entries;
2041 for (; entry; entry = entry->next)
2043 if (strcmp (sym->name, entry->sym->name) == 0)
2045 if (strcmp (gsym_ns->proc_name->name,
2046 sym->ns->proc_name->name) == 0)
2050 && strcmp (gsym_ns->proc_name->name,
2051 sym->ns->parent->proc_name->name) == 0)
2060 resolve_global_procedure (gfc_symbol *sym, locus *where,
2061 gfc_actual_arglist **actual, int sub)
2065 enum gfc_symbol_type type;
2067 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2069 gsym = gfc_get_gsymbol (sym->name);
2071 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2072 gfc_global_used (gsym, where);
2074 if (gfc_option.flag_whole_file
2075 && (sym->attr.if_source == IFSRC_UNKNOWN
2076 || sym->attr.if_source == IFSRC_IFBODY)
2077 && gsym->type != GSYM_UNKNOWN
2079 && gsym->ns->resolved != -1
2080 && gsym->ns->proc_name
2081 && not_in_recursive (sym, gsym->ns)
2082 && not_entry_self_reference (sym, gsym->ns))
2084 gfc_symbol *def_sym;
2086 /* Resolve the gsymbol namespace if needed. */
2087 if (!gsym->ns->resolved)
2089 gfc_dt_list *old_dt_list;
2090 struct gfc_omp_saved_state old_omp_state;
2092 /* Stash away derived types so that the backend_decls do not
2094 old_dt_list = gfc_derived_types;
2095 gfc_derived_types = NULL;
2096 /* And stash away openmp state. */
2097 gfc_omp_save_and_clear_state (&old_omp_state);
2099 gfc_resolve (gsym->ns);
2101 /* Store the new derived types with the global namespace. */
2102 if (gfc_derived_types)
2103 gsym->ns->derived_types = gfc_derived_types;
2105 /* Restore the derived types of this namespace. */
2106 gfc_derived_types = old_dt_list;
2107 /* And openmp state. */
2108 gfc_omp_restore_state (&old_omp_state);
2111 /* Make sure that translation for the gsymbol occurs before
2112 the procedure currently being resolved. */
2113 ns = gfc_global_ns_list;
2114 for (; ns && ns != gsym->ns; ns = ns->sibling)
2116 if (ns->sibling == gsym->ns)
2118 ns->sibling = gsym->ns->sibling;
2119 gsym->ns->sibling = gfc_global_ns_list;
2120 gfc_global_ns_list = gsym->ns;
2125 def_sym = gsym->ns->proc_name;
2126 if (def_sym->attr.entry_master)
2128 gfc_entry_list *entry;
2129 for (entry = gsym->ns->entries; entry; entry = entry->next)
2130 if (strcmp (entry->sym->name, sym->name) == 0)
2132 def_sym = entry->sym;
2137 /* Differences in constant character lengths. */
2138 if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2140 long int l1 = 0, l2 = 0;
2141 gfc_charlen *cl1 = sym->ts.u.cl;
2142 gfc_charlen *cl2 = def_sym->ts.u.cl;
2145 && cl1->length != NULL
2146 && cl1->length->expr_type == EXPR_CONSTANT)
2147 l1 = mpz_get_si (cl1->length->value.integer);
2150 && cl2->length != NULL
2151 && cl2->length->expr_type == EXPR_CONSTANT)
2152 l2 = mpz_get_si (cl2->length->value.integer);
2154 if (l1 && l2 && l1 != l2)
2155 gfc_error ("Character length mismatch in return type of "
2156 "function '%s' at %L (%ld/%ld)", sym->name,
2157 &sym->declared_at, l1, l2);
2160 /* Type mismatch of function return type and expected type. */
2161 if (sym->attr.function
2162 && !gfc_compare_types (&sym->ts, &def_sym->ts))
2163 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2164 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2165 gfc_typename (&def_sym->ts));
2167 if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2169 gfc_formal_arglist *arg = def_sym->formal;
2170 for ( ; arg; arg = arg->next)
2173 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2174 else if (arg->sym->attr.allocatable
2175 || arg->sym->attr.asynchronous
2176 || arg->sym->attr.optional
2177 || arg->sym->attr.pointer
2178 || arg->sym->attr.target
2179 || arg->sym->attr.value
2180 || arg->sym->attr.volatile_)
2182 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2183 "has an attribute that requires an explicit "
2184 "interface for this procedure", arg->sym->name,
2185 sym->name, &sym->declared_at);
2188 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2189 else if (arg->sym && arg->sym->as
2190 && arg->sym->as->type == AS_ASSUMED_SHAPE)
2192 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2193 "argument '%s' must have an explicit interface",
2194 sym->name, &sym->declared_at, arg->sym->name);
2197 /* F2008, 12.4.2.2 (2c) */
2198 else if (arg->sym->attr.codimension)
2200 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2201 "'%s' must have an explicit interface",
2202 sym->name, &sym->declared_at, arg->sym->name);
2205 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2206 else if (false) /* TODO: is a parametrized derived type */
2208 gfc_error ("Procedure '%s' at %L with parametrized derived "
2209 "type argument '%s' must have an explicit "
2210 "interface", sym->name, &sym->declared_at,
2214 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2215 else if (arg->sym->ts.type == BT_CLASS)
2217 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2218 "argument '%s' must have an explicit interface",
2219 sym->name, &sym->declared_at, arg->sym->name);
2224 if (def_sym->attr.function)
2226 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2227 if (def_sym->as && def_sym->as->rank
2228 && (!sym->as || sym->as->rank != def_sym->as->rank))
2229 gfc_error ("The reference to function '%s' at %L either needs an "
2230 "explicit INTERFACE or the rank is incorrect", sym->name,
2233 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2234 if ((def_sym->result->attr.pointer
2235 || def_sym->result->attr.allocatable)
2236 && (sym->attr.if_source != IFSRC_IFBODY
2237 || def_sym->result->attr.pointer
2238 != sym->result->attr.pointer
2239 || def_sym->result->attr.allocatable
2240 != sym->result->attr.allocatable))
2241 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2242 "result must have an explicit interface", sym->name,
2245 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2246 if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2247 && def_sym->ts.type == BT_CHARACTER && def_sym->ts.u.cl->length != NULL)
2249 gfc_charlen *cl = sym->ts.u.cl;
2251 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2252 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2254 gfc_error ("Nonconstant character-length function '%s' at %L "
2255 "must have an explicit interface", sym->name,
2261 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2262 if (def_sym->attr.elemental && !sym->attr.elemental)
2264 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2265 "interface", sym->name, &sym->declared_at);
2268 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2269 if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2271 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2272 "an explicit interface", sym->name, &sym->declared_at);
2275 if (gfc_option.flag_whole_file == 1
2276 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2277 && !(gfc_option.warn_std & GFC_STD_GNU)))
2278 gfc_errors_to_warnings (1);
2280 if (sym->attr.if_source != IFSRC_IFBODY)
2281 gfc_procedure_use (def_sym, actual, where);
2283 gfc_errors_to_warnings (0);
2286 if (gsym->type == GSYM_UNKNOWN)
2289 gsym->where = *where;
2296 /************* Function resolution *************/
2298 /* Resolve a function call known to be generic.
2299 Section 14.1.2.4.1. */
2302 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2306 if (sym->attr.generic)
2308 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2311 expr->value.function.name = s->name;
2312 expr->value.function.esym = s;
2314 if (s->ts.type != BT_UNKNOWN)
2316 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2317 expr->ts = s->result->ts;
2320 expr->rank = s->as->rank;
2321 else if (s->result != NULL && s->result->as != NULL)
2322 expr->rank = s->result->as->rank;
2324 gfc_set_sym_referenced (expr->value.function.esym);
2329 /* TODO: Need to search for elemental references in generic
2333 if (sym->attr.intrinsic)
2334 return gfc_intrinsic_func_interface (expr, 0);
2341 resolve_generic_f (gfc_expr *expr)
2345 gfc_interface *intr = NULL;
2347 sym = expr->symtree->n.sym;
2351 m = resolve_generic_f0 (expr, sym);
2354 else if (m == MATCH_ERROR)
2359 for (intr = sym->generic; intr; intr = intr->next)
2360 if (intr->sym->attr.flavor == FL_DERIVED)
2363 if (sym->ns->parent == NULL)
2365 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2369 if (!generic_sym (sym))
2373 /* Last ditch attempt. See if the reference is to an intrinsic
2374 that possesses a matching interface. 14.1.2.4 */
2375 if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
2377 gfc_error ("There is no specific function for the generic '%s' "
2378 "at %L", expr->symtree->n.sym->name, &expr->where);
2384 if (gfc_convert_to_structure_constructor (expr, intr->sym, NULL, NULL,
2387 return resolve_structure_cons (expr, 0);
2390 m = gfc_intrinsic_func_interface (expr, 0);
2395 gfc_error ("Generic function '%s' at %L is not consistent with a "
2396 "specific intrinsic interface", expr->symtree->n.sym->name,
2403 /* Resolve a function call known to be specific. */
2406 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2410 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2412 if (sym->attr.dummy)
2414 sym->attr.proc = PROC_DUMMY;
2418 sym->attr.proc = PROC_EXTERNAL;
2422 if (sym->attr.proc == PROC_MODULE
2423 || sym->attr.proc == PROC_ST_FUNCTION
2424 || sym->attr.proc == PROC_INTERNAL)
2427 if (sym->attr.intrinsic)
2429 m = gfc_intrinsic_func_interface (expr, 1);
2433 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2434 "with an intrinsic", sym->name, &expr->where);
2442 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2445 expr->ts = sym->result->ts;
2448 expr->value.function.name = sym->name;
2449 expr->value.function.esym = sym;
2450 if (sym->as != NULL)
2451 expr->rank = sym->as->rank;
2458 resolve_specific_f (gfc_expr *expr)
2463 sym = expr->symtree->n.sym;
2467 m = resolve_specific_f0 (sym, expr);
2470 if (m == MATCH_ERROR)
2473 if (sym->ns->parent == NULL)
2476 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2482 gfc_error ("Unable to resolve the specific function '%s' at %L",
2483 expr->symtree->n.sym->name, &expr->where);
2489 /* Resolve a procedure call not known to be generic nor specific. */
2492 resolve_unknown_f (gfc_expr *expr)
2497 sym = expr->symtree->n.sym;
2499 if (sym->attr.dummy)
2501 sym->attr.proc = PROC_DUMMY;
2502 expr->value.function.name = sym->name;
2506 /* See if we have an intrinsic function reference. */
2508 if (gfc_is_intrinsic (sym, 0, expr->where))
2510 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2515 /* The reference is to an external name. */
2517 sym->attr.proc = PROC_EXTERNAL;
2518 expr->value.function.name = sym->name;
2519 expr->value.function.esym = expr->symtree->n.sym;
2521 if (sym->as != NULL)
2522 expr->rank = sym->as->rank;
2524 /* Type of the expression is either the type of the symbol or the
2525 default type of the symbol. */
2528 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2530 if (sym->ts.type != BT_UNKNOWN)
2534 ts = gfc_get_default_type (sym->name, sym->ns);
2536 if (ts->type == BT_UNKNOWN)
2538 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2539 sym->name, &expr->where);
2550 /* Return true, if the symbol is an external procedure. */
2552 is_external_proc (gfc_symbol *sym)
2554 if (!sym->attr.dummy && !sym->attr.contained
2555 && !(sym->attr.intrinsic
2556 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2557 && sym->attr.proc != PROC_ST_FUNCTION
2558 && !sym->attr.proc_pointer
2559 && !sym->attr.use_assoc
2567 /* Figure out if a function reference is pure or not. Also set the name
2568 of the function for a potential error message. Return nonzero if the
2569 function is PURE, zero if not. */
2571 pure_stmt_function (gfc_expr *, gfc_symbol *);
2574 pure_function (gfc_expr *e, const char **name)
2580 if (e->symtree != NULL
2581 && e->symtree->n.sym != NULL
2582 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2583 return pure_stmt_function (e, e->symtree->n.sym);
2585 if (e->value.function.esym)
2587 pure = gfc_pure (e->value.function.esym);
2588 *name = e->value.function.esym->name;
2590 else if (e->value.function.isym)
2592 pure = e->value.function.isym->pure
2593 || e->value.function.isym->elemental;
2594 *name = e->value.function.isym->name;
2598 /* Implicit functions are not pure. */
2600 *name = e->value.function.name;
2608 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2609 int *f ATTRIBUTE_UNUSED)
2613 /* Don't bother recursing into other statement functions
2614 since they will be checked individually for purity. */
2615 if (e->expr_type != EXPR_FUNCTION
2617 || e->symtree->n.sym == sym
2618 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2621 return pure_function (e, &name) ? false : true;
2626 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2628 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2633 is_scalar_expr_ptr (gfc_expr *expr)
2635 gfc_try retval = SUCCESS;
2640 /* See if we have a gfc_ref, which means we have a substring, array
2641 reference, or a component. */
2642 if (expr->ref != NULL)
2645 while (ref->next != NULL)
2651 if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
2652 || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
2657 if (ref->u.ar.type == AR_ELEMENT)
2659 else if (ref->u.ar.type == AR_FULL)
2661 /* The user can give a full array if the array is of size 1. */
2662 if (ref->u.ar.as != NULL
2663 && ref->u.ar.as->rank == 1
2664 && ref->u.ar.as->type == AS_EXPLICIT
2665 && ref->u.ar.as->lower[0] != NULL
2666 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2667 && ref->u.ar.as->upper[0] != NULL
2668 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2670 /* If we have a character string, we need to check if
2671 its length is one. */
2672 if (expr->ts.type == BT_CHARACTER)
2674 if (expr->ts.u.cl == NULL
2675 || expr->ts.u.cl->length == NULL
2676 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2682 /* We have constant lower and upper bounds. If the
2683 difference between is 1, it can be considered a
2685 FIXME: Use gfc_dep_compare_expr instead. */
2686 start = (int) mpz_get_si
2687 (ref->u.ar.as->lower[0]->value.integer);
2688 end = (int) mpz_get_si
2689 (ref->u.ar.as->upper[0]->value.integer);
2690 if (end - start + 1 != 1)
2705 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2707 /* Character string. Make sure it's of length 1. */
2708 if (expr->ts.u.cl == NULL
2709 || expr->ts.u.cl->length == NULL
2710 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2713 else if (expr->rank != 0)
2720 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2721 and, in the case of c_associated, set the binding label based on
2725 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2726 gfc_symbol **new_sym)
2728 char name[GFC_MAX_SYMBOL_LEN + 1];
2729 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2730 int optional_arg = 0;
2731 gfc_try retval = SUCCESS;
2732 gfc_symbol *args_sym;
2733 gfc_typespec *arg_ts;
2734 symbol_attribute arg_attr;
2736 if (args->expr->expr_type == EXPR_CONSTANT
2737 || args->expr->expr_type == EXPR_OP
2738 || args->expr->expr_type == EXPR_NULL)
2740 gfc_error ("Argument to '%s' at %L is not a variable",
2741 sym->name, &(args->expr->where));
2745 args_sym = args->expr->symtree->n.sym;
2747 /* The typespec for the actual arg should be that stored in the expr
2748 and not necessarily that of the expr symbol (args_sym), because
2749 the actual expression could be a part-ref of the expr symbol. */
2750 arg_ts = &(args->expr->ts);
2751 arg_attr = gfc_expr_attr (args->expr);
2753 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2755 /* If the user gave two args then they are providing something for
2756 the optional arg (the second cptr). Therefore, set the name and
2757 binding label to the c_associated for two cptrs. Otherwise,
2758 set c_associated to expect one cptr. */
2762 sprintf (name, "%s_2", sym->name);
2763 sprintf (binding_label, "%s_2", sym->binding_label);
2769 sprintf (name, "%s_1", sym->name);
2770 sprintf (binding_label, "%s_1", sym->binding_label);
2774 /* Get a new symbol for the version of c_associated that
2776 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2778 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2779 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2781 sprintf (name, "%s", sym->name);
2782 sprintf (binding_label, "%s", sym->binding_label);
2784 /* Error check the call. */
2785 if (args->next != NULL)
2787 gfc_error_now ("More actual than formal arguments in '%s' "
2788 "call at %L", name, &(args->expr->where));
2791 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2796 /* Make sure we have either the target or pointer attribute. */
2797 if (!arg_attr.target && !arg_attr.pointer)
2799 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2800 "a TARGET or an associated pointer",
2802 sym->name, &(args->expr->where));
2806 if (gfc_is_coindexed (args->expr))
2808 gfc_error_now ("Coindexed argument not permitted"
2809 " in '%s' call at %L", name,
2810 &(args->expr->where));
2814 /* Follow references to make sure there are no array
2816 seen_section = false;
2818 for (ref=args->expr->ref; ref; ref = ref->next)
2820 if (ref->type == REF_ARRAY)
2822 if (ref->u.ar.type == AR_SECTION)
2823 seen_section = true;
2825 if (ref->u.ar.type != AR_ELEMENT)
2828 for (r = ref->next; r; r=r->next)
2829 if (r->type == REF_COMPONENT)
2831 gfc_error_now ("Array section not permitted"
2832 " in '%s' call at %L", name,
2833 &(args->expr->where));
2841 if (seen_section && retval == SUCCESS)
2842 gfc_warning ("Array section in '%s' call at %L", name,
2843 &(args->expr->where));
2845 /* See if we have interoperable type and type param. */
2846 if (gfc_verify_c_interop (arg_ts) == SUCCESS
2847 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2849 if (args_sym->attr.target == 1)
2851 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2852 has the target attribute and is interoperable. */
2853 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2854 allocatable variable that has the TARGET attribute and
2855 is not an array of zero size. */
2856 if (args_sym->attr.allocatable == 1)
2858 if (args_sym->attr.dimension != 0
2859 && (args_sym->as && args_sym->as->rank == 0))
2861 gfc_error_now ("Allocatable variable '%s' used as a "
2862 "parameter to '%s' at %L must not be "
2863 "an array of zero size",
2864 args_sym->name, sym->name,
2865 &(args->expr->where));
2871 /* A non-allocatable target variable with C
2872 interoperable type and type parameters must be
2874 if (args_sym && args_sym->attr.dimension)
2876 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2878 gfc_error ("Assumed-shape array '%s' at %L "
2879 "cannot be an argument to the "
2880 "procedure '%s' because "
2881 "it is not C interoperable",
2883 &(args->expr->where), sym->name);
2886 else if (args_sym->as->type == AS_DEFERRED)
2888 gfc_error ("Deferred-shape array '%s' at %L "
2889 "cannot be an argument to the "
2890 "procedure '%s' because "
2891 "it is not C interoperable",
2893 &(args->expr->where), sym->name);
2898 /* Make sure it's not a character string. Arrays of
2899 any type should be ok if the variable is of a C
2900 interoperable type. */
2901 if (arg_ts->type == BT_CHARACTER)
2902 if (arg_ts->u.cl != NULL
2903 && (arg_ts->u.cl->length == NULL
2904 || arg_ts->u.cl->length->expr_type
2907 (arg_ts->u.cl->length->value.integer, 1)
2909 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2911 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2912 "at %L must have a length of 1",
2913 args_sym->name, sym->name,
2914 &(args->expr->where));
2919 else if (arg_attr.pointer
2920 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2922 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2924 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2925 "associated scalar POINTER", args_sym->name,
2926 sym->name, &(args->expr->where));
2932 /* The parameter is not required to be C interoperable. If it
2933 is not C interoperable, it must be a nonpolymorphic scalar
2934 with no length type parameters. It still must have either
2935 the pointer or target attribute, and it can be
2936 allocatable (but must be allocated when c_loc is called). */
2937 if (args->expr->rank != 0
2938 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2940 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2941 "scalar", args_sym->name, sym->name,
2942 &(args->expr->where));
2945 else if (arg_ts->type == BT_CHARACTER
2946 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2948 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2949 "%L must have a length of 1",
2950 args_sym->name, sym->name,
2951 &(args->expr->where));
2954 else if (arg_ts->type == BT_CLASS)
2956 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2957 "polymorphic", args_sym->name, sym->name,
2958 &(args->expr->where));
2963 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2965 if (args_sym->attr.flavor != FL_PROCEDURE)
2967 /* TODO: Update this error message to allow for procedure
2968 pointers once they are implemented. */
2969 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2971 args_sym->name, sym->name,
2972 &(args->expr->where));
2975 else if (args_sym->attr.is_bind_c != 1)
2977 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2979 args_sym->name, sym->name,
2980 &(args->expr->where));
2985 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2990 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2991 "iso_c_binding function: '%s'!\n", sym->name);
2998 /* Resolve a function call, which means resolving the arguments, then figuring
2999 out which entity the name refers to. */
3002 resolve_function (gfc_expr *expr)
3004 gfc_actual_arglist *arg;
3009 procedure_type p = PROC_INTRINSIC;
3010 bool no_formal_args;
3014 sym = expr->symtree->n.sym;
3016 /* If this is a procedure pointer component, it has already been resolved. */
3017 if (gfc_is_proc_ptr_comp (expr, NULL))
3020 if (sym && sym->attr.intrinsic
3021 && resolve_intrinsic (sym, &expr->where) == FAILURE)
3024 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
3026 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
3030 /* If this ia a deferred TBP with an abstract interface (which may
3031 of course be referenced), expr->value.function.esym will be set. */
3032 if (sym && sym->attr.abstract && !expr->value.function.esym)
3034 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3035 sym->name, &expr->where);
3039 /* Switch off assumed size checking and do this again for certain kinds
3040 of procedure, once the procedure itself is resolved. */
3041 need_full_assumed_size++;
3043 if (expr->symtree && expr->symtree->n.sym)
3044 p = expr->symtree->n.sym->attr.proc;
3046 if (expr->value.function.isym && expr->value.function.isym->inquiry)
3047 inquiry_argument = true;
3048 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
3050 if (resolve_actual_arglist (expr->value.function.actual,
3051 p, no_formal_args) == FAILURE)
3053 inquiry_argument = false;
3057 inquiry_argument = false;
3059 /* Need to setup the call to the correct c_associated, depending on
3060 the number of cptrs to user gives to compare. */
3061 if (sym && sym->attr.is_iso_c == 1)
3063 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
3067 /* Get the symtree for the new symbol (resolved func).
3068 the old one will be freed later, when it's no longer used. */
3069 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
3072 /* Resume assumed_size checking. */
3073 need_full_assumed_size--;
3075 /* If the procedure is external, check for usage. */
3076 if (sym && is_external_proc (sym))
3077 resolve_global_procedure (sym, &expr->where,
3078 &expr->value.function.actual, 0);
3080 if (sym && sym->ts.type == BT_CHARACTER
3082 && sym->ts.u.cl->length == NULL
3084 && !sym->ts.deferred
3085 && expr->value.function.esym == NULL
3086 && !sym->attr.contained)
3088 /* Internal procedures are taken care of in resolve_contained_fntype. */
3089 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
3090 "be used at %L since it is not a dummy argument",
3091 sym->name, &expr->where);
3095 /* See if function is already resolved. */
3097 if (expr->value.function.name != NULL)
3099 if (expr->ts.type == BT_UNKNOWN)
3105 /* Apply the rules of section 14.1.2. */
3107 switch (procedure_kind (sym))
3110 t = resolve_generic_f (expr);
3113 case PTYPE_SPECIFIC:
3114 t = resolve_specific_f (expr);
3118 t = resolve_unknown_f (expr);
3122 gfc_internal_error ("resolve_function(): bad function type");
3126 /* If the expression is still a function (it might have simplified),
3127 then we check to see if we are calling an elemental function. */
3129 if (expr->expr_type != EXPR_FUNCTION)
3132 temp = need_full_assumed_size;
3133 need_full_assumed_size = 0;
3135 if (resolve_elemental_actual (expr, NULL) == FAILURE)
3138 if (omp_workshare_flag
3139 && expr->value.function.esym
3140 && ! gfc_elemental (expr->value.function.esym))
3142 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3143 "in WORKSHARE construct", expr->value.function.esym->name,
3148 #define GENERIC_ID expr->value.function.isym->id
3149 else if (expr->value.function.actual != NULL
3150 && expr->value.function.isym != NULL
3151 && GENERIC_ID != GFC_ISYM_LBOUND
3152 && GENERIC_ID != GFC_ISYM_LEN
3153 && GENERIC_ID != GFC_ISYM_LOC
3154 && GENERIC_ID != GFC_ISYM_PRESENT)
3156 /* Array intrinsics must also have the last upper bound of an
3157 assumed size array argument. UBOUND and SIZE have to be
3158 excluded from the check if the second argument is anything
3161 for (arg = expr->value.function.actual; arg; arg = arg->next)
3163 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3164 && arg->next != NULL && arg->next->expr)
3166 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3169 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3172 if ((int)mpz_get_si (arg->next->expr->value.integer)
3177 if (arg->expr != NULL
3178 && arg->expr->rank > 0
3179 && resolve_assumed_size_actual (arg->expr))
3185 need_full_assumed_size = temp;
3188 if (!pure_function (expr, &name) && name)
3192 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3193 "FORALL %s", name, &expr->where,
3194 forall_flag == 2 ? "mask" : "block");
3197 else if (do_concurrent_flag)
3199 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3200 "DO CONCURRENT %s", name, &expr->where,
3201 do_concurrent_flag == 2 ? "mask" : "block");
3204 else if (gfc_pure (NULL))
3206 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3207 "procedure within a PURE procedure", name, &expr->where);
3211 if (gfc_implicit_pure (NULL))
3212 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3215 /* Functions without the RECURSIVE attribution are not allowed to
3216 * call themselves. */
3217 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3220 esym = expr->value.function.esym;
3222 if (is_illegal_recursion (esym, gfc_current_ns))
3224 if (esym->attr.entry && esym->ns->entries)
3225 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3226 " function '%s' is not RECURSIVE",
3227 esym->name, &expr->where, esym->ns->entries->sym->name);
3229 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3230 " is not RECURSIVE", esym->name, &expr->where);
3236 /* Character lengths of use associated functions may contains references to
3237 symbols not referenced from the current program unit otherwise. Make sure
3238 those symbols are marked as referenced. */
3240 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3241 && expr->value.function.esym->attr.use_assoc)
3243 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3246 /* Make sure that the expression has a typespec that works. */
3247 if (expr->ts.type == BT_UNKNOWN)
3249 if (expr->symtree->n.sym->result
3250 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3251 && !expr->symtree->n.sym->result->attr.proc_pointer)
3252 expr->ts = expr->symtree->n.sym->result->ts;
3259 /************* Subroutine resolution *************/
3262 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3268 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3269 sym->name, &c->loc);
3270 else if (do_concurrent_flag)
3271 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3272 "PURE", sym->name, &c->loc);
3273 else if (gfc_pure (NULL))
3274 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3277 if (gfc_implicit_pure (NULL))
3278 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3283 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3287 if (sym->attr.generic)
3289 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3292 c->resolved_sym = s;
3293 pure_subroutine (c, s);
3297 /* TODO: Need to search for elemental references in generic interface. */
3300 if (sym->attr.intrinsic)
3301 return gfc_intrinsic_sub_interface (c, 0);
3308 resolve_generic_s (gfc_code *c)
3313 sym = c->symtree->n.sym;
3317 m = resolve_generic_s0 (c, sym);
3320 else if (m == MATCH_ERROR)
3324 if (sym->ns->parent == NULL)
3326 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3330 if (!generic_sym (sym))
3334 /* Last ditch attempt. See if the reference is to an intrinsic
3335 that possesses a matching interface. 14.1.2.4 */
3336 sym = c->symtree->n.sym;
3338 if (!gfc_is_intrinsic (sym, 1, c->loc))
3340 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3341 sym->name, &c->loc);
3345 m = gfc_intrinsic_sub_interface (c, 0);
3349 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3350 "intrinsic subroutine interface", sym->name, &c->loc);
3356 /* Set the name and binding label of the subroutine symbol in the call
3357 expression represented by 'c' to include the type and kind of the
3358 second parameter. This function is for resolving the appropriate
3359 version of c_f_pointer() and c_f_procpointer(). For example, a
3360 call to c_f_pointer() for a default integer pointer could have a
3361 name of c_f_pointer_i4. If no second arg exists, which is an error
3362 for these two functions, it defaults to the generic symbol's name
3363 and binding label. */
3366 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3367 char *name, char *binding_label)
3369 gfc_expr *arg = NULL;
3373 /* The second arg of c_f_pointer and c_f_procpointer determines
3374 the type and kind for the procedure name. */
3375 arg = c->ext.actual->next->expr;
3379 /* Set up the name to have the given symbol's name,
3380 plus the type and kind. */
3381 /* a derived type is marked with the type letter 'u' */
3382 if (arg->ts.type == BT_DERIVED)
3385 kind = 0; /* set the kind as 0 for now */
3389 type = gfc_type_letter (arg->ts.type);
3390 kind = arg->ts.kind;
3393 if (arg->ts.type == BT_CHARACTER)
3394 /* Kind info for character strings not needed. */
3397 sprintf (name, "%s_%c%d", sym->name, type, kind);
3398 /* Set up the binding label as the given symbol's label plus
3399 the type and kind. */
3400 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
3404 /* If the second arg is missing, set the name and label as
3405 was, cause it should at least be found, and the missing
3406 arg error will be caught by compare_parameters(). */
3407 sprintf (name, "%s", sym->name);
3408 sprintf (binding_label, "%s", sym->binding_label);
3415 /* Resolve a generic version of the iso_c_binding procedure given
3416 (sym) to the specific one based on the type and kind of the
3417 argument(s). Currently, this function resolves c_f_pointer() and
3418 c_f_procpointer based on the type and kind of the second argument
3419 (FPTR). Other iso_c_binding procedures aren't specially handled.
3420 Upon successfully exiting, c->resolved_sym will hold the resolved
3421 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3425 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3427 gfc_symbol *new_sym;
3428 /* this is fine, since we know the names won't use the max */
3429 char name[GFC_MAX_SYMBOL_LEN + 1];
3430 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
3431 /* default to success; will override if find error */
3432 match m = MATCH_YES;
3434 /* Make sure the actual arguments are in the necessary order (based on the
3435 formal args) before resolving. */
3436 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3438 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3439 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3441 set_name_and_label (c, sym, name, binding_label);
3443 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3445 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3447 /* Make sure we got a third arg if the second arg has non-zero
3448 rank. We must also check that the type and rank are
3449 correct since we short-circuit this check in
3450 gfc_procedure_use() (called above to sort actual args). */
3451 if (c->ext.actual->next->expr->rank != 0)
3453 if(c->ext.actual->next->next == NULL
3454 || c->ext.actual->next->next->expr == NULL)
3457 gfc_error ("Missing SHAPE parameter for call to %s "
3458 "at %L", sym->name, &(c->loc));
3460 else if (c->ext.actual->next->next->expr->ts.type
3462 || c->ext.actual->next->next->expr->rank != 1)
3465 gfc_error ("SHAPE parameter for call to %s at %L must "
3466 "be a rank 1 INTEGER array", sym->name,
3473 if (m != MATCH_ERROR)
3475 /* the 1 means to add the optional arg to formal list */
3476 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3478 /* for error reporting, say it's declared where the original was */
3479 new_sym->declared_at = sym->declared_at;
3484 /* no differences for c_loc or c_funloc */
3488 /* set the resolved symbol */
3489 if (m != MATCH_ERROR)
3490 c->resolved_sym = new_sym;
3492 c->resolved_sym = sym;
3498 /* Resolve a subroutine call known to be specific. */
3501 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3505 if(sym->attr.is_iso_c)
3507 m = gfc_iso_c_sub_interface (c,sym);
3511 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3513 if (sym->attr.dummy)
3515 sym->attr.proc = PROC_DUMMY;
3519 sym->attr.proc = PROC_EXTERNAL;
3523 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3526 if (sym->attr.intrinsic)
3528 m = gfc_intrinsic_sub_interface (c, 1);
3532 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3533 "with an intrinsic", sym->name, &c->loc);
3541 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3543 c->resolved_sym = sym;
3544 pure_subroutine (c, sym);
3551 resolve_specific_s (gfc_code *c)
3556 sym = c->symtree->n.sym;
3560 m = resolve_specific_s0 (c, sym);
3563 if (m == MATCH_ERROR)
3566 if (sym->ns->parent == NULL)
3569 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3575 sym = c->symtree->n.sym;
3576 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3577 sym->name, &c->loc);
3583 /* Resolve a subroutine call not known to be generic nor specific. */
3586 resolve_unknown_s (gfc_code *c)
3590 sym = c->symtree->n.sym;
3592 if (sym->attr.dummy)
3594 sym->attr.proc = PROC_DUMMY;
3598 /* See if we have an intrinsic function reference. */
3600 if (gfc_is_intrinsic (sym, 1, c->loc))
3602 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3607 /* The reference is to an external name. */
3610 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3612 c->resolved_sym = sym;
3614 pure_subroutine (c, sym);
3620 /* Resolve a subroutine call. Although it was tempting to use the same code
3621 for functions, subroutines and functions are stored differently and this
3622 makes things awkward. */
3625 resolve_call (gfc_code *c)
3628 procedure_type ptype = PROC_INTRINSIC;
3629 gfc_symbol *csym, *sym;
3630 bool no_formal_args;
3632 csym = c->symtree ? c->symtree->n.sym : NULL;
3634 if (csym && csym->ts.type != BT_UNKNOWN)
3636 gfc_error ("'%s' at %L has a type, which is not consistent with "
3637 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3641 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3644 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3645 sym = st ? st->n.sym : NULL;
3646 if (sym && csym != sym
3647 && sym->ns == gfc_current_ns
3648 && sym->attr.flavor == FL_PROCEDURE
3649 && sym->attr.contained)
3652 if (csym->attr.generic)
3653 c->symtree->n.sym = sym;
3656 csym = c->symtree->n.sym;
3660 /* If this ia a deferred TBP with an abstract interface
3661 (which may of course be referenced), c->expr1 will be set. */
3662 if (csym && csym->attr.abstract && !c->expr1)
3664 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3665 csym->name, &c->loc);
3669 /* Subroutines without the RECURSIVE attribution are not allowed to
3670 * call themselves. */
3671 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3673 if (csym->attr.entry && csym->ns->entries)
3674 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3675 " subroutine '%s' is not RECURSIVE",
3676 csym->name, &c->loc, csym->ns->entries->sym->name);
3678 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3679 " is not RECURSIVE", csym->name, &c->loc);
3684 /* Switch off assumed size checking and do this again for certain kinds
3685 of procedure, once the procedure itself is resolved. */
3686 need_full_assumed_size++;
3689 ptype = csym->attr.proc;
3691 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3692 if (resolve_actual_arglist (c->ext.actual, ptype,
3693 no_formal_args) == FAILURE)
3696 /* Resume assumed_size checking. */
3697 need_full_assumed_size--;
3699 /* If external, check for usage. */
3700 if (csym && is_external_proc (csym))
3701 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3704 if (c->resolved_sym == NULL)
3706 c->resolved_isym = NULL;
3707 switch (procedure_kind (csym))
3710 t = resolve_generic_s (c);
3713 case PTYPE_SPECIFIC:
3714 t = resolve_specific_s (c);
3718 t = resolve_unknown_s (c);
3722 gfc_internal_error ("resolve_subroutine(): bad function type");
3726 /* Some checks of elemental subroutine actual arguments. */
3727 if (resolve_elemental_actual (NULL, c) == FAILURE)
3734 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3735 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3736 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3737 if their shapes do not match. If either op1->shape or op2->shape is
3738 NULL, return SUCCESS. */
3741 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3748 if (op1->shape != NULL && op2->shape != NULL)
3750 for (i = 0; i < op1->rank; i++)
3752 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3754 gfc_error ("Shapes for operands at %L and %L are not conformable",
3755 &op1->where, &op2->where);
3766 /* Resolve an operator expression node. This can involve replacing the
3767 operation with a user defined function call. */
3770 resolve_operator (gfc_expr *e)
3772 gfc_expr *op1, *op2;
3774 bool dual_locus_error;
3777 /* Resolve all subnodes-- give them types. */
3779 switch (e->value.op.op)
3782 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3785 /* Fall through... */
3788 case INTRINSIC_UPLUS:
3789 case INTRINSIC_UMINUS:
3790 case INTRINSIC_PARENTHESES:
3791 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3796 /* Typecheck the new node. */
3798 op1 = e->value.op.op1;
3799 op2 = e->value.op.op2;
3800 dual_locus_error = false;
3802 if ((op1 && op1->expr_type == EXPR_NULL)
3803 || (op2 && op2->expr_type == EXPR_NULL))
3805 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3809 switch (e->value.op.op)
3811 case INTRINSIC_UPLUS:
3812 case INTRINSIC_UMINUS:
3813 if (op1->ts.type == BT_INTEGER
3814 || op1->ts.type == BT_REAL
3815 || op1->ts.type == BT_COMPLEX)
3821 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3822 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3825 case INTRINSIC_PLUS:
3826 case INTRINSIC_MINUS:
3827 case INTRINSIC_TIMES:
3828 case INTRINSIC_DIVIDE:
3829 case INTRINSIC_POWER:
3830 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3832 gfc_type_convert_binary (e, 1);
3837 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3838 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3839 gfc_typename (&op2->ts));
3842 case INTRINSIC_CONCAT:
3843 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3844 && op1->ts.kind == op2->ts.kind)
3846 e->ts.type = BT_CHARACTER;
3847 e->ts.kind = op1->ts.kind;
3852 _("Operands of string concatenation operator at %%L are %s/%s"),
3853 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3859 case INTRINSIC_NEQV:
3860 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3862 e->ts.type = BT_LOGICAL;
3863 e->ts.kind = gfc_kind_max (op1, op2);
3864 if (op1->ts.kind < e->ts.kind)
3865 gfc_convert_type (op1, &e->ts, 2);
3866 else if (op2->ts.kind < e->ts.kind)
3867 gfc_convert_type (op2, &e->ts, 2);
3871 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3872 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3873 gfc_typename (&op2->ts));
3878 if (op1->ts.type == BT_LOGICAL)
3880 e->ts.type = BT_LOGICAL;
3881 e->ts.kind = op1->ts.kind;
3885 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3886 gfc_typename (&op1->ts));
3890 case INTRINSIC_GT_OS:
3892 case INTRINSIC_GE_OS:
3894 case INTRINSIC_LT_OS:
3896 case INTRINSIC_LE_OS:
3897 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3899 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3903 /* Fall through... */
3906 case INTRINSIC_EQ_OS:
3908 case INTRINSIC_NE_OS:
3909 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3910 && op1->ts.kind == op2->ts.kind)
3912 e->ts.type = BT_LOGICAL;
3913 e->ts.kind = gfc_default_logical_kind;
3917 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3919 gfc_type_convert_binary (e, 1);
3921 e->ts.type = BT_LOGICAL;
3922 e->ts.kind = gfc_default_logical_kind;
3926 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3928 _("Logicals at %%L must be compared with %s instead of %s"),
3929 (e->value.op.op == INTRINSIC_EQ
3930 || e->value.op.op == INTRINSIC_EQ_OS)
3931 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3934 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3935 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3936 gfc_typename (&op2->ts));
3940 case INTRINSIC_USER:
3941 if (e->value.op.uop->op == NULL)
3942 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3943 else if (op2 == NULL)
3944 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3945 e->value.op.uop->name, gfc_typename (&op1->ts));
3948 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3949 e->value.op.uop->name, gfc_typename (&op1->ts),
3950 gfc_typename (&op2->ts));
3951 e->value.op.uop->op->sym->attr.referenced = 1;
3956 case INTRINSIC_PARENTHESES:
3958 if (e->ts.type == BT_CHARACTER)
3959 e->ts.u.cl = op1->ts.u.cl;
3963 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3966 /* Deal with arrayness of an operand through an operator. */
3970 switch (e->value.op.op)
3972 case INTRINSIC_PLUS:
3973 case INTRINSIC_MINUS:
3974 case INTRINSIC_TIMES:
3975 case INTRINSIC_DIVIDE:
3976 case INTRINSIC_POWER:
3977 case INTRINSIC_CONCAT:
3981 case INTRINSIC_NEQV:
3983 case INTRINSIC_EQ_OS:
3985 case INTRINSIC_NE_OS:
3987 case INTRINSIC_GT_OS:
3989 case INTRINSIC_GE_OS:
3991 case INTRINSIC_LT_OS:
3993 case INTRINSIC_LE_OS:
3995 if (op1->rank == 0 && op2->rank == 0)
3998 if (op1->rank == 0 && op2->rank != 0)
4000 e->rank = op2->rank;
4002 if (e->shape == NULL)
4003 e->shape = gfc_copy_shape (op2->shape, op2->rank);
4006 if (op1->rank != 0 && op2->rank == 0)
4008 e->rank = op1->rank;
4010 if (e->shape == NULL)
4011 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4014 if (op1->rank != 0 && op2->rank != 0)
4016 if (op1->rank == op2->rank)
4018 e->rank = op1->rank;
4019 if (e->shape == NULL)
4021 t = compare_shapes (op1, op2);
4025 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4030 /* Allow higher level expressions to work. */
4033 /* Try user-defined operators, and otherwise throw an error. */
4034 dual_locus_error = true;
4036 _("Inconsistent ranks for operator at %%L and %%L"));
4043 case INTRINSIC_PARENTHESES:
4045 case INTRINSIC_UPLUS:
4046 case INTRINSIC_UMINUS:
4047 /* Simply copy arrayness attribute */
4048 e->rank = op1->rank;
4050 if (e->shape == NULL)
4051 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4059 /* Attempt to simplify the expression. */
4062 t = gfc_simplify_expr (e, 0);
4063 /* Some calls do not succeed in simplification and return FAILURE
4064 even though there is no error; e.g. variable references to
4065 PARAMETER arrays. */
4066 if (!gfc_is_constant_expr (e))
4074 match m = gfc_extend_expr (e);
4077 if (m == MATCH_ERROR)
4081 if (dual_locus_error)
4082 gfc_error (msg, &op1->where, &op2->where);
4084 gfc_error (msg, &e->where);
4090 /************** Array resolution subroutines **************/
4093 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
4096 /* Compare two integer expressions. */
4099 compare_bound (gfc_expr *a, gfc_expr *b)
4103 if (a == NULL || a->expr_type != EXPR_CONSTANT
4104 || b == NULL || b->expr_type != EXPR_CONSTANT)
4107 /* If either of the types isn't INTEGER, we must have
4108 raised an error earlier. */
4110 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
4113 i = mpz_cmp (a->value.integer, b->value.integer);
4123 /* Compare an integer expression with an integer. */
4126 compare_bound_int (gfc_expr *a, int b)
4130 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4133 if (a->ts.type != BT_INTEGER)
4134 gfc_internal_error ("compare_bound_int(): Bad expression");
4136 i = mpz_cmp_si (a->value.integer, b);
4146 /* Compare an integer expression with a mpz_t. */
4149 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4153 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4156 if (a->ts.type != BT_INTEGER)
4157 gfc_internal_error ("compare_bound_int(): Bad expression");
4159 i = mpz_cmp (a->value.integer, b);
4169 /* Compute the last value of a sequence given by a triplet.
4170 Return 0 if it wasn't able to compute the last value, or if the
4171 sequence if empty, and 1 otherwise. */
4174 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4175 gfc_expr *stride, mpz_t last)
4179 if (start == NULL || start->expr_type != EXPR_CONSTANT
4180 || end == NULL || end->expr_type != EXPR_CONSTANT
4181 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4184 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4185 || (stride != NULL && stride->ts.type != BT_INTEGER))
4188 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
4190 if (compare_bound (start, end) == CMP_GT)
4192 mpz_set (last, end->value.integer);
4196 if (compare_bound_int (stride, 0) == CMP_GT)
4198 /* Stride is positive */
4199 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4204 /* Stride is negative */
4205 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4210 mpz_sub (rem, end->value.integer, start->value.integer);
4211 mpz_tdiv_r (rem, rem, stride->value.integer);
4212 mpz_sub (last, end->value.integer, rem);
4219 /* Compare a single dimension of an array reference to the array
4223 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4227 if (ar->dimen_type[i] == DIMEN_STAR)
4229 gcc_assert (ar->stride[i] == NULL);
4230 /* This implies [*] as [*:] and [*:3] are not possible. */
4231 if (ar->start[i] == NULL)
4233 gcc_assert (ar->end[i] == NULL);
4238 /* Given start, end and stride values, calculate the minimum and
4239 maximum referenced indexes. */
4241 switch (ar->dimen_type[i])
4244 case DIMEN_THIS_IMAGE:
4249 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4252 gfc_warning ("Array reference at %L is out of bounds "
4253 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4254 mpz_get_si (ar->start[i]->value.integer),
4255 mpz_get_si (as->lower[i]->value.integer), i+1);
4257 gfc_warning ("Array reference at %L is out of bounds "
4258 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4259 mpz_get_si (ar->start[i]->value.integer),
4260 mpz_get_si (as->lower[i]->value.integer),
4264 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4267 gfc_warning ("Array reference at %L is out of bounds "
4268 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4269 mpz_get_si (ar->start[i]->value.integer),
4270 mpz_get_si (as->upper[i]->value.integer), i+1);
4272 gfc_warning ("Array reference at %L is out of bounds "
4273 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4274 mpz_get_si (ar->start[i]->value.integer),
4275 mpz_get_si (as->upper[i]->value.integer),
4284 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4285 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4287 comparison comp_start_end = compare_bound (AR_START, AR_END);
4289 /* Check for zero stride, which is not allowed. */
4290 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4292 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4296 /* if start == len || (stride > 0 && start < len)
4297 || (stride < 0 && start > len),
4298 then the array section contains at least one element. In this
4299 case, there is an out-of-bounds access if
4300 (start < lower || start > upper). */
4301 if (compare_bound (AR_START, AR_END) == CMP_EQ
4302 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4303 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4304 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4305 && comp_start_end == CMP_GT))
4307 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4309 gfc_warning ("Lower array reference at %L is out of bounds "
4310 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4311 mpz_get_si (AR_START->value.integer),
4312 mpz_get_si (as->lower[i]->value.integer), i+1);
4315 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4317 gfc_warning ("Lower array reference at %L is out of bounds "
4318 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4319 mpz_get_si (AR_START->value.integer),
4320 mpz_get_si (as->upper[i]->value.integer), i+1);
4325 /* If we can compute the highest index of the array section,
4326 then it also has to be between lower and upper. */
4327 mpz_init (last_value);
4328 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4331 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4333 gfc_warning ("Upper array reference at %L is out of bounds "
4334 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4335 mpz_get_si (last_value),
4336 mpz_get_si (as->lower[i]->value.integer), i+1);
4337 mpz_clear (last_value);
4340 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4342 gfc_warning ("Upper array reference at %L is out of bounds "
4343 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4344 mpz_get_si (last_value),
4345 mpz_get_si (as->upper[i]->value.integer), i+1);
4346 mpz_clear (last_value);
4350 mpz_clear (last_value);
4358 gfc_internal_error ("check_dimension(): Bad array reference");
4365 /* Compare an array reference with an array specification. */
4368 compare_spec_to_ref (gfc_array_ref *ar)
4375 /* TODO: Full array sections are only allowed as actual parameters. */
4376 if (as->type == AS_ASSUMED_SIZE
4377 && (/*ar->type == AR_FULL
4378 ||*/ (ar->type == AR_SECTION
4379 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4381 gfc_error ("Rightmost upper bound of assumed size array section "
4382 "not specified at %L", &ar->where);
4386 if (ar->type == AR_FULL)
4389 if (as->rank != ar->dimen)
4391 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4392 &ar->where, ar->dimen, as->rank);
4396 /* ar->codimen == 0 is a local array. */
4397 if (as->corank != ar->codimen && ar->codimen != 0)
4399 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4400 &ar->where, ar->codimen, as->corank);
4404 for (i = 0; i < as->rank; i++)
4405 if (check_dimension (i, ar, as) == FAILURE)
4408 /* Local access has no coarray spec. */
4409 if (ar->codimen != 0)
4410 for (i = as->rank; i < as->rank + as->corank; i++)
4412 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
4413 && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
4415 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4416 i + 1 - as->rank, &ar->where);
4419 if (check_dimension (i, ar, as) == FAILURE)
4427 /* Resolve one part of an array index. */
4430 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4431 int force_index_integer_kind)
4438 if (gfc_resolve_expr (index) == FAILURE)
4441 if (check_scalar && index->rank != 0)
4443 gfc_error ("Array index at %L must be scalar", &index->where);
4447 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4449 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4450 &index->where, gfc_basic_typename (index->ts.type));
4454 if (index->ts.type == BT_REAL)
4455 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
4456 &index->where) == FAILURE)
4459 if ((index->ts.kind != gfc_index_integer_kind
4460 && force_index_integer_kind)
4461 || index->ts.type != BT_INTEGER)
4464 ts.type = BT_INTEGER;
4465 ts.kind = gfc_index_integer_kind;
4467 gfc_convert_type_warn (index, &ts, 2, 0);
4473 /* Resolve one part of an array index. */
4476 gfc_resolve_index (gfc_expr *index, int check_scalar)
4478 return gfc_resolve_index_1 (index, check_scalar, 1);
4481 /* Resolve a dim argument to an intrinsic function. */
4484 gfc_resolve_dim_arg (gfc_expr *dim)
4489 if (gfc_resolve_expr (dim) == FAILURE)
4494 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4499 if (dim->ts.type != BT_INTEGER)
4501 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4505 if (dim->ts.kind != gfc_index_integer_kind)
4510 ts.type = BT_INTEGER;
4511 ts.kind = gfc_index_integer_kind;
4513 gfc_convert_type_warn (dim, &ts, 2, 0);
4519 /* Given an expression that contains array references, update those array
4520 references to point to the right array specifications. While this is
4521 filled in during matching, this information is difficult to save and load
4522 in a module, so we take care of it here.
4524 The idea here is that the original array reference comes from the
4525 base symbol. We traverse the list of reference structures, setting
4526 the stored reference to references. Component references can
4527 provide an additional array specification. */
4530 find_array_spec (gfc_expr *e)
4536 if (e->symtree->n.sym->ts.type == BT_CLASS)
4537 as = CLASS_DATA (e->symtree->n.sym)->as;
4539 as = e->symtree->n.sym->as;
4541 for (ref = e->ref; ref; ref = ref->next)
4546 gfc_internal_error ("find_array_spec(): Missing spec");
4553 c = ref->u.c.component;
4554 if (c->attr.dimension)
4557 gfc_internal_error ("find_array_spec(): unused as(1)");
4568 gfc_internal_error ("find_array_spec(): unused as(2)");
4572 /* Resolve an array reference. */
4575 resolve_array_ref (gfc_array_ref *ar)
4577 int i, check_scalar;
4580 for (i = 0; i < ar->dimen + ar->codimen; i++)
4582 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4584 /* Do not force gfc_index_integer_kind for the start. We can
4585 do fine with any integer kind. This avoids temporary arrays
4586 created for indexing with a vector. */
4587 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4589 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4591 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4596 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4600 ar->dimen_type[i] = DIMEN_ELEMENT;
4604 ar->dimen_type[i] = DIMEN_VECTOR;
4605 if (e->expr_type == EXPR_VARIABLE
4606 && e->symtree->n.sym->ts.type == BT_DERIVED)
4607 ar->start[i] = gfc_get_parentheses (e);
4611 gfc_error ("Array index at %L is an array of rank %d",
4612 &ar->c_where[i], e->rank);
4616 /* Fill in the upper bound, which may be lower than the
4617 specified one for something like a(2:10:5), which is
4618 identical to a(2:7:5). Only relevant for strides not equal
4619 to one. Don't try a division by zero. */
4620 if (ar->dimen_type[i] == DIMEN_RANGE
4621 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4622 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
4623 && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
4627 if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4629 if (ar->end[i] == NULL)
4632 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4634 mpz_set (ar->end[i]->value.integer, end);
4636 else if (ar->end[i]->ts.type == BT_INTEGER
4637 && ar->end[i]->expr_type == EXPR_CONSTANT)
4639 mpz_set (ar->end[i]->value.integer, end);
4650 if (ar->type == AR_FULL)
4652 if (ar->as->rank == 0)
4653 ar->type = AR_ELEMENT;
4655 /* Make sure array is the same as array(:,:), this way
4656 we don't need to special case all the time. */
4657 ar->dimen = ar->as->rank;
4658 for (i = 0; i < ar->dimen; i++)
4660 ar->dimen_type[i] = DIMEN_RANGE;
4662 gcc_assert (ar->start[i] == NULL);
4663 gcc_assert (ar->end[i] == NULL);
4664 gcc_assert (ar->stride[i] == NULL);
4668 /* If the reference type is unknown, figure out what kind it is. */
4670 if (ar->type == AR_UNKNOWN)
4672 ar->type = AR_ELEMENT;
4673 for (i = 0; i < ar->dimen; i++)
4674 if (ar->dimen_type[i] == DIMEN_RANGE
4675 || ar->dimen_type[i] == DIMEN_VECTOR)
4677 ar->type = AR_SECTION;
4682 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4685 if (ar->as->corank && ar->codimen == 0)
4688 ar->codimen = ar->as->corank;
4689 for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
4690 ar->dimen_type[n] = DIMEN_THIS_IMAGE;
4698 resolve_substring (gfc_ref *ref)
4700 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4702 if (ref->u.ss.start != NULL)
4704 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4707 if (ref->u.ss.start->ts.type != BT_INTEGER)
4709 gfc_error ("Substring start index at %L must be of type INTEGER",
4710 &ref->u.ss.start->where);
4714 if (ref->u.ss.start->rank != 0)
4716 gfc_error ("Substring start index at %L must be scalar",
4717 &ref->u.ss.start->where);
4721 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4722 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4723 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4725 gfc_error ("Substring start index at %L is less than one",
4726 &ref->u.ss.start->where);
4731 if (ref->u.ss.end != NULL)
4733 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4736 if (ref->u.ss.end->ts.type != BT_INTEGER)
4738 gfc_error ("Substring end index at %L must be of type INTEGER",
4739 &ref->u.ss.end->where);
4743 if (ref->u.ss.end->rank != 0)
4745 gfc_error ("Substring end index at %L must be scalar",
4746 &ref->u.ss.end->where);
4750 if (ref->u.ss.length != NULL
4751 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4752 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4753 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4755 gfc_error ("Substring end index at %L exceeds the string length",
4756 &ref->u.ss.start->where);
4760 if (compare_bound_mpz_t (ref->u.ss.end,
4761 gfc_integer_kinds[k].huge) == CMP_GT
4762 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4763 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4765 gfc_error ("Substring end index at %L is too large",
4766 &ref->u.ss.end->where);
4775 /* This function supplies missing substring charlens. */
4778 gfc_resolve_substring_charlen (gfc_expr *e)
4781 gfc_expr *start, *end;
4783 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4784 if (char_ref->type == REF_SUBSTRING)
4790 gcc_assert (char_ref->next == NULL);
4794 if (e->ts.u.cl->length)
4795 gfc_free_expr (e->ts.u.cl->length);
4796 else if (e->expr_type == EXPR_VARIABLE
4797 && e->symtree->n.sym->attr.dummy)
4801 e->ts.type = BT_CHARACTER;
4802 e->ts.kind = gfc_default_character_kind;
4805 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4807 if (char_ref->u.ss.start)
4808 start = gfc_copy_expr (char_ref->u.ss.start);
4810 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4812 if (char_ref->u.ss.end)
4813 end = gfc_copy_expr (char_ref->u.ss.end);
4814 else if (e->expr_type == EXPR_VARIABLE)
4815 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4822 /* Length = (end - start +1). */
4823 e->ts.u.cl->length = gfc_subtract (end, start);
4824 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4825 gfc_get_int_expr (gfc_default_integer_kind,
4828 e->ts.u.cl->length->ts.type = BT_INTEGER;
4829 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4831 /* Make sure that the length is simplified. */
4832 gfc_simplify_expr (e->ts.u.cl->length, 1);
4833 gfc_resolve_expr (e->ts.u.cl->length);
4837 /* Resolve subtype references. */
4840 resolve_ref (gfc_expr *expr)
4842 int current_part_dimension, n_components, seen_part_dimension;
4845 for (ref = expr->ref; ref; ref = ref->next)
4846 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4848 find_array_spec (expr);
4852 for (ref = expr->ref; ref; ref = ref->next)
4856 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4864 if (resolve_substring (ref) == FAILURE)
4869 /* Check constraints on part references. */
4871 current_part_dimension = 0;
4872 seen_part_dimension = 0;
4875 for (ref = expr->ref; ref; ref = ref->next)
4880 switch (ref->u.ar.type)
4883 /* Coarray scalar. */
4884 if (ref->u.ar.as->rank == 0)
4886 current_part_dimension = 0;
4891 current_part_dimension = 1;
4895 current_part_dimension = 0;
4899 gfc_internal_error ("resolve_ref(): Bad array reference");
4905 if (current_part_dimension || seen_part_dimension)
4908 if (ref->u.c.component->attr.pointer
4909 || ref->u.c.component->attr.proc_pointer)
4911 gfc_error ("Component to the right of a part reference "
4912 "with nonzero rank must not have the POINTER "
4913 "attribute at %L", &expr->where);
4916 else if (ref->u.c.component->attr.allocatable)
4918 gfc_error ("Component to the right of a part reference "
4919 "with nonzero rank must not have the ALLOCATABLE "
4920 "attribute at %L", &expr->where);
4932 if (((ref->type == REF_COMPONENT && n_components > 1)
4933 || ref->next == NULL)
4934 && current_part_dimension
4935 && seen_part_dimension)
4937 gfc_error ("Two or more part references with nonzero rank must "
4938 "not be specified at %L", &expr->where);
4942 if (ref->type == REF_COMPONENT)
4944 if (current_part_dimension)
4945 seen_part_dimension = 1;
4947 /* reset to make sure */
4948 current_part_dimension = 0;
4956 /* Given an expression, determine its shape. This is easier than it sounds.
4957 Leaves the shape array NULL if it is not possible to determine the shape. */
4960 expression_shape (gfc_expr *e)
4962 mpz_t array[GFC_MAX_DIMENSIONS];
4965 if (e->rank == 0 || e->shape != NULL)
4968 for (i = 0; i < e->rank; i++)
4969 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4972 e->shape = gfc_get_shape (e->rank);
4974 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4979 for (i--; i >= 0; i--)
4980 mpz_clear (array[i]);
4984 /* Given a variable expression node, compute the rank of the expression by
4985 examining the base symbol and any reference structures it may have. */
4988 expression_rank (gfc_expr *e)
4993 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4994 could lead to serious confusion... */
4995 gcc_assert (e->expr_type != EXPR_COMPCALL);
4999 if (e->expr_type == EXPR_ARRAY)
5001 /* Constructors can have a rank different from one via RESHAPE(). */
5003 if (e->symtree == NULL)
5009 e->rank = (e->symtree->n.sym->as == NULL)
5010 ? 0 : e->symtree->n.sym->as->rank;
5016 for (ref = e->ref; ref; ref = ref->next)
5018 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
5019 && ref->u.c.component->attr.function && !ref->next)
5020 rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
5022 if (ref->type != REF_ARRAY)
5025 if (ref->u.ar.type == AR_FULL)
5027 rank = ref->u.ar.as->rank;
5031 if (ref->u.ar.type == AR_SECTION)
5033 /* Figure out the rank of the section. */
5035 gfc_internal_error ("expression_rank(): Two array specs");
5037 for (i = 0; i < ref->u.ar.dimen; i++)
5038 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
5039 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
5049 expression_shape (e);
5053 /* Resolve a variable expression. */
5056 resolve_variable (gfc_expr *e)
5063 if (e->symtree == NULL)
5065 sym = e->symtree->n.sym;
5067 /* If this is an associate-name, it may be parsed with an array reference
5068 in error even though the target is scalar. Fail directly in this case. */
5069 if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
5072 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
5073 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
5075 /* On the other hand, the parser may not have known this is an array;
5076 in this case, we have to add a FULL reference. */
5077 if (sym->assoc && sym->attr.dimension && !e->ref)
5079 e->ref = gfc_get_ref ();
5080 e->ref->type = REF_ARRAY;
5081 e->ref->u.ar.type = AR_FULL;
5082 e->ref->u.ar.dimen = 0;
5085 if (e->ref && resolve_ref (e) == FAILURE)
5088 if (sym->attr.flavor == FL_PROCEDURE
5089 && (!sym->attr.function
5090 || (sym->attr.function && sym->result
5091 && sym->result->attr.proc_pointer
5092 && !sym->result->attr.function)))
5094 e->ts.type = BT_PROCEDURE;
5095 goto resolve_procedure;
5098 if (sym->ts.type != BT_UNKNOWN)
5099 gfc_variable_attr (e, &e->ts);
5102 /* Must be a simple variable reference. */
5103 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
5108 if (check_assumed_size_reference (sym, e))
5111 /* Deal with forward references to entries during resolve_code, to
5112 satisfy, at least partially, 12.5.2.5. */
5113 if (gfc_current_ns->entries
5114 && current_entry_id == sym->entry_id
5117 && cs_base->current->op != EXEC_ENTRY)
5119 gfc_entry_list *entry;
5120 gfc_formal_arglist *formal;
5124 /* If the symbol is a dummy... */
5125 if (sym->attr.dummy && sym->ns == gfc_current_ns)
5127 entry = gfc_current_ns->entries;
5130 /* ...test if the symbol is a parameter of previous entries. */
5131 for (; entry && entry->id <= current_entry_id; entry = entry->next)
5132 for (formal = entry->sym->formal; formal; formal = formal->next)
5134 if (formal->sym && sym->name == formal->sym->name)
5138 /* If it has not been seen as a dummy, this is an error. */
5141 if (specification_expr)
5142 gfc_error ("Variable '%s', used in a specification expression"
5143 ", is referenced at %L before the ENTRY statement "
5144 "in which it is a parameter",
5145 sym->name, &cs_base->current->loc);
5147 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5148 "statement in which it is a parameter",
5149 sym->name, &cs_base->current->loc);
5154 /* Now do the same check on the specification expressions. */
5155 specification_expr = 1;
5156 if (sym->ts.type == BT_CHARACTER
5157 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
5161 for (n = 0; n < sym->as->rank; n++)
5163 specification_expr = 1;
5164 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
5166 specification_expr = 1;
5167 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
5170 specification_expr = 0;
5173 /* Update the symbol's entry level. */
5174 sym->entry_id = current_entry_id + 1;
5177 /* If a symbol has been host_associated mark it. This is used latter,
5178 to identify if aliasing is possible via host association. */
5179 if (sym->attr.flavor == FL_VARIABLE
5180 && gfc_current_ns->parent
5181 && (gfc_current_ns->parent == sym->ns
5182 || (gfc_current_ns->parent->parent
5183 && gfc_current_ns->parent->parent == sym->ns)))
5184 sym->attr.host_assoc = 1;
5187 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
5190 /* F2008, C617 and C1229. */
5191 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5192 && gfc_is_coindexed (e))
5194 gfc_ref *ref, *ref2 = NULL;
5196 for (ref = e->ref; ref; ref = ref->next)
5198 if (ref->type == REF_COMPONENT)
5200 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5204 for ( ; ref; ref = ref->next)
5205 if (ref->type == REF_COMPONENT)
5208 /* Expression itself is not coindexed object. */
5209 if (ref && e->ts.type == BT_CLASS)
5211 gfc_error ("Polymorphic subobject of coindexed object at %L",
5216 /* Expression itself is coindexed object. */
5220 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5221 for ( ; c; c = c->next)
5222 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5224 gfc_error ("Coindexed object with polymorphic allocatable "
5225 "subcomponent at %L", &e->where);
5236 /* Checks to see that the correct symbol has been host associated.
5237 The only situation where this arises is that in which a twice
5238 contained function is parsed after the host association is made.
5239 Therefore, on detecting this, change the symbol in the expression
5240 and convert the array reference into an actual arglist if the old
5241 symbol is a variable. */
5243 check_host_association (gfc_expr *e)
5245 gfc_symbol *sym, *old_sym;
5249 gfc_actual_arglist *arg, *tail = NULL;
5250 bool retval = e->expr_type == EXPR_FUNCTION;
5252 /* If the expression is the result of substitution in
5253 interface.c(gfc_extend_expr) because there is no way in
5254 which the host association can be wrong. */
5255 if (e->symtree == NULL
5256 || e->symtree->n.sym == NULL
5257 || e->user_operator)
5260 old_sym = e->symtree->n.sym;
5262 if (gfc_current_ns->parent
5263 && old_sym->ns != gfc_current_ns)
5265 /* Use the 'USE' name so that renamed module symbols are
5266 correctly handled. */
5267 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5269 if (sym && old_sym != sym
5270 && sym->ts.type == old_sym->ts.type
5271 && sym->attr.flavor == FL_PROCEDURE
5272 && sym->attr.contained)
5274 /* Clear the shape, since it might not be valid. */
5275 gfc_free_shape (&e->shape, e->rank);
5277 /* Give the expression the right symtree! */
5278 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5279 gcc_assert (st != NULL);
5281 if (old_sym->attr.flavor == FL_PROCEDURE
5282 || e->expr_type == EXPR_FUNCTION)
5284 /* Original was function so point to the new symbol, since
5285 the actual argument list is already attached to the
5287 e->value.function.esym = NULL;
5292 /* Original was variable so convert array references into
5293 an actual arglist. This does not need any checking now
5294 since resolve_function will take care of it. */
5295 e->value.function.actual = NULL;
5296 e->expr_type = EXPR_FUNCTION;
5299 /* Ambiguity will not arise if the array reference is not
5300 the last reference. */
5301 for (ref = e->ref; ref; ref = ref->next)
5302 if (ref->type == REF_ARRAY && ref->next == NULL)
5305 gcc_assert (ref->type == REF_ARRAY);
5307 /* Grab the start expressions from the array ref and
5308 copy them into actual arguments. */
5309 for (n = 0; n < ref->u.ar.dimen; n++)
5311 arg = gfc_get_actual_arglist ();
5312 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5313 if (e->value.function.actual == NULL)
5314 tail = e->value.function.actual = arg;
5322 /* Dump the reference list and set the rank. */
5323 gfc_free_ref_list (e->ref);
5325 e->rank = sym->as ? sym->as->rank : 0;
5328 gfc_resolve_expr (e);
5332 /* This might have changed! */
5333 return e->expr_type == EXPR_FUNCTION;
5338 gfc_resolve_character_operator (gfc_expr *e)
5340 gfc_expr *op1 = e->value.op.op1;
5341 gfc_expr *op2 = e->value.op.op2;
5342 gfc_expr *e1 = NULL;
5343 gfc_expr *e2 = NULL;
5345 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5347 if (op1->ts.u.cl && op1->ts.u.cl->length)
5348 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5349 else if (op1->expr_type == EXPR_CONSTANT)
5350 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5351 op1->value.character.length);
5353 if (op2->ts.u.cl && op2->ts.u.cl->length)
5354 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5355 else if (op2->expr_type == EXPR_CONSTANT)
5356 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5357 op2->value.character.length);
5359 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5364 e->ts.u.cl->length = gfc_add (e1, e2);
5365 e->ts.u.cl->length->ts.type = BT_INTEGER;
5366 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5367 gfc_simplify_expr (e->ts.u.cl->length, 0);
5368 gfc_resolve_expr (e->ts.u.cl->length);
5374 /* Ensure that an character expression has a charlen and, if possible, a
5375 length expression. */
5378 fixup_charlen (gfc_expr *e)
5380 /* The cases fall through so that changes in expression type and the need
5381 for multiple fixes are picked up. In all circumstances, a charlen should
5382 be available for the middle end to hang a backend_decl on. */
5383 switch (e->expr_type)
5386 gfc_resolve_character_operator (e);
5389 if (e->expr_type == EXPR_ARRAY)
5390 gfc_resolve_character_array_constructor (e);
5392 case EXPR_SUBSTRING:
5393 if (!e->ts.u.cl && e->ref)
5394 gfc_resolve_substring_charlen (e);
5398 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5405 /* Update an actual argument to include the passed-object for type-bound
5406 procedures at the right position. */
5408 static gfc_actual_arglist*
5409 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5412 gcc_assert (argpos > 0);
5416 gfc_actual_arglist* result;
5418 result = gfc_get_actual_arglist ();
5422 result->name = name;
5428 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5430 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5435 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5438 extract_compcall_passed_object (gfc_expr* e)
5442 gcc_assert (e->expr_type == EXPR_COMPCALL);
5444 if (e->value.compcall.base_object)
5445 po = gfc_copy_expr (e->value.compcall.base_object);
5448 po = gfc_get_expr ();
5449 po->expr_type = EXPR_VARIABLE;
5450 po->symtree = e->symtree;
5451 po->ref = gfc_copy_ref (e->ref);
5452 po->where = e->where;
5455 if (gfc_resolve_expr (po) == FAILURE)
5462 /* Update the arglist of an EXPR_COMPCALL expression to include the
5466 update_compcall_arglist (gfc_expr* e)
5469 gfc_typebound_proc* tbp;
5471 tbp = e->value.compcall.tbp;
5476 po = extract_compcall_passed_object (e);
5480 if (tbp->nopass || e->value.compcall.ignore_pass)
5486 gcc_assert (tbp->pass_arg_num > 0);
5487 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5495 /* Extract the passed object from a PPC call (a copy of it). */
5498 extract_ppc_passed_object (gfc_expr *e)
5503 po = gfc_get_expr ();
5504 po->expr_type = EXPR_VARIABLE;
5505 po->symtree = e->symtree;
5506 po->ref = gfc_copy_ref (e->ref);
5507 po->where = e->where;
5509 /* Remove PPC reference. */
5511 while ((*ref)->next)
5512 ref = &(*ref)->next;
5513 gfc_free_ref_list (*ref);
5516 if (gfc_resolve_expr (po) == FAILURE)
5523 /* Update the actual arglist of a procedure pointer component to include the
5527 update_ppc_arglist (gfc_expr* e)
5531 gfc_typebound_proc* tb;
5533 if (!gfc_is_proc_ptr_comp (e, &ppc))
5540 else if (tb->nopass)
5543 po = extract_ppc_passed_object (e);
5550 gfc_error ("Passed-object at %L must be scalar", &e->where);
5555 if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
5557 gfc_error ("Base object for procedure-pointer component call at %L is of"
5558 " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name);
5562 gcc_assert (tb->pass_arg_num > 0);
5563 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5571 /* Check that the object a TBP is called on is valid, i.e. it must not be
5572 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5575 check_typebound_baseobject (gfc_expr* e)
5578 gfc_try return_value = FAILURE;
5580 base = extract_compcall_passed_object (e);
5584 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5587 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5589 gfc_error ("Base object for type-bound procedure call at %L is of"
5590 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5594 /* F08:C1230. If the procedure called is NOPASS,
5595 the base object must be scalar. */
5596 if (e->value.compcall.tbp->nopass && base->rank > 0)
5598 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5599 " be scalar", &e->where);
5603 return_value = SUCCESS;
5606 gfc_free_expr (base);
5607 return return_value;
5611 /* Resolve a call to a type-bound procedure, either function or subroutine,
5612 statically from the data in an EXPR_COMPCALL expression. The adapted
5613 arglist and the target-procedure symtree are returned. */
5616 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5617 gfc_actual_arglist** actual)
5619 gcc_assert (e->expr_type == EXPR_COMPCALL);
5620 gcc_assert (!e->value.compcall.tbp->is_generic);
5622 /* Update the actual arglist for PASS. */
5623 if (update_compcall_arglist (e) == FAILURE)
5626 *actual = e->value.compcall.actual;
5627 *target = e->value.compcall.tbp->u.specific;
5629 gfc_free_ref_list (e->ref);
5631 e->value.compcall.actual = NULL;
5633 /* If we find a deferred typebound procedure, check for derived types
5634 that an over-riding typebound procedure has not been missed. */
5635 if (e->value.compcall.tbp->deferred
5636 && e->value.compcall.name
5637 && !e->value.compcall.tbp->non_overridable
5638 && e->value.compcall.base_object
5639 && e->value.compcall.base_object->ts.type == BT_DERIVED)
5642 gfc_symbol *derived;
5644 /* Use the derived type of the base_object. */
5645 derived = e->value.compcall.base_object->ts.u.derived;
5648 /* If necessary, go throught the inheritance chain. */
5649 while (!st && derived)
5651 /* Look for the typebound procedure 'name'. */
5652 if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
5653 st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
5654 e->value.compcall.name);
5656 derived = gfc_get_derived_super_type (derived);
5659 /* Now find the specific name in the derived type namespace. */
5660 if (st && st->n.tb && st->n.tb->u.specific)
5661 gfc_find_sym_tree (st->n.tb->u.specific->name,
5662 derived->ns, 1, &st);
5670 /* Get the ultimate declared type from an expression. In addition,
5671 return the last class/derived type reference and the copy of the
5672 reference list. If check_types is set true, derived types are
5673 identified as well as class references. */
5675 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5676 gfc_expr *e, bool check_types)
5678 gfc_symbol *declared;
5685 *new_ref = gfc_copy_ref (e->ref);
5687 for (ref = e->ref; ref; ref = ref->next)
5689 if (ref->type != REF_COMPONENT)
5692 if ((ref->u.c.component->ts.type == BT_CLASS
5693 || (check_types && ref->u.c.component->ts.type == BT_DERIVED))
5694 && ref->u.c.component->attr.flavor != FL_PROCEDURE)
5696 declared = ref->u.c.component->ts.u.derived;
5702 if (declared == NULL)
5703 declared = e->symtree->n.sym->ts.u.derived;
5709 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5710 which of the specific bindings (if any) matches the arglist and transform
5711 the expression into a call of that binding. */
5714 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5716 gfc_typebound_proc* genproc;
5717 const char* genname;
5719 gfc_symbol *derived;
5721 gcc_assert (e->expr_type == EXPR_COMPCALL);
5722 genname = e->value.compcall.name;
5723 genproc = e->value.compcall.tbp;
5725 if (!genproc->is_generic)
5728 /* Try the bindings on this type and in the inheritance hierarchy. */
5729 for (; genproc; genproc = genproc->overridden)
5733 gcc_assert (genproc->is_generic);
5734 for (g = genproc->u.generic; g; g = g->next)
5737 gfc_actual_arglist* args;
5740 gcc_assert (g->specific);
5742 if (g->specific->error)
5745 target = g->specific->u.specific->n.sym;
5747 /* Get the right arglist by handling PASS/NOPASS. */
5748 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5749 if (!g->specific->nopass)
5752 po = extract_compcall_passed_object (e);
5756 gcc_assert (g->specific->pass_arg_num > 0);
5757 gcc_assert (!g->specific->error);
5758 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5759 g->specific->pass_arg);
5761 resolve_actual_arglist (args, target->attr.proc,
5762 is_external_proc (target) && !target->formal);
5764 /* Check if this arglist matches the formal. */
5765 matches = gfc_arglist_matches_symbol (&args, target);
5767 /* Clean up and break out of the loop if we've found it. */
5768 gfc_free_actual_arglist (args);
5771 e->value.compcall.tbp = g->specific;
5772 genname = g->specific_st->name;
5773 /* Pass along the name for CLASS methods, where the vtab
5774 procedure pointer component has to be referenced. */
5782 /* Nothing matching found! */
5783 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5784 " '%s' at %L", genname, &e->where);
5788 /* Make sure that we have the right specific instance for the name. */
5789 derived = get_declared_from_expr (NULL, NULL, e, true);
5791 st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
5793 e->value.compcall.tbp = st->n.tb;
5799 /* Resolve a call to a type-bound subroutine. */
5802 resolve_typebound_call (gfc_code* c, const char **name)
5804 gfc_actual_arglist* newactual;
5805 gfc_symtree* target;
5807 /* Check that's really a SUBROUTINE. */
5808 if (!c->expr1->value.compcall.tbp->subroutine)
5810 gfc_error ("'%s' at %L should be a SUBROUTINE",
5811 c->expr1->value.compcall.name, &c->loc);
5815 if (check_typebound_baseobject (c->expr1) == FAILURE)
5818 /* Pass along the name for CLASS methods, where the vtab
5819 procedure pointer component has to be referenced. */
5821 *name = c->expr1->value.compcall.name;
5823 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5826 /* Transform into an ordinary EXEC_CALL for now. */
5828 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5831 c->ext.actual = newactual;
5832 c->symtree = target;
5833 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5835 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5837 gfc_free_expr (c->expr1);
5838 c->expr1 = gfc_get_expr ();
5839 c->expr1->expr_type = EXPR_FUNCTION;
5840 c->expr1->symtree = target;
5841 c->expr1->where = c->loc;
5843 return resolve_call (c);
5847 /* Resolve a component-call expression. */
5849 resolve_compcall (gfc_expr* e, const char **name)
5851 gfc_actual_arglist* newactual;
5852 gfc_symtree* target;
5854 /* Check that's really a FUNCTION. */
5855 if (!e->value.compcall.tbp->function)
5857 gfc_error ("'%s' at %L should be a FUNCTION",
5858 e->value.compcall.name, &e->where);
5862 /* These must not be assign-calls! */
5863 gcc_assert (!e->value.compcall.assign);
5865 if (check_typebound_baseobject (e) == FAILURE)
5868 /* Pass along the name for CLASS methods, where the vtab
5869 procedure pointer component has to be referenced. */
5871 *name = e->value.compcall.name;
5873 if (resolve_typebound_generic_call (e, name) == FAILURE)
5875 gcc_assert (!e->value.compcall.tbp->is_generic);
5877 /* Take the rank from the function's symbol. */
5878 if (e->value.compcall.tbp->u.specific->n.sym->as)
5879 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5881 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5882 arglist to the TBP's binding target. */
5884 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5887 e->value.function.actual = newactual;
5888 e->value.function.name = NULL;
5889 e->value.function.esym = target->n.sym;
5890 e->value.function.isym = NULL;
5891 e->symtree = target;
5892 e->ts = target->n.sym->ts;
5893 e->expr_type = EXPR_FUNCTION;
5895 /* Resolution is not necessary if this is a class subroutine; this
5896 function only has to identify the specific proc. Resolution of
5897 the call will be done next in resolve_typebound_call. */
5898 return gfc_resolve_expr (e);
5903 /* Resolve a typebound function, or 'method'. First separate all
5904 the non-CLASS references by calling resolve_compcall directly. */
5907 resolve_typebound_function (gfc_expr* e)
5909 gfc_symbol *declared;
5921 /* Deal with typebound operators for CLASS objects. */
5922 expr = e->value.compcall.base_object;
5923 overridable = !e->value.compcall.tbp->non_overridable;
5924 if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
5926 /* If the base_object is not a variable, the corresponding actual
5927 argument expression must be stored in e->base_expression so
5928 that the corresponding tree temporary can be used as the base
5929 object in gfc_conv_procedure_call. */
5930 if (expr->expr_type != EXPR_VARIABLE)
5932 gfc_actual_arglist *args;
5934 for (args= e->value.function.actual; args; args = args->next)
5936 if (expr == args->expr)
5941 /* Since the typebound operators are generic, we have to ensure
5942 that any delays in resolution are corrected and that the vtab
5945 declared = ts.u.derived;
5946 c = gfc_find_component (declared, "_vptr", true, true);
5947 if (c->ts.u.derived == NULL)
5948 c->ts.u.derived = gfc_find_derived_vtab (declared);
5950 if (resolve_compcall (e, &name) == FAILURE)
5953 /* Use the generic name if it is there. */
5954 name = name ? name : e->value.function.esym->name;
5955 e->symtree = expr->symtree;
5956 e->ref = gfc_copy_ref (expr->ref);
5957 get_declared_from_expr (&class_ref, NULL, e, false);
5959 /* Trim away the extraneous references that emerge from nested
5960 use of interface.c (extend_expr). */
5961 if (class_ref && class_ref->next)
5963 gfc_free_ref_list (class_ref->next);
5964 class_ref->next = NULL;
5966 else if (e->ref && !class_ref)
5968 gfc_free_ref_list (e->ref);
5972 gfc_add_vptr_component (e);
5973 gfc_add_component_ref (e, name);
5974 e->value.function.esym = NULL;
5975 if (expr->expr_type != EXPR_VARIABLE)
5976 e->base_expr = expr;
5981 return resolve_compcall (e, NULL);
5983 if (resolve_ref (e) == FAILURE)
5986 /* Get the CLASS declared type. */
5987 declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
5989 /* Weed out cases of the ultimate component being a derived type. */
5990 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5991 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5993 gfc_free_ref_list (new_ref);
5994 return resolve_compcall (e, NULL);
5997 c = gfc_find_component (declared, "_data", true, true);
5998 declared = c->ts.u.derived;
6000 /* Treat the call as if it is a typebound procedure, in order to roll
6001 out the correct name for the specific function. */
6002 if (resolve_compcall (e, &name) == FAILURE)
6008 /* Convert the expression to a procedure pointer component call. */
6009 e->value.function.esym = NULL;
6015 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6016 gfc_add_vptr_component (e);
6017 gfc_add_component_ref (e, name);
6019 /* Recover the typespec for the expression. This is really only
6020 necessary for generic procedures, where the additional call
6021 to gfc_add_component_ref seems to throw the collection of the
6022 correct typespec. */
6029 /* Resolve a typebound subroutine, or 'method'. First separate all
6030 the non-CLASS references by calling resolve_typebound_call
6034 resolve_typebound_subroutine (gfc_code *code)
6036 gfc_symbol *declared;
6046 st = code->expr1->symtree;
6048 /* Deal with typebound operators for CLASS objects. */
6049 expr = code->expr1->value.compcall.base_object;
6050 overridable = !code->expr1->value.compcall.tbp->non_overridable;
6051 if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
6053 /* If the base_object is not a variable, the corresponding actual
6054 argument expression must be stored in e->base_expression so
6055 that the corresponding tree temporary can be used as the base
6056 object in gfc_conv_procedure_call. */
6057 if (expr->expr_type != EXPR_VARIABLE)
6059 gfc_actual_arglist *args;
6061 args= code->expr1->value.function.actual;
6062 for (; args; args = args->next)
6063 if (expr == args->expr)
6067 /* Since the typebound operators are generic, we have to ensure
6068 that any delays in resolution are corrected and that the vtab
6070 declared = expr->ts.u.derived;
6071 c = gfc_find_component (declared, "_vptr", true, true);
6072 if (c->ts.u.derived == NULL)
6073 c->ts.u.derived = gfc_find_derived_vtab (declared);
6075 if (resolve_typebound_call (code, &name) == FAILURE)
6078 /* Use the generic name if it is there. */
6079 name = name ? name : code->expr1->value.function.esym->name;
6080 code->expr1->symtree = expr->symtree;
6081 code->expr1->ref = gfc_copy_ref (expr->ref);
6083 /* Trim away the extraneous references that emerge from nested
6084 use of interface.c (extend_expr). */
6085 get_declared_from_expr (&class_ref, NULL, code->expr1, false);
6086 if (class_ref && class_ref->next)
6088 gfc_free_ref_list (class_ref->next);
6089 class_ref->next = NULL;
6091 else if (code->expr1->ref && !class_ref)
6093 gfc_free_ref_list (code->expr1->ref);
6094 code->expr1->ref = NULL;
6097 /* Now use the procedure in the vtable. */
6098 gfc_add_vptr_component (code->expr1);
6099 gfc_add_component_ref (code->expr1, name);
6100 code->expr1->value.function.esym = NULL;
6101 if (expr->expr_type != EXPR_VARIABLE)
6102 code->expr1->base_expr = expr;
6107 return resolve_typebound_call (code, NULL);
6109 if (resolve_ref (code->expr1) == FAILURE)
6112 /* Get the CLASS declared type. */
6113 get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
6115 /* Weed out cases of the ultimate component being a derived type. */
6116 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
6117 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
6119 gfc_free_ref_list (new_ref);
6120 return resolve_typebound_call (code, NULL);
6123 if (resolve_typebound_call (code, &name) == FAILURE)
6125 ts = code->expr1->ts;
6129 /* Convert the expression to a procedure pointer component call. */
6130 code->expr1->value.function.esym = NULL;
6131 code->expr1->symtree = st;
6134 code->expr1->ref = new_ref;
6136 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6137 gfc_add_vptr_component (code->expr1);
6138 gfc_add_component_ref (code->expr1, name);
6140 /* Recover the typespec for the expression. This is really only
6141 necessary for generic procedures, where the additional call
6142 to gfc_add_component_ref seems to throw the collection of the
6143 correct typespec. */
6144 code->expr1->ts = ts;
6151 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6154 resolve_ppc_call (gfc_code* c)
6156 gfc_component *comp;
6159 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
6162 c->resolved_sym = c->expr1->symtree->n.sym;
6163 c->expr1->expr_type = EXPR_VARIABLE;
6165 if (!comp->attr.subroutine)
6166 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
6168 if (resolve_ref (c->expr1) == FAILURE)
6171 if (update_ppc_arglist (c->expr1) == FAILURE)
6174 c->ext.actual = c->expr1->value.compcall.actual;
6176 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
6177 comp->formal == NULL) == FAILURE)
6180 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
6186 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6189 resolve_expr_ppc (gfc_expr* e)
6191 gfc_component *comp;
6194 b = gfc_is_proc_ptr_comp (e, &comp);
6197 /* Convert to EXPR_FUNCTION. */
6198 e->expr_type = EXPR_FUNCTION;
6199 e->value.function.isym = NULL;
6200 e->value.function.actual = e->value.compcall.actual;
6202 if (comp->as != NULL)
6203 e->rank = comp->as->rank;
6205 if (!comp->attr.function)
6206 gfc_add_function (&comp->attr, comp->name, &e->where);
6208 if (resolve_ref (e) == FAILURE)
6211 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
6212 comp->formal == NULL) == FAILURE)
6215 if (update_ppc_arglist (e) == FAILURE)
6218 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
6225 gfc_is_expandable_expr (gfc_expr *e)
6227 gfc_constructor *con;
6229 if (e->expr_type == EXPR_ARRAY)
6231 /* Traverse the constructor looking for variables that are flavor
6232 parameter. Parameters must be expanded since they are fully used at
6234 con = gfc_constructor_first (e->value.constructor);
6235 for (; con; con = gfc_constructor_next (con))
6237 if (con->expr->expr_type == EXPR_VARIABLE
6238 && con->expr->symtree
6239 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6240 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
6242 if (con->expr->expr_type == EXPR_ARRAY
6243 && gfc_is_expandable_expr (con->expr))
6251 /* Resolve an expression. That is, make sure that types of operands agree
6252 with their operators, intrinsic operators are converted to function calls
6253 for overloaded types and unresolved function references are resolved. */
6256 gfc_resolve_expr (gfc_expr *e)
6264 /* inquiry_argument only applies to variables. */
6265 inquiry_save = inquiry_argument;
6266 if (e->expr_type != EXPR_VARIABLE)
6267 inquiry_argument = false;
6269 switch (e->expr_type)
6272 t = resolve_operator (e);
6278 if (check_host_association (e))
6279 t = resolve_function (e);
6282 t = resolve_variable (e);
6284 expression_rank (e);
6287 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6288 && e->ref->type != REF_SUBSTRING)
6289 gfc_resolve_substring_charlen (e);
6294 t = resolve_typebound_function (e);
6297 case EXPR_SUBSTRING:
6298 t = resolve_ref (e);
6307 t = resolve_expr_ppc (e);
6312 if (resolve_ref (e) == FAILURE)
6315 t = gfc_resolve_array_constructor (e);
6316 /* Also try to expand a constructor. */
6319 expression_rank (e);
6320 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6321 gfc_expand_constructor (e, false);
6324 /* This provides the opportunity for the length of constructors with
6325 character valued function elements to propagate the string length
6326 to the expression. */
6327 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6329 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6330 here rather then add a duplicate test for it above. */
6331 gfc_expand_constructor (e, false);
6332 t = gfc_resolve_character_array_constructor (e);
6337 case EXPR_STRUCTURE:
6338 t = resolve_ref (e);
6342 t = resolve_structure_cons (e, 0);
6346 t = gfc_simplify_expr (e, 0);
6350 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6353 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6356 inquiry_argument = inquiry_save;
6362 /* Resolve an expression from an iterator. They must be scalar and have
6363 INTEGER or (optionally) REAL type. */
6366 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6367 const char *name_msgid)
6369 if (gfc_resolve_expr (expr) == FAILURE)
6372 if (expr->rank != 0)
6374 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6378 if (expr->ts.type != BT_INTEGER)
6380 if (expr->ts.type == BT_REAL)
6383 return gfc_notify_std (GFC_STD_F95_DEL,
6384 "Deleted feature: %s at %L must be integer",
6385 _(name_msgid), &expr->where);
6388 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6395 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6403 /* Resolve the expressions in an iterator structure. If REAL_OK is
6404 false allow only INTEGER type iterators, otherwise allow REAL types. */
6407 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6409 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6413 if (gfc_check_vardef_context (iter->var, false, false, _("iterator variable"))
6417 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6418 "Start expression in DO loop") == FAILURE)
6421 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6422 "End expression in DO loop") == FAILURE)
6425 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6426 "Step expression in DO loop") == FAILURE)
6429 if (iter->step->expr_type == EXPR_CONSTANT)
6431 if ((iter->step->ts.type == BT_INTEGER
6432 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6433 || (iter->step->ts.type == BT_REAL
6434 && mpfr_sgn (iter->step->value.real) == 0))
6436 gfc_error ("Step expression in DO loop at %L cannot be zero",
6437 &iter->step->where);
6442 /* Convert start, end, and step to the same type as var. */
6443 if (iter->start->ts.kind != iter->var->ts.kind
6444 || iter->start->ts.type != iter->var->ts.type)
6445 gfc_convert_type (iter->start, &iter->var->ts, 2);
6447 if (iter->end->ts.kind != iter->var->ts.kind
6448 || iter->end->ts.type != iter->var->ts.type)
6449 gfc_convert_type (iter->end, &iter->var->ts, 2);
6451 if (iter->step->ts.kind != iter->var->ts.kind
6452 || iter->step->ts.type != iter->var->ts.type)
6453 gfc_convert_type (iter->step, &iter->var->ts, 2);
6455 if (iter->start->expr_type == EXPR_CONSTANT
6456 && iter->end->expr_type == EXPR_CONSTANT
6457 && iter->step->expr_type == EXPR_CONSTANT)
6460 if (iter->start->ts.type == BT_INTEGER)
6462 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6463 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6467 sgn = mpfr_sgn (iter->step->value.real);
6468 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6470 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6471 gfc_warning ("DO loop at %L will be executed zero times",
6472 &iter->step->where);
6479 /* Traversal function for find_forall_index. f == 2 signals that
6480 that variable itself is not to be checked - only the references. */
6483 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6485 if (expr->expr_type != EXPR_VARIABLE)
6488 /* A scalar assignment */
6489 if (!expr->ref || *f == 1)
6491 if (expr->symtree->n.sym == sym)
6503 /* Check whether the FORALL index appears in the expression or not.
6504 Returns SUCCESS if SYM is found in EXPR. */
6507 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6509 if (gfc_traverse_expr (expr, sym, forall_index, f))
6516 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6517 to be a scalar INTEGER variable. The subscripts and stride are scalar
6518 INTEGERs, and if stride is a constant it must be nonzero.
6519 Furthermore "A subscript or stride in a forall-triplet-spec shall
6520 not contain a reference to any index-name in the
6521 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6524 resolve_forall_iterators (gfc_forall_iterator *it)
6526 gfc_forall_iterator *iter, *iter2;
6528 for (iter = it; iter; iter = iter->next)
6530 if (gfc_resolve_expr (iter->var) == SUCCESS
6531 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6532 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6535 if (gfc_resolve_expr (iter->start) == SUCCESS
6536 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6537 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6538 &iter->start->where);
6539 if (iter->var->ts.kind != iter->start->ts.kind)
6540 gfc_convert_type (iter->start, &iter->var->ts, 1);
6542 if (gfc_resolve_expr (iter->end) == SUCCESS
6543 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6544 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6546 if (iter->var->ts.kind != iter->end->ts.kind)
6547 gfc_convert_type (iter->end, &iter->var->ts, 1);
6549 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6551 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6552 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6553 &iter->stride->where, "INTEGER");
6555 if (iter->stride->expr_type == EXPR_CONSTANT
6556 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6557 gfc_error ("FORALL stride expression at %L cannot be zero",
6558 &iter->stride->where);
6560 if (iter->var->ts.kind != iter->stride->ts.kind)
6561 gfc_convert_type (iter->stride, &iter->var->ts, 1);
6564 for (iter = it; iter; iter = iter->next)
6565 for (iter2 = iter; iter2; iter2 = iter2->next)
6567 if (find_forall_index (iter2->start,
6568 iter->var->symtree->n.sym, 0) == SUCCESS
6569 || find_forall_index (iter2->end,
6570 iter->var->symtree->n.sym, 0) == SUCCESS
6571 || find_forall_index (iter2->stride,
6572 iter->var->symtree->n.sym, 0) == SUCCESS)
6573 gfc_error ("FORALL index '%s' may not appear in triplet "
6574 "specification at %L", iter->var->symtree->name,
6575 &iter2->start->where);
6580 /* Given a pointer to a symbol that is a derived type, see if it's
6581 inaccessible, i.e. if it's defined in another module and the components are
6582 PRIVATE. The search is recursive if necessary. Returns zero if no
6583 inaccessible components are found, nonzero otherwise. */
6586 derived_inaccessible (gfc_symbol *sym)
6590 if (sym->attr.use_assoc && sym->attr.private_comp)
6593 for (c = sym->components; c; c = c->next)
6595 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6603 /* Resolve the argument of a deallocate expression. The expression must be
6604 a pointer or a full array. */
6607 resolve_deallocate_expr (gfc_expr *e)
6609 symbol_attribute attr;
6610 int allocatable, pointer;
6615 if (gfc_resolve_expr (e) == FAILURE)
6618 if (e->expr_type != EXPR_VARIABLE)
6621 sym = e->symtree->n.sym;
6623 if (sym->ts.type == BT_CLASS)
6625 allocatable = CLASS_DATA (sym)->attr.allocatable;
6626 pointer = CLASS_DATA (sym)->attr.class_pointer;
6630 allocatable = sym->attr.allocatable;
6631 pointer = sym->attr.pointer;
6633 for (ref = e->ref; ref; ref = ref->next)
6638 if (ref->u.ar.type != AR_FULL
6639 && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
6640 && ref->u.ar.codimen && gfc_ref_this_image (ref)))
6645 c = ref->u.c.component;
6646 if (c->ts.type == BT_CLASS)
6648 allocatable = CLASS_DATA (c)->attr.allocatable;
6649 pointer = CLASS_DATA (c)->attr.class_pointer;
6653 allocatable = c->attr.allocatable;
6654 pointer = c->attr.pointer;
6664 attr = gfc_expr_attr (e);
6666 if (allocatable == 0 && attr.pointer == 0)
6669 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6675 if (gfc_is_coindexed (e))
6677 gfc_error ("Coindexed allocatable object at %L", &e->where);
6682 && gfc_check_vardef_context (e, true, true, _("DEALLOCATE object"))
6685 if (gfc_check_vardef_context (e, false, true, _("DEALLOCATE object"))
6693 /* Returns true if the expression e contains a reference to the symbol sym. */
6695 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6697 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6704 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6706 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6710 /* Given the expression node e for an allocatable/pointer of derived type to be
6711 allocated, get the expression node to be initialized afterwards (needed for
6712 derived types with default initializers, and derived types with allocatable
6713 components that need nullification.) */
6716 gfc_expr_to_initialize (gfc_expr *e)
6722 result = gfc_copy_expr (e);
6724 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6725 for (ref = result->ref; ref; ref = ref->next)
6726 if (ref->type == REF_ARRAY && ref->next == NULL)
6728 ref->u.ar.type = AR_FULL;
6730 for (i = 0; i < ref->u.ar.dimen; i++)
6731 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6736 gfc_free_shape (&result->shape, result->rank);
6738 /* Recalculate rank, shape, etc. */
6739 gfc_resolve_expr (result);
6744 /* If the last ref of an expression is an array ref, return a copy of the
6745 expression with that one removed. Otherwise, a copy of the original
6746 expression. This is used for allocate-expressions and pointer assignment
6747 LHS, where there may be an array specification that needs to be stripped
6748 off when using gfc_check_vardef_context. */
6751 remove_last_array_ref (gfc_expr* e)
6756 e2 = gfc_copy_expr (e);
6757 for (r = &e2->ref; *r; r = &(*r)->next)
6758 if ((*r)->type == REF_ARRAY && !(*r)->next)
6760 gfc_free_ref_list (*r);
6769 /* Used in resolve_allocate_expr to check that a allocation-object and
6770 a source-expr are conformable. This does not catch all possible
6771 cases; in particular a runtime checking is needed. */
6774 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6777 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6779 /* First compare rank. */
6780 if (tail && e1->rank != tail->u.ar.as->rank)
6782 gfc_error ("Source-expr at %L must be scalar or have the "
6783 "same rank as the allocate-object at %L",
6784 &e1->where, &e2->where);
6795 for (i = 0; i < e1->rank; i++)
6797 if (tail->u.ar.end[i])
6799 mpz_set (s, tail->u.ar.end[i]->value.integer);
6800 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6801 mpz_add_ui (s, s, 1);
6805 mpz_set (s, tail->u.ar.start[i]->value.integer);
6808 if (mpz_cmp (e1->shape[i], s) != 0)
6810 gfc_error ("Source-expr at %L and allocate-object at %L must "
6811 "have the same shape", &e1->where, &e2->where);
6824 /* Resolve the expression in an ALLOCATE statement, doing the additional
6825 checks to see whether the expression is OK or not. The expression must
6826 have a trailing array reference that gives the size of the array. */
6829 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6831 int i, pointer, allocatable, dimension, is_abstract;
6834 symbol_attribute attr;
6835 gfc_ref *ref, *ref2;
6838 gfc_symbol *sym = NULL;
6843 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6844 checking of coarrays. */
6845 for (ref = e->ref; ref; ref = ref->next)
6846 if (ref->next == NULL)
6849 if (ref && ref->type == REF_ARRAY)
6850 ref->u.ar.in_allocate = true;
6852 if (gfc_resolve_expr (e) == FAILURE)
6855 /* Make sure the expression is allocatable or a pointer. If it is
6856 pointer, the next-to-last reference must be a pointer. */
6860 sym = e->symtree->n.sym;
6862 /* Check whether ultimate component is abstract and CLASS. */
6865 if (e->expr_type != EXPR_VARIABLE)
6868 attr = gfc_expr_attr (e);
6869 pointer = attr.pointer;
6870 dimension = attr.dimension;
6871 codimension = attr.codimension;
6875 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
6877 allocatable = CLASS_DATA (sym)->attr.allocatable;
6878 pointer = CLASS_DATA (sym)->attr.class_pointer;
6879 dimension = CLASS_DATA (sym)->attr.dimension;
6880 codimension = CLASS_DATA (sym)->attr.codimension;
6881 is_abstract = CLASS_DATA (sym)->attr.abstract;
6885 allocatable = sym->attr.allocatable;
6886 pointer = sym->attr.pointer;
6887 dimension = sym->attr.dimension;
6888 codimension = sym->attr.codimension;
6893 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6898 if (ref->u.ar.codimen > 0)
6901 for (n = ref->u.ar.dimen;
6902 n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
6903 if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
6910 if (ref->next != NULL)
6918 gfc_error ("Coindexed allocatable object at %L",
6923 c = ref->u.c.component;
6924 if (c->ts.type == BT_CLASS)
6926 allocatable = CLASS_DATA (c)->attr.allocatable;
6927 pointer = CLASS_DATA (c)->attr.class_pointer;
6928 dimension = CLASS_DATA (c)->attr.dimension;
6929 codimension = CLASS_DATA (c)->attr.codimension;
6930 is_abstract = CLASS_DATA (c)->attr.abstract;
6934 allocatable = c->attr.allocatable;
6935 pointer = c->attr.pointer;
6936 dimension = c->attr.dimension;
6937 codimension = c->attr.codimension;
6938 is_abstract = c->attr.abstract;
6950 if (allocatable == 0 && pointer == 0)
6952 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6957 /* Some checks for the SOURCE tag. */
6960 /* Check F03:C631. */
6961 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6963 gfc_error ("Type of entity at %L is type incompatible with "
6964 "source-expr at %L", &e->where, &code->expr3->where);
6968 /* Check F03:C632 and restriction following Note 6.18. */
6969 if (code->expr3->rank > 0
6970 && conformable_arrays (code->expr3, e) == FAILURE)
6973 /* Check F03:C633. */
6974 if (code->expr3->ts.kind != e->ts.kind)
6976 gfc_error ("The allocate-object at %L and the source-expr at %L "
6977 "shall have the same kind type parameter",
6978 &e->where, &code->expr3->where);
6982 /* Check F2008, C642. */
6983 if (code->expr3->ts.type == BT_DERIVED
6984 && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
6985 || (code->expr3->ts.u.derived->from_intmod
6986 == INTMOD_ISO_FORTRAN_ENV
6987 && code->expr3->ts.u.derived->intmod_sym_id
6988 == ISOFORTRAN_LOCK_TYPE)))
6990 gfc_error ("The source-expr at %L shall neither be of type "
6991 "LOCK_TYPE nor have a LOCK_TYPE component if "
6992 "allocate-object at %L is a coarray",
6993 &code->expr3->where, &e->where);
6998 /* Check F08:C629. */
6999 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
7002 gcc_assert (e->ts.type == BT_CLASS);
7003 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7004 "type-spec or source-expr", sym->name, &e->where);
7008 if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred)
7010 int cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
7011 code->ext.alloc.ts.u.cl->length);
7012 if (cmp == 1 || cmp == -1 || cmp == -3)
7014 gfc_error ("Allocating %s at %L with type-spec requires the same "
7015 "character-length parameter as in the declaration",
7016 sym->name, &e->where);
7021 /* In the variable definition context checks, gfc_expr_attr is used
7022 on the expression. This is fooled by the array specification
7023 present in e, thus we have to eliminate that one temporarily. */
7024 e2 = remove_last_array_ref (e);
7026 if (t == SUCCESS && pointer)
7027 t = gfc_check_vardef_context (e2, true, true, _("ALLOCATE object"));
7029 t = gfc_check_vardef_context (e2, false, true, _("ALLOCATE object"));
7034 if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
7035 && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
7037 /* For class arrays, the initialization with SOURCE is done
7038 using _copy and trans_call. It is convenient to exploit that
7039 when the allocated type is different from the declared type but
7040 no SOURCE exists by setting expr3. */
7041 code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
7043 else if (!code->expr3)
7045 /* Set up default initializer if needed. */
7049 if (code->ext.alloc.ts.type == BT_DERIVED)
7050 ts = code->ext.alloc.ts;
7054 if (ts.type == BT_CLASS)
7055 ts = ts.u.derived->components->ts;
7057 if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
7059 gfc_code *init_st = gfc_get_code ();
7060 init_st->loc = code->loc;
7061 init_st->op = EXEC_INIT_ASSIGN;
7062 init_st->expr1 = gfc_expr_to_initialize (e);
7063 init_st->expr2 = init_e;
7064 init_st->next = code->next;
7065 code->next = init_st;
7068 else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
7070 /* Default initialization via MOLD (non-polymorphic). */
7071 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
7072 gfc_resolve_expr (rhs);
7073 gfc_free_expr (code->expr3);
7077 if (e->ts.type == BT_CLASS)
7079 /* Make sure the vtab symbol is present when
7080 the module variables are generated. */
7081 gfc_typespec ts = e->ts;
7083 ts = code->expr3->ts;
7084 else if (code->ext.alloc.ts.type == BT_DERIVED)
7085 ts = code->ext.alloc.ts;
7086 gfc_find_derived_vtab (ts.u.derived);
7088 e = gfc_expr_to_initialize (e);
7091 if (dimension == 0 && codimension == 0)
7094 /* Make sure the last reference node is an array specifiction. */
7096 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
7097 || (dimension && ref2->u.ar.dimen == 0))
7099 gfc_error ("Array specification required in ALLOCATE statement "
7100 "at %L", &e->where);
7104 /* Make sure that the array section reference makes sense in the
7105 context of an ALLOCATE specification. */
7110 for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
7111 if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
7113 gfc_error ("Coarray specification required in ALLOCATE statement "
7114 "at %L", &e->where);
7118 for (i = 0; i < ar->dimen; i++)
7120 if (ref2->u.ar.type == AR_ELEMENT)
7123 switch (ar->dimen_type[i])
7129 if (ar->start[i] != NULL
7130 && ar->end[i] != NULL
7131 && ar->stride[i] == NULL)
7134 /* Fall Through... */
7139 case DIMEN_THIS_IMAGE:
7140 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7146 for (a = code->ext.alloc.list; a; a = a->next)
7148 sym = a->expr->symtree->n.sym;
7150 /* TODO - check derived type components. */
7151 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
7154 if ((ar->start[i] != NULL
7155 && gfc_find_sym_in_expr (sym, ar->start[i]))
7156 || (ar->end[i] != NULL
7157 && gfc_find_sym_in_expr (sym, ar->end[i])))
7159 gfc_error ("'%s' must not appear in the array specification at "
7160 "%L in the same ALLOCATE statement where it is "
7161 "itself allocated", sym->name, &ar->where);
7167 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
7169 if (ar->dimen_type[i] == DIMEN_ELEMENT
7170 || ar->dimen_type[i] == DIMEN_RANGE)
7172 if (i == (ar->dimen + ar->codimen - 1))
7174 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7175 "statement at %L", &e->where);
7181 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
7182 && ar->stride[i] == NULL)
7185 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7198 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
7200 gfc_expr *stat, *errmsg, *pe, *qe;
7201 gfc_alloc *a, *p, *q;
7204 errmsg = code->expr2;
7206 /* Check the stat variable. */
7209 gfc_check_vardef_context (stat, false, false, _("STAT variable"));
7211 if ((stat->ts.type != BT_INTEGER
7212 && !(stat->ref && (stat->ref->type == REF_ARRAY
7213 || stat->ref->type == REF_COMPONENT)))
7215 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7216 "variable", &stat->where);
7218 for (p = code->ext.alloc.list; p; p = p->next)
7219 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
7221 gfc_ref *ref1, *ref2;
7224 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
7225 ref1 = ref1->next, ref2 = ref2->next)
7227 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7229 if (ref1->u.c.component->name != ref2->u.c.component->name)
7238 gfc_error ("Stat-variable at %L shall not be %sd within "
7239 "the same %s statement", &stat->where, fcn, fcn);
7245 /* Check the errmsg variable. */
7249 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7252 gfc_check_vardef_context (errmsg, false, false, _("ERRMSG variable"));
7254 if ((errmsg->ts.type != BT_CHARACTER
7256 && (errmsg->ref->type == REF_ARRAY
7257 || errmsg->ref->type == REF_COMPONENT)))
7258 || errmsg->rank > 0 )
7259 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7260 "variable", &errmsg->where);
7262 for (p = code->ext.alloc.list; p; p = p->next)
7263 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
7265 gfc_ref *ref1, *ref2;
7268 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
7269 ref1 = ref1->next, ref2 = ref2->next)
7271 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7273 if (ref1->u.c.component->name != ref2->u.c.component->name)
7282 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7283 "the same %s statement", &errmsg->where, fcn, fcn);
7289 /* Check that an allocate-object appears only once in the statement.
7290 FIXME: Checking derived types is disabled. */
7291 for (p = code->ext.alloc.list; p; p = p->next)
7294 for (q = p->next; q; q = q->next)
7297 if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
7299 /* This is a potential collision. */
7300 gfc_ref *pr = pe->ref;
7301 gfc_ref *qr = qe->ref;
7303 /* Follow the references until
7304 a) They start to differ, in which case there is no error;
7305 you can deallocate a%b and a%c in a single statement
7306 b) Both of them stop, which is an error
7307 c) One of them stops, which is also an error. */
7310 if (pr == NULL && qr == NULL)
7312 gfc_error ("Allocate-object at %L also appears at %L",
7313 &pe->where, &qe->where);
7316 else if (pr != NULL && qr == NULL)
7318 gfc_error ("Allocate-object at %L is subobject of"
7319 " object at %L", &pe->where, &qe->where);
7322 else if (pr == NULL && qr != NULL)
7324 gfc_error ("Allocate-object at %L is subobject of"
7325 " object at %L", &qe->where, &pe->where);
7328 /* Here, pr != NULL && qr != NULL */
7329 gcc_assert(pr->type == qr->type);
7330 if (pr->type == REF_ARRAY)
7332 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7334 gcc_assert (qr->type == REF_ARRAY);
7336 if (pr->next && qr->next)
7338 gfc_array_ref *par = &(pr->u.ar);
7339 gfc_array_ref *qar = &(qr->u.ar);
7340 if (gfc_dep_compare_expr (par->start[0],
7341 qar->start[0]) != 0)
7347 if (pr->u.c.component->name != qr->u.c.component->name)
7358 if (strcmp (fcn, "ALLOCATE") == 0)
7360 for (a = code->ext.alloc.list; a; a = a->next)
7361 resolve_allocate_expr (a->expr, code);
7365 for (a = code->ext.alloc.list; a; a = a->next)
7366 resolve_deallocate_expr (a->expr);
7371 /************ SELECT CASE resolution subroutines ************/
7373 /* Callback function for our mergesort variant. Determines interval
7374 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7375 op1 > op2. Assumes we're not dealing with the default case.
7376 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7377 There are nine situations to check. */
7380 compare_cases (const gfc_case *op1, const gfc_case *op2)
7384 if (op1->low == NULL) /* op1 = (:L) */
7386 /* op2 = (:N), so overlap. */
7388 /* op2 = (M:) or (M:N), L < M */
7389 if (op2->low != NULL
7390 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7393 else if (op1->high == NULL) /* op1 = (K:) */
7395 /* op2 = (M:), so overlap. */
7397 /* op2 = (:N) or (M:N), K > N */
7398 if (op2->high != NULL
7399 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7402 else /* op1 = (K:L) */
7404 if (op2->low == NULL) /* op2 = (:N), K > N */
7405 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7407 else if (op2->high == NULL) /* op2 = (M:), L < M */
7408 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7410 else /* op2 = (M:N) */
7414 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7417 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7426 /* Merge-sort a double linked case list, detecting overlap in the
7427 process. LIST is the head of the double linked case list before it
7428 is sorted. Returns the head of the sorted list if we don't see any
7429 overlap, or NULL otherwise. */
7432 check_case_overlap (gfc_case *list)
7434 gfc_case *p, *q, *e, *tail;
7435 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7437 /* If the passed list was empty, return immediately. */
7444 /* Loop unconditionally. The only exit from this loop is a return
7445 statement, when we've finished sorting the case list. */
7452 /* Count the number of merges we do in this pass. */
7455 /* Loop while there exists a merge to be done. */
7460 /* Count this merge. */
7463 /* Cut the list in two pieces by stepping INSIZE places
7464 forward in the list, starting from P. */
7467 for (i = 0; i < insize; i++)
7476 /* Now we have two lists. Merge them! */
7477 while (psize > 0 || (qsize > 0 && q != NULL))
7479 /* See from which the next case to merge comes from. */
7482 /* P is empty so the next case must come from Q. */
7487 else if (qsize == 0 || q == NULL)
7496 cmp = compare_cases (p, q);
7499 /* The whole case range for P is less than the
7507 /* The whole case range for Q is greater than
7508 the case range for P. */
7515 /* The cases overlap, or they are the same
7516 element in the list. Either way, we must
7517 issue an error and get the next case from P. */
7518 /* FIXME: Sort P and Q by line number. */
7519 gfc_error ("CASE label at %L overlaps with CASE "
7520 "label at %L", &p->where, &q->where);
7528 /* Add the next element to the merged list. */
7537 /* P has now stepped INSIZE places along, and so has Q. So
7538 they're the same. */
7543 /* If we have done only one merge or none at all, we've
7544 finished sorting the cases. */
7553 /* Otherwise repeat, merging lists twice the size. */
7559 /* Check to see if an expression is suitable for use in a CASE statement.
7560 Makes sure that all case expressions are scalar constants of the same
7561 type. Return FAILURE if anything is wrong. */
7564 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7566 if (e == NULL) return SUCCESS;
7568 if (e->ts.type != case_expr->ts.type)
7570 gfc_error ("Expression in CASE statement at %L must be of type %s",
7571 &e->where, gfc_basic_typename (case_expr->ts.type));
7575 /* C805 (R808) For a given case-construct, each case-value shall be of
7576 the same type as case-expr. For character type, length differences
7577 are allowed, but the kind type parameters shall be the same. */
7579 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7581 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7582 &e->where, case_expr->ts.kind);
7586 /* Convert the case value kind to that of case expression kind,
7589 if (e->ts.kind != case_expr->ts.kind)
7590 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7594 gfc_error ("Expression in CASE statement at %L must be scalar",
7603 /* Given a completely parsed select statement, we:
7605 - Validate all expressions and code within the SELECT.
7606 - Make sure that the selection expression is not of the wrong type.
7607 - Make sure that no case ranges overlap.
7608 - Eliminate unreachable cases and unreachable code resulting from
7609 removing case labels.
7611 The standard does allow unreachable cases, e.g. CASE (5:3). But
7612 they are a hassle for code generation, and to prevent that, we just
7613 cut them out here. This is not necessary for overlapping cases
7614 because they are illegal and we never even try to generate code.
7616 We have the additional caveat that a SELECT construct could have
7617 been a computed GOTO in the source code. Fortunately we can fairly
7618 easily work around that here: The case_expr for a "real" SELECT CASE
7619 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7620 we have to do is make sure that the case_expr is a scalar integer
7624 resolve_select (gfc_code *code)
7627 gfc_expr *case_expr;
7628 gfc_case *cp, *default_case, *tail, *head;
7629 int seen_unreachable;
7635 if (code->expr1 == NULL)
7637 /* This was actually a computed GOTO statement. */
7638 case_expr = code->expr2;
7639 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7640 gfc_error ("Selection expression in computed GOTO statement "
7641 "at %L must be a scalar integer expression",
7644 /* Further checking is not necessary because this SELECT was built
7645 by the compiler, so it should always be OK. Just move the
7646 case_expr from expr2 to expr so that we can handle computed
7647 GOTOs as normal SELECTs from here on. */
7648 code->expr1 = code->expr2;
7653 case_expr = code->expr1;
7655 type = case_expr->ts.type;
7656 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7658 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7659 &case_expr->where, gfc_typename (&case_expr->ts));
7661 /* Punt. Going on here just produce more garbage error messages. */
7665 /* Raise a warning if an INTEGER case value exceeds the range of
7666 the case-expr. Later, all expressions will be promoted to the
7667 largest kind of all case-labels. */
7669 if (type == BT_INTEGER)
7670 for (body = code->block; body; body = body->block)
7671 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7674 && gfc_check_integer_range (cp->low->value.integer,
7675 case_expr->ts.kind) != ARITH_OK)
7676 gfc_warning ("Expression in CASE statement at %L is "
7677 "not in the range of %s", &cp->low->where,
7678 gfc_typename (&case_expr->ts));
7681 && cp->low != cp->high
7682 && gfc_check_integer_range (cp->high->value.integer,
7683 case_expr->ts.kind) != ARITH_OK)
7684 gfc_warning ("Expression in CASE statement at %L is "
7685 "not in the range of %s", &cp->high->where,
7686 gfc_typename (&case_expr->ts));
7689 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7690 of the SELECT CASE expression and its CASE values. Walk the lists
7691 of case values, and if we find a mismatch, promote case_expr to
7692 the appropriate kind. */
7694 if (type == BT_LOGICAL || type == BT_INTEGER)
7696 for (body = code->block; body; body = body->block)
7698 /* Walk the case label list. */
7699 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7701 /* Intercept the DEFAULT case. It does not have a kind. */
7702 if (cp->low == NULL && cp->high == NULL)
7705 /* Unreachable case ranges are discarded, so ignore. */
7706 if (cp->low != NULL && cp->high != NULL
7707 && cp->low != cp->high
7708 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7712 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7713 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7715 if (cp->high != NULL
7716 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7717 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7722 /* Assume there is no DEFAULT case. */
7723 default_case = NULL;
7728 for (body = code->block; body; body = body->block)
7730 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7732 seen_unreachable = 0;
7734 /* Walk the case label list, making sure that all case labels
7736 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7738 /* Count the number of cases in the whole construct. */
7741 /* Intercept the DEFAULT case. */
7742 if (cp->low == NULL && cp->high == NULL)
7744 if (default_case != NULL)
7746 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7747 "by a second DEFAULT CASE at %L",
7748 &default_case->where, &cp->where);
7759 /* Deal with single value cases and case ranges. Errors are
7760 issued from the validation function. */
7761 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7762 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7768 if (type == BT_LOGICAL
7769 && ((cp->low == NULL || cp->high == NULL)
7770 || cp->low != cp->high))
7772 gfc_error ("Logical range in CASE statement at %L is not "
7773 "allowed", &cp->low->where);
7778 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7781 value = cp->low->value.logical == 0 ? 2 : 1;
7782 if (value & seen_logical)
7784 gfc_error ("Constant logical value in CASE statement "
7785 "is repeated at %L",
7790 seen_logical |= value;
7793 if (cp->low != NULL && cp->high != NULL
7794 && cp->low != cp->high
7795 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7797 if (gfc_option.warn_surprising)
7798 gfc_warning ("Range specification at %L can never "
7799 "be matched", &cp->where);
7801 cp->unreachable = 1;
7802 seen_unreachable = 1;
7806 /* If the case range can be matched, it can also overlap with
7807 other cases. To make sure it does not, we put it in a
7808 double linked list here. We sort that with a merge sort
7809 later on to detect any overlapping cases. */
7813 head->right = head->left = NULL;
7818 tail->right->left = tail;
7825 /* It there was a failure in the previous case label, give up
7826 for this case label list. Continue with the next block. */
7830 /* See if any case labels that are unreachable have been seen.
7831 If so, we eliminate them. This is a bit of a kludge because
7832 the case lists for a single case statement (label) is a
7833 single forward linked lists. */
7834 if (seen_unreachable)
7836 /* Advance until the first case in the list is reachable. */
7837 while (body->ext.block.case_list != NULL
7838 && body->ext.block.case_list->unreachable)
7840 gfc_case *n = body->ext.block.case_list;
7841 body->ext.block.case_list = body->ext.block.case_list->next;
7843 gfc_free_case_list (n);
7846 /* Strip all other unreachable cases. */
7847 if (body->ext.block.case_list)
7849 for (cp = body->ext.block.case_list; cp->next; cp = cp->next)
7851 if (cp->next->unreachable)
7853 gfc_case *n = cp->next;
7854 cp->next = cp->next->next;
7856 gfc_free_case_list (n);
7863 /* See if there were overlapping cases. If the check returns NULL,
7864 there was overlap. In that case we don't do anything. If head
7865 is non-NULL, we prepend the DEFAULT case. The sorted list can
7866 then used during code generation for SELECT CASE constructs with
7867 a case expression of a CHARACTER type. */
7870 head = check_case_overlap (head);
7872 /* Prepend the default_case if it is there. */
7873 if (head != NULL && default_case)
7875 default_case->left = NULL;
7876 default_case->right = head;
7877 head->left = default_case;
7881 /* Eliminate dead blocks that may be the result if we've seen
7882 unreachable case labels for a block. */
7883 for (body = code; body && body->block; body = body->block)
7885 if (body->block->ext.block.case_list == NULL)
7887 /* Cut the unreachable block from the code chain. */
7888 gfc_code *c = body->block;
7889 body->block = c->block;
7891 /* Kill the dead block, but not the blocks below it. */
7893 gfc_free_statements (c);
7897 /* More than two cases is legal but insane for logical selects.
7898 Issue a warning for it. */
7899 if (gfc_option.warn_surprising && type == BT_LOGICAL
7901 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7906 /* Check if a derived type is extensible. */
7909 gfc_type_is_extensible (gfc_symbol *sym)
7911 return !(sym->attr.is_bind_c || sym->attr.sequence);
7915 /* Resolve an associate name: Resolve target and ensure the type-spec is
7916 correct as well as possibly the array-spec. */
7919 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
7923 gcc_assert (sym->assoc);
7924 gcc_assert (sym->attr.flavor == FL_VARIABLE);
7926 /* If this is for SELECT TYPE, the target may not yet be set. In that
7927 case, return. Resolution will be called later manually again when
7929 target = sym->assoc->target;
7932 gcc_assert (!sym->assoc->dangling);
7934 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
7937 /* For variable targets, we get some attributes from the target. */
7938 if (target->expr_type == EXPR_VARIABLE)
7942 gcc_assert (target->symtree);
7943 tsym = target->symtree->n.sym;
7945 sym->attr.asynchronous = tsym->attr.asynchronous;
7946 sym->attr.volatile_ = tsym->attr.volatile_;
7948 if (tsym->ts.type == BT_CLASS)
7949 sym->attr.target = tsym->attr.target || CLASS_DATA (tsym)->attr.pointer;
7951 sym->attr.target = tsym->attr.target || tsym->attr.pointer;
7953 if (sym->ts.type == BT_DERIVED && tsym->ts.type == BT_CLASS)
7954 target->rank = sym->as ? sym->as->rank : 0;
7957 /* Get type if this was not already set. Note that it can be
7958 some other type than the target in case this is a SELECT TYPE
7959 selector! So we must not update when the type is already there. */
7960 if (sym->ts.type == BT_UNKNOWN)
7961 sym->ts = target->ts;
7962 gcc_assert (sym->ts.type != BT_UNKNOWN);
7964 /* See if this is a valid association-to-variable. */
7965 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
7966 && !gfc_has_vector_subscript (target));
7968 /* Finally resolve if this is an array or not. */
7969 if (sym->attr.dimension
7970 && (target->ts.type == BT_CLASS
7971 ? !CLASS_DATA (target)->attr.dimension
7972 : target->rank == 0))
7974 gfc_error ("Associate-name '%s' at %L is used as array",
7975 sym->name, &sym->declared_at);
7976 sym->attr.dimension = 0;
7979 if (target->rank > 0)
7980 sym->attr.dimension = 1;
7982 if (sym->attr.dimension)
7984 sym->as = gfc_get_array_spec ();
7985 sym->as->rank = target->rank;
7986 sym->as->type = AS_DEFERRED;
7988 /* Target must not be coindexed, thus the associate-variable
7990 sym->as->corank = 0;
7995 /* Resolve a SELECT TYPE statement. */
7998 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
8000 gfc_symbol *selector_type;
8001 gfc_code *body, *new_st, *if_st, *tail;
8002 gfc_code *class_is = NULL, *default_case = NULL;
8005 char name[GFC_MAX_SYMBOL_LEN];
8009 ns = code->ext.block.ns;
8012 /* Check for F03:C813. */
8013 if (code->expr1->ts.type != BT_CLASS
8014 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
8016 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8017 "at %L", &code->loc);
8021 if (!code->expr1->symtree->n.sym->attr.class_ok)
8026 if (code->expr1->symtree->n.sym->attr.untyped)
8027 code->expr1->symtree->n.sym->ts = code->expr2->ts;
8028 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
8031 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
8033 /* Loop over TYPE IS / CLASS IS cases. */
8034 for (body = code->block; body; body = body->block)
8036 c = body->ext.block.case_list;
8038 /* Check F03:C815. */
8039 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8040 && !gfc_type_is_extensible (c->ts.u.derived))
8042 gfc_error ("Derived type '%s' at %L must be extensible",
8043 c->ts.u.derived->name, &c->where);
8048 /* Check F03:C816. */
8049 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8050 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
8052 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
8053 c->ts.u.derived->name, &c->where, selector_type->name);
8058 /* Intercept the DEFAULT case. */
8059 if (c->ts.type == BT_UNKNOWN)
8061 /* Check F03:C818. */
8064 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8065 "by a second DEFAULT CASE at %L",
8066 &default_case->ext.block.case_list->where, &c->where);
8071 default_case = body;
8078 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8079 target if present. If there are any EXIT statements referring to the
8080 SELECT TYPE construct, this is no problem because the gfc_code
8081 reference stays the same and EXIT is equally possible from the BLOCK
8082 it is changed to. */
8083 code->op = EXEC_BLOCK;
8086 gfc_association_list* assoc;
8088 assoc = gfc_get_association_list ();
8089 assoc->st = code->expr1->symtree;
8090 assoc->target = gfc_copy_expr (code->expr2);
8091 assoc->target->where = code->expr2->where;
8092 /* assoc->variable will be set by resolve_assoc_var. */
8094 code->ext.block.assoc = assoc;
8095 code->expr1->symtree->n.sym->assoc = assoc;
8097 resolve_assoc_var (code->expr1->symtree->n.sym, false);
8100 code->ext.block.assoc = NULL;
8102 /* Add EXEC_SELECT to switch on type. */
8103 new_st = gfc_get_code ();
8104 new_st->op = code->op;
8105 new_st->expr1 = code->expr1;
8106 new_st->expr2 = code->expr2;
8107 new_st->block = code->block;
8108 code->expr1 = code->expr2 = NULL;
8113 ns->code->next = new_st;
8115 code->op = EXEC_SELECT;
8116 gfc_add_vptr_component (code->expr1);
8117 gfc_add_hash_component (code->expr1);
8119 /* Loop over TYPE IS / CLASS IS cases. */
8120 for (body = code->block; body; body = body->block)
8122 c = body->ext.block.case_list;
8124 if (c->ts.type == BT_DERIVED)
8125 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
8126 c->ts.u.derived->hash_value);
8128 else if (c->ts.type == BT_UNKNOWN)
8131 /* Associate temporary to selector. This should only be done
8132 when this case is actually true, so build a new ASSOCIATE
8133 that does precisely this here (instead of using the
8136 if (c->ts.type == BT_CLASS)
8137 sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
8139 sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
8140 st = gfc_find_symtree (ns->sym_root, name);
8141 gcc_assert (st->n.sym->assoc);
8142 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
8143 st->n.sym->assoc->target->where = code->expr1->where;
8144 if (c->ts.type == BT_DERIVED)
8145 gfc_add_data_component (st->n.sym->assoc->target);
8147 new_st = gfc_get_code ();
8148 new_st->op = EXEC_BLOCK;
8149 new_st->ext.block.ns = gfc_build_block_ns (ns);
8150 new_st->ext.block.ns->code = body->next;
8151 body->next = new_st;
8153 /* Chain in the new list only if it is marked as dangling. Otherwise
8154 there is a CASE label overlap and this is already used. Just ignore,
8155 the error is diagonsed elsewhere. */
8156 if (st->n.sym->assoc->dangling)
8158 new_st->ext.block.assoc = st->n.sym->assoc;
8159 st->n.sym->assoc->dangling = 0;
8162 resolve_assoc_var (st->n.sym, false);
8165 /* Take out CLASS IS cases for separate treatment. */
8167 while (body && body->block)
8169 if (body->block->ext.block.case_list->ts.type == BT_CLASS)
8171 /* Add to class_is list. */
8172 if (class_is == NULL)
8174 class_is = body->block;
8179 for (tail = class_is; tail->block; tail = tail->block) ;
8180 tail->block = body->block;
8183 /* Remove from EXEC_SELECT list. */
8184 body->block = body->block->block;
8197 /* Add a default case to hold the CLASS IS cases. */
8198 for (tail = code; tail->block; tail = tail->block) ;
8199 tail->block = gfc_get_code ();
8201 tail->op = EXEC_SELECT_TYPE;
8202 tail->ext.block.case_list = gfc_get_case ();
8203 tail->ext.block.case_list->ts.type = BT_UNKNOWN;
8205 default_case = tail;
8208 /* More than one CLASS IS block? */
8209 if (class_is->block)
8213 /* Sort CLASS IS blocks by extension level. */
8217 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
8220 /* F03:C817 (check for doubles). */
8221 if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
8222 == c2->ext.block.case_list->ts.u.derived->hash_value)
8224 gfc_error ("Double CLASS IS block in SELECT TYPE "
8226 &c2->ext.block.case_list->where);
8229 if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
8230 < c2->ext.block.case_list->ts.u.derived->attr.extension)
8233 (*c1)->block = c2->block;
8243 /* Generate IF chain. */
8244 if_st = gfc_get_code ();
8245 if_st->op = EXEC_IF;
8247 for (body = class_is; body; body = body->block)
8249 new_st->block = gfc_get_code ();
8250 new_st = new_st->block;
8251 new_st->op = EXEC_IF;
8252 /* Set up IF condition: Call _gfortran_is_extension_of. */
8253 new_st->expr1 = gfc_get_expr ();
8254 new_st->expr1->expr_type = EXPR_FUNCTION;
8255 new_st->expr1->ts.type = BT_LOGICAL;
8256 new_st->expr1->ts.kind = 4;
8257 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
8258 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
8259 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
8260 /* Set up arguments. */
8261 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
8262 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
8263 new_st->expr1->value.function.actual->expr->where = code->loc;
8264 gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
8265 vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
8266 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
8267 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
8268 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
8269 new_st->next = body->next;
8271 if (default_case->next)
8273 new_st->block = gfc_get_code ();
8274 new_st = new_st->block;
8275 new_st->op = EXEC_IF;
8276 new_st->next = default_case->next;
8279 /* Replace CLASS DEFAULT code by the IF chain. */
8280 default_case->next = if_st;
8283 /* Resolve the internal code. This can not be done earlier because
8284 it requires that the sym->assoc of selectors is set already. */
8285 gfc_current_ns = ns;
8286 gfc_resolve_blocks (code->block, gfc_current_ns);
8287 gfc_current_ns = old_ns;
8289 resolve_select (code);
8293 /* Resolve a transfer statement. This is making sure that:
8294 -- a derived type being transferred has only non-pointer components
8295 -- a derived type being transferred doesn't have private components, unless
8296 it's being transferred from the module where the type was defined
8297 -- we're not trying to transfer a whole assumed size array. */
8300 resolve_transfer (gfc_code *code)
8309 while (exp != NULL && exp->expr_type == EXPR_OP
8310 && exp->value.op.op == INTRINSIC_PARENTHESES)
8311 exp = exp->value.op.op1;
8313 if (exp && exp->expr_type == EXPR_NULL && exp->ts.type == BT_UNKNOWN)
8315 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8316 "MOLD=", &exp->where);
8320 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
8321 && exp->expr_type != EXPR_FUNCTION))
8324 /* If we are reading, the variable will be changed. Note that
8325 code->ext.dt may be NULL if the TRANSFER is related to
8326 an INQUIRE statement -- but in this case, we are not reading, either. */
8327 if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
8328 && gfc_check_vardef_context (exp, false, false, _("item in READ"))
8332 sym = exp->symtree->n.sym;
8335 /* Go to actual component transferred. */
8336 for (ref = exp->ref; ref; ref = ref->next)
8337 if (ref->type == REF_COMPONENT)
8338 ts = &ref->u.c.component->ts;
8340 if (ts->type == BT_CLASS)
8342 /* FIXME: Test for defined input/output. */
8343 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8344 "it is processed by a defined input/output procedure",
8349 if (ts->type == BT_DERIVED)
8351 /* Check that transferred derived type doesn't contain POINTER
8353 if (ts->u.derived->attr.pointer_comp)
8355 gfc_error ("Data transfer element at %L cannot have POINTER "
8356 "components unless it is processed by a defined "
8357 "input/output procedure", &code->loc);
8362 if (ts->u.derived->attr.proc_pointer_comp)
8364 gfc_error ("Data transfer element at %L cannot have "
8365 "procedure pointer components", &code->loc);
8369 if (ts->u.derived->attr.alloc_comp)
8371 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8372 "components unless it is processed by a defined "
8373 "input/output procedure", &code->loc);
8377 if (derived_inaccessible (ts->u.derived))
8379 gfc_error ("Data transfer element at %L cannot have "
8380 "PRIVATE components",&code->loc);
8385 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
8386 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
8388 gfc_error ("Data transfer element at %L cannot be a full reference to "
8389 "an assumed-size array", &code->loc);
8395 /*********** Toplevel code resolution subroutines ***********/
8397 /* Find the set of labels that are reachable from this block. We also
8398 record the last statement in each block. */
8401 find_reachable_labels (gfc_code *block)
8408 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
8410 /* Collect labels in this block. We don't keep those corresponding
8411 to END {IF|SELECT}, these are checked in resolve_branch by going
8412 up through the code_stack. */
8413 for (c = block; c; c = c->next)
8415 if (c->here && c->op != EXEC_END_NESTED_BLOCK)
8416 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8419 /* Merge with labels from parent block. */
8422 gcc_assert (cs_base->prev->reachable_labels);
8423 bitmap_ior_into (cs_base->reachable_labels,
8424 cs_base->prev->reachable_labels);
8430 resolve_lock_unlock (gfc_code *code)
8432 if (code->expr1->ts.type != BT_DERIVED
8433 || code->expr1->expr_type != EXPR_VARIABLE
8434 || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
8435 || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
8436 || code->expr1->rank != 0
8437 || (!gfc_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1)))
8438 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8439 &code->expr1->where);
8443 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8444 || code->expr2->expr_type != EXPR_VARIABLE))
8445 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8446 &code->expr2->where);
8449 && gfc_check_vardef_context (code->expr2, false, false,
8450 _("STAT variable")) == FAILURE)
8455 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8456 || code->expr3->expr_type != EXPR_VARIABLE))
8457 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8458 &code->expr3->where);
8461 && gfc_check_vardef_context (code->expr3, false, false,
8462 _("ERRMSG variable")) == FAILURE)
8465 /* Check ACQUIRED_LOCK. */
8467 && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
8468 || code->expr4->expr_type != EXPR_VARIABLE))
8469 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8470 "variable", &code->expr4->where);
8473 && gfc_check_vardef_context (code->expr4, false, false,
8474 _("ACQUIRED_LOCK variable")) == FAILURE)
8480 resolve_sync (gfc_code *code)
8482 /* Check imageset. The * case matches expr1 == NULL. */
8485 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8486 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8487 "INTEGER expression", &code->expr1->where);
8488 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8489 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8490 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8491 &code->expr1->where);
8492 else if (code->expr1->expr_type == EXPR_ARRAY
8493 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8495 gfc_constructor *cons;
8496 cons = gfc_constructor_first (code->expr1->value.constructor);
8497 for (; cons; cons = gfc_constructor_next (cons))
8498 if (cons->expr->expr_type == EXPR_CONSTANT
8499 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8500 gfc_error ("Imageset argument at %L must between 1 and "
8501 "num_images()", &cons->expr->where);
8507 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8508 || code->expr2->expr_type != EXPR_VARIABLE))
8509 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8510 &code->expr2->where);
8514 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8515 || code->expr3->expr_type != EXPR_VARIABLE))
8516 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8517 &code->expr3->where);
8521 /* Given a branch to a label, see if the branch is conforming.
8522 The code node describes where the branch is located. */
8525 resolve_branch (gfc_st_label *label, gfc_code *code)
8532 /* Step one: is this a valid branching target? */
8534 if (label->defined == ST_LABEL_UNKNOWN)
8536 gfc_error ("Label %d referenced at %L is never defined", label->value,
8541 if (label->defined != ST_LABEL_TARGET)
8543 gfc_error ("Statement at %L is not a valid branch target statement "
8544 "for the branch statement at %L", &label->where, &code->loc);
8548 /* Step two: make sure this branch is not a branch to itself ;-) */
8550 if (code->here == label)
8552 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8556 /* Step three: See if the label is in the same block as the
8557 branching statement. The hard work has been done by setting up
8558 the bitmap reachable_labels. */
8560 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8562 /* Check now whether there is a CRITICAL construct; if so, check
8563 whether the label is still visible outside of the CRITICAL block,
8564 which is invalid. */
8565 for (stack = cs_base; stack; stack = stack->prev)
8567 if (stack->current->op == EXEC_CRITICAL
8568 && bitmap_bit_p (stack->reachable_labels, label->value))
8569 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8570 "label at %L", &code->loc, &label->where);
8571 else if (stack->current->op == EXEC_DO_CONCURRENT
8572 && bitmap_bit_p (stack->reachable_labels, label->value))
8573 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8574 "for label at %L", &code->loc, &label->where);
8580 /* Step four: If we haven't found the label in the bitmap, it may
8581 still be the label of the END of the enclosing block, in which
8582 case we find it by going up the code_stack. */
8584 for (stack = cs_base; stack; stack = stack->prev)
8586 if (stack->current->next && stack->current->next->here == label)
8588 if (stack->current->op == EXEC_CRITICAL)
8590 /* Note: A label at END CRITICAL does not leave the CRITICAL
8591 construct as END CRITICAL is still part of it. */
8592 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8593 " at %L", &code->loc, &label->where);
8596 else if (stack->current->op == EXEC_DO_CONCURRENT)
8598 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8599 "label at %L", &code->loc, &label->where);
8606 gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
8610 /* The label is not in an enclosing block, so illegal. This was
8611 allowed in Fortran 66, so we allow it as extension. No
8612 further checks are necessary in this case. */
8613 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
8614 "as the GOTO statement at %L", &label->where,
8620 /* Check whether EXPR1 has the same shape as EXPR2. */
8623 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
8625 mpz_t shape[GFC_MAX_DIMENSIONS];
8626 mpz_t shape2[GFC_MAX_DIMENSIONS];
8627 gfc_try result = FAILURE;
8630 /* Compare the rank. */
8631 if (expr1->rank != expr2->rank)
8634 /* Compare the size of each dimension. */
8635 for (i=0; i<expr1->rank; i++)
8637 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
8640 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
8643 if (mpz_cmp (shape[i], shape2[i]))
8647 /* When either of the two expression is an assumed size array, we
8648 ignore the comparison of dimension sizes. */
8653 gfc_clear_shape (shape, i);
8654 gfc_clear_shape (shape2, i);
8659 /* Check whether a WHERE assignment target or a WHERE mask expression
8660 has the same shape as the outmost WHERE mask expression. */
8663 resolve_where (gfc_code *code, gfc_expr *mask)
8669 cblock = code->block;
8671 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8672 In case of nested WHERE, only the outmost one is stored. */
8673 if (mask == NULL) /* outmost WHERE */
8675 else /* inner WHERE */
8682 /* Check if the mask-expr has a consistent shape with the
8683 outmost WHERE mask-expr. */
8684 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8685 gfc_error ("WHERE mask at %L has inconsistent shape",
8686 &cblock->expr1->where);
8689 /* the assignment statement of a WHERE statement, or the first
8690 statement in where-body-construct of a WHERE construct */
8691 cnext = cblock->next;
8696 /* WHERE assignment statement */
8699 /* Check shape consistent for WHERE assignment target. */
8700 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8701 gfc_error ("WHERE assignment target at %L has "
8702 "inconsistent shape", &cnext->expr1->where);
8706 case EXEC_ASSIGN_CALL:
8707 resolve_call (cnext);
8708 if (!cnext->resolved_sym->attr.elemental)
8709 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8710 &cnext->ext.actual->expr->where);
8713 /* WHERE or WHERE construct is part of a where-body-construct */
8715 resolve_where (cnext, e);
8719 gfc_error ("Unsupported statement inside WHERE at %L",
8722 /* the next statement within the same where-body-construct */
8723 cnext = cnext->next;
8725 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8726 cblock = cblock->block;
8731 /* Resolve assignment in FORALL construct.
8732 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8733 FORALL index variables. */
8736 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8740 for (n = 0; n < nvar; n++)
8742 gfc_symbol *forall_index;
8744 forall_index = var_expr[n]->symtree->n.sym;
8746 /* Check whether the assignment target is one of the FORALL index
8748 if ((code->expr1->expr_type == EXPR_VARIABLE)
8749 && (code->expr1->symtree->n.sym == forall_index))
8750 gfc_error ("Assignment to a FORALL index variable at %L",
8751 &code->expr1->where);
8754 /* If one of the FORALL index variables doesn't appear in the
8755 assignment variable, then there could be a many-to-one
8756 assignment. Emit a warning rather than an error because the
8757 mask could be resolving this problem. */
8758 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8759 gfc_warning ("The FORALL with index '%s' is not used on the "
8760 "left side of the assignment at %L and so might "
8761 "cause multiple assignment to this object",
8762 var_expr[n]->symtree->name, &code->expr1->where);
8768 /* Resolve WHERE statement in FORALL construct. */
8771 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8772 gfc_expr **var_expr)
8777 cblock = code->block;
8780 /* the assignment statement of a WHERE statement, or the first
8781 statement in where-body-construct of a WHERE construct */
8782 cnext = cblock->next;
8787 /* WHERE assignment statement */
8789 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8792 /* WHERE operator assignment statement */
8793 case EXEC_ASSIGN_CALL:
8794 resolve_call (cnext);
8795 if (!cnext->resolved_sym->attr.elemental)
8796 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8797 &cnext->ext.actual->expr->where);
8800 /* WHERE or WHERE construct is part of a where-body-construct */
8802 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8806 gfc_error ("Unsupported statement inside WHERE at %L",
8809 /* the next statement within the same where-body-construct */
8810 cnext = cnext->next;
8812 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8813 cblock = cblock->block;
8818 /* Traverse the FORALL body to check whether the following errors exist:
8819 1. For assignment, check if a many-to-one assignment happens.
8820 2. For WHERE statement, check the WHERE body to see if there is any
8821 many-to-one assignment. */
8824 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8828 c = code->block->next;
8834 case EXEC_POINTER_ASSIGN:
8835 gfc_resolve_assign_in_forall (c, nvar, var_expr);
8838 case EXEC_ASSIGN_CALL:
8842 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8843 there is no need to handle it here. */
8847 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8852 /* The next statement in the FORALL body. */
8858 /* Counts the number of iterators needed inside a forall construct, including
8859 nested forall constructs. This is used to allocate the needed memory
8860 in gfc_resolve_forall. */
8863 gfc_count_forall_iterators (gfc_code *code)
8865 int max_iters, sub_iters, current_iters;
8866 gfc_forall_iterator *fa;
8868 gcc_assert(code->op == EXEC_FORALL);
8872 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8875 code = code->block->next;
8879 if (code->op == EXEC_FORALL)
8881 sub_iters = gfc_count_forall_iterators (code);
8882 if (sub_iters > max_iters)
8883 max_iters = sub_iters;
8888 return current_iters + max_iters;
8892 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8893 gfc_resolve_forall_body to resolve the FORALL body. */
8896 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8898 static gfc_expr **var_expr;
8899 static int total_var = 0;
8900 static int nvar = 0;
8902 gfc_forall_iterator *fa;
8907 /* Start to resolve a FORALL construct */
8908 if (forall_save == 0)
8910 /* Count the total number of FORALL index in the nested FORALL
8911 construct in order to allocate the VAR_EXPR with proper size. */
8912 total_var = gfc_count_forall_iterators (code);
8914 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8915 var_expr = XCNEWVEC (gfc_expr *, total_var);
8918 /* The information about FORALL iterator, including FORALL index start, end
8919 and stride. The FORALL index can not appear in start, end or stride. */
8920 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8922 /* Check if any outer FORALL index name is the same as the current
8924 for (i = 0; i < nvar; i++)
8926 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8928 gfc_error ("An outer FORALL construct already has an index "
8929 "with this name %L", &fa->var->where);
8933 /* Record the current FORALL index. */
8934 var_expr[nvar] = gfc_copy_expr (fa->var);
8938 /* No memory leak. */
8939 gcc_assert (nvar <= total_var);
8942 /* Resolve the FORALL body. */
8943 gfc_resolve_forall_body (code, nvar, var_expr);
8945 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8946 gfc_resolve_blocks (code->block, ns);
8950 /* Free only the VAR_EXPRs allocated in this frame. */
8951 for (i = nvar; i < tmp; i++)
8952 gfc_free_expr (var_expr[i]);
8956 /* We are in the outermost FORALL construct. */
8957 gcc_assert (forall_save == 0);
8959 /* VAR_EXPR is not needed any more. */
8966 /* Resolve a BLOCK construct statement. */
8969 resolve_block_construct (gfc_code* code)
8971 /* Resolve the BLOCK's namespace. */
8972 gfc_resolve (code->ext.block.ns);
8974 /* For an ASSOCIATE block, the associations (and their targets) are already
8975 resolved during resolve_symbol. */
8979 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8982 static void resolve_code (gfc_code *, gfc_namespace *);
8985 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8989 for (; b; b = b->block)
8991 t = gfc_resolve_expr (b->expr1);
8992 if (gfc_resolve_expr (b->expr2) == FAILURE)
8998 if (t == SUCCESS && b->expr1 != NULL
8999 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
9000 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9007 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
9008 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9013 resolve_branch (b->label1, b);
9017 resolve_block_construct (b);
9021 case EXEC_SELECT_TYPE:
9025 case EXEC_DO_CONCURRENT:
9033 case EXEC_OMP_ATOMIC:
9034 case EXEC_OMP_CRITICAL:
9036 case EXEC_OMP_MASTER:
9037 case EXEC_OMP_ORDERED:
9038 case EXEC_OMP_PARALLEL:
9039 case EXEC_OMP_PARALLEL_DO:
9040 case EXEC_OMP_PARALLEL_SECTIONS:
9041 case EXEC_OMP_PARALLEL_WORKSHARE:
9042 case EXEC_OMP_SECTIONS:
9043 case EXEC_OMP_SINGLE:
9045 case EXEC_OMP_TASKWAIT:
9046 case EXEC_OMP_TASKYIELD:
9047 case EXEC_OMP_WORKSHARE:
9051 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9054 resolve_code (b->next, ns);
9059 /* Does everything to resolve an ordinary assignment. Returns true
9060 if this is an interface assignment. */
9062 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
9072 if (gfc_extend_assign (code, ns) == SUCCESS)
9076 if (code->op == EXEC_ASSIGN_CALL)
9078 lhs = code->ext.actual->expr;
9079 rhsptr = &code->ext.actual->next->expr;
9083 gfc_actual_arglist* args;
9084 gfc_typebound_proc* tbp;
9086 gcc_assert (code->op == EXEC_COMPCALL);
9088 args = code->expr1->value.compcall.actual;
9090 rhsptr = &args->next->expr;
9092 tbp = code->expr1->value.compcall.tbp;
9093 gcc_assert (!tbp->is_generic);
9096 /* Make a temporary rhs when there is a default initializer
9097 and rhs is the same symbol as the lhs. */
9098 if ((*rhsptr)->expr_type == EXPR_VARIABLE
9099 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
9100 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
9101 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
9102 *rhsptr = gfc_get_parentheses (*rhsptr);
9111 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
9112 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9113 &code->loc) == FAILURE)
9116 /* Handle the case of a BOZ literal on the RHS. */
9117 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
9120 if (gfc_option.warn_surprising)
9121 gfc_warning ("BOZ literal at %L is bitwise transferred "
9122 "non-integer symbol '%s'", &code->loc,
9123 lhs->symtree->n.sym->name);
9125 if (!gfc_convert_boz (rhs, &lhs->ts))
9127 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
9129 if (rc == ARITH_UNDERFLOW)
9130 gfc_error ("Arithmetic underflow 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_OVERFLOW)
9134 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9135 ". This check can be disabled with the option "
9136 "-fno-range-check", &rhs->where);
9137 else if (rc == ARITH_NAN)
9138 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9139 ". This check can be disabled with the option "
9140 "-fno-range-check", &rhs->where);
9145 if (lhs->ts.type == BT_CHARACTER
9146 && gfc_option.warn_character_truncation)
9148 if (lhs->ts.u.cl != NULL
9149 && lhs->ts.u.cl->length != NULL
9150 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9151 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
9153 if (rhs->expr_type == EXPR_CONSTANT)
9154 rlen = rhs->value.character.length;
9156 else if (rhs->ts.u.cl != NULL
9157 && rhs->ts.u.cl->length != NULL
9158 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9159 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
9161 if (rlen && llen && rlen > llen)
9162 gfc_warning_now ("CHARACTER expression will be truncated "
9163 "in assignment (%d/%d) at %L",
9164 llen, rlen, &code->loc);
9167 /* Ensure that a vector index expression for the lvalue is evaluated
9168 to a temporary if the lvalue symbol is referenced in it. */
9171 for (ref = lhs->ref; ref; ref= ref->next)
9172 if (ref->type == REF_ARRAY)
9174 for (n = 0; n < ref->u.ar.dimen; n++)
9175 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
9176 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
9177 ref->u.ar.start[n]))
9179 = gfc_get_parentheses (ref->u.ar.start[n]);
9183 if (gfc_pure (NULL))
9185 if (lhs->ts.type == BT_DERIVED
9186 && lhs->expr_type == EXPR_VARIABLE
9187 && lhs->ts.u.derived->attr.pointer_comp
9188 && rhs->expr_type == EXPR_VARIABLE
9189 && (gfc_impure_variable (rhs->symtree->n.sym)
9190 || gfc_is_coindexed (rhs)))
9193 if (gfc_is_coindexed (rhs))
9194 gfc_error ("Coindexed expression at %L is assigned to "
9195 "a derived type variable with a POINTER "
9196 "component in a PURE procedure",
9199 gfc_error ("The impure variable at %L is assigned to "
9200 "a derived type variable with a POINTER "
9201 "component in a PURE procedure (12.6)",
9206 /* Fortran 2008, C1283. */
9207 if (gfc_is_coindexed (lhs))
9209 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9210 "procedure", &rhs->where);
9215 if (gfc_implicit_pure (NULL))
9217 if (lhs->expr_type == EXPR_VARIABLE
9218 && lhs->symtree->n.sym != gfc_current_ns->proc_name
9219 && lhs->symtree->n.sym->ns != gfc_current_ns)
9220 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9222 if (lhs->ts.type == BT_DERIVED
9223 && lhs->expr_type == EXPR_VARIABLE
9224 && lhs->ts.u.derived->attr.pointer_comp
9225 && rhs->expr_type == EXPR_VARIABLE
9226 && (gfc_impure_variable (rhs->symtree->n.sym)
9227 || gfc_is_coindexed (rhs)))
9228 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9230 /* Fortran 2008, C1283. */
9231 if (gfc_is_coindexed (lhs))
9232 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9236 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9237 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9238 if (lhs->ts.type == BT_CLASS)
9240 gfc_error ("Variable must not be polymorphic in intrinsic assignment at "
9241 "%L - check that there is a matching specific subroutine "
9242 "for '=' operator", &lhs->where);
9246 /* F2008, Section 7.2.1.2. */
9247 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
9249 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9250 "component in assignment at %L", &lhs->where);
9254 gfc_check_assign (lhs, rhs, 1);
9259 /* Given a block of code, recursively resolve everything pointed to by this
9263 resolve_code (gfc_code *code, gfc_namespace *ns)
9265 int omp_workshare_save;
9266 int forall_save, do_concurrent_save;
9270 frame.prev = cs_base;
9274 find_reachable_labels (code);
9276 for (; code; code = code->next)
9278 frame.current = code;
9279 forall_save = forall_flag;
9280 do_concurrent_save = do_concurrent_flag;
9282 if (code->op == EXEC_FORALL)
9285 gfc_resolve_forall (code, ns, forall_save);
9288 else if (code->block)
9290 omp_workshare_save = -1;
9293 case EXEC_OMP_PARALLEL_WORKSHARE:
9294 omp_workshare_save = omp_workshare_flag;
9295 omp_workshare_flag = 1;
9296 gfc_resolve_omp_parallel_blocks (code, ns);
9298 case EXEC_OMP_PARALLEL:
9299 case EXEC_OMP_PARALLEL_DO:
9300 case EXEC_OMP_PARALLEL_SECTIONS:
9302 omp_workshare_save = omp_workshare_flag;
9303 omp_workshare_flag = 0;
9304 gfc_resolve_omp_parallel_blocks (code, ns);
9307 gfc_resolve_omp_do_blocks (code, ns);
9309 case EXEC_SELECT_TYPE:
9310 /* Blocks are handled in resolve_select_type because we have
9311 to transform the SELECT TYPE into ASSOCIATE first. */
9313 case EXEC_DO_CONCURRENT:
9314 do_concurrent_flag = 1;
9315 gfc_resolve_blocks (code->block, ns);
9316 do_concurrent_flag = 2;
9318 case EXEC_OMP_WORKSHARE:
9319 omp_workshare_save = omp_workshare_flag;
9320 omp_workshare_flag = 1;
9323 gfc_resolve_blocks (code->block, ns);
9327 if (omp_workshare_save != -1)
9328 omp_workshare_flag = omp_workshare_save;
9332 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
9333 t = gfc_resolve_expr (code->expr1);
9334 forall_flag = forall_save;
9335 do_concurrent_flag = do_concurrent_save;
9337 if (gfc_resolve_expr (code->expr2) == FAILURE)
9340 if (code->op == EXEC_ALLOCATE
9341 && gfc_resolve_expr (code->expr3) == FAILURE)
9347 case EXEC_END_BLOCK:
9348 case EXEC_END_NESTED_BLOCK:
9352 case EXEC_ERROR_STOP:
9356 case EXEC_ASSIGN_CALL:
9361 case EXEC_SYNC_IMAGES:
9362 case EXEC_SYNC_MEMORY:
9363 resolve_sync (code);
9368 resolve_lock_unlock (code);
9372 /* Keep track of which entry we are up to. */
9373 current_entry_id = code->ext.entry->id;
9377 resolve_where (code, NULL);
9381 if (code->expr1 != NULL)
9383 if (code->expr1->ts.type != BT_INTEGER)
9384 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9385 "INTEGER variable", &code->expr1->where);
9386 else if (code->expr1->symtree->n.sym->attr.assign != 1)
9387 gfc_error ("Variable '%s' has not been assigned a target "
9388 "label at %L", code->expr1->symtree->n.sym->name,
9389 &code->expr1->where);
9392 resolve_branch (code->label1, code);
9396 if (code->expr1 != NULL
9397 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
9398 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9399 "INTEGER return specifier", &code->expr1->where);
9402 case EXEC_INIT_ASSIGN:
9403 case EXEC_END_PROCEDURE:
9410 if (gfc_check_vardef_context (code->expr1, false, false,
9411 _("assignment")) == FAILURE)
9414 if (resolve_ordinary_assign (code, ns))
9416 if (code->op == EXEC_COMPCALL)
9423 case EXEC_LABEL_ASSIGN:
9424 if (code->label1->defined == ST_LABEL_UNKNOWN)
9425 gfc_error ("Label %d referenced at %L is never defined",
9426 code->label1->value, &code->label1->where);
9428 && (code->expr1->expr_type != EXPR_VARIABLE
9429 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
9430 || code->expr1->symtree->n.sym->ts.kind
9431 != gfc_default_integer_kind
9432 || code->expr1->symtree->n.sym->as != NULL))
9433 gfc_error ("ASSIGN statement at %L requires a scalar "
9434 "default INTEGER variable", &code->expr1->where);
9437 case EXEC_POINTER_ASSIGN:
9444 /* This is both a variable definition and pointer assignment
9445 context, so check both of them. For rank remapping, a final
9446 array ref may be present on the LHS and fool gfc_expr_attr
9447 used in gfc_check_vardef_context. Remove it. */
9448 e = remove_last_array_ref (code->expr1);
9449 t = gfc_check_vardef_context (e, true, false,
9450 _("pointer assignment"));
9452 t = gfc_check_vardef_context (e, false, false,
9453 _("pointer assignment"));
9458 gfc_check_pointer_assign (code->expr1, code->expr2);
9462 case EXEC_ARITHMETIC_IF:
9464 && code->expr1->ts.type != BT_INTEGER
9465 && code->expr1->ts.type != BT_REAL)
9466 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9467 "expression", &code->expr1->where);
9469 resolve_branch (code->label1, code);
9470 resolve_branch (code->label2, code);
9471 resolve_branch (code->label3, code);
9475 if (t == SUCCESS && code->expr1 != NULL
9476 && (code->expr1->ts.type != BT_LOGICAL
9477 || code->expr1->rank != 0))
9478 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9479 &code->expr1->where);
9484 resolve_call (code);
9489 resolve_typebound_subroutine (code);
9493 resolve_ppc_call (code);
9497 /* Select is complicated. Also, a SELECT construct could be
9498 a transformed computed GOTO. */
9499 resolve_select (code);
9502 case EXEC_SELECT_TYPE:
9503 resolve_select_type (code, ns);
9507 resolve_block_construct (code);
9511 if (code->ext.iterator != NULL)
9513 gfc_iterator *iter = code->ext.iterator;
9514 if (gfc_resolve_iterator (iter, true) != FAILURE)
9515 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
9520 if (code->expr1 == NULL)
9521 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9523 && (code->expr1->rank != 0
9524 || code->expr1->ts.type != BT_LOGICAL))
9525 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9526 "a scalar LOGICAL expression", &code->expr1->where);
9531 resolve_allocate_deallocate (code, "ALLOCATE");
9535 case EXEC_DEALLOCATE:
9537 resolve_allocate_deallocate (code, "DEALLOCATE");
9542 if (gfc_resolve_open (code->ext.open) == FAILURE)
9545 resolve_branch (code->ext.open->err, code);
9549 if (gfc_resolve_close (code->ext.close) == FAILURE)
9552 resolve_branch (code->ext.close->err, code);
9555 case EXEC_BACKSPACE:
9559 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
9562 resolve_branch (code->ext.filepos->err, code);
9566 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9569 resolve_branch (code->ext.inquire->err, code);
9573 gcc_assert (code->ext.inquire != NULL);
9574 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9577 resolve_branch (code->ext.inquire->err, code);
9581 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
9584 resolve_branch (code->ext.wait->err, code);
9585 resolve_branch (code->ext.wait->end, code);
9586 resolve_branch (code->ext.wait->eor, code);
9591 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
9594 resolve_branch (code->ext.dt->err, code);
9595 resolve_branch (code->ext.dt->end, code);
9596 resolve_branch (code->ext.dt->eor, code);
9600 resolve_transfer (code);
9603 case EXEC_DO_CONCURRENT:
9605 resolve_forall_iterators (code->ext.forall_iterator);
9607 if (code->expr1 != NULL
9608 && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
9609 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9610 "expression", &code->expr1->where);
9613 case EXEC_OMP_ATOMIC:
9614 case EXEC_OMP_BARRIER:
9615 case EXEC_OMP_CRITICAL:
9616 case EXEC_OMP_FLUSH:
9618 case EXEC_OMP_MASTER:
9619 case EXEC_OMP_ORDERED:
9620 case EXEC_OMP_SECTIONS:
9621 case EXEC_OMP_SINGLE:
9622 case EXEC_OMP_TASKWAIT:
9623 case EXEC_OMP_TASKYIELD:
9624 case EXEC_OMP_WORKSHARE:
9625 gfc_resolve_omp_directive (code, ns);
9628 case EXEC_OMP_PARALLEL:
9629 case EXEC_OMP_PARALLEL_DO:
9630 case EXEC_OMP_PARALLEL_SECTIONS:
9631 case EXEC_OMP_PARALLEL_WORKSHARE:
9633 omp_workshare_save = omp_workshare_flag;
9634 omp_workshare_flag = 0;
9635 gfc_resolve_omp_directive (code, ns);
9636 omp_workshare_flag = omp_workshare_save;
9640 gfc_internal_error ("resolve_code(): Bad statement code");
9644 cs_base = frame.prev;
9648 /* Resolve initial values and make sure they are compatible with
9652 resolve_values (gfc_symbol *sym)
9656 if (sym->value == NULL)
9659 if (sym->value->expr_type == EXPR_STRUCTURE)
9660 t= resolve_structure_cons (sym->value, 1);
9662 t = gfc_resolve_expr (sym->value);
9667 gfc_check_assign_symbol (sym, sym->value);
9671 /* Verify the binding labels for common blocks that are BIND(C). The label
9672 for a BIND(C) common block must be identical in all scoping units in which
9673 the common block is declared. Further, the binding label can not collide
9674 with any other global entity in the program. */
9677 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
9679 if (comm_block_tree->n.common->is_bind_c == 1)
9681 gfc_gsymbol *binding_label_gsym;
9682 gfc_gsymbol *comm_name_gsym;
9684 /* See if a global symbol exists by the common block's name. It may
9685 be NULL if the common block is use-associated. */
9686 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
9687 comm_block_tree->n.common->name);
9688 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
9689 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9690 "with the global entity '%s' at %L",
9691 comm_block_tree->n.common->binding_label,
9692 comm_block_tree->n.common->name,
9693 &(comm_block_tree->n.common->where),
9694 comm_name_gsym->name, &(comm_name_gsym->where));
9695 else if (comm_name_gsym != NULL
9696 && strcmp (comm_name_gsym->name,
9697 comm_block_tree->n.common->name) == 0)
9699 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9701 if (comm_name_gsym->binding_label == NULL)
9702 /* No binding label for common block stored yet; save this one. */
9703 comm_name_gsym->binding_label =
9704 comm_block_tree->n.common->binding_label;
9706 if (strcmp (comm_name_gsym->binding_label,
9707 comm_block_tree->n.common->binding_label) != 0)
9709 /* Common block names match but binding labels do not. */
9710 gfc_error ("Binding label '%s' for common block '%s' at %L "
9711 "does not match the binding label '%s' for common "
9713 comm_block_tree->n.common->binding_label,
9714 comm_block_tree->n.common->name,
9715 &(comm_block_tree->n.common->where),
9716 comm_name_gsym->binding_label,
9717 comm_name_gsym->name,
9718 &(comm_name_gsym->where));
9723 /* There is no binding label (NAME="") so we have nothing further to
9724 check and nothing to add as a global symbol for the label. */
9725 if (comm_block_tree->n.common->binding_label[0] == '\0' )
9728 binding_label_gsym =
9729 gfc_find_gsymbol (gfc_gsym_root,
9730 comm_block_tree->n.common->binding_label);
9731 if (binding_label_gsym == NULL)
9733 /* Need to make a global symbol for the binding label to prevent
9734 it from colliding with another. */
9735 binding_label_gsym =
9736 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9737 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9738 binding_label_gsym->type = GSYM_COMMON;
9742 /* If comm_name_gsym is NULL, the name common block is use
9743 associated and the name could be colliding. */
9744 if (binding_label_gsym->type != GSYM_COMMON)
9745 gfc_error ("Binding label '%s' for common block '%s' at %L "
9746 "collides with the global entity '%s' at %L",
9747 comm_block_tree->n.common->binding_label,
9748 comm_block_tree->n.common->name,
9749 &(comm_block_tree->n.common->where),
9750 binding_label_gsym->name,
9751 &(binding_label_gsym->where));
9752 else if (comm_name_gsym != NULL
9753 && (strcmp (binding_label_gsym->name,
9754 comm_name_gsym->binding_label) != 0)
9755 && (strcmp (binding_label_gsym->sym_name,
9756 comm_name_gsym->name) != 0))
9757 gfc_error ("Binding label '%s' for common block '%s' at %L "
9758 "collides with global entity '%s' at %L",
9759 binding_label_gsym->name, binding_label_gsym->sym_name,
9760 &(comm_block_tree->n.common->where),
9761 comm_name_gsym->name, &(comm_name_gsym->where));
9769 /* Verify any BIND(C) derived types in the namespace so we can report errors
9770 for them once, rather than for each variable declared of that type. */
9773 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9775 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9776 && derived_sym->attr.is_bind_c == 1)
9777 verify_bind_c_derived_type (derived_sym);
9783 /* Verify that any binding labels used in a given namespace do not collide
9784 with the names or binding labels of any global symbols. */
9787 gfc_verify_binding_labels (gfc_symbol *sym)
9791 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9792 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
9794 gfc_gsymbol *bind_c_sym;
9796 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9797 if (bind_c_sym != NULL
9798 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9800 if (sym->attr.if_source == IFSRC_DECL
9801 && (bind_c_sym->type != GSYM_SUBROUTINE
9802 && bind_c_sym->type != GSYM_FUNCTION)
9803 && ((sym->attr.contained == 1
9804 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9805 || (sym->attr.use_assoc == 1
9806 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9808 /* Make sure global procedures don't collide with anything. */
9809 gfc_error ("Binding label '%s' at %L collides with the global "
9810 "entity '%s' at %L", sym->binding_label,
9811 &(sym->declared_at), bind_c_sym->name,
9812 &(bind_c_sym->where));
9815 else if (sym->attr.contained == 0
9816 && (sym->attr.if_source == IFSRC_IFBODY
9817 && sym->attr.flavor == FL_PROCEDURE)
9818 && (bind_c_sym->sym_name != NULL
9819 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9821 /* Make sure procedures in interface bodies don't collide. */
9822 gfc_error ("Binding label '%s' in interface body at %L collides "
9823 "with the global entity '%s' at %L",
9825 &(sym->declared_at), bind_c_sym->name,
9826 &(bind_c_sym->where));
9829 else if (sym->attr.contained == 0
9830 && sym->attr.if_source == IFSRC_UNKNOWN)
9831 if ((sym->attr.use_assoc && bind_c_sym->mod_name
9832 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9833 || sym->attr.use_assoc == 0)
9835 gfc_error ("Binding label '%s' at %L collides with global "
9836 "entity '%s' at %L", sym->binding_label,
9837 &(sym->declared_at), bind_c_sym->name,
9838 &(bind_c_sym->where));
9843 /* Clear the binding label to prevent checking multiple times. */
9844 sym->binding_label[0] = '\0';
9846 else if (bind_c_sym == NULL)
9848 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9849 bind_c_sym->where = sym->declared_at;
9850 bind_c_sym->sym_name = sym->name;
9852 if (sym->attr.use_assoc == 1)
9853 bind_c_sym->mod_name = sym->module;
9855 if (sym->ns->proc_name != NULL)
9856 bind_c_sym->mod_name = sym->ns->proc_name->name;
9858 if (sym->attr.contained == 0)
9860 if (sym->attr.subroutine)
9861 bind_c_sym->type = GSYM_SUBROUTINE;
9862 else if (sym->attr.function)
9863 bind_c_sym->type = GSYM_FUNCTION;
9871 /* Resolve an index expression. */
9874 resolve_index_expr (gfc_expr *e)
9876 if (gfc_resolve_expr (e) == FAILURE)
9879 if (gfc_simplify_expr (e, 0) == FAILURE)
9882 if (gfc_specification_expr (e) == FAILURE)
9889 /* Resolve a charlen structure. */
9892 resolve_charlen (gfc_charlen *cl)
9901 specification_expr = 1;
9903 if (resolve_index_expr (cl->length) == FAILURE)
9905 specification_expr = 0;
9909 /* "If the character length parameter value evaluates to a negative
9910 value, the length of character entities declared is zero." */
9911 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9913 if (gfc_option.warn_surprising)
9914 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9915 " the length has been set to zero",
9916 &cl->length->where, i);
9917 gfc_replace_expr (cl->length,
9918 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9921 /* Check that the character length is not too large. */
9922 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9923 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9924 && cl->length->ts.type == BT_INTEGER
9925 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9927 gfc_error ("String length at %L is too large", &cl->length->where);
9935 /* Test for non-constant shape arrays. */
9938 is_non_constant_shape_array (gfc_symbol *sym)
9944 not_constant = false;
9945 if (sym->as != NULL)
9947 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9948 has not been simplified; parameter array references. Do the
9949 simplification now. */
9950 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9952 e = sym->as->lower[i];
9953 if (e && (resolve_index_expr (e) == FAILURE
9954 || !gfc_is_constant_expr (e)))
9955 not_constant = true;
9956 e = sym->as->upper[i];
9957 if (e && (resolve_index_expr (e) == FAILURE
9958 || !gfc_is_constant_expr (e)))
9959 not_constant = true;
9962 return not_constant;
9965 /* Given a symbol and an initialization expression, add code to initialize
9966 the symbol to the function entry. */
9968 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9972 gfc_namespace *ns = sym->ns;
9974 /* Search for the function namespace if this is a contained
9975 function without an explicit result. */
9976 if (sym->attr.function && sym == sym->result
9977 && sym->name != sym->ns->proc_name->name)
9980 for (;ns; ns = ns->sibling)
9981 if (strcmp (ns->proc_name->name, sym->name) == 0)
9987 gfc_free_expr (init);
9991 /* Build an l-value expression for the result. */
9992 lval = gfc_lval_expr_from_sym (sym);
9994 /* Add the code at scope entry. */
9995 init_st = gfc_get_code ();
9996 init_st->next = ns->code;
9999 /* Assign the default initializer to the l-value. */
10000 init_st->loc = sym->declared_at;
10001 init_st->op = EXEC_INIT_ASSIGN;
10002 init_st->expr1 = lval;
10003 init_st->expr2 = init;
10006 /* Assign the default initializer to a derived type variable or result. */
10009 apply_default_init (gfc_symbol *sym)
10011 gfc_expr *init = NULL;
10013 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
10016 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
10017 init = gfc_default_initializer (&sym->ts);
10019 if (init == NULL && sym->ts.type != BT_CLASS)
10022 build_init_assign (sym, init);
10023 sym->attr.referenced = 1;
10026 /* Build an initializer for a local integer, real, complex, logical, or
10027 character variable, based on the command line flags finit-local-zero,
10028 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10029 null if the symbol should not have a default initialization. */
10031 build_default_init_expr (gfc_symbol *sym)
10034 gfc_expr *init_expr;
10037 /* These symbols should never have a default initialization. */
10038 if (sym->attr.allocatable
10039 || sym->attr.external
10041 || sym->attr.pointer
10042 || sym->attr.in_equivalence
10043 || sym->attr.in_common
10046 || sym->attr.cray_pointee
10047 || sym->attr.cray_pointer)
10050 /* Now we'll try to build an initializer expression. */
10051 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
10052 &sym->declared_at);
10054 /* We will only initialize integers, reals, complex, logicals, and
10055 characters, and only if the corresponding command-line flags
10056 were set. Otherwise, we free init_expr and return null. */
10057 switch (sym->ts.type)
10060 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
10061 mpz_set_si (init_expr->value.integer,
10062 gfc_option.flag_init_integer_value);
10065 gfc_free_expr (init_expr);
10071 switch (gfc_option.flag_init_real)
10073 case GFC_INIT_REAL_SNAN:
10074 init_expr->is_snan = 1;
10075 /* Fall through. */
10076 case GFC_INIT_REAL_NAN:
10077 mpfr_set_nan (init_expr->value.real);
10080 case GFC_INIT_REAL_INF:
10081 mpfr_set_inf (init_expr->value.real, 1);
10084 case GFC_INIT_REAL_NEG_INF:
10085 mpfr_set_inf (init_expr->value.real, -1);
10088 case GFC_INIT_REAL_ZERO:
10089 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
10093 gfc_free_expr (init_expr);
10100 switch (gfc_option.flag_init_real)
10102 case GFC_INIT_REAL_SNAN:
10103 init_expr->is_snan = 1;
10104 /* Fall through. */
10105 case GFC_INIT_REAL_NAN:
10106 mpfr_set_nan (mpc_realref (init_expr->value.complex));
10107 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
10110 case GFC_INIT_REAL_INF:
10111 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
10112 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
10115 case GFC_INIT_REAL_NEG_INF:
10116 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
10117 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
10120 case GFC_INIT_REAL_ZERO:
10121 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
10125 gfc_free_expr (init_expr);
10132 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
10133 init_expr->value.logical = 0;
10134 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
10135 init_expr->value.logical = 1;
10138 gfc_free_expr (init_expr);
10144 /* For characters, the length must be constant in order to
10145 create a default initializer. */
10146 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
10147 && sym->ts.u.cl->length
10148 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
10150 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
10151 init_expr->value.character.length = char_len;
10152 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
10153 for (i = 0; i < char_len; i++)
10154 init_expr->value.character.string[i]
10155 = (unsigned char) gfc_option.flag_init_character_value;
10159 gfc_free_expr (init_expr);
10162 if (!init_expr && gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
10163 && sym->ts.u.cl->length)
10165 gfc_actual_arglist *arg;
10166 init_expr = gfc_get_expr ();
10167 init_expr->where = sym->declared_at;
10168 init_expr->ts = sym->ts;
10169 init_expr->expr_type = EXPR_FUNCTION;
10170 init_expr->value.function.isym =
10171 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT);
10172 init_expr->value.function.name = "repeat";
10173 arg = gfc_get_actual_arglist ();
10174 arg->expr = gfc_get_character_expr (sym->ts.kind, &sym->declared_at,
10176 arg->expr->value.character.string[0]
10177 = gfc_option.flag_init_character_value;
10178 arg->next = gfc_get_actual_arglist ();
10179 arg->next->expr = gfc_copy_expr (sym->ts.u.cl->length);
10180 init_expr->value.function.actual = arg;
10185 gfc_free_expr (init_expr);
10191 /* Add an initialization expression to a local variable. */
10193 apply_default_init_local (gfc_symbol *sym)
10195 gfc_expr *init = NULL;
10197 /* The symbol should be a variable or a function return value. */
10198 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
10199 || (sym->attr.function && sym->result != sym))
10202 /* Try to build the initializer expression. If we can't initialize
10203 this symbol, then init will be NULL. */
10204 init = build_default_init_expr (sym);
10208 /* For saved variables, we don't want to add an initializer at function
10209 entry, so we just add a static initializer. Note that automatic variables
10210 are stack allocated even with -fno-automatic. */
10211 if (sym->attr.save || sym->ns->save_all
10212 || (gfc_option.flag_max_stack_var_size == 0
10213 && (!sym->attr.dimension || !is_non_constant_shape_array (sym))))
10215 /* Don't clobber an existing initializer! */
10216 gcc_assert (sym->value == NULL);
10221 build_init_assign (sym, init);
10225 /* Resolution of common features of flavors variable and procedure. */
10228 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
10230 gfc_array_spec *as;
10232 /* Avoid double diagnostics for function result symbols. */
10233 if ((sym->result || sym->attr.result) && !sym->attr.dummy
10234 && (sym->ns != gfc_current_ns))
10237 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
10238 as = CLASS_DATA (sym)->as;
10242 /* Constraints on deferred shape variable. */
10243 if (as == NULL || as->type != AS_DEFERRED)
10245 bool pointer, allocatable, dimension;
10247 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
10249 pointer = CLASS_DATA (sym)->attr.class_pointer;
10250 allocatable = CLASS_DATA (sym)->attr.allocatable;
10251 dimension = CLASS_DATA (sym)->attr.dimension;
10255 pointer = sym->attr.pointer;
10256 allocatable = sym->attr.allocatable;
10257 dimension = sym->attr.dimension;
10264 gfc_error ("Allocatable array '%s' at %L must have "
10265 "a deferred shape", sym->name, &sym->declared_at);
10268 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
10269 "may not be ALLOCATABLE", sym->name,
10270 &sym->declared_at) == FAILURE)
10274 if (pointer && dimension)
10276 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
10277 sym->name, &sym->declared_at);
10283 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
10284 && sym->ts.type != BT_CLASS && !sym->assoc)
10286 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10287 sym->name, &sym->declared_at);
10292 /* Constraints on polymorphic variables. */
10293 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
10296 if (sym->attr.class_ok
10297 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
10299 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10300 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
10301 &sym->declared_at);
10306 /* Assume that use associated symbols were checked in the module ns.
10307 Class-variables that are associate-names are also something special
10308 and excepted from the test. */
10309 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
10311 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10312 "or pointer", sym->name, &sym->declared_at);
10321 /* Additional checks for symbols with flavor variable and derived
10322 type. To be called from resolve_fl_variable. */
10325 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
10327 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
10329 /* Check to see if a derived type is blocked from being host
10330 associated by the presence of another class I symbol in the same
10331 namespace. 14.6.1.3 of the standard and the discussion on
10332 comp.lang.fortran. */
10333 if (sym->ns != sym->ts.u.derived->ns
10334 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
10337 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
10338 if (s && s->attr.generic)
10339 s = gfc_find_dt_in_generic (s);
10340 if (s && s->attr.flavor != FL_DERIVED)
10342 gfc_error ("The type '%s' cannot be host associated at %L "
10343 "because it is blocked by an incompatible object "
10344 "of the same name declared at %L",
10345 sym->ts.u.derived->name, &sym->declared_at,
10351 /* 4th constraint in section 11.3: "If an object of a type for which
10352 component-initialization is specified (R429) appears in the
10353 specification-part of a module and does not have the ALLOCATABLE
10354 or POINTER attribute, the object shall have the SAVE attribute."
10356 The check for initializers is performed with
10357 gfc_has_default_initializer because gfc_default_initializer generates
10358 a hidden default for allocatable components. */
10359 if (!(sym->value || no_init_flag) && sym->ns->proc_name
10360 && sym->ns->proc_name->attr.flavor == FL_MODULE
10361 && !sym->ns->save_all && !sym->attr.save
10362 && !sym->attr.pointer && !sym->attr.allocatable
10363 && gfc_has_default_initializer (sym->ts.u.derived)
10364 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
10365 "module variable '%s' at %L, needed due to "
10366 "the default initialization", sym->name,
10367 &sym->declared_at) == FAILURE)
10370 /* Assign default initializer. */
10371 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
10372 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
10374 sym->value = gfc_default_initializer (&sym->ts);
10381 /* Resolve symbols with flavor variable. */
10384 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
10386 int no_init_flag, automatic_flag;
10388 const char *auto_save_msg;
10390 auto_save_msg = "Automatic object '%s' at %L cannot have the "
10393 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10396 /* Set this flag to check that variables are parameters of all entries.
10397 This check is effected by the call to gfc_resolve_expr through
10398 is_non_constant_shape_array. */
10399 specification_expr = 1;
10401 if (sym->ns->proc_name
10402 && (sym->ns->proc_name->attr.flavor == FL_MODULE
10403 || sym->ns->proc_name->attr.is_main_program)
10404 && !sym->attr.use_assoc
10405 && !sym->attr.allocatable
10406 && !sym->attr.pointer
10407 && is_non_constant_shape_array (sym))
10409 /* The shape of a main program or module array needs to be
10411 gfc_error ("The module or main program array '%s' at %L must "
10412 "have constant shape", sym->name, &sym->declared_at);
10413 specification_expr = 0;
10417 /* Constraints on deferred type parameter. */
10418 if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
10420 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10421 "requires either the pointer or allocatable attribute",
10422 sym->name, &sym->declared_at);
10426 if (sym->ts.type == BT_CHARACTER)
10428 /* Make sure that character string variables with assumed length are
10429 dummy arguments. */
10430 e = sym->ts.u.cl->length;
10431 if (e == NULL && !sym->attr.dummy && !sym->attr.result
10432 && !sym->ts.deferred)
10434 gfc_error ("Entity with assumed character length at %L must be a "
10435 "dummy argument or a PARAMETER", &sym->declared_at);
10439 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
10441 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10445 if (!gfc_is_constant_expr (e)
10446 && !(e->expr_type == EXPR_VARIABLE
10447 && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
10449 if (!sym->attr.use_assoc && sym->ns->proc_name
10450 && (sym->ns->proc_name->attr.flavor == FL_MODULE
10451 || sym->ns->proc_name->attr.is_main_program))
10453 gfc_error ("'%s' at %L must have constant character length "
10454 "in this context", sym->name, &sym->declared_at);
10457 if (sym->attr.in_common)
10459 gfc_error ("COMMON variable '%s' at %L must have constant "
10460 "character length", sym->name, &sym->declared_at);
10466 if (sym->value == NULL && sym->attr.referenced)
10467 apply_default_init_local (sym); /* Try to apply a default initialization. */
10469 /* Determine if the symbol may not have an initializer. */
10470 no_init_flag = automatic_flag = 0;
10471 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
10472 || sym->attr.intrinsic || sym->attr.result)
10474 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
10475 && is_non_constant_shape_array (sym))
10477 no_init_flag = automatic_flag = 1;
10479 /* Also, they must not have the SAVE attribute.
10480 SAVE_IMPLICIT is checked below. */
10481 if (sym->as && sym->attr.codimension)
10483 int corank = sym->as->corank;
10484 sym->as->corank = 0;
10485 no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
10486 sym->as->corank = corank;
10488 if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
10490 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10495 /* Ensure that any initializer is simplified. */
10497 gfc_simplify_expr (sym->value, 1);
10499 /* Reject illegal initializers. */
10500 if (!sym->mark && sym->value)
10502 if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
10503 && CLASS_DATA (sym)->attr.allocatable))
10504 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10505 sym->name, &sym->declared_at);
10506 else if (sym->attr.external)
10507 gfc_error ("External '%s' at %L cannot have an initializer",
10508 sym->name, &sym->declared_at);
10509 else if (sym->attr.dummy
10510 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
10511 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10512 sym->name, &sym->declared_at);
10513 else if (sym->attr.intrinsic)
10514 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10515 sym->name, &sym->declared_at);
10516 else if (sym->attr.result)
10517 gfc_error ("Function result '%s' at %L cannot have an initializer",
10518 sym->name, &sym->declared_at);
10519 else if (automatic_flag)
10520 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10521 sym->name, &sym->declared_at);
10523 goto no_init_error;
10528 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
10529 return resolve_fl_variable_derived (sym, no_init_flag);
10535 /* Resolve a procedure. */
10538 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
10540 gfc_formal_arglist *arg;
10542 if (sym->attr.function
10543 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10546 if (sym->ts.type == BT_CHARACTER)
10548 gfc_charlen *cl = sym->ts.u.cl;
10550 if (cl && cl->length && gfc_is_constant_expr (cl->length)
10551 && resolve_charlen (cl) == FAILURE)
10554 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
10555 && sym->attr.proc == PROC_ST_FUNCTION)
10557 gfc_error ("Character-valued statement function '%s' at %L must "
10558 "have constant length", sym->name, &sym->declared_at);
10563 /* Ensure that derived type for are not of a private type. Internal
10564 module procedures are excluded by 2.2.3.3 - i.e., they are not
10565 externally accessible and can access all the objects accessible in
10567 if (!(sym->ns->parent
10568 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
10569 && gfc_check_symbol_access (sym))
10571 gfc_interface *iface;
10573 for (arg = sym->formal; arg; arg = arg->next)
10576 && arg->sym->ts.type == BT_DERIVED
10577 && !arg->sym->ts.u.derived->attr.use_assoc
10578 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10579 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
10580 "PRIVATE type and cannot be a dummy argument"
10581 " of '%s', which is PUBLIC at %L",
10582 arg->sym->name, sym->name, &sym->declared_at)
10585 /* Stop this message from recurring. */
10586 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10591 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10592 PRIVATE to the containing module. */
10593 for (iface = sym->generic; iface; iface = iface->next)
10595 for (arg = iface->sym->formal; arg; arg = arg->next)
10598 && arg->sym->ts.type == BT_DERIVED
10599 && !arg->sym->ts.u.derived->attr.use_assoc
10600 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10601 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10602 "'%s' in PUBLIC interface '%s' at %L "
10603 "takes dummy arguments of '%s' which is "
10604 "PRIVATE", iface->sym->name, sym->name,
10605 &iface->sym->declared_at,
10606 gfc_typename (&arg->sym->ts)) == FAILURE)
10608 /* Stop this message from recurring. */
10609 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10615 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10616 PRIVATE to the containing module. */
10617 for (iface = sym->generic; iface; iface = iface->next)
10619 for (arg = iface->sym->formal; arg; arg = arg->next)
10622 && arg->sym->ts.type == BT_DERIVED
10623 && !arg->sym->ts.u.derived->attr.use_assoc
10624 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10625 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10626 "'%s' in PUBLIC interface '%s' at %L "
10627 "takes dummy arguments of '%s' which is "
10628 "PRIVATE", iface->sym->name, sym->name,
10629 &iface->sym->declared_at,
10630 gfc_typename (&arg->sym->ts)) == FAILURE)
10632 /* Stop this message from recurring. */
10633 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10640 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10641 && !sym->attr.proc_pointer)
10643 gfc_error ("Function '%s' at %L cannot have an initializer",
10644 sym->name, &sym->declared_at);
10648 /* An external symbol may not have an initializer because it is taken to be
10649 a procedure. Exception: Procedure Pointers. */
10650 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10652 gfc_error ("External object '%s' at %L may not have an initializer",
10653 sym->name, &sym->declared_at);
10657 /* An elemental function is required to return a scalar 12.7.1 */
10658 if (sym->attr.elemental && sym->attr.function && sym->as)
10660 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10661 "result", sym->name, &sym->declared_at);
10662 /* Reset so that the error only occurs once. */
10663 sym->attr.elemental = 0;
10667 if (sym->attr.proc == PROC_ST_FUNCTION
10668 && (sym->attr.allocatable || sym->attr.pointer))
10670 gfc_error ("Statement function '%s' at %L may not have pointer or "
10671 "allocatable attribute", sym->name, &sym->declared_at);
10675 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10676 char-len-param shall not be array-valued, pointer-valued, recursive
10677 or pure. ....snip... A character value of * may only be used in the
10678 following ways: (i) Dummy arg of procedure - dummy associates with
10679 actual length; (ii) To declare a named constant; or (iii) External
10680 function - but length must be declared in calling scoping unit. */
10681 if (sym->attr.function
10682 && sym->ts.type == BT_CHARACTER
10683 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10685 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10686 || (sym->attr.recursive) || (sym->attr.pure))
10688 if (sym->as && sym->as->rank)
10689 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10690 "array-valued", sym->name, &sym->declared_at);
10692 if (sym->attr.pointer)
10693 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10694 "pointer-valued", sym->name, &sym->declared_at);
10696 if (sym->attr.pure)
10697 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10698 "pure", sym->name, &sym->declared_at);
10700 if (sym->attr.recursive)
10701 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10702 "recursive", sym->name, &sym->declared_at);
10707 /* Appendix B.2 of the standard. Contained functions give an
10708 error anyway. Fixed-form is likely to be F77/legacy. Deferred
10709 character length is an F2003 feature. */
10710 if (!sym->attr.contained
10711 && gfc_current_form != FORM_FIXED
10712 && !sym->ts.deferred)
10713 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10714 "CHARACTER(*) function '%s' at %L",
10715 sym->name, &sym->declared_at);
10718 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10720 gfc_formal_arglist *curr_arg;
10721 int has_non_interop_arg = 0;
10723 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10724 sym->common_block) == FAILURE)
10726 /* Clear these to prevent looking at them again if there was an
10728 sym->attr.is_bind_c = 0;
10729 sym->attr.is_c_interop = 0;
10730 sym->ts.is_c_interop = 0;
10734 /* So far, no errors have been found. */
10735 sym->attr.is_c_interop = 1;
10736 sym->ts.is_c_interop = 1;
10739 curr_arg = sym->formal;
10740 while (curr_arg != NULL)
10742 /* Skip implicitly typed dummy args here. */
10743 if (curr_arg->sym->attr.implicit_type == 0)
10744 if (gfc_verify_c_interop_param (curr_arg->sym) == FAILURE)
10745 /* If something is found to fail, record the fact so we
10746 can mark the symbol for the procedure as not being
10747 BIND(C) to try and prevent multiple errors being
10749 has_non_interop_arg = 1;
10751 curr_arg = curr_arg->next;
10754 /* See if any of the arguments were not interoperable and if so, clear
10755 the procedure symbol to prevent duplicate error messages. */
10756 if (has_non_interop_arg != 0)
10758 sym->attr.is_c_interop = 0;
10759 sym->ts.is_c_interop = 0;
10760 sym->attr.is_bind_c = 0;
10764 if (!sym->attr.proc_pointer)
10766 if (sym->attr.save == SAVE_EXPLICIT)
10768 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10769 "in '%s' at %L", sym->name, &sym->declared_at);
10772 if (sym->attr.intent)
10774 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10775 "in '%s' at %L", sym->name, &sym->declared_at);
10778 if (sym->attr.subroutine && sym->attr.result)
10780 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10781 "in '%s' at %L", sym->name, &sym->declared_at);
10784 if (sym->attr.external && sym->attr.function
10785 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10786 || sym->attr.contained))
10788 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10789 "in '%s' at %L", sym->name, &sym->declared_at);
10792 if (strcmp ("ppr@", sym->name) == 0)
10794 gfc_error ("Procedure pointer result '%s' at %L "
10795 "is missing the pointer attribute",
10796 sym->ns->proc_name->name, &sym->declared_at);
10805 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10806 been defined and we now know their defined arguments, check that they fulfill
10807 the requirements of the standard for procedures used as finalizers. */
10810 gfc_resolve_finalizers (gfc_symbol* derived)
10812 gfc_finalizer* list;
10813 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10814 gfc_try result = SUCCESS;
10815 bool seen_scalar = false;
10817 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10820 /* Walk over the list of finalizer-procedures, check them, and if any one
10821 does not fit in with the standard's definition, print an error and remove
10822 it from the list. */
10823 prev_link = &derived->f2k_derived->finalizers;
10824 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10830 /* Skip this finalizer if we already resolved it. */
10831 if (list->proc_tree)
10833 prev_link = &(list->next);
10837 /* Check this exists and is a SUBROUTINE. */
10838 if (!list->proc_sym->attr.subroutine)
10840 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10841 list->proc_sym->name, &list->where);
10845 /* We should have exactly one argument. */
10846 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10848 gfc_error ("FINAL procedure at %L must have exactly one argument",
10852 arg = list->proc_sym->formal->sym;
10854 /* This argument must be of our type. */
10855 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10857 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10858 &arg->declared_at, derived->name);
10862 /* It must neither be a pointer nor allocatable nor optional. */
10863 if (arg->attr.pointer)
10865 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10866 &arg->declared_at);
10869 if (arg->attr.allocatable)
10871 gfc_error ("Argument of FINAL procedure at %L must not be"
10872 " ALLOCATABLE", &arg->declared_at);
10875 if (arg->attr.optional)
10877 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10878 &arg->declared_at);
10882 /* It must not be INTENT(OUT). */
10883 if (arg->attr.intent == INTENT_OUT)
10885 gfc_error ("Argument of FINAL procedure at %L must not be"
10886 " INTENT(OUT)", &arg->declared_at);
10890 /* Warn if the procedure is non-scalar and not assumed shape. */
10891 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10892 && arg->as->type != AS_ASSUMED_SHAPE)
10893 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10894 " shape argument", &arg->declared_at);
10896 /* Check that it does not match in kind and rank with a FINAL procedure
10897 defined earlier. To really loop over the *earlier* declarations,
10898 we need to walk the tail of the list as new ones were pushed at the
10900 /* TODO: Handle kind parameters once they are implemented. */
10901 my_rank = (arg->as ? arg->as->rank : 0);
10902 for (i = list->next; i; i = i->next)
10904 /* Argument list might be empty; that is an error signalled earlier,
10905 but we nevertheless continued resolving. */
10906 if (i->proc_sym->formal)
10908 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10909 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10910 if (i_rank == my_rank)
10912 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10913 " rank (%d) as '%s'",
10914 list->proc_sym->name, &list->where, my_rank,
10915 i->proc_sym->name);
10921 /* Is this the/a scalar finalizer procedure? */
10922 if (!arg->as || arg->as->rank == 0)
10923 seen_scalar = true;
10925 /* Find the symtree for this procedure. */
10926 gcc_assert (!list->proc_tree);
10927 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10929 prev_link = &list->next;
10932 /* Remove wrong nodes immediately from the list so we don't risk any
10933 troubles in the future when they might fail later expectations. */
10937 *prev_link = list->next;
10938 gfc_free_finalizer (i);
10941 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10942 were nodes in the list, must have been for arrays. It is surely a good
10943 idea to have a scalar version there if there's something to finalize. */
10944 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10945 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10946 " defined at %L, suggest also scalar one",
10947 derived->name, &derived->declared_at);
10949 /* TODO: Remove this error when finalization is finished. */
10950 gfc_error ("Finalization at %L is not yet implemented",
10951 &derived->declared_at);
10957 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10960 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10961 const char* generic_name, locus where)
10966 gcc_assert (t1->specific && t2->specific);
10967 gcc_assert (!t1->specific->is_generic);
10968 gcc_assert (!t2->specific->is_generic);
10970 sym1 = t1->specific->u.specific->n.sym;
10971 sym2 = t2->specific->u.specific->n.sym;
10976 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10977 if (sym1->attr.subroutine != sym2->attr.subroutine
10978 || sym1->attr.function != sym2->attr.function)
10980 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10981 " GENERIC '%s' at %L",
10982 sym1->name, sym2->name, generic_name, &where);
10986 /* Compare the interfaces. */
10987 if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
10989 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10990 sym1->name, sym2->name, generic_name, &where);
10998 /* Worker function for resolving a generic procedure binding; this is used to
10999 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11001 The difference between those cases is finding possible inherited bindings
11002 that are overridden, as one has to look for them in tb_sym_root,
11003 tb_uop_root or tb_op, respectively. Thus the caller must already find
11004 the super-type and set p->overridden correctly. */
11007 resolve_tb_generic_targets (gfc_symbol* super_type,
11008 gfc_typebound_proc* p, const char* name)
11010 gfc_tbp_generic* target;
11011 gfc_symtree* first_target;
11012 gfc_symtree* inherited;
11014 gcc_assert (p && p->is_generic);
11016 /* Try to find the specific bindings for the symtrees in our target-list. */
11017 gcc_assert (p->u.generic);
11018 for (target = p->u.generic; target; target = target->next)
11019 if (!target->specific)
11021 gfc_typebound_proc* overridden_tbp;
11022 gfc_tbp_generic* g;
11023 const char* target_name;
11025 target_name = target->specific_st->name;
11027 /* Defined for this type directly. */
11028 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
11030 target->specific = target->specific_st->n.tb;
11031 goto specific_found;
11034 /* Look for an inherited specific binding. */
11037 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
11042 gcc_assert (inherited->n.tb);
11043 target->specific = inherited->n.tb;
11044 goto specific_found;
11048 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11049 " at %L", target_name, name, &p->where);
11052 /* Once we've found the specific binding, check it is not ambiguous with
11053 other specifics already found or inherited for the same GENERIC. */
11055 gcc_assert (target->specific);
11057 /* This must really be a specific binding! */
11058 if (target->specific->is_generic)
11060 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11061 " '%s' is GENERIC, too", name, &p->where, target_name);
11065 /* Check those already resolved on this type directly. */
11066 for (g = p->u.generic; g; g = g->next)
11067 if (g != target && g->specific
11068 && check_generic_tbp_ambiguity (target, g, name, p->where)
11072 /* Check for ambiguity with inherited specific targets. */
11073 for (overridden_tbp = p->overridden; overridden_tbp;
11074 overridden_tbp = overridden_tbp->overridden)
11075 if (overridden_tbp->is_generic)
11077 for (g = overridden_tbp->u.generic; g; g = g->next)
11079 gcc_assert (g->specific);
11080 if (check_generic_tbp_ambiguity (target, g,
11081 name, p->where) == FAILURE)
11087 /* If we attempt to "overwrite" a specific binding, this is an error. */
11088 if (p->overridden && !p->overridden->is_generic)
11090 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11091 " the same name", name, &p->where);
11095 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11096 all must have the same attributes here. */
11097 first_target = p->u.generic->specific->u.specific;
11098 gcc_assert (first_target);
11099 p->subroutine = first_target->n.sym->attr.subroutine;
11100 p->function = first_target->n.sym->attr.function;
11106 /* Resolve a GENERIC procedure binding for a derived type. */
11109 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
11111 gfc_symbol* super_type;
11113 /* Find the overridden binding if any. */
11114 st->n.tb->overridden = NULL;
11115 super_type = gfc_get_derived_super_type (derived);
11118 gfc_symtree* overridden;
11119 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
11122 if (overridden && overridden->n.tb)
11123 st->n.tb->overridden = overridden->n.tb;
11126 /* Resolve using worker function. */
11127 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
11131 /* Retrieve the target-procedure of an operator binding and do some checks in
11132 common for intrinsic and user-defined type-bound operators. */
11135 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
11137 gfc_symbol* target_proc;
11139 gcc_assert (target->specific && !target->specific->is_generic);
11140 target_proc = target->specific->u.specific->n.sym;
11141 gcc_assert (target_proc);
11143 /* All operator bindings must have a passed-object dummy argument. */
11144 if (target->specific->nopass)
11146 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
11150 return target_proc;
11154 /* Resolve a type-bound intrinsic operator. */
11157 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
11158 gfc_typebound_proc* p)
11160 gfc_symbol* super_type;
11161 gfc_tbp_generic* target;
11163 /* If there's already an error here, do nothing (but don't fail again). */
11167 /* Operators should always be GENERIC bindings. */
11168 gcc_assert (p->is_generic);
11170 /* Look for an overridden binding. */
11171 super_type = gfc_get_derived_super_type (derived);
11172 if (super_type && super_type->f2k_derived)
11173 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
11176 p->overridden = NULL;
11178 /* Resolve general GENERIC properties using worker function. */
11179 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
11182 /* Check the targets to be procedures of correct interface. */
11183 for (target = p->u.generic; target; target = target->next)
11185 gfc_symbol* target_proc;
11187 target_proc = get_checked_tb_operator_target (target, p->where);
11191 if (!gfc_check_operator_interface (target_proc, op, p->where))
11203 /* Resolve a type-bound user operator (tree-walker callback). */
11205 static gfc_symbol* resolve_bindings_derived;
11206 static gfc_try resolve_bindings_result;
11208 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
11211 resolve_typebound_user_op (gfc_symtree* stree)
11213 gfc_symbol* super_type;
11214 gfc_tbp_generic* target;
11216 gcc_assert (stree && stree->n.tb);
11218 if (stree->n.tb->error)
11221 /* Operators should always be GENERIC bindings. */
11222 gcc_assert (stree->n.tb->is_generic);
11224 /* Find overridden procedure, if any. */
11225 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11226 if (super_type && super_type->f2k_derived)
11228 gfc_symtree* overridden;
11229 overridden = gfc_find_typebound_user_op (super_type, NULL,
11230 stree->name, true, NULL);
11232 if (overridden && overridden->n.tb)
11233 stree->n.tb->overridden = overridden->n.tb;
11236 stree->n.tb->overridden = NULL;
11238 /* Resolve basically using worker function. */
11239 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
11243 /* Check the targets to be functions of correct interface. */
11244 for (target = stree->n.tb->u.generic; target; target = target->next)
11246 gfc_symbol* target_proc;
11248 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
11252 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
11259 resolve_bindings_result = FAILURE;
11260 stree->n.tb->error = 1;
11264 /* Resolve the type-bound procedures for a derived type. */
11267 resolve_typebound_procedure (gfc_symtree* stree)
11271 gfc_symbol* me_arg;
11272 gfc_symbol* super_type;
11273 gfc_component* comp;
11275 gcc_assert (stree);
11277 /* Undefined specific symbol from GENERIC target definition. */
11281 if (stree->n.tb->error)
11284 /* If this is a GENERIC binding, use that routine. */
11285 if (stree->n.tb->is_generic)
11287 if (resolve_typebound_generic (resolve_bindings_derived, stree)
11293 /* Get the target-procedure to check it. */
11294 gcc_assert (!stree->n.tb->is_generic);
11295 gcc_assert (stree->n.tb->u.specific);
11296 proc = stree->n.tb->u.specific->n.sym;
11297 where = stree->n.tb->where;
11299 /* Default access should already be resolved from the parser. */
11300 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
11302 /* It should be a module procedure or an external procedure with explicit
11303 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
11304 if ((!proc->attr.subroutine && !proc->attr.function)
11305 || (proc->attr.proc != PROC_MODULE
11306 && proc->attr.if_source != IFSRC_IFBODY)
11307 || (proc->attr.abstract && !stree->n.tb->deferred))
11309 gfc_error ("'%s' must be a module procedure or an external procedure with"
11310 " an explicit interface at %L", proc->name, &where);
11313 stree->n.tb->subroutine = proc->attr.subroutine;
11314 stree->n.tb->function = proc->attr.function;
11316 /* Find the super-type of the current derived type. We could do this once and
11317 store in a global if speed is needed, but as long as not I believe this is
11318 more readable and clearer. */
11319 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11321 /* If PASS, resolve and check arguments if not already resolved / loaded
11322 from a .mod file. */
11323 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
11325 if (stree->n.tb->pass_arg)
11327 gfc_formal_arglist* i;
11329 /* If an explicit passing argument name is given, walk the arg-list
11330 and look for it. */
11333 stree->n.tb->pass_arg_num = 1;
11334 for (i = proc->formal; i; i = i->next)
11336 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
11341 ++stree->n.tb->pass_arg_num;
11346 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11348 proc->name, stree->n.tb->pass_arg, &where,
11349 stree->n.tb->pass_arg);
11355 /* Otherwise, take the first one; there should in fact be at least
11357 stree->n.tb->pass_arg_num = 1;
11360 gfc_error ("Procedure '%s' with PASS at %L must have at"
11361 " least one argument", proc->name, &where);
11364 me_arg = proc->formal->sym;
11367 /* Now check that the argument-type matches and the passed-object
11368 dummy argument is generally fine. */
11370 gcc_assert (me_arg);
11372 if (me_arg->ts.type != BT_CLASS)
11374 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11375 " at %L", proc->name, &where);
11379 if (CLASS_DATA (me_arg)->ts.u.derived
11380 != resolve_bindings_derived)
11382 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11383 " the derived-type '%s'", me_arg->name, proc->name,
11384 me_arg->name, &where, resolve_bindings_derived->name);
11388 gcc_assert (me_arg->ts.type == BT_CLASS);
11389 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
11391 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11392 " scalar", proc->name, &where);
11395 if (CLASS_DATA (me_arg)->attr.allocatable)
11397 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11398 " be ALLOCATABLE", proc->name, &where);
11401 if (CLASS_DATA (me_arg)->attr.class_pointer)
11403 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11404 " be POINTER", proc->name, &where);
11409 /* If we are extending some type, check that we don't override a procedure
11410 flagged NON_OVERRIDABLE. */
11411 stree->n.tb->overridden = NULL;
11414 gfc_symtree* overridden;
11415 overridden = gfc_find_typebound_proc (super_type, NULL,
11416 stree->name, true, NULL);
11420 if (overridden->n.tb)
11421 stree->n.tb->overridden = overridden->n.tb;
11423 if (gfc_check_typebound_override (stree, overridden) == FAILURE)
11428 /* See if there's a name collision with a component directly in this type. */
11429 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11430 if (!strcmp (comp->name, stree->name))
11432 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11434 stree->name, &where, resolve_bindings_derived->name);
11438 /* Try to find a name collision with an inherited component. */
11439 if (super_type && gfc_find_component (super_type, stree->name, true, true))
11441 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11442 " component of '%s'",
11443 stree->name, &where, resolve_bindings_derived->name);
11447 stree->n.tb->error = 0;
11451 resolve_bindings_result = FAILURE;
11452 stree->n.tb->error = 1;
11457 resolve_typebound_procedures (gfc_symbol* derived)
11460 gfc_symbol* super_type;
11462 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11465 super_type = gfc_get_derived_super_type (derived);
11467 resolve_typebound_procedures (super_type);
11469 resolve_bindings_derived = derived;
11470 resolve_bindings_result = SUCCESS;
11472 /* Make sure the vtab has been generated. */
11473 gfc_find_derived_vtab (derived);
11475 if (derived->f2k_derived->tb_sym_root)
11476 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11477 &resolve_typebound_procedure);
11479 if (derived->f2k_derived->tb_uop_root)
11480 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11481 &resolve_typebound_user_op);
11483 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11485 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11486 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11488 resolve_bindings_result = FAILURE;
11491 return resolve_bindings_result;
11495 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11496 to give all identical derived types the same backend_decl. */
11498 add_dt_to_dt_list (gfc_symbol *derived)
11500 gfc_dt_list *dt_list;
11502 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11503 if (derived == dt_list->derived)
11506 dt_list = gfc_get_dt_list ();
11507 dt_list->next = gfc_derived_types;
11508 dt_list->derived = derived;
11509 gfc_derived_types = dt_list;
11513 /* Ensure that a derived-type is really not abstract, meaning that every
11514 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11517 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11522 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11524 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11527 if (st->n.tb && st->n.tb->deferred)
11529 gfc_symtree* overriding;
11530 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11533 gcc_assert (overriding->n.tb);
11534 if (overriding->n.tb->deferred)
11536 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11537 " '%s' is DEFERRED and not overridden",
11538 sub->name, &sub->declared_at, st->name);
11547 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11549 /* The algorithm used here is to recursively travel up the ancestry of sub
11550 and for each ancestor-type, check all bindings. If any of them is
11551 DEFERRED, look it up starting from sub and see if the found (overriding)
11552 binding is not DEFERRED.
11553 This is not the most efficient way to do this, but it should be ok and is
11554 clearer than something sophisticated. */
11556 gcc_assert (ancestor && !sub->attr.abstract);
11558 if (!ancestor->attr.abstract)
11561 /* Walk bindings of this ancestor. */
11562 if (ancestor->f2k_derived)
11565 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11570 /* Find next ancestor type and recurse on it. */
11571 ancestor = gfc_get_derived_super_type (ancestor);
11573 return ensure_not_abstract (sub, ancestor);
11579 /* Resolve the components of a derived type. This does not have to wait until
11580 resolution stage, but can be done as soon as the dt declaration has been
11584 resolve_fl_derived0 (gfc_symbol *sym)
11586 gfc_symbol* super_type;
11589 super_type = gfc_get_derived_super_type (sym);
11592 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11594 gfc_error ("As extending type '%s' at %L has a coarray component, "
11595 "parent type '%s' shall also have one", sym->name,
11596 &sym->declared_at, super_type->name);
11600 /* Ensure the extended type gets resolved before we do. */
11601 if (super_type && resolve_fl_derived0 (super_type) == FAILURE)
11604 /* An ABSTRACT type must be extensible. */
11605 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11607 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11608 sym->name, &sym->declared_at);
11612 c = (sym->attr.is_class) ? sym->components->ts.u.derived->components
11615 for ( ; c != NULL; c = c->next)
11617 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
11618 if (c->ts.type == BT_CHARACTER && c->ts.deferred)
11620 gfc_error ("Deferred-length character component '%s' at %L is not "
11621 "yet supported", c->name, &c->loc);
11626 if ((!sym->attr.is_class || c != sym->components)
11627 && c->attr.codimension
11628 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11630 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11631 "deferred shape", c->name, &c->loc);
11636 if (c->attr.codimension && c->ts.type == BT_DERIVED
11637 && c->ts.u.derived->ts.is_iso_c)
11639 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11640 "shall not be a coarray", c->name, &c->loc);
11645 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11646 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11647 || c->attr.allocatable))
11649 gfc_error ("Component '%s' at %L with coarray component "
11650 "shall be a nonpointer, nonallocatable scalar",
11656 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11658 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11659 "is not an array pointer", c->name, &c->loc);
11663 if (c->attr.proc_pointer && c->ts.interface)
11665 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11666 gfc_error ("Interface '%s', used by procedure pointer component "
11667 "'%s' at %L, is declared in a later PROCEDURE statement",
11668 c->ts.interface->name, c->name, &c->loc);
11670 /* Get the attributes from the interface (now resolved). */
11671 if (c->ts.interface->attr.if_source
11672 || c->ts.interface->attr.intrinsic)
11674 gfc_symbol *ifc = c->ts.interface;
11676 if (ifc->formal && !ifc->formal_ns)
11677 resolve_symbol (ifc);
11679 if (ifc->attr.intrinsic)
11680 resolve_intrinsic (ifc, &ifc->declared_at);
11684 c->ts = ifc->result->ts;
11685 c->attr.allocatable = ifc->result->attr.allocatable;
11686 c->attr.pointer = ifc->result->attr.pointer;
11687 c->attr.dimension = ifc->result->attr.dimension;
11688 c->as = gfc_copy_array_spec (ifc->result->as);
11693 c->attr.allocatable = ifc->attr.allocatable;
11694 c->attr.pointer = ifc->attr.pointer;
11695 c->attr.dimension = ifc->attr.dimension;
11696 c->as = gfc_copy_array_spec (ifc->as);
11698 c->ts.interface = ifc;
11699 c->attr.function = ifc->attr.function;
11700 c->attr.subroutine = ifc->attr.subroutine;
11701 gfc_copy_formal_args_ppc (c, ifc);
11703 c->attr.pure = ifc->attr.pure;
11704 c->attr.elemental = ifc->attr.elemental;
11705 c->attr.recursive = ifc->attr.recursive;
11706 c->attr.always_explicit = ifc->attr.always_explicit;
11707 c->attr.ext_attr |= ifc->attr.ext_attr;
11708 /* Replace symbols in array spec. */
11712 for (i = 0; i < c->as->rank; i++)
11714 gfc_expr_replace_comp (c->as->lower[i], c);
11715 gfc_expr_replace_comp (c->as->upper[i], c);
11718 /* Copy char length. */
11719 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11721 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11722 gfc_expr_replace_comp (cl->length, c);
11723 if (cl->length && !cl->resolved
11724 && gfc_resolve_expr (cl->length) == FAILURE)
11729 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11731 gfc_error ("Interface '%s' of procedure pointer component "
11732 "'%s' at %L must be explicit", c->ts.interface->name,
11737 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11739 /* Since PPCs are not implicitly typed, a PPC without an explicit
11740 interface must be a subroutine. */
11741 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11744 /* Procedure pointer components: Check PASS arg. */
11745 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11746 && !sym->attr.vtype)
11748 gfc_symbol* me_arg;
11750 if (c->tb->pass_arg)
11752 gfc_formal_arglist* i;
11754 /* If an explicit passing argument name is given, walk the arg-list
11755 and look for it. */
11758 c->tb->pass_arg_num = 1;
11759 for (i = c->formal; i; i = i->next)
11761 if (!strcmp (i->sym->name, c->tb->pass_arg))
11766 c->tb->pass_arg_num++;
11771 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11772 "at %L has no argument '%s'", c->name,
11773 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11780 /* Otherwise, take the first one; there should in fact be at least
11782 c->tb->pass_arg_num = 1;
11785 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11786 "must have at least one argument",
11791 me_arg = c->formal->sym;
11794 /* Now check that the argument-type matches. */
11795 gcc_assert (me_arg);
11796 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11797 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11798 || (me_arg->ts.type == BT_CLASS
11799 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11801 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11802 " the derived type '%s'", me_arg->name, c->name,
11803 me_arg->name, &c->loc, sym->name);
11808 /* Check for C453. */
11809 if (me_arg->attr.dimension)
11811 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11812 "must be scalar", me_arg->name, c->name, me_arg->name,
11818 if (me_arg->attr.pointer)
11820 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11821 "may not have the POINTER attribute", me_arg->name,
11822 c->name, me_arg->name, &c->loc);
11827 if (me_arg->attr.allocatable)
11829 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11830 "may not be ALLOCATABLE", me_arg->name, c->name,
11831 me_arg->name, &c->loc);
11836 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11837 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11838 " at %L", c->name, &c->loc);
11842 /* Check type-spec if this is not the parent-type component. */
11843 if (((sym->attr.is_class
11844 && (!sym->components->ts.u.derived->attr.extension
11845 || c != sym->components->ts.u.derived->components))
11846 || (!sym->attr.is_class
11847 && (!sym->attr.extension || c != sym->components)))
11848 && !sym->attr.vtype
11849 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11852 /* If this type is an extension, set the accessibility of the parent
11855 && ((sym->attr.is_class
11856 && c == sym->components->ts.u.derived->components)
11857 || (!sym->attr.is_class && c == sym->components))
11858 && strcmp (super_type->name, c->name) == 0)
11859 c->attr.access = super_type->attr.access;
11861 /* If this type is an extension, see if this component has the same name
11862 as an inherited type-bound procedure. */
11863 if (super_type && !sym->attr.is_class
11864 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11866 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11867 " inherited type-bound procedure",
11868 c->name, sym->name, &c->loc);
11872 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
11873 && !c->ts.deferred)
11875 if (c->ts.u.cl->length == NULL
11876 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11877 || !gfc_is_constant_expr (c->ts.u.cl->length))
11879 gfc_error ("Character length of component '%s' needs to "
11880 "be a constant specification expression at %L",
11882 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11887 if (c->ts.type == BT_CHARACTER && c->ts.deferred
11888 && !c->attr.pointer && !c->attr.allocatable)
11890 gfc_error ("Character component '%s' of '%s' at %L with deferred "
11891 "length must be a POINTER or ALLOCATABLE",
11892 c->name, sym->name, &c->loc);
11896 if (c->ts.type == BT_DERIVED
11897 && sym->component_access != ACCESS_PRIVATE
11898 && gfc_check_symbol_access (sym)
11899 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11900 && !c->ts.u.derived->attr.use_assoc
11901 && !gfc_check_symbol_access (c->ts.u.derived)
11902 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11903 "is a PRIVATE type and cannot be a component of "
11904 "'%s', which is PUBLIC at %L", c->name,
11905 sym->name, &sym->declared_at) == FAILURE)
11908 if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
11910 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11911 "type %s", c->name, &c->loc, sym->name);
11915 if (sym->attr.sequence)
11917 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11919 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11920 "not have the SEQUENCE attribute",
11921 c->ts.u.derived->name, &sym->declared_at);
11926 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
11927 c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
11928 else if (c->ts.type == BT_CLASS && c->attr.class_ok
11929 && CLASS_DATA (c)->ts.u.derived->attr.generic)
11930 CLASS_DATA (c)->ts.u.derived
11931 = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
11933 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
11934 && c->attr.pointer && c->ts.u.derived->components == NULL
11935 && !c->ts.u.derived->attr.zero_comp)
11937 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11938 "that has not been declared", c->name, sym->name,
11943 if (c->ts.type == BT_CLASS && c->attr.class_ok
11944 && CLASS_DATA (c)->attr.class_pointer
11945 && CLASS_DATA (c)->ts.u.derived->components == NULL
11946 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11948 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11949 "that has not been declared", c->name, sym->name,
11955 if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE
11956 && (!c->attr.class_ok
11957 || !(CLASS_DATA (c)->attr.class_pointer
11958 || CLASS_DATA (c)->attr.allocatable)))
11960 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11961 "or pointer", c->name, &c->loc);
11965 /* Ensure that all the derived type components are put on the
11966 derived type list; even in formal namespaces, where derived type
11967 pointer components might not have been declared. */
11968 if (c->ts.type == BT_DERIVED
11970 && c->ts.u.derived->components
11972 && sym != c->ts.u.derived)
11973 add_dt_to_dt_list (c->ts.u.derived);
11975 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11976 || c->attr.proc_pointer
11977 || c->attr.allocatable)) == FAILURE)
11981 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11982 all DEFERRED bindings are overridden. */
11983 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11984 && !sym->attr.is_class
11985 && ensure_not_abstract (sym, super_type) == FAILURE)
11988 /* Add derived type to the derived type list. */
11989 add_dt_to_dt_list (sym);
11995 /* The following procedure does the full resolution of a derived type,
11996 including resolution of all type-bound procedures (if present). In contrast
11997 to 'resolve_fl_derived0' this can only be done after the module has been
11998 parsed completely. */
12001 resolve_fl_derived (gfc_symbol *sym)
12003 gfc_symbol *gen_dt = NULL;
12005 if (!sym->attr.is_class)
12006 gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
12007 if (gen_dt && gen_dt->generic && gen_dt->generic->next
12008 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Generic name '%s' of "
12009 "function '%s' at %L being the same name as derived "
12010 "type at %L", sym->name,
12011 gen_dt->generic->sym == sym
12012 ? gen_dt->generic->next->sym->name
12013 : gen_dt->generic->sym->name,
12014 gen_dt->generic->sym == sym
12015 ? &gen_dt->generic->next->sym->declared_at
12016 : &gen_dt->generic->sym->declared_at,
12017 &sym->declared_at) == FAILURE)
12020 if (sym->attr.is_class && sym->ts.u.derived == NULL)
12022 /* Fix up incomplete CLASS symbols. */
12023 gfc_component *data = gfc_find_component (sym, "_data", true, true);
12024 gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
12025 if (vptr->ts.u.derived == NULL)
12027 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
12029 vptr->ts.u.derived = vtab->ts.u.derived;
12033 if (resolve_fl_derived0 (sym) == FAILURE)
12036 /* Resolve the type-bound procedures. */
12037 if (resolve_typebound_procedures (sym) == FAILURE)
12040 /* Resolve the finalizer procedures. */
12041 if (gfc_resolve_finalizers (sym) == FAILURE)
12049 resolve_fl_namelist (gfc_symbol *sym)
12054 for (nl = sym->namelist; nl; nl = nl->next)
12056 /* Check again, the check in match only works if NAMELIST comes
12058 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
12060 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12061 "allowed", nl->sym->name, sym->name, &sym->declared_at);
12065 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
12066 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
12067 "object '%s' with assumed shape in namelist "
12068 "'%s' at %L", nl->sym->name, sym->name,
12069 &sym->declared_at) == FAILURE)
12072 if (is_non_constant_shape_array (nl->sym)
12073 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
12074 "object '%s' with nonconstant shape in namelist "
12075 "'%s' at %L", nl->sym->name, sym->name,
12076 &sym->declared_at) == FAILURE)
12079 if (nl->sym->ts.type == BT_CHARACTER
12080 && (nl->sym->ts.u.cl->length == NULL
12081 || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
12082 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
12083 "'%s' with nonconstant character length in "
12084 "namelist '%s' at %L", nl->sym->name, sym->name,
12085 &sym->declared_at) == FAILURE)
12088 /* FIXME: Once UDDTIO is implemented, the following can be
12090 if (nl->sym->ts.type == BT_CLASS)
12092 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12093 "polymorphic and requires a defined input/output "
12094 "procedure", nl->sym->name, sym->name, &sym->declared_at);
12098 if (nl->sym->ts.type == BT_DERIVED
12099 && (nl->sym->ts.u.derived->attr.alloc_comp
12100 || nl->sym->ts.u.derived->attr.pointer_comp))
12102 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
12103 "'%s' in namelist '%s' at %L with ALLOCATABLE "
12104 "or POINTER components", nl->sym->name,
12105 sym->name, &sym->declared_at) == FAILURE)
12108 /* FIXME: Once UDDTIO is implemented, the following can be
12110 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12111 "ALLOCATABLE or POINTER components and thus requires "
12112 "a defined input/output procedure", nl->sym->name,
12113 sym->name, &sym->declared_at);
12118 /* Reject PRIVATE objects in a PUBLIC namelist. */
12119 if (gfc_check_symbol_access (sym))
12121 for (nl = sym->namelist; nl; nl = nl->next)
12123 if (!nl->sym->attr.use_assoc
12124 && !is_sym_host_assoc (nl->sym, sym->ns)
12125 && !gfc_check_symbol_access (nl->sym))
12127 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12128 "cannot be member of PUBLIC namelist '%s' at %L",
12129 nl->sym->name, sym->name, &sym->declared_at);
12133 /* Types with private components that came here by USE-association. */
12134 if (nl->sym->ts.type == BT_DERIVED
12135 && derived_inaccessible (nl->sym->ts.u.derived))
12137 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12138 "components and cannot be member of namelist '%s' at %L",
12139 nl->sym->name, sym->name, &sym->declared_at);
12143 /* Types with private components that are defined in the same module. */
12144 if (nl->sym->ts.type == BT_DERIVED
12145 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
12146 && nl->sym->ts.u.derived->attr.private_comp)
12148 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12149 "cannot be a member of PUBLIC namelist '%s' at %L",
12150 nl->sym->name, sym->name, &sym->declared_at);
12157 /* 14.1.2 A module or internal procedure represent local entities
12158 of the same type as a namelist member and so are not allowed. */
12159 for (nl = sym->namelist; nl; nl = nl->next)
12161 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
12164 if (nl->sym->attr.function && nl->sym == nl->sym->result)
12165 if ((nl->sym == sym->ns->proc_name)
12167 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
12171 if (nl->sym && nl->sym->name)
12172 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
12173 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
12175 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12176 "attribute in '%s' at %L", nlsym->name,
12177 &sym->declared_at);
12187 resolve_fl_parameter (gfc_symbol *sym)
12189 /* A parameter array's shape needs to be constant. */
12190 if (sym->as != NULL
12191 && (sym->as->type == AS_DEFERRED
12192 || is_non_constant_shape_array (sym)))
12194 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12195 "or of deferred shape", sym->name, &sym->declared_at);
12199 /* Make sure a parameter that has been implicitly typed still
12200 matches the implicit type, since PARAMETER statements can precede
12201 IMPLICIT statements. */
12202 if (sym->attr.implicit_type
12203 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
12206 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12207 "later IMPLICIT type", sym->name, &sym->declared_at);
12211 /* Make sure the types of derived parameters are consistent. This
12212 type checking is deferred until resolution because the type may
12213 refer to a derived type from the host. */
12214 if (sym->ts.type == BT_DERIVED
12215 && !gfc_compare_types (&sym->ts, &sym->value->ts))
12217 gfc_error ("Incompatible derived type in PARAMETER at %L",
12218 &sym->value->where);
12225 /* Do anything necessary to resolve a symbol. Right now, we just
12226 assume that an otherwise unknown symbol is a variable. This sort
12227 of thing commonly happens for symbols in module. */
12230 resolve_symbol (gfc_symbol *sym)
12232 int check_constant, mp_flag;
12233 gfc_symtree *symtree;
12234 gfc_symtree *this_symtree;
12237 symbol_attribute class_attr;
12238 gfc_array_spec *as;
12240 if (sym->attr.flavor == FL_UNKNOWN)
12243 /* If we find that a flavorless symbol is an interface in one of the
12244 parent namespaces, find its symtree in this namespace, free the
12245 symbol and set the symtree to point to the interface symbol. */
12246 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
12248 symtree = gfc_find_symtree (ns->sym_root, sym->name);
12249 if (symtree && (symtree->n.sym->generic ||
12250 (symtree->n.sym->attr.flavor == FL_PROCEDURE
12251 && sym->ns->construct_entities)))
12253 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
12255 gfc_release_symbol (sym);
12256 symtree->n.sym->refs++;
12257 this_symtree->n.sym = symtree->n.sym;
12262 /* Otherwise give it a flavor according to such attributes as
12264 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
12265 sym->attr.flavor = FL_VARIABLE;
12268 sym->attr.flavor = FL_PROCEDURE;
12269 if (sym->attr.dimension)
12270 sym->attr.function = 1;
12274 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
12275 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
12277 if (sym->attr.procedure && sym->ts.interface
12278 && sym->attr.if_source != IFSRC_DECL
12279 && resolve_procedure_interface (sym) == FAILURE)
12282 if (sym->attr.is_protected && !sym->attr.proc_pointer
12283 && (sym->attr.procedure || sym->attr.external))
12285 if (sym->attr.external)
12286 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12287 "at %L", &sym->declared_at);
12289 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12290 "at %L", &sym->declared_at);
12295 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
12298 /* Symbols that are module procedures with results (functions) have
12299 the types and array specification copied for type checking in
12300 procedures that call them, as well as for saving to a module
12301 file. These symbols can't stand the scrutiny that their results
12303 mp_flag = (sym->result != NULL && sym->result != sym);
12305 /* Make sure that the intrinsic is consistent with its internal
12306 representation. This needs to be done before assigning a default
12307 type to avoid spurious warnings. */
12308 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
12309 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
12312 /* Resolve associate names. */
12314 resolve_assoc_var (sym, true);
12316 /* Assign default type to symbols that need one and don't have one. */
12317 if (sym->ts.type == BT_UNKNOWN)
12319 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
12321 gfc_set_default_type (sym, 1, NULL);
12324 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
12325 && !sym->attr.function && !sym->attr.subroutine
12326 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
12327 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
12329 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
12331 /* The specific case of an external procedure should emit an error
12332 in the case that there is no implicit type. */
12334 gfc_set_default_type (sym, sym->attr.external, NULL);
12337 /* Result may be in another namespace. */
12338 resolve_symbol (sym->result);
12340 if (!sym->result->attr.proc_pointer)
12342 sym->ts = sym->result->ts;
12343 sym->as = gfc_copy_array_spec (sym->result->as);
12344 sym->attr.dimension = sym->result->attr.dimension;
12345 sym->attr.pointer = sym->result->attr.pointer;
12346 sym->attr.allocatable = sym->result->attr.allocatable;
12347 sym->attr.contiguous = sym->result->attr.contiguous;
12352 else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
12353 gfc_resolve_array_spec (sym->result->as, false);
12355 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
12357 as = CLASS_DATA (sym)->as;
12358 class_attr = CLASS_DATA (sym)->attr;
12359 class_attr.pointer = class_attr.class_pointer;
12363 class_attr = sym->attr;
12368 if (sym->attr.contiguous
12369 && (!class_attr.dimension
12370 || (as->type != AS_ASSUMED_SHAPE && !class_attr.pointer)))
12372 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12373 "array pointer or an assumed-shape array", sym->name,
12374 &sym->declared_at);
12378 /* Assumed size arrays and assumed shape arrays must be dummy
12379 arguments. Array-spec's of implied-shape should have been resolved to
12380 AS_EXPLICIT already. */
12384 gcc_assert (as->type != AS_IMPLIED_SHAPE);
12385 if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
12386 || as->type == AS_ASSUMED_SHAPE)
12387 && sym->attr.dummy == 0)
12389 if (as->type == AS_ASSUMED_SIZE)
12390 gfc_error ("Assumed size array at %L must be a dummy argument",
12391 &sym->declared_at);
12393 gfc_error ("Assumed shape array at %L must be a dummy argument",
12394 &sym->declared_at);
12399 /* Make sure symbols with known intent or optional are really dummy
12400 variable. Because of ENTRY statement, this has to be deferred
12401 until resolution time. */
12403 if (!sym->attr.dummy
12404 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
12406 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
12410 if (sym->attr.value && !sym->attr.dummy)
12412 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12413 "it is not a dummy argument", sym->name, &sym->declared_at);
12417 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
12419 gfc_charlen *cl = sym->ts.u.cl;
12420 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
12422 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12423 "attribute must have constant length",
12424 sym->name, &sym->declared_at);
12428 if (sym->ts.is_c_interop
12429 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
12431 gfc_error ("C interoperable character dummy variable '%s' at %L "
12432 "with VALUE attribute must have length one",
12433 sym->name, &sym->declared_at);
12438 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
12439 && sym->ts.u.derived->attr.generic)
12441 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
12442 if (!sym->ts.u.derived)
12444 gfc_error ("The derived type '%s' at %L is of type '%s', "
12445 "which has not been defined", sym->name,
12446 &sym->declared_at, sym->ts.u.derived->name);
12447 sym->ts.type = BT_UNKNOWN;
12452 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12453 do this for something that was implicitly typed because that is handled
12454 in gfc_set_default_type. Handle dummy arguments and procedure
12455 definitions separately. Also, anything that is use associated is not
12456 handled here but instead is handled in the module it is declared in.
12457 Finally, derived type definitions are allowed to be BIND(C) since that
12458 only implies that they're interoperable, and they are checked fully for
12459 interoperability when a variable is declared of that type. */
12460 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
12461 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
12462 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
12464 gfc_try t = SUCCESS;
12466 /* First, make sure the variable is declared at the
12467 module-level scope (J3/04-007, Section 15.3). */
12468 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
12469 sym->attr.in_common == 0)
12471 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12472 "is neither a COMMON block nor declared at the "
12473 "module level scope", sym->name, &(sym->declared_at));
12476 else if (sym->common_head != NULL)
12478 t = verify_com_block_vars_c_interop (sym->common_head);
12482 /* If type() declaration, we need to verify that the components
12483 of the given type are all C interoperable, etc. */
12484 if (sym->ts.type == BT_DERIVED &&
12485 sym->ts.u.derived->attr.is_c_interop != 1)
12487 /* Make sure the user marked the derived type as BIND(C). If
12488 not, call the verify routine. This could print an error
12489 for the derived type more than once if multiple variables
12490 of that type are declared. */
12491 if (sym->ts.u.derived->attr.is_bind_c != 1)
12492 verify_bind_c_derived_type (sym->ts.u.derived);
12496 /* Verify the variable itself as C interoperable if it
12497 is BIND(C). It is not possible for this to succeed if
12498 the verify_bind_c_derived_type failed, so don't have to handle
12499 any error returned by verify_bind_c_derived_type. */
12500 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
12501 sym->common_block);
12506 /* clear the is_bind_c flag to prevent reporting errors more than
12507 once if something failed. */
12508 sym->attr.is_bind_c = 0;
12513 /* If a derived type symbol has reached this point, without its
12514 type being declared, we have an error. Notice that most
12515 conditions that produce undefined derived types have already
12516 been dealt with. However, the likes of:
12517 implicit type(t) (t) ..... call foo (t) will get us here if
12518 the type is not declared in the scope of the implicit
12519 statement. Change the type to BT_UNKNOWN, both because it is so
12520 and to prevent an ICE. */
12521 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
12522 && sym->ts.u.derived->components == NULL
12523 && !sym->ts.u.derived->attr.zero_comp)
12525 gfc_error ("The derived type '%s' at %L is of type '%s', "
12526 "which has not been defined", sym->name,
12527 &sym->declared_at, sym->ts.u.derived->name);
12528 sym->ts.type = BT_UNKNOWN;
12532 /* Make sure that the derived type has been resolved and that the
12533 derived type is visible in the symbol's namespace, if it is a
12534 module function and is not PRIVATE. */
12535 if (sym->ts.type == BT_DERIVED
12536 && sym->ts.u.derived->attr.use_assoc
12537 && sym->ns->proc_name
12538 && sym->ns->proc_name->attr.flavor == FL_MODULE
12539 && resolve_fl_derived (sym->ts.u.derived) == FAILURE)
12542 /* Unless the derived-type declaration is use associated, Fortran 95
12543 does not allow public entries of private derived types.
12544 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12545 161 in 95-006r3. */
12546 if (sym->ts.type == BT_DERIVED
12547 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12548 && !sym->ts.u.derived->attr.use_assoc
12549 && gfc_check_symbol_access (sym)
12550 && !gfc_check_symbol_access (sym->ts.u.derived)
12551 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12552 "of PRIVATE derived type '%s'",
12553 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12554 : "variable", sym->name, &sym->declared_at,
12555 sym->ts.u.derived->name) == FAILURE)
12558 /* F2008, C1302. */
12559 if (sym->ts.type == BT_DERIVED
12560 && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
12561 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
12562 || sym->ts.u.derived->attr.lock_comp)
12563 && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
12565 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
12566 "type LOCK_TYPE must be a coarray", sym->name,
12567 &sym->declared_at);
12571 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12572 default initialization is defined (5.1.2.4.4). */
12573 if (sym->ts.type == BT_DERIVED
12575 && sym->attr.intent == INTENT_OUT
12577 && sym->as->type == AS_ASSUMED_SIZE)
12579 for (c = sym->ts.u.derived->components; c; c = c->next)
12581 if (c->initializer)
12583 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12584 "ASSUMED SIZE and so cannot have a default initializer",
12585 sym->name, &sym->declared_at);
12592 if (sym->ts.type == BT_DERIVED && sym->attr.dummy
12593 && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
12595 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
12596 "INTENT(OUT)", sym->name, &sym->declared_at);
12601 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12602 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12603 && CLASS_DATA (sym)->attr.coarray_comp))
12604 || class_attr.codimension)
12605 && (sym->attr.result || sym->result == sym))
12607 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12608 "a coarray component", sym->name, &sym->declared_at);
12613 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12614 && sym->ts.u.derived->ts.is_iso_c)
12616 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12617 "shall not be a coarray", sym->name, &sym->declared_at);
12622 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12623 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12624 && CLASS_DATA (sym)->attr.coarray_comp))
12625 && (class_attr.codimension || class_attr.pointer || class_attr.dimension
12626 || class_attr.allocatable))
12628 gfc_error ("Variable '%s' at %L with coarray component "
12629 "shall be a nonpointer, nonallocatable scalar",
12630 sym->name, &sym->declared_at);
12634 /* F2008, C526. The function-result case was handled above. */
12635 if (class_attr.codimension
12636 && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
12637 || sym->attr.select_type_temporary
12638 || sym->ns->save_all
12639 || sym->ns->proc_name->attr.flavor == FL_MODULE
12640 || sym->ns->proc_name->attr.is_main_program
12641 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12643 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
12644 "nor a dummy argument", sym->name, &sym->declared_at);
12648 else if (class_attr.codimension && !sym->attr.select_type_temporary
12649 && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
12651 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12652 "deferred shape", sym->name, &sym->declared_at);
12655 else if (class_attr.codimension && class_attr.allocatable && as
12656 && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
12658 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12659 "deferred shape", sym->name, &sym->declared_at);
12664 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12665 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12666 && CLASS_DATA (sym)->attr.coarray_comp))
12667 || (class_attr.codimension && class_attr.allocatable))
12668 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12670 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12671 "allocatable coarray or have coarray components",
12672 sym->name, &sym->declared_at);
12676 if (class_attr.codimension && sym->attr.dummy
12677 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12679 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12680 "procedure '%s'", sym->name, &sym->declared_at,
12681 sym->ns->proc_name->name);
12685 switch (sym->attr.flavor)
12688 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12693 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12698 if (resolve_fl_namelist (sym) == FAILURE)
12703 if (resolve_fl_parameter (sym) == FAILURE)
12711 /* Resolve array specifier. Check as well some constraints
12712 on COMMON blocks. */
12714 check_constant = sym->attr.in_common && !sym->attr.pointer;
12716 /* Set the formal_arg_flag so that check_conflict will not throw
12717 an error for host associated variables in the specification
12718 expression for an array_valued function. */
12719 if (sym->attr.function && sym->as)
12720 formal_arg_flag = 1;
12722 gfc_resolve_array_spec (sym->as, check_constant);
12724 formal_arg_flag = 0;
12726 /* Resolve formal namespaces. */
12727 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12728 && !sym->attr.contained && !sym->attr.intrinsic)
12729 gfc_resolve (sym->formal_ns);
12731 /* Make sure the formal namespace is present. */
12732 if (sym->formal && !sym->formal_ns)
12734 gfc_formal_arglist *formal = sym->formal;
12735 while (formal && !formal->sym)
12736 formal = formal->next;
12740 sym->formal_ns = formal->sym->ns;
12741 sym->formal_ns->refs++;
12745 /* Check threadprivate restrictions. */
12746 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12747 && (!sym->attr.in_common
12748 && sym->module == NULL
12749 && (sym->ns->proc_name == NULL
12750 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12751 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12753 /* If we have come this far we can apply default-initializers, as
12754 described in 14.7.5, to those variables that have not already
12755 been assigned one. */
12756 if (sym->ts.type == BT_DERIVED
12757 && sym->ns == gfc_current_ns
12759 && !sym->attr.allocatable
12760 && !sym->attr.alloc_comp)
12762 symbol_attribute *a = &sym->attr;
12764 if ((!a->save && !a->dummy && !a->pointer
12765 && !a->in_common && !a->use_assoc
12766 && (a->referenced || a->result)
12767 && !(a->function && sym != sym->result))
12768 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12769 apply_default_init (sym);
12772 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
12773 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
12774 && !CLASS_DATA (sym)->attr.class_pointer
12775 && !CLASS_DATA (sym)->attr.allocatable)
12776 apply_default_init (sym);
12778 /* If this symbol has a type-spec, check it. */
12779 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12780 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12781 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12787 /************* Resolve DATA statements *************/
12791 gfc_data_value *vnode;
12797 /* Advance the values structure to point to the next value in the data list. */
12800 next_data_value (void)
12802 while (mpz_cmp_ui (values.left, 0) == 0)
12805 if (values.vnode->next == NULL)
12808 values.vnode = values.vnode->next;
12809 mpz_set (values.left, values.vnode->repeat);
12817 check_data_variable (gfc_data_variable *var, locus *where)
12823 ar_type mark = AR_UNKNOWN;
12825 mpz_t section_index[GFC_MAX_DIMENSIONS];
12831 if (gfc_resolve_expr (var->expr) == FAILURE)
12835 mpz_init_set_si (offset, 0);
12838 if (e->expr_type != EXPR_VARIABLE)
12839 gfc_internal_error ("check_data_variable(): Bad expression");
12841 sym = e->symtree->n.sym;
12843 if (sym->ns->is_block_data && !sym->attr.in_common)
12845 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12846 sym->name, &sym->declared_at);
12849 if (e->ref == NULL && sym->as)
12851 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12852 " declaration", sym->name, where);
12856 has_pointer = sym->attr.pointer;
12858 if (gfc_is_coindexed (e))
12860 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name,
12865 for (ref = e->ref; ref; ref = ref->next)
12867 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12871 && ref->type == REF_ARRAY
12872 && ref->u.ar.type != AR_FULL)
12874 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12875 "be a full array", sym->name, where);
12880 if (e->rank == 0 || has_pointer)
12882 mpz_init_set_ui (size, 1);
12889 /* Find the array section reference. */
12890 for (ref = e->ref; ref; ref = ref->next)
12892 if (ref->type != REF_ARRAY)
12894 if (ref->u.ar.type == AR_ELEMENT)
12900 /* Set marks according to the reference pattern. */
12901 switch (ref->u.ar.type)
12909 /* Get the start position of array section. */
12910 gfc_get_section_index (ar, section_index, &offset);
12915 gcc_unreachable ();
12918 if (gfc_array_size (e, &size) == FAILURE)
12920 gfc_error ("Nonconstant array section at %L in DATA statement",
12922 mpz_clear (offset);
12929 while (mpz_cmp_ui (size, 0) > 0)
12931 if (next_data_value () == FAILURE)
12933 gfc_error ("DATA statement at %L has more variables than values",
12939 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12943 /* If we have more than one element left in the repeat count,
12944 and we have more than one element left in the target variable,
12945 then create a range assignment. */
12946 /* FIXME: Only done for full arrays for now, since array sections
12948 if (mark == AR_FULL && ref && ref->next == NULL
12949 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12953 if (mpz_cmp (size, values.left) >= 0)
12955 mpz_init_set (range, values.left);
12956 mpz_sub (size, size, values.left);
12957 mpz_set_ui (values.left, 0);
12961 mpz_init_set (range, size);
12962 mpz_sub (values.left, values.left, size);
12963 mpz_set_ui (size, 0);
12966 t = gfc_assign_data_value (var->expr, values.vnode->expr,
12969 mpz_add (offset, offset, range);
12976 /* Assign initial value to symbol. */
12979 mpz_sub_ui (values.left, values.left, 1);
12980 mpz_sub_ui (size, size, 1);
12982 t = gfc_assign_data_value (var->expr, values.vnode->expr,
12987 if (mark == AR_FULL)
12988 mpz_add_ui (offset, offset, 1);
12990 /* Modify the array section indexes and recalculate the offset
12991 for next element. */
12992 else if (mark == AR_SECTION)
12993 gfc_advance_section (section_index, ar, &offset);
12997 if (mark == AR_SECTION)
12999 for (i = 0; i < ar->dimen; i++)
13000 mpz_clear (section_index[i]);
13004 mpz_clear (offset);
13010 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
13012 /* Iterate over a list of elements in a DATA statement. */
13015 traverse_data_list (gfc_data_variable *var, locus *where)
13018 iterator_stack frame;
13019 gfc_expr *e, *start, *end, *step;
13020 gfc_try retval = SUCCESS;
13022 mpz_init (frame.value);
13025 start = gfc_copy_expr (var->iter.start);
13026 end = gfc_copy_expr (var->iter.end);
13027 step = gfc_copy_expr (var->iter.step);
13029 if (gfc_simplify_expr (start, 1) == FAILURE
13030 || start->expr_type != EXPR_CONSTANT)
13032 gfc_error ("start of implied-do loop at %L could not be "
13033 "simplified to a constant value", &start->where);
13037 if (gfc_simplify_expr (end, 1) == FAILURE
13038 || end->expr_type != EXPR_CONSTANT)
13040 gfc_error ("end of implied-do loop at %L could not be "
13041 "simplified to a constant value", &start->where);
13045 if (gfc_simplify_expr (step, 1) == FAILURE
13046 || step->expr_type != EXPR_CONSTANT)
13048 gfc_error ("step of implied-do loop at %L could not be "
13049 "simplified to a constant value", &start->where);
13054 mpz_set (trip, end->value.integer);
13055 mpz_sub (trip, trip, start->value.integer);
13056 mpz_add (trip, trip, step->value.integer);
13058 mpz_div (trip, trip, step->value.integer);
13060 mpz_set (frame.value, start->value.integer);
13062 frame.prev = iter_stack;
13063 frame.variable = var->iter.var->symtree;
13064 iter_stack = &frame;
13066 while (mpz_cmp_ui (trip, 0) > 0)
13068 if (traverse_data_var (var->list, where) == FAILURE)
13074 e = gfc_copy_expr (var->expr);
13075 if (gfc_simplify_expr (e, 1) == FAILURE)
13082 mpz_add (frame.value, frame.value, step->value.integer);
13084 mpz_sub_ui (trip, trip, 1);
13088 mpz_clear (frame.value);
13091 gfc_free_expr (start);
13092 gfc_free_expr (end);
13093 gfc_free_expr (step);
13095 iter_stack = frame.prev;
13100 /* Type resolve variables in the variable list of a DATA statement. */
13103 traverse_data_var (gfc_data_variable *var, locus *where)
13107 for (; var; var = var->next)
13109 if (var->expr == NULL)
13110 t = traverse_data_list (var, where);
13112 t = check_data_variable (var, where);
13122 /* Resolve the expressions and iterators associated with a data statement.
13123 This is separate from the assignment checking because data lists should
13124 only be resolved once. */
13127 resolve_data_variables (gfc_data_variable *d)
13129 for (; d; d = d->next)
13131 if (d->list == NULL)
13133 if (gfc_resolve_expr (d->expr) == FAILURE)
13138 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
13141 if (resolve_data_variables (d->list) == FAILURE)
13150 /* Resolve a single DATA statement. We implement this by storing a pointer to
13151 the value list into static variables, and then recursively traversing the
13152 variables list, expanding iterators and such. */
13155 resolve_data (gfc_data *d)
13158 if (resolve_data_variables (d->var) == FAILURE)
13161 values.vnode = d->value;
13162 if (d->value == NULL)
13163 mpz_set_ui (values.left, 0);
13165 mpz_set (values.left, d->value->repeat);
13167 if (traverse_data_var (d->var, &d->where) == FAILURE)
13170 /* At this point, we better not have any values left. */
13172 if (next_data_value () == SUCCESS)
13173 gfc_error ("DATA statement at %L has more values than variables",
13178 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13179 accessed by host or use association, is a dummy argument to a pure function,
13180 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13181 is storage associated with any such variable, shall not be used in the
13182 following contexts: (clients of this function). */
13184 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13185 procedure. Returns zero if assignment is OK, nonzero if there is a
13188 gfc_impure_variable (gfc_symbol *sym)
13193 if (sym->attr.use_assoc || sym->attr.in_common)
13196 /* Check if the symbol's ns is inside the pure procedure. */
13197 for (ns = gfc_current_ns; ns; ns = ns->parent)
13201 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
13205 proc = sym->ns->proc_name;
13206 if (sym->attr.dummy && gfc_pure (proc)
13207 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
13209 proc->attr.function))
13212 /* TODO: Sort out what can be storage associated, if anything, and include
13213 it here. In principle equivalences should be scanned but it does not
13214 seem to be possible to storage associate an impure variable this way. */
13219 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13220 current namespace is inside a pure procedure. */
13223 gfc_pure (gfc_symbol *sym)
13225 symbol_attribute attr;
13230 /* Check if the current namespace or one of its parents
13231 belongs to a pure procedure. */
13232 for (ns = gfc_current_ns; ns; ns = ns->parent)
13234 sym = ns->proc_name;
13238 if (attr.flavor == FL_PROCEDURE && attr.pure)
13246 return attr.flavor == FL_PROCEDURE && attr.pure;
13250 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13251 checks if the current namespace is implicitly pure. Note that this
13252 function returns false for a PURE procedure. */
13255 gfc_implicit_pure (gfc_symbol *sym)
13261 /* Check if the current procedure is implicit_pure. Walk up
13262 the procedure list until we find a procedure. */
13263 for (ns = gfc_current_ns; ns; ns = ns->parent)
13265 sym = ns->proc_name;
13269 if (sym->attr.flavor == FL_PROCEDURE)
13274 return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
13275 && !sym->attr.pure;
13279 /* Test whether the current procedure is elemental or not. */
13282 gfc_elemental (gfc_symbol *sym)
13284 symbol_attribute attr;
13287 sym = gfc_current_ns->proc_name;
13292 return attr.flavor == FL_PROCEDURE && attr.elemental;
13296 /* Warn about unused labels. */
13299 warn_unused_fortran_label (gfc_st_label *label)
13304 warn_unused_fortran_label (label->left);
13306 if (label->defined == ST_LABEL_UNKNOWN)
13309 switch (label->referenced)
13311 case ST_LABEL_UNKNOWN:
13312 gfc_warning ("Label %d at %L defined but not used", label->value,
13316 case ST_LABEL_BAD_TARGET:
13317 gfc_warning ("Label %d at %L defined but cannot be used",
13318 label->value, &label->where);
13325 warn_unused_fortran_label (label->right);
13329 /* Returns the sequence type of a symbol or sequence. */
13332 sequence_type (gfc_typespec ts)
13341 if (ts.u.derived->components == NULL)
13342 return SEQ_NONDEFAULT;
13344 result = sequence_type (ts.u.derived->components->ts);
13345 for (c = ts.u.derived->components->next; c; c = c->next)
13346 if (sequence_type (c->ts) != result)
13352 if (ts.kind != gfc_default_character_kind)
13353 return SEQ_NONDEFAULT;
13355 return SEQ_CHARACTER;
13358 if (ts.kind != gfc_default_integer_kind)
13359 return SEQ_NONDEFAULT;
13361 return SEQ_NUMERIC;
13364 if (!(ts.kind == gfc_default_real_kind
13365 || ts.kind == gfc_default_double_kind))
13366 return SEQ_NONDEFAULT;
13368 return SEQ_NUMERIC;
13371 if (ts.kind != gfc_default_complex_kind)
13372 return SEQ_NONDEFAULT;
13374 return SEQ_NUMERIC;
13377 if (ts.kind != gfc_default_logical_kind)
13378 return SEQ_NONDEFAULT;
13380 return SEQ_NUMERIC;
13383 return SEQ_NONDEFAULT;
13388 /* Resolve derived type EQUIVALENCE object. */
13391 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
13393 gfc_component *c = derived->components;
13398 /* Shall not be an object of nonsequence derived type. */
13399 if (!derived->attr.sequence)
13401 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13402 "attribute to be an EQUIVALENCE object", sym->name,
13407 /* Shall not have allocatable components. */
13408 if (derived->attr.alloc_comp)
13410 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13411 "components to be an EQUIVALENCE object",sym->name,
13416 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
13418 gfc_error ("Derived type variable '%s' at %L with default "
13419 "initialization cannot be in EQUIVALENCE with a variable "
13420 "in COMMON", sym->name, &e->where);
13424 for (; c ; c = c->next)
13426 if (c->ts.type == BT_DERIVED
13427 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
13430 /* Shall not be an object of sequence derived type containing a pointer
13431 in the structure. */
13432 if (c->attr.pointer)
13434 gfc_error ("Derived type variable '%s' at %L with pointer "
13435 "component(s) cannot be an EQUIVALENCE object",
13436 sym->name, &e->where);
13444 /* Resolve equivalence object.
13445 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13446 an allocatable array, an object of nonsequence derived type, an object of
13447 sequence derived type containing a pointer at any level of component
13448 selection, an automatic object, a function name, an entry name, a result
13449 name, a named constant, a structure component, or a subobject of any of
13450 the preceding objects. A substring shall not have length zero. A
13451 derived type shall not have components with default initialization nor
13452 shall two objects of an equivalence group be initialized.
13453 Either all or none of the objects shall have an protected attribute.
13454 The simple constraints are done in symbol.c(check_conflict) and the rest
13455 are implemented here. */
13458 resolve_equivalence (gfc_equiv *eq)
13461 gfc_symbol *first_sym;
13464 locus *last_where = NULL;
13465 seq_type eq_type, last_eq_type;
13466 gfc_typespec *last_ts;
13467 int object, cnt_protected;
13470 last_ts = &eq->expr->symtree->n.sym->ts;
13472 first_sym = eq->expr->symtree->n.sym;
13476 for (object = 1; eq; eq = eq->eq, object++)
13480 e->ts = e->symtree->n.sym->ts;
13481 /* match_varspec might not know yet if it is seeing
13482 array reference or substring reference, as it doesn't
13484 if (e->ref && e->ref->type == REF_ARRAY)
13486 gfc_ref *ref = e->ref;
13487 sym = e->symtree->n.sym;
13489 if (sym->attr.dimension)
13491 ref->u.ar.as = sym->as;
13495 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13496 if (e->ts.type == BT_CHARACTER
13498 && ref->type == REF_ARRAY
13499 && ref->u.ar.dimen == 1
13500 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
13501 && ref->u.ar.stride[0] == NULL)
13503 gfc_expr *start = ref->u.ar.start[0];
13504 gfc_expr *end = ref->u.ar.end[0];
13507 /* Optimize away the (:) reference. */
13508 if (start == NULL && end == NULL)
13511 e->ref = ref->next;
13513 e->ref->next = ref->next;
13518 ref->type = REF_SUBSTRING;
13520 start = gfc_get_int_expr (gfc_default_integer_kind,
13522 ref->u.ss.start = start;
13523 if (end == NULL && e->ts.u.cl)
13524 end = gfc_copy_expr (e->ts.u.cl->length);
13525 ref->u.ss.end = end;
13526 ref->u.ss.length = e->ts.u.cl;
13533 /* Any further ref is an error. */
13536 gcc_assert (ref->type == REF_ARRAY);
13537 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13543 if (gfc_resolve_expr (e) == FAILURE)
13546 sym = e->symtree->n.sym;
13548 if (sym->attr.is_protected)
13550 if (cnt_protected > 0 && cnt_protected != object)
13552 gfc_error ("Either all or none of the objects in the "
13553 "EQUIVALENCE set at %L shall have the "
13554 "PROTECTED attribute",
13559 /* Shall not equivalence common block variables in a PURE procedure. */
13560 if (sym->ns->proc_name
13561 && sym->ns->proc_name->attr.pure
13562 && sym->attr.in_common)
13564 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13565 "object in the pure procedure '%s'",
13566 sym->name, &e->where, sym->ns->proc_name->name);
13570 /* Shall not be a named constant. */
13571 if (e->expr_type == EXPR_CONSTANT)
13573 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13574 "object", sym->name, &e->where);
13578 if (e->ts.type == BT_DERIVED
13579 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
13582 /* Check that the types correspond correctly:
13584 A numeric sequence structure may be equivalenced to another sequence
13585 structure, an object of default integer type, default real type, double
13586 precision real type, default logical type such that components of the
13587 structure ultimately only become associated to objects of the same
13588 kind. A character sequence structure may be equivalenced to an object
13589 of default character kind or another character sequence structure.
13590 Other objects may be equivalenced only to objects of the same type and
13591 kind parameters. */
13593 /* Identical types are unconditionally OK. */
13594 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
13595 goto identical_types;
13597 last_eq_type = sequence_type (*last_ts);
13598 eq_type = sequence_type (sym->ts);
13600 /* Since the pair of objects is not of the same type, mixed or
13601 non-default sequences can be rejected. */
13603 msg = "Sequence %s with mixed components in EQUIVALENCE "
13604 "statement at %L with different type objects";
13606 && last_eq_type == SEQ_MIXED
13607 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
13609 || (eq_type == SEQ_MIXED
13610 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13611 &e->where) == FAILURE))
13614 msg = "Non-default type object or sequence %s in EQUIVALENCE "
13615 "statement at %L with objects of different type";
13617 && last_eq_type == SEQ_NONDEFAULT
13618 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
13619 last_where) == FAILURE)
13620 || (eq_type == SEQ_NONDEFAULT
13621 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13622 &e->where) == FAILURE))
13625 msg ="Non-CHARACTER object '%s' in default CHARACTER "
13626 "EQUIVALENCE statement at %L";
13627 if (last_eq_type == SEQ_CHARACTER
13628 && eq_type != SEQ_CHARACTER
13629 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13630 &e->where) == FAILURE)
13633 msg ="Non-NUMERIC object '%s' in default NUMERIC "
13634 "EQUIVALENCE statement at %L";
13635 if (last_eq_type == SEQ_NUMERIC
13636 && eq_type != SEQ_NUMERIC
13637 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13638 &e->where) == FAILURE)
13643 last_where = &e->where;
13648 /* Shall not be an automatic array. */
13649 if (e->ref->type == REF_ARRAY
13650 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
13652 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13653 "an EQUIVALENCE object", sym->name, &e->where);
13660 /* Shall not be a structure component. */
13661 if (r->type == REF_COMPONENT)
13663 gfc_error ("Structure component '%s' at %L cannot be an "
13664 "EQUIVALENCE object",
13665 r->u.c.component->name, &e->where);
13669 /* A substring shall not have length zero. */
13670 if (r->type == REF_SUBSTRING)
13672 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13674 gfc_error ("Substring at %L has length zero",
13675 &r->u.ss.start->where);
13685 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13688 resolve_fntype (gfc_namespace *ns)
13690 gfc_entry_list *el;
13693 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13696 /* If there are any entries, ns->proc_name is the entry master
13697 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13699 sym = ns->entries->sym;
13701 sym = ns->proc_name;
13702 if (sym->result == sym
13703 && sym->ts.type == BT_UNKNOWN
13704 && gfc_set_default_type (sym, 0, NULL) == FAILURE
13705 && !sym->attr.untyped)
13707 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13708 sym->name, &sym->declared_at);
13709 sym->attr.untyped = 1;
13712 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13713 && !sym->attr.contained
13714 && !gfc_check_symbol_access (sym->ts.u.derived)
13715 && gfc_check_symbol_access (sym))
13717 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13718 "%L of PRIVATE type '%s'", sym->name,
13719 &sym->declared_at, sym->ts.u.derived->name);
13723 for (el = ns->entries->next; el; el = el->next)
13725 if (el->sym->result == el->sym
13726 && el->sym->ts.type == BT_UNKNOWN
13727 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13728 && !el->sym->attr.untyped)
13730 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13731 el->sym->name, &el->sym->declared_at);
13732 el->sym->attr.untyped = 1;
13738 /* 12.3.2.1.1 Defined operators. */
13741 check_uop_procedure (gfc_symbol *sym, locus where)
13743 gfc_formal_arglist *formal;
13745 if (!sym->attr.function)
13747 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13748 sym->name, &where);
13752 if (sym->ts.type == BT_CHARACTER
13753 && !(sym->ts.u.cl && sym->ts.u.cl->length)
13754 && !(sym->result && sym->result->ts.u.cl
13755 && sym->result->ts.u.cl->length))
13757 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13758 "character length", sym->name, &where);
13762 formal = sym->formal;
13763 if (!formal || !formal->sym)
13765 gfc_error ("User operator procedure '%s' at %L must have at least "
13766 "one argument", sym->name, &where);
13770 if (formal->sym->attr.intent != INTENT_IN)
13772 gfc_error ("First argument of operator interface at %L must be "
13773 "INTENT(IN)", &where);
13777 if (formal->sym->attr.optional)
13779 gfc_error ("First argument of operator interface at %L cannot be "
13780 "optional", &where);
13784 formal = formal->next;
13785 if (!formal || !formal->sym)
13788 if (formal->sym->attr.intent != INTENT_IN)
13790 gfc_error ("Second argument of operator interface at %L must be "
13791 "INTENT(IN)", &where);
13795 if (formal->sym->attr.optional)
13797 gfc_error ("Second argument of operator interface at %L cannot be "
13798 "optional", &where);
13804 gfc_error ("Operator interface at %L must have, at most, two "
13805 "arguments", &where);
13813 gfc_resolve_uops (gfc_symtree *symtree)
13815 gfc_interface *itr;
13817 if (symtree == NULL)
13820 gfc_resolve_uops (symtree->left);
13821 gfc_resolve_uops (symtree->right);
13823 for (itr = symtree->n.uop->op; itr; itr = itr->next)
13824 check_uop_procedure (itr->sym, itr->sym->declared_at);
13828 /* Examine all of the expressions associated with a program unit,
13829 assign types to all intermediate expressions, make sure that all
13830 assignments are to compatible types and figure out which names
13831 refer to which functions or subroutines. It doesn't check code
13832 block, which is handled by resolve_code. */
13835 resolve_types (gfc_namespace *ns)
13841 gfc_namespace* old_ns = gfc_current_ns;
13843 /* Check that all IMPLICIT types are ok. */
13844 if (!ns->seen_implicit_none)
13847 for (letter = 0; letter != GFC_LETTERS; ++letter)
13848 if (ns->set_flag[letter]
13849 && resolve_typespec_used (&ns->default_type[letter],
13850 &ns->implicit_loc[letter],
13855 gfc_current_ns = ns;
13857 resolve_entries (ns);
13859 resolve_common_vars (ns->blank_common.head, false);
13860 resolve_common_blocks (ns->common_root);
13862 resolve_contained_functions (ns);
13864 if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
13865 && ns->proc_name->attr.if_source == IFSRC_IFBODY)
13866 resolve_formal_arglist (ns->proc_name);
13868 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13870 for (cl = ns->cl_list; cl; cl = cl->next)
13871 resolve_charlen (cl);
13873 gfc_traverse_ns (ns, resolve_symbol);
13875 resolve_fntype (ns);
13877 for (n = ns->contained; n; n = n->sibling)
13879 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13880 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13881 "also be PURE", n->proc_name->name,
13882 &n->proc_name->declared_at);
13888 do_concurrent_flag = 0;
13889 gfc_check_interfaces (ns);
13891 gfc_traverse_ns (ns, resolve_values);
13897 for (d = ns->data; d; d = d->next)
13901 gfc_traverse_ns (ns, gfc_formalize_init_value);
13903 gfc_traverse_ns (ns, gfc_verify_binding_labels);
13905 if (ns->common_root != NULL)
13906 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13908 for (eq = ns->equiv; eq; eq = eq->next)
13909 resolve_equivalence (eq);
13911 /* Warn about unused labels. */
13912 if (warn_unused_label)
13913 warn_unused_fortran_label (ns->st_labels);
13915 gfc_resolve_uops (ns->uop_root);
13917 gfc_current_ns = old_ns;
13921 /* Call resolve_code recursively. */
13924 resolve_codes (gfc_namespace *ns)
13927 bitmap_obstack old_obstack;
13929 if (ns->resolved == 1)
13932 for (n = ns->contained; n; n = n->sibling)
13935 gfc_current_ns = ns;
13937 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13938 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13941 /* Set to an out of range value. */
13942 current_entry_id = -1;
13944 old_obstack = labels_obstack;
13945 bitmap_obstack_initialize (&labels_obstack);
13947 resolve_code (ns->code, ns);
13949 bitmap_obstack_release (&labels_obstack);
13950 labels_obstack = old_obstack;
13954 /* This function is called after a complete program unit has been compiled.
13955 Its purpose is to examine all of the expressions associated with a program
13956 unit, assign types to all intermediate expressions, make sure that all
13957 assignments are to compatible types and figure out which names refer to
13958 which functions or subroutines. */
13961 gfc_resolve (gfc_namespace *ns)
13963 gfc_namespace *old_ns;
13964 code_stack *old_cs_base;
13970 old_ns = gfc_current_ns;
13971 old_cs_base = cs_base;
13973 resolve_types (ns);
13974 resolve_codes (ns);
13976 gfc_current_ns = old_ns;
13977 cs_base = old_cs_base;
13980 gfc_run_passes (ns);