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
405 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
406 && CLASS_DATA (sym)->attr.class_pointer))
408 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
409 "have the POINTER attribute", sym->name,
414 if (sym->attr.flavor == FL_PROCEDURE)
416 gfc_error ("Dummy procedure '%s' not allowed in elemental "
417 "procedure '%s' at %L", sym->name, proc->name,
422 if (sym->attr.intent == INTENT_UNKNOWN)
424 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
425 "have its INTENT specified", sym->name, proc->name,
431 /* Each dummy shall be specified to be scalar. */
432 if (proc->attr.proc == PROC_ST_FUNCTION)
436 gfc_error ("Argument '%s' of statement function at %L must "
437 "be scalar", sym->name, &sym->declared_at);
441 if (sym->ts.type == BT_CHARACTER)
443 gfc_charlen *cl = sym->ts.u.cl;
444 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
446 gfc_error ("Character-valued argument '%s' of statement "
447 "function at %L must have constant length",
448 sym->name, &sym->declared_at);
458 /* Work function called when searching for symbols that have argument lists
459 associated with them. */
462 find_arglists (gfc_symbol *sym)
464 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
465 || sym->attr.flavor == FL_DERIVED)
468 resolve_formal_arglist (sym);
472 /* Given a namespace, resolve all formal argument lists within the namespace.
476 resolve_formal_arglists (gfc_namespace *ns)
481 gfc_traverse_ns (ns, find_arglists);
486 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
490 /* If this namespace is not a function or an entry master function,
492 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
493 || sym->attr.entry_master)
496 /* Try to find out of what the return type is. */
497 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
499 t = gfc_set_default_type (sym->result, 0, ns);
501 if (t == FAILURE && !sym->result->attr.untyped)
503 if (sym->result == sym)
504 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
505 sym->name, &sym->declared_at);
506 else if (!sym->result->attr.proc_pointer)
507 gfc_error ("Result '%s' of contained function '%s' at %L has "
508 "no IMPLICIT type", sym->result->name, sym->name,
509 &sym->result->declared_at);
510 sym->result->attr.untyped = 1;
514 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
515 type, lists the only ways a character length value of * can be used:
516 dummy arguments of procedures, named constants, and function results
517 in external functions. Internal function results and results of module
518 procedures are not on this list, ergo, not permitted. */
520 if (sym->result->ts.type == BT_CHARACTER)
522 gfc_charlen *cl = sym->result->ts.u.cl;
523 if ((!cl || !cl->length) && !sym->result->ts.deferred)
525 /* See if this is a module-procedure and adapt error message
528 gcc_assert (ns->parent && ns->parent->proc_name);
529 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
531 gfc_error ("Character-valued %s '%s' at %L must not be"
533 module_proc ? _("module procedure")
534 : _("internal function"),
535 sym->name, &sym->declared_at);
541 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
542 introduce duplicates. */
545 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
547 gfc_formal_arglist *f, *new_arglist;
550 for (; new_args != NULL; new_args = new_args->next)
552 new_sym = new_args->sym;
553 /* See if this arg is already in the formal argument list. */
554 for (f = proc->formal; f; f = f->next)
556 if (new_sym == f->sym)
563 /* Add a new argument. Argument order is not important. */
564 new_arglist = gfc_get_formal_arglist ();
565 new_arglist->sym = new_sym;
566 new_arglist->next = proc->formal;
567 proc->formal = new_arglist;
572 /* Flag the arguments that are not present in all entries. */
575 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
577 gfc_formal_arglist *f, *head;
580 for (f = proc->formal; f; f = f->next)
585 for (new_args = head; new_args; new_args = new_args->next)
587 if (new_args->sym == f->sym)
594 f->sym->attr.not_always_present = 1;
599 /* Resolve alternate entry points. If a symbol has multiple entry points we
600 create a new master symbol for the main routine, and turn the existing
601 symbol into an entry point. */
604 resolve_entries (gfc_namespace *ns)
606 gfc_namespace *old_ns;
610 char name[GFC_MAX_SYMBOL_LEN + 1];
611 static int master_count = 0;
613 if (ns->proc_name == NULL)
616 /* No need to do anything if this procedure doesn't have alternate entry
621 /* We may already have resolved alternate entry points. */
622 if (ns->proc_name->attr.entry_master)
625 /* If this isn't a procedure something has gone horribly wrong. */
626 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
628 /* Remember the current namespace. */
629 old_ns = gfc_current_ns;
633 /* Add the main entry point to the list of entry points. */
634 el = gfc_get_entry_list ();
635 el->sym = ns->proc_name;
637 el->next = ns->entries;
639 ns->proc_name->attr.entry = 1;
641 /* If it is a module function, it needs to be in the right namespace
642 so that gfc_get_fake_result_decl can gather up the results. The
643 need for this arose in get_proc_name, where these beasts were
644 left in their own namespace, to keep prior references linked to
645 the entry declaration.*/
646 if (ns->proc_name->attr.function
647 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
650 /* Do the same for entries where the master is not a module
651 procedure. These are retained in the module namespace because
652 of the module procedure declaration. */
653 for (el = el->next; el; el = el->next)
654 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
655 && el->sym->attr.mod_proc)
659 /* Add an entry statement for it. */
666 /* Create a new symbol for the master function. */
667 /* Give the internal function a unique name (within this file).
668 Also include the function name so the user has some hope of figuring
669 out what is going on. */
670 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
671 master_count++, ns->proc_name->name);
672 gfc_get_ha_symbol (name, &proc);
673 gcc_assert (proc != NULL);
675 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
676 if (ns->proc_name->attr.subroutine)
677 gfc_add_subroutine (&proc->attr, proc->name, NULL);
681 gfc_typespec *ts, *fts;
682 gfc_array_spec *as, *fas;
683 gfc_add_function (&proc->attr, proc->name, NULL);
685 fas = ns->entries->sym->as;
686 fas = fas ? fas : ns->entries->sym->result->as;
687 fts = &ns->entries->sym->result->ts;
688 if (fts->type == BT_UNKNOWN)
689 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
690 for (el = ns->entries->next; el; el = el->next)
692 ts = &el->sym->result->ts;
694 as = as ? as : el->sym->result->as;
695 if (ts->type == BT_UNKNOWN)
696 ts = gfc_get_default_type (el->sym->result->name, NULL);
698 if (! gfc_compare_types (ts, fts)
699 || (el->sym->result->attr.dimension
700 != ns->entries->sym->result->attr.dimension)
701 || (el->sym->result->attr.pointer
702 != ns->entries->sym->result->attr.pointer))
704 else if (as && fas && ns->entries->sym->result != el->sym->result
705 && gfc_compare_array_spec (as, fas) == 0)
706 gfc_error ("Function %s at %L has entries with mismatched "
707 "array specifications", ns->entries->sym->name,
708 &ns->entries->sym->declared_at);
709 /* The characteristics need to match and thus both need to have
710 the same string length, i.e. both len=*, or both len=4.
711 Having both len=<variable> is also possible, but difficult to
712 check at compile time. */
713 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
714 && (((ts->u.cl->length && !fts->u.cl->length)
715 ||(!ts->u.cl->length && fts->u.cl->length))
717 && ts->u.cl->length->expr_type
718 != fts->u.cl->length->expr_type)
720 && ts->u.cl->length->expr_type == EXPR_CONSTANT
721 && mpz_cmp (ts->u.cl->length->value.integer,
722 fts->u.cl->length->value.integer) != 0)))
723 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
724 "entries returning variables of different "
725 "string lengths", ns->entries->sym->name,
726 &ns->entries->sym->declared_at);
731 sym = ns->entries->sym->result;
732 /* All result types the same. */
734 if (sym->attr.dimension)
735 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
736 if (sym->attr.pointer)
737 gfc_add_pointer (&proc->attr, NULL);
741 /* Otherwise the result will be passed through a union by
743 proc->attr.mixed_entry_master = 1;
744 for (el = ns->entries; el; el = el->next)
746 sym = el->sym->result;
747 if (sym->attr.dimension)
749 if (el == ns->entries)
750 gfc_error ("FUNCTION result %s can't be an array in "
751 "FUNCTION %s at %L", sym->name,
752 ns->entries->sym->name, &sym->declared_at);
754 gfc_error ("ENTRY result %s can't be an array in "
755 "FUNCTION %s at %L", sym->name,
756 ns->entries->sym->name, &sym->declared_at);
758 else if (sym->attr.pointer)
760 if (el == ns->entries)
761 gfc_error ("FUNCTION result %s can't be a POINTER in "
762 "FUNCTION %s at %L", sym->name,
763 ns->entries->sym->name, &sym->declared_at);
765 gfc_error ("ENTRY result %s can't be a POINTER in "
766 "FUNCTION %s at %L", sym->name,
767 ns->entries->sym->name, &sym->declared_at);
772 if (ts->type == BT_UNKNOWN)
773 ts = gfc_get_default_type (sym->name, NULL);
777 if (ts->kind == gfc_default_integer_kind)
781 if (ts->kind == gfc_default_real_kind
782 || ts->kind == gfc_default_double_kind)
786 if (ts->kind == gfc_default_complex_kind)
790 if (ts->kind == gfc_default_logical_kind)
794 /* We will issue error elsewhere. */
802 if (el == ns->entries)
803 gfc_error ("FUNCTION result %s can't be of type %s "
804 "in FUNCTION %s at %L", sym->name,
805 gfc_typename (ts), ns->entries->sym->name,
808 gfc_error ("ENTRY result %s can't be of type %s "
809 "in FUNCTION %s at %L", sym->name,
810 gfc_typename (ts), ns->entries->sym->name,
817 proc->attr.access = ACCESS_PRIVATE;
818 proc->attr.entry_master = 1;
820 /* Merge all the entry point arguments. */
821 for (el = ns->entries; el; el = el->next)
822 merge_argument_lists (proc, el->sym->formal);
824 /* Check the master formal arguments for any that are not
825 present in all entry points. */
826 for (el = ns->entries; el; el = el->next)
827 check_argument_lists (proc, el->sym->formal);
829 /* Use the master function for the function body. */
830 ns->proc_name = proc;
832 /* Finalize the new symbols. */
833 gfc_commit_symbols ();
835 /* Restore the original namespace. */
836 gfc_current_ns = old_ns;
840 /* Resolve common variables. */
842 resolve_common_vars (gfc_symbol *sym, bool named_common)
844 gfc_symbol *csym = sym;
846 for (; csym; csym = csym->common_next)
848 if (csym->value || csym->attr.data)
850 if (!csym->ns->is_block_data)
851 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
852 "but only in BLOCK DATA initialization is "
853 "allowed", csym->name, &csym->declared_at);
854 else if (!named_common)
855 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
856 "in a blank COMMON but initialization is only "
857 "allowed in named common blocks", csym->name,
861 if (csym->ts.type != BT_DERIVED)
864 if (!(csym->ts.u.derived->attr.sequence
865 || csym->ts.u.derived->attr.is_bind_c))
866 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
867 "has neither the SEQUENCE nor the BIND(C) "
868 "attribute", csym->name, &csym->declared_at);
869 if (csym->ts.u.derived->attr.alloc_comp)
870 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
871 "has an ultimate component that is "
872 "allocatable", csym->name, &csym->declared_at);
873 if (gfc_has_default_initializer (csym->ts.u.derived))
874 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
875 "may not have default initializer", csym->name,
878 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
879 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
883 /* Resolve common blocks. */
885 resolve_common_blocks (gfc_symtree *common_root)
889 if (common_root == NULL)
892 if (common_root->left)
893 resolve_common_blocks (common_root->left);
894 if (common_root->right)
895 resolve_common_blocks (common_root->right);
897 resolve_common_vars (common_root->n.common->head, true);
899 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
903 if (sym->attr.flavor == FL_PARAMETER)
904 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
905 sym->name, &common_root->n.common->where, &sym->declared_at);
907 if (sym->attr.external)
908 gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
909 sym->name, &common_root->n.common->where);
911 if (sym->attr.intrinsic)
912 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
913 sym->name, &common_root->n.common->where);
914 else if (sym->attr.result
915 || gfc_is_function_return_value (sym, gfc_current_ns))
916 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
917 "that is also a function result", sym->name,
918 &common_root->n.common->where);
919 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
920 && sym->attr.proc != PROC_ST_FUNCTION)
921 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
922 "that is also a global procedure", sym->name,
923 &common_root->n.common->where);
927 /* Resolve contained function types. Because contained functions can call one
928 another, they have to be worked out before any of the contained procedures
931 The good news is that if a function doesn't already have a type, the only
932 way it can get one is through an IMPLICIT type or a RESULT variable, because
933 by definition contained functions are contained namespace they're contained
934 in, not in a sibling or parent namespace. */
937 resolve_contained_functions (gfc_namespace *ns)
939 gfc_namespace *child;
942 resolve_formal_arglists (ns);
944 for (child = ns->contained; child; child = child->sibling)
946 /* Resolve alternate entry points first. */
947 resolve_entries (child);
949 /* Then check function return types. */
950 resolve_contained_fntype (child->proc_name, child);
951 for (el = child->entries; el; el = el->next)
952 resolve_contained_fntype (el->sym, child);
957 static gfc_try resolve_fl_derived0 (gfc_symbol *sym);
960 /* Resolve all of the elements of a structure constructor and make sure that
961 the types are correct. The 'init' flag indicates that the given
962 constructor is an initializer. */
965 resolve_structure_cons (gfc_expr *expr, int init)
967 gfc_constructor *cons;
974 if (expr->ts.type == BT_DERIVED)
975 resolve_fl_derived0 (expr->ts.u.derived);
977 cons = gfc_constructor_first (expr->value.constructor);
979 /* See if the user is trying to invoke a structure constructor for one of
980 the iso_c_binding derived types. */
981 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
982 && expr->ts.u.derived->ts.is_iso_c && cons
983 && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
985 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
986 expr->ts.u.derived->name, &(expr->where));
990 /* Return if structure constructor is c_null_(fun)prt. */
991 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
992 && expr->ts.u.derived->ts.is_iso_c && cons
993 && cons->expr && cons->expr->expr_type == EXPR_NULL)
996 /* A constructor may have references if it is the result of substituting a
997 parameter variable. In this case we just pull out the component we
1000 comp = expr->ref->u.c.sym->components;
1002 comp = expr->ts.u.derived->components;
1004 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1011 if (gfc_resolve_expr (cons->expr) == FAILURE)
1017 rank = comp->as ? comp->as->rank : 0;
1018 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
1019 && (comp->attr.allocatable || cons->expr->rank))
1021 gfc_error ("The rank of the element in the structure "
1022 "constructor at %L does not match that of the "
1023 "component (%d/%d)", &cons->expr->where,
1024 cons->expr->rank, rank);
1028 /* If we don't have the right type, try to convert it. */
1030 if (!comp->attr.proc_pointer &&
1031 !gfc_compare_types (&cons->expr->ts, &comp->ts))
1034 if (strcmp (comp->name, "_extends") == 0)
1036 /* Can afford to be brutal with the _extends initializer.
1037 The derived type can get lost because it is PRIVATE
1038 but it is not usage constrained by the standard. */
1039 cons->expr->ts = comp->ts;
1042 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1043 gfc_error ("The element in the structure constructor at %L, "
1044 "for pointer component '%s', is %s but should be %s",
1045 &cons->expr->where, comp->name,
1046 gfc_basic_typename (cons->expr->ts.type),
1047 gfc_basic_typename (comp->ts.type));
1049 t = gfc_convert_type (cons->expr, &comp->ts, 1);
1052 /* For strings, the length of the constructor should be the same as
1053 the one of the structure, ensure this if the lengths are known at
1054 compile time and when we are dealing with PARAMETER or structure
1056 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1057 && comp->ts.u.cl->length
1058 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1059 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1060 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1061 && cons->expr->rank != 0
1062 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1063 comp->ts.u.cl->length->value.integer) != 0)
1065 if (cons->expr->expr_type == EXPR_VARIABLE
1066 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1068 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1069 to make use of the gfc_resolve_character_array_constructor
1070 machinery. The expression is later simplified away to
1071 an array of string literals. */
1072 gfc_expr *para = cons->expr;
1073 cons->expr = gfc_get_expr ();
1074 cons->expr->ts = para->ts;
1075 cons->expr->where = para->where;
1076 cons->expr->expr_type = EXPR_ARRAY;
1077 cons->expr->rank = para->rank;
1078 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1079 gfc_constructor_append_expr (&cons->expr->value.constructor,
1080 para, &cons->expr->where);
1082 if (cons->expr->expr_type == EXPR_ARRAY)
1085 p = gfc_constructor_first (cons->expr->value.constructor);
1086 if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
1088 gfc_charlen *cl, *cl2;
1091 for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
1093 if (cl == cons->expr->ts.u.cl)
1101 cl2->next = cl->next;
1103 gfc_free_expr (cl->length);
1107 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1108 cons->expr->ts.u.cl->length_from_typespec = true;
1109 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1110 gfc_resolve_character_array_constructor (cons->expr);
1114 if (cons->expr->expr_type == EXPR_NULL
1115 && !(comp->attr.pointer || comp->attr.allocatable
1116 || comp->attr.proc_pointer
1117 || (comp->ts.type == BT_CLASS
1118 && (CLASS_DATA (comp)->attr.class_pointer
1119 || CLASS_DATA (comp)->attr.allocatable))))
1122 gfc_error ("The NULL in the structure constructor at %L is "
1123 "being applied to component '%s', which is neither "
1124 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1128 if (comp->attr.proc_pointer && comp->ts.interface)
1130 /* Check procedure pointer interface. */
1131 gfc_symbol *s2 = NULL;
1136 if (gfc_is_proc_ptr_comp (cons->expr, &c2))
1138 s2 = c2->ts.interface;
1141 else if (cons->expr->expr_type == EXPR_FUNCTION)
1143 s2 = cons->expr->symtree->n.sym->result;
1144 name = cons->expr->symtree->n.sym->result->name;
1146 else if (cons->expr->expr_type != EXPR_NULL)
1148 s2 = cons->expr->symtree->n.sym;
1149 name = cons->expr->symtree->n.sym->name;
1152 if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
1155 gfc_error ("Interface mismatch for procedure-pointer component "
1156 "'%s' in structure constructor at %L: %s",
1157 comp->name, &cons->expr->where, err);
1162 if (!comp->attr.pointer || comp->attr.proc_pointer
1163 || cons->expr->expr_type == EXPR_NULL)
1166 a = gfc_expr_attr (cons->expr);
1168 if (!a.pointer && !a.target)
1171 gfc_error ("The element in the structure constructor at %L, "
1172 "for pointer component '%s' should be a POINTER or "
1173 "a TARGET", &cons->expr->where, comp->name);
1178 /* F08:C461. Additional checks for pointer initialization. */
1182 gfc_error ("Pointer initialization target at %L "
1183 "must not be ALLOCATABLE ", &cons->expr->where);
1188 gfc_error ("Pointer initialization target at %L "
1189 "must have the SAVE attribute", &cons->expr->where);
1193 /* F2003, C1272 (3). */
1194 if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
1195 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1196 || gfc_is_coindexed (cons->expr)))
1199 gfc_error ("Invalid expression in the structure constructor for "
1200 "pointer component '%s' at %L in PURE procedure",
1201 comp->name, &cons->expr->where);
1204 if (gfc_implicit_pure (NULL)
1205 && cons->expr->expr_type == EXPR_VARIABLE
1206 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1207 || gfc_is_coindexed (cons->expr)))
1208 gfc_current_ns->proc_name->attr.implicit_pure = 0;
1216 /****************** Expression name resolution ******************/
1218 /* Returns 0 if a symbol was not declared with a type or
1219 attribute declaration statement, nonzero otherwise. */
1222 was_declared (gfc_symbol *sym)
1228 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1231 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1232 || a.optional || a.pointer || a.save || a.target || a.volatile_
1233 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1234 || a.asynchronous || a.codimension)
1241 /* Determine if a symbol is generic or not. */
1244 generic_sym (gfc_symbol *sym)
1248 if (sym->attr.generic ||
1249 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1252 if (was_declared (sym) || sym->ns->parent == NULL)
1255 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1262 return generic_sym (s);
1269 /* Determine if a symbol is specific or not. */
1272 specific_sym (gfc_symbol *sym)
1276 if (sym->attr.if_source == IFSRC_IFBODY
1277 || sym->attr.proc == PROC_MODULE
1278 || sym->attr.proc == PROC_INTERNAL
1279 || sym->attr.proc == PROC_ST_FUNCTION
1280 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1281 || sym->attr.external)
1284 if (was_declared (sym) || sym->ns->parent == NULL)
1287 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1289 return (s == NULL) ? 0 : specific_sym (s);
1293 /* Figure out if the procedure is specific, generic or unknown. */
1296 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1300 procedure_kind (gfc_symbol *sym)
1302 if (generic_sym (sym))
1303 return PTYPE_GENERIC;
1305 if (specific_sym (sym))
1306 return PTYPE_SPECIFIC;
1308 return PTYPE_UNKNOWN;
1311 /* Check references to assumed size arrays. The flag need_full_assumed_size
1312 is nonzero when matching actual arguments. */
1314 static int need_full_assumed_size = 0;
1317 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1319 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1322 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1323 What should it be? */
1324 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1325 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1326 && (e->ref->u.ar.type == AR_FULL))
1328 gfc_error ("The upper bound in the last dimension must "
1329 "appear in the reference to the assumed size "
1330 "array '%s' at %L", sym->name, &e->where);
1337 /* Look for bad assumed size array references in argument expressions
1338 of elemental and array valued intrinsic procedures. Since this is
1339 called from procedure resolution functions, it only recurses at
1343 resolve_assumed_size_actual (gfc_expr *e)
1348 switch (e->expr_type)
1351 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1356 if (resolve_assumed_size_actual (e->value.op.op1)
1357 || resolve_assumed_size_actual (e->value.op.op2))
1368 /* Check a generic procedure, passed as an actual argument, to see if
1369 there is a matching specific name. If none, it is an error, and if
1370 more than one, the reference is ambiguous. */
1372 count_specific_procs (gfc_expr *e)
1379 sym = e->symtree->n.sym;
1381 for (p = sym->generic; p; p = p->next)
1382 if (strcmp (sym->name, p->sym->name) == 0)
1384 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1390 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1394 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1395 "argument at %L", sym->name, &e->where);
1401 /* See if a call to sym could possibly be a not allowed RECURSION because of
1402 a missing RECURIVE declaration. This means that either sym is the current
1403 context itself, or sym is the parent of a contained procedure calling its
1404 non-RECURSIVE containing procedure.
1405 This also works if sym is an ENTRY. */
1408 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1410 gfc_symbol* proc_sym;
1411 gfc_symbol* context_proc;
1412 gfc_namespace* real_context;
1414 if (sym->attr.flavor == FL_PROGRAM
1415 || sym->attr.flavor == FL_DERIVED)
1418 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1420 /* If we've got an ENTRY, find real procedure. */
1421 if (sym->attr.entry && sym->ns->entries)
1422 proc_sym = sym->ns->entries->sym;
1426 /* If sym is RECURSIVE, all is well of course. */
1427 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1430 /* Find the context procedure's "real" symbol if it has entries.
1431 We look for a procedure symbol, so recurse on the parents if we don't
1432 find one (like in case of a BLOCK construct). */
1433 for (real_context = context; ; real_context = real_context->parent)
1435 /* We should find something, eventually! */
1436 gcc_assert (real_context);
1438 context_proc = (real_context->entries ? real_context->entries->sym
1439 : real_context->proc_name);
1441 /* In some special cases, there may not be a proc_name, like for this
1443 real(bad_kind()) function foo () ...
1444 when checking the call to bad_kind ().
1445 In these cases, we simply return here and assume that the
1450 if (context_proc->attr.flavor != FL_LABEL)
1454 /* A call from sym's body to itself is recursion, of course. */
1455 if (context_proc == proc_sym)
1458 /* The same is true if context is a contained procedure and sym the
1460 if (context_proc->attr.contained)
1462 gfc_symbol* parent_proc;
1464 gcc_assert (context->parent);
1465 parent_proc = (context->parent->entries ? context->parent->entries->sym
1466 : context->parent->proc_name);
1468 if (parent_proc == proc_sym)
1476 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1477 its typespec and formal argument list. */
1480 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1482 gfc_intrinsic_sym* isym = NULL;
1488 /* Already resolved. */
1489 if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
1492 /* We already know this one is an intrinsic, so we don't call
1493 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1494 gfc_find_subroutine directly to check whether it is a function or
1497 if (sym->intmod_sym_id)
1498 isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
1500 isym = gfc_find_function (sym->name);
1504 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1505 && !sym->attr.implicit_type)
1506 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1507 " ignored", sym->name, &sym->declared_at);
1509 if (!sym->attr.function &&
1510 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1515 else if ((isym = gfc_find_subroutine (sym->name)))
1517 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1519 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1520 " specifier", sym->name, &sym->declared_at);
1524 if (!sym->attr.subroutine &&
1525 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1530 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1535 gfc_copy_formal_args_intr (sym, isym);
1537 /* Check it is actually available in the standard settings. */
1538 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1541 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1542 " available in the current standard settings but %s. Use"
1543 " an appropriate -std=* option or enable -fall-intrinsics"
1544 " in order to use it.",
1545 sym->name, &sym->declared_at, symstd);
1553 /* Resolve a procedure expression, like passing it to a called procedure or as
1554 RHS for a procedure pointer assignment. */
1557 resolve_procedure_expression (gfc_expr* expr)
1561 if (expr->expr_type != EXPR_VARIABLE)
1563 gcc_assert (expr->symtree);
1565 sym = expr->symtree->n.sym;
1567 if (sym->attr.intrinsic)
1568 resolve_intrinsic (sym, &expr->where);
1570 if (sym->attr.flavor != FL_PROCEDURE
1571 || (sym->attr.function && sym->result == sym))
1574 /* A non-RECURSIVE procedure that is used as procedure expression within its
1575 own body is in danger of being called recursively. */
1576 if (is_illegal_recursion (sym, gfc_current_ns))
1577 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1578 " itself recursively. Declare it RECURSIVE or use"
1579 " -frecursive", sym->name, &expr->where);
1585 /* Resolve an actual argument list. Most of the time, this is just
1586 resolving the expressions in the list.
1587 The exception is that we sometimes have to decide whether arguments
1588 that look like procedure arguments are really simple variable
1592 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1593 bool no_formal_args)
1596 gfc_symtree *parent_st;
1598 int save_need_full_assumed_size;
1600 for (; arg; arg = arg->next)
1605 /* Check the label is a valid branching target. */
1608 if (arg->label->defined == ST_LABEL_UNKNOWN)
1610 gfc_error ("Label %d referenced at %L is never defined",
1611 arg->label->value, &arg->label->where);
1618 if (e->expr_type == EXPR_VARIABLE
1619 && e->symtree->n.sym->attr.generic
1621 && count_specific_procs (e) != 1)
1624 if (e->ts.type != BT_PROCEDURE)
1626 save_need_full_assumed_size = need_full_assumed_size;
1627 if (e->expr_type != EXPR_VARIABLE)
1628 need_full_assumed_size = 0;
1629 if (gfc_resolve_expr (e) != SUCCESS)
1631 need_full_assumed_size = save_need_full_assumed_size;
1635 /* See if the expression node should really be a variable reference. */
1637 sym = e->symtree->n.sym;
1639 if (sym->attr.flavor == FL_PROCEDURE
1640 || sym->attr.intrinsic
1641 || sym->attr.external)
1645 /* If a procedure is not already determined to be something else
1646 check if it is intrinsic. */
1647 if (!sym->attr.intrinsic
1648 && !(sym->attr.external || sym->attr.use_assoc
1649 || sym->attr.if_source == IFSRC_IFBODY)
1650 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1651 sym->attr.intrinsic = 1;
1653 if (sym->attr.proc == PROC_ST_FUNCTION)
1655 gfc_error ("Statement function '%s' at %L is not allowed as an "
1656 "actual argument", sym->name, &e->where);
1659 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1660 sym->attr.subroutine);
1661 if (sym->attr.intrinsic && actual_ok == 0)
1663 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1664 "actual argument", sym->name, &e->where);
1667 if (sym->attr.contained && !sym->attr.use_assoc
1668 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1670 if (gfc_notify_std (GFC_STD_F2008,
1671 "Fortran 2008: Internal procedure '%s' is"
1672 " used as actual argument at %L",
1673 sym->name, &e->where) == FAILURE)
1677 if (sym->attr.elemental && !sym->attr.intrinsic)
1679 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1680 "allowed as an actual argument at %L", sym->name,
1684 /* Check if a generic interface has a specific procedure
1685 with the same name before emitting an error. */
1686 if (sym->attr.generic && count_specific_procs (e) != 1)
1689 /* Just in case a specific was found for the expression. */
1690 sym = e->symtree->n.sym;
1692 /* If the symbol is the function that names the current (or
1693 parent) scope, then we really have a variable reference. */
1695 if (gfc_is_function_return_value (sym, sym->ns))
1698 /* If all else fails, see if we have a specific intrinsic. */
1699 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1701 gfc_intrinsic_sym *isym;
1703 isym = gfc_find_function (sym->name);
1704 if (isym == NULL || !isym->specific)
1706 gfc_error ("Unable to find a specific INTRINSIC procedure "
1707 "for the reference '%s' at %L", sym->name,
1712 sym->attr.intrinsic = 1;
1713 sym->attr.function = 1;
1716 if (gfc_resolve_expr (e) == FAILURE)
1721 /* See if the name is a module procedure in a parent unit. */
1723 if (was_declared (sym) || sym->ns->parent == NULL)
1726 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1728 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1732 if (parent_st == NULL)
1735 sym = parent_st->n.sym;
1736 e->symtree = parent_st; /* Point to the right thing. */
1738 if (sym->attr.flavor == FL_PROCEDURE
1739 || sym->attr.intrinsic
1740 || sym->attr.external)
1742 if (gfc_resolve_expr (e) == FAILURE)
1748 e->expr_type = EXPR_VARIABLE;
1750 if ((sym->as != NULL && sym->ts.type != BT_CLASS)
1751 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
1752 && CLASS_DATA (sym)->as))
1754 e->rank = sym->ts.type == BT_CLASS
1755 ? CLASS_DATA (sym)->as->rank : sym->as->rank;
1756 e->ref = gfc_get_ref ();
1757 e->ref->type = REF_ARRAY;
1758 e->ref->u.ar.type = AR_FULL;
1759 e->ref->u.ar.as = sym->ts.type == BT_CLASS
1760 ? CLASS_DATA (sym)->as : sym->as;
1763 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1764 primary.c (match_actual_arg). If above code determines that it
1765 is a variable instead, it needs to be resolved as it was not
1766 done at the beginning of this function. */
1767 save_need_full_assumed_size = need_full_assumed_size;
1768 if (e->expr_type != EXPR_VARIABLE)
1769 need_full_assumed_size = 0;
1770 if (gfc_resolve_expr (e) != SUCCESS)
1772 need_full_assumed_size = save_need_full_assumed_size;
1775 /* Check argument list functions %VAL, %LOC and %REF. There is
1776 nothing to do for %REF. */
1777 if (arg->name && arg->name[0] == '%')
1779 if (strncmp ("%VAL", arg->name, 4) == 0)
1781 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1783 gfc_error ("By-value argument at %L is not of numeric "
1790 gfc_error ("By-value argument at %L cannot be an array or "
1791 "an array section", &e->where);
1795 /* Intrinsics are still PROC_UNKNOWN here. However,
1796 since same file external procedures are not resolvable
1797 in gfortran, it is a good deal easier to leave them to
1799 if (ptype != PROC_UNKNOWN
1800 && ptype != PROC_DUMMY
1801 && ptype != PROC_EXTERNAL
1802 && ptype != PROC_MODULE)
1804 gfc_error ("By-value argument at %L is not allowed "
1805 "in this context", &e->where);
1810 /* Statement functions have already been excluded above. */
1811 else if (strncmp ("%LOC", arg->name, 4) == 0
1812 && e->ts.type == BT_PROCEDURE)
1814 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1816 gfc_error ("Passing internal procedure at %L by location "
1817 "not allowed", &e->where);
1823 /* Fortran 2008, C1237. */
1824 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1825 && gfc_has_ultimate_pointer (e))
1827 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1828 "component", &e->where);
1837 /* Do the checks of the actual argument list that are specific to elemental
1838 procedures. If called with c == NULL, we have a function, otherwise if
1839 expr == NULL, we have a subroutine. */
1842 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1844 gfc_actual_arglist *arg0;
1845 gfc_actual_arglist *arg;
1846 gfc_symbol *esym = NULL;
1847 gfc_intrinsic_sym *isym = NULL;
1849 gfc_intrinsic_arg *iformal = NULL;
1850 gfc_formal_arglist *eformal = NULL;
1851 bool formal_optional = false;
1852 bool set_by_optional = false;
1856 /* Is this an elemental procedure? */
1857 if (expr && expr->value.function.actual != NULL)
1859 if (expr->value.function.esym != NULL
1860 && expr->value.function.esym->attr.elemental)
1862 arg0 = expr->value.function.actual;
1863 esym = expr->value.function.esym;
1865 else if (expr->value.function.isym != NULL
1866 && expr->value.function.isym->elemental)
1868 arg0 = expr->value.function.actual;
1869 isym = expr->value.function.isym;
1874 else if (c && c->ext.actual != NULL)
1876 arg0 = c->ext.actual;
1878 if (c->resolved_sym)
1879 esym = c->resolved_sym;
1881 esym = c->symtree->n.sym;
1884 if (!esym->attr.elemental)
1890 /* The rank of an elemental is the rank of its array argument(s). */
1891 for (arg = arg0; arg; arg = arg->next)
1893 if (arg->expr != NULL && arg->expr->rank > 0)
1895 rank = arg->expr->rank;
1896 if (arg->expr->expr_type == EXPR_VARIABLE
1897 && arg->expr->symtree->n.sym->attr.optional)
1898 set_by_optional = true;
1900 /* Function specific; set the result rank and shape. */
1904 if (!expr->shape && arg->expr->shape)
1906 expr->shape = gfc_get_shape (rank);
1907 for (i = 0; i < rank; i++)
1908 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1915 /* If it is an array, it shall not be supplied as an actual argument
1916 to an elemental procedure unless an array of the same rank is supplied
1917 as an actual argument corresponding to a nonoptional dummy argument of
1918 that elemental procedure(12.4.1.5). */
1919 formal_optional = false;
1921 iformal = isym->formal;
1923 eformal = esym->formal;
1925 for (arg = arg0; arg; arg = arg->next)
1929 if (eformal->sym && eformal->sym->attr.optional)
1930 formal_optional = true;
1931 eformal = eformal->next;
1933 else if (isym && iformal)
1935 if (iformal->optional)
1936 formal_optional = true;
1937 iformal = iformal->next;
1940 formal_optional = true;
1942 if (pedantic && arg->expr != NULL
1943 && arg->expr->expr_type == EXPR_VARIABLE
1944 && arg->expr->symtree->n.sym->attr.optional
1947 && (set_by_optional || arg->expr->rank != rank)
1948 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1950 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1951 "MISSING, it cannot be the actual argument of an "
1952 "ELEMENTAL procedure unless there is a non-optional "
1953 "argument with the same rank (12.4.1.5)",
1954 arg->expr->symtree->n.sym->name, &arg->expr->where);
1959 for (arg = arg0; arg; arg = arg->next)
1961 if (arg->expr == NULL || arg->expr->rank == 0)
1964 /* Being elemental, the last upper bound of an assumed size array
1965 argument must be present. */
1966 if (resolve_assumed_size_actual (arg->expr))
1969 /* Elemental procedure's array actual arguments must conform. */
1972 if (gfc_check_conformance (arg->expr, e,
1973 "elemental procedure") == FAILURE)
1980 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1981 is an array, the intent inout/out variable needs to be also an array. */
1982 if (rank > 0 && esym && expr == NULL)
1983 for (eformal = esym->formal, arg = arg0; arg && eformal;
1984 arg = arg->next, eformal = eformal->next)
1985 if ((eformal->sym->attr.intent == INTENT_OUT
1986 || eformal->sym->attr.intent == INTENT_INOUT)
1987 && arg->expr && arg->expr->rank == 0)
1989 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1990 "ELEMENTAL subroutine '%s' is a scalar, but another "
1991 "actual argument is an array", &arg->expr->where,
1992 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1993 : "INOUT", eformal->sym->name, esym->name);
2000 /* This function does the checking of references to global procedures
2001 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2002 77 and 95 standards. It checks for a gsymbol for the name, making
2003 one if it does not already exist. If it already exists, then the
2004 reference being resolved must correspond to the type of gsymbol.
2005 Otherwise, the new symbol is equipped with the attributes of the
2006 reference. The corresponding code that is called in creating
2007 global entities is parse.c.
2009 In addition, for all but -std=legacy, the gsymbols are used to
2010 check the interfaces of external procedures from the same file.
2011 The namespace of the gsymbol is resolved and then, once this is
2012 done the interface is checked. */
2016 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2018 if (!gsym_ns->proc_name->attr.recursive)
2021 if (sym->ns == gsym_ns)
2024 if (sym->ns->parent && sym->ns->parent == gsym_ns)
2031 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
2033 if (gsym_ns->entries)
2035 gfc_entry_list *entry = gsym_ns->entries;
2037 for (; entry; entry = entry->next)
2039 if (strcmp (sym->name, entry->sym->name) == 0)
2041 if (strcmp (gsym_ns->proc_name->name,
2042 sym->ns->proc_name->name) == 0)
2046 && strcmp (gsym_ns->proc_name->name,
2047 sym->ns->parent->proc_name->name) == 0)
2056 resolve_global_procedure (gfc_symbol *sym, locus *where,
2057 gfc_actual_arglist **actual, int sub)
2061 enum gfc_symbol_type type;
2063 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2065 gsym = gfc_get_gsymbol (sym->name);
2067 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2068 gfc_global_used (gsym, where);
2070 if (gfc_option.flag_whole_file
2071 && (sym->attr.if_source == IFSRC_UNKNOWN
2072 || sym->attr.if_source == IFSRC_IFBODY)
2073 && gsym->type != GSYM_UNKNOWN
2075 && gsym->ns->resolved != -1
2076 && gsym->ns->proc_name
2077 && not_in_recursive (sym, gsym->ns)
2078 && not_entry_self_reference (sym, gsym->ns))
2080 gfc_symbol *def_sym;
2082 /* Resolve the gsymbol namespace if needed. */
2083 if (!gsym->ns->resolved)
2085 gfc_dt_list *old_dt_list;
2086 struct gfc_omp_saved_state old_omp_state;
2088 /* Stash away derived types so that the backend_decls do not
2090 old_dt_list = gfc_derived_types;
2091 gfc_derived_types = NULL;
2092 /* And stash away openmp state. */
2093 gfc_omp_save_and_clear_state (&old_omp_state);
2095 gfc_resolve (gsym->ns);
2097 /* Store the new derived types with the global namespace. */
2098 if (gfc_derived_types)
2099 gsym->ns->derived_types = gfc_derived_types;
2101 /* Restore the derived types of this namespace. */
2102 gfc_derived_types = old_dt_list;
2103 /* And openmp state. */
2104 gfc_omp_restore_state (&old_omp_state);
2107 /* Make sure that translation for the gsymbol occurs before
2108 the procedure currently being resolved. */
2109 ns = gfc_global_ns_list;
2110 for (; ns && ns != gsym->ns; ns = ns->sibling)
2112 if (ns->sibling == gsym->ns)
2114 ns->sibling = gsym->ns->sibling;
2115 gsym->ns->sibling = gfc_global_ns_list;
2116 gfc_global_ns_list = gsym->ns;
2121 def_sym = gsym->ns->proc_name;
2122 if (def_sym->attr.entry_master)
2124 gfc_entry_list *entry;
2125 for (entry = gsym->ns->entries; entry; entry = entry->next)
2126 if (strcmp (entry->sym->name, sym->name) == 0)
2128 def_sym = entry->sym;
2133 /* Differences in constant character lengths. */
2134 if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2136 long int l1 = 0, l2 = 0;
2137 gfc_charlen *cl1 = sym->ts.u.cl;
2138 gfc_charlen *cl2 = def_sym->ts.u.cl;
2141 && cl1->length != NULL
2142 && cl1->length->expr_type == EXPR_CONSTANT)
2143 l1 = mpz_get_si (cl1->length->value.integer);
2146 && cl2->length != NULL
2147 && cl2->length->expr_type == EXPR_CONSTANT)
2148 l2 = mpz_get_si (cl2->length->value.integer);
2150 if (l1 && l2 && l1 != l2)
2151 gfc_error ("Character length mismatch in return type of "
2152 "function '%s' at %L (%ld/%ld)", sym->name,
2153 &sym->declared_at, l1, l2);
2156 /* Type mismatch of function return type and expected type. */
2157 if (sym->attr.function
2158 && !gfc_compare_types (&sym->ts, &def_sym->ts))
2159 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2160 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2161 gfc_typename (&def_sym->ts));
2163 if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2165 gfc_formal_arglist *arg = def_sym->formal;
2166 for ( ; arg; arg = arg->next)
2169 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2170 else if (arg->sym->attr.allocatable
2171 || arg->sym->attr.asynchronous
2172 || arg->sym->attr.optional
2173 || arg->sym->attr.pointer
2174 || arg->sym->attr.target
2175 || arg->sym->attr.value
2176 || arg->sym->attr.volatile_)
2178 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2179 "has an attribute that requires an explicit "
2180 "interface for this procedure", arg->sym->name,
2181 sym->name, &sym->declared_at);
2184 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2185 else if (arg->sym && arg->sym->as
2186 && arg->sym->as->type == AS_ASSUMED_SHAPE)
2188 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2189 "argument '%s' must have an explicit interface",
2190 sym->name, &sym->declared_at, arg->sym->name);
2193 /* F2008, 12.4.2.2 (2c) */
2194 else if (arg->sym->attr.codimension)
2196 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2197 "'%s' must have an explicit interface",
2198 sym->name, &sym->declared_at, arg->sym->name);
2201 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2202 else if (false) /* TODO: is a parametrized derived type */
2204 gfc_error ("Procedure '%s' at %L with parametrized derived "
2205 "type argument '%s' must have an explicit "
2206 "interface", sym->name, &sym->declared_at,
2210 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2211 else if (arg->sym->ts.type == BT_CLASS)
2213 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2214 "argument '%s' must have an explicit interface",
2215 sym->name, &sym->declared_at, arg->sym->name);
2220 if (def_sym->attr.function)
2222 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2223 if (def_sym->as && def_sym->as->rank
2224 && (!sym->as || sym->as->rank != def_sym->as->rank))
2225 gfc_error ("The reference to function '%s' at %L either needs an "
2226 "explicit INTERFACE or the rank is incorrect", sym->name,
2229 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2230 if ((def_sym->result->attr.pointer
2231 || def_sym->result->attr.allocatable)
2232 && (sym->attr.if_source != IFSRC_IFBODY
2233 || def_sym->result->attr.pointer
2234 != sym->result->attr.pointer
2235 || def_sym->result->attr.allocatable
2236 != sym->result->attr.allocatable))
2237 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2238 "result must have an explicit interface", sym->name,
2241 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2242 if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2243 && def_sym->ts.type == BT_CHARACTER && def_sym->ts.u.cl->length != NULL)
2245 gfc_charlen *cl = sym->ts.u.cl;
2247 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2248 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2250 gfc_error ("Nonconstant character-length function '%s' at %L "
2251 "must have an explicit interface", sym->name,
2257 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2258 if (def_sym->attr.elemental && !sym->attr.elemental)
2260 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2261 "interface", sym->name, &sym->declared_at);
2264 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2265 if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2267 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2268 "an explicit interface", sym->name, &sym->declared_at);
2271 if (gfc_option.flag_whole_file == 1
2272 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2273 && !(gfc_option.warn_std & GFC_STD_GNU)))
2274 gfc_errors_to_warnings (1);
2276 if (sym->attr.if_source != IFSRC_IFBODY)
2277 gfc_procedure_use (def_sym, actual, where);
2279 gfc_errors_to_warnings (0);
2282 if (gsym->type == GSYM_UNKNOWN)
2285 gsym->where = *where;
2292 /************* Function resolution *************/
2294 /* Resolve a function call known to be generic.
2295 Section 14.1.2.4.1. */
2298 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2302 if (sym->attr.generic)
2304 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2307 expr->value.function.name = s->name;
2308 expr->value.function.esym = s;
2310 if (s->ts.type != BT_UNKNOWN)
2312 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2313 expr->ts = s->result->ts;
2316 expr->rank = s->as->rank;
2317 else if (s->result != NULL && s->result->as != NULL)
2318 expr->rank = s->result->as->rank;
2320 gfc_set_sym_referenced (expr->value.function.esym);
2325 /* TODO: Need to search for elemental references in generic
2329 if (sym->attr.intrinsic)
2330 return gfc_intrinsic_func_interface (expr, 0);
2337 resolve_generic_f (gfc_expr *expr)
2341 gfc_interface *intr = NULL;
2343 sym = expr->symtree->n.sym;
2347 m = resolve_generic_f0 (expr, sym);
2350 else if (m == MATCH_ERROR)
2355 for (intr = sym->generic; intr; intr = intr->next)
2356 if (intr->sym->attr.flavor == FL_DERIVED)
2359 if (sym->ns->parent == NULL)
2361 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2365 if (!generic_sym (sym))
2369 /* Last ditch attempt. See if the reference is to an intrinsic
2370 that possesses a matching interface. 14.1.2.4 */
2371 if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
2373 gfc_error ("There is no specific function for the generic '%s' "
2374 "at %L", expr->symtree->n.sym->name, &expr->where);
2380 if (gfc_convert_to_structure_constructor (expr, intr->sym, NULL, NULL,
2383 return resolve_structure_cons (expr, 0);
2386 m = gfc_intrinsic_func_interface (expr, 0);
2391 gfc_error ("Generic function '%s' at %L is not consistent with a "
2392 "specific intrinsic interface", expr->symtree->n.sym->name,
2399 /* Resolve a function call known to be specific. */
2402 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2406 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2408 if (sym->attr.dummy)
2410 sym->attr.proc = PROC_DUMMY;
2414 sym->attr.proc = PROC_EXTERNAL;
2418 if (sym->attr.proc == PROC_MODULE
2419 || sym->attr.proc == PROC_ST_FUNCTION
2420 || sym->attr.proc == PROC_INTERNAL)
2423 if (sym->attr.intrinsic)
2425 m = gfc_intrinsic_func_interface (expr, 1);
2429 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2430 "with an intrinsic", sym->name, &expr->where);
2438 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2441 expr->ts = sym->result->ts;
2444 expr->value.function.name = sym->name;
2445 expr->value.function.esym = sym;
2446 if (sym->as != NULL)
2447 expr->rank = sym->as->rank;
2454 resolve_specific_f (gfc_expr *expr)
2459 sym = expr->symtree->n.sym;
2463 m = resolve_specific_f0 (sym, expr);
2466 if (m == MATCH_ERROR)
2469 if (sym->ns->parent == NULL)
2472 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2478 gfc_error ("Unable to resolve the specific function '%s' at %L",
2479 expr->symtree->n.sym->name, &expr->where);
2485 /* Resolve a procedure call not known to be generic nor specific. */
2488 resolve_unknown_f (gfc_expr *expr)
2493 sym = expr->symtree->n.sym;
2495 if (sym->attr.dummy)
2497 sym->attr.proc = PROC_DUMMY;
2498 expr->value.function.name = sym->name;
2502 /* See if we have an intrinsic function reference. */
2504 if (gfc_is_intrinsic (sym, 0, expr->where))
2506 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2511 /* The reference is to an external name. */
2513 sym->attr.proc = PROC_EXTERNAL;
2514 expr->value.function.name = sym->name;
2515 expr->value.function.esym = expr->symtree->n.sym;
2517 if (sym->as != NULL)
2518 expr->rank = sym->as->rank;
2520 /* Type of the expression is either the type of the symbol or the
2521 default type of the symbol. */
2524 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2526 if (sym->ts.type != BT_UNKNOWN)
2530 ts = gfc_get_default_type (sym->name, sym->ns);
2532 if (ts->type == BT_UNKNOWN)
2534 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2535 sym->name, &expr->where);
2546 /* Return true, if the symbol is an external procedure. */
2548 is_external_proc (gfc_symbol *sym)
2550 if (!sym->attr.dummy && !sym->attr.contained
2551 && !(sym->attr.intrinsic
2552 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2553 && sym->attr.proc != PROC_ST_FUNCTION
2554 && !sym->attr.proc_pointer
2555 && !sym->attr.use_assoc
2563 /* Figure out if a function reference is pure or not. Also set the name
2564 of the function for a potential error message. Return nonzero if the
2565 function is PURE, zero if not. */
2567 pure_stmt_function (gfc_expr *, gfc_symbol *);
2570 pure_function (gfc_expr *e, const char **name)
2576 if (e->symtree != NULL
2577 && e->symtree->n.sym != NULL
2578 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2579 return pure_stmt_function (e, e->symtree->n.sym);
2581 if (e->value.function.esym)
2583 pure = gfc_pure (e->value.function.esym);
2584 *name = e->value.function.esym->name;
2586 else if (e->value.function.isym)
2588 pure = e->value.function.isym->pure
2589 || e->value.function.isym->elemental;
2590 *name = e->value.function.isym->name;
2594 /* Implicit functions are not pure. */
2596 *name = e->value.function.name;
2604 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2605 int *f ATTRIBUTE_UNUSED)
2609 /* Don't bother recursing into other statement functions
2610 since they will be checked individually for purity. */
2611 if (e->expr_type != EXPR_FUNCTION
2613 || e->symtree->n.sym == sym
2614 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2617 return pure_function (e, &name) ? false : true;
2622 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2624 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2629 is_scalar_expr_ptr (gfc_expr *expr)
2631 gfc_try retval = SUCCESS;
2636 /* See if we have a gfc_ref, which means we have a substring, array
2637 reference, or a component. */
2638 if (expr->ref != NULL)
2641 while (ref->next != NULL)
2647 if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
2648 || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
2653 if (ref->u.ar.type == AR_ELEMENT)
2655 else if (ref->u.ar.type == AR_FULL)
2657 /* The user can give a full array if the array is of size 1. */
2658 if (ref->u.ar.as != NULL
2659 && ref->u.ar.as->rank == 1
2660 && ref->u.ar.as->type == AS_EXPLICIT
2661 && ref->u.ar.as->lower[0] != NULL
2662 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2663 && ref->u.ar.as->upper[0] != NULL
2664 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2666 /* If we have a character string, we need to check if
2667 its length is one. */
2668 if (expr->ts.type == BT_CHARACTER)
2670 if (expr->ts.u.cl == NULL
2671 || expr->ts.u.cl->length == NULL
2672 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2678 /* We have constant lower and upper bounds. If the
2679 difference between is 1, it can be considered a
2681 FIXME: Use gfc_dep_compare_expr instead. */
2682 start = (int) mpz_get_si
2683 (ref->u.ar.as->lower[0]->value.integer);
2684 end = (int) mpz_get_si
2685 (ref->u.ar.as->upper[0]->value.integer);
2686 if (end - start + 1 != 1)
2701 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2703 /* Character string. Make sure it's of length 1. */
2704 if (expr->ts.u.cl == NULL
2705 || expr->ts.u.cl->length == NULL
2706 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2709 else if (expr->rank != 0)
2716 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2717 and, in the case of c_associated, set the binding label based on
2721 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2722 gfc_symbol **new_sym)
2724 char name[GFC_MAX_SYMBOL_LEN + 1];
2725 int optional_arg = 0;
2726 gfc_try retval = SUCCESS;
2727 gfc_symbol *args_sym;
2728 gfc_typespec *arg_ts;
2729 symbol_attribute arg_attr;
2731 if (args->expr->expr_type == EXPR_CONSTANT
2732 || args->expr->expr_type == EXPR_OP
2733 || args->expr->expr_type == EXPR_NULL)
2735 gfc_error ("Argument to '%s' at %L is not a variable",
2736 sym->name, &(args->expr->where));
2740 args_sym = args->expr->symtree->n.sym;
2742 /* The typespec for the actual arg should be that stored in the expr
2743 and not necessarily that of the expr symbol (args_sym), because
2744 the actual expression could be a part-ref of the expr symbol. */
2745 arg_ts = &(args->expr->ts);
2746 arg_attr = gfc_expr_attr (args->expr);
2748 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2750 /* If the user gave two args then they are providing something for
2751 the optional arg (the second cptr). Therefore, set the name and
2752 binding label to the c_associated for two cptrs. Otherwise,
2753 set c_associated to expect one cptr. */
2757 sprintf (name, "%s_2", sym->name);
2763 sprintf (name, "%s_1", sym->name);
2767 /* Get a new symbol for the version of c_associated that
2769 *new_sym = get_iso_c_sym (sym, name, NULL, optional_arg);
2771 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2772 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2774 sprintf (name, "%s", sym->name);
2776 /* Error check the call. */
2777 if (args->next != NULL)
2779 gfc_error_now ("More actual than formal arguments in '%s' "
2780 "call at %L", name, &(args->expr->where));
2783 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2788 /* Make sure we have either the target or pointer attribute. */
2789 if (!arg_attr.target && !arg_attr.pointer)
2791 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2792 "a TARGET or an associated pointer",
2794 sym->name, &(args->expr->where));
2798 if (gfc_is_coindexed (args->expr))
2800 gfc_error_now ("Coindexed argument not permitted"
2801 " in '%s' call at %L", name,
2802 &(args->expr->where));
2806 /* Follow references to make sure there are no array
2808 seen_section = false;
2810 for (ref=args->expr->ref; ref; ref = ref->next)
2812 if (ref->type == REF_ARRAY)
2814 if (ref->u.ar.type == AR_SECTION)
2815 seen_section = true;
2817 if (ref->u.ar.type != AR_ELEMENT)
2820 for (r = ref->next; r; r=r->next)
2821 if (r->type == REF_COMPONENT)
2823 gfc_error_now ("Array section not permitted"
2824 " in '%s' call at %L", name,
2825 &(args->expr->where));
2833 if (seen_section && retval == SUCCESS)
2834 gfc_warning ("Array section in '%s' call at %L", name,
2835 &(args->expr->where));
2837 /* See if we have interoperable type and type param. */
2838 if (gfc_verify_c_interop (arg_ts) == SUCCESS
2839 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2841 if (args_sym->attr.target == 1)
2843 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2844 has the target attribute and is interoperable. */
2845 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2846 allocatable variable that has the TARGET attribute and
2847 is not an array of zero size. */
2848 if (args_sym->attr.allocatable == 1)
2850 if (args_sym->attr.dimension != 0
2851 && (args_sym->as && args_sym->as->rank == 0))
2853 gfc_error_now ("Allocatable variable '%s' used as a "
2854 "parameter to '%s' at %L must not be "
2855 "an array of zero size",
2856 args_sym->name, sym->name,
2857 &(args->expr->where));
2863 /* A non-allocatable target variable with C
2864 interoperable type and type parameters must be
2866 if (args_sym && args_sym->attr.dimension)
2868 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2870 gfc_error ("Assumed-shape array '%s' at %L "
2871 "cannot be an argument to the "
2872 "procedure '%s' because "
2873 "it is not C interoperable",
2875 &(args->expr->where), sym->name);
2878 else if (args_sym->as->type == AS_DEFERRED)
2880 gfc_error ("Deferred-shape array '%s' at %L "
2881 "cannot be an argument to the "
2882 "procedure '%s' because "
2883 "it is not C interoperable",
2885 &(args->expr->where), sym->name);
2890 /* Make sure it's not a character string. Arrays of
2891 any type should be ok if the variable is of a C
2892 interoperable type. */
2893 if (arg_ts->type == BT_CHARACTER)
2894 if (arg_ts->u.cl != NULL
2895 && (arg_ts->u.cl->length == NULL
2896 || arg_ts->u.cl->length->expr_type
2899 (arg_ts->u.cl->length->value.integer, 1)
2901 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2903 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2904 "at %L must have a length of 1",
2905 args_sym->name, sym->name,
2906 &(args->expr->where));
2911 else if (arg_attr.pointer
2912 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2914 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2916 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2917 "associated scalar POINTER", args_sym->name,
2918 sym->name, &(args->expr->where));
2924 /* The parameter is not required to be C interoperable. If it
2925 is not C interoperable, it must be a nonpolymorphic scalar
2926 with no length type parameters. It still must have either
2927 the pointer or target attribute, and it can be
2928 allocatable (but must be allocated when c_loc is called). */
2929 if (args->expr->rank != 0
2930 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2932 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2933 "scalar", args_sym->name, sym->name,
2934 &(args->expr->where));
2937 else if (arg_ts->type == BT_CHARACTER
2938 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2940 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2941 "%L must have a length of 1",
2942 args_sym->name, sym->name,
2943 &(args->expr->where));
2946 else if (arg_ts->type == BT_CLASS)
2948 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2949 "polymorphic", args_sym->name, sym->name,
2950 &(args->expr->where));
2955 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2957 if (args_sym->attr.flavor != FL_PROCEDURE)
2959 /* TODO: Update this error message to allow for procedure
2960 pointers once they are implemented. */
2961 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2963 args_sym->name, sym->name,
2964 &(args->expr->where));
2967 else if (args_sym->attr.is_bind_c != 1)
2969 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2971 args_sym->name, sym->name,
2972 &(args->expr->where));
2977 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2982 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2983 "iso_c_binding function: '%s'!\n", sym->name);
2990 /* Resolve a function call, which means resolving the arguments, then figuring
2991 out which entity the name refers to. */
2994 resolve_function (gfc_expr *expr)
2996 gfc_actual_arglist *arg;
3001 procedure_type p = PROC_INTRINSIC;
3002 bool no_formal_args;
3006 sym = expr->symtree->n.sym;
3008 /* If this is a procedure pointer component, it has already been resolved. */
3009 if (gfc_is_proc_ptr_comp (expr, NULL))
3012 if (sym && sym->attr.intrinsic
3013 && resolve_intrinsic (sym, &expr->where) == FAILURE)
3016 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
3018 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
3022 /* If this ia a deferred TBP with an abstract interface (which may
3023 of course be referenced), expr->value.function.esym will be set. */
3024 if (sym && sym->attr.abstract && !expr->value.function.esym)
3026 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3027 sym->name, &expr->where);
3031 /* Switch off assumed size checking and do this again for certain kinds
3032 of procedure, once the procedure itself is resolved. */
3033 need_full_assumed_size++;
3035 if (expr->symtree && expr->symtree->n.sym)
3036 p = expr->symtree->n.sym->attr.proc;
3038 if (expr->value.function.isym && expr->value.function.isym->inquiry)
3039 inquiry_argument = true;
3040 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
3042 if (resolve_actual_arglist (expr->value.function.actual,
3043 p, no_formal_args) == FAILURE)
3045 inquiry_argument = false;
3049 inquiry_argument = false;
3051 /* Need to setup the call to the correct c_associated, depending on
3052 the number of cptrs to user gives to compare. */
3053 if (sym && sym->attr.is_iso_c == 1)
3055 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
3059 /* Get the symtree for the new symbol (resolved func).
3060 the old one will be freed later, when it's no longer used. */
3061 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
3064 /* Resume assumed_size checking. */
3065 need_full_assumed_size--;
3067 /* If the procedure is external, check for usage. */
3068 if (sym && is_external_proc (sym))
3069 resolve_global_procedure (sym, &expr->where,
3070 &expr->value.function.actual, 0);
3072 if (sym && sym->ts.type == BT_CHARACTER
3074 && sym->ts.u.cl->length == NULL
3076 && !sym->ts.deferred
3077 && expr->value.function.esym == NULL
3078 && !sym->attr.contained)
3080 /* Internal procedures are taken care of in resolve_contained_fntype. */
3081 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
3082 "be used at %L since it is not a dummy argument",
3083 sym->name, &expr->where);
3087 /* See if function is already resolved. */
3089 if (expr->value.function.name != NULL)
3091 if (expr->ts.type == BT_UNKNOWN)
3097 /* Apply the rules of section 14.1.2. */
3099 switch (procedure_kind (sym))
3102 t = resolve_generic_f (expr);
3105 case PTYPE_SPECIFIC:
3106 t = resolve_specific_f (expr);
3110 t = resolve_unknown_f (expr);
3114 gfc_internal_error ("resolve_function(): bad function type");
3118 /* If the expression is still a function (it might have simplified),
3119 then we check to see if we are calling an elemental function. */
3121 if (expr->expr_type != EXPR_FUNCTION)
3124 temp = need_full_assumed_size;
3125 need_full_assumed_size = 0;
3127 if (resolve_elemental_actual (expr, NULL) == FAILURE)
3130 if (omp_workshare_flag
3131 && expr->value.function.esym
3132 && ! gfc_elemental (expr->value.function.esym))
3134 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3135 "in WORKSHARE construct", expr->value.function.esym->name,
3140 #define GENERIC_ID expr->value.function.isym->id
3141 else if (expr->value.function.actual != NULL
3142 && expr->value.function.isym != NULL
3143 && GENERIC_ID != GFC_ISYM_LBOUND
3144 && GENERIC_ID != GFC_ISYM_LEN
3145 && GENERIC_ID != GFC_ISYM_LOC
3146 && GENERIC_ID != GFC_ISYM_PRESENT)
3148 /* Array intrinsics must also have the last upper bound of an
3149 assumed size array argument. UBOUND and SIZE have to be
3150 excluded from the check if the second argument is anything
3153 for (arg = expr->value.function.actual; arg; arg = arg->next)
3155 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3156 && arg->next != NULL && arg->next->expr)
3158 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3161 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3164 if ((int)mpz_get_si (arg->next->expr->value.integer)
3169 if (arg->expr != NULL
3170 && arg->expr->rank > 0
3171 && resolve_assumed_size_actual (arg->expr))
3177 need_full_assumed_size = temp;
3180 if (!pure_function (expr, &name) && name)
3184 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3185 "FORALL %s", name, &expr->where,
3186 forall_flag == 2 ? "mask" : "block");
3189 else if (do_concurrent_flag)
3191 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3192 "DO CONCURRENT %s", name, &expr->where,
3193 do_concurrent_flag == 2 ? "mask" : "block");
3196 else if (gfc_pure (NULL))
3198 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3199 "procedure within a PURE procedure", name, &expr->where);
3203 if (gfc_implicit_pure (NULL))
3204 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3207 /* Functions without the RECURSIVE attribution are not allowed to
3208 * call themselves. */
3209 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3212 esym = expr->value.function.esym;
3214 if (is_illegal_recursion (esym, gfc_current_ns))
3216 if (esym->attr.entry && esym->ns->entries)
3217 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3218 " function '%s' is not RECURSIVE",
3219 esym->name, &expr->where, esym->ns->entries->sym->name);
3221 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3222 " is not RECURSIVE", esym->name, &expr->where);
3228 /* Character lengths of use associated functions may contains references to
3229 symbols not referenced from the current program unit otherwise. Make sure
3230 those symbols are marked as referenced. */
3232 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3233 && expr->value.function.esym->attr.use_assoc)
3235 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3238 /* Make sure that the expression has a typespec that works. */
3239 if (expr->ts.type == BT_UNKNOWN)
3241 if (expr->symtree->n.sym->result
3242 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3243 && !expr->symtree->n.sym->result->attr.proc_pointer)
3244 expr->ts = expr->symtree->n.sym->result->ts;
3251 /************* Subroutine resolution *************/
3254 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3260 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3261 sym->name, &c->loc);
3262 else if (do_concurrent_flag)
3263 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3264 "PURE", sym->name, &c->loc);
3265 else if (gfc_pure (NULL))
3266 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3269 if (gfc_implicit_pure (NULL))
3270 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3275 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3279 if (sym->attr.generic)
3281 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3284 c->resolved_sym = s;
3285 pure_subroutine (c, s);
3289 /* TODO: Need to search for elemental references in generic interface. */
3292 if (sym->attr.intrinsic)
3293 return gfc_intrinsic_sub_interface (c, 0);
3300 resolve_generic_s (gfc_code *c)
3305 sym = c->symtree->n.sym;
3309 m = resolve_generic_s0 (c, sym);
3312 else if (m == MATCH_ERROR)
3316 if (sym->ns->parent == NULL)
3318 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3322 if (!generic_sym (sym))
3326 /* Last ditch attempt. See if the reference is to an intrinsic
3327 that possesses a matching interface. 14.1.2.4 */
3328 sym = c->symtree->n.sym;
3330 if (!gfc_is_intrinsic (sym, 1, c->loc))
3332 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3333 sym->name, &c->loc);
3337 m = gfc_intrinsic_sub_interface (c, 0);
3341 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3342 "intrinsic subroutine interface", sym->name, &c->loc);
3348 /* Set the name and binding label of the subroutine symbol in the call
3349 expression represented by 'c' to include the type and kind of the
3350 second parameter. This function is for resolving the appropriate
3351 version of c_f_pointer() and c_f_procpointer(). For example, a
3352 call to c_f_pointer() for a default integer pointer could have a
3353 name of c_f_pointer_i4. If no second arg exists, which is an error
3354 for these two functions, it defaults to the generic symbol's name
3355 and binding label. */
3358 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3359 char *name, char **binding_label)
3361 gfc_expr *arg = NULL;
3365 /* The second arg of c_f_pointer and c_f_procpointer determines
3366 the type and kind for the procedure name. */
3367 arg = c->ext.actual->next->expr;
3371 /* Set up the name to have the given symbol's name,
3372 plus the type and kind. */
3373 /* a derived type is marked with the type letter 'u' */
3374 if (arg->ts.type == BT_DERIVED)
3377 kind = 0; /* set the kind as 0 for now */
3381 type = gfc_type_letter (arg->ts.type);
3382 kind = arg->ts.kind;
3385 if (arg->ts.type == BT_CHARACTER)
3386 /* Kind info for character strings not needed. */
3389 sprintf (name, "%s_%c%d", sym->name, type, kind);
3390 /* Set up the binding label as the given symbol's label plus
3391 the type and kind. */
3392 *binding_label = gfc_get_string ("%s_%c%d", sym->binding_label, type,
3397 /* If the second arg is missing, set the name and label as
3398 was, cause it should at least be found, and the missing
3399 arg error will be caught by compare_parameters(). */
3400 sprintf (name, "%s", sym->name);
3401 *binding_label = sym->binding_label;
3408 /* Resolve a generic version of the iso_c_binding procedure given
3409 (sym) to the specific one based on the type and kind of the
3410 argument(s). Currently, this function resolves c_f_pointer() and
3411 c_f_procpointer based on the type and kind of the second argument
3412 (FPTR). Other iso_c_binding procedures aren't specially handled.
3413 Upon successfully exiting, c->resolved_sym will hold the resolved
3414 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3418 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3420 gfc_symbol *new_sym;
3421 /* this is fine, since we know the names won't use the max */
3422 char name[GFC_MAX_SYMBOL_LEN + 1];
3423 char* binding_label;
3424 /* default to success; will override if find error */
3425 match m = MATCH_YES;
3427 /* Make sure the actual arguments are in the necessary order (based on the
3428 formal args) before resolving. */
3429 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3431 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3432 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3434 set_name_and_label (c, sym, name, &binding_label);
3436 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3438 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3440 /* Make sure we got a third arg if the second arg has non-zero
3441 rank. We must also check that the type and rank are
3442 correct since we short-circuit this check in
3443 gfc_procedure_use() (called above to sort actual args). */
3444 if (c->ext.actual->next->expr->rank != 0)
3446 if(c->ext.actual->next->next == NULL
3447 || c->ext.actual->next->next->expr == NULL)
3450 gfc_error ("Missing SHAPE parameter for call to %s "
3451 "at %L", sym->name, &(c->loc));
3453 else if (c->ext.actual->next->next->expr->ts.type
3455 || c->ext.actual->next->next->expr->rank != 1)
3458 gfc_error ("SHAPE parameter for call to %s at %L must "
3459 "be a rank 1 INTEGER array", sym->name,
3466 if (m != MATCH_ERROR)
3468 /* the 1 means to add the optional arg to formal list */
3469 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3471 /* for error reporting, say it's declared where the original was */
3472 new_sym->declared_at = sym->declared_at;
3477 /* no differences for c_loc or c_funloc */
3481 /* set the resolved symbol */
3482 if (m != MATCH_ERROR)
3483 c->resolved_sym = new_sym;
3485 c->resolved_sym = sym;
3491 /* Resolve a subroutine call known to be specific. */
3494 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3498 if(sym->attr.is_iso_c)
3500 m = gfc_iso_c_sub_interface (c,sym);
3504 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3506 if (sym->attr.dummy)
3508 sym->attr.proc = PROC_DUMMY;
3512 sym->attr.proc = PROC_EXTERNAL;
3516 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3519 if (sym->attr.intrinsic)
3521 m = gfc_intrinsic_sub_interface (c, 1);
3525 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3526 "with an intrinsic", sym->name, &c->loc);
3534 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3536 c->resolved_sym = sym;
3537 pure_subroutine (c, sym);
3544 resolve_specific_s (gfc_code *c)
3549 sym = c->symtree->n.sym;
3553 m = resolve_specific_s0 (c, sym);
3556 if (m == MATCH_ERROR)
3559 if (sym->ns->parent == NULL)
3562 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3568 sym = c->symtree->n.sym;
3569 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3570 sym->name, &c->loc);
3576 /* Resolve a subroutine call not known to be generic nor specific. */
3579 resolve_unknown_s (gfc_code *c)
3583 sym = c->symtree->n.sym;
3585 if (sym->attr.dummy)
3587 sym->attr.proc = PROC_DUMMY;
3591 /* See if we have an intrinsic function reference. */
3593 if (gfc_is_intrinsic (sym, 1, c->loc))
3595 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3600 /* The reference is to an external name. */
3603 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3605 c->resolved_sym = sym;
3607 pure_subroutine (c, sym);
3613 /* Resolve a subroutine call. Although it was tempting to use the same code
3614 for functions, subroutines and functions are stored differently and this
3615 makes things awkward. */
3618 resolve_call (gfc_code *c)
3621 procedure_type ptype = PROC_INTRINSIC;
3622 gfc_symbol *csym, *sym;
3623 bool no_formal_args;
3625 csym = c->symtree ? c->symtree->n.sym : NULL;
3627 if (csym && csym->ts.type != BT_UNKNOWN)
3629 gfc_error ("'%s' at %L has a type, which is not consistent with "
3630 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3634 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3637 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3638 sym = st ? st->n.sym : NULL;
3639 if (sym && csym != sym
3640 && sym->ns == gfc_current_ns
3641 && sym->attr.flavor == FL_PROCEDURE
3642 && sym->attr.contained)
3645 if (csym->attr.generic)
3646 c->symtree->n.sym = sym;
3649 csym = c->symtree->n.sym;
3653 /* If this ia a deferred TBP with an abstract interface
3654 (which may of course be referenced), c->expr1 will be set. */
3655 if (csym && csym->attr.abstract && !c->expr1)
3657 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3658 csym->name, &c->loc);
3662 /* Subroutines without the RECURSIVE attribution are not allowed to
3663 * call themselves. */
3664 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3666 if (csym->attr.entry && csym->ns->entries)
3667 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3668 " subroutine '%s' is not RECURSIVE",
3669 csym->name, &c->loc, csym->ns->entries->sym->name);
3671 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3672 " is not RECURSIVE", csym->name, &c->loc);
3677 /* Switch off assumed size checking and do this again for certain kinds
3678 of procedure, once the procedure itself is resolved. */
3679 need_full_assumed_size++;
3682 ptype = csym->attr.proc;
3684 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3685 if (resolve_actual_arglist (c->ext.actual, ptype,
3686 no_formal_args) == FAILURE)
3689 /* Resume assumed_size checking. */
3690 need_full_assumed_size--;
3692 /* If external, check for usage. */
3693 if (csym && is_external_proc (csym))
3694 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3697 if (c->resolved_sym == NULL)
3699 c->resolved_isym = NULL;
3700 switch (procedure_kind (csym))
3703 t = resolve_generic_s (c);
3706 case PTYPE_SPECIFIC:
3707 t = resolve_specific_s (c);
3711 t = resolve_unknown_s (c);
3715 gfc_internal_error ("resolve_subroutine(): bad function type");
3719 /* Some checks of elemental subroutine actual arguments. */
3720 if (resolve_elemental_actual (NULL, c) == FAILURE)
3727 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3728 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3729 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3730 if their shapes do not match. If either op1->shape or op2->shape is
3731 NULL, return SUCCESS. */
3734 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3741 if (op1->shape != NULL && op2->shape != NULL)
3743 for (i = 0; i < op1->rank; i++)
3745 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3747 gfc_error ("Shapes for operands at %L and %L are not conformable",
3748 &op1->where, &op2->where);
3759 /* Resolve an operator expression node. This can involve replacing the
3760 operation with a user defined function call. */
3763 resolve_operator (gfc_expr *e)
3765 gfc_expr *op1, *op2;
3767 bool dual_locus_error;
3770 /* Resolve all subnodes-- give them types. */
3772 switch (e->value.op.op)
3775 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3778 /* Fall through... */
3781 case INTRINSIC_UPLUS:
3782 case INTRINSIC_UMINUS:
3783 case INTRINSIC_PARENTHESES:
3784 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3789 /* Typecheck the new node. */
3791 op1 = e->value.op.op1;
3792 op2 = e->value.op.op2;
3793 dual_locus_error = false;
3795 if ((op1 && op1->expr_type == EXPR_NULL)
3796 || (op2 && op2->expr_type == EXPR_NULL))
3798 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3802 switch (e->value.op.op)
3804 case INTRINSIC_UPLUS:
3805 case INTRINSIC_UMINUS:
3806 if (op1->ts.type == BT_INTEGER
3807 || op1->ts.type == BT_REAL
3808 || op1->ts.type == BT_COMPLEX)
3814 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3815 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3818 case INTRINSIC_PLUS:
3819 case INTRINSIC_MINUS:
3820 case INTRINSIC_TIMES:
3821 case INTRINSIC_DIVIDE:
3822 case INTRINSIC_POWER:
3823 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3825 gfc_type_convert_binary (e, 1);
3830 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3831 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3832 gfc_typename (&op2->ts));
3835 case INTRINSIC_CONCAT:
3836 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3837 && op1->ts.kind == op2->ts.kind)
3839 e->ts.type = BT_CHARACTER;
3840 e->ts.kind = op1->ts.kind;
3845 _("Operands of string concatenation operator at %%L are %s/%s"),
3846 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3852 case INTRINSIC_NEQV:
3853 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3855 e->ts.type = BT_LOGICAL;
3856 e->ts.kind = gfc_kind_max (op1, op2);
3857 if (op1->ts.kind < e->ts.kind)
3858 gfc_convert_type (op1, &e->ts, 2);
3859 else if (op2->ts.kind < e->ts.kind)
3860 gfc_convert_type (op2, &e->ts, 2);
3864 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3865 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3866 gfc_typename (&op2->ts));
3871 if (op1->ts.type == BT_LOGICAL)
3873 e->ts.type = BT_LOGICAL;
3874 e->ts.kind = op1->ts.kind;
3878 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3879 gfc_typename (&op1->ts));
3883 case INTRINSIC_GT_OS:
3885 case INTRINSIC_GE_OS:
3887 case INTRINSIC_LT_OS:
3889 case INTRINSIC_LE_OS:
3890 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3892 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3896 /* Fall through... */
3899 case INTRINSIC_EQ_OS:
3901 case INTRINSIC_NE_OS:
3902 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3903 && op1->ts.kind == op2->ts.kind)
3905 e->ts.type = BT_LOGICAL;
3906 e->ts.kind = gfc_default_logical_kind;
3910 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3912 gfc_type_convert_binary (e, 1);
3914 e->ts.type = BT_LOGICAL;
3915 e->ts.kind = gfc_default_logical_kind;
3919 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3921 _("Logicals at %%L must be compared with %s instead of %s"),
3922 (e->value.op.op == INTRINSIC_EQ
3923 || e->value.op.op == INTRINSIC_EQ_OS)
3924 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3927 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3928 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3929 gfc_typename (&op2->ts));
3933 case INTRINSIC_USER:
3934 if (e->value.op.uop->op == NULL)
3935 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3936 else if (op2 == NULL)
3937 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3938 e->value.op.uop->name, gfc_typename (&op1->ts));
3941 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3942 e->value.op.uop->name, gfc_typename (&op1->ts),
3943 gfc_typename (&op2->ts));
3944 e->value.op.uop->op->sym->attr.referenced = 1;
3949 case INTRINSIC_PARENTHESES:
3951 if (e->ts.type == BT_CHARACTER)
3952 e->ts.u.cl = op1->ts.u.cl;
3956 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3959 /* Deal with arrayness of an operand through an operator. */
3963 switch (e->value.op.op)
3965 case INTRINSIC_PLUS:
3966 case INTRINSIC_MINUS:
3967 case INTRINSIC_TIMES:
3968 case INTRINSIC_DIVIDE:
3969 case INTRINSIC_POWER:
3970 case INTRINSIC_CONCAT:
3974 case INTRINSIC_NEQV:
3976 case INTRINSIC_EQ_OS:
3978 case INTRINSIC_NE_OS:
3980 case INTRINSIC_GT_OS:
3982 case INTRINSIC_GE_OS:
3984 case INTRINSIC_LT_OS:
3986 case INTRINSIC_LE_OS:
3988 if (op1->rank == 0 && op2->rank == 0)
3991 if (op1->rank == 0 && op2->rank != 0)
3993 e->rank = op2->rank;
3995 if (e->shape == NULL)
3996 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3999 if (op1->rank != 0 && op2->rank == 0)
4001 e->rank = op1->rank;
4003 if (e->shape == NULL)
4004 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4007 if (op1->rank != 0 && op2->rank != 0)
4009 if (op1->rank == op2->rank)
4011 e->rank = op1->rank;
4012 if (e->shape == NULL)
4014 t = compare_shapes (op1, op2);
4018 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4023 /* Allow higher level expressions to work. */
4026 /* Try user-defined operators, and otherwise throw an error. */
4027 dual_locus_error = true;
4029 _("Inconsistent ranks for operator at %%L and %%L"));
4036 case INTRINSIC_PARENTHESES:
4038 case INTRINSIC_UPLUS:
4039 case INTRINSIC_UMINUS:
4040 /* Simply copy arrayness attribute */
4041 e->rank = op1->rank;
4043 if (e->shape == NULL)
4044 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4052 /* Attempt to simplify the expression. */
4055 t = gfc_simplify_expr (e, 0);
4056 /* Some calls do not succeed in simplification and return FAILURE
4057 even though there is no error; e.g. variable references to
4058 PARAMETER arrays. */
4059 if (!gfc_is_constant_expr (e))
4067 match m = gfc_extend_expr (e);
4070 if (m == MATCH_ERROR)
4074 if (dual_locus_error)
4075 gfc_error (msg, &op1->where, &op2->where);
4077 gfc_error (msg, &e->where);
4083 /************** Array resolution subroutines **************/
4086 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
4089 /* Compare two integer expressions. */
4092 compare_bound (gfc_expr *a, gfc_expr *b)
4096 if (a == NULL || a->expr_type != EXPR_CONSTANT
4097 || b == NULL || b->expr_type != EXPR_CONSTANT)
4100 /* If either of the types isn't INTEGER, we must have
4101 raised an error earlier. */
4103 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
4106 i = mpz_cmp (a->value.integer, b->value.integer);
4116 /* Compare an integer expression with an integer. */
4119 compare_bound_int (gfc_expr *a, int b)
4123 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4126 if (a->ts.type != BT_INTEGER)
4127 gfc_internal_error ("compare_bound_int(): Bad expression");
4129 i = mpz_cmp_si (a->value.integer, b);
4139 /* Compare an integer expression with a mpz_t. */
4142 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4146 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4149 if (a->ts.type != BT_INTEGER)
4150 gfc_internal_error ("compare_bound_int(): Bad expression");
4152 i = mpz_cmp (a->value.integer, b);
4162 /* Compute the last value of a sequence given by a triplet.
4163 Return 0 if it wasn't able to compute the last value, or if the
4164 sequence if empty, and 1 otherwise. */
4167 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4168 gfc_expr *stride, mpz_t last)
4172 if (start == NULL || start->expr_type != EXPR_CONSTANT
4173 || end == NULL || end->expr_type != EXPR_CONSTANT
4174 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4177 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4178 || (stride != NULL && stride->ts.type != BT_INTEGER))
4181 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
4183 if (compare_bound (start, end) == CMP_GT)
4185 mpz_set (last, end->value.integer);
4189 if (compare_bound_int (stride, 0) == CMP_GT)
4191 /* Stride is positive */
4192 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4197 /* Stride is negative */
4198 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4203 mpz_sub (rem, end->value.integer, start->value.integer);
4204 mpz_tdiv_r (rem, rem, stride->value.integer);
4205 mpz_sub (last, end->value.integer, rem);
4212 /* Compare a single dimension of an array reference to the array
4216 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4220 if (ar->dimen_type[i] == DIMEN_STAR)
4222 gcc_assert (ar->stride[i] == NULL);
4223 /* This implies [*] as [*:] and [*:3] are not possible. */
4224 if (ar->start[i] == NULL)
4226 gcc_assert (ar->end[i] == NULL);
4231 /* Given start, end and stride values, calculate the minimum and
4232 maximum referenced indexes. */
4234 switch (ar->dimen_type[i])
4237 case DIMEN_THIS_IMAGE:
4242 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4245 gfc_warning ("Array reference at %L is out of bounds "
4246 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4247 mpz_get_si (ar->start[i]->value.integer),
4248 mpz_get_si (as->lower[i]->value.integer), i+1);
4250 gfc_warning ("Array reference at %L is out of bounds "
4251 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4252 mpz_get_si (ar->start[i]->value.integer),
4253 mpz_get_si (as->lower[i]->value.integer),
4257 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4260 gfc_warning ("Array reference at %L is out of bounds "
4261 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4262 mpz_get_si (ar->start[i]->value.integer),
4263 mpz_get_si (as->upper[i]->value.integer), i+1);
4265 gfc_warning ("Array reference at %L is out of bounds "
4266 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4267 mpz_get_si (ar->start[i]->value.integer),
4268 mpz_get_si (as->upper[i]->value.integer),
4277 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4278 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4280 comparison comp_start_end = compare_bound (AR_START, AR_END);
4282 /* Check for zero stride, which is not allowed. */
4283 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4285 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4289 /* if start == len || (stride > 0 && start < len)
4290 || (stride < 0 && start > len),
4291 then the array section contains at least one element. In this
4292 case, there is an out-of-bounds access if
4293 (start < lower || start > upper). */
4294 if (compare_bound (AR_START, AR_END) == CMP_EQ
4295 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4296 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4297 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4298 && comp_start_end == CMP_GT))
4300 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4302 gfc_warning ("Lower array reference at %L is out of bounds "
4303 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4304 mpz_get_si (AR_START->value.integer),
4305 mpz_get_si (as->lower[i]->value.integer), i+1);
4308 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4310 gfc_warning ("Lower array reference at %L is out of bounds "
4311 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4312 mpz_get_si (AR_START->value.integer),
4313 mpz_get_si (as->upper[i]->value.integer), i+1);
4318 /* If we can compute the highest index of the array section,
4319 then it also has to be between lower and upper. */
4320 mpz_init (last_value);
4321 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4324 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4326 gfc_warning ("Upper array reference at %L is out of bounds "
4327 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4328 mpz_get_si (last_value),
4329 mpz_get_si (as->lower[i]->value.integer), i+1);
4330 mpz_clear (last_value);
4333 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4335 gfc_warning ("Upper array reference at %L is out of bounds "
4336 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4337 mpz_get_si (last_value),
4338 mpz_get_si (as->upper[i]->value.integer), i+1);
4339 mpz_clear (last_value);
4343 mpz_clear (last_value);
4351 gfc_internal_error ("check_dimension(): Bad array reference");
4358 /* Compare an array reference with an array specification. */
4361 compare_spec_to_ref (gfc_array_ref *ar)
4368 /* TODO: Full array sections are only allowed as actual parameters. */
4369 if (as->type == AS_ASSUMED_SIZE
4370 && (/*ar->type == AR_FULL
4371 ||*/ (ar->type == AR_SECTION
4372 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4374 gfc_error ("Rightmost upper bound of assumed size array section "
4375 "not specified at %L", &ar->where);
4379 if (ar->type == AR_FULL)
4382 if (as->rank != ar->dimen)
4384 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4385 &ar->where, ar->dimen, as->rank);
4389 /* ar->codimen == 0 is a local array. */
4390 if (as->corank != ar->codimen && ar->codimen != 0)
4392 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4393 &ar->where, ar->codimen, as->corank);
4397 for (i = 0; i < as->rank; i++)
4398 if (check_dimension (i, ar, as) == FAILURE)
4401 /* Local access has no coarray spec. */
4402 if (ar->codimen != 0)
4403 for (i = as->rank; i < as->rank + as->corank; i++)
4405 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
4406 && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
4408 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4409 i + 1 - as->rank, &ar->where);
4412 if (check_dimension (i, ar, as) == FAILURE)
4420 /* Resolve one part of an array index. */
4423 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4424 int force_index_integer_kind)
4431 if (gfc_resolve_expr (index) == FAILURE)
4434 if (check_scalar && index->rank != 0)
4436 gfc_error ("Array index at %L must be scalar", &index->where);
4440 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4442 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4443 &index->where, gfc_basic_typename (index->ts.type));
4447 if (index->ts.type == BT_REAL)
4448 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
4449 &index->where) == FAILURE)
4452 if ((index->ts.kind != gfc_index_integer_kind
4453 && force_index_integer_kind)
4454 || index->ts.type != BT_INTEGER)
4457 ts.type = BT_INTEGER;
4458 ts.kind = gfc_index_integer_kind;
4460 gfc_convert_type_warn (index, &ts, 2, 0);
4466 /* Resolve one part of an array index. */
4469 gfc_resolve_index (gfc_expr *index, int check_scalar)
4471 return gfc_resolve_index_1 (index, check_scalar, 1);
4474 /* Resolve a dim argument to an intrinsic function. */
4477 gfc_resolve_dim_arg (gfc_expr *dim)
4482 if (gfc_resolve_expr (dim) == FAILURE)
4487 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4492 if (dim->ts.type != BT_INTEGER)
4494 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4498 if (dim->ts.kind != gfc_index_integer_kind)
4503 ts.type = BT_INTEGER;
4504 ts.kind = gfc_index_integer_kind;
4506 gfc_convert_type_warn (dim, &ts, 2, 0);
4512 /* Given an expression that contains array references, update those array
4513 references to point to the right array specifications. While this is
4514 filled in during matching, this information is difficult to save and load
4515 in a module, so we take care of it here.
4517 The idea here is that the original array reference comes from the
4518 base symbol. We traverse the list of reference structures, setting
4519 the stored reference to references. Component references can
4520 provide an additional array specification. */
4523 find_array_spec (gfc_expr *e)
4529 if (e->symtree->n.sym->ts.type == BT_CLASS)
4530 as = CLASS_DATA (e->symtree->n.sym)->as;
4532 as = e->symtree->n.sym->as;
4534 for (ref = e->ref; ref; ref = ref->next)
4539 gfc_internal_error ("find_array_spec(): Missing spec");
4546 c = ref->u.c.component;
4547 if (c->attr.dimension)
4550 gfc_internal_error ("find_array_spec(): unused as(1)");
4561 gfc_internal_error ("find_array_spec(): unused as(2)");
4565 /* Resolve an array reference. */
4568 resolve_array_ref (gfc_array_ref *ar)
4570 int i, check_scalar;
4573 for (i = 0; i < ar->dimen + ar->codimen; i++)
4575 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4577 /* Do not force gfc_index_integer_kind for the start. We can
4578 do fine with any integer kind. This avoids temporary arrays
4579 created for indexing with a vector. */
4580 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4582 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4584 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4589 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4593 ar->dimen_type[i] = DIMEN_ELEMENT;
4597 ar->dimen_type[i] = DIMEN_VECTOR;
4598 if (e->expr_type == EXPR_VARIABLE
4599 && e->symtree->n.sym->ts.type == BT_DERIVED)
4600 ar->start[i] = gfc_get_parentheses (e);
4604 gfc_error ("Array index at %L is an array of rank %d",
4605 &ar->c_where[i], e->rank);
4609 /* Fill in the upper bound, which may be lower than the
4610 specified one for something like a(2:10:5), which is
4611 identical to a(2:7:5). Only relevant for strides not equal
4612 to one. Don't try a division by zero. */
4613 if (ar->dimen_type[i] == DIMEN_RANGE
4614 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4615 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
4616 && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
4620 if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4622 if (ar->end[i] == NULL)
4625 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4627 mpz_set (ar->end[i]->value.integer, end);
4629 else if (ar->end[i]->ts.type == BT_INTEGER
4630 && ar->end[i]->expr_type == EXPR_CONSTANT)
4632 mpz_set (ar->end[i]->value.integer, end);
4643 if (ar->type == AR_FULL)
4645 if (ar->as->rank == 0)
4646 ar->type = AR_ELEMENT;
4648 /* Make sure array is the same as array(:,:), this way
4649 we don't need to special case all the time. */
4650 ar->dimen = ar->as->rank;
4651 for (i = 0; i < ar->dimen; i++)
4653 ar->dimen_type[i] = DIMEN_RANGE;
4655 gcc_assert (ar->start[i] == NULL);
4656 gcc_assert (ar->end[i] == NULL);
4657 gcc_assert (ar->stride[i] == NULL);
4661 /* If the reference type is unknown, figure out what kind it is. */
4663 if (ar->type == AR_UNKNOWN)
4665 ar->type = AR_ELEMENT;
4666 for (i = 0; i < ar->dimen; i++)
4667 if (ar->dimen_type[i] == DIMEN_RANGE
4668 || ar->dimen_type[i] == DIMEN_VECTOR)
4670 ar->type = AR_SECTION;
4675 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4678 if (ar->as->corank && ar->codimen == 0)
4681 ar->codimen = ar->as->corank;
4682 for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
4683 ar->dimen_type[n] = DIMEN_THIS_IMAGE;
4691 resolve_substring (gfc_ref *ref)
4693 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4695 if (ref->u.ss.start != NULL)
4697 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4700 if (ref->u.ss.start->ts.type != BT_INTEGER)
4702 gfc_error ("Substring start index at %L must be of type INTEGER",
4703 &ref->u.ss.start->where);
4707 if (ref->u.ss.start->rank != 0)
4709 gfc_error ("Substring start index at %L must be scalar",
4710 &ref->u.ss.start->where);
4714 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4715 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4716 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4718 gfc_error ("Substring start index at %L is less than one",
4719 &ref->u.ss.start->where);
4724 if (ref->u.ss.end != NULL)
4726 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4729 if (ref->u.ss.end->ts.type != BT_INTEGER)
4731 gfc_error ("Substring end index at %L must be of type INTEGER",
4732 &ref->u.ss.end->where);
4736 if (ref->u.ss.end->rank != 0)
4738 gfc_error ("Substring end index at %L must be scalar",
4739 &ref->u.ss.end->where);
4743 if (ref->u.ss.length != NULL
4744 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4745 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4746 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4748 gfc_error ("Substring end index at %L exceeds the string length",
4749 &ref->u.ss.start->where);
4753 if (compare_bound_mpz_t (ref->u.ss.end,
4754 gfc_integer_kinds[k].huge) == CMP_GT
4755 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4756 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4758 gfc_error ("Substring end index at %L is too large",
4759 &ref->u.ss.end->where);
4768 /* This function supplies missing substring charlens. */
4771 gfc_resolve_substring_charlen (gfc_expr *e)
4774 gfc_expr *start, *end;
4776 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4777 if (char_ref->type == REF_SUBSTRING)
4783 gcc_assert (char_ref->next == NULL);
4787 if (e->ts.u.cl->length)
4788 gfc_free_expr (e->ts.u.cl->length);
4789 else if (e->expr_type == EXPR_VARIABLE
4790 && e->symtree->n.sym->attr.dummy)
4794 e->ts.type = BT_CHARACTER;
4795 e->ts.kind = gfc_default_character_kind;
4798 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4800 if (char_ref->u.ss.start)
4801 start = gfc_copy_expr (char_ref->u.ss.start);
4803 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4805 if (char_ref->u.ss.end)
4806 end = gfc_copy_expr (char_ref->u.ss.end);
4807 else if (e->expr_type == EXPR_VARIABLE)
4808 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4815 /* Length = (end - start +1). */
4816 e->ts.u.cl->length = gfc_subtract (end, start);
4817 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4818 gfc_get_int_expr (gfc_default_integer_kind,
4821 e->ts.u.cl->length->ts.type = BT_INTEGER;
4822 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4824 /* Make sure that the length is simplified. */
4825 gfc_simplify_expr (e->ts.u.cl->length, 1);
4826 gfc_resolve_expr (e->ts.u.cl->length);
4830 /* Resolve subtype references. */
4833 resolve_ref (gfc_expr *expr)
4835 int current_part_dimension, n_components, seen_part_dimension;
4838 for (ref = expr->ref; ref; ref = ref->next)
4839 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4841 find_array_spec (expr);
4845 for (ref = expr->ref; ref; ref = ref->next)
4849 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4857 if (resolve_substring (ref) == FAILURE)
4862 /* Check constraints on part references. */
4864 current_part_dimension = 0;
4865 seen_part_dimension = 0;
4868 for (ref = expr->ref; ref; ref = ref->next)
4873 switch (ref->u.ar.type)
4876 /* Coarray scalar. */
4877 if (ref->u.ar.as->rank == 0)
4879 current_part_dimension = 0;
4884 current_part_dimension = 1;
4888 current_part_dimension = 0;
4892 gfc_internal_error ("resolve_ref(): Bad array reference");
4898 if (current_part_dimension || seen_part_dimension)
4901 if (ref->u.c.component->attr.pointer
4902 || ref->u.c.component->attr.proc_pointer)
4904 gfc_error ("Component to the right of a part reference "
4905 "with nonzero rank must not have the POINTER "
4906 "attribute at %L", &expr->where);
4909 else if (ref->u.c.component->attr.allocatable)
4911 gfc_error ("Component to the right of a part reference "
4912 "with nonzero rank must not have the ALLOCATABLE "
4913 "attribute at %L", &expr->where);
4925 if (((ref->type == REF_COMPONENT && n_components > 1)
4926 || ref->next == NULL)
4927 && current_part_dimension
4928 && seen_part_dimension)
4930 gfc_error ("Two or more part references with nonzero rank must "
4931 "not be specified at %L", &expr->where);
4935 if (ref->type == REF_COMPONENT)
4937 if (current_part_dimension)
4938 seen_part_dimension = 1;
4940 /* reset to make sure */
4941 current_part_dimension = 0;
4949 /* Given an expression, determine its shape. This is easier than it sounds.
4950 Leaves the shape array NULL if it is not possible to determine the shape. */
4953 expression_shape (gfc_expr *e)
4955 mpz_t array[GFC_MAX_DIMENSIONS];
4958 if (e->rank == 0 || e->shape != NULL)
4961 for (i = 0; i < e->rank; i++)
4962 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4965 e->shape = gfc_get_shape (e->rank);
4967 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4972 for (i--; i >= 0; i--)
4973 mpz_clear (array[i]);
4977 /* Given a variable expression node, compute the rank of the expression by
4978 examining the base symbol and any reference structures it may have. */
4981 expression_rank (gfc_expr *e)
4986 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4987 could lead to serious confusion... */
4988 gcc_assert (e->expr_type != EXPR_COMPCALL);
4992 if (e->expr_type == EXPR_ARRAY)
4994 /* Constructors can have a rank different from one via RESHAPE(). */
4996 if (e->symtree == NULL)
5002 e->rank = (e->symtree->n.sym->as == NULL)
5003 ? 0 : e->symtree->n.sym->as->rank;
5009 for (ref = e->ref; ref; ref = ref->next)
5011 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
5012 && ref->u.c.component->attr.function && !ref->next)
5013 rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
5015 if (ref->type != REF_ARRAY)
5018 if (ref->u.ar.type == AR_FULL)
5020 rank = ref->u.ar.as->rank;
5024 if (ref->u.ar.type == AR_SECTION)
5026 /* Figure out the rank of the section. */
5028 gfc_internal_error ("expression_rank(): Two array specs");
5030 for (i = 0; i < ref->u.ar.dimen; i++)
5031 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
5032 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
5042 expression_shape (e);
5046 /* Resolve a variable expression. */
5049 resolve_variable (gfc_expr *e)
5056 if (e->symtree == NULL)
5058 sym = e->symtree->n.sym;
5060 /* If this is an associate-name, it may be parsed with an array reference
5061 in error even though the target is scalar. Fail directly in this case. */
5062 if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
5065 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
5066 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
5068 /* On the other hand, the parser may not have known this is an array;
5069 in this case, we have to add a FULL reference. */
5070 if (sym->assoc && sym->attr.dimension && !e->ref)
5072 e->ref = gfc_get_ref ();
5073 e->ref->type = REF_ARRAY;
5074 e->ref->u.ar.type = AR_FULL;
5075 e->ref->u.ar.dimen = 0;
5078 if (e->ref && resolve_ref (e) == FAILURE)
5081 if (sym->attr.flavor == FL_PROCEDURE
5082 && (!sym->attr.function
5083 || (sym->attr.function && sym->result
5084 && sym->result->attr.proc_pointer
5085 && !sym->result->attr.function)))
5087 e->ts.type = BT_PROCEDURE;
5088 goto resolve_procedure;
5091 if (sym->ts.type != BT_UNKNOWN)
5092 gfc_variable_attr (e, &e->ts);
5095 /* Must be a simple variable reference. */
5096 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
5101 if (check_assumed_size_reference (sym, e))
5104 /* Deal with forward references to entries during resolve_code, to
5105 satisfy, at least partially, 12.5.2.5. */
5106 if (gfc_current_ns->entries
5107 && current_entry_id == sym->entry_id
5110 && cs_base->current->op != EXEC_ENTRY)
5112 gfc_entry_list *entry;
5113 gfc_formal_arglist *formal;
5117 /* If the symbol is a dummy... */
5118 if (sym->attr.dummy && sym->ns == gfc_current_ns)
5120 entry = gfc_current_ns->entries;
5123 /* ...test if the symbol is a parameter of previous entries. */
5124 for (; entry && entry->id <= current_entry_id; entry = entry->next)
5125 for (formal = entry->sym->formal; formal; formal = formal->next)
5127 if (formal->sym && sym->name == formal->sym->name)
5131 /* If it has not been seen as a dummy, this is an error. */
5134 if (specification_expr)
5135 gfc_error ("Variable '%s', used in a specification expression"
5136 ", is referenced at %L before the ENTRY statement "
5137 "in which it is a parameter",
5138 sym->name, &cs_base->current->loc);
5140 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5141 "statement in which it is a parameter",
5142 sym->name, &cs_base->current->loc);
5147 /* Now do the same check on the specification expressions. */
5148 specification_expr = 1;
5149 if (sym->ts.type == BT_CHARACTER
5150 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
5154 for (n = 0; n < sym->as->rank; n++)
5156 specification_expr = 1;
5157 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
5159 specification_expr = 1;
5160 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
5163 specification_expr = 0;
5166 /* Update the symbol's entry level. */
5167 sym->entry_id = current_entry_id + 1;
5170 /* If a symbol has been host_associated mark it. This is used latter,
5171 to identify if aliasing is possible via host association. */
5172 if (sym->attr.flavor == FL_VARIABLE
5173 && gfc_current_ns->parent
5174 && (gfc_current_ns->parent == sym->ns
5175 || (gfc_current_ns->parent->parent
5176 && gfc_current_ns->parent->parent == sym->ns)))
5177 sym->attr.host_assoc = 1;
5180 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
5183 /* F2008, C617 and C1229. */
5184 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5185 && gfc_is_coindexed (e))
5187 gfc_ref *ref, *ref2 = NULL;
5189 for (ref = e->ref; ref; ref = ref->next)
5191 if (ref->type == REF_COMPONENT)
5193 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5197 for ( ; ref; ref = ref->next)
5198 if (ref->type == REF_COMPONENT)
5201 /* Expression itself is not coindexed object. */
5202 if (ref && e->ts.type == BT_CLASS)
5204 gfc_error ("Polymorphic subobject of coindexed object at %L",
5209 /* Expression itself is coindexed object. */
5213 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5214 for ( ; c; c = c->next)
5215 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5217 gfc_error ("Coindexed object with polymorphic allocatable "
5218 "subcomponent at %L", &e->where);
5229 /* Checks to see that the correct symbol has been host associated.
5230 The only situation where this arises is that in which a twice
5231 contained function is parsed after the host association is made.
5232 Therefore, on detecting this, change the symbol in the expression
5233 and convert the array reference into an actual arglist if the old
5234 symbol is a variable. */
5236 check_host_association (gfc_expr *e)
5238 gfc_symbol *sym, *old_sym;
5242 gfc_actual_arglist *arg, *tail = NULL;
5243 bool retval = e->expr_type == EXPR_FUNCTION;
5245 /* If the expression is the result of substitution in
5246 interface.c(gfc_extend_expr) because there is no way in
5247 which the host association can be wrong. */
5248 if (e->symtree == NULL
5249 || e->symtree->n.sym == NULL
5250 || e->user_operator)
5253 old_sym = e->symtree->n.sym;
5255 if (gfc_current_ns->parent
5256 && old_sym->ns != gfc_current_ns)
5258 /* Use the 'USE' name so that renamed module symbols are
5259 correctly handled. */
5260 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5262 if (sym && old_sym != sym
5263 && sym->ts.type == old_sym->ts.type
5264 && sym->attr.flavor == FL_PROCEDURE
5265 && sym->attr.contained)
5267 /* Clear the shape, since it might not be valid. */
5268 gfc_free_shape (&e->shape, e->rank);
5270 /* Give the expression the right symtree! */
5271 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5272 gcc_assert (st != NULL);
5274 if (old_sym->attr.flavor == FL_PROCEDURE
5275 || e->expr_type == EXPR_FUNCTION)
5277 /* Original was function so point to the new symbol, since
5278 the actual argument list is already attached to the
5280 e->value.function.esym = NULL;
5285 /* Original was variable so convert array references into
5286 an actual arglist. This does not need any checking now
5287 since resolve_function will take care of it. */
5288 e->value.function.actual = NULL;
5289 e->expr_type = EXPR_FUNCTION;
5292 /* Ambiguity will not arise if the array reference is not
5293 the last reference. */
5294 for (ref = e->ref; ref; ref = ref->next)
5295 if (ref->type == REF_ARRAY && ref->next == NULL)
5298 gcc_assert (ref->type == REF_ARRAY);
5300 /* Grab the start expressions from the array ref and
5301 copy them into actual arguments. */
5302 for (n = 0; n < ref->u.ar.dimen; n++)
5304 arg = gfc_get_actual_arglist ();
5305 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5306 if (e->value.function.actual == NULL)
5307 tail = e->value.function.actual = arg;
5315 /* Dump the reference list and set the rank. */
5316 gfc_free_ref_list (e->ref);
5318 e->rank = sym->as ? sym->as->rank : 0;
5321 gfc_resolve_expr (e);
5325 /* This might have changed! */
5326 return e->expr_type == EXPR_FUNCTION;
5331 gfc_resolve_character_operator (gfc_expr *e)
5333 gfc_expr *op1 = e->value.op.op1;
5334 gfc_expr *op2 = e->value.op.op2;
5335 gfc_expr *e1 = NULL;
5336 gfc_expr *e2 = NULL;
5338 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5340 if (op1->ts.u.cl && op1->ts.u.cl->length)
5341 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5342 else if (op1->expr_type == EXPR_CONSTANT)
5343 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5344 op1->value.character.length);
5346 if (op2->ts.u.cl && op2->ts.u.cl->length)
5347 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5348 else if (op2->expr_type == EXPR_CONSTANT)
5349 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5350 op2->value.character.length);
5352 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5357 e->ts.u.cl->length = gfc_add (e1, e2);
5358 e->ts.u.cl->length->ts.type = BT_INTEGER;
5359 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5360 gfc_simplify_expr (e->ts.u.cl->length, 0);
5361 gfc_resolve_expr (e->ts.u.cl->length);
5367 /* Ensure that an character expression has a charlen and, if possible, a
5368 length expression. */
5371 fixup_charlen (gfc_expr *e)
5373 /* The cases fall through so that changes in expression type and the need
5374 for multiple fixes are picked up. In all circumstances, a charlen should
5375 be available for the middle end to hang a backend_decl on. */
5376 switch (e->expr_type)
5379 gfc_resolve_character_operator (e);
5382 if (e->expr_type == EXPR_ARRAY)
5383 gfc_resolve_character_array_constructor (e);
5385 case EXPR_SUBSTRING:
5386 if (!e->ts.u.cl && e->ref)
5387 gfc_resolve_substring_charlen (e);
5391 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5398 /* Update an actual argument to include the passed-object for type-bound
5399 procedures at the right position. */
5401 static gfc_actual_arglist*
5402 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5405 gcc_assert (argpos > 0);
5409 gfc_actual_arglist* result;
5411 result = gfc_get_actual_arglist ();
5415 result->name = name;
5421 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5423 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5428 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5431 extract_compcall_passed_object (gfc_expr* e)
5435 gcc_assert (e->expr_type == EXPR_COMPCALL);
5437 if (e->value.compcall.base_object)
5438 po = gfc_copy_expr (e->value.compcall.base_object);
5441 po = gfc_get_expr ();
5442 po->expr_type = EXPR_VARIABLE;
5443 po->symtree = e->symtree;
5444 po->ref = gfc_copy_ref (e->ref);
5445 po->where = e->where;
5448 if (gfc_resolve_expr (po) == FAILURE)
5455 /* Update the arglist of an EXPR_COMPCALL expression to include the
5459 update_compcall_arglist (gfc_expr* e)
5462 gfc_typebound_proc* tbp;
5464 tbp = e->value.compcall.tbp;
5469 po = extract_compcall_passed_object (e);
5473 if (tbp->nopass || e->value.compcall.ignore_pass)
5479 gcc_assert (tbp->pass_arg_num > 0);
5480 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5488 /* Extract the passed object from a PPC call (a copy of it). */
5491 extract_ppc_passed_object (gfc_expr *e)
5496 po = gfc_get_expr ();
5497 po->expr_type = EXPR_VARIABLE;
5498 po->symtree = e->symtree;
5499 po->ref = gfc_copy_ref (e->ref);
5500 po->where = e->where;
5502 /* Remove PPC reference. */
5504 while ((*ref)->next)
5505 ref = &(*ref)->next;
5506 gfc_free_ref_list (*ref);
5509 if (gfc_resolve_expr (po) == FAILURE)
5516 /* Update the actual arglist of a procedure pointer component to include the
5520 update_ppc_arglist (gfc_expr* e)
5524 gfc_typebound_proc* tb;
5526 if (!gfc_is_proc_ptr_comp (e, &ppc))
5533 else if (tb->nopass)
5536 po = extract_ppc_passed_object (e);
5543 gfc_error ("Passed-object at %L must be scalar", &e->where);
5548 if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
5550 gfc_error ("Base object for procedure-pointer component call at %L is of"
5551 " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name);
5555 gcc_assert (tb->pass_arg_num > 0);
5556 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5564 /* Check that the object a TBP is called on is valid, i.e. it must not be
5565 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5568 check_typebound_baseobject (gfc_expr* e)
5571 gfc_try return_value = FAILURE;
5573 base = extract_compcall_passed_object (e);
5577 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5580 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5582 gfc_error ("Base object for type-bound procedure call at %L is of"
5583 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5587 /* F08:C1230. If the procedure called is NOPASS,
5588 the base object must be scalar. */
5589 if (e->value.compcall.tbp->nopass && base->rank > 0)
5591 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5592 " be scalar", &e->where);
5596 return_value = SUCCESS;
5599 gfc_free_expr (base);
5600 return return_value;
5604 /* Resolve a call to a type-bound procedure, either function or subroutine,
5605 statically from the data in an EXPR_COMPCALL expression. The adapted
5606 arglist and the target-procedure symtree are returned. */
5609 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5610 gfc_actual_arglist** actual)
5612 gcc_assert (e->expr_type == EXPR_COMPCALL);
5613 gcc_assert (!e->value.compcall.tbp->is_generic);
5615 /* Update the actual arglist for PASS. */
5616 if (update_compcall_arglist (e) == FAILURE)
5619 *actual = e->value.compcall.actual;
5620 *target = e->value.compcall.tbp->u.specific;
5622 gfc_free_ref_list (e->ref);
5624 e->value.compcall.actual = NULL;
5626 /* If we find a deferred typebound procedure, check for derived types
5627 that an over-riding typebound procedure has not been missed. */
5628 if (e->value.compcall.tbp->deferred
5629 && e->value.compcall.name
5630 && !e->value.compcall.tbp->non_overridable
5631 && e->value.compcall.base_object
5632 && e->value.compcall.base_object->ts.type == BT_DERIVED)
5635 gfc_symbol *derived;
5637 /* Use the derived type of the base_object. */
5638 derived = e->value.compcall.base_object->ts.u.derived;
5641 /* If necessary, go throught the inheritance chain. */
5642 while (!st && derived)
5644 /* Look for the typebound procedure 'name'. */
5645 if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
5646 st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
5647 e->value.compcall.name);
5649 derived = gfc_get_derived_super_type (derived);
5652 /* Now find the specific name in the derived type namespace. */
5653 if (st && st->n.tb && st->n.tb->u.specific)
5654 gfc_find_sym_tree (st->n.tb->u.specific->name,
5655 derived->ns, 1, &st);
5663 /* Get the ultimate declared type from an expression. In addition,
5664 return the last class/derived type reference and the copy of the
5665 reference list. If check_types is set true, derived types are
5666 identified as well as class references. */
5668 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5669 gfc_expr *e, bool check_types)
5671 gfc_symbol *declared;
5678 *new_ref = gfc_copy_ref (e->ref);
5680 for (ref = e->ref; ref; ref = ref->next)
5682 if (ref->type != REF_COMPONENT)
5685 if ((ref->u.c.component->ts.type == BT_CLASS
5686 || (check_types && ref->u.c.component->ts.type == BT_DERIVED))
5687 && ref->u.c.component->attr.flavor != FL_PROCEDURE)
5689 declared = ref->u.c.component->ts.u.derived;
5695 if (declared == NULL)
5696 declared = e->symtree->n.sym->ts.u.derived;
5702 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5703 which of the specific bindings (if any) matches the arglist and transform
5704 the expression into a call of that binding. */
5707 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5709 gfc_typebound_proc* genproc;
5710 const char* genname;
5712 gfc_symbol *derived;
5714 gcc_assert (e->expr_type == EXPR_COMPCALL);
5715 genname = e->value.compcall.name;
5716 genproc = e->value.compcall.tbp;
5718 if (!genproc->is_generic)
5721 /* Try the bindings on this type and in the inheritance hierarchy. */
5722 for (; genproc; genproc = genproc->overridden)
5726 gcc_assert (genproc->is_generic);
5727 for (g = genproc->u.generic; g; g = g->next)
5730 gfc_actual_arglist* args;
5733 gcc_assert (g->specific);
5735 if (g->specific->error)
5738 target = g->specific->u.specific->n.sym;
5740 /* Get the right arglist by handling PASS/NOPASS. */
5741 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5742 if (!g->specific->nopass)
5745 po = extract_compcall_passed_object (e);
5749 gcc_assert (g->specific->pass_arg_num > 0);
5750 gcc_assert (!g->specific->error);
5751 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5752 g->specific->pass_arg);
5754 resolve_actual_arglist (args, target->attr.proc,
5755 is_external_proc (target) && !target->formal);
5757 /* Check if this arglist matches the formal. */
5758 matches = gfc_arglist_matches_symbol (&args, target);
5760 /* Clean up and break out of the loop if we've found it. */
5761 gfc_free_actual_arglist (args);
5764 e->value.compcall.tbp = g->specific;
5765 genname = g->specific_st->name;
5766 /* Pass along the name for CLASS methods, where the vtab
5767 procedure pointer component has to be referenced. */
5775 /* Nothing matching found! */
5776 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5777 " '%s' at %L", genname, &e->where);
5781 /* Make sure that we have the right specific instance for the name. */
5782 derived = get_declared_from_expr (NULL, NULL, e, true);
5784 st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
5786 e->value.compcall.tbp = st->n.tb;
5792 /* Resolve a call to a type-bound subroutine. */
5795 resolve_typebound_call (gfc_code* c, const char **name)
5797 gfc_actual_arglist* newactual;
5798 gfc_symtree* target;
5800 /* Check that's really a SUBROUTINE. */
5801 if (!c->expr1->value.compcall.tbp->subroutine)
5803 gfc_error ("'%s' at %L should be a SUBROUTINE",
5804 c->expr1->value.compcall.name, &c->loc);
5808 if (check_typebound_baseobject (c->expr1) == FAILURE)
5811 /* Pass along the name for CLASS methods, where the vtab
5812 procedure pointer component has to be referenced. */
5814 *name = c->expr1->value.compcall.name;
5816 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5819 /* Transform into an ordinary EXEC_CALL for now. */
5821 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5824 c->ext.actual = newactual;
5825 c->symtree = target;
5826 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5828 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5830 gfc_free_expr (c->expr1);
5831 c->expr1 = gfc_get_expr ();
5832 c->expr1->expr_type = EXPR_FUNCTION;
5833 c->expr1->symtree = target;
5834 c->expr1->where = c->loc;
5836 return resolve_call (c);
5840 /* Resolve a component-call expression. */
5842 resolve_compcall (gfc_expr* e, const char **name)
5844 gfc_actual_arglist* newactual;
5845 gfc_symtree* target;
5847 /* Check that's really a FUNCTION. */
5848 if (!e->value.compcall.tbp->function)
5850 gfc_error ("'%s' at %L should be a FUNCTION",
5851 e->value.compcall.name, &e->where);
5855 /* These must not be assign-calls! */
5856 gcc_assert (!e->value.compcall.assign);
5858 if (check_typebound_baseobject (e) == FAILURE)
5861 /* Pass along the name for CLASS methods, where the vtab
5862 procedure pointer component has to be referenced. */
5864 *name = e->value.compcall.name;
5866 if (resolve_typebound_generic_call (e, name) == FAILURE)
5868 gcc_assert (!e->value.compcall.tbp->is_generic);
5870 /* Take the rank from the function's symbol. */
5871 if (e->value.compcall.tbp->u.specific->n.sym->as)
5872 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5874 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5875 arglist to the TBP's binding target. */
5877 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5880 e->value.function.actual = newactual;
5881 e->value.function.name = NULL;
5882 e->value.function.esym = target->n.sym;
5883 e->value.function.isym = NULL;
5884 e->symtree = target;
5885 e->ts = target->n.sym->ts;
5886 e->expr_type = EXPR_FUNCTION;
5888 /* Resolution is not necessary if this is a class subroutine; this
5889 function only has to identify the specific proc. Resolution of
5890 the call will be done next in resolve_typebound_call. */
5891 return gfc_resolve_expr (e);
5896 /* Resolve a typebound function, or 'method'. First separate all
5897 the non-CLASS references by calling resolve_compcall directly. */
5900 resolve_typebound_function (gfc_expr* e)
5902 gfc_symbol *declared;
5914 /* Deal with typebound operators for CLASS objects. */
5915 expr = e->value.compcall.base_object;
5916 overridable = !e->value.compcall.tbp->non_overridable;
5917 if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
5919 /* If the base_object is not a variable, the corresponding actual
5920 argument expression must be stored in e->base_expression so
5921 that the corresponding tree temporary can be used as the base
5922 object in gfc_conv_procedure_call. */
5923 if (expr->expr_type != EXPR_VARIABLE)
5925 gfc_actual_arglist *args;
5927 for (args= e->value.function.actual; args; args = args->next)
5929 if (expr == args->expr)
5934 /* Since the typebound operators are generic, we have to ensure
5935 that any delays in resolution are corrected and that the vtab
5938 declared = ts.u.derived;
5939 c = gfc_find_component (declared, "_vptr", true, true);
5940 if (c->ts.u.derived == NULL)
5941 c->ts.u.derived = gfc_find_derived_vtab (declared);
5943 if (resolve_compcall (e, &name) == FAILURE)
5946 /* Use the generic name if it is there. */
5947 name = name ? name : e->value.function.esym->name;
5948 e->symtree = expr->symtree;
5949 e->ref = gfc_copy_ref (expr->ref);
5950 get_declared_from_expr (&class_ref, NULL, e, false);
5952 /* Trim away the extraneous references that emerge from nested
5953 use of interface.c (extend_expr). */
5954 if (class_ref && class_ref->next)
5956 gfc_free_ref_list (class_ref->next);
5957 class_ref->next = NULL;
5959 else if (e->ref && !class_ref)
5961 gfc_free_ref_list (e->ref);
5965 gfc_add_vptr_component (e);
5966 gfc_add_component_ref (e, name);
5967 e->value.function.esym = NULL;
5968 if (expr->expr_type != EXPR_VARIABLE)
5969 e->base_expr = expr;
5974 return resolve_compcall (e, NULL);
5976 if (resolve_ref (e) == FAILURE)
5979 /* Get the CLASS declared type. */
5980 declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
5982 /* Weed out cases of the ultimate component being a derived type. */
5983 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5984 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5986 gfc_free_ref_list (new_ref);
5987 return resolve_compcall (e, NULL);
5990 c = gfc_find_component (declared, "_data", true, true);
5991 declared = c->ts.u.derived;
5993 /* Treat the call as if it is a typebound procedure, in order to roll
5994 out the correct name for the specific function. */
5995 if (resolve_compcall (e, &name) == FAILURE)
6001 /* Convert the expression to a procedure pointer component call. */
6002 e->value.function.esym = NULL;
6008 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6009 gfc_add_vptr_component (e);
6010 gfc_add_component_ref (e, name);
6012 /* Recover the typespec for the expression. This is really only
6013 necessary for generic procedures, where the additional call
6014 to gfc_add_component_ref seems to throw the collection of the
6015 correct typespec. */
6022 /* Resolve a typebound subroutine, or 'method'. First separate all
6023 the non-CLASS references by calling resolve_typebound_call
6027 resolve_typebound_subroutine (gfc_code *code)
6029 gfc_symbol *declared;
6039 st = code->expr1->symtree;
6041 /* Deal with typebound operators for CLASS objects. */
6042 expr = code->expr1->value.compcall.base_object;
6043 overridable = !code->expr1->value.compcall.tbp->non_overridable;
6044 if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
6046 /* If the base_object is not a variable, the corresponding actual
6047 argument expression must be stored in e->base_expression so
6048 that the corresponding tree temporary can be used as the base
6049 object in gfc_conv_procedure_call. */
6050 if (expr->expr_type != EXPR_VARIABLE)
6052 gfc_actual_arglist *args;
6054 args= code->expr1->value.function.actual;
6055 for (; args; args = args->next)
6056 if (expr == args->expr)
6060 /* Since the typebound operators are generic, we have to ensure
6061 that any delays in resolution are corrected and that the vtab
6063 declared = expr->ts.u.derived;
6064 c = gfc_find_component (declared, "_vptr", true, true);
6065 if (c->ts.u.derived == NULL)
6066 c->ts.u.derived = gfc_find_derived_vtab (declared);
6068 if (resolve_typebound_call (code, &name) == FAILURE)
6071 /* Use the generic name if it is there. */
6072 name = name ? name : code->expr1->value.function.esym->name;
6073 code->expr1->symtree = expr->symtree;
6074 code->expr1->ref = gfc_copy_ref (expr->ref);
6076 /* Trim away the extraneous references that emerge from nested
6077 use of interface.c (extend_expr). */
6078 get_declared_from_expr (&class_ref, NULL, code->expr1, false);
6079 if (class_ref && class_ref->next)
6081 gfc_free_ref_list (class_ref->next);
6082 class_ref->next = NULL;
6084 else if (code->expr1->ref && !class_ref)
6086 gfc_free_ref_list (code->expr1->ref);
6087 code->expr1->ref = NULL;
6090 /* Now use the procedure in the vtable. */
6091 gfc_add_vptr_component (code->expr1);
6092 gfc_add_component_ref (code->expr1, name);
6093 code->expr1->value.function.esym = NULL;
6094 if (expr->expr_type != EXPR_VARIABLE)
6095 code->expr1->base_expr = expr;
6100 return resolve_typebound_call (code, NULL);
6102 if (resolve_ref (code->expr1) == FAILURE)
6105 /* Get the CLASS declared type. */
6106 get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
6108 /* Weed out cases of the ultimate component being a derived type. */
6109 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
6110 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
6112 gfc_free_ref_list (new_ref);
6113 return resolve_typebound_call (code, NULL);
6116 if (resolve_typebound_call (code, &name) == FAILURE)
6118 ts = code->expr1->ts;
6122 /* Convert the expression to a procedure pointer component call. */
6123 code->expr1->value.function.esym = NULL;
6124 code->expr1->symtree = st;
6127 code->expr1->ref = new_ref;
6129 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6130 gfc_add_vptr_component (code->expr1);
6131 gfc_add_component_ref (code->expr1, name);
6133 /* Recover the typespec for the expression. This is really only
6134 necessary for generic procedures, where the additional call
6135 to gfc_add_component_ref seems to throw the collection of the
6136 correct typespec. */
6137 code->expr1->ts = ts;
6144 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6147 resolve_ppc_call (gfc_code* c)
6149 gfc_component *comp;
6152 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
6155 c->resolved_sym = c->expr1->symtree->n.sym;
6156 c->expr1->expr_type = EXPR_VARIABLE;
6158 if (!comp->attr.subroutine)
6159 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
6161 if (resolve_ref (c->expr1) == FAILURE)
6164 if (update_ppc_arglist (c->expr1) == FAILURE)
6167 c->ext.actual = c->expr1->value.compcall.actual;
6169 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
6170 comp->formal == NULL) == FAILURE)
6173 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
6179 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6182 resolve_expr_ppc (gfc_expr* e)
6184 gfc_component *comp;
6187 b = gfc_is_proc_ptr_comp (e, &comp);
6190 /* Convert to EXPR_FUNCTION. */
6191 e->expr_type = EXPR_FUNCTION;
6192 e->value.function.isym = NULL;
6193 e->value.function.actual = e->value.compcall.actual;
6195 if (comp->as != NULL)
6196 e->rank = comp->as->rank;
6198 if (!comp->attr.function)
6199 gfc_add_function (&comp->attr, comp->name, &e->where);
6201 if (resolve_ref (e) == FAILURE)
6204 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
6205 comp->formal == NULL) == FAILURE)
6208 if (update_ppc_arglist (e) == FAILURE)
6211 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
6218 gfc_is_expandable_expr (gfc_expr *e)
6220 gfc_constructor *con;
6222 if (e->expr_type == EXPR_ARRAY)
6224 /* Traverse the constructor looking for variables that are flavor
6225 parameter. Parameters must be expanded since they are fully used at
6227 con = gfc_constructor_first (e->value.constructor);
6228 for (; con; con = gfc_constructor_next (con))
6230 if (con->expr->expr_type == EXPR_VARIABLE
6231 && con->expr->symtree
6232 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6233 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
6235 if (con->expr->expr_type == EXPR_ARRAY
6236 && gfc_is_expandable_expr (con->expr))
6244 /* Resolve an expression. That is, make sure that types of operands agree
6245 with their operators, intrinsic operators are converted to function calls
6246 for overloaded types and unresolved function references are resolved. */
6249 gfc_resolve_expr (gfc_expr *e)
6257 /* inquiry_argument only applies to variables. */
6258 inquiry_save = inquiry_argument;
6259 if (e->expr_type != EXPR_VARIABLE)
6260 inquiry_argument = false;
6262 switch (e->expr_type)
6265 t = resolve_operator (e);
6271 if (check_host_association (e))
6272 t = resolve_function (e);
6275 t = resolve_variable (e);
6277 expression_rank (e);
6280 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6281 && e->ref->type != REF_SUBSTRING)
6282 gfc_resolve_substring_charlen (e);
6287 t = resolve_typebound_function (e);
6290 case EXPR_SUBSTRING:
6291 t = resolve_ref (e);
6300 t = resolve_expr_ppc (e);
6305 if (resolve_ref (e) == FAILURE)
6308 t = gfc_resolve_array_constructor (e);
6309 /* Also try to expand a constructor. */
6312 expression_rank (e);
6313 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6314 gfc_expand_constructor (e, false);
6317 /* This provides the opportunity for the length of constructors with
6318 character valued function elements to propagate the string length
6319 to the expression. */
6320 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6322 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6323 here rather then add a duplicate test for it above. */
6324 gfc_expand_constructor (e, false);
6325 t = gfc_resolve_character_array_constructor (e);
6330 case EXPR_STRUCTURE:
6331 t = resolve_ref (e);
6335 t = resolve_structure_cons (e, 0);
6339 t = gfc_simplify_expr (e, 0);
6343 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6346 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6349 inquiry_argument = inquiry_save;
6355 /* Resolve an expression from an iterator. They must be scalar and have
6356 INTEGER or (optionally) REAL type. */
6359 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6360 const char *name_msgid)
6362 if (gfc_resolve_expr (expr) == FAILURE)
6365 if (expr->rank != 0)
6367 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6371 if (expr->ts.type != BT_INTEGER)
6373 if (expr->ts.type == BT_REAL)
6376 return gfc_notify_std (GFC_STD_F95_DEL,
6377 "Deleted feature: %s at %L must be integer",
6378 _(name_msgid), &expr->where);
6381 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6388 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6396 /* Resolve the expressions in an iterator structure. If REAL_OK is
6397 false allow only INTEGER type iterators, otherwise allow REAL types. */
6400 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6402 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6406 if (gfc_check_vardef_context (iter->var, false, false, _("iterator variable"))
6410 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6411 "Start expression in DO loop") == FAILURE)
6414 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6415 "End expression in DO loop") == FAILURE)
6418 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6419 "Step expression in DO loop") == FAILURE)
6422 if (iter->step->expr_type == EXPR_CONSTANT)
6424 if ((iter->step->ts.type == BT_INTEGER
6425 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6426 || (iter->step->ts.type == BT_REAL
6427 && mpfr_sgn (iter->step->value.real) == 0))
6429 gfc_error ("Step expression in DO loop at %L cannot be zero",
6430 &iter->step->where);
6435 /* Convert start, end, and step to the same type as var. */
6436 if (iter->start->ts.kind != iter->var->ts.kind
6437 || iter->start->ts.type != iter->var->ts.type)
6438 gfc_convert_type (iter->start, &iter->var->ts, 2);
6440 if (iter->end->ts.kind != iter->var->ts.kind
6441 || iter->end->ts.type != iter->var->ts.type)
6442 gfc_convert_type (iter->end, &iter->var->ts, 2);
6444 if (iter->step->ts.kind != iter->var->ts.kind
6445 || iter->step->ts.type != iter->var->ts.type)
6446 gfc_convert_type (iter->step, &iter->var->ts, 2);
6448 if (iter->start->expr_type == EXPR_CONSTANT
6449 && iter->end->expr_type == EXPR_CONSTANT
6450 && iter->step->expr_type == EXPR_CONSTANT)
6453 if (iter->start->ts.type == BT_INTEGER)
6455 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6456 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6460 sgn = mpfr_sgn (iter->step->value.real);
6461 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6463 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6464 gfc_warning ("DO loop at %L will be executed zero times",
6465 &iter->step->where);
6472 /* Traversal function for find_forall_index. f == 2 signals that
6473 that variable itself is not to be checked - only the references. */
6476 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6478 if (expr->expr_type != EXPR_VARIABLE)
6481 /* A scalar assignment */
6482 if (!expr->ref || *f == 1)
6484 if (expr->symtree->n.sym == sym)
6496 /* Check whether the FORALL index appears in the expression or not.
6497 Returns SUCCESS if SYM is found in EXPR. */
6500 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6502 if (gfc_traverse_expr (expr, sym, forall_index, f))
6509 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6510 to be a scalar INTEGER variable. The subscripts and stride are scalar
6511 INTEGERs, and if stride is a constant it must be nonzero.
6512 Furthermore "A subscript or stride in a forall-triplet-spec shall
6513 not contain a reference to any index-name in the
6514 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6517 resolve_forall_iterators (gfc_forall_iterator *it)
6519 gfc_forall_iterator *iter, *iter2;
6521 for (iter = it; iter; iter = iter->next)
6523 if (gfc_resolve_expr (iter->var) == SUCCESS
6524 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6525 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6528 if (gfc_resolve_expr (iter->start) == SUCCESS
6529 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6530 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6531 &iter->start->where);
6532 if (iter->var->ts.kind != iter->start->ts.kind)
6533 gfc_convert_type (iter->start, &iter->var->ts, 1);
6535 if (gfc_resolve_expr (iter->end) == SUCCESS
6536 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6537 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6539 if (iter->var->ts.kind != iter->end->ts.kind)
6540 gfc_convert_type (iter->end, &iter->var->ts, 1);
6542 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6544 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6545 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6546 &iter->stride->where, "INTEGER");
6548 if (iter->stride->expr_type == EXPR_CONSTANT
6549 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6550 gfc_error ("FORALL stride expression at %L cannot be zero",
6551 &iter->stride->where);
6553 if (iter->var->ts.kind != iter->stride->ts.kind)
6554 gfc_convert_type (iter->stride, &iter->var->ts, 1);
6557 for (iter = it; iter; iter = iter->next)
6558 for (iter2 = iter; iter2; iter2 = iter2->next)
6560 if (find_forall_index (iter2->start,
6561 iter->var->symtree->n.sym, 0) == SUCCESS
6562 || find_forall_index (iter2->end,
6563 iter->var->symtree->n.sym, 0) == SUCCESS
6564 || find_forall_index (iter2->stride,
6565 iter->var->symtree->n.sym, 0) == SUCCESS)
6566 gfc_error ("FORALL index '%s' may not appear in triplet "
6567 "specification at %L", iter->var->symtree->name,
6568 &iter2->start->where);
6573 /* Given a pointer to a symbol that is a derived type, see if it's
6574 inaccessible, i.e. if it's defined in another module and the components are
6575 PRIVATE. The search is recursive if necessary. Returns zero if no
6576 inaccessible components are found, nonzero otherwise. */
6579 derived_inaccessible (gfc_symbol *sym)
6583 if (sym->attr.use_assoc && sym->attr.private_comp)
6586 for (c = sym->components; c; c = c->next)
6588 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6596 /* Resolve the argument of a deallocate expression. The expression must be
6597 a pointer or a full array. */
6600 resolve_deallocate_expr (gfc_expr *e)
6602 symbol_attribute attr;
6603 int allocatable, pointer;
6608 if (gfc_resolve_expr (e) == FAILURE)
6611 if (e->expr_type != EXPR_VARIABLE)
6614 sym = e->symtree->n.sym;
6616 if (sym->ts.type == BT_CLASS)
6618 allocatable = CLASS_DATA (sym)->attr.allocatable;
6619 pointer = CLASS_DATA (sym)->attr.class_pointer;
6623 allocatable = sym->attr.allocatable;
6624 pointer = sym->attr.pointer;
6626 for (ref = e->ref; ref; ref = ref->next)
6631 if (ref->u.ar.type != AR_FULL
6632 && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
6633 && ref->u.ar.codimen && gfc_ref_this_image (ref)))
6638 c = ref->u.c.component;
6639 if (c->ts.type == BT_CLASS)
6641 allocatable = CLASS_DATA (c)->attr.allocatable;
6642 pointer = CLASS_DATA (c)->attr.class_pointer;
6646 allocatable = c->attr.allocatable;
6647 pointer = c->attr.pointer;
6657 attr = gfc_expr_attr (e);
6659 if (allocatable == 0 && attr.pointer == 0)
6662 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6668 if (gfc_is_coindexed (e))
6670 gfc_error ("Coindexed allocatable object at %L", &e->where);
6675 && gfc_check_vardef_context (e, true, true, _("DEALLOCATE object"))
6678 if (gfc_check_vardef_context (e, false, true, _("DEALLOCATE object"))
6686 /* Returns true if the expression e contains a reference to the symbol sym. */
6688 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6690 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6697 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6699 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6703 /* Given the expression node e for an allocatable/pointer of derived type to be
6704 allocated, get the expression node to be initialized afterwards (needed for
6705 derived types with default initializers, and derived types with allocatable
6706 components that need nullification.) */
6709 gfc_expr_to_initialize (gfc_expr *e)
6715 result = gfc_copy_expr (e);
6717 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6718 for (ref = result->ref; ref; ref = ref->next)
6719 if (ref->type == REF_ARRAY && ref->next == NULL)
6721 ref->u.ar.type = AR_FULL;
6723 for (i = 0; i < ref->u.ar.dimen; i++)
6724 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6729 gfc_free_shape (&result->shape, result->rank);
6731 /* Recalculate rank, shape, etc. */
6732 gfc_resolve_expr (result);
6737 /* If the last ref of an expression is an array ref, return a copy of the
6738 expression with that one removed. Otherwise, a copy of the original
6739 expression. This is used for allocate-expressions and pointer assignment
6740 LHS, where there may be an array specification that needs to be stripped
6741 off when using gfc_check_vardef_context. */
6744 remove_last_array_ref (gfc_expr* e)
6749 e2 = gfc_copy_expr (e);
6750 for (r = &e2->ref; *r; r = &(*r)->next)
6751 if ((*r)->type == REF_ARRAY && !(*r)->next)
6753 gfc_free_ref_list (*r);
6762 /* Used in resolve_allocate_expr to check that a allocation-object and
6763 a source-expr are conformable. This does not catch all possible
6764 cases; in particular a runtime checking is needed. */
6767 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6770 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6772 /* First compare rank. */
6773 if (tail && e1->rank != tail->u.ar.as->rank)
6775 gfc_error ("Source-expr at %L must be scalar or have the "
6776 "same rank as the allocate-object at %L",
6777 &e1->where, &e2->where);
6788 for (i = 0; i < e1->rank; i++)
6790 if (tail->u.ar.end[i])
6792 mpz_set (s, tail->u.ar.end[i]->value.integer);
6793 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6794 mpz_add_ui (s, s, 1);
6798 mpz_set (s, tail->u.ar.start[i]->value.integer);
6801 if (mpz_cmp (e1->shape[i], s) != 0)
6803 gfc_error ("Source-expr at %L and allocate-object at %L must "
6804 "have the same shape", &e1->where, &e2->where);
6817 /* Resolve the expression in an ALLOCATE statement, doing the additional
6818 checks to see whether the expression is OK or not. The expression must
6819 have a trailing array reference that gives the size of the array. */
6822 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6824 int i, pointer, allocatable, dimension, is_abstract;
6827 symbol_attribute attr;
6828 gfc_ref *ref, *ref2;
6831 gfc_symbol *sym = NULL;
6836 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6837 checking of coarrays. */
6838 for (ref = e->ref; ref; ref = ref->next)
6839 if (ref->next == NULL)
6842 if (ref && ref->type == REF_ARRAY)
6843 ref->u.ar.in_allocate = true;
6845 if (gfc_resolve_expr (e) == FAILURE)
6848 /* Make sure the expression is allocatable or a pointer. If it is
6849 pointer, the next-to-last reference must be a pointer. */
6853 sym = e->symtree->n.sym;
6855 /* Check whether ultimate component is abstract and CLASS. */
6858 if (e->expr_type != EXPR_VARIABLE)
6861 attr = gfc_expr_attr (e);
6862 pointer = attr.pointer;
6863 dimension = attr.dimension;
6864 codimension = attr.codimension;
6868 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
6870 allocatable = CLASS_DATA (sym)->attr.allocatable;
6871 pointer = CLASS_DATA (sym)->attr.class_pointer;
6872 dimension = CLASS_DATA (sym)->attr.dimension;
6873 codimension = CLASS_DATA (sym)->attr.codimension;
6874 is_abstract = CLASS_DATA (sym)->attr.abstract;
6878 allocatable = sym->attr.allocatable;
6879 pointer = sym->attr.pointer;
6880 dimension = sym->attr.dimension;
6881 codimension = sym->attr.codimension;
6886 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6891 if (ref->u.ar.codimen > 0)
6894 for (n = ref->u.ar.dimen;
6895 n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
6896 if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
6903 if (ref->next != NULL)
6911 gfc_error ("Coindexed allocatable object at %L",
6916 c = ref->u.c.component;
6917 if (c->ts.type == BT_CLASS)
6919 allocatable = CLASS_DATA (c)->attr.allocatable;
6920 pointer = CLASS_DATA (c)->attr.class_pointer;
6921 dimension = CLASS_DATA (c)->attr.dimension;
6922 codimension = CLASS_DATA (c)->attr.codimension;
6923 is_abstract = CLASS_DATA (c)->attr.abstract;
6927 allocatable = c->attr.allocatable;
6928 pointer = c->attr.pointer;
6929 dimension = c->attr.dimension;
6930 codimension = c->attr.codimension;
6931 is_abstract = c->attr.abstract;
6943 if (allocatable == 0 && pointer == 0)
6945 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6950 /* Some checks for the SOURCE tag. */
6953 /* Check F03:C631. */
6954 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6956 gfc_error ("Type of entity at %L is type incompatible with "
6957 "source-expr at %L", &e->where, &code->expr3->where);
6961 /* Check F03:C632 and restriction following Note 6.18. */
6962 if (code->expr3->rank > 0
6963 && conformable_arrays (code->expr3, e) == FAILURE)
6966 /* Check F03:C633. */
6967 if (code->expr3->ts.kind != e->ts.kind)
6969 gfc_error ("The allocate-object at %L and the source-expr at %L "
6970 "shall have the same kind type parameter",
6971 &e->where, &code->expr3->where);
6975 /* Check F2008, C642. */
6976 if (code->expr3->ts.type == BT_DERIVED
6977 && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
6978 || (code->expr3->ts.u.derived->from_intmod
6979 == INTMOD_ISO_FORTRAN_ENV
6980 && code->expr3->ts.u.derived->intmod_sym_id
6981 == ISOFORTRAN_LOCK_TYPE)))
6983 gfc_error ("The source-expr at %L shall neither be of type "
6984 "LOCK_TYPE nor have a LOCK_TYPE component if "
6985 "allocate-object at %L is a coarray",
6986 &code->expr3->where, &e->where);
6991 /* Check F08:C629. */
6992 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
6995 gcc_assert (e->ts.type == BT_CLASS);
6996 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6997 "type-spec or source-expr", sym->name, &e->where);
7001 if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred)
7003 int cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
7004 code->ext.alloc.ts.u.cl->length);
7005 if (cmp == 1 || cmp == -1 || cmp == -3)
7007 gfc_error ("Allocating %s at %L with type-spec requires the same "
7008 "character-length parameter as in the declaration",
7009 sym->name, &e->where);
7014 /* In the variable definition context checks, gfc_expr_attr is used
7015 on the expression. This is fooled by the array specification
7016 present in e, thus we have to eliminate that one temporarily. */
7017 e2 = remove_last_array_ref (e);
7019 if (t == SUCCESS && pointer)
7020 t = gfc_check_vardef_context (e2, true, true, _("ALLOCATE object"));
7022 t = gfc_check_vardef_context (e2, false, true, _("ALLOCATE object"));
7027 if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
7028 && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
7030 /* For class arrays, the initialization with SOURCE is done
7031 using _copy and trans_call. It is convenient to exploit that
7032 when the allocated type is different from the declared type but
7033 no SOURCE exists by setting expr3. */
7034 code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
7036 else if (!code->expr3)
7038 /* Set up default initializer if needed. */
7042 if (code->ext.alloc.ts.type == BT_DERIVED)
7043 ts = code->ext.alloc.ts;
7047 if (ts.type == BT_CLASS)
7048 ts = ts.u.derived->components->ts;
7050 if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
7052 gfc_code *init_st = gfc_get_code ();
7053 init_st->loc = code->loc;
7054 init_st->op = EXEC_INIT_ASSIGN;
7055 init_st->expr1 = gfc_expr_to_initialize (e);
7056 init_st->expr2 = init_e;
7057 init_st->next = code->next;
7058 code->next = init_st;
7061 else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
7063 /* Default initialization via MOLD (non-polymorphic). */
7064 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
7065 gfc_resolve_expr (rhs);
7066 gfc_free_expr (code->expr3);
7070 if (e->ts.type == BT_CLASS)
7072 /* Make sure the vtab symbol is present when
7073 the module variables are generated. */
7074 gfc_typespec ts = e->ts;
7076 ts = code->expr3->ts;
7077 else if (code->ext.alloc.ts.type == BT_DERIVED)
7078 ts = code->ext.alloc.ts;
7079 gfc_find_derived_vtab (ts.u.derived);
7081 e = gfc_expr_to_initialize (e);
7084 if (dimension == 0 && codimension == 0)
7087 /* Make sure the last reference node is an array specifiction. */
7089 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
7090 || (dimension && ref2->u.ar.dimen == 0))
7092 gfc_error ("Array specification required in ALLOCATE statement "
7093 "at %L", &e->where);
7097 /* Make sure that the array section reference makes sense in the
7098 context of an ALLOCATE specification. */
7103 for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
7104 if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
7106 gfc_error ("Coarray specification required in ALLOCATE statement "
7107 "at %L", &e->where);
7111 for (i = 0; i < ar->dimen; i++)
7113 if (ref2->u.ar.type == AR_ELEMENT)
7116 switch (ar->dimen_type[i])
7122 if (ar->start[i] != NULL
7123 && ar->end[i] != NULL
7124 && ar->stride[i] == NULL)
7127 /* Fall Through... */
7132 case DIMEN_THIS_IMAGE:
7133 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7139 for (a = code->ext.alloc.list; a; a = a->next)
7141 sym = a->expr->symtree->n.sym;
7143 /* TODO - check derived type components. */
7144 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
7147 if ((ar->start[i] != NULL
7148 && gfc_find_sym_in_expr (sym, ar->start[i]))
7149 || (ar->end[i] != NULL
7150 && gfc_find_sym_in_expr (sym, ar->end[i])))
7152 gfc_error ("'%s' must not appear in the array specification at "
7153 "%L in the same ALLOCATE statement where it is "
7154 "itself allocated", sym->name, &ar->where);
7160 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
7162 if (ar->dimen_type[i] == DIMEN_ELEMENT
7163 || ar->dimen_type[i] == DIMEN_RANGE)
7165 if (i == (ar->dimen + ar->codimen - 1))
7167 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7168 "statement at %L", &e->where);
7174 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
7175 && ar->stride[i] == NULL)
7178 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7191 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
7193 gfc_expr *stat, *errmsg, *pe, *qe;
7194 gfc_alloc *a, *p, *q;
7197 errmsg = code->expr2;
7199 /* Check the stat variable. */
7202 gfc_check_vardef_context (stat, false, false, _("STAT variable"));
7204 if ((stat->ts.type != BT_INTEGER
7205 && !(stat->ref && (stat->ref->type == REF_ARRAY
7206 || stat->ref->type == REF_COMPONENT)))
7208 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7209 "variable", &stat->where);
7211 for (p = code->ext.alloc.list; p; p = p->next)
7212 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
7214 gfc_ref *ref1, *ref2;
7217 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
7218 ref1 = ref1->next, ref2 = ref2->next)
7220 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7222 if (ref1->u.c.component->name != ref2->u.c.component->name)
7231 gfc_error ("Stat-variable at %L shall not be %sd within "
7232 "the same %s statement", &stat->where, fcn, fcn);
7238 /* Check the errmsg variable. */
7242 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7245 gfc_check_vardef_context (errmsg, false, false, _("ERRMSG variable"));
7247 if ((errmsg->ts.type != BT_CHARACTER
7249 && (errmsg->ref->type == REF_ARRAY
7250 || errmsg->ref->type == REF_COMPONENT)))
7251 || errmsg->rank > 0 )
7252 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7253 "variable", &errmsg->where);
7255 for (p = code->ext.alloc.list; p; p = p->next)
7256 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
7258 gfc_ref *ref1, *ref2;
7261 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
7262 ref1 = ref1->next, ref2 = ref2->next)
7264 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7266 if (ref1->u.c.component->name != ref2->u.c.component->name)
7275 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7276 "the same %s statement", &errmsg->where, fcn, fcn);
7282 /* Check that an allocate-object appears only once in the statement.
7283 FIXME: Checking derived types is disabled. */
7284 for (p = code->ext.alloc.list; p; p = p->next)
7287 for (q = p->next; q; q = q->next)
7290 if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
7292 /* This is a potential collision. */
7293 gfc_ref *pr = pe->ref;
7294 gfc_ref *qr = qe->ref;
7296 /* Follow the references until
7297 a) They start to differ, in which case there is no error;
7298 you can deallocate a%b and a%c in a single statement
7299 b) Both of them stop, which is an error
7300 c) One of them stops, which is also an error. */
7303 if (pr == NULL && qr == NULL)
7305 gfc_error ("Allocate-object at %L also appears at %L",
7306 &pe->where, &qe->where);
7309 else if (pr != NULL && qr == NULL)
7311 gfc_error ("Allocate-object at %L is subobject of"
7312 " object at %L", &pe->where, &qe->where);
7315 else if (pr == NULL && qr != NULL)
7317 gfc_error ("Allocate-object at %L is subobject of"
7318 " object at %L", &qe->where, &pe->where);
7321 /* Here, pr != NULL && qr != NULL */
7322 gcc_assert(pr->type == qr->type);
7323 if (pr->type == REF_ARRAY)
7325 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7327 gcc_assert (qr->type == REF_ARRAY);
7329 if (pr->next && qr->next)
7331 gfc_array_ref *par = &(pr->u.ar);
7332 gfc_array_ref *qar = &(qr->u.ar);
7333 if (gfc_dep_compare_expr (par->start[0],
7334 qar->start[0]) != 0)
7340 if (pr->u.c.component->name != qr->u.c.component->name)
7351 if (strcmp (fcn, "ALLOCATE") == 0)
7353 for (a = code->ext.alloc.list; a; a = a->next)
7354 resolve_allocate_expr (a->expr, code);
7358 for (a = code->ext.alloc.list; a; a = a->next)
7359 resolve_deallocate_expr (a->expr);
7364 /************ SELECT CASE resolution subroutines ************/
7366 /* Callback function for our mergesort variant. Determines interval
7367 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7368 op1 > op2. Assumes we're not dealing with the default case.
7369 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7370 There are nine situations to check. */
7373 compare_cases (const gfc_case *op1, const gfc_case *op2)
7377 if (op1->low == NULL) /* op1 = (:L) */
7379 /* op2 = (:N), so overlap. */
7381 /* op2 = (M:) or (M:N), L < M */
7382 if (op2->low != NULL
7383 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7386 else if (op1->high == NULL) /* op1 = (K:) */
7388 /* op2 = (M:), so overlap. */
7390 /* op2 = (:N) or (M:N), K > N */
7391 if (op2->high != NULL
7392 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7395 else /* op1 = (K:L) */
7397 if (op2->low == NULL) /* op2 = (:N), K > N */
7398 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7400 else if (op2->high == NULL) /* op2 = (M:), L < M */
7401 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7403 else /* op2 = (M:N) */
7407 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7410 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7419 /* Merge-sort a double linked case list, detecting overlap in the
7420 process. LIST is the head of the double linked case list before it
7421 is sorted. Returns the head of the sorted list if we don't see any
7422 overlap, or NULL otherwise. */
7425 check_case_overlap (gfc_case *list)
7427 gfc_case *p, *q, *e, *tail;
7428 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7430 /* If the passed list was empty, return immediately. */
7437 /* Loop unconditionally. The only exit from this loop is a return
7438 statement, when we've finished sorting the case list. */
7445 /* Count the number of merges we do in this pass. */
7448 /* Loop while there exists a merge to be done. */
7453 /* Count this merge. */
7456 /* Cut the list in two pieces by stepping INSIZE places
7457 forward in the list, starting from P. */
7460 for (i = 0; i < insize; i++)
7469 /* Now we have two lists. Merge them! */
7470 while (psize > 0 || (qsize > 0 && q != NULL))
7472 /* See from which the next case to merge comes from. */
7475 /* P is empty so the next case must come from Q. */
7480 else if (qsize == 0 || q == NULL)
7489 cmp = compare_cases (p, q);
7492 /* The whole case range for P is less than the
7500 /* The whole case range for Q is greater than
7501 the case range for P. */
7508 /* The cases overlap, or they are the same
7509 element in the list. Either way, we must
7510 issue an error and get the next case from P. */
7511 /* FIXME: Sort P and Q by line number. */
7512 gfc_error ("CASE label at %L overlaps with CASE "
7513 "label at %L", &p->where, &q->where);
7521 /* Add the next element to the merged list. */
7530 /* P has now stepped INSIZE places along, and so has Q. So
7531 they're the same. */
7536 /* If we have done only one merge or none at all, we've
7537 finished sorting the cases. */
7546 /* Otherwise repeat, merging lists twice the size. */
7552 /* Check to see if an expression is suitable for use in a CASE statement.
7553 Makes sure that all case expressions are scalar constants of the same
7554 type. Return FAILURE if anything is wrong. */
7557 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7559 if (e == NULL) return SUCCESS;
7561 if (e->ts.type != case_expr->ts.type)
7563 gfc_error ("Expression in CASE statement at %L must be of type %s",
7564 &e->where, gfc_basic_typename (case_expr->ts.type));
7568 /* C805 (R808) For a given case-construct, each case-value shall be of
7569 the same type as case-expr. For character type, length differences
7570 are allowed, but the kind type parameters shall be the same. */
7572 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7574 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7575 &e->where, case_expr->ts.kind);
7579 /* Convert the case value kind to that of case expression kind,
7582 if (e->ts.kind != case_expr->ts.kind)
7583 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7587 gfc_error ("Expression in CASE statement at %L must be scalar",
7596 /* Given a completely parsed select statement, we:
7598 - Validate all expressions and code within the SELECT.
7599 - Make sure that the selection expression is not of the wrong type.
7600 - Make sure that no case ranges overlap.
7601 - Eliminate unreachable cases and unreachable code resulting from
7602 removing case labels.
7604 The standard does allow unreachable cases, e.g. CASE (5:3). But
7605 they are a hassle for code generation, and to prevent that, we just
7606 cut them out here. This is not necessary for overlapping cases
7607 because they are illegal and we never even try to generate code.
7609 We have the additional caveat that a SELECT construct could have
7610 been a computed GOTO in the source code. Fortunately we can fairly
7611 easily work around that here: The case_expr for a "real" SELECT CASE
7612 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7613 we have to do is make sure that the case_expr is a scalar integer
7617 resolve_select (gfc_code *code)
7620 gfc_expr *case_expr;
7621 gfc_case *cp, *default_case, *tail, *head;
7622 int seen_unreachable;
7628 if (code->expr1 == NULL)
7630 /* This was actually a computed GOTO statement. */
7631 case_expr = code->expr2;
7632 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7633 gfc_error ("Selection expression in computed GOTO statement "
7634 "at %L must be a scalar integer expression",
7637 /* Further checking is not necessary because this SELECT was built
7638 by the compiler, so it should always be OK. Just move the
7639 case_expr from expr2 to expr so that we can handle computed
7640 GOTOs as normal SELECTs from here on. */
7641 code->expr1 = code->expr2;
7646 case_expr = code->expr1;
7648 type = case_expr->ts.type;
7649 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7651 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7652 &case_expr->where, gfc_typename (&case_expr->ts));
7654 /* Punt. Going on here just produce more garbage error messages. */
7658 /* Raise a warning if an INTEGER case value exceeds the range of
7659 the case-expr. Later, all expressions will be promoted to the
7660 largest kind of all case-labels. */
7662 if (type == BT_INTEGER)
7663 for (body = code->block; body; body = body->block)
7664 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7667 && gfc_check_integer_range (cp->low->value.integer,
7668 case_expr->ts.kind) != ARITH_OK)
7669 gfc_warning ("Expression in CASE statement at %L is "
7670 "not in the range of %s", &cp->low->where,
7671 gfc_typename (&case_expr->ts));
7674 && cp->low != cp->high
7675 && gfc_check_integer_range (cp->high->value.integer,
7676 case_expr->ts.kind) != ARITH_OK)
7677 gfc_warning ("Expression in CASE statement at %L is "
7678 "not in the range of %s", &cp->high->where,
7679 gfc_typename (&case_expr->ts));
7682 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7683 of the SELECT CASE expression and its CASE values. Walk the lists
7684 of case values, and if we find a mismatch, promote case_expr to
7685 the appropriate kind. */
7687 if (type == BT_LOGICAL || type == BT_INTEGER)
7689 for (body = code->block; body; body = body->block)
7691 /* Walk the case label list. */
7692 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7694 /* Intercept the DEFAULT case. It does not have a kind. */
7695 if (cp->low == NULL && cp->high == NULL)
7698 /* Unreachable case ranges are discarded, so ignore. */
7699 if (cp->low != NULL && cp->high != NULL
7700 && cp->low != cp->high
7701 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7705 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7706 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7708 if (cp->high != NULL
7709 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7710 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7715 /* Assume there is no DEFAULT case. */
7716 default_case = NULL;
7721 for (body = code->block; body; body = body->block)
7723 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7725 seen_unreachable = 0;
7727 /* Walk the case label list, making sure that all case labels
7729 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7731 /* Count the number of cases in the whole construct. */
7734 /* Intercept the DEFAULT case. */
7735 if (cp->low == NULL && cp->high == NULL)
7737 if (default_case != NULL)
7739 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7740 "by a second DEFAULT CASE at %L",
7741 &default_case->where, &cp->where);
7752 /* Deal with single value cases and case ranges. Errors are
7753 issued from the validation function. */
7754 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7755 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7761 if (type == BT_LOGICAL
7762 && ((cp->low == NULL || cp->high == NULL)
7763 || cp->low != cp->high))
7765 gfc_error ("Logical range in CASE statement at %L is not "
7766 "allowed", &cp->low->where);
7771 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7774 value = cp->low->value.logical == 0 ? 2 : 1;
7775 if (value & seen_logical)
7777 gfc_error ("Constant logical value in CASE statement "
7778 "is repeated at %L",
7783 seen_logical |= value;
7786 if (cp->low != NULL && cp->high != NULL
7787 && cp->low != cp->high
7788 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7790 if (gfc_option.warn_surprising)
7791 gfc_warning ("Range specification at %L can never "
7792 "be matched", &cp->where);
7794 cp->unreachable = 1;
7795 seen_unreachable = 1;
7799 /* If the case range can be matched, it can also overlap with
7800 other cases. To make sure it does not, we put it in a
7801 double linked list here. We sort that with a merge sort
7802 later on to detect any overlapping cases. */
7806 head->right = head->left = NULL;
7811 tail->right->left = tail;
7818 /* It there was a failure in the previous case label, give up
7819 for this case label list. Continue with the next block. */
7823 /* See if any case labels that are unreachable have been seen.
7824 If so, we eliminate them. This is a bit of a kludge because
7825 the case lists for a single case statement (label) is a
7826 single forward linked lists. */
7827 if (seen_unreachable)
7829 /* Advance until the first case in the list is reachable. */
7830 while (body->ext.block.case_list != NULL
7831 && body->ext.block.case_list->unreachable)
7833 gfc_case *n = body->ext.block.case_list;
7834 body->ext.block.case_list = body->ext.block.case_list->next;
7836 gfc_free_case_list (n);
7839 /* Strip all other unreachable cases. */
7840 if (body->ext.block.case_list)
7842 for (cp = body->ext.block.case_list; cp->next; cp = cp->next)
7844 if (cp->next->unreachable)
7846 gfc_case *n = cp->next;
7847 cp->next = cp->next->next;
7849 gfc_free_case_list (n);
7856 /* See if there were overlapping cases. If the check returns NULL,
7857 there was overlap. In that case we don't do anything. If head
7858 is non-NULL, we prepend the DEFAULT case. The sorted list can
7859 then used during code generation for SELECT CASE constructs with
7860 a case expression of a CHARACTER type. */
7863 head = check_case_overlap (head);
7865 /* Prepend the default_case if it is there. */
7866 if (head != NULL && default_case)
7868 default_case->left = NULL;
7869 default_case->right = head;
7870 head->left = default_case;
7874 /* Eliminate dead blocks that may be the result if we've seen
7875 unreachable case labels for a block. */
7876 for (body = code; body && body->block; body = body->block)
7878 if (body->block->ext.block.case_list == NULL)
7880 /* Cut the unreachable block from the code chain. */
7881 gfc_code *c = body->block;
7882 body->block = c->block;
7884 /* Kill the dead block, but not the blocks below it. */
7886 gfc_free_statements (c);
7890 /* More than two cases is legal but insane for logical selects.
7891 Issue a warning for it. */
7892 if (gfc_option.warn_surprising && type == BT_LOGICAL
7894 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7899 /* Check if a derived type is extensible. */
7902 gfc_type_is_extensible (gfc_symbol *sym)
7904 return !(sym->attr.is_bind_c || sym->attr.sequence);
7908 /* Resolve an associate name: Resolve target and ensure the type-spec is
7909 correct as well as possibly the array-spec. */
7912 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
7916 gcc_assert (sym->assoc);
7917 gcc_assert (sym->attr.flavor == FL_VARIABLE);
7919 /* If this is for SELECT TYPE, the target may not yet be set. In that
7920 case, return. Resolution will be called later manually again when
7922 target = sym->assoc->target;
7925 gcc_assert (!sym->assoc->dangling);
7927 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
7930 /* For variable targets, we get some attributes from the target. */
7931 if (target->expr_type == EXPR_VARIABLE)
7935 gcc_assert (target->symtree);
7936 tsym = target->symtree->n.sym;
7938 sym->attr.asynchronous = tsym->attr.asynchronous;
7939 sym->attr.volatile_ = tsym->attr.volatile_;
7941 sym->attr.target = tsym->attr.target
7942 || gfc_expr_attr (target).pointer;
7945 /* Get type if this was not already set. Note that it can be
7946 some other type than the target in case this is a SELECT TYPE
7947 selector! So we must not update when the type is already there. */
7948 if (sym->ts.type == BT_UNKNOWN)
7949 sym->ts = target->ts;
7950 gcc_assert (sym->ts.type != BT_UNKNOWN);
7952 /* See if this is a valid association-to-variable. */
7953 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
7954 && !gfc_has_vector_subscript (target));
7956 /* Finally resolve if this is an array or not. */
7957 if (sym->attr.dimension && target->rank == 0)
7959 gfc_error ("Associate-name '%s' at %L is used as array",
7960 sym->name, &sym->declared_at);
7961 sym->attr.dimension = 0;
7964 if (target->rank > 0)
7965 sym->attr.dimension = 1;
7967 if (sym->attr.dimension)
7969 sym->as = gfc_get_array_spec ();
7970 sym->as->rank = target->rank;
7971 sym->as->type = AS_DEFERRED;
7973 /* Target must not be coindexed, thus the associate-variable
7975 sym->as->corank = 0;
7980 /* Resolve a SELECT TYPE statement. */
7983 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
7985 gfc_symbol *selector_type;
7986 gfc_code *body, *new_st, *if_st, *tail;
7987 gfc_code *class_is = NULL, *default_case = NULL;
7990 char name[GFC_MAX_SYMBOL_LEN];
7994 ns = code->ext.block.ns;
7997 /* Check for F03:C813. */
7998 if (code->expr1->ts.type != BT_CLASS
7999 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
8001 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8002 "at %L", &code->loc);
8006 if (!code->expr1->symtree->n.sym->attr.class_ok)
8011 if (code->expr1->symtree->n.sym->attr.untyped)
8012 code->expr1->symtree->n.sym->ts = code->expr2->ts;
8013 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
8016 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
8018 /* Loop over TYPE IS / CLASS IS cases. */
8019 for (body = code->block; body; body = body->block)
8021 c = body->ext.block.case_list;
8023 /* Check F03:C815. */
8024 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8025 && !gfc_type_is_extensible (c->ts.u.derived))
8027 gfc_error ("Derived type '%s' at %L must be extensible",
8028 c->ts.u.derived->name, &c->where);
8033 /* Check F03:C816. */
8034 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8035 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
8037 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
8038 c->ts.u.derived->name, &c->where, selector_type->name);
8043 /* Intercept the DEFAULT case. */
8044 if (c->ts.type == BT_UNKNOWN)
8046 /* Check F03:C818. */
8049 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8050 "by a second DEFAULT CASE at %L",
8051 &default_case->ext.block.case_list->where, &c->where);
8056 default_case = body;
8063 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8064 target if present. If there are any EXIT statements referring to the
8065 SELECT TYPE construct, this is no problem because the gfc_code
8066 reference stays the same and EXIT is equally possible from the BLOCK
8067 it is changed to. */
8068 code->op = EXEC_BLOCK;
8071 gfc_association_list* assoc;
8073 assoc = gfc_get_association_list ();
8074 assoc->st = code->expr1->symtree;
8075 assoc->target = gfc_copy_expr (code->expr2);
8076 assoc->target->where = code->expr2->where;
8077 /* assoc->variable will be set by resolve_assoc_var. */
8079 code->ext.block.assoc = assoc;
8080 code->expr1->symtree->n.sym->assoc = assoc;
8082 resolve_assoc_var (code->expr1->symtree->n.sym, false);
8085 code->ext.block.assoc = NULL;
8087 /* Add EXEC_SELECT to switch on type. */
8088 new_st = gfc_get_code ();
8089 new_st->op = code->op;
8090 new_st->expr1 = code->expr1;
8091 new_st->expr2 = code->expr2;
8092 new_st->block = code->block;
8093 code->expr1 = code->expr2 = NULL;
8098 ns->code->next = new_st;
8100 code->op = EXEC_SELECT;
8101 gfc_add_vptr_component (code->expr1);
8102 gfc_add_hash_component (code->expr1);
8104 /* Loop over TYPE IS / CLASS IS cases. */
8105 for (body = code->block; body; body = body->block)
8107 c = body->ext.block.case_list;
8109 if (c->ts.type == BT_DERIVED)
8110 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
8111 c->ts.u.derived->hash_value);
8113 else if (c->ts.type == BT_UNKNOWN)
8116 /* Associate temporary to selector. This should only be done
8117 when this case is actually true, so build a new ASSOCIATE
8118 that does precisely this here (instead of using the
8121 if (c->ts.type == BT_CLASS)
8122 sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
8124 sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
8125 st = gfc_find_symtree (ns->sym_root, name);
8126 gcc_assert (st->n.sym->assoc);
8127 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
8128 st->n.sym->assoc->target->where = code->expr1->where;
8129 if (c->ts.type == BT_DERIVED)
8130 gfc_add_data_component (st->n.sym->assoc->target);
8132 new_st = gfc_get_code ();
8133 new_st->op = EXEC_BLOCK;
8134 new_st->ext.block.ns = gfc_build_block_ns (ns);
8135 new_st->ext.block.ns->code = body->next;
8136 body->next = new_st;
8138 /* Chain in the new list only if it is marked as dangling. Otherwise
8139 there is a CASE label overlap and this is already used. Just ignore,
8140 the error is diagonsed elsewhere. */
8141 if (st->n.sym->assoc->dangling)
8143 new_st->ext.block.assoc = st->n.sym->assoc;
8144 st->n.sym->assoc->dangling = 0;
8147 resolve_assoc_var (st->n.sym, false);
8150 /* Take out CLASS IS cases for separate treatment. */
8152 while (body && body->block)
8154 if (body->block->ext.block.case_list->ts.type == BT_CLASS)
8156 /* Add to class_is list. */
8157 if (class_is == NULL)
8159 class_is = body->block;
8164 for (tail = class_is; tail->block; tail = tail->block) ;
8165 tail->block = body->block;
8168 /* Remove from EXEC_SELECT list. */
8169 body->block = body->block->block;
8182 /* Add a default case to hold the CLASS IS cases. */
8183 for (tail = code; tail->block; tail = tail->block) ;
8184 tail->block = gfc_get_code ();
8186 tail->op = EXEC_SELECT_TYPE;
8187 tail->ext.block.case_list = gfc_get_case ();
8188 tail->ext.block.case_list->ts.type = BT_UNKNOWN;
8190 default_case = tail;
8193 /* More than one CLASS IS block? */
8194 if (class_is->block)
8198 /* Sort CLASS IS blocks by extension level. */
8202 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
8205 /* F03:C817 (check for doubles). */
8206 if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
8207 == c2->ext.block.case_list->ts.u.derived->hash_value)
8209 gfc_error ("Double CLASS IS block in SELECT TYPE "
8211 &c2->ext.block.case_list->where);
8214 if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
8215 < c2->ext.block.case_list->ts.u.derived->attr.extension)
8218 (*c1)->block = c2->block;
8228 /* Generate IF chain. */
8229 if_st = gfc_get_code ();
8230 if_st->op = EXEC_IF;
8232 for (body = class_is; body; body = body->block)
8234 new_st->block = gfc_get_code ();
8235 new_st = new_st->block;
8236 new_st->op = EXEC_IF;
8237 /* Set up IF condition: Call _gfortran_is_extension_of. */
8238 new_st->expr1 = gfc_get_expr ();
8239 new_st->expr1->expr_type = EXPR_FUNCTION;
8240 new_st->expr1->ts.type = BT_LOGICAL;
8241 new_st->expr1->ts.kind = 4;
8242 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
8243 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
8244 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
8245 /* Set up arguments. */
8246 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
8247 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
8248 new_st->expr1->value.function.actual->expr->where = code->loc;
8249 gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
8250 vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
8251 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
8252 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
8253 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
8254 new_st->next = body->next;
8256 if (default_case->next)
8258 new_st->block = gfc_get_code ();
8259 new_st = new_st->block;
8260 new_st->op = EXEC_IF;
8261 new_st->next = default_case->next;
8264 /* Replace CLASS DEFAULT code by the IF chain. */
8265 default_case->next = if_st;
8268 /* Resolve the internal code. This can not be done earlier because
8269 it requires that the sym->assoc of selectors is set already. */
8270 gfc_current_ns = ns;
8271 gfc_resolve_blocks (code->block, gfc_current_ns);
8272 gfc_current_ns = old_ns;
8274 resolve_select (code);
8278 /* Resolve a transfer statement. This is making sure that:
8279 -- a derived type being transferred has only non-pointer components
8280 -- a derived type being transferred doesn't have private components, unless
8281 it's being transferred from the module where the type was defined
8282 -- we're not trying to transfer a whole assumed size array. */
8285 resolve_transfer (gfc_code *code)
8294 while (exp != NULL && exp->expr_type == EXPR_OP
8295 && exp->value.op.op == INTRINSIC_PARENTHESES)
8296 exp = exp->value.op.op1;
8298 if (exp && exp->expr_type == EXPR_NULL && exp->ts.type == BT_UNKNOWN)
8300 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8301 "MOLD=", &exp->where);
8305 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
8306 && exp->expr_type != EXPR_FUNCTION))
8309 /* If we are reading, the variable will be changed. Note that
8310 code->ext.dt may be NULL if the TRANSFER is related to
8311 an INQUIRE statement -- but in this case, we are not reading, either. */
8312 if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
8313 && gfc_check_vardef_context (exp, false, false, _("item in READ"))
8317 sym = exp->symtree->n.sym;
8320 /* Go to actual component transferred. */
8321 for (ref = exp->ref; ref; ref = ref->next)
8322 if (ref->type == REF_COMPONENT)
8323 ts = &ref->u.c.component->ts;
8325 if (ts->type == BT_CLASS)
8327 /* FIXME: Test for defined input/output. */
8328 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8329 "it is processed by a defined input/output procedure",
8334 if (ts->type == BT_DERIVED)
8336 /* Check that transferred derived type doesn't contain POINTER
8338 if (ts->u.derived->attr.pointer_comp)
8340 gfc_error ("Data transfer element at %L cannot have POINTER "
8341 "components unless it is processed by a defined "
8342 "input/output procedure", &code->loc);
8347 if (ts->u.derived->attr.proc_pointer_comp)
8349 gfc_error ("Data transfer element at %L cannot have "
8350 "procedure pointer components", &code->loc);
8354 if (ts->u.derived->attr.alloc_comp)
8356 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8357 "components unless it is processed by a defined "
8358 "input/output procedure", &code->loc);
8362 if (derived_inaccessible (ts->u.derived))
8364 gfc_error ("Data transfer element at %L cannot have "
8365 "PRIVATE components",&code->loc);
8370 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
8371 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
8373 gfc_error ("Data transfer element at %L cannot be a full reference to "
8374 "an assumed-size array", &code->loc);
8380 /*********** Toplevel code resolution subroutines ***********/
8382 /* Find the set of labels that are reachable from this block. We also
8383 record the last statement in each block. */
8386 find_reachable_labels (gfc_code *block)
8393 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
8395 /* Collect labels in this block. We don't keep those corresponding
8396 to END {IF|SELECT}, these are checked in resolve_branch by going
8397 up through the code_stack. */
8398 for (c = block; c; c = c->next)
8400 if (c->here && c->op != EXEC_END_NESTED_BLOCK)
8401 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8404 /* Merge with labels from parent block. */
8407 gcc_assert (cs_base->prev->reachable_labels);
8408 bitmap_ior_into (cs_base->reachable_labels,
8409 cs_base->prev->reachable_labels);
8415 resolve_lock_unlock (gfc_code *code)
8417 if (code->expr1->ts.type != BT_DERIVED
8418 || code->expr1->expr_type != EXPR_VARIABLE
8419 || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
8420 || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
8421 || code->expr1->rank != 0
8422 || (!gfc_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1)))
8423 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8424 &code->expr1->where);
8428 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8429 || code->expr2->expr_type != EXPR_VARIABLE))
8430 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8431 &code->expr2->where);
8434 && gfc_check_vardef_context (code->expr2, false, false,
8435 _("STAT variable")) == FAILURE)
8440 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8441 || code->expr3->expr_type != EXPR_VARIABLE))
8442 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8443 &code->expr3->where);
8446 && gfc_check_vardef_context (code->expr3, false, false,
8447 _("ERRMSG variable")) == FAILURE)
8450 /* Check ACQUIRED_LOCK. */
8452 && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
8453 || code->expr4->expr_type != EXPR_VARIABLE))
8454 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8455 "variable", &code->expr4->where);
8458 && gfc_check_vardef_context (code->expr4, false, false,
8459 _("ACQUIRED_LOCK variable")) == FAILURE)
8465 resolve_sync (gfc_code *code)
8467 /* Check imageset. The * case matches expr1 == NULL. */
8470 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8471 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8472 "INTEGER expression", &code->expr1->where);
8473 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8474 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8475 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8476 &code->expr1->where);
8477 else if (code->expr1->expr_type == EXPR_ARRAY
8478 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8480 gfc_constructor *cons;
8481 cons = gfc_constructor_first (code->expr1->value.constructor);
8482 for (; cons; cons = gfc_constructor_next (cons))
8483 if (cons->expr->expr_type == EXPR_CONSTANT
8484 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8485 gfc_error ("Imageset argument at %L must between 1 and "
8486 "num_images()", &cons->expr->where);
8492 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8493 || code->expr2->expr_type != EXPR_VARIABLE))
8494 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8495 &code->expr2->where);
8499 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8500 || code->expr3->expr_type != EXPR_VARIABLE))
8501 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8502 &code->expr3->where);
8506 /* Given a branch to a label, see if the branch is conforming.
8507 The code node describes where the branch is located. */
8510 resolve_branch (gfc_st_label *label, gfc_code *code)
8517 /* Step one: is this a valid branching target? */
8519 if (label->defined == ST_LABEL_UNKNOWN)
8521 gfc_error ("Label %d referenced at %L is never defined", label->value,
8526 if (label->defined != ST_LABEL_TARGET)
8528 gfc_error ("Statement at %L is not a valid branch target statement "
8529 "for the branch statement at %L", &label->where, &code->loc);
8533 /* Step two: make sure this branch is not a branch to itself ;-) */
8535 if (code->here == label)
8537 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8541 /* Step three: See if the label is in the same block as the
8542 branching statement. The hard work has been done by setting up
8543 the bitmap reachable_labels. */
8545 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8547 /* Check now whether there is a CRITICAL construct; if so, check
8548 whether the label is still visible outside of the CRITICAL block,
8549 which is invalid. */
8550 for (stack = cs_base; stack; stack = stack->prev)
8552 if (stack->current->op == EXEC_CRITICAL
8553 && bitmap_bit_p (stack->reachable_labels, label->value))
8554 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8555 "label at %L", &code->loc, &label->where);
8556 else if (stack->current->op == EXEC_DO_CONCURRENT
8557 && bitmap_bit_p (stack->reachable_labels, label->value))
8558 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8559 "for label at %L", &code->loc, &label->where);
8565 /* Step four: If we haven't found the label in the bitmap, it may
8566 still be the label of the END of the enclosing block, in which
8567 case we find it by going up the code_stack. */
8569 for (stack = cs_base; stack; stack = stack->prev)
8571 if (stack->current->next && stack->current->next->here == label)
8573 if (stack->current->op == EXEC_CRITICAL)
8575 /* Note: A label at END CRITICAL does not leave the CRITICAL
8576 construct as END CRITICAL is still part of it. */
8577 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8578 " at %L", &code->loc, &label->where);
8581 else if (stack->current->op == EXEC_DO_CONCURRENT)
8583 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8584 "label at %L", &code->loc, &label->where);
8591 gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
8595 /* The label is not in an enclosing block, so illegal. This was
8596 allowed in Fortran 66, so we allow it as extension. No
8597 further checks are necessary in this case. */
8598 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
8599 "as the GOTO statement at %L", &label->where,
8605 /* Check whether EXPR1 has the same shape as EXPR2. */
8608 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
8610 mpz_t shape[GFC_MAX_DIMENSIONS];
8611 mpz_t shape2[GFC_MAX_DIMENSIONS];
8612 gfc_try result = FAILURE;
8615 /* Compare the rank. */
8616 if (expr1->rank != expr2->rank)
8619 /* Compare the size of each dimension. */
8620 for (i=0; i<expr1->rank; i++)
8622 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
8625 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
8628 if (mpz_cmp (shape[i], shape2[i]))
8632 /* When either of the two expression is an assumed size array, we
8633 ignore the comparison of dimension sizes. */
8638 gfc_clear_shape (shape, i);
8639 gfc_clear_shape (shape2, i);
8644 /* Check whether a WHERE assignment target or a WHERE mask expression
8645 has the same shape as the outmost WHERE mask expression. */
8648 resolve_where (gfc_code *code, gfc_expr *mask)
8654 cblock = code->block;
8656 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8657 In case of nested WHERE, only the outmost one is stored. */
8658 if (mask == NULL) /* outmost WHERE */
8660 else /* inner WHERE */
8667 /* Check if the mask-expr has a consistent shape with the
8668 outmost WHERE mask-expr. */
8669 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8670 gfc_error ("WHERE mask at %L has inconsistent shape",
8671 &cblock->expr1->where);
8674 /* the assignment statement of a WHERE statement, or the first
8675 statement in where-body-construct of a WHERE construct */
8676 cnext = cblock->next;
8681 /* WHERE assignment statement */
8684 /* Check shape consistent for WHERE assignment target. */
8685 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8686 gfc_error ("WHERE assignment target at %L has "
8687 "inconsistent shape", &cnext->expr1->where);
8691 case EXEC_ASSIGN_CALL:
8692 resolve_call (cnext);
8693 if (!cnext->resolved_sym->attr.elemental)
8694 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8695 &cnext->ext.actual->expr->where);
8698 /* WHERE or WHERE construct is part of a where-body-construct */
8700 resolve_where (cnext, e);
8704 gfc_error ("Unsupported statement inside WHERE at %L",
8707 /* the next statement within the same where-body-construct */
8708 cnext = cnext->next;
8710 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8711 cblock = cblock->block;
8716 /* Resolve assignment in FORALL construct.
8717 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8718 FORALL index variables. */
8721 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8725 for (n = 0; n < nvar; n++)
8727 gfc_symbol *forall_index;
8729 forall_index = var_expr[n]->symtree->n.sym;
8731 /* Check whether the assignment target is one of the FORALL index
8733 if ((code->expr1->expr_type == EXPR_VARIABLE)
8734 && (code->expr1->symtree->n.sym == forall_index))
8735 gfc_error ("Assignment to a FORALL index variable at %L",
8736 &code->expr1->where);
8739 /* If one of the FORALL index variables doesn't appear in the
8740 assignment variable, then there could be a many-to-one
8741 assignment. Emit a warning rather than an error because the
8742 mask could be resolving this problem. */
8743 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8744 gfc_warning ("The FORALL with index '%s' is not used on the "
8745 "left side of the assignment at %L and so might "
8746 "cause multiple assignment to this object",
8747 var_expr[n]->symtree->name, &code->expr1->where);
8753 /* Resolve WHERE statement in FORALL construct. */
8756 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8757 gfc_expr **var_expr)
8762 cblock = code->block;
8765 /* the assignment statement of a WHERE statement, or the first
8766 statement in where-body-construct of a WHERE construct */
8767 cnext = cblock->next;
8772 /* WHERE assignment statement */
8774 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8777 /* WHERE operator assignment statement */
8778 case EXEC_ASSIGN_CALL:
8779 resolve_call (cnext);
8780 if (!cnext->resolved_sym->attr.elemental)
8781 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8782 &cnext->ext.actual->expr->where);
8785 /* WHERE or WHERE construct is part of a where-body-construct */
8787 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8791 gfc_error ("Unsupported statement inside WHERE at %L",
8794 /* the next statement within the same where-body-construct */
8795 cnext = cnext->next;
8797 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8798 cblock = cblock->block;
8803 /* Traverse the FORALL body to check whether the following errors exist:
8804 1. For assignment, check if a many-to-one assignment happens.
8805 2. For WHERE statement, check the WHERE body to see if there is any
8806 many-to-one assignment. */
8809 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8813 c = code->block->next;
8819 case EXEC_POINTER_ASSIGN:
8820 gfc_resolve_assign_in_forall (c, nvar, var_expr);
8823 case EXEC_ASSIGN_CALL:
8827 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8828 there is no need to handle it here. */
8832 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8837 /* The next statement in the FORALL body. */
8843 /* Counts the number of iterators needed inside a forall construct, including
8844 nested forall constructs. This is used to allocate the needed memory
8845 in gfc_resolve_forall. */
8848 gfc_count_forall_iterators (gfc_code *code)
8850 int max_iters, sub_iters, current_iters;
8851 gfc_forall_iterator *fa;
8853 gcc_assert(code->op == EXEC_FORALL);
8857 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8860 code = code->block->next;
8864 if (code->op == EXEC_FORALL)
8866 sub_iters = gfc_count_forall_iterators (code);
8867 if (sub_iters > max_iters)
8868 max_iters = sub_iters;
8873 return current_iters + max_iters;
8877 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8878 gfc_resolve_forall_body to resolve the FORALL body. */
8881 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8883 static gfc_expr **var_expr;
8884 static int total_var = 0;
8885 static int nvar = 0;
8887 gfc_forall_iterator *fa;
8892 /* Start to resolve a FORALL construct */
8893 if (forall_save == 0)
8895 /* Count the total number of FORALL index in the nested FORALL
8896 construct in order to allocate the VAR_EXPR with proper size. */
8897 total_var = gfc_count_forall_iterators (code);
8899 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8900 var_expr = XCNEWVEC (gfc_expr *, total_var);
8903 /* The information about FORALL iterator, including FORALL index start, end
8904 and stride. The FORALL index can not appear in start, end or stride. */
8905 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8907 /* Check if any outer FORALL index name is the same as the current
8909 for (i = 0; i < nvar; i++)
8911 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8913 gfc_error ("An outer FORALL construct already has an index "
8914 "with this name %L", &fa->var->where);
8918 /* Record the current FORALL index. */
8919 var_expr[nvar] = gfc_copy_expr (fa->var);
8923 /* No memory leak. */
8924 gcc_assert (nvar <= total_var);
8927 /* Resolve the FORALL body. */
8928 gfc_resolve_forall_body (code, nvar, var_expr);
8930 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8931 gfc_resolve_blocks (code->block, ns);
8935 /* Free only the VAR_EXPRs allocated in this frame. */
8936 for (i = nvar; i < tmp; i++)
8937 gfc_free_expr (var_expr[i]);
8941 /* We are in the outermost FORALL construct. */
8942 gcc_assert (forall_save == 0);
8944 /* VAR_EXPR is not needed any more. */
8951 /* Resolve a BLOCK construct statement. */
8954 resolve_block_construct (gfc_code* code)
8956 /* Resolve the BLOCK's namespace. */
8957 gfc_resolve (code->ext.block.ns);
8959 /* For an ASSOCIATE block, the associations (and their targets) are already
8960 resolved during resolve_symbol. */
8964 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8967 static void resolve_code (gfc_code *, gfc_namespace *);
8970 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8974 for (; b; b = b->block)
8976 t = gfc_resolve_expr (b->expr1);
8977 if (gfc_resolve_expr (b->expr2) == FAILURE)
8983 if (t == SUCCESS && b->expr1 != NULL
8984 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
8985 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8992 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
8993 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8998 resolve_branch (b->label1, b);
9002 resolve_block_construct (b);
9006 case EXEC_SELECT_TYPE:
9010 case EXEC_DO_CONCURRENT:
9018 case EXEC_OMP_ATOMIC:
9019 case EXEC_OMP_CRITICAL:
9021 case EXEC_OMP_MASTER:
9022 case EXEC_OMP_ORDERED:
9023 case EXEC_OMP_PARALLEL:
9024 case EXEC_OMP_PARALLEL_DO:
9025 case EXEC_OMP_PARALLEL_SECTIONS:
9026 case EXEC_OMP_PARALLEL_WORKSHARE:
9027 case EXEC_OMP_SECTIONS:
9028 case EXEC_OMP_SINGLE:
9030 case EXEC_OMP_TASKWAIT:
9031 case EXEC_OMP_TASKYIELD:
9032 case EXEC_OMP_WORKSHARE:
9036 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9039 resolve_code (b->next, ns);
9044 /* Does everything to resolve an ordinary assignment. Returns true
9045 if this is an interface assignment. */
9047 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
9057 if (gfc_extend_assign (code, ns) == SUCCESS)
9061 if (code->op == EXEC_ASSIGN_CALL)
9063 lhs = code->ext.actual->expr;
9064 rhsptr = &code->ext.actual->next->expr;
9068 gfc_actual_arglist* args;
9069 gfc_typebound_proc* tbp;
9071 gcc_assert (code->op == EXEC_COMPCALL);
9073 args = code->expr1->value.compcall.actual;
9075 rhsptr = &args->next->expr;
9077 tbp = code->expr1->value.compcall.tbp;
9078 gcc_assert (!tbp->is_generic);
9081 /* Make a temporary rhs when there is a default initializer
9082 and rhs is the same symbol as the lhs. */
9083 if ((*rhsptr)->expr_type == EXPR_VARIABLE
9084 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
9085 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
9086 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
9087 *rhsptr = gfc_get_parentheses (*rhsptr);
9096 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
9097 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9098 &code->loc) == FAILURE)
9101 /* Handle the case of a BOZ literal on the RHS. */
9102 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
9105 if (gfc_option.warn_surprising)
9106 gfc_warning ("BOZ literal at %L is bitwise transferred "
9107 "non-integer symbol '%s'", &code->loc,
9108 lhs->symtree->n.sym->name);
9110 if (!gfc_convert_boz (rhs, &lhs->ts))
9112 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
9114 if (rc == ARITH_UNDERFLOW)
9115 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9116 ". This check can be disabled with the option "
9117 "-fno-range-check", &rhs->where);
9118 else if (rc == ARITH_OVERFLOW)
9119 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9120 ". This check can be disabled with the option "
9121 "-fno-range-check", &rhs->where);
9122 else if (rc == ARITH_NAN)
9123 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9124 ". This check can be disabled with the option "
9125 "-fno-range-check", &rhs->where);
9130 if (lhs->ts.type == BT_CHARACTER
9131 && gfc_option.warn_character_truncation)
9133 if (lhs->ts.u.cl != NULL
9134 && lhs->ts.u.cl->length != NULL
9135 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9136 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
9138 if (rhs->expr_type == EXPR_CONSTANT)
9139 rlen = rhs->value.character.length;
9141 else if (rhs->ts.u.cl != NULL
9142 && rhs->ts.u.cl->length != NULL
9143 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9144 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
9146 if (rlen && llen && rlen > llen)
9147 gfc_warning_now ("CHARACTER expression will be truncated "
9148 "in assignment (%d/%d) at %L",
9149 llen, rlen, &code->loc);
9152 /* Ensure that a vector index expression for the lvalue is evaluated
9153 to a temporary if the lvalue symbol is referenced in it. */
9156 for (ref = lhs->ref; ref; ref= ref->next)
9157 if (ref->type == REF_ARRAY)
9159 for (n = 0; n < ref->u.ar.dimen; n++)
9160 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
9161 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
9162 ref->u.ar.start[n]))
9164 = gfc_get_parentheses (ref->u.ar.start[n]);
9168 if (gfc_pure (NULL))
9170 if (lhs->ts.type == BT_DERIVED
9171 && lhs->expr_type == EXPR_VARIABLE
9172 && lhs->ts.u.derived->attr.pointer_comp
9173 && rhs->expr_type == EXPR_VARIABLE
9174 && (gfc_impure_variable (rhs->symtree->n.sym)
9175 || gfc_is_coindexed (rhs)))
9178 if (gfc_is_coindexed (rhs))
9179 gfc_error ("Coindexed expression at %L is assigned to "
9180 "a derived type variable with a POINTER "
9181 "component in a PURE procedure",
9184 gfc_error ("The impure variable at %L is assigned to "
9185 "a derived type variable with a POINTER "
9186 "component in a PURE procedure (12.6)",
9191 /* Fortran 2008, C1283. */
9192 if (gfc_is_coindexed (lhs))
9194 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9195 "procedure", &rhs->where);
9200 if (gfc_implicit_pure (NULL))
9202 if (lhs->expr_type == EXPR_VARIABLE
9203 && lhs->symtree->n.sym != gfc_current_ns->proc_name
9204 && lhs->symtree->n.sym->ns != gfc_current_ns)
9205 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9207 if (lhs->ts.type == BT_DERIVED
9208 && lhs->expr_type == EXPR_VARIABLE
9209 && lhs->ts.u.derived->attr.pointer_comp
9210 && rhs->expr_type == EXPR_VARIABLE
9211 && (gfc_impure_variable (rhs->symtree->n.sym)
9212 || gfc_is_coindexed (rhs)))
9213 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9215 /* Fortran 2008, C1283. */
9216 if (gfc_is_coindexed (lhs))
9217 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9221 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9222 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9223 if (lhs->ts.type == BT_CLASS)
9225 gfc_error ("Variable must not be polymorphic in intrinsic assignment at "
9226 "%L - check that there is a matching specific subroutine "
9227 "for '=' operator", &lhs->where);
9231 /* F2008, Section 7.2.1.2. */
9232 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
9234 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9235 "component in assignment at %L", &lhs->where);
9239 gfc_check_assign (lhs, rhs, 1);
9244 /* Given a block of code, recursively resolve everything pointed to by this
9248 resolve_code (gfc_code *code, gfc_namespace *ns)
9250 int omp_workshare_save;
9251 int forall_save, do_concurrent_save;
9255 frame.prev = cs_base;
9259 find_reachable_labels (code);
9261 for (; code; code = code->next)
9263 frame.current = code;
9264 forall_save = forall_flag;
9265 do_concurrent_save = do_concurrent_flag;
9267 if (code->op == EXEC_FORALL)
9270 gfc_resolve_forall (code, ns, forall_save);
9273 else if (code->block)
9275 omp_workshare_save = -1;
9278 case EXEC_OMP_PARALLEL_WORKSHARE:
9279 omp_workshare_save = omp_workshare_flag;
9280 omp_workshare_flag = 1;
9281 gfc_resolve_omp_parallel_blocks (code, ns);
9283 case EXEC_OMP_PARALLEL:
9284 case EXEC_OMP_PARALLEL_DO:
9285 case EXEC_OMP_PARALLEL_SECTIONS:
9287 omp_workshare_save = omp_workshare_flag;
9288 omp_workshare_flag = 0;
9289 gfc_resolve_omp_parallel_blocks (code, ns);
9292 gfc_resolve_omp_do_blocks (code, ns);
9294 case EXEC_SELECT_TYPE:
9295 /* Blocks are handled in resolve_select_type because we have
9296 to transform the SELECT TYPE into ASSOCIATE first. */
9298 case EXEC_DO_CONCURRENT:
9299 do_concurrent_flag = 1;
9300 gfc_resolve_blocks (code->block, ns);
9301 do_concurrent_flag = 2;
9303 case EXEC_OMP_WORKSHARE:
9304 omp_workshare_save = omp_workshare_flag;
9305 omp_workshare_flag = 1;
9308 gfc_resolve_blocks (code->block, ns);
9312 if (omp_workshare_save != -1)
9313 omp_workshare_flag = omp_workshare_save;
9317 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
9318 t = gfc_resolve_expr (code->expr1);
9319 forall_flag = forall_save;
9320 do_concurrent_flag = do_concurrent_save;
9322 if (gfc_resolve_expr (code->expr2) == FAILURE)
9325 if (code->op == EXEC_ALLOCATE
9326 && gfc_resolve_expr (code->expr3) == FAILURE)
9332 case EXEC_END_BLOCK:
9333 case EXEC_END_NESTED_BLOCK:
9337 case EXEC_ERROR_STOP:
9341 case EXEC_ASSIGN_CALL:
9346 case EXEC_SYNC_IMAGES:
9347 case EXEC_SYNC_MEMORY:
9348 resolve_sync (code);
9353 resolve_lock_unlock (code);
9357 /* Keep track of which entry we are up to. */
9358 current_entry_id = code->ext.entry->id;
9362 resolve_where (code, NULL);
9366 if (code->expr1 != NULL)
9368 if (code->expr1->ts.type != BT_INTEGER)
9369 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9370 "INTEGER variable", &code->expr1->where);
9371 else if (code->expr1->symtree->n.sym->attr.assign != 1)
9372 gfc_error ("Variable '%s' has not been assigned a target "
9373 "label at %L", code->expr1->symtree->n.sym->name,
9374 &code->expr1->where);
9377 resolve_branch (code->label1, code);
9381 if (code->expr1 != NULL
9382 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
9383 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9384 "INTEGER return specifier", &code->expr1->where);
9387 case EXEC_INIT_ASSIGN:
9388 case EXEC_END_PROCEDURE:
9395 if (gfc_check_vardef_context (code->expr1, false, false,
9396 _("assignment")) == FAILURE)
9399 if (resolve_ordinary_assign (code, ns))
9401 if (code->op == EXEC_COMPCALL)
9408 case EXEC_LABEL_ASSIGN:
9409 if (code->label1->defined == ST_LABEL_UNKNOWN)
9410 gfc_error ("Label %d referenced at %L is never defined",
9411 code->label1->value, &code->label1->where);
9413 && (code->expr1->expr_type != EXPR_VARIABLE
9414 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
9415 || code->expr1->symtree->n.sym->ts.kind
9416 != gfc_default_integer_kind
9417 || code->expr1->symtree->n.sym->as != NULL))
9418 gfc_error ("ASSIGN statement at %L requires a scalar "
9419 "default INTEGER variable", &code->expr1->where);
9422 case EXEC_POINTER_ASSIGN:
9429 /* This is both a variable definition and pointer assignment
9430 context, so check both of them. For rank remapping, a final
9431 array ref may be present on the LHS and fool gfc_expr_attr
9432 used in gfc_check_vardef_context. Remove it. */
9433 e = remove_last_array_ref (code->expr1);
9434 t = gfc_check_vardef_context (e, true, false,
9435 _("pointer assignment"));
9437 t = gfc_check_vardef_context (e, false, false,
9438 _("pointer assignment"));
9443 gfc_check_pointer_assign (code->expr1, code->expr2);
9447 case EXEC_ARITHMETIC_IF:
9449 && code->expr1->ts.type != BT_INTEGER
9450 && code->expr1->ts.type != BT_REAL)
9451 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9452 "expression", &code->expr1->where);
9454 resolve_branch (code->label1, code);
9455 resolve_branch (code->label2, code);
9456 resolve_branch (code->label3, code);
9460 if (t == SUCCESS && code->expr1 != NULL
9461 && (code->expr1->ts.type != BT_LOGICAL
9462 || code->expr1->rank != 0))
9463 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9464 &code->expr1->where);
9469 resolve_call (code);
9474 resolve_typebound_subroutine (code);
9478 resolve_ppc_call (code);
9482 /* Select is complicated. Also, a SELECT construct could be
9483 a transformed computed GOTO. */
9484 resolve_select (code);
9487 case EXEC_SELECT_TYPE:
9488 resolve_select_type (code, ns);
9492 resolve_block_construct (code);
9496 if (code->ext.iterator != NULL)
9498 gfc_iterator *iter = code->ext.iterator;
9499 if (gfc_resolve_iterator (iter, true) != FAILURE)
9500 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
9505 if (code->expr1 == NULL)
9506 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9508 && (code->expr1->rank != 0
9509 || code->expr1->ts.type != BT_LOGICAL))
9510 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9511 "a scalar LOGICAL expression", &code->expr1->where);
9516 resolve_allocate_deallocate (code, "ALLOCATE");
9520 case EXEC_DEALLOCATE:
9522 resolve_allocate_deallocate (code, "DEALLOCATE");
9527 if (gfc_resolve_open (code->ext.open) == FAILURE)
9530 resolve_branch (code->ext.open->err, code);
9534 if (gfc_resolve_close (code->ext.close) == FAILURE)
9537 resolve_branch (code->ext.close->err, code);
9540 case EXEC_BACKSPACE:
9544 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
9547 resolve_branch (code->ext.filepos->err, code);
9551 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9554 resolve_branch (code->ext.inquire->err, code);
9558 gcc_assert (code->ext.inquire != NULL);
9559 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9562 resolve_branch (code->ext.inquire->err, code);
9566 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
9569 resolve_branch (code->ext.wait->err, code);
9570 resolve_branch (code->ext.wait->end, code);
9571 resolve_branch (code->ext.wait->eor, code);
9576 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
9579 resolve_branch (code->ext.dt->err, code);
9580 resolve_branch (code->ext.dt->end, code);
9581 resolve_branch (code->ext.dt->eor, code);
9585 resolve_transfer (code);
9588 case EXEC_DO_CONCURRENT:
9590 resolve_forall_iterators (code->ext.forall_iterator);
9592 if (code->expr1 != NULL
9593 && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
9594 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9595 "expression", &code->expr1->where);
9598 case EXEC_OMP_ATOMIC:
9599 case EXEC_OMP_BARRIER:
9600 case EXEC_OMP_CRITICAL:
9601 case EXEC_OMP_FLUSH:
9603 case EXEC_OMP_MASTER:
9604 case EXEC_OMP_ORDERED:
9605 case EXEC_OMP_SECTIONS:
9606 case EXEC_OMP_SINGLE:
9607 case EXEC_OMP_TASKWAIT:
9608 case EXEC_OMP_TASKYIELD:
9609 case EXEC_OMP_WORKSHARE:
9610 gfc_resolve_omp_directive (code, ns);
9613 case EXEC_OMP_PARALLEL:
9614 case EXEC_OMP_PARALLEL_DO:
9615 case EXEC_OMP_PARALLEL_SECTIONS:
9616 case EXEC_OMP_PARALLEL_WORKSHARE:
9618 omp_workshare_save = omp_workshare_flag;
9619 omp_workshare_flag = 0;
9620 gfc_resolve_omp_directive (code, ns);
9621 omp_workshare_flag = omp_workshare_save;
9625 gfc_internal_error ("resolve_code(): Bad statement code");
9629 cs_base = frame.prev;
9633 /* Resolve initial values and make sure they are compatible with
9637 resolve_values (gfc_symbol *sym)
9641 if (sym->value == NULL)
9644 if (sym->value->expr_type == EXPR_STRUCTURE)
9645 t= resolve_structure_cons (sym->value, 1);
9647 t = gfc_resolve_expr (sym->value);
9652 gfc_check_assign_symbol (sym, sym->value);
9656 /* Verify the binding labels for common blocks that are BIND(C). The label
9657 for a BIND(C) common block must be identical in all scoping units in which
9658 the common block is declared. Further, the binding label can not collide
9659 with any other global entity in the program. */
9662 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
9664 if (comm_block_tree->n.common->is_bind_c == 1)
9666 gfc_gsymbol *binding_label_gsym;
9667 gfc_gsymbol *comm_name_gsym;
9668 const char * bind_label = comm_block_tree->n.common->binding_label
9669 ? comm_block_tree->n.common->binding_label : "";
9671 /* See if a global symbol exists by the common block's name. It may
9672 be NULL if the common block is use-associated. */
9673 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
9674 comm_block_tree->n.common->name);
9675 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
9676 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9677 "with the global entity '%s' at %L",
9679 comm_block_tree->n.common->name,
9680 &(comm_block_tree->n.common->where),
9681 comm_name_gsym->name, &(comm_name_gsym->where));
9682 else if (comm_name_gsym != NULL
9683 && strcmp (comm_name_gsym->name,
9684 comm_block_tree->n.common->name) == 0)
9686 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9688 if (comm_name_gsym->binding_label == NULL)
9689 /* No binding label for common block stored yet; save this one. */
9690 comm_name_gsym->binding_label = bind_label;
9691 else if (strcmp (comm_name_gsym->binding_label, bind_label) != 0)
9693 /* Common block names match but binding labels do not. */
9694 gfc_error ("Binding label '%s' for common block '%s' at %L "
9695 "does not match the binding label '%s' for common "
9698 comm_block_tree->n.common->name,
9699 &(comm_block_tree->n.common->where),
9700 comm_name_gsym->binding_label,
9701 comm_name_gsym->name,
9702 &(comm_name_gsym->where));
9707 /* There is no binding label (NAME="") so we have nothing further to
9708 check and nothing to add as a global symbol for the label. */
9709 if (!comm_block_tree->n.common->binding_label)
9712 binding_label_gsym =
9713 gfc_find_gsymbol (gfc_gsym_root,
9714 comm_block_tree->n.common->binding_label);
9715 if (binding_label_gsym == NULL)
9717 /* Need to make a global symbol for the binding label to prevent
9718 it from colliding with another. */
9719 binding_label_gsym =
9720 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9721 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9722 binding_label_gsym->type = GSYM_COMMON;
9726 /* If comm_name_gsym is NULL, the name common block is use
9727 associated and the name could be colliding. */
9728 if (binding_label_gsym->type != GSYM_COMMON)
9729 gfc_error ("Binding label '%s' for common block '%s' at %L "
9730 "collides with the global entity '%s' at %L",
9731 comm_block_tree->n.common->binding_label,
9732 comm_block_tree->n.common->name,
9733 &(comm_block_tree->n.common->where),
9734 binding_label_gsym->name,
9735 &(binding_label_gsym->where));
9736 else if (comm_name_gsym != NULL
9737 && (strcmp (binding_label_gsym->name,
9738 comm_name_gsym->binding_label) != 0)
9739 && (strcmp (binding_label_gsym->sym_name,
9740 comm_name_gsym->name) != 0))
9741 gfc_error ("Binding label '%s' for common block '%s' at %L "
9742 "collides with global entity '%s' at %L",
9743 binding_label_gsym->name, binding_label_gsym->sym_name,
9744 &(comm_block_tree->n.common->where),
9745 comm_name_gsym->name, &(comm_name_gsym->where));
9753 /* Verify any BIND(C) derived types in the namespace so we can report errors
9754 for them once, rather than for each variable declared of that type. */
9757 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9759 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9760 && derived_sym->attr.is_bind_c == 1)
9761 verify_bind_c_derived_type (derived_sym);
9767 /* Verify that any binding labels used in a given namespace do not collide
9768 with the names or binding labels of any global symbols. */
9771 gfc_verify_binding_labels (gfc_symbol *sym)
9775 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9776 && sym->attr.flavor != FL_DERIVED && sym->binding_label)
9778 gfc_gsymbol *bind_c_sym;
9780 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9781 if (bind_c_sym != NULL
9782 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9784 if (sym->attr.if_source == IFSRC_DECL
9785 && (bind_c_sym->type != GSYM_SUBROUTINE
9786 && bind_c_sym->type != GSYM_FUNCTION)
9787 && ((sym->attr.contained == 1
9788 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9789 || (sym->attr.use_assoc == 1
9790 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9792 /* Make sure global procedures don't collide with anything. */
9793 gfc_error ("Binding label '%s' at %L collides with the global "
9794 "entity '%s' at %L", sym->binding_label,
9795 &(sym->declared_at), bind_c_sym->name,
9796 &(bind_c_sym->where));
9799 else if (sym->attr.contained == 0
9800 && (sym->attr.if_source == IFSRC_IFBODY
9801 && sym->attr.flavor == FL_PROCEDURE)
9802 && (bind_c_sym->sym_name != NULL
9803 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9805 /* Make sure procedures in interface bodies don't collide. */
9806 gfc_error ("Binding label '%s' in interface body at %L collides "
9807 "with the global entity '%s' at %L",
9809 &(sym->declared_at), bind_c_sym->name,
9810 &(bind_c_sym->where));
9813 else if (sym->attr.contained == 0
9814 && sym->attr.if_source == IFSRC_UNKNOWN)
9815 if ((sym->attr.use_assoc && bind_c_sym->mod_name
9816 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9817 || sym->attr.use_assoc == 0)
9819 gfc_error ("Binding label '%s' at %L collides with global "
9820 "entity '%s' at %L", sym->binding_label,
9821 &(sym->declared_at), bind_c_sym->name,
9822 &(bind_c_sym->where));
9827 /* Clear the binding label to prevent checking multiple times. */
9828 sym->binding_label = NULL;
9830 else if (bind_c_sym == NULL)
9832 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9833 bind_c_sym->where = sym->declared_at;
9834 bind_c_sym->sym_name = sym->name;
9836 if (sym->attr.use_assoc == 1)
9837 bind_c_sym->mod_name = sym->module;
9839 if (sym->ns->proc_name != NULL)
9840 bind_c_sym->mod_name = sym->ns->proc_name->name;
9842 if (sym->attr.contained == 0)
9844 if (sym->attr.subroutine)
9845 bind_c_sym->type = GSYM_SUBROUTINE;
9846 else if (sym->attr.function)
9847 bind_c_sym->type = GSYM_FUNCTION;
9855 /* Resolve an index expression. */
9858 resolve_index_expr (gfc_expr *e)
9860 if (gfc_resolve_expr (e) == FAILURE)
9863 if (gfc_simplify_expr (e, 0) == FAILURE)
9866 if (gfc_specification_expr (e) == FAILURE)
9873 /* Resolve a charlen structure. */
9876 resolve_charlen (gfc_charlen *cl)
9885 specification_expr = 1;
9887 if (resolve_index_expr (cl->length) == FAILURE)
9889 specification_expr = 0;
9893 /* "If the character length parameter value evaluates to a negative
9894 value, the length of character entities declared is zero." */
9895 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9897 if (gfc_option.warn_surprising)
9898 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9899 " the length has been set to zero",
9900 &cl->length->where, i);
9901 gfc_replace_expr (cl->length,
9902 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9905 /* Check that the character length is not too large. */
9906 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9907 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9908 && cl->length->ts.type == BT_INTEGER
9909 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9911 gfc_error ("String length at %L is too large", &cl->length->where);
9919 /* Test for non-constant shape arrays. */
9922 is_non_constant_shape_array (gfc_symbol *sym)
9928 not_constant = false;
9929 if (sym->as != NULL)
9931 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9932 has not been simplified; parameter array references. Do the
9933 simplification now. */
9934 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9936 e = sym->as->lower[i];
9937 if (e && (resolve_index_expr (e) == FAILURE
9938 || !gfc_is_constant_expr (e)))
9939 not_constant = true;
9940 e = sym->as->upper[i];
9941 if (e && (resolve_index_expr (e) == FAILURE
9942 || !gfc_is_constant_expr (e)))
9943 not_constant = true;
9946 return not_constant;
9949 /* Given a symbol and an initialization expression, add code to initialize
9950 the symbol to the function entry. */
9952 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9956 gfc_namespace *ns = sym->ns;
9958 /* Search for the function namespace if this is a contained
9959 function without an explicit result. */
9960 if (sym->attr.function && sym == sym->result
9961 && sym->name != sym->ns->proc_name->name)
9964 for (;ns; ns = ns->sibling)
9965 if (strcmp (ns->proc_name->name, sym->name) == 0)
9971 gfc_free_expr (init);
9975 /* Build an l-value expression for the result. */
9976 lval = gfc_lval_expr_from_sym (sym);
9978 /* Add the code at scope entry. */
9979 init_st = gfc_get_code ();
9980 init_st->next = ns->code;
9983 /* Assign the default initializer to the l-value. */
9984 init_st->loc = sym->declared_at;
9985 init_st->op = EXEC_INIT_ASSIGN;
9986 init_st->expr1 = lval;
9987 init_st->expr2 = init;
9990 /* Assign the default initializer to a derived type variable or result. */
9993 apply_default_init (gfc_symbol *sym)
9995 gfc_expr *init = NULL;
9997 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
10000 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
10001 init = gfc_default_initializer (&sym->ts);
10003 if (init == NULL && sym->ts.type != BT_CLASS)
10006 build_init_assign (sym, init);
10007 sym->attr.referenced = 1;
10010 /* Build an initializer for a local integer, real, complex, logical, or
10011 character variable, based on the command line flags finit-local-zero,
10012 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10013 null if the symbol should not have a default initialization. */
10015 build_default_init_expr (gfc_symbol *sym)
10018 gfc_expr *init_expr;
10021 /* These symbols should never have a default initialization. */
10022 if (sym->attr.allocatable
10023 || sym->attr.external
10025 || sym->attr.pointer
10026 || sym->attr.in_equivalence
10027 || sym->attr.in_common
10030 || sym->attr.cray_pointee
10031 || sym->attr.cray_pointer)
10034 /* Now we'll try to build an initializer expression. */
10035 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
10036 &sym->declared_at);
10038 /* We will only initialize integers, reals, complex, logicals, and
10039 characters, and only if the corresponding command-line flags
10040 were set. Otherwise, we free init_expr and return null. */
10041 switch (sym->ts.type)
10044 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
10045 mpz_set_si (init_expr->value.integer,
10046 gfc_option.flag_init_integer_value);
10049 gfc_free_expr (init_expr);
10055 switch (gfc_option.flag_init_real)
10057 case GFC_INIT_REAL_SNAN:
10058 init_expr->is_snan = 1;
10059 /* Fall through. */
10060 case GFC_INIT_REAL_NAN:
10061 mpfr_set_nan (init_expr->value.real);
10064 case GFC_INIT_REAL_INF:
10065 mpfr_set_inf (init_expr->value.real, 1);
10068 case GFC_INIT_REAL_NEG_INF:
10069 mpfr_set_inf (init_expr->value.real, -1);
10072 case GFC_INIT_REAL_ZERO:
10073 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
10077 gfc_free_expr (init_expr);
10084 switch (gfc_option.flag_init_real)
10086 case GFC_INIT_REAL_SNAN:
10087 init_expr->is_snan = 1;
10088 /* Fall through. */
10089 case GFC_INIT_REAL_NAN:
10090 mpfr_set_nan (mpc_realref (init_expr->value.complex));
10091 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
10094 case GFC_INIT_REAL_INF:
10095 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
10096 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
10099 case GFC_INIT_REAL_NEG_INF:
10100 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
10101 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
10104 case GFC_INIT_REAL_ZERO:
10105 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
10109 gfc_free_expr (init_expr);
10116 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
10117 init_expr->value.logical = 0;
10118 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
10119 init_expr->value.logical = 1;
10122 gfc_free_expr (init_expr);
10128 /* For characters, the length must be constant in order to
10129 create a default initializer. */
10130 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
10131 && sym->ts.u.cl->length
10132 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
10134 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
10135 init_expr->value.character.length = char_len;
10136 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
10137 for (i = 0; i < char_len; i++)
10138 init_expr->value.character.string[i]
10139 = (unsigned char) gfc_option.flag_init_character_value;
10143 gfc_free_expr (init_expr);
10146 if (!init_expr && gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
10147 && sym->ts.u.cl->length)
10149 gfc_actual_arglist *arg;
10150 init_expr = gfc_get_expr ();
10151 init_expr->where = sym->declared_at;
10152 init_expr->ts = sym->ts;
10153 init_expr->expr_type = EXPR_FUNCTION;
10154 init_expr->value.function.isym =
10155 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT);
10156 init_expr->value.function.name = "repeat";
10157 arg = gfc_get_actual_arglist ();
10158 arg->expr = gfc_get_character_expr (sym->ts.kind, &sym->declared_at,
10160 arg->expr->value.character.string[0]
10161 = gfc_option.flag_init_character_value;
10162 arg->next = gfc_get_actual_arglist ();
10163 arg->next->expr = gfc_copy_expr (sym->ts.u.cl->length);
10164 init_expr->value.function.actual = arg;
10169 gfc_free_expr (init_expr);
10175 /* Add an initialization expression to a local variable. */
10177 apply_default_init_local (gfc_symbol *sym)
10179 gfc_expr *init = NULL;
10181 /* The symbol should be a variable or a function return value. */
10182 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
10183 || (sym->attr.function && sym->result != sym))
10186 /* Try to build the initializer expression. If we can't initialize
10187 this symbol, then init will be NULL. */
10188 init = build_default_init_expr (sym);
10192 /* For saved variables, we don't want to add an initializer at function
10193 entry, so we just add a static initializer. Note that automatic variables
10194 are stack allocated even with -fno-automatic. */
10195 if (sym->attr.save || sym->ns->save_all
10196 || (gfc_option.flag_max_stack_var_size == 0
10197 && (!sym->attr.dimension || !is_non_constant_shape_array (sym))))
10199 /* Don't clobber an existing initializer! */
10200 gcc_assert (sym->value == NULL);
10205 build_init_assign (sym, init);
10209 /* Resolution of common features of flavors variable and procedure. */
10212 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
10214 gfc_array_spec *as;
10216 /* Avoid double diagnostics for function result symbols. */
10217 if ((sym->result || sym->attr.result) && !sym->attr.dummy
10218 && (sym->ns != gfc_current_ns))
10221 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
10222 as = CLASS_DATA (sym)->as;
10226 /* Constraints on deferred shape variable. */
10227 if (as == NULL || as->type != AS_DEFERRED)
10229 bool pointer, allocatable, dimension;
10231 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
10233 pointer = CLASS_DATA (sym)->attr.class_pointer;
10234 allocatable = CLASS_DATA (sym)->attr.allocatable;
10235 dimension = CLASS_DATA (sym)->attr.dimension;
10239 pointer = sym->attr.pointer;
10240 allocatable = sym->attr.allocatable;
10241 dimension = sym->attr.dimension;
10248 gfc_error ("Allocatable array '%s' at %L must have "
10249 "a deferred shape", sym->name, &sym->declared_at);
10252 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
10253 "may not be ALLOCATABLE", sym->name,
10254 &sym->declared_at) == FAILURE)
10258 if (pointer && dimension)
10260 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
10261 sym->name, &sym->declared_at);
10267 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
10268 && sym->ts.type != BT_CLASS && !sym->assoc)
10270 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10271 sym->name, &sym->declared_at);
10276 /* Constraints on polymorphic variables. */
10277 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
10280 if (sym->attr.class_ok
10281 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
10283 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10284 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
10285 &sym->declared_at);
10290 /* Assume that use associated symbols were checked in the module ns.
10291 Class-variables that are associate-names are also something special
10292 and excepted from the test. */
10293 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
10295 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10296 "or pointer", sym->name, &sym->declared_at);
10305 /* Additional checks for symbols with flavor variable and derived
10306 type. To be called from resolve_fl_variable. */
10309 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
10311 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
10313 /* Check to see if a derived type is blocked from being host
10314 associated by the presence of another class I symbol in the same
10315 namespace. 14.6.1.3 of the standard and the discussion on
10316 comp.lang.fortran. */
10317 if (sym->ns != sym->ts.u.derived->ns
10318 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
10321 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
10322 if (s && s->attr.generic)
10323 s = gfc_find_dt_in_generic (s);
10324 if (s && s->attr.flavor != FL_DERIVED)
10326 gfc_error ("The type '%s' cannot be host associated at %L "
10327 "because it is blocked by an incompatible object "
10328 "of the same name declared at %L",
10329 sym->ts.u.derived->name, &sym->declared_at,
10335 /* 4th constraint in section 11.3: "If an object of a type for which
10336 component-initialization is specified (R429) appears in the
10337 specification-part of a module and does not have the ALLOCATABLE
10338 or POINTER attribute, the object shall have the SAVE attribute."
10340 The check for initializers is performed with
10341 gfc_has_default_initializer because gfc_default_initializer generates
10342 a hidden default for allocatable components. */
10343 if (!(sym->value || no_init_flag) && sym->ns->proc_name
10344 && sym->ns->proc_name->attr.flavor == FL_MODULE
10345 && !sym->ns->save_all && !sym->attr.save
10346 && !sym->attr.pointer && !sym->attr.allocatable
10347 && gfc_has_default_initializer (sym->ts.u.derived)
10348 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
10349 "module variable '%s' at %L, needed due to "
10350 "the default initialization", sym->name,
10351 &sym->declared_at) == FAILURE)
10354 /* Assign default initializer. */
10355 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
10356 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
10358 sym->value = gfc_default_initializer (&sym->ts);
10365 /* Resolve symbols with flavor variable. */
10368 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
10370 int no_init_flag, automatic_flag;
10372 const char *auto_save_msg;
10374 auto_save_msg = "Automatic object '%s' at %L cannot have the "
10377 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10380 /* Set this flag to check that variables are parameters of all entries.
10381 This check is effected by the call to gfc_resolve_expr through
10382 is_non_constant_shape_array. */
10383 specification_expr = 1;
10385 if (sym->ns->proc_name
10386 && (sym->ns->proc_name->attr.flavor == FL_MODULE
10387 || sym->ns->proc_name->attr.is_main_program)
10388 && !sym->attr.use_assoc
10389 && !sym->attr.allocatable
10390 && !sym->attr.pointer
10391 && is_non_constant_shape_array (sym))
10393 /* The shape of a main program or module array needs to be
10395 gfc_error ("The module or main program array '%s' at %L must "
10396 "have constant shape", sym->name, &sym->declared_at);
10397 specification_expr = 0;
10401 /* Constraints on deferred type parameter. */
10402 if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
10404 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10405 "requires either the pointer or allocatable attribute",
10406 sym->name, &sym->declared_at);
10410 if (sym->ts.type == BT_CHARACTER)
10412 /* Make sure that character string variables with assumed length are
10413 dummy arguments. */
10414 e = sym->ts.u.cl->length;
10415 if (e == NULL && !sym->attr.dummy && !sym->attr.result
10416 && !sym->ts.deferred)
10418 gfc_error ("Entity with assumed character length at %L must be a "
10419 "dummy argument or a PARAMETER", &sym->declared_at);
10423 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
10425 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10429 if (!gfc_is_constant_expr (e)
10430 && !(e->expr_type == EXPR_VARIABLE
10431 && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
10433 if (!sym->attr.use_assoc && sym->ns->proc_name
10434 && (sym->ns->proc_name->attr.flavor == FL_MODULE
10435 || sym->ns->proc_name->attr.is_main_program))
10437 gfc_error ("'%s' at %L must have constant character length "
10438 "in this context", sym->name, &sym->declared_at);
10441 if (sym->attr.in_common)
10443 gfc_error ("COMMON variable '%s' at %L must have constant "
10444 "character length", sym->name, &sym->declared_at);
10450 if (sym->value == NULL && sym->attr.referenced)
10451 apply_default_init_local (sym); /* Try to apply a default initialization. */
10453 /* Determine if the symbol may not have an initializer. */
10454 no_init_flag = automatic_flag = 0;
10455 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
10456 || sym->attr.intrinsic || sym->attr.result)
10458 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
10459 && is_non_constant_shape_array (sym))
10461 no_init_flag = automatic_flag = 1;
10463 /* Also, they must not have the SAVE attribute.
10464 SAVE_IMPLICIT is checked below. */
10465 if (sym->as && sym->attr.codimension)
10467 int corank = sym->as->corank;
10468 sym->as->corank = 0;
10469 no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
10470 sym->as->corank = corank;
10472 if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
10474 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10479 /* Ensure that any initializer is simplified. */
10481 gfc_simplify_expr (sym->value, 1);
10483 /* Reject illegal initializers. */
10484 if (!sym->mark && sym->value)
10486 if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
10487 && CLASS_DATA (sym)->attr.allocatable))
10488 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10489 sym->name, &sym->declared_at);
10490 else if (sym->attr.external)
10491 gfc_error ("External '%s' at %L cannot have an initializer",
10492 sym->name, &sym->declared_at);
10493 else if (sym->attr.dummy
10494 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
10495 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10496 sym->name, &sym->declared_at);
10497 else if (sym->attr.intrinsic)
10498 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10499 sym->name, &sym->declared_at);
10500 else if (sym->attr.result)
10501 gfc_error ("Function result '%s' at %L cannot have an initializer",
10502 sym->name, &sym->declared_at);
10503 else if (automatic_flag)
10504 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10505 sym->name, &sym->declared_at);
10507 goto no_init_error;
10512 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
10513 return resolve_fl_variable_derived (sym, no_init_flag);
10519 /* Resolve a procedure. */
10522 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
10524 gfc_formal_arglist *arg;
10526 if (sym->attr.function
10527 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10530 if (sym->ts.type == BT_CHARACTER)
10532 gfc_charlen *cl = sym->ts.u.cl;
10534 if (cl && cl->length && gfc_is_constant_expr (cl->length)
10535 && resolve_charlen (cl) == FAILURE)
10538 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
10539 && sym->attr.proc == PROC_ST_FUNCTION)
10541 gfc_error ("Character-valued statement function '%s' at %L must "
10542 "have constant length", sym->name, &sym->declared_at);
10547 /* Ensure that derived type for are not of a private type. Internal
10548 module procedures are excluded by 2.2.3.3 - i.e., they are not
10549 externally accessible and can access all the objects accessible in
10551 if (!(sym->ns->parent
10552 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
10553 && gfc_check_symbol_access (sym))
10555 gfc_interface *iface;
10557 for (arg = sym->formal; arg; arg = arg->next)
10560 && arg->sym->ts.type == BT_DERIVED
10561 && !arg->sym->ts.u.derived->attr.use_assoc
10562 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10563 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
10564 "PRIVATE type and cannot be a dummy argument"
10565 " of '%s', which is PUBLIC at %L",
10566 arg->sym->name, sym->name, &sym->declared_at)
10569 /* Stop this message from recurring. */
10570 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10575 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10576 PRIVATE to the containing module. */
10577 for (iface = sym->generic; iface; iface = iface->next)
10579 for (arg = iface->sym->formal; arg; arg = arg->next)
10582 && arg->sym->ts.type == BT_DERIVED
10583 && !arg->sym->ts.u.derived->attr.use_assoc
10584 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10585 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10586 "'%s' in PUBLIC interface '%s' at %L "
10587 "takes dummy arguments of '%s' which is "
10588 "PRIVATE", iface->sym->name, sym->name,
10589 &iface->sym->declared_at,
10590 gfc_typename (&arg->sym->ts)) == FAILURE)
10592 /* Stop this message from recurring. */
10593 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10599 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10600 PRIVATE to the containing module. */
10601 for (iface = sym->generic; iface; iface = iface->next)
10603 for (arg = iface->sym->formal; arg; arg = arg->next)
10606 && arg->sym->ts.type == BT_DERIVED
10607 && !arg->sym->ts.u.derived->attr.use_assoc
10608 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10609 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10610 "'%s' in PUBLIC interface '%s' at %L "
10611 "takes dummy arguments of '%s' which is "
10612 "PRIVATE", iface->sym->name, sym->name,
10613 &iface->sym->declared_at,
10614 gfc_typename (&arg->sym->ts)) == FAILURE)
10616 /* Stop this message from recurring. */
10617 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10624 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10625 && !sym->attr.proc_pointer)
10627 gfc_error ("Function '%s' at %L cannot have an initializer",
10628 sym->name, &sym->declared_at);
10632 /* An external symbol may not have an initializer because it is taken to be
10633 a procedure. Exception: Procedure Pointers. */
10634 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10636 gfc_error ("External object '%s' at %L may not have an initializer",
10637 sym->name, &sym->declared_at);
10641 /* An elemental function is required to return a scalar 12.7.1 */
10642 if (sym->attr.elemental && sym->attr.function && sym->as)
10644 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10645 "result", sym->name, &sym->declared_at);
10646 /* Reset so that the error only occurs once. */
10647 sym->attr.elemental = 0;
10651 if (sym->attr.proc == PROC_ST_FUNCTION
10652 && (sym->attr.allocatable || sym->attr.pointer))
10654 gfc_error ("Statement function '%s' at %L may not have pointer or "
10655 "allocatable attribute", sym->name, &sym->declared_at);
10659 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10660 char-len-param shall not be array-valued, pointer-valued, recursive
10661 or pure. ....snip... A character value of * may only be used in the
10662 following ways: (i) Dummy arg of procedure - dummy associates with
10663 actual length; (ii) To declare a named constant; or (iii) External
10664 function - but length must be declared in calling scoping unit. */
10665 if (sym->attr.function
10666 && sym->ts.type == BT_CHARACTER
10667 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10669 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10670 || (sym->attr.recursive) || (sym->attr.pure))
10672 if (sym->as && sym->as->rank)
10673 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10674 "array-valued", sym->name, &sym->declared_at);
10676 if (sym->attr.pointer)
10677 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10678 "pointer-valued", sym->name, &sym->declared_at);
10680 if (sym->attr.pure)
10681 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10682 "pure", sym->name, &sym->declared_at);
10684 if (sym->attr.recursive)
10685 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10686 "recursive", sym->name, &sym->declared_at);
10691 /* Appendix B.2 of the standard. Contained functions give an
10692 error anyway. Fixed-form is likely to be F77/legacy. Deferred
10693 character length is an F2003 feature. */
10694 if (!sym->attr.contained
10695 && gfc_current_form != FORM_FIXED
10696 && !sym->ts.deferred)
10697 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10698 "CHARACTER(*) function '%s' at %L",
10699 sym->name, &sym->declared_at);
10702 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10704 gfc_formal_arglist *curr_arg;
10705 int has_non_interop_arg = 0;
10707 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10708 sym->common_block) == FAILURE)
10710 /* Clear these to prevent looking at them again if there was an
10712 sym->attr.is_bind_c = 0;
10713 sym->attr.is_c_interop = 0;
10714 sym->ts.is_c_interop = 0;
10718 /* So far, no errors have been found. */
10719 sym->attr.is_c_interop = 1;
10720 sym->ts.is_c_interop = 1;
10723 curr_arg = sym->formal;
10724 while (curr_arg != NULL)
10726 /* Skip implicitly typed dummy args here. */
10727 if (curr_arg->sym->attr.implicit_type == 0)
10728 if (gfc_verify_c_interop_param (curr_arg->sym) == FAILURE)
10729 /* If something is found to fail, record the fact so we
10730 can mark the symbol for the procedure as not being
10731 BIND(C) to try and prevent multiple errors being
10733 has_non_interop_arg = 1;
10735 curr_arg = curr_arg->next;
10738 /* See if any of the arguments were not interoperable and if so, clear
10739 the procedure symbol to prevent duplicate error messages. */
10740 if (has_non_interop_arg != 0)
10742 sym->attr.is_c_interop = 0;
10743 sym->ts.is_c_interop = 0;
10744 sym->attr.is_bind_c = 0;
10748 if (!sym->attr.proc_pointer)
10750 if (sym->attr.save == SAVE_EXPLICIT)
10752 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10753 "in '%s' at %L", sym->name, &sym->declared_at);
10756 if (sym->attr.intent)
10758 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10759 "in '%s' at %L", sym->name, &sym->declared_at);
10762 if (sym->attr.subroutine && sym->attr.result)
10764 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10765 "in '%s' at %L", sym->name, &sym->declared_at);
10768 if (sym->attr.external && sym->attr.function
10769 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10770 || sym->attr.contained))
10772 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10773 "in '%s' at %L", sym->name, &sym->declared_at);
10776 if (strcmp ("ppr@", sym->name) == 0)
10778 gfc_error ("Procedure pointer result '%s' at %L "
10779 "is missing the pointer attribute",
10780 sym->ns->proc_name->name, &sym->declared_at);
10789 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10790 been defined and we now know their defined arguments, check that they fulfill
10791 the requirements of the standard for procedures used as finalizers. */
10794 gfc_resolve_finalizers (gfc_symbol* derived)
10796 gfc_finalizer* list;
10797 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10798 gfc_try result = SUCCESS;
10799 bool seen_scalar = false;
10801 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10804 /* Walk over the list of finalizer-procedures, check them, and if any one
10805 does not fit in with the standard's definition, print an error and remove
10806 it from the list. */
10807 prev_link = &derived->f2k_derived->finalizers;
10808 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10814 /* Skip this finalizer if we already resolved it. */
10815 if (list->proc_tree)
10817 prev_link = &(list->next);
10821 /* Check this exists and is a SUBROUTINE. */
10822 if (!list->proc_sym->attr.subroutine)
10824 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10825 list->proc_sym->name, &list->where);
10829 /* We should have exactly one argument. */
10830 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10832 gfc_error ("FINAL procedure at %L must have exactly one argument",
10836 arg = list->proc_sym->formal->sym;
10838 /* This argument must be of our type. */
10839 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10841 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10842 &arg->declared_at, derived->name);
10846 /* It must neither be a pointer nor allocatable nor optional. */
10847 if (arg->attr.pointer)
10849 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10850 &arg->declared_at);
10853 if (arg->attr.allocatable)
10855 gfc_error ("Argument of FINAL procedure at %L must not be"
10856 " ALLOCATABLE", &arg->declared_at);
10859 if (arg->attr.optional)
10861 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10862 &arg->declared_at);
10866 /* It must not be INTENT(OUT). */
10867 if (arg->attr.intent == INTENT_OUT)
10869 gfc_error ("Argument of FINAL procedure at %L must not be"
10870 " INTENT(OUT)", &arg->declared_at);
10874 /* Warn if the procedure is non-scalar and not assumed shape. */
10875 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10876 && arg->as->type != AS_ASSUMED_SHAPE)
10877 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10878 " shape argument", &arg->declared_at);
10880 /* Check that it does not match in kind and rank with a FINAL procedure
10881 defined earlier. To really loop over the *earlier* declarations,
10882 we need to walk the tail of the list as new ones were pushed at the
10884 /* TODO: Handle kind parameters once they are implemented. */
10885 my_rank = (arg->as ? arg->as->rank : 0);
10886 for (i = list->next; i; i = i->next)
10888 /* Argument list might be empty; that is an error signalled earlier,
10889 but we nevertheless continued resolving. */
10890 if (i->proc_sym->formal)
10892 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10893 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10894 if (i_rank == my_rank)
10896 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10897 " rank (%d) as '%s'",
10898 list->proc_sym->name, &list->where, my_rank,
10899 i->proc_sym->name);
10905 /* Is this the/a scalar finalizer procedure? */
10906 if (!arg->as || arg->as->rank == 0)
10907 seen_scalar = true;
10909 /* Find the symtree for this procedure. */
10910 gcc_assert (!list->proc_tree);
10911 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10913 prev_link = &list->next;
10916 /* Remove wrong nodes immediately from the list so we don't risk any
10917 troubles in the future when they might fail later expectations. */
10921 *prev_link = list->next;
10922 gfc_free_finalizer (i);
10925 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10926 were nodes in the list, must have been for arrays. It is surely a good
10927 idea to have a scalar version there if there's something to finalize. */
10928 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10929 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10930 " defined at %L, suggest also scalar one",
10931 derived->name, &derived->declared_at);
10933 /* TODO: Remove this error when finalization is finished. */
10934 gfc_error ("Finalization at %L is not yet implemented",
10935 &derived->declared_at);
10941 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10944 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10945 const char* generic_name, locus where)
10950 gcc_assert (t1->specific && t2->specific);
10951 gcc_assert (!t1->specific->is_generic);
10952 gcc_assert (!t2->specific->is_generic);
10954 sym1 = t1->specific->u.specific->n.sym;
10955 sym2 = t2->specific->u.specific->n.sym;
10960 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10961 if (sym1->attr.subroutine != sym2->attr.subroutine
10962 || sym1->attr.function != sym2->attr.function)
10964 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10965 " GENERIC '%s' at %L",
10966 sym1->name, sym2->name, generic_name, &where);
10970 /* Compare the interfaces. */
10971 if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
10973 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10974 sym1->name, sym2->name, generic_name, &where);
10982 /* Worker function for resolving a generic procedure binding; this is used to
10983 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10985 The difference between those cases is finding possible inherited bindings
10986 that are overridden, as one has to look for them in tb_sym_root,
10987 tb_uop_root or tb_op, respectively. Thus the caller must already find
10988 the super-type and set p->overridden correctly. */
10991 resolve_tb_generic_targets (gfc_symbol* super_type,
10992 gfc_typebound_proc* p, const char* name)
10994 gfc_tbp_generic* target;
10995 gfc_symtree* first_target;
10996 gfc_symtree* inherited;
10998 gcc_assert (p && p->is_generic);
11000 /* Try to find the specific bindings for the symtrees in our target-list. */
11001 gcc_assert (p->u.generic);
11002 for (target = p->u.generic; target; target = target->next)
11003 if (!target->specific)
11005 gfc_typebound_proc* overridden_tbp;
11006 gfc_tbp_generic* g;
11007 const char* target_name;
11009 target_name = target->specific_st->name;
11011 /* Defined for this type directly. */
11012 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
11014 target->specific = target->specific_st->n.tb;
11015 goto specific_found;
11018 /* Look for an inherited specific binding. */
11021 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
11026 gcc_assert (inherited->n.tb);
11027 target->specific = inherited->n.tb;
11028 goto specific_found;
11032 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11033 " at %L", target_name, name, &p->where);
11036 /* Once we've found the specific binding, check it is not ambiguous with
11037 other specifics already found or inherited for the same GENERIC. */
11039 gcc_assert (target->specific);
11041 /* This must really be a specific binding! */
11042 if (target->specific->is_generic)
11044 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11045 " '%s' is GENERIC, too", name, &p->where, target_name);
11049 /* Check those already resolved on this type directly. */
11050 for (g = p->u.generic; g; g = g->next)
11051 if (g != target && g->specific
11052 && check_generic_tbp_ambiguity (target, g, name, p->where)
11056 /* Check for ambiguity with inherited specific targets. */
11057 for (overridden_tbp = p->overridden; overridden_tbp;
11058 overridden_tbp = overridden_tbp->overridden)
11059 if (overridden_tbp->is_generic)
11061 for (g = overridden_tbp->u.generic; g; g = g->next)
11063 gcc_assert (g->specific);
11064 if (check_generic_tbp_ambiguity (target, g,
11065 name, p->where) == FAILURE)
11071 /* If we attempt to "overwrite" a specific binding, this is an error. */
11072 if (p->overridden && !p->overridden->is_generic)
11074 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11075 " the same name", name, &p->where);
11079 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11080 all must have the same attributes here. */
11081 first_target = p->u.generic->specific->u.specific;
11082 gcc_assert (first_target);
11083 p->subroutine = first_target->n.sym->attr.subroutine;
11084 p->function = first_target->n.sym->attr.function;
11090 /* Resolve a GENERIC procedure binding for a derived type. */
11093 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
11095 gfc_symbol* super_type;
11097 /* Find the overridden binding if any. */
11098 st->n.tb->overridden = NULL;
11099 super_type = gfc_get_derived_super_type (derived);
11102 gfc_symtree* overridden;
11103 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
11106 if (overridden && overridden->n.tb)
11107 st->n.tb->overridden = overridden->n.tb;
11110 /* Resolve using worker function. */
11111 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
11115 /* Retrieve the target-procedure of an operator binding and do some checks in
11116 common for intrinsic and user-defined type-bound operators. */
11119 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
11121 gfc_symbol* target_proc;
11123 gcc_assert (target->specific && !target->specific->is_generic);
11124 target_proc = target->specific->u.specific->n.sym;
11125 gcc_assert (target_proc);
11127 /* All operator bindings must have a passed-object dummy argument. */
11128 if (target->specific->nopass)
11130 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
11134 return target_proc;
11138 /* Resolve a type-bound intrinsic operator. */
11141 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
11142 gfc_typebound_proc* p)
11144 gfc_symbol* super_type;
11145 gfc_tbp_generic* target;
11147 /* If there's already an error here, do nothing (but don't fail again). */
11151 /* Operators should always be GENERIC bindings. */
11152 gcc_assert (p->is_generic);
11154 /* Look for an overridden binding. */
11155 super_type = gfc_get_derived_super_type (derived);
11156 if (super_type && super_type->f2k_derived)
11157 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
11160 p->overridden = NULL;
11162 /* Resolve general GENERIC properties using worker function. */
11163 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
11166 /* Check the targets to be procedures of correct interface. */
11167 for (target = p->u.generic; target; target = target->next)
11169 gfc_symbol* target_proc;
11171 target_proc = get_checked_tb_operator_target (target, p->where);
11175 if (!gfc_check_operator_interface (target_proc, op, p->where))
11187 /* Resolve a type-bound user operator (tree-walker callback). */
11189 static gfc_symbol* resolve_bindings_derived;
11190 static gfc_try resolve_bindings_result;
11192 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
11195 resolve_typebound_user_op (gfc_symtree* stree)
11197 gfc_symbol* super_type;
11198 gfc_tbp_generic* target;
11200 gcc_assert (stree && stree->n.tb);
11202 if (stree->n.tb->error)
11205 /* Operators should always be GENERIC bindings. */
11206 gcc_assert (stree->n.tb->is_generic);
11208 /* Find overridden procedure, if any. */
11209 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11210 if (super_type && super_type->f2k_derived)
11212 gfc_symtree* overridden;
11213 overridden = gfc_find_typebound_user_op (super_type, NULL,
11214 stree->name, true, NULL);
11216 if (overridden && overridden->n.tb)
11217 stree->n.tb->overridden = overridden->n.tb;
11220 stree->n.tb->overridden = NULL;
11222 /* Resolve basically using worker function. */
11223 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
11227 /* Check the targets to be functions of correct interface. */
11228 for (target = stree->n.tb->u.generic; target; target = target->next)
11230 gfc_symbol* target_proc;
11232 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
11236 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
11243 resolve_bindings_result = FAILURE;
11244 stree->n.tb->error = 1;
11248 /* Resolve the type-bound procedures for a derived type. */
11251 resolve_typebound_procedure (gfc_symtree* stree)
11255 gfc_symbol* me_arg;
11256 gfc_symbol* super_type;
11257 gfc_component* comp;
11259 gcc_assert (stree);
11261 /* Undefined specific symbol from GENERIC target definition. */
11265 if (stree->n.tb->error)
11268 /* If this is a GENERIC binding, use that routine. */
11269 if (stree->n.tb->is_generic)
11271 if (resolve_typebound_generic (resolve_bindings_derived, stree)
11277 /* Get the target-procedure to check it. */
11278 gcc_assert (!stree->n.tb->is_generic);
11279 gcc_assert (stree->n.tb->u.specific);
11280 proc = stree->n.tb->u.specific->n.sym;
11281 where = stree->n.tb->where;
11283 /* Default access should already be resolved from the parser. */
11284 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
11286 /* It should be a module procedure or an external procedure with explicit
11287 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
11288 if ((!proc->attr.subroutine && !proc->attr.function)
11289 || (proc->attr.proc != PROC_MODULE
11290 && proc->attr.if_source != IFSRC_IFBODY)
11291 || (proc->attr.abstract && !stree->n.tb->deferred))
11293 gfc_error ("'%s' must be a module procedure or an external procedure with"
11294 " an explicit interface at %L", proc->name, &where);
11297 stree->n.tb->subroutine = proc->attr.subroutine;
11298 stree->n.tb->function = proc->attr.function;
11300 /* Find the super-type of the current derived type. We could do this once and
11301 store in a global if speed is needed, but as long as not I believe this is
11302 more readable and clearer. */
11303 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11305 /* If PASS, resolve and check arguments if not already resolved / loaded
11306 from a .mod file. */
11307 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
11309 if (stree->n.tb->pass_arg)
11311 gfc_formal_arglist* i;
11313 /* If an explicit passing argument name is given, walk the arg-list
11314 and look for it. */
11317 stree->n.tb->pass_arg_num = 1;
11318 for (i = proc->formal; i; i = i->next)
11320 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
11325 ++stree->n.tb->pass_arg_num;
11330 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11332 proc->name, stree->n.tb->pass_arg, &where,
11333 stree->n.tb->pass_arg);
11339 /* Otherwise, take the first one; there should in fact be at least
11341 stree->n.tb->pass_arg_num = 1;
11344 gfc_error ("Procedure '%s' with PASS at %L must have at"
11345 " least one argument", proc->name, &where);
11348 me_arg = proc->formal->sym;
11351 /* Now check that the argument-type matches and the passed-object
11352 dummy argument is generally fine. */
11354 gcc_assert (me_arg);
11356 if (me_arg->ts.type != BT_CLASS)
11358 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11359 " at %L", proc->name, &where);
11363 if (CLASS_DATA (me_arg)->ts.u.derived
11364 != resolve_bindings_derived)
11366 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11367 " the derived-type '%s'", me_arg->name, proc->name,
11368 me_arg->name, &where, resolve_bindings_derived->name);
11372 gcc_assert (me_arg->ts.type == BT_CLASS);
11373 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
11375 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11376 " scalar", proc->name, &where);
11379 if (CLASS_DATA (me_arg)->attr.allocatable)
11381 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11382 " be ALLOCATABLE", proc->name, &where);
11385 if (CLASS_DATA (me_arg)->attr.class_pointer)
11387 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11388 " be POINTER", proc->name, &where);
11393 /* If we are extending some type, check that we don't override a procedure
11394 flagged NON_OVERRIDABLE. */
11395 stree->n.tb->overridden = NULL;
11398 gfc_symtree* overridden;
11399 overridden = gfc_find_typebound_proc (super_type, NULL,
11400 stree->name, true, NULL);
11404 if (overridden->n.tb)
11405 stree->n.tb->overridden = overridden->n.tb;
11407 if (gfc_check_typebound_override (stree, overridden) == FAILURE)
11412 /* See if there's a name collision with a component directly in this type. */
11413 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11414 if (!strcmp (comp->name, stree->name))
11416 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11418 stree->name, &where, resolve_bindings_derived->name);
11422 /* Try to find a name collision with an inherited component. */
11423 if (super_type && gfc_find_component (super_type, stree->name, true, true))
11425 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11426 " component of '%s'",
11427 stree->name, &where, resolve_bindings_derived->name);
11431 stree->n.tb->error = 0;
11435 resolve_bindings_result = FAILURE;
11436 stree->n.tb->error = 1;
11441 resolve_typebound_procedures (gfc_symbol* derived)
11444 gfc_symbol* super_type;
11446 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11449 super_type = gfc_get_derived_super_type (derived);
11451 resolve_typebound_procedures (super_type);
11453 resolve_bindings_derived = derived;
11454 resolve_bindings_result = SUCCESS;
11456 /* Make sure the vtab has been generated. */
11457 gfc_find_derived_vtab (derived);
11459 if (derived->f2k_derived->tb_sym_root)
11460 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11461 &resolve_typebound_procedure);
11463 if (derived->f2k_derived->tb_uop_root)
11464 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11465 &resolve_typebound_user_op);
11467 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11469 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11470 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11472 resolve_bindings_result = FAILURE;
11475 return resolve_bindings_result;
11479 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11480 to give all identical derived types the same backend_decl. */
11482 add_dt_to_dt_list (gfc_symbol *derived)
11484 gfc_dt_list *dt_list;
11486 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11487 if (derived == dt_list->derived)
11490 dt_list = gfc_get_dt_list ();
11491 dt_list->next = gfc_derived_types;
11492 dt_list->derived = derived;
11493 gfc_derived_types = dt_list;
11497 /* Ensure that a derived-type is really not abstract, meaning that every
11498 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11501 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11506 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11508 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11511 if (st->n.tb && st->n.tb->deferred)
11513 gfc_symtree* overriding;
11514 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11517 gcc_assert (overriding->n.tb);
11518 if (overriding->n.tb->deferred)
11520 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11521 " '%s' is DEFERRED and not overridden",
11522 sub->name, &sub->declared_at, st->name);
11531 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11533 /* The algorithm used here is to recursively travel up the ancestry of sub
11534 and for each ancestor-type, check all bindings. If any of them is
11535 DEFERRED, look it up starting from sub and see if the found (overriding)
11536 binding is not DEFERRED.
11537 This is not the most efficient way to do this, but it should be ok and is
11538 clearer than something sophisticated. */
11540 gcc_assert (ancestor && !sub->attr.abstract);
11542 if (!ancestor->attr.abstract)
11545 /* Walk bindings of this ancestor. */
11546 if (ancestor->f2k_derived)
11549 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11554 /* Find next ancestor type and recurse on it. */
11555 ancestor = gfc_get_derived_super_type (ancestor);
11557 return ensure_not_abstract (sub, ancestor);
11563 /* Resolve the components of a derived type. This does not have to wait until
11564 resolution stage, but can be done as soon as the dt declaration has been
11568 resolve_fl_derived0 (gfc_symbol *sym)
11570 gfc_symbol* super_type;
11573 super_type = gfc_get_derived_super_type (sym);
11576 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11578 gfc_error ("As extending type '%s' at %L has a coarray component, "
11579 "parent type '%s' shall also have one", sym->name,
11580 &sym->declared_at, super_type->name);
11584 /* Ensure the extended type gets resolved before we do. */
11585 if (super_type && resolve_fl_derived0 (super_type) == FAILURE)
11588 /* An ABSTRACT type must be extensible. */
11589 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11591 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11592 sym->name, &sym->declared_at);
11596 c = (sym->attr.is_class) ? sym->components->ts.u.derived->components
11599 for ( ; c != NULL; c = c->next)
11601 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
11602 if (c->ts.type == BT_CHARACTER && c->ts.deferred)
11604 gfc_error ("Deferred-length character component '%s' at %L is not "
11605 "yet supported", c->name, &c->loc);
11610 if ((!sym->attr.is_class || c != sym->components)
11611 && c->attr.codimension
11612 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11614 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11615 "deferred shape", c->name, &c->loc);
11620 if (c->attr.codimension && c->ts.type == BT_DERIVED
11621 && c->ts.u.derived->ts.is_iso_c)
11623 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11624 "shall not be a coarray", c->name, &c->loc);
11629 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11630 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11631 || c->attr.allocatable))
11633 gfc_error ("Component '%s' at %L with coarray component "
11634 "shall be a nonpointer, nonallocatable scalar",
11640 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11642 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11643 "is not an array pointer", c->name, &c->loc);
11647 if (c->attr.proc_pointer && c->ts.interface)
11649 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11650 gfc_error ("Interface '%s', used by procedure pointer component "
11651 "'%s' at %L, is declared in a later PROCEDURE statement",
11652 c->ts.interface->name, c->name, &c->loc);
11654 /* Get the attributes from the interface (now resolved). */
11655 if (c->ts.interface->attr.if_source
11656 || c->ts.interface->attr.intrinsic)
11658 gfc_symbol *ifc = c->ts.interface;
11660 if (ifc->formal && !ifc->formal_ns)
11661 resolve_symbol (ifc);
11663 if (ifc->attr.intrinsic)
11664 resolve_intrinsic (ifc, &ifc->declared_at);
11668 c->ts = ifc->result->ts;
11669 c->attr.allocatable = ifc->result->attr.allocatable;
11670 c->attr.pointer = ifc->result->attr.pointer;
11671 c->attr.dimension = ifc->result->attr.dimension;
11672 c->as = gfc_copy_array_spec (ifc->result->as);
11677 c->attr.allocatable = ifc->attr.allocatable;
11678 c->attr.pointer = ifc->attr.pointer;
11679 c->attr.dimension = ifc->attr.dimension;
11680 c->as = gfc_copy_array_spec (ifc->as);
11682 c->ts.interface = ifc;
11683 c->attr.function = ifc->attr.function;
11684 c->attr.subroutine = ifc->attr.subroutine;
11685 gfc_copy_formal_args_ppc (c, ifc);
11687 c->attr.pure = ifc->attr.pure;
11688 c->attr.elemental = ifc->attr.elemental;
11689 c->attr.recursive = ifc->attr.recursive;
11690 c->attr.always_explicit = ifc->attr.always_explicit;
11691 c->attr.ext_attr |= ifc->attr.ext_attr;
11692 /* Replace symbols in array spec. */
11696 for (i = 0; i < c->as->rank; i++)
11698 gfc_expr_replace_comp (c->as->lower[i], c);
11699 gfc_expr_replace_comp (c->as->upper[i], c);
11702 /* Copy char length. */
11703 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11705 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11706 gfc_expr_replace_comp (cl->length, c);
11707 if (cl->length && !cl->resolved
11708 && gfc_resolve_expr (cl->length) == FAILURE)
11713 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11715 gfc_error ("Interface '%s' of procedure pointer component "
11716 "'%s' at %L must be explicit", c->ts.interface->name,
11721 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11723 /* Since PPCs are not implicitly typed, a PPC without an explicit
11724 interface must be a subroutine. */
11725 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11728 /* Procedure pointer components: Check PASS arg. */
11729 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11730 && !sym->attr.vtype)
11732 gfc_symbol* me_arg;
11734 if (c->tb->pass_arg)
11736 gfc_formal_arglist* i;
11738 /* If an explicit passing argument name is given, walk the arg-list
11739 and look for it. */
11742 c->tb->pass_arg_num = 1;
11743 for (i = c->formal; i; i = i->next)
11745 if (!strcmp (i->sym->name, c->tb->pass_arg))
11750 c->tb->pass_arg_num++;
11755 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11756 "at %L has no argument '%s'", c->name,
11757 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11764 /* Otherwise, take the first one; there should in fact be at least
11766 c->tb->pass_arg_num = 1;
11769 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11770 "must have at least one argument",
11775 me_arg = c->formal->sym;
11778 /* Now check that the argument-type matches. */
11779 gcc_assert (me_arg);
11780 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11781 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11782 || (me_arg->ts.type == BT_CLASS
11783 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11785 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11786 " the derived type '%s'", me_arg->name, c->name,
11787 me_arg->name, &c->loc, sym->name);
11792 /* Check for C453. */
11793 if (me_arg->attr.dimension)
11795 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11796 "must be scalar", me_arg->name, c->name, me_arg->name,
11802 if (me_arg->attr.pointer)
11804 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11805 "may not have the POINTER attribute", me_arg->name,
11806 c->name, me_arg->name, &c->loc);
11811 if (me_arg->attr.allocatable)
11813 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11814 "may not be ALLOCATABLE", me_arg->name, c->name,
11815 me_arg->name, &c->loc);
11820 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11821 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11822 " at %L", c->name, &c->loc);
11826 /* Check type-spec if this is not the parent-type component. */
11827 if (((sym->attr.is_class
11828 && (!sym->components->ts.u.derived->attr.extension
11829 || c != sym->components->ts.u.derived->components))
11830 || (!sym->attr.is_class
11831 && (!sym->attr.extension || c != sym->components)))
11832 && !sym->attr.vtype
11833 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11836 /* If this type is an extension, set the accessibility of the parent
11839 && ((sym->attr.is_class
11840 && c == sym->components->ts.u.derived->components)
11841 || (!sym->attr.is_class && c == sym->components))
11842 && strcmp (super_type->name, c->name) == 0)
11843 c->attr.access = super_type->attr.access;
11845 /* If this type is an extension, see if this component has the same name
11846 as an inherited type-bound procedure. */
11847 if (super_type && !sym->attr.is_class
11848 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11850 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11851 " inherited type-bound procedure",
11852 c->name, sym->name, &c->loc);
11856 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
11857 && !c->ts.deferred)
11859 if (c->ts.u.cl->length == NULL
11860 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11861 || !gfc_is_constant_expr (c->ts.u.cl->length))
11863 gfc_error ("Character length of component '%s' needs to "
11864 "be a constant specification expression at %L",
11866 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11871 if (c->ts.type == BT_CHARACTER && c->ts.deferred
11872 && !c->attr.pointer && !c->attr.allocatable)
11874 gfc_error ("Character component '%s' of '%s' at %L with deferred "
11875 "length must be a POINTER or ALLOCATABLE",
11876 c->name, sym->name, &c->loc);
11880 if (c->ts.type == BT_DERIVED
11881 && sym->component_access != ACCESS_PRIVATE
11882 && gfc_check_symbol_access (sym)
11883 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11884 && !c->ts.u.derived->attr.use_assoc
11885 && !gfc_check_symbol_access (c->ts.u.derived)
11886 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11887 "is a PRIVATE type and cannot be a component of "
11888 "'%s', which is PUBLIC at %L", c->name,
11889 sym->name, &sym->declared_at) == FAILURE)
11892 if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
11894 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11895 "type %s", c->name, &c->loc, sym->name);
11899 if (sym->attr.sequence)
11901 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11903 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11904 "not have the SEQUENCE attribute",
11905 c->ts.u.derived->name, &sym->declared_at);
11910 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
11911 c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
11912 else if (c->ts.type == BT_CLASS && c->attr.class_ok
11913 && CLASS_DATA (c)->ts.u.derived->attr.generic)
11914 CLASS_DATA (c)->ts.u.derived
11915 = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
11917 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
11918 && c->attr.pointer && c->ts.u.derived->components == NULL
11919 && !c->ts.u.derived->attr.zero_comp)
11921 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11922 "that has not been declared", c->name, sym->name,
11927 if (c->ts.type == BT_CLASS && c->attr.class_ok
11928 && CLASS_DATA (c)->attr.class_pointer
11929 && CLASS_DATA (c)->ts.u.derived->components == NULL
11930 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11932 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11933 "that has not been declared", c->name, sym->name,
11939 if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE
11940 && (!c->attr.class_ok
11941 || !(CLASS_DATA (c)->attr.class_pointer
11942 || CLASS_DATA (c)->attr.allocatable)))
11944 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11945 "or pointer", c->name, &c->loc);
11949 /* Ensure that all the derived type components are put on the
11950 derived type list; even in formal namespaces, where derived type
11951 pointer components might not have been declared. */
11952 if (c->ts.type == BT_DERIVED
11954 && c->ts.u.derived->components
11956 && sym != c->ts.u.derived)
11957 add_dt_to_dt_list (c->ts.u.derived);
11959 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11960 || c->attr.proc_pointer
11961 || c->attr.allocatable)) == FAILURE)
11965 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11966 all DEFERRED bindings are overridden. */
11967 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11968 && !sym->attr.is_class
11969 && ensure_not_abstract (sym, super_type) == FAILURE)
11972 /* Add derived type to the derived type list. */
11973 add_dt_to_dt_list (sym);
11979 /* The following procedure does the full resolution of a derived type,
11980 including resolution of all type-bound procedures (if present). In contrast
11981 to 'resolve_fl_derived0' this can only be done after the module has been
11982 parsed completely. */
11985 resolve_fl_derived (gfc_symbol *sym)
11987 gfc_symbol *gen_dt = NULL;
11989 if (!sym->attr.is_class)
11990 gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
11991 if (gen_dt && gen_dt->generic && gen_dt->generic->next
11992 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Generic name '%s' of "
11993 "function '%s' at %L being the same name as derived "
11994 "type at %L", sym->name,
11995 gen_dt->generic->sym == sym
11996 ? gen_dt->generic->next->sym->name
11997 : gen_dt->generic->sym->name,
11998 gen_dt->generic->sym == sym
11999 ? &gen_dt->generic->next->sym->declared_at
12000 : &gen_dt->generic->sym->declared_at,
12001 &sym->declared_at) == FAILURE)
12004 if (sym->attr.is_class && sym->ts.u.derived == NULL)
12006 /* Fix up incomplete CLASS symbols. */
12007 gfc_component *data = gfc_find_component (sym, "_data", true, true);
12008 gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
12009 if (vptr->ts.u.derived == NULL)
12011 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
12013 vptr->ts.u.derived = vtab->ts.u.derived;
12017 if (resolve_fl_derived0 (sym) == FAILURE)
12020 /* Resolve the type-bound procedures. */
12021 if (resolve_typebound_procedures (sym) == FAILURE)
12024 /* Resolve the finalizer procedures. */
12025 if (gfc_resolve_finalizers (sym) == FAILURE)
12033 resolve_fl_namelist (gfc_symbol *sym)
12038 for (nl = sym->namelist; nl; nl = nl->next)
12040 /* Check again, the check in match only works if NAMELIST comes
12042 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
12044 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12045 "allowed", nl->sym->name, sym->name, &sym->declared_at);
12049 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
12050 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
12051 "object '%s' with assumed shape in namelist "
12052 "'%s' at %L", nl->sym->name, sym->name,
12053 &sym->declared_at) == FAILURE)
12056 if (is_non_constant_shape_array (nl->sym)
12057 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
12058 "object '%s' with nonconstant shape in namelist "
12059 "'%s' at %L", nl->sym->name, sym->name,
12060 &sym->declared_at) == FAILURE)
12063 if (nl->sym->ts.type == BT_CHARACTER
12064 && (nl->sym->ts.u.cl->length == NULL
12065 || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
12066 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
12067 "'%s' with nonconstant character length in "
12068 "namelist '%s' at %L", nl->sym->name, sym->name,
12069 &sym->declared_at) == FAILURE)
12072 /* FIXME: Once UDDTIO is implemented, the following can be
12074 if (nl->sym->ts.type == BT_CLASS)
12076 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12077 "polymorphic and requires a defined input/output "
12078 "procedure", nl->sym->name, sym->name, &sym->declared_at);
12082 if (nl->sym->ts.type == BT_DERIVED
12083 && (nl->sym->ts.u.derived->attr.alloc_comp
12084 || nl->sym->ts.u.derived->attr.pointer_comp))
12086 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
12087 "'%s' in namelist '%s' at %L with ALLOCATABLE "
12088 "or POINTER components", nl->sym->name,
12089 sym->name, &sym->declared_at) == FAILURE)
12092 /* FIXME: Once UDDTIO is implemented, the following can be
12094 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12095 "ALLOCATABLE or POINTER components and thus requires "
12096 "a defined input/output procedure", nl->sym->name,
12097 sym->name, &sym->declared_at);
12102 /* Reject PRIVATE objects in a PUBLIC namelist. */
12103 if (gfc_check_symbol_access (sym))
12105 for (nl = sym->namelist; nl; nl = nl->next)
12107 if (!nl->sym->attr.use_assoc
12108 && !is_sym_host_assoc (nl->sym, sym->ns)
12109 && !gfc_check_symbol_access (nl->sym))
12111 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12112 "cannot be member of PUBLIC namelist '%s' at %L",
12113 nl->sym->name, sym->name, &sym->declared_at);
12117 /* Types with private components that came here by USE-association. */
12118 if (nl->sym->ts.type == BT_DERIVED
12119 && derived_inaccessible (nl->sym->ts.u.derived))
12121 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12122 "components and cannot be member of namelist '%s' at %L",
12123 nl->sym->name, sym->name, &sym->declared_at);
12127 /* Types with private components that are defined in the same module. */
12128 if (nl->sym->ts.type == BT_DERIVED
12129 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
12130 && nl->sym->ts.u.derived->attr.private_comp)
12132 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12133 "cannot be a member of PUBLIC namelist '%s' at %L",
12134 nl->sym->name, sym->name, &sym->declared_at);
12141 /* 14.1.2 A module or internal procedure represent local entities
12142 of the same type as a namelist member and so are not allowed. */
12143 for (nl = sym->namelist; nl; nl = nl->next)
12145 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
12148 if (nl->sym->attr.function && nl->sym == nl->sym->result)
12149 if ((nl->sym == sym->ns->proc_name)
12151 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
12155 if (nl->sym && nl->sym->name)
12156 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
12157 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
12159 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12160 "attribute in '%s' at %L", nlsym->name,
12161 &sym->declared_at);
12171 resolve_fl_parameter (gfc_symbol *sym)
12173 /* A parameter array's shape needs to be constant. */
12174 if (sym->as != NULL
12175 && (sym->as->type == AS_DEFERRED
12176 || is_non_constant_shape_array (sym)))
12178 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12179 "or of deferred shape", sym->name, &sym->declared_at);
12183 /* Make sure a parameter that has been implicitly typed still
12184 matches the implicit type, since PARAMETER statements can precede
12185 IMPLICIT statements. */
12186 if (sym->attr.implicit_type
12187 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
12190 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12191 "later IMPLICIT type", sym->name, &sym->declared_at);
12195 /* Make sure the types of derived parameters are consistent. This
12196 type checking is deferred until resolution because the type may
12197 refer to a derived type from the host. */
12198 if (sym->ts.type == BT_DERIVED
12199 && !gfc_compare_types (&sym->ts, &sym->value->ts))
12201 gfc_error ("Incompatible derived type in PARAMETER at %L",
12202 &sym->value->where);
12209 /* Do anything necessary to resolve a symbol. Right now, we just
12210 assume that an otherwise unknown symbol is a variable. This sort
12211 of thing commonly happens for symbols in module. */
12214 resolve_symbol (gfc_symbol *sym)
12216 int check_constant, mp_flag;
12217 gfc_symtree *symtree;
12218 gfc_symtree *this_symtree;
12221 symbol_attribute class_attr;
12222 gfc_array_spec *as;
12224 if (sym->attr.flavor == FL_UNKNOWN)
12227 /* If we find that a flavorless symbol is an interface in one of the
12228 parent namespaces, find its symtree in this namespace, free the
12229 symbol and set the symtree to point to the interface symbol. */
12230 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
12232 symtree = gfc_find_symtree (ns->sym_root, sym->name);
12233 if (symtree && (symtree->n.sym->generic ||
12234 (symtree->n.sym->attr.flavor == FL_PROCEDURE
12235 && sym->ns->construct_entities)))
12237 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
12239 gfc_release_symbol (sym);
12240 symtree->n.sym->refs++;
12241 this_symtree->n.sym = symtree->n.sym;
12246 /* Otherwise give it a flavor according to such attributes as
12248 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
12249 sym->attr.flavor = FL_VARIABLE;
12252 sym->attr.flavor = FL_PROCEDURE;
12253 if (sym->attr.dimension)
12254 sym->attr.function = 1;
12258 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
12259 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
12261 if (sym->attr.procedure && sym->ts.interface
12262 && sym->attr.if_source != IFSRC_DECL
12263 && resolve_procedure_interface (sym) == FAILURE)
12266 if (sym->attr.is_protected && !sym->attr.proc_pointer
12267 && (sym->attr.procedure || sym->attr.external))
12269 if (sym->attr.external)
12270 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12271 "at %L", &sym->declared_at);
12273 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12274 "at %L", &sym->declared_at);
12279 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
12282 /* Symbols that are module procedures with results (functions) have
12283 the types and array specification copied for type checking in
12284 procedures that call them, as well as for saving to a module
12285 file. These symbols can't stand the scrutiny that their results
12287 mp_flag = (sym->result != NULL && sym->result != sym);
12289 /* Make sure that the intrinsic is consistent with its internal
12290 representation. This needs to be done before assigning a default
12291 type to avoid spurious warnings. */
12292 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
12293 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
12296 /* Resolve associate names. */
12298 resolve_assoc_var (sym, true);
12300 /* Assign default type to symbols that need one and don't have one. */
12301 if (sym->ts.type == BT_UNKNOWN)
12303 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
12305 gfc_set_default_type (sym, 1, NULL);
12308 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
12309 && !sym->attr.function && !sym->attr.subroutine
12310 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
12311 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
12313 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
12315 /* The specific case of an external procedure should emit an error
12316 in the case that there is no implicit type. */
12318 gfc_set_default_type (sym, sym->attr.external, NULL);
12321 /* Result may be in another namespace. */
12322 resolve_symbol (sym->result);
12324 if (!sym->result->attr.proc_pointer)
12326 sym->ts = sym->result->ts;
12327 sym->as = gfc_copy_array_spec (sym->result->as);
12328 sym->attr.dimension = sym->result->attr.dimension;
12329 sym->attr.pointer = sym->result->attr.pointer;
12330 sym->attr.allocatable = sym->result->attr.allocatable;
12331 sym->attr.contiguous = sym->result->attr.contiguous;
12336 else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
12337 gfc_resolve_array_spec (sym->result->as, false);
12339 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
12341 as = CLASS_DATA (sym)->as;
12342 class_attr = CLASS_DATA (sym)->attr;
12343 class_attr.pointer = class_attr.class_pointer;
12347 class_attr = sym->attr;
12352 if (sym->attr.contiguous
12353 && (!class_attr.dimension
12354 || (as->type != AS_ASSUMED_SHAPE && !class_attr.pointer)))
12356 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12357 "array pointer or an assumed-shape array", sym->name,
12358 &sym->declared_at);
12362 /* Assumed size arrays and assumed shape arrays must be dummy
12363 arguments. Array-spec's of implied-shape should have been resolved to
12364 AS_EXPLICIT already. */
12368 gcc_assert (as->type != AS_IMPLIED_SHAPE);
12369 if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
12370 || as->type == AS_ASSUMED_SHAPE)
12371 && sym->attr.dummy == 0)
12373 if (as->type == AS_ASSUMED_SIZE)
12374 gfc_error ("Assumed size array at %L must be a dummy argument",
12375 &sym->declared_at);
12377 gfc_error ("Assumed shape array at %L must be a dummy argument",
12378 &sym->declared_at);
12383 /* Make sure symbols with known intent or optional are really dummy
12384 variable. Because of ENTRY statement, this has to be deferred
12385 until resolution time. */
12387 if (!sym->attr.dummy
12388 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
12390 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
12394 if (sym->attr.value && !sym->attr.dummy)
12396 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12397 "it is not a dummy argument", sym->name, &sym->declared_at);
12401 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
12403 gfc_charlen *cl = sym->ts.u.cl;
12404 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
12406 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12407 "attribute must have constant length",
12408 sym->name, &sym->declared_at);
12412 if (sym->ts.is_c_interop
12413 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
12415 gfc_error ("C interoperable character dummy variable '%s' at %L "
12416 "with VALUE attribute must have length one",
12417 sym->name, &sym->declared_at);
12422 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
12423 && sym->ts.u.derived->attr.generic)
12425 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
12426 if (!sym->ts.u.derived)
12428 gfc_error ("The derived type '%s' at %L is of type '%s', "
12429 "which has not been defined", sym->name,
12430 &sym->declared_at, sym->ts.u.derived->name);
12431 sym->ts.type = BT_UNKNOWN;
12436 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12437 do this for something that was implicitly typed because that is handled
12438 in gfc_set_default_type. Handle dummy arguments and procedure
12439 definitions separately. Also, anything that is use associated is not
12440 handled here but instead is handled in the module it is declared in.
12441 Finally, derived type definitions are allowed to be BIND(C) since that
12442 only implies that they're interoperable, and they are checked fully for
12443 interoperability when a variable is declared of that type. */
12444 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
12445 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
12446 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
12448 gfc_try t = SUCCESS;
12450 /* First, make sure the variable is declared at the
12451 module-level scope (J3/04-007, Section 15.3). */
12452 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
12453 sym->attr.in_common == 0)
12455 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12456 "is neither a COMMON block nor declared at the "
12457 "module level scope", sym->name, &(sym->declared_at));
12460 else if (sym->common_head != NULL)
12462 t = verify_com_block_vars_c_interop (sym->common_head);
12466 /* If type() declaration, we need to verify that the components
12467 of the given type are all C interoperable, etc. */
12468 if (sym->ts.type == BT_DERIVED &&
12469 sym->ts.u.derived->attr.is_c_interop != 1)
12471 /* Make sure the user marked the derived type as BIND(C). If
12472 not, call the verify routine. This could print an error
12473 for the derived type more than once if multiple variables
12474 of that type are declared. */
12475 if (sym->ts.u.derived->attr.is_bind_c != 1)
12476 verify_bind_c_derived_type (sym->ts.u.derived);
12480 /* Verify the variable itself as C interoperable if it
12481 is BIND(C). It is not possible for this to succeed if
12482 the verify_bind_c_derived_type failed, so don't have to handle
12483 any error returned by verify_bind_c_derived_type. */
12484 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
12485 sym->common_block);
12490 /* clear the is_bind_c flag to prevent reporting errors more than
12491 once if something failed. */
12492 sym->attr.is_bind_c = 0;
12497 /* If a derived type symbol has reached this point, without its
12498 type being declared, we have an error. Notice that most
12499 conditions that produce undefined derived types have already
12500 been dealt with. However, the likes of:
12501 implicit type(t) (t) ..... call foo (t) will get us here if
12502 the type is not declared in the scope of the implicit
12503 statement. Change the type to BT_UNKNOWN, both because it is so
12504 and to prevent an ICE. */
12505 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
12506 && sym->ts.u.derived->components == NULL
12507 && !sym->ts.u.derived->attr.zero_comp)
12509 gfc_error ("The derived type '%s' at %L is of type '%s', "
12510 "which has not been defined", sym->name,
12511 &sym->declared_at, sym->ts.u.derived->name);
12512 sym->ts.type = BT_UNKNOWN;
12516 /* Make sure that the derived type has been resolved and that the
12517 derived type is visible in the symbol's namespace, if it is a
12518 module function and is not PRIVATE. */
12519 if (sym->ts.type == BT_DERIVED
12520 && sym->ts.u.derived->attr.use_assoc
12521 && sym->ns->proc_name
12522 && sym->ns->proc_name->attr.flavor == FL_MODULE
12523 && resolve_fl_derived (sym->ts.u.derived) == FAILURE)
12526 /* Unless the derived-type declaration is use associated, Fortran 95
12527 does not allow public entries of private derived types.
12528 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12529 161 in 95-006r3. */
12530 if (sym->ts.type == BT_DERIVED
12531 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12532 && !sym->ts.u.derived->attr.use_assoc
12533 && gfc_check_symbol_access (sym)
12534 && !gfc_check_symbol_access (sym->ts.u.derived)
12535 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12536 "of PRIVATE derived type '%s'",
12537 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12538 : "variable", sym->name, &sym->declared_at,
12539 sym->ts.u.derived->name) == FAILURE)
12542 /* F2008, C1302. */
12543 if (sym->ts.type == BT_DERIVED
12544 && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
12545 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
12546 || sym->ts.u.derived->attr.lock_comp)
12547 && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
12549 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
12550 "type LOCK_TYPE must be a coarray", sym->name,
12551 &sym->declared_at);
12555 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12556 default initialization is defined (5.1.2.4.4). */
12557 if (sym->ts.type == BT_DERIVED
12559 && sym->attr.intent == INTENT_OUT
12561 && sym->as->type == AS_ASSUMED_SIZE)
12563 for (c = sym->ts.u.derived->components; c; c = c->next)
12565 if (c->initializer)
12567 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12568 "ASSUMED SIZE and so cannot have a default initializer",
12569 sym->name, &sym->declared_at);
12576 if (sym->ts.type == BT_DERIVED && sym->attr.dummy
12577 && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
12579 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
12580 "INTENT(OUT)", sym->name, &sym->declared_at);
12585 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12586 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12587 && CLASS_DATA (sym)->attr.coarray_comp))
12588 || class_attr.codimension)
12589 && (sym->attr.result || sym->result == sym))
12591 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12592 "a coarray component", sym->name, &sym->declared_at);
12597 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12598 && sym->ts.u.derived->ts.is_iso_c)
12600 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12601 "shall not be a coarray", sym->name, &sym->declared_at);
12606 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12607 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12608 && CLASS_DATA (sym)->attr.coarray_comp))
12609 && (class_attr.codimension || class_attr.pointer || class_attr.dimension
12610 || class_attr.allocatable))
12612 gfc_error ("Variable '%s' at %L with coarray component "
12613 "shall be a nonpointer, nonallocatable scalar",
12614 sym->name, &sym->declared_at);
12618 /* F2008, C526. The function-result case was handled above. */
12619 if (class_attr.codimension
12620 && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
12621 || sym->attr.select_type_temporary
12622 || sym->ns->save_all
12623 || sym->ns->proc_name->attr.flavor == FL_MODULE
12624 || sym->ns->proc_name->attr.is_main_program
12625 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12627 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
12628 "nor a dummy argument", sym->name, &sym->declared_at);
12632 else if (class_attr.codimension && !sym->attr.select_type_temporary
12633 && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
12635 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12636 "deferred shape", sym->name, &sym->declared_at);
12639 else if (class_attr.codimension && class_attr.allocatable && as
12640 && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
12642 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12643 "deferred shape", sym->name, &sym->declared_at);
12648 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12649 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
12650 && CLASS_DATA (sym)->attr.coarray_comp))
12651 || (class_attr.codimension && class_attr.allocatable))
12652 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12654 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12655 "allocatable coarray or have coarray components",
12656 sym->name, &sym->declared_at);
12660 if (class_attr.codimension && sym->attr.dummy
12661 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12663 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12664 "procedure '%s'", sym->name, &sym->declared_at,
12665 sym->ns->proc_name->name);
12669 switch (sym->attr.flavor)
12672 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12677 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12682 if (resolve_fl_namelist (sym) == FAILURE)
12687 if (resolve_fl_parameter (sym) == FAILURE)
12695 /* Resolve array specifier. Check as well some constraints
12696 on COMMON blocks. */
12698 check_constant = sym->attr.in_common && !sym->attr.pointer;
12700 /* Set the formal_arg_flag so that check_conflict will not throw
12701 an error for host associated variables in the specification
12702 expression for an array_valued function. */
12703 if (sym->attr.function && sym->as)
12704 formal_arg_flag = 1;
12706 gfc_resolve_array_spec (sym->as, check_constant);
12708 formal_arg_flag = 0;
12710 /* Resolve formal namespaces. */
12711 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12712 && !sym->attr.contained && !sym->attr.intrinsic)
12713 gfc_resolve (sym->formal_ns);
12715 /* Make sure the formal namespace is present. */
12716 if (sym->formal && !sym->formal_ns)
12718 gfc_formal_arglist *formal = sym->formal;
12719 while (formal && !formal->sym)
12720 formal = formal->next;
12724 sym->formal_ns = formal->sym->ns;
12725 sym->formal_ns->refs++;
12729 /* Check threadprivate restrictions. */
12730 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12731 && (!sym->attr.in_common
12732 && sym->module == NULL
12733 && (sym->ns->proc_name == NULL
12734 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12735 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12737 /* If we have come this far we can apply default-initializers, as
12738 described in 14.7.5, to those variables that have not already
12739 been assigned one. */
12740 if (sym->ts.type == BT_DERIVED
12741 && sym->ns == gfc_current_ns
12743 && !sym->attr.allocatable
12744 && !sym->attr.alloc_comp)
12746 symbol_attribute *a = &sym->attr;
12748 if ((!a->save && !a->dummy && !a->pointer
12749 && !a->in_common && !a->use_assoc
12750 && (a->referenced || a->result)
12751 && !(a->function && sym != sym->result))
12752 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12753 apply_default_init (sym);
12756 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
12757 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
12758 && !CLASS_DATA (sym)->attr.class_pointer
12759 && !CLASS_DATA (sym)->attr.allocatable)
12760 apply_default_init (sym);
12762 /* If this symbol has a type-spec, check it. */
12763 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12764 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12765 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12771 /************* Resolve DATA statements *************/
12775 gfc_data_value *vnode;
12781 /* Advance the values structure to point to the next value in the data list. */
12784 next_data_value (void)
12786 while (mpz_cmp_ui (values.left, 0) == 0)
12789 if (values.vnode->next == NULL)
12792 values.vnode = values.vnode->next;
12793 mpz_set (values.left, values.vnode->repeat);
12801 check_data_variable (gfc_data_variable *var, locus *where)
12807 ar_type mark = AR_UNKNOWN;
12809 mpz_t section_index[GFC_MAX_DIMENSIONS];
12815 if (gfc_resolve_expr (var->expr) == FAILURE)
12819 mpz_init_set_si (offset, 0);
12822 if (e->expr_type != EXPR_VARIABLE)
12823 gfc_internal_error ("check_data_variable(): Bad expression");
12825 sym = e->symtree->n.sym;
12827 if (sym->ns->is_block_data && !sym->attr.in_common)
12829 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12830 sym->name, &sym->declared_at);
12833 if (e->ref == NULL && sym->as)
12835 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12836 " declaration", sym->name, where);
12840 has_pointer = sym->attr.pointer;
12842 if (gfc_is_coindexed (e))
12844 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name,
12849 for (ref = e->ref; ref; ref = ref->next)
12851 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12855 && ref->type == REF_ARRAY
12856 && ref->u.ar.type != AR_FULL)
12858 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12859 "be a full array", sym->name, where);
12864 if (e->rank == 0 || has_pointer)
12866 mpz_init_set_ui (size, 1);
12873 /* Find the array section reference. */
12874 for (ref = e->ref; ref; ref = ref->next)
12876 if (ref->type != REF_ARRAY)
12878 if (ref->u.ar.type == AR_ELEMENT)
12884 /* Set marks according to the reference pattern. */
12885 switch (ref->u.ar.type)
12893 /* Get the start position of array section. */
12894 gfc_get_section_index (ar, section_index, &offset);
12899 gcc_unreachable ();
12902 if (gfc_array_size (e, &size) == FAILURE)
12904 gfc_error ("Nonconstant array section at %L in DATA statement",
12906 mpz_clear (offset);
12913 while (mpz_cmp_ui (size, 0) > 0)
12915 if (next_data_value () == FAILURE)
12917 gfc_error ("DATA statement at %L has more variables than values",
12923 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12927 /* If we have more than one element left in the repeat count,
12928 and we have more than one element left in the target variable,
12929 then create a range assignment. */
12930 /* FIXME: Only done for full arrays for now, since array sections
12932 if (mark == AR_FULL && ref && ref->next == NULL
12933 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12937 if (mpz_cmp (size, values.left) >= 0)
12939 mpz_init_set (range, values.left);
12940 mpz_sub (size, size, values.left);
12941 mpz_set_ui (values.left, 0);
12945 mpz_init_set (range, size);
12946 mpz_sub (values.left, values.left, size);
12947 mpz_set_ui (size, 0);
12950 t = gfc_assign_data_value (var->expr, values.vnode->expr,
12953 mpz_add (offset, offset, range);
12960 /* Assign initial value to symbol. */
12963 mpz_sub_ui (values.left, values.left, 1);
12964 mpz_sub_ui (size, size, 1);
12966 t = gfc_assign_data_value (var->expr, values.vnode->expr,
12971 if (mark == AR_FULL)
12972 mpz_add_ui (offset, offset, 1);
12974 /* Modify the array section indexes and recalculate the offset
12975 for next element. */
12976 else if (mark == AR_SECTION)
12977 gfc_advance_section (section_index, ar, &offset);
12981 if (mark == AR_SECTION)
12983 for (i = 0; i < ar->dimen; i++)
12984 mpz_clear (section_index[i]);
12988 mpz_clear (offset);
12994 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
12996 /* Iterate over a list of elements in a DATA statement. */
12999 traverse_data_list (gfc_data_variable *var, locus *where)
13002 iterator_stack frame;
13003 gfc_expr *e, *start, *end, *step;
13004 gfc_try retval = SUCCESS;
13006 mpz_init (frame.value);
13009 start = gfc_copy_expr (var->iter.start);
13010 end = gfc_copy_expr (var->iter.end);
13011 step = gfc_copy_expr (var->iter.step);
13013 if (gfc_simplify_expr (start, 1) == FAILURE
13014 || start->expr_type != EXPR_CONSTANT)
13016 gfc_error ("start of implied-do loop at %L could not be "
13017 "simplified to a constant value", &start->where);
13021 if (gfc_simplify_expr (end, 1) == FAILURE
13022 || end->expr_type != EXPR_CONSTANT)
13024 gfc_error ("end of implied-do loop at %L could not be "
13025 "simplified to a constant value", &start->where);
13029 if (gfc_simplify_expr (step, 1) == FAILURE
13030 || step->expr_type != EXPR_CONSTANT)
13032 gfc_error ("step of implied-do loop at %L could not be "
13033 "simplified to a constant value", &start->where);
13038 mpz_set (trip, end->value.integer);
13039 mpz_sub (trip, trip, start->value.integer);
13040 mpz_add (trip, trip, step->value.integer);
13042 mpz_div (trip, trip, step->value.integer);
13044 mpz_set (frame.value, start->value.integer);
13046 frame.prev = iter_stack;
13047 frame.variable = var->iter.var->symtree;
13048 iter_stack = &frame;
13050 while (mpz_cmp_ui (trip, 0) > 0)
13052 if (traverse_data_var (var->list, where) == FAILURE)
13058 e = gfc_copy_expr (var->expr);
13059 if (gfc_simplify_expr (e, 1) == FAILURE)
13066 mpz_add (frame.value, frame.value, step->value.integer);
13068 mpz_sub_ui (trip, trip, 1);
13072 mpz_clear (frame.value);
13075 gfc_free_expr (start);
13076 gfc_free_expr (end);
13077 gfc_free_expr (step);
13079 iter_stack = frame.prev;
13084 /* Type resolve variables in the variable list of a DATA statement. */
13087 traverse_data_var (gfc_data_variable *var, locus *where)
13091 for (; var; var = var->next)
13093 if (var->expr == NULL)
13094 t = traverse_data_list (var, where);
13096 t = check_data_variable (var, where);
13106 /* Resolve the expressions and iterators associated with a data statement.
13107 This is separate from the assignment checking because data lists should
13108 only be resolved once. */
13111 resolve_data_variables (gfc_data_variable *d)
13113 for (; d; d = d->next)
13115 if (d->list == NULL)
13117 if (gfc_resolve_expr (d->expr) == FAILURE)
13122 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
13125 if (resolve_data_variables (d->list) == FAILURE)
13134 /* Resolve a single DATA statement. We implement this by storing a pointer to
13135 the value list into static variables, and then recursively traversing the
13136 variables list, expanding iterators and such. */
13139 resolve_data (gfc_data *d)
13142 if (resolve_data_variables (d->var) == FAILURE)
13145 values.vnode = d->value;
13146 if (d->value == NULL)
13147 mpz_set_ui (values.left, 0);
13149 mpz_set (values.left, d->value->repeat);
13151 if (traverse_data_var (d->var, &d->where) == FAILURE)
13154 /* At this point, we better not have any values left. */
13156 if (next_data_value () == SUCCESS)
13157 gfc_error ("DATA statement at %L has more values than variables",
13162 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13163 accessed by host or use association, is a dummy argument to a pure function,
13164 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13165 is storage associated with any such variable, shall not be used in the
13166 following contexts: (clients of this function). */
13168 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13169 procedure. Returns zero if assignment is OK, nonzero if there is a
13172 gfc_impure_variable (gfc_symbol *sym)
13177 if (sym->attr.use_assoc || sym->attr.in_common)
13180 /* Check if the symbol's ns is inside the pure procedure. */
13181 for (ns = gfc_current_ns; ns; ns = ns->parent)
13185 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
13189 proc = sym->ns->proc_name;
13190 if (sym->attr.dummy && gfc_pure (proc)
13191 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
13193 proc->attr.function))
13196 /* TODO: Sort out what can be storage associated, if anything, and include
13197 it here. In principle equivalences should be scanned but it does not
13198 seem to be possible to storage associate an impure variable this way. */
13203 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13204 current namespace is inside a pure procedure. */
13207 gfc_pure (gfc_symbol *sym)
13209 symbol_attribute attr;
13214 /* Check if the current namespace or one of its parents
13215 belongs to a pure procedure. */
13216 for (ns = gfc_current_ns; ns; ns = ns->parent)
13218 sym = ns->proc_name;
13222 if (attr.flavor == FL_PROCEDURE && attr.pure)
13230 return attr.flavor == FL_PROCEDURE && attr.pure;
13234 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13235 checks if the current namespace is implicitly pure. Note that this
13236 function returns false for a PURE procedure. */
13239 gfc_implicit_pure (gfc_symbol *sym)
13245 /* Check if the current procedure is implicit_pure. Walk up
13246 the procedure list until we find a procedure. */
13247 for (ns = gfc_current_ns; ns; ns = ns->parent)
13249 sym = ns->proc_name;
13253 if (sym->attr.flavor == FL_PROCEDURE)
13258 return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
13259 && !sym->attr.pure;
13263 /* Test whether the current procedure is elemental or not. */
13266 gfc_elemental (gfc_symbol *sym)
13268 symbol_attribute attr;
13271 sym = gfc_current_ns->proc_name;
13276 return attr.flavor == FL_PROCEDURE && attr.elemental;
13280 /* Warn about unused labels. */
13283 warn_unused_fortran_label (gfc_st_label *label)
13288 warn_unused_fortran_label (label->left);
13290 if (label->defined == ST_LABEL_UNKNOWN)
13293 switch (label->referenced)
13295 case ST_LABEL_UNKNOWN:
13296 gfc_warning ("Label %d at %L defined but not used", label->value,
13300 case ST_LABEL_BAD_TARGET:
13301 gfc_warning ("Label %d at %L defined but cannot be used",
13302 label->value, &label->where);
13309 warn_unused_fortran_label (label->right);
13313 /* Returns the sequence type of a symbol or sequence. */
13316 sequence_type (gfc_typespec ts)
13325 if (ts.u.derived->components == NULL)
13326 return SEQ_NONDEFAULT;
13328 result = sequence_type (ts.u.derived->components->ts);
13329 for (c = ts.u.derived->components->next; c; c = c->next)
13330 if (sequence_type (c->ts) != result)
13336 if (ts.kind != gfc_default_character_kind)
13337 return SEQ_NONDEFAULT;
13339 return SEQ_CHARACTER;
13342 if (ts.kind != gfc_default_integer_kind)
13343 return SEQ_NONDEFAULT;
13345 return SEQ_NUMERIC;
13348 if (!(ts.kind == gfc_default_real_kind
13349 || ts.kind == gfc_default_double_kind))
13350 return SEQ_NONDEFAULT;
13352 return SEQ_NUMERIC;
13355 if (ts.kind != gfc_default_complex_kind)
13356 return SEQ_NONDEFAULT;
13358 return SEQ_NUMERIC;
13361 if (ts.kind != gfc_default_logical_kind)
13362 return SEQ_NONDEFAULT;
13364 return SEQ_NUMERIC;
13367 return SEQ_NONDEFAULT;
13372 /* Resolve derived type EQUIVALENCE object. */
13375 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
13377 gfc_component *c = derived->components;
13382 /* Shall not be an object of nonsequence derived type. */
13383 if (!derived->attr.sequence)
13385 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13386 "attribute to be an EQUIVALENCE object", sym->name,
13391 /* Shall not have allocatable components. */
13392 if (derived->attr.alloc_comp)
13394 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13395 "components to be an EQUIVALENCE object",sym->name,
13400 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
13402 gfc_error ("Derived type variable '%s' at %L with default "
13403 "initialization cannot be in EQUIVALENCE with a variable "
13404 "in COMMON", sym->name, &e->where);
13408 for (; c ; c = c->next)
13410 if (c->ts.type == BT_DERIVED
13411 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
13414 /* Shall not be an object of sequence derived type containing a pointer
13415 in the structure. */
13416 if (c->attr.pointer)
13418 gfc_error ("Derived type variable '%s' at %L with pointer "
13419 "component(s) cannot be an EQUIVALENCE object",
13420 sym->name, &e->where);
13428 /* Resolve equivalence object.
13429 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13430 an allocatable array, an object of nonsequence derived type, an object of
13431 sequence derived type containing a pointer at any level of component
13432 selection, an automatic object, a function name, an entry name, a result
13433 name, a named constant, a structure component, or a subobject of any of
13434 the preceding objects. A substring shall not have length zero. A
13435 derived type shall not have components with default initialization nor
13436 shall two objects of an equivalence group be initialized.
13437 Either all or none of the objects shall have an protected attribute.
13438 The simple constraints are done in symbol.c(check_conflict) and the rest
13439 are implemented here. */
13442 resolve_equivalence (gfc_equiv *eq)
13445 gfc_symbol *first_sym;
13448 locus *last_where = NULL;
13449 seq_type eq_type, last_eq_type;
13450 gfc_typespec *last_ts;
13451 int object, cnt_protected;
13454 last_ts = &eq->expr->symtree->n.sym->ts;
13456 first_sym = eq->expr->symtree->n.sym;
13460 for (object = 1; eq; eq = eq->eq, object++)
13464 e->ts = e->symtree->n.sym->ts;
13465 /* match_varspec might not know yet if it is seeing
13466 array reference or substring reference, as it doesn't
13468 if (e->ref && e->ref->type == REF_ARRAY)
13470 gfc_ref *ref = e->ref;
13471 sym = e->symtree->n.sym;
13473 if (sym->attr.dimension)
13475 ref->u.ar.as = sym->as;
13479 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13480 if (e->ts.type == BT_CHARACTER
13482 && ref->type == REF_ARRAY
13483 && ref->u.ar.dimen == 1
13484 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
13485 && ref->u.ar.stride[0] == NULL)
13487 gfc_expr *start = ref->u.ar.start[0];
13488 gfc_expr *end = ref->u.ar.end[0];
13491 /* Optimize away the (:) reference. */
13492 if (start == NULL && end == NULL)
13495 e->ref = ref->next;
13497 e->ref->next = ref->next;
13502 ref->type = REF_SUBSTRING;
13504 start = gfc_get_int_expr (gfc_default_integer_kind,
13506 ref->u.ss.start = start;
13507 if (end == NULL && e->ts.u.cl)
13508 end = gfc_copy_expr (e->ts.u.cl->length);
13509 ref->u.ss.end = end;
13510 ref->u.ss.length = e->ts.u.cl;
13517 /* Any further ref is an error. */
13520 gcc_assert (ref->type == REF_ARRAY);
13521 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13527 if (gfc_resolve_expr (e) == FAILURE)
13530 sym = e->symtree->n.sym;
13532 if (sym->attr.is_protected)
13534 if (cnt_protected > 0 && cnt_protected != object)
13536 gfc_error ("Either all or none of the objects in the "
13537 "EQUIVALENCE set at %L shall have the "
13538 "PROTECTED attribute",
13543 /* Shall not equivalence common block variables in a PURE procedure. */
13544 if (sym->ns->proc_name
13545 && sym->ns->proc_name->attr.pure
13546 && sym->attr.in_common)
13548 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13549 "object in the pure procedure '%s'",
13550 sym->name, &e->where, sym->ns->proc_name->name);
13554 /* Shall not be a named constant. */
13555 if (e->expr_type == EXPR_CONSTANT)
13557 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13558 "object", sym->name, &e->where);
13562 if (e->ts.type == BT_DERIVED
13563 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
13566 /* Check that the types correspond correctly:
13568 A numeric sequence structure may be equivalenced to another sequence
13569 structure, an object of default integer type, default real type, double
13570 precision real type, default logical type such that components of the
13571 structure ultimately only become associated to objects of the same
13572 kind. A character sequence structure may be equivalenced to an object
13573 of default character kind or another character sequence structure.
13574 Other objects may be equivalenced only to objects of the same type and
13575 kind parameters. */
13577 /* Identical types are unconditionally OK. */
13578 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
13579 goto identical_types;
13581 last_eq_type = sequence_type (*last_ts);
13582 eq_type = sequence_type (sym->ts);
13584 /* Since the pair of objects is not of the same type, mixed or
13585 non-default sequences can be rejected. */
13587 msg = "Sequence %s with mixed components in EQUIVALENCE "
13588 "statement at %L with different type objects";
13590 && last_eq_type == SEQ_MIXED
13591 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
13593 || (eq_type == SEQ_MIXED
13594 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13595 &e->where) == FAILURE))
13598 msg = "Non-default type object or sequence %s in EQUIVALENCE "
13599 "statement at %L with objects of different type";
13601 && last_eq_type == SEQ_NONDEFAULT
13602 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
13603 last_where) == FAILURE)
13604 || (eq_type == SEQ_NONDEFAULT
13605 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13606 &e->where) == FAILURE))
13609 msg ="Non-CHARACTER object '%s' in default CHARACTER "
13610 "EQUIVALENCE statement at %L";
13611 if (last_eq_type == SEQ_CHARACTER
13612 && eq_type != SEQ_CHARACTER
13613 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13614 &e->where) == FAILURE)
13617 msg ="Non-NUMERIC object '%s' in default NUMERIC "
13618 "EQUIVALENCE statement at %L";
13619 if (last_eq_type == SEQ_NUMERIC
13620 && eq_type != SEQ_NUMERIC
13621 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13622 &e->where) == FAILURE)
13627 last_where = &e->where;
13632 /* Shall not be an automatic array. */
13633 if (e->ref->type == REF_ARRAY
13634 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
13636 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13637 "an EQUIVALENCE object", sym->name, &e->where);
13644 /* Shall not be a structure component. */
13645 if (r->type == REF_COMPONENT)
13647 gfc_error ("Structure component '%s' at %L cannot be an "
13648 "EQUIVALENCE object",
13649 r->u.c.component->name, &e->where);
13653 /* A substring shall not have length zero. */
13654 if (r->type == REF_SUBSTRING)
13656 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13658 gfc_error ("Substring at %L has length zero",
13659 &r->u.ss.start->where);
13669 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13672 resolve_fntype (gfc_namespace *ns)
13674 gfc_entry_list *el;
13677 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13680 /* If there are any entries, ns->proc_name is the entry master
13681 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13683 sym = ns->entries->sym;
13685 sym = ns->proc_name;
13686 if (sym->result == sym
13687 && sym->ts.type == BT_UNKNOWN
13688 && gfc_set_default_type (sym, 0, NULL) == FAILURE
13689 && !sym->attr.untyped)
13691 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13692 sym->name, &sym->declared_at);
13693 sym->attr.untyped = 1;
13696 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13697 && !sym->attr.contained
13698 && !gfc_check_symbol_access (sym->ts.u.derived)
13699 && gfc_check_symbol_access (sym))
13701 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13702 "%L of PRIVATE type '%s'", sym->name,
13703 &sym->declared_at, sym->ts.u.derived->name);
13707 for (el = ns->entries->next; el; el = el->next)
13709 if (el->sym->result == el->sym
13710 && el->sym->ts.type == BT_UNKNOWN
13711 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13712 && !el->sym->attr.untyped)
13714 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13715 el->sym->name, &el->sym->declared_at);
13716 el->sym->attr.untyped = 1;
13722 /* 12.3.2.1.1 Defined operators. */
13725 check_uop_procedure (gfc_symbol *sym, locus where)
13727 gfc_formal_arglist *formal;
13729 if (!sym->attr.function)
13731 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13732 sym->name, &where);
13736 if (sym->ts.type == BT_CHARACTER
13737 && !(sym->ts.u.cl && sym->ts.u.cl->length)
13738 && !(sym->result && sym->result->ts.u.cl
13739 && sym->result->ts.u.cl->length))
13741 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13742 "character length", sym->name, &where);
13746 formal = sym->formal;
13747 if (!formal || !formal->sym)
13749 gfc_error ("User operator procedure '%s' at %L must have at least "
13750 "one argument", sym->name, &where);
13754 if (formal->sym->attr.intent != INTENT_IN)
13756 gfc_error ("First argument of operator interface at %L must be "
13757 "INTENT(IN)", &where);
13761 if (formal->sym->attr.optional)
13763 gfc_error ("First argument of operator interface at %L cannot be "
13764 "optional", &where);
13768 formal = formal->next;
13769 if (!formal || !formal->sym)
13772 if (formal->sym->attr.intent != INTENT_IN)
13774 gfc_error ("Second argument of operator interface at %L must be "
13775 "INTENT(IN)", &where);
13779 if (formal->sym->attr.optional)
13781 gfc_error ("Second argument of operator interface at %L cannot be "
13782 "optional", &where);
13788 gfc_error ("Operator interface at %L must have, at most, two "
13789 "arguments", &where);
13797 gfc_resolve_uops (gfc_symtree *symtree)
13799 gfc_interface *itr;
13801 if (symtree == NULL)
13804 gfc_resolve_uops (symtree->left);
13805 gfc_resolve_uops (symtree->right);
13807 for (itr = symtree->n.uop->op; itr; itr = itr->next)
13808 check_uop_procedure (itr->sym, itr->sym->declared_at);
13812 /* Examine all of the expressions associated with a program unit,
13813 assign types to all intermediate expressions, make sure that all
13814 assignments are to compatible types and figure out which names
13815 refer to which functions or subroutines. It doesn't check code
13816 block, which is handled by resolve_code. */
13819 resolve_types (gfc_namespace *ns)
13825 gfc_namespace* old_ns = gfc_current_ns;
13827 /* Check that all IMPLICIT types are ok. */
13828 if (!ns->seen_implicit_none)
13831 for (letter = 0; letter != GFC_LETTERS; ++letter)
13832 if (ns->set_flag[letter]
13833 && resolve_typespec_used (&ns->default_type[letter],
13834 &ns->implicit_loc[letter],
13839 gfc_current_ns = ns;
13841 resolve_entries (ns);
13843 resolve_common_vars (ns->blank_common.head, false);
13844 resolve_common_blocks (ns->common_root);
13846 resolve_contained_functions (ns);
13848 if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
13849 && ns->proc_name->attr.if_source == IFSRC_IFBODY)
13850 resolve_formal_arglist (ns->proc_name);
13852 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13854 for (cl = ns->cl_list; cl; cl = cl->next)
13855 resolve_charlen (cl);
13857 gfc_traverse_ns (ns, resolve_symbol);
13859 resolve_fntype (ns);
13861 for (n = ns->contained; n; n = n->sibling)
13863 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13864 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13865 "also be PURE", n->proc_name->name,
13866 &n->proc_name->declared_at);
13872 do_concurrent_flag = 0;
13873 gfc_check_interfaces (ns);
13875 gfc_traverse_ns (ns, resolve_values);
13881 for (d = ns->data; d; d = d->next)
13885 gfc_traverse_ns (ns, gfc_formalize_init_value);
13887 gfc_traverse_ns (ns, gfc_verify_binding_labels);
13889 if (ns->common_root != NULL)
13890 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13892 for (eq = ns->equiv; eq; eq = eq->next)
13893 resolve_equivalence (eq);
13895 /* Warn about unused labels. */
13896 if (warn_unused_label)
13897 warn_unused_fortran_label (ns->st_labels);
13899 gfc_resolve_uops (ns->uop_root);
13901 gfc_current_ns = old_ns;
13905 /* Call resolve_code recursively. */
13908 resolve_codes (gfc_namespace *ns)
13911 bitmap_obstack old_obstack;
13913 if (ns->resolved == 1)
13916 for (n = ns->contained; n; n = n->sibling)
13919 gfc_current_ns = ns;
13921 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13922 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13925 /* Set to an out of range value. */
13926 current_entry_id = -1;
13928 old_obstack = labels_obstack;
13929 bitmap_obstack_initialize (&labels_obstack);
13931 resolve_code (ns->code, ns);
13933 bitmap_obstack_release (&labels_obstack);
13934 labels_obstack = old_obstack;
13938 /* This function is called after a complete program unit has been compiled.
13939 Its purpose is to examine all of the expressions associated with a program
13940 unit, assign types to all intermediate expressions, make sure that all
13941 assignments are to compatible types and figure out which names refer to
13942 which functions or subroutines. */
13945 gfc_resolve (gfc_namespace *ns)
13947 gfc_namespace *old_ns;
13948 code_stack *old_cs_base;
13954 old_ns = gfc_current_ns;
13955 old_cs_base = cs_base;
13957 resolve_types (ns);
13958 resolve_codes (ns);
13960 gfc_current_ns = old_ns;
13961 cs_base = old_cs_base;
13964 gfc_run_passes (ns);