1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 #include "target-memory.h" /* for gfc_simplify_transfer */
32 #include "constructor.h"
34 /* Types used in equivalence statements. */
38 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
42 /* Stack to keep track of the nesting of blocks as we move through the
43 code. See resolve_branch() and resolve_code(). */
45 typedef struct code_stack
47 struct gfc_code *head, *current;
48 struct code_stack *prev;
50 /* This bitmap keeps track of the targets valid for a branch from
51 inside this block except for END {IF|SELECT}s of enclosing
53 bitmap reachable_labels;
57 static code_stack *cs_base = NULL;
60 /* Nonzero if we're inside a FORALL block. */
62 static int forall_flag;
64 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
66 static int omp_workshare_flag;
68 /* Nonzero if we are processing a formal arglist. The corresponding function
69 resets the flag each time that it is read. */
70 static int formal_arg_flag = 0;
72 /* True if we are resolving a specification expression. */
73 static int specification_expr = 0;
75 /* The id of the last entry seen. */
76 static int current_entry_id;
78 /* We use bitmaps to determine if a branch target is valid. */
79 static bitmap_obstack labels_obstack;
81 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
82 static bool inquiry_argument = false;
85 gfc_is_formal_arg (void)
87 return formal_arg_flag;
90 /* Is the symbol host associated? */
92 is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
94 for (ns = ns->parent; ns; ns = ns->parent)
103 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
104 an ABSTRACT derived-type. If where is not NULL, an error message with that
105 locus is printed, optionally using name. */
108 resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
110 if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
115 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
116 name, where, ts->u.derived->name);
118 gfc_error ("ABSTRACT type '%s' used at %L",
119 ts->u.derived->name, where);
129 static void resolve_symbol (gfc_symbol *sym);
130 static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc);
133 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
136 resolve_procedure_interface (gfc_symbol *sym)
138 if (sym->ts.interface == sym)
140 gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
141 sym->name, &sym->declared_at);
144 if (sym->ts.interface->attr.procedure)
146 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
147 "in a later PROCEDURE statement", sym->ts.interface->name,
148 sym->name, &sym->declared_at);
152 /* Get the attributes from the interface (now resolved). */
153 if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
155 gfc_symbol *ifc = sym->ts.interface;
156 resolve_symbol (ifc);
158 if (ifc->attr.intrinsic)
159 resolve_intrinsic (ifc, &ifc->declared_at);
162 sym->ts = ifc->result->ts;
165 sym->ts.interface = ifc;
166 sym->attr.function = ifc->attr.function;
167 sym->attr.subroutine = ifc->attr.subroutine;
168 gfc_copy_formal_args (sym, ifc);
170 sym->attr.allocatable = ifc->attr.allocatable;
171 sym->attr.pointer = ifc->attr.pointer;
172 sym->attr.pure = ifc->attr.pure;
173 sym->attr.elemental = ifc->attr.elemental;
174 sym->attr.dimension = ifc->attr.dimension;
175 sym->attr.contiguous = ifc->attr.contiguous;
176 sym->attr.recursive = ifc->attr.recursive;
177 sym->attr.always_explicit = ifc->attr.always_explicit;
178 sym->attr.ext_attr |= ifc->attr.ext_attr;
179 /* Copy array spec. */
180 sym->as = gfc_copy_array_spec (ifc->as);
184 for (i = 0; i < sym->as->rank; i++)
186 gfc_expr_replace_symbols (sym->as->lower[i], sym);
187 gfc_expr_replace_symbols (sym->as->upper[i], sym);
190 /* Copy char length. */
191 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
193 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
194 gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
195 if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
196 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
200 else if (sym->ts.interface->name[0] != '\0')
202 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
203 sym->ts.interface->name, sym->name, &sym->declared_at);
211 /* Resolve types of formal argument lists. These have to be done early so that
212 the formal argument lists of module procedures can be copied to the
213 containing module before the individual procedures are resolved
214 individually. We also resolve argument lists of procedures in interface
215 blocks because they are self-contained scoping units.
217 Since a dummy argument cannot be a non-dummy procedure, the only
218 resort left for untyped names are the IMPLICIT types. */
221 resolve_formal_arglist (gfc_symbol *proc)
223 gfc_formal_arglist *f;
227 if (proc->result != NULL)
232 if (gfc_elemental (proc)
233 || sym->attr.pointer || sym->attr.allocatable
234 || (sym->as && sym->as->rank > 0))
236 proc->attr.always_explicit = 1;
237 sym->attr.always_explicit = 1;
242 for (f = proc->formal; f; f = f->next)
248 /* Alternate return placeholder. */
249 if (gfc_elemental (proc))
250 gfc_error ("Alternate return specifier in elemental subroutine "
251 "'%s' at %L is not allowed", proc->name,
253 if (proc->attr.function)
254 gfc_error ("Alternate return specifier in function "
255 "'%s' at %L is not allowed", proc->name,
259 else if (sym->attr.procedure && sym->ts.interface
260 && sym->attr.if_source != IFSRC_DECL)
261 resolve_procedure_interface (sym);
263 if (sym->attr.if_source != IFSRC_UNKNOWN)
264 resolve_formal_arglist (sym);
266 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
268 if (gfc_pure (proc) && !gfc_pure (sym))
270 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
271 "also be PURE", sym->name, &sym->declared_at);
275 if (gfc_elemental (proc))
277 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
278 "procedure", &sym->declared_at);
282 if (sym->attr.function
283 && sym->ts.type == BT_UNKNOWN
284 && sym->attr.intrinsic)
286 gfc_intrinsic_sym *isym;
287 isym = gfc_find_function (sym->name);
288 if (isym == NULL || !isym->specific)
290 gfc_error ("Unable to find a specific INTRINSIC procedure "
291 "for the reference '%s' at %L", sym->name,
300 if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
301 && (!sym->attr.function || sym->result == sym))
302 gfc_set_default_type (sym, 1, sym->ns);
304 gfc_resolve_array_spec (sym->as, 0);
306 /* We can't tell if an array with dimension (:) is assumed or deferred
307 shape until we know if it has the pointer or allocatable attributes.
309 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
310 && !(sym->attr.pointer || sym->attr.allocatable))
312 sym->as->type = AS_ASSUMED_SHAPE;
313 for (i = 0; i < sym->as->rank; i++)
314 sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
318 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
319 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
320 || sym->attr.optional)
322 proc->attr.always_explicit = 1;
324 proc->result->attr.always_explicit = 1;
327 /* If the flavor is unknown at this point, it has to be a variable.
328 A procedure specification would have already set the type. */
330 if (sym->attr.flavor == FL_UNKNOWN)
331 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
333 if (gfc_pure (proc) && !sym->attr.pointer
334 && sym->attr.flavor != FL_PROCEDURE)
336 if (proc->attr.function && sym->attr.intent != INTENT_IN)
337 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
338 "INTENT(IN)", sym->name, proc->name,
341 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
342 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
343 "have its INTENT specified", sym->name, proc->name,
347 if (gfc_elemental (proc))
350 if (sym->attr.codimension)
352 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
353 "procedure", sym->name, &sym->declared_at);
359 gfc_error ("Argument '%s' of elemental procedure at %L must "
360 "be scalar", sym->name, &sym->declared_at);
364 if (sym->attr.allocatable)
366 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
367 "have the ALLOCATABLE attribute", sym->name,
372 if (sym->attr.pointer)
374 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
375 "have the POINTER attribute", sym->name,
380 if (sym->attr.flavor == FL_PROCEDURE)
382 gfc_error ("Dummy procedure '%s' not allowed in elemental "
383 "procedure '%s' at %L", sym->name, proc->name,
388 if (sym->attr.intent == INTENT_UNKNOWN)
390 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
391 "have its INTENT specified", sym->name, proc->name,
397 /* Each dummy shall be specified to be scalar. */
398 if (proc->attr.proc == PROC_ST_FUNCTION)
402 gfc_error ("Argument '%s' of statement function at %L must "
403 "be scalar", sym->name, &sym->declared_at);
407 if (sym->ts.type == BT_CHARACTER)
409 gfc_charlen *cl = sym->ts.u.cl;
410 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
412 gfc_error ("Character-valued argument '%s' of statement "
413 "function at %L must have constant length",
414 sym->name, &sym->declared_at);
424 /* Work function called when searching for symbols that have argument lists
425 associated with them. */
428 find_arglists (gfc_symbol *sym)
430 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
433 resolve_formal_arglist (sym);
437 /* Given a namespace, resolve all formal argument lists within the namespace.
441 resolve_formal_arglists (gfc_namespace *ns)
446 gfc_traverse_ns (ns, find_arglists);
451 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
455 /* If this namespace is not a function or an entry master function,
457 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
458 || sym->attr.entry_master)
461 /* Try to find out of what the return type is. */
462 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
464 t = gfc_set_default_type (sym->result, 0, ns);
466 if (t == FAILURE && !sym->result->attr.untyped)
468 if (sym->result == sym)
469 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
470 sym->name, &sym->declared_at);
471 else if (!sym->result->attr.proc_pointer)
472 gfc_error ("Result '%s' of contained function '%s' at %L has "
473 "no IMPLICIT type", sym->result->name, sym->name,
474 &sym->result->declared_at);
475 sym->result->attr.untyped = 1;
479 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
480 type, lists the only ways a character length value of * can be used:
481 dummy arguments of procedures, named constants, and function results
482 in external functions. Internal function results and results of module
483 procedures are not on this list, ergo, not permitted. */
485 if (sym->result->ts.type == BT_CHARACTER)
487 gfc_charlen *cl = sym->result->ts.u.cl;
488 if (!cl || !cl->length)
490 /* See if this is a module-procedure and adapt error message
493 gcc_assert (ns->parent && ns->parent->proc_name);
494 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
496 gfc_error ("Character-valued %s '%s' at %L must not be"
498 module_proc ? _("module procedure")
499 : _("internal function"),
500 sym->name, &sym->declared_at);
506 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
507 introduce duplicates. */
510 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
512 gfc_formal_arglist *f, *new_arglist;
515 for (; new_args != NULL; new_args = new_args->next)
517 new_sym = new_args->sym;
518 /* See if this arg is already in the formal argument list. */
519 for (f = proc->formal; f; f = f->next)
521 if (new_sym == f->sym)
528 /* Add a new argument. Argument order is not important. */
529 new_arglist = gfc_get_formal_arglist ();
530 new_arglist->sym = new_sym;
531 new_arglist->next = proc->formal;
532 proc->formal = new_arglist;
537 /* Flag the arguments that are not present in all entries. */
540 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
542 gfc_formal_arglist *f, *head;
545 for (f = proc->formal; f; f = f->next)
550 for (new_args = head; new_args; new_args = new_args->next)
552 if (new_args->sym == f->sym)
559 f->sym->attr.not_always_present = 1;
564 /* Resolve alternate entry points. If a symbol has multiple entry points we
565 create a new master symbol for the main routine, and turn the existing
566 symbol into an entry point. */
569 resolve_entries (gfc_namespace *ns)
571 gfc_namespace *old_ns;
575 char name[GFC_MAX_SYMBOL_LEN + 1];
576 static int master_count = 0;
578 if (ns->proc_name == NULL)
581 /* No need to do anything if this procedure doesn't have alternate entry
586 /* We may already have resolved alternate entry points. */
587 if (ns->proc_name->attr.entry_master)
590 /* If this isn't a procedure something has gone horribly wrong. */
591 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
593 /* Remember the current namespace. */
594 old_ns = gfc_current_ns;
598 /* Add the main entry point to the list of entry points. */
599 el = gfc_get_entry_list ();
600 el->sym = ns->proc_name;
602 el->next = ns->entries;
604 ns->proc_name->attr.entry = 1;
606 /* If it is a module function, it needs to be in the right namespace
607 so that gfc_get_fake_result_decl can gather up the results. The
608 need for this arose in get_proc_name, where these beasts were
609 left in their own namespace, to keep prior references linked to
610 the entry declaration.*/
611 if (ns->proc_name->attr.function
612 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
615 /* Do the same for entries where the master is not a module
616 procedure. These are retained in the module namespace because
617 of the module procedure declaration. */
618 for (el = el->next; el; el = el->next)
619 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
620 && el->sym->attr.mod_proc)
624 /* Add an entry statement for it. */
631 /* Create a new symbol for the master function. */
632 /* Give the internal function a unique name (within this file).
633 Also include the function name so the user has some hope of figuring
634 out what is going on. */
635 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
636 master_count++, ns->proc_name->name);
637 gfc_get_ha_symbol (name, &proc);
638 gcc_assert (proc != NULL);
640 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
641 if (ns->proc_name->attr.subroutine)
642 gfc_add_subroutine (&proc->attr, proc->name, NULL);
646 gfc_typespec *ts, *fts;
647 gfc_array_spec *as, *fas;
648 gfc_add_function (&proc->attr, proc->name, NULL);
650 fas = ns->entries->sym->as;
651 fas = fas ? fas : ns->entries->sym->result->as;
652 fts = &ns->entries->sym->result->ts;
653 if (fts->type == BT_UNKNOWN)
654 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
655 for (el = ns->entries->next; el; el = el->next)
657 ts = &el->sym->result->ts;
659 as = as ? as : el->sym->result->as;
660 if (ts->type == BT_UNKNOWN)
661 ts = gfc_get_default_type (el->sym->result->name, NULL);
663 if (! gfc_compare_types (ts, fts)
664 || (el->sym->result->attr.dimension
665 != ns->entries->sym->result->attr.dimension)
666 || (el->sym->result->attr.pointer
667 != ns->entries->sym->result->attr.pointer))
669 else if (as && fas && ns->entries->sym->result != el->sym->result
670 && gfc_compare_array_spec (as, fas) == 0)
671 gfc_error ("Function %s at %L has entries with mismatched "
672 "array specifications", ns->entries->sym->name,
673 &ns->entries->sym->declared_at);
674 /* The characteristics need to match and thus both need to have
675 the same string length, i.e. both len=*, or both len=4.
676 Having both len=<variable> is also possible, but difficult to
677 check at compile time. */
678 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
679 && (((ts->u.cl->length && !fts->u.cl->length)
680 ||(!ts->u.cl->length && fts->u.cl->length))
682 && ts->u.cl->length->expr_type
683 != fts->u.cl->length->expr_type)
685 && ts->u.cl->length->expr_type == EXPR_CONSTANT
686 && mpz_cmp (ts->u.cl->length->value.integer,
687 fts->u.cl->length->value.integer) != 0)))
688 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
689 "entries returning variables of different "
690 "string lengths", ns->entries->sym->name,
691 &ns->entries->sym->declared_at);
696 sym = ns->entries->sym->result;
697 /* All result types the same. */
699 if (sym->attr.dimension)
700 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
701 if (sym->attr.pointer)
702 gfc_add_pointer (&proc->attr, NULL);
706 /* Otherwise the result will be passed through a union by
708 proc->attr.mixed_entry_master = 1;
709 for (el = ns->entries; el; el = el->next)
711 sym = el->sym->result;
712 if (sym->attr.dimension)
714 if (el == ns->entries)
715 gfc_error ("FUNCTION result %s can't be an array in "
716 "FUNCTION %s at %L", sym->name,
717 ns->entries->sym->name, &sym->declared_at);
719 gfc_error ("ENTRY result %s can't be an array in "
720 "FUNCTION %s at %L", sym->name,
721 ns->entries->sym->name, &sym->declared_at);
723 else if (sym->attr.pointer)
725 if (el == ns->entries)
726 gfc_error ("FUNCTION result %s can't be a POINTER in "
727 "FUNCTION %s at %L", sym->name,
728 ns->entries->sym->name, &sym->declared_at);
730 gfc_error ("ENTRY result %s can't be a POINTER in "
731 "FUNCTION %s at %L", sym->name,
732 ns->entries->sym->name, &sym->declared_at);
737 if (ts->type == BT_UNKNOWN)
738 ts = gfc_get_default_type (sym->name, NULL);
742 if (ts->kind == gfc_default_integer_kind)
746 if (ts->kind == gfc_default_real_kind
747 || ts->kind == gfc_default_double_kind)
751 if (ts->kind == gfc_default_complex_kind)
755 if (ts->kind == gfc_default_logical_kind)
759 /* We will issue error elsewhere. */
767 if (el == ns->entries)
768 gfc_error ("FUNCTION result %s can't be of type %s "
769 "in FUNCTION %s at %L", sym->name,
770 gfc_typename (ts), ns->entries->sym->name,
773 gfc_error ("ENTRY result %s can't be of type %s "
774 "in FUNCTION %s at %L", sym->name,
775 gfc_typename (ts), ns->entries->sym->name,
782 proc->attr.access = ACCESS_PRIVATE;
783 proc->attr.entry_master = 1;
785 /* Merge all the entry point arguments. */
786 for (el = ns->entries; el; el = el->next)
787 merge_argument_lists (proc, el->sym->formal);
789 /* Check the master formal arguments for any that are not
790 present in all entry points. */
791 for (el = ns->entries; el; el = el->next)
792 check_argument_lists (proc, el->sym->formal);
794 /* Use the master function for the function body. */
795 ns->proc_name = proc;
797 /* Finalize the new symbols. */
798 gfc_commit_symbols ();
800 /* Restore the original namespace. */
801 gfc_current_ns = old_ns;
805 /* Resolve common variables. */
807 resolve_common_vars (gfc_symbol *sym, bool named_common)
809 gfc_symbol *csym = sym;
811 for (; csym; csym = csym->common_next)
813 if (csym->value || csym->attr.data)
815 if (!csym->ns->is_block_data)
816 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
817 "but only in BLOCK DATA initialization is "
818 "allowed", csym->name, &csym->declared_at);
819 else if (!named_common)
820 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
821 "in a blank COMMON but initialization is only "
822 "allowed in named common blocks", csym->name,
826 if (csym->ts.type != BT_DERIVED)
829 if (!(csym->ts.u.derived->attr.sequence
830 || csym->ts.u.derived->attr.is_bind_c))
831 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
832 "has neither the SEQUENCE nor the BIND(C) "
833 "attribute", csym->name, &csym->declared_at);
834 if (csym->ts.u.derived->attr.alloc_comp)
835 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
836 "has an ultimate component that is "
837 "allocatable", csym->name, &csym->declared_at);
838 if (gfc_has_default_initializer (csym->ts.u.derived))
839 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
840 "may not have default initializer", csym->name,
843 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
844 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
848 /* Resolve common blocks. */
850 resolve_common_blocks (gfc_symtree *common_root)
854 if (common_root == NULL)
857 if (common_root->left)
858 resolve_common_blocks (common_root->left);
859 if (common_root->right)
860 resolve_common_blocks (common_root->right);
862 resolve_common_vars (common_root->n.common->head, true);
864 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
868 if (sym->attr.flavor == FL_PARAMETER)
869 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
870 sym->name, &common_root->n.common->where, &sym->declared_at);
872 if (sym->attr.intrinsic)
873 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
874 sym->name, &common_root->n.common->where);
875 else if (sym->attr.result
876 || gfc_is_function_return_value (sym, gfc_current_ns))
877 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
878 "that is also a function result", sym->name,
879 &common_root->n.common->where);
880 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
881 && sym->attr.proc != PROC_ST_FUNCTION)
882 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
883 "that is also a global procedure", sym->name,
884 &common_root->n.common->where);
888 /* Resolve contained function types. Because contained functions can call one
889 another, they have to be worked out before any of the contained procedures
892 The good news is that if a function doesn't already have a type, the only
893 way it can get one is through an IMPLICIT type or a RESULT variable, because
894 by definition contained functions are contained namespace they're contained
895 in, not in a sibling or parent namespace. */
898 resolve_contained_functions (gfc_namespace *ns)
900 gfc_namespace *child;
903 resolve_formal_arglists (ns);
905 for (child = ns->contained; child; child = child->sibling)
907 /* Resolve alternate entry points first. */
908 resolve_entries (child);
910 /* Then check function return types. */
911 resolve_contained_fntype (child->proc_name, child);
912 for (el = child->entries; el; el = el->next)
913 resolve_contained_fntype (el->sym, child);
918 /* Resolve all of the elements of a structure constructor and make sure that
919 the types are correct. The 'init' flag indicates that the given
920 constructor is an initializer. */
923 resolve_structure_cons (gfc_expr *expr, int init)
925 gfc_constructor *cons;
932 if (expr->ts.type == BT_DERIVED)
933 resolve_symbol (expr->ts.u.derived);
935 cons = gfc_constructor_first (expr->value.constructor);
936 /* A constructor may have references if it is the result of substituting a
937 parameter variable. In this case we just pull out the component we
940 comp = expr->ref->u.c.sym->components;
942 comp = expr->ts.u.derived->components;
944 /* See if the user is trying to invoke a structure constructor for one of
945 the iso_c_binding derived types. */
946 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
947 && expr->ts.u.derived->ts.is_iso_c && cons
948 && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
950 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
951 expr->ts.u.derived->name, &(expr->where));
955 /* Return if structure constructor is c_null_(fun)prt. */
956 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
957 && expr->ts.u.derived->ts.is_iso_c && cons
958 && cons->expr && cons->expr->expr_type == EXPR_NULL)
961 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
968 if (gfc_resolve_expr (cons->expr) == FAILURE)
974 rank = comp->as ? comp->as->rank : 0;
975 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
976 && (comp->attr.allocatable || cons->expr->rank))
978 gfc_error ("The rank of the element in the derived type "
979 "constructor at %L does not match that of the "
980 "component (%d/%d)", &cons->expr->where,
981 cons->expr->rank, rank);
985 /* If we don't have the right type, try to convert it. */
987 if (!comp->attr.proc_pointer &&
988 !gfc_compare_types (&cons->expr->ts, &comp->ts))
991 if (strcmp (comp->name, "$extends") == 0)
993 /* Can afford to be brutal with the $extends initializer.
994 The derived type can get lost because it is PRIVATE
995 but it is not usage constrained by the standard. */
996 cons->expr->ts = comp->ts;
999 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1000 gfc_error ("The element in the derived type constructor at %L, "
1001 "for pointer component '%s', is %s but should be %s",
1002 &cons->expr->where, comp->name,
1003 gfc_basic_typename (cons->expr->ts.type),
1004 gfc_basic_typename (comp->ts.type));
1006 t = gfc_convert_type (cons->expr, &comp->ts, 1);
1009 /* For strings, the length of the constructor should be the same as
1010 the one of the structure, ensure this if the lengths are known at
1011 compile time and when we are dealing with PARAMETER or structure
1013 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1014 && comp->ts.u.cl->length
1015 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1016 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1017 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1018 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1019 comp->ts.u.cl->length->value.integer) != 0)
1021 if (cons->expr->expr_type == EXPR_VARIABLE
1022 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1024 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1025 to make use of the gfc_resolve_character_array_constructor
1026 machinery. The expression is later simplified away to
1027 an array of string literals. */
1028 gfc_expr *para = cons->expr;
1029 cons->expr = gfc_get_expr ();
1030 cons->expr->ts = para->ts;
1031 cons->expr->where = para->where;
1032 cons->expr->expr_type = EXPR_ARRAY;
1033 cons->expr->rank = para->rank;
1034 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1035 gfc_constructor_append_expr (&cons->expr->value.constructor,
1036 para, &cons->expr->where);
1038 if (cons->expr->expr_type == EXPR_ARRAY)
1041 p = gfc_constructor_first (cons->expr->value.constructor);
1042 if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
1044 gfc_charlen *cl, *cl2;
1047 for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
1049 if (cl == cons->expr->ts.u.cl)
1057 cl2->next = cl->next;
1059 gfc_free_expr (cl->length);
1063 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1064 cons->expr->ts.u.cl->length_from_typespec = true;
1065 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1066 gfc_resolve_character_array_constructor (cons->expr);
1070 if (cons->expr->expr_type == EXPR_NULL
1071 && !(comp->attr.pointer || comp->attr.allocatable
1072 || comp->attr.proc_pointer
1073 || (comp->ts.type == BT_CLASS
1074 && (CLASS_DATA (comp)->attr.class_pointer
1075 || CLASS_DATA (comp)->attr.allocatable))))
1078 gfc_error ("The NULL in the derived type constructor at %L is "
1079 "being applied to component '%s', which is neither "
1080 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1084 if (!comp->attr.pointer || comp->attr.proc_pointer
1085 || cons->expr->expr_type == EXPR_NULL)
1088 a = gfc_expr_attr (cons->expr);
1090 if (!a.pointer && !a.target)
1093 gfc_error ("The element in the derived type constructor at %L, "
1094 "for pointer component '%s' should be a POINTER or "
1095 "a TARGET", &cons->expr->where, comp->name);
1100 /* F08:C461. Additional checks for pointer initialization. */
1104 gfc_error ("Pointer initialization target at %L "
1105 "must not be ALLOCATABLE ", &cons->expr->where);
1110 gfc_error ("Pointer initialization target at %L "
1111 "must have the SAVE attribute", &cons->expr->where);
1115 /* F2003, C1272 (3). */
1116 if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
1117 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1118 || gfc_is_coindexed (cons->expr)))
1121 gfc_error ("Invalid expression in the derived type constructor for "
1122 "pointer component '%s' at %L in PURE procedure",
1123 comp->name, &cons->expr->where);
1132 /****************** Expression name resolution ******************/
1134 /* Returns 0 if a symbol was not declared with a type or
1135 attribute declaration statement, nonzero otherwise. */
1138 was_declared (gfc_symbol *sym)
1144 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1147 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1148 || a.optional || a.pointer || a.save || a.target || a.volatile_
1149 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1150 || a.asynchronous || a.codimension)
1157 /* Determine if a symbol is generic or not. */
1160 generic_sym (gfc_symbol *sym)
1164 if (sym->attr.generic ||
1165 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1168 if (was_declared (sym) || sym->ns->parent == NULL)
1171 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1178 return generic_sym (s);
1185 /* Determine if a symbol is specific or not. */
1188 specific_sym (gfc_symbol *sym)
1192 if (sym->attr.if_source == IFSRC_IFBODY
1193 || sym->attr.proc == PROC_MODULE
1194 || sym->attr.proc == PROC_INTERNAL
1195 || sym->attr.proc == PROC_ST_FUNCTION
1196 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1197 || sym->attr.external)
1200 if (was_declared (sym) || sym->ns->parent == NULL)
1203 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1205 return (s == NULL) ? 0 : specific_sym (s);
1209 /* Figure out if the procedure is specific, generic or unknown. */
1212 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1216 procedure_kind (gfc_symbol *sym)
1218 if (generic_sym (sym))
1219 return PTYPE_GENERIC;
1221 if (specific_sym (sym))
1222 return PTYPE_SPECIFIC;
1224 return PTYPE_UNKNOWN;
1227 /* Check references to assumed size arrays. The flag need_full_assumed_size
1228 is nonzero when matching actual arguments. */
1230 static int need_full_assumed_size = 0;
1233 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1235 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1238 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1239 What should it be? */
1240 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1241 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1242 && (e->ref->u.ar.type == AR_FULL))
1244 gfc_error ("The upper bound in the last dimension must "
1245 "appear in the reference to the assumed size "
1246 "array '%s' at %L", sym->name, &e->where);
1253 /* Look for bad assumed size array references in argument expressions
1254 of elemental and array valued intrinsic procedures. Since this is
1255 called from procedure resolution functions, it only recurses at
1259 resolve_assumed_size_actual (gfc_expr *e)
1264 switch (e->expr_type)
1267 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1272 if (resolve_assumed_size_actual (e->value.op.op1)
1273 || resolve_assumed_size_actual (e->value.op.op2))
1284 /* Check a generic procedure, passed as an actual argument, to see if
1285 there is a matching specific name. If none, it is an error, and if
1286 more than one, the reference is ambiguous. */
1288 count_specific_procs (gfc_expr *e)
1295 sym = e->symtree->n.sym;
1297 for (p = sym->generic; p; p = p->next)
1298 if (strcmp (sym->name, p->sym->name) == 0)
1300 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1306 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1310 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1311 "argument at %L", sym->name, &e->where);
1317 /* See if a call to sym could possibly be a not allowed RECURSION because of
1318 a missing RECURIVE declaration. This means that either sym is the current
1319 context itself, or sym is the parent of a contained procedure calling its
1320 non-RECURSIVE containing procedure.
1321 This also works if sym is an ENTRY. */
1324 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1326 gfc_symbol* proc_sym;
1327 gfc_symbol* context_proc;
1328 gfc_namespace* real_context;
1330 if (sym->attr.flavor == FL_PROGRAM)
1333 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1335 /* If we've got an ENTRY, find real procedure. */
1336 if (sym->attr.entry && sym->ns->entries)
1337 proc_sym = sym->ns->entries->sym;
1341 /* If sym is RECURSIVE, all is well of course. */
1342 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1345 /* Find the context procedure's "real" symbol if it has entries.
1346 We look for a procedure symbol, so recurse on the parents if we don't
1347 find one (like in case of a BLOCK construct). */
1348 for (real_context = context; ; real_context = real_context->parent)
1350 /* We should find something, eventually! */
1351 gcc_assert (real_context);
1353 context_proc = (real_context->entries ? real_context->entries->sym
1354 : real_context->proc_name);
1356 /* In some special cases, there may not be a proc_name, like for this
1358 real(bad_kind()) function foo () ...
1359 when checking the call to bad_kind ().
1360 In these cases, we simply return here and assume that the
1365 if (context_proc->attr.flavor != FL_LABEL)
1369 /* A call from sym's body to itself is recursion, of course. */
1370 if (context_proc == proc_sym)
1373 /* The same is true if context is a contained procedure and sym the
1375 if (context_proc->attr.contained)
1377 gfc_symbol* parent_proc;
1379 gcc_assert (context->parent);
1380 parent_proc = (context->parent->entries ? context->parent->entries->sym
1381 : context->parent->proc_name);
1383 if (parent_proc == proc_sym)
1391 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1392 its typespec and formal argument list. */
1395 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1397 gfc_intrinsic_sym* isym = NULL;
1403 /* We already know this one is an intrinsic, so we don't call
1404 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1405 gfc_find_subroutine directly to check whether it is a function or
1408 if (sym->intmod_sym_id)
1409 isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
1411 isym = gfc_find_function (sym->name);
1415 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1416 && !sym->attr.implicit_type)
1417 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1418 " ignored", sym->name, &sym->declared_at);
1420 if (!sym->attr.function &&
1421 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1426 else if ((isym = gfc_find_subroutine (sym->name)))
1428 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1430 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1431 " specifier", sym->name, &sym->declared_at);
1435 if (!sym->attr.subroutine &&
1436 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1441 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1446 gfc_copy_formal_args_intr (sym, isym);
1448 /* Check it is actually available in the standard settings. */
1449 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1452 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1453 " available in the current standard settings but %s. Use"
1454 " an appropriate -std=* option or enable -fall-intrinsics"
1455 " in order to use it.",
1456 sym->name, &sym->declared_at, symstd);
1464 /* Resolve a procedure expression, like passing it to a called procedure or as
1465 RHS for a procedure pointer assignment. */
1468 resolve_procedure_expression (gfc_expr* expr)
1472 if (expr->expr_type != EXPR_VARIABLE)
1474 gcc_assert (expr->symtree);
1476 sym = expr->symtree->n.sym;
1478 if (sym->attr.intrinsic)
1479 resolve_intrinsic (sym, &expr->where);
1481 if (sym->attr.flavor != FL_PROCEDURE
1482 || (sym->attr.function && sym->result == sym))
1485 /* A non-RECURSIVE procedure that is used as procedure expression within its
1486 own body is in danger of being called recursively. */
1487 if (is_illegal_recursion (sym, gfc_current_ns))
1488 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1489 " itself recursively. Declare it RECURSIVE or use"
1490 " -frecursive", sym->name, &expr->where);
1496 /* Resolve an actual argument list. Most of the time, this is just
1497 resolving the expressions in the list.
1498 The exception is that we sometimes have to decide whether arguments
1499 that look like procedure arguments are really simple variable
1503 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1504 bool no_formal_args)
1507 gfc_symtree *parent_st;
1509 int save_need_full_assumed_size;
1510 gfc_component *comp;
1512 for (; arg; arg = arg->next)
1517 /* Check the label is a valid branching target. */
1520 if (arg->label->defined == ST_LABEL_UNKNOWN)
1522 gfc_error ("Label %d referenced at %L is never defined",
1523 arg->label->value, &arg->label->where);
1530 if (gfc_is_proc_ptr_comp (e, &comp))
1533 if (e->expr_type == EXPR_PPC)
1535 if (comp->as != NULL)
1536 e->rank = comp->as->rank;
1537 e->expr_type = EXPR_FUNCTION;
1539 if (gfc_resolve_expr (e) == FAILURE)
1544 if (e->expr_type == EXPR_VARIABLE
1545 && e->symtree->n.sym->attr.generic
1547 && count_specific_procs (e) != 1)
1550 if (e->ts.type != BT_PROCEDURE)
1552 save_need_full_assumed_size = need_full_assumed_size;
1553 if (e->expr_type != EXPR_VARIABLE)
1554 need_full_assumed_size = 0;
1555 if (gfc_resolve_expr (e) != SUCCESS)
1557 need_full_assumed_size = save_need_full_assumed_size;
1561 /* See if the expression node should really be a variable reference. */
1563 sym = e->symtree->n.sym;
1565 if (sym->attr.flavor == FL_PROCEDURE
1566 || sym->attr.intrinsic
1567 || sym->attr.external)
1571 /* If a procedure is not already determined to be something else
1572 check if it is intrinsic. */
1573 if (!sym->attr.intrinsic
1574 && !(sym->attr.external || sym->attr.use_assoc
1575 || sym->attr.if_source == IFSRC_IFBODY)
1576 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1577 sym->attr.intrinsic = 1;
1579 if (sym->attr.proc == PROC_ST_FUNCTION)
1581 gfc_error ("Statement function '%s' at %L is not allowed as an "
1582 "actual argument", sym->name, &e->where);
1585 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1586 sym->attr.subroutine);
1587 if (sym->attr.intrinsic && actual_ok == 0)
1589 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1590 "actual argument", sym->name, &e->where);
1593 if (sym->attr.contained && !sym->attr.use_assoc
1594 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1596 if (gfc_notify_std (GFC_STD_F2008,
1597 "Fortran 2008: Internal procedure '%s' is"
1598 " used as actual argument at %L",
1599 sym->name, &e->where) == FAILURE)
1603 if (sym->attr.elemental && !sym->attr.intrinsic)
1605 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1606 "allowed as an actual argument at %L", sym->name,
1610 /* Check if a generic interface has a specific procedure
1611 with the same name before emitting an error. */
1612 if (sym->attr.generic && count_specific_procs (e) != 1)
1615 /* Just in case a specific was found for the expression. */
1616 sym = e->symtree->n.sym;
1618 /* If the symbol is the function that names the current (or
1619 parent) scope, then we really have a variable reference. */
1621 if (gfc_is_function_return_value (sym, sym->ns))
1624 /* If all else fails, see if we have a specific intrinsic. */
1625 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1627 gfc_intrinsic_sym *isym;
1629 isym = gfc_find_function (sym->name);
1630 if (isym == NULL || !isym->specific)
1632 gfc_error ("Unable to find a specific INTRINSIC procedure "
1633 "for the reference '%s' at %L", sym->name,
1638 sym->attr.intrinsic = 1;
1639 sym->attr.function = 1;
1642 if (gfc_resolve_expr (e) == FAILURE)
1647 /* See if the name is a module procedure in a parent unit. */
1649 if (was_declared (sym) || sym->ns->parent == NULL)
1652 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1654 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1658 if (parent_st == NULL)
1661 sym = parent_st->n.sym;
1662 e->symtree = parent_st; /* Point to the right thing. */
1664 if (sym->attr.flavor == FL_PROCEDURE
1665 || sym->attr.intrinsic
1666 || sym->attr.external)
1668 if (gfc_resolve_expr (e) == FAILURE)
1674 e->expr_type = EXPR_VARIABLE;
1676 if (sym->as != NULL)
1678 e->rank = sym->as->rank;
1679 e->ref = gfc_get_ref ();
1680 e->ref->type = REF_ARRAY;
1681 e->ref->u.ar.type = AR_FULL;
1682 e->ref->u.ar.as = sym->as;
1685 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1686 primary.c (match_actual_arg). If above code determines that it
1687 is a variable instead, it needs to be resolved as it was not
1688 done at the beginning of this function. */
1689 save_need_full_assumed_size = need_full_assumed_size;
1690 if (e->expr_type != EXPR_VARIABLE)
1691 need_full_assumed_size = 0;
1692 if (gfc_resolve_expr (e) != SUCCESS)
1694 need_full_assumed_size = save_need_full_assumed_size;
1697 /* Check argument list functions %VAL, %LOC and %REF. There is
1698 nothing to do for %REF. */
1699 if (arg->name && arg->name[0] == '%')
1701 if (strncmp ("%VAL", arg->name, 4) == 0)
1703 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1705 gfc_error ("By-value argument at %L is not of numeric "
1712 gfc_error ("By-value argument at %L cannot be an array or "
1713 "an array section", &e->where);
1717 /* Intrinsics are still PROC_UNKNOWN here. However,
1718 since same file external procedures are not resolvable
1719 in gfortran, it is a good deal easier to leave them to
1721 if (ptype != PROC_UNKNOWN
1722 && ptype != PROC_DUMMY
1723 && ptype != PROC_EXTERNAL
1724 && ptype != PROC_MODULE)
1726 gfc_error ("By-value argument at %L is not allowed "
1727 "in this context", &e->where);
1732 /* Statement functions have already been excluded above. */
1733 else if (strncmp ("%LOC", arg->name, 4) == 0
1734 && e->ts.type == BT_PROCEDURE)
1736 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1738 gfc_error ("Passing internal procedure at %L by location "
1739 "not allowed", &e->where);
1745 /* Fortran 2008, C1237. */
1746 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1747 && gfc_has_ultimate_pointer (e))
1749 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1750 "component", &e->where);
1759 /* Do the checks of the actual argument list that are specific to elemental
1760 procedures. If called with c == NULL, we have a function, otherwise if
1761 expr == NULL, we have a subroutine. */
1764 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1766 gfc_actual_arglist *arg0;
1767 gfc_actual_arglist *arg;
1768 gfc_symbol *esym = NULL;
1769 gfc_intrinsic_sym *isym = NULL;
1771 gfc_intrinsic_arg *iformal = NULL;
1772 gfc_formal_arglist *eformal = NULL;
1773 bool formal_optional = false;
1774 bool set_by_optional = false;
1778 /* Is this an elemental procedure? */
1779 if (expr && expr->value.function.actual != NULL)
1781 if (expr->value.function.esym != NULL
1782 && expr->value.function.esym->attr.elemental)
1784 arg0 = expr->value.function.actual;
1785 esym = expr->value.function.esym;
1787 else if (expr->value.function.isym != NULL
1788 && expr->value.function.isym->elemental)
1790 arg0 = expr->value.function.actual;
1791 isym = expr->value.function.isym;
1796 else if (c && c->ext.actual != NULL)
1798 arg0 = c->ext.actual;
1800 if (c->resolved_sym)
1801 esym = c->resolved_sym;
1803 esym = c->symtree->n.sym;
1806 if (!esym->attr.elemental)
1812 /* The rank of an elemental is the rank of its array argument(s). */
1813 for (arg = arg0; arg; arg = arg->next)
1815 if (arg->expr != NULL && arg->expr->rank > 0)
1817 rank = arg->expr->rank;
1818 if (arg->expr->expr_type == EXPR_VARIABLE
1819 && arg->expr->symtree->n.sym->attr.optional)
1820 set_by_optional = true;
1822 /* Function specific; set the result rank and shape. */
1826 if (!expr->shape && arg->expr->shape)
1828 expr->shape = gfc_get_shape (rank);
1829 for (i = 0; i < rank; i++)
1830 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1837 /* If it is an array, it shall not be supplied as an actual argument
1838 to an elemental procedure unless an array of the same rank is supplied
1839 as an actual argument corresponding to a nonoptional dummy argument of
1840 that elemental procedure(12.4.1.5). */
1841 formal_optional = false;
1843 iformal = isym->formal;
1845 eformal = esym->formal;
1847 for (arg = arg0; arg; arg = arg->next)
1851 if (eformal->sym && eformal->sym->attr.optional)
1852 formal_optional = true;
1853 eformal = eformal->next;
1855 else if (isym && iformal)
1857 if (iformal->optional)
1858 formal_optional = true;
1859 iformal = iformal->next;
1862 formal_optional = true;
1864 if (pedantic && arg->expr != NULL
1865 && arg->expr->expr_type == EXPR_VARIABLE
1866 && arg->expr->symtree->n.sym->attr.optional
1869 && (set_by_optional || arg->expr->rank != rank)
1870 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1872 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1873 "MISSING, it cannot be the actual argument of an "
1874 "ELEMENTAL procedure unless there is a non-optional "
1875 "argument with the same rank (12.4.1.5)",
1876 arg->expr->symtree->n.sym->name, &arg->expr->where);
1881 for (arg = arg0; arg; arg = arg->next)
1883 if (arg->expr == NULL || arg->expr->rank == 0)
1886 /* Being elemental, the last upper bound of an assumed size array
1887 argument must be present. */
1888 if (resolve_assumed_size_actual (arg->expr))
1891 /* Elemental procedure's array actual arguments must conform. */
1894 if (gfc_check_conformance (arg->expr, e,
1895 "elemental procedure") == FAILURE)
1902 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1903 is an array, the intent inout/out variable needs to be also an array. */
1904 if (rank > 0 && esym && expr == NULL)
1905 for (eformal = esym->formal, arg = arg0; arg && eformal;
1906 arg = arg->next, eformal = eformal->next)
1907 if ((eformal->sym->attr.intent == INTENT_OUT
1908 || eformal->sym->attr.intent == INTENT_INOUT)
1909 && arg->expr && arg->expr->rank == 0)
1911 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1912 "ELEMENTAL subroutine '%s' is a scalar, but another "
1913 "actual argument is an array", &arg->expr->where,
1914 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1915 : "INOUT", eformal->sym->name, esym->name);
1922 /* This function does the checking of references to global procedures
1923 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1924 77 and 95 standards. It checks for a gsymbol for the name, making
1925 one if it does not already exist. If it already exists, then the
1926 reference being resolved must correspond to the type of gsymbol.
1927 Otherwise, the new symbol is equipped with the attributes of the
1928 reference. The corresponding code that is called in creating
1929 global entities is parse.c.
1931 In addition, for all but -std=legacy, the gsymbols are used to
1932 check the interfaces of external procedures from the same file.
1933 The namespace of the gsymbol is resolved and then, once this is
1934 done the interface is checked. */
1938 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
1940 if (!gsym_ns->proc_name->attr.recursive)
1943 if (sym->ns == gsym_ns)
1946 if (sym->ns->parent && sym->ns->parent == gsym_ns)
1953 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
1955 if (gsym_ns->entries)
1957 gfc_entry_list *entry = gsym_ns->entries;
1959 for (; entry; entry = entry->next)
1961 if (strcmp (sym->name, entry->sym->name) == 0)
1963 if (strcmp (gsym_ns->proc_name->name,
1964 sym->ns->proc_name->name) == 0)
1968 && strcmp (gsym_ns->proc_name->name,
1969 sym->ns->parent->proc_name->name) == 0)
1978 resolve_global_procedure (gfc_symbol *sym, locus *where,
1979 gfc_actual_arglist **actual, int sub)
1983 enum gfc_symbol_type type;
1985 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1987 gsym = gfc_get_gsymbol (sym->name);
1989 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1990 gfc_global_used (gsym, where);
1992 if (gfc_option.flag_whole_file
1993 && (sym->attr.if_source == IFSRC_UNKNOWN
1994 || sym->attr.if_source == IFSRC_IFBODY)
1995 && gsym->type != GSYM_UNKNOWN
1997 && gsym->ns->resolved != -1
1998 && gsym->ns->proc_name
1999 && not_in_recursive (sym, gsym->ns)
2000 && not_entry_self_reference (sym, gsym->ns))
2002 gfc_symbol *def_sym;
2004 /* Resolve the gsymbol namespace if needed. */
2005 if (!gsym->ns->resolved)
2007 gfc_dt_list *old_dt_list;
2009 /* Stash away derived types so that the backend_decls do not
2011 old_dt_list = gfc_derived_types;
2012 gfc_derived_types = NULL;
2014 gfc_resolve (gsym->ns);
2016 /* Store the new derived types with the global namespace. */
2017 if (gfc_derived_types)
2018 gsym->ns->derived_types = gfc_derived_types;
2020 /* Restore the derived types of this namespace. */
2021 gfc_derived_types = old_dt_list;
2024 /* Make sure that translation for the gsymbol occurs before
2025 the procedure currently being resolved. */
2026 ns = gfc_global_ns_list;
2027 for (; ns && ns != gsym->ns; ns = ns->sibling)
2029 if (ns->sibling == gsym->ns)
2031 ns->sibling = gsym->ns->sibling;
2032 gsym->ns->sibling = gfc_global_ns_list;
2033 gfc_global_ns_list = gsym->ns;
2038 def_sym = gsym->ns->proc_name;
2039 if (def_sym->attr.entry_master)
2041 gfc_entry_list *entry;
2042 for (entry = gsym->ns->entries; entry; entry = entry->next)
2043 if (strcmp (entry->sym->name, sym->name) == 0)
2045 def_sym = entry->sym;
2050 /* Differences in constant character lengths. */
2051 if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2053 long int l1 = 0, l2 = 0;
2054 gfc_charlen *cl1 = sym->ts.u.cl;
2055 gfc_charlen *cl2 = def_sym->ts.u.cl;
2058 && cl1->length != NULL
2059 && cl1->length->expr_type == EXPR_CONSTANT)
2060 l1 = mpz_get_si (cl1->length->value.integer);
2063 && cl2->length != NULL
2064 && cl2->length->expr_type == EXPR_CONSTANT)
2065 l2 = mpz_get_si (cl2->length->value.integer);
2067 if (l1 && l2 && l1 != l2)
2068 gfc_error ("Character length mismatch in return type of "
2069 "function '%s' at %L (%ld/%ld)", sym->name,
2070 &sym->declared_at, l1, l2);
2073 /* Type mismatch of function return type and expected type. */
2074 if (sym->attr.function
2075 && !gfc_compare_types (&sym->ts, &def_sym->ts))
2076 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2077 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2078 gfc_typename (&def_sym->ts));
2080 if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2082 gfc_formal_arglist *arg = def_sym->formal;
2083 for ( ; arg; arg = arg->next)
2086 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2087 else if (arg->sym->attr.allocatable
2088 || arg->sym->attr.asynchronous
2089 || arg->sym->attr.optional
2090 || arg->sym->attr.pointer
2091 || arg->sym->attr.target
2092 || arg->sym->attr.value
2093 || arg->sym->attr.volatile_)
2095 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2096 "has an attribute that requires an explicit "
2097 "interface for this procedure", arg->sym->name,
2098 sym->name, &sym->declared_at);
2101 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2102 else if (arg->sym && arg->sym->as
2103 && arg->sym->as->type == AS_ASSUMED_SHAPE)
2105 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2106 "argument '%s' must have an explicit interface",
2107 sym->name, &sym->declared_at, arg->sym->name);
2110 /* F2008, 12.4.2.2 (2c) */
2111 else if (arg->sym->attr.codimension)
2113 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2114 "'%s' must have an explicit interface",
2115 sym->name, &sym->declared_at, arg->sym->name);
2118 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2119 else if (false) /* TODO: is a parametrized derived type */
2121 gfc_error ("Procedure '%s' at %L with parametrized derived "
2122 "type argument '%s' must have an explicit "
2123 "interface", sym->name, &sym->declared_at,
2127 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2128 else if (arg->sym->ts.type == BT_CLASS)
2130 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2131 "argument '%s' must have an explicit interface",
2132 sym->name, &sym->declared_at, arg->sym->name);
2137 if (def_sym->attr.function)
2139 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2140 if (def_sym->as && def_sym->as->rank
2141 && (!sym->as || sym->as->rank != def_sym->as->rank))
2142 gfc_error ("The reference to function '%s' at %L either needs an "
2143 "explicit INTERFACE or the rank is incorrect", sym->name,
2146 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2147 if ((def_sym->result->attr.pointer
2148 || def_sym->result->attr.allocatable)
2149 && (sym->attr.if_source != IFSRC_IFBODY
2150 || def_sym->result->attr.pointer
2151 != sym->result->attr.pointer
2152 || def_sym->result->attr.allocatable
2153 != sym->result->attr.allocatable))
2154 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2155 "result must have an explicit interface", sym->name,
2158 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2159 if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2160 && def_sym->ts.u.cl->length != NULL)
2162 gfc_charlen *cl = sym->ts.u.cl;
2164 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2165 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2167 gfc_error ("Nonconstant character-length function '%s' at %L "
2168 "must have an explicit interface", sym->name,
2174 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2175 if (def_sym->attr.elemental && !sym->attr.elemental)
2177 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2178 "interface", sym->name, &sym->declared_at);
2181 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2182 if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2184 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2185 "an explicit interface", sym->name, &sym->declared_at);
2188 if (gfc_option.flag_whole_file == 1
2189 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2190 && !(gfc_option.warn_std & GFC_STD_GNU)))
2191 gfc_errors_to_warnings (1);
2193 if (sym->attr.if_source != IFSRC_IFBODY)
2194 gfc_procedure_use (def_sym, actual, where);
2196 gfc_errors_to_warnings (0);
2199 if (gsym->type == GSYM_UNKNOWN)
2202 gsym->where = *where;
2209 /************* Function resolution *************/
2211 /* Resolve a function call known to be generic.
2212 Section 14.1.2.4.1. */
2215 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2219 if (sym->attr.generic)
2221 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2224 expr->value.function.name = s->name;
2225 expr->value.function.esym = s;
2227 if (s->ts.type != BT_UNKNOWN)
2229 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2230 expr->ts = s->result->ts;
2233 expr->rank = s->as->rank;
2234 else if (s->result != NULL && s->result->as != NULL)
2235 expr->rank = s->result->as->rank;
2237 gfc_set_sym_referenced (expr->value.function.esym);
2242 /* TODO: Need to search for elemental references in generic
2246 if (sym->attr.intrinsic)
2247 return gfc_intrinsic_func_interface (expr, 0);
2254 resolve_generic_f (gfc_expr *expr)
2259 sym = expr->symtree->n.sym;
2263 m = resolve_generic_f0 (expr, sym);
2266 else if (m == MATCH_ERROR)
2270 if (sym->ns->parent == NULL)
2272 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2276 if (!generic_sym (sym))
2280 /* Last ditch attempt. See if the reference is to an intrinsic
2281 that possesses a matching interface. 14.1.2.4 */
2282 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
2284 gfc_error ("There is no specific function for the generic '%s' at %L",
2285 expr->symtree->n.sym->name, &expr->where);
2289 m = gfc_intrinsic_func_interface (expr, 0);
2293 gfc_error ("Generic function '%s' at %L is not consistent with a "
2294 "specific intrinsic interface", expr->symtree->n.sym->name,
2301 /* Resolve a function call known to be specific. */
2304 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2308 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2310 if (sym->attr.dummy)
2312 sym->attr.proc = PROC_DUMMY;
2316 sym->attr.proc = PROC_EXTERNAL;
2320 if (sym->attr.proc == PROC_MODULE
2321 || sym->attr.proc == PROC_ST_FUNCTION
2322 || sym->attr.proc == PROC_INTERNAL)
2325 if (sym->attr.intrinsic)
2327 m = gfc_intrinsic_func_interface (expr, 1);
2331 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2332 "with an intrinsic", sym->name, &expr->where);
2340 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2343 expr->ts = sym->result->ts;
2346 expr->value.function.name = sym->name;
2347 expr->value.function.esym = sym;
2348 if (sym->as != NULL)
2349 expr->rank = sym->as->rank;
2356 resolve_specific_f (gfc_expr *expr)
2361 sym = expr->symtree->n.sym;
2365 m = resolve_specific_f0 (sym, expr);
2368 if (m == MATCH_ERROR)
2371 if (sym->ns->parent == NULL)
2374 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2380 gfc_error ("Unable to resolve the specific function '%s' at %L",
2381 expr->symtree->n.sym->name, &expr->where);
2387 /* Resolve a procedure call not known to be generic nor specific. */
2390 resolve_unknown_f (gfc_expr *expr)
2395 sym = expr->symtree->n.sym;
2397 if (sym->attr.dummy)
2399 sym->attr.proc = PROC_DUMMY;
2400 expr->value.function.name = sym->name;
2404 /* See if we have an intrinsic function reference. */
2406 if (gfc_is_intrinsic (sym, 0, expr->where))
2408 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2413 /* The reference is to an external name. */
2415 sym->attr.proc = PROC_EXTERNAL;
2416 expr->value.function.name = sym->name;
2417 expr->value.function.esym = expr->symtree->n.sym;
2419 if (sym->as != NULL)
2420 expr->rank = sym->as->rank;
2422 /* Type of the expression is either the type of the symbol or the
2423 default type of the symbol. */
2426 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2428 if (sym->ts.type != BT_UNKNOWN)
2432 ts = gfc_get_default_type (sym->name, sym->ns);
2434 if (ts->type == BT_UNKNOWN)
2436 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2437 sym->name, &expr->where);
2448 /* Return true, if the symbol is an external procedure. */
2450 is_external_proc (gfc_symbol *sym)
2452 if (!sym->attr.dummy && !sym->attr.contained
2453 && !(sym->attr.intrinsic
2454 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2455 && sym->attr.proc != PROC_ST_FUNCTION
2456 && !sym->attr.proc_pointer
2457 && !sym->attr.use_assoc
2465 /* Figure out if a function reference is pure or not. Also set the name
2466 of the function for a potential error message. Return nonzero if the
2467 function is PURE, zero if not. */
2469 pure_stmt_function (gfc_expr *, gfc_symbol *);
2472 pure_function (gfc_expr *e, const char **name)
2478 if (e->symtree != NULL
2479 && e->symtree->n.sym != NULL
2480 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2481 return pure_stmt_function (e, e->symtree->n.sym);
2483 if (e->value.function.esym)
2485 pure = gfc_pure (e->value.function.esym);
2486 *name = e->value.function.esym->name;
2488 else if (e->value.function.isym)
2490 pure = e->value.function.isym->pure
2491 || e->value.function.isym->elemental;
2492 *name = e->value.function.isym->name;
2496 /* Implicit functions are not pure. */
2498 *name = e->value.function.name;
2506 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2507 int *f ATTRIBUTE_UNUSED)
2511 /* Don't bother recursing into other statement functions
2512 since they will be checked individually for purity. */
2513 if (e->expr_type != EXPR_FUNCTION
2515 || e->symtree->n.sym == sym
2516 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2519 return pure_function (e, &name) ? false : true;
2524 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2526 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2531 is_scalar_expr_ptr (gfc_expr *expr)
2533 gfc_try retval = SUCCESS;
2538 /* See if we have a gfc_ref, which means we have a substring, array
2539 reference, or a component. */
2540 if (expr->ref != NULL)
2543 while (ref->next != NULL)
2549 if (ref->u.ss.length != NULL
2550 && ref->u.ss.length->length != NULL
2552 && ref->u.ss.start->expr_type == EXPR_CONSTANT
2554 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
2556 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
2557 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
2558 if (end - start + 1 != 1)
2565 if (ref->u.ar.type == AR_ELEMENT)
2567 else if (ref->u.ar.type == AR_FULL)
2569 /* The user can give a full array if the array is of size 1. */
2570 if (ref->u.ar.as != NULL
2571 && ref->u.ar.as->rank == 1
2572 && ref->u.ar.as->type == AS_EXPLICIT
2573 && ref->u.ar.as->lower[0] != NULL
2574 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2575 && ref->u.ar.as->upper[0] != NULL
2576 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2578 /* If we have a character string, we need to check if
2579 its length is one. */
2580 if (expr->ts.type == BT_CHARACTER)
2582 if (expr->ts.u.cl == NULL
2583 || expr->ts.u.cl->length == NULL
2584 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2590 /* We have constant lower and upper bounds. If the
2591 difference between is 1, it can be considered a
2593 start = (int) mpz_get_si
2594 (ref->u.ar.as->lower[0]->value.integer);
2595 end = (int) mpz_get_si
2596 (ref->u.ar.as->upper[0]->value.integer);
2597 if (end - start + 1 != 1)
2612 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2614 /* Character string. Make sure it's of length 1. */
2615 if (expr->ts.u.cl == NULL
2616 || expr->ts.u.cl->length == NULL
2617 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2620 else if (expr->rank != 0)
2627 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2628 and, in the case of c_associated, set the binding label based on
2632 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2633 gfc_symbol **new_sym)
2635 char name[GFC_MAX_SYMBOL_LEN + 1];
2636 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2637 int optional_arg = 0;
2638 gfc_try retval = SUCCESS;
2639 gfc_symbol *args_sym;
2640 gfc_typespec *arg_ts;
2641 symbol_attribute arg_attr;
2643 if (args->expr->expr_type == EXPR_CONSTANT
2644 || args->expr->expr_type == EXPR_OP
2645 || args->expr->expr_type == EXPR_NULL)
2647 gfc_error ("Argument to '%s' at %L is not a variable",
2648 sym->name, &(args->expr->where));
2652 args_sym = args->expr->symtree->n.sym;
2654 /* The typespec for the actual arg should be that stored in the expr
2655 and not necessarily that of the expr symbol (args_sym), because
2656 the actual expression could be a part-ref of the expr symbol. */
2657 arg_ts = &(args->expr->ts);
2658 arg_attr = gfc_expr_attr (args->expr);
2660 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2662 /* If the user gave two args then they are providing something for
2663 the optional arg (the second cptr). Therefore, set the name and
2664 binding label to the c_associated for two cptrs. Otherwise,
2665 set c_associated to expect one cptr. */
2669 sprintf (name, "%s_2", sym->name);
2670 sprintf (binding_label, "%s_2", sym->binding_label);
2676 sprintf (name, "%s_1", sym->name);
2677 sprintf (binding_label, "%s_1", sym->binding_label);
2681 /* Get a new symbol for the version of c_associated that
2683 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2685 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2686 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2688 sprintf (name, "%s", sym->name);
2689 sprintf (binding_label, "%s", sym->binding_label);
2691 /* Error check the call. */
2692 if (args->next != NULL)
2694 gfc_error_now ("More actual than formal arguments in '%s' "
2695 "call at %L", name, &(args->expr->where));
2698 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2700 /* Make sure we have either the target or pointer attribute. */
2701 if (!arg_attr.target && !arg_attr.pointer)
2703 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2704 "a TARGET or an associated pointer",
2706 sym->name, &(args->expr->where));
2710 /* See if we have interoperable type and type param. */
2711 if (verify_c_interop (arg_ts) == SUCCESS
2712 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2714 if (args_sym->attr.target == 1)
2716 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2717 has the target attribute and is interoperable. */
2718 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2719 allocatable variable that has the TARGET attribute and
2720 is not an array of zero size. */
2721 if (args_sym->attr.allocatable == 1)
2723 if (args_sym->attr.dimension != 0
2724 && (args_sym->as && args_sym->as->rank == 0))
2726 gfc_error_now ("Allocatable variable '%s' used as a "
2727 "parameter to '%s' at %L must not be "
2728 "an array of zero size",
2729 args_sym->name, sym->name,
2730 &(args->expr->where));
2736 /* A non-allocatable target variable with C
2737 interoperable type and type parameters must be
2739 if (args_sym && args_sym->attr.dimension)
2741 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2743 gfc_error ("Assumed-shape array '%s' at %L "
2744 "cannot be an argument to the "
2745 "procedure '%s' because "
2746 "it is not C interoperable",
2748 &(args->expr->where), sym->name);
2751 else if (args_sym->as->type == AS_DEFERRED)
2753 gfc_error ("Deferred-shape array '%s' at %L "
2754 "cannot be an argument to the "
2755 "procedure '%s' because "
2756 "it is not C interoperable",
2758 &(args->expr->where), sym->name);
2763 /* Make sure it's not a character string. Arrays of
2764 any type should be ok if the variable is of a C
2765 interoperable type. */
2766 if (arg_ts->type == BT_CHARACTER)
2767 if (arg_ts->u.cl != NULL
2768 && (arg_ts->u.cl->length == NULL
2769 || arg_ts->u.cl->length->expr_type
2772 (arg_ts->u.cl->length->value.integer, 1)
2774 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2776 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2777 "at %L must have a length of 1",
2778 args_sym->name, sym->name,
2779 &(args->expr->where));
2784 else if (arg_attr.pointer
2785 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2787 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2789 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2790 "associated scalar POINTER", args_sym->name,
2791 sym->name, &(args->expr->where));
2797 /* The parameter is not required to be C interoperable. If it
2798 is not C interoperable, it must be a nonpolymorphic scalar
2799 with no length type parameters. It still must have either
2800 the pointer or target attribute, and it can be
2801 allocatable (but must be allocated when c_loc is called). */
2802 if (args->expr->rank != 0
2803 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2805 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2806 "scalar", args_sym->name, sym->name,
2807 &(args->expr->where));
2810 else if (arg_ts->type == BT_CHARACTER
2811 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2813 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2814 "%L must have a length of 1",
2815 args_sym->name, sym->name,
2816 &(args->expr->where));
2819 else if (arg_ts->type == BT_CLASS)
2821 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2822 "polymorphic", args_sym->name, sym->name,
2823 &(args->expr->where));
2828 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2830 if (args_sym->attr.flavor != FL_PROCEDURE)
2832 /* TODO: Update this error message to allow for procedure
2833 pointers once they are implemented. */
2834 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2836 args_sym->name, sym->name,
2837 &(args->expr->where));
2840 else if (args_sym->attr.is_bind_c != 1)
2842 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2844 args_sym->name, sym->name,
2845 &(args->expr->where));
2850 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2855 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2856 "iso_c_binding function: '%s'!\n", sym->name);
2863 /* Resolve a function call, which means resolving the arguments, then figuring
2864 out which entity the name refers to. */
2867 resolve_function (gfc_expr *expr)
2869 gfc_actual_arglist *arg;
2874 procedure_type p = PROC_INTRINSIC;
2875 bool no_formal_args;
2879 sym = expr->symtree->n.sym;
2881 /* If this is a procedure pointer component, it has already been resolved. */
2882 if (gfc_is_proc_ptr_comp (expr, NULL))
2885 if (sym && sym->attr.intrinsic
2886 && resolve_intrinsic (sym, &expr->where) == FAILURE)
2889 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2891 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2895 /* If this ia a deferred TBP with an abstract interface (which may
2896 of course be referenced), expr->value.function.esym will be set. */
2897 if (sym && sym->attr.abstract && !expr->value.function.esym)
2899 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2900 sym->name, &expr->where);
2904 /* Switch off assumed size checking and do this again for certain kinds
2905 of procedure, once the procedure itself is resolved. */
2906 need_full_assumed_size++;
2908 if (expr->symtree && expr->symtree->n.sym)
2909 p = expr->symtree->n.sym->attr.proc;
2911 if (expr->value.function.isym && expr->value.function.isym->inquiry)
2912 inquiry_argument = true;
2913 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2915 if (resolve_actual_arglist (expr->value.function.actual,
2916 p, no_formal_args) == FAILURE)
2918 inquiry_argument = false;
2922 inquiry_argument = false;
2924 /* Need to setup the call to the correct c_associated, depending on
2925 the number of cptrs to user gives to compare. */
2926 if (sym && sym->attr.is_iso_c == 1)
2928 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2932 /* Get the symtree for the new symbol (resolved func).
2933 the old one will be freed later, when it's no longer used. */
2934 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2937 /* Resume assumed_size checking. */
2938 need_full_assumed_size--;
2940 /* If the procedure is external, check for usage. */
2941 if (sym && is_external_proc (sym))
2942 resolve_global_procedure (sym, &expr->where,
2943 &expr->value.function.actual, 0);
2945 if (sym && sym->ts.type == BT_CHARACTER
2947 && sym->ts.u.cl->length == NULL
2949 && expr->value.function.esym == NULL
2950 && !sym->attr.contained)
2952 /* Internal procedures are taken care of in resolve_contained_fntype. */
2953 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2954 "be used at %L since it is not a dummy argument",
2955 sym->name, &expr->where);
2959 /* See if function is already resolved. */
2961 if (expr->value.function.name != NULL)
2963 if (expr->ts.type == BT_UNKNOWN)
2969 /* Apply the rules of section 14.1.2. */
2971 switch (procedure_kind (sym))
2974 t = resolve_generic_f (expr);
2977 case PTYPE_SPECIFIC:
2978 t = resolve_specific_f (expr);
2982 t = resolve_unknown_f (expr);
2986 gfc_internal_error ("resolve_function(): bad function type");
2990 /* If the expression is still a function (it might have simplified),
2991 then we check to see if we are calling an elemental function. */
2993 if (expr->expr_type != EXPR_FUNCTION)
2996 temp = need_full_assumed_size;
2997 need_full_assumed_size = 0;
2999 if (resolve_elemental_actual (expr, NULL) == FAILURE)
3002 if (omp_workshare_flag
3003 && expr->value.function.esym
3004 && ! gfc_elemental (expr->value.function.esym))
3006 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3007 "in WORKSHARE construct", expr->value.function.esym->name,
3012 #define GENERIC_ID expr->value.function.isym->id
3013 else if (expr->value.function.actual != NULL
3014 && expr->value.function.isym != NULL
3015 && GENERIC_ID != GFC_ISYM_LBOUND
3016 && GENERIC_ID != GFC_ISYM_LEN
3017 && GENERIC_ID != GFC_ISYM_LOC
3018 && GENERIC_ID != GFC_ISYM_PRESENT)
3020 /* Array intrinsics must also have the last upper bound of an
3021 assumed size array argument. UBOUND and SIZE have to be
3022 excluded from the check if the second argument is anything
3025 for (arg = expr->value.function.actual; arg; arg = arg->next)
3027 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3028 && arg->next != NULL && arg->next->expr)
3030 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3033 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3036 if ((int)mpz_get_si (arg->next->expr->value.integer)
3041 if (arg->expr != NULL
3042 && arg->expr->rank > 0
3043 && resolve_assumed_size_actual (arg->expr))
3049 need_full_assumed_size = temp;
3052 if (!pure_function (expr, &name) && name)
3056 gfc_error ("reference to non-PURE function '%s' at %L inside a "
3057 "FORALL %s", name, &expr->where,
3058 forall_flag == 2 ? "mask" : "block");
3061 else if (gfc_pure (NULL))
3063 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3064 "procedure within a PURE procedure", name, &expr->where);
3069 /* Functions without the RECURSIVE attribution are not allowed to
3070 * call themselves. */
3071 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3074 esym = expr->value.function.esym;
3076 if (is_illegal_recursion (esym, gfc_current_ns))
3078 if (esym->attr.entry && esym->ns->entries)
3079 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3080 " function '%s' is not RECURSIVE",
3081 esym->name, &expr->where, esym->ns->entries->sym->name);
3083 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3084 " is not RECURSIVE", esym->name, &expr->where);
3090 /* Character lengths of use associated functions may contains references to
3091 symbols not referenced from the current program unit otherwise. Make sure
3092 those symbols are marked as referenced. */
3094 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3095 && expr->value.function.esym->attr.use_assoc)
3097 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3100 /* Make sure that the expression has a typespec that works. */
3101 if (expr->ts.type == BT_UNKNOWN)
3103 if (expr->symtree->n.sym->result
3104 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3105 && !expr->symtree->n.sym->result->attr.proc_pointer)
3106 expr->ts = expr->symtree->n.sym->result->ts;
3113 /************* Subroutine resolution *************/
3116 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3122 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3123 sym->name, &c->loc);
3124 else if (gfc_pure (NULL))
3125 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3131 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3135 if (sym->attr.generic)
3137 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3140 c->resolved_sym = s;
3141 pure_subroutine (c, s);
3145 /* TODO: Need to search for elemental references in generic interface. */
3148 if (sym->attr.intrinsic)
3149 return gfc_intrinsic_sub_interface (c, 0);
3156 resolve_generic_s (gfc_code *c)
3161 sym = c->symtree->n.sym;
3165 m = resolve_generic_s0 (c, sym);
3168 else if (m == MATCH_ERROR)
3172 if (sym->ns->parent == NULL)
3174 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3178 if (!generic_sym (sym))
3182 /* Last ditch attempt. See if the reference is to an intrinsic
3183 that possesses a matching interface. 14.1.2.4 */
3184 sym = c->symtree->n.sym;
3186 if (!gfc_is_intrinsic (sym, 1, c->loc))
3188 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3189 sym->name, &c->loc);
3193 m = gfc_intrinsic_sub_interface (c, 0);
3197 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3198 "intrinsic subroutine interface", sym->name, &c->loc);
3204 /* Set the name and binding label of the subroutine symbol in the call
3205 expression represented by 'c' to include the type and kind of the
3206 second parameter. This function is for resolving the appropriate
3207 version of c_f_pointer() and c_f_procpointer(). For example, a
3208 call to c_f_pointer() for a default integer pointer could have a
3209 name of c_f_pointer_i4. If no second arg exists, which is an error
3210 for these two functions, it defaults to the generic symbol's name
3211 and binding label. */
3214 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3215 char *name, char *binding_label)
3217 gfc_expr *arg = NULL;
3221 /* The second arg of c_f_pointer and c_f_procpointer determines
3222 the type and kind for the procedure name. */
3223 arg = c->ext.actual->next->expr;
3227 /* Set up the name to have the given symbol's name,
3228 plus the type and kind. */
3229 /* a derived type is marked with the type letter 'u' */
3230 if (arg->ts.type == BT_DERIVED)
3233 kind = 0; /* set the kind as 0 for now */
3237 type = gfc_type_letter (arg->ts.type);
3238 kind = arg->ts.kind;
3241 if (arg->ts.type == BT_CHARACTER)
3242 /* Kind info for character strings not needed. */
3245 sprintf (name, "%s_%c%d", sym->name, type, kind);
3246 /* Set up the binding label as the given symbol's label plus
3247 the type and kind. */
3248 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
3252 /* If the second arg is missing, set the name and label as
3253 was, cause it should at least be found, and the missing
3254 arg error will be caught by compare_parameters(). */
3255 sprintf (name, "%s", sym->name);
3256 sprintf (binding_label, "%s", sym->binding_label);
3263 /* Resolve a generic version of the iso_c_binding procedure given
3264 (sym) to the specific one based on the type and kind of the
3265 argument(s). Currently, this function resolves c_f_pointer() and
3266 c_f_procpointer based on the type and kind of the second argument
3267 (FPTR). Other iso_c_binding procedures aren't specially handled.
3268 Upon successfully exiting, c->resolved_sym will hold the resolved
3269 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3273 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3275 gfc_symbol *new_sym;
3276 /* this is fine, since we know the names won't use the max */
3277 char name[GFC_MAX_SYMBOL_LEN + 1];
3278 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
3279 /* default to success; will override if find error */
3280 match m = MATCH_YES;
3282 /* Make sure the actual arguments are in the necessary order (based on the
3283 formal args) before resolving. */
3284 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3286 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3287 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3289 set_name_and_label (c, sym, name, binding_label);
3291 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3293 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3295 /* Make sure we got a third arg if the second arg has non-zero
3296 rank. We must also check that the type and rank are
3297 correct since we short-circuit this check in
3298 gfc_procedure_use() (called above to sort actual args). */
3299 if (c->ext.actual->next->expr->rank != 0)
3301 if(c->ext.actual->next->next == NULL
3302 || c->ext.actual->next->next->expr == NULL)
3305 gfc_error ("Missing SHAPE parameter for call to %s "
3306 "at %L", sym->name, &(c->loc));
3308 else if (c->ext.actual->next->next->expr->ts.type
3310 || c->ext.actual->next->next->expr->rank != 1)
3313 gfc_error ("SHAPE parameter for call to %s at %L must "
3314 "be a rank 1 INTEGER array", sym->name,
3321 if (m != MATCH_ERROR)
3323 /* the 1 means to add the optional arg to formal list */
3324 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3326 /* for error reporting, say it's declared where the original was */
3327 new_sym->declared_at = sym->declared_at;
3332 /* no differences for c_loc or c_funloc */
3336 /* set the resolved symbol */
3337 if (m != MATCH_ERROR)
3338 c->resolved_sym = new_sym;
3340 c->resolved_sym = sym;
3346 /* Resolve a subroutine call known to be specific. */
3349 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3353 if(sym->attr.is_iso_c)
3355 m = gfc_iso_c_sub_interface (c,sym);
3359 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3361 if (sym->attr.dummy)
3363 sym->attr.proc = PROC_DUMMY;
3367 sym->attr.proc = PROC_EXTERNAL;
3371 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3374 if (sym->attr.intrinsic)
3376 m = gfc_intrinsic_sub_interface (c, 1);
3380 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3381 "with an intrinsic", sym->name, &c->loc);
3389 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3391 c->resolved_sym = sym;
3392 pure_subroutine (c, sym);
3399 resolve_specific_s (gfc_code *c)
3404 sym = c->symtree->n.sym;
3408 m = resolve_specific_s0 (c, sym);
3411 if (m == MATCH_ERROR)
3414 if (sym->ns->parent == NULL)
3417 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3423 sym = c->symtree->n.sym;
3424 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3425 sym->name, &c->loc);
3431 /* Resolve a subroutine call not known to be generic nor specific. */
3434 resolve_unknown_s (gfc_code *c)
3438 sym = c->symtree->n.sym;
3440 if (sym->attr.dummy)
3442 sym->attr.proc = PROC_DUMMY;
3446 /* See if we have an intrinsic function reference. */
3448 if (gfc_is_intrinsic (sym, 1, c->loc))
3450 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3455 /* The reference is to an external name. */
3458 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3460 c->resolved_sym = sym;
3462 pure_subroutine (c, sym);
3468 /* Resolve a subroutine call. Although it was tempting to use the same code
3469 for functions, subroutines and functions are stored differently and this
3470 makes things awkward. */
3473 resolve_call (gfc_code *c)
3476 procedure_type ptype = PROC_INTRINSIC;
3477 gfc_symbol *csym, *sym;
3478 bool no_formal_args;
3480 csym = c->symtree ? c->symtree->n.sym : NULL;
3482 if (csym && csym->ts.type != BT_UNKNOWN)
3484 gfc_error ("'%s' at %L has a type, which is not consistent with "
3485 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3489 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3492 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3493 sym = st ? st->n.sym : NULL;
3494 if (sym && csym != sym
3495 && sym->ns == gfc_current_ns
3496 && sym->attr.flavor == FL_PROCEDURE
3497 && sym->attr.contained)
3500 if (csym->attr.generic)
3501 c->symtree->n.sym = sym;
3504 csym = c->symtree->n.sym;
3508 /* If this ia a deferred TBP with an abstract interface
3509 (which may of course be referenced), c->expr1 will be set. */
3510 if (csym && csym->attr.abstract && !c->expr1)
3512 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3513 csym->name, &c->loc);
3517 /* Subroutines without the RECURSIVE attribution are not allowed to
3518 * call themselves. */
3519 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3521 if (csym->attr.entry && csym->ns->entries)
3522 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3523 " subroutine '%s' is not RECURSIVE",
3524 csym->name, &c->loc, csym->ns->entries->sym->name);
3526 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3527 " is not RECURSIVE", csym->name, &c->loc);
3532 /* Switch off assumed size checking and do this again for certain kinds
3533 of procedure, once the procedure itself is resolved. */
3534 need_full_assumed_size++;
3537 ptype = csym->attr.proc;
3539 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3540 if (resolve_actual_arglist (c->ext.actual, ptype,
3541 no_formal_args) == FAILURE)
3544 /* Resume assumed_size checking. */
3545 need_full_assumed_size--;
3547 /* If external, check for usage. */
3548 if (csym && is_external_proc (csym))
3549 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3552 if (c->resolved_sym == NULL)
3554 c->resolved_isym = NULL;
3555 switch (procedure_kind (csym))
3558 t = resolve_generic_s (c);
3561 case PTYPE_SPECIFIC:
3562 t = resolve_specific_s (c);
3566 t = resolve_unknown_s (c);
3570 gfc_internal_error ("resolve_subroutine(): bad function type");
3574 /* Some checks of elemental subroutine actual arguments. */
3575 if (resolve_elemental_actual (NULL, c) == FAILURE)
3582 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3583 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3584 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3585 if their shapes do not match. If either op1->shape or op2->shape is
3586 NULL, return SUCCESS. */
3589 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3596 if (op1->shape != NULL && op2->shape != NULL)
3598 for (i = 0; i < op1->rank; i++)
3600 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3602 gfc_error ("Shapes for operands at %L and %L are not conformable",
3603 &op1->where, &op2->where);
3614 /* Resolve an operator expression node. This can involve replacing the
3615 operation with a user defined function call. */
3618 resolve_operator (gfc_expr *e)
3620 gfc_expr *op1, *op2;
3622 bool dual_locus_error;
3625 /* Resolve all subnodes-- give them types. */
3627 switch (e->value.op.op)
3630 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3633 /* Fall through... */
3636 case INTRINSIC_UPLUS:
3637 case INTRINSIC_UMINUS:
3638 case INTRINSIC_PARENTHESES:
3639 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3644 /* Typecheck the new node. */
3646 op1 = e->value.op.op1;
3647 op2 = e->value.op.op2;
3648 dual_locus_error = false;
3650 if ((op1 && op1->expr_type == EXPR_NULL)
3651 || (op2 && op2->expr_type == EXPR_NULL))
3653 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3657 switch (e->value.op.op)
3659 case INTRINSIC_UPLUS:
3660 case INTRINSIC_UMINUS:
3661 if (op1->ts.type == BT_INTEGER
3662 || op1->ts.type == BT_REAL
3663 || op1->ts.type == BT_COMPLEX)
3669 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3670 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3673 case INTRINSIC_PLUS:
3674 case INTRINSIC_MINUS:
3675 case INTRINSIC_TIMES:
3676 case INTRINSIC_DIVIDE:
3677 case INTRINSIC_POWER:
3678 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3680 gfc_type_convert_binary (e, 1);
3685 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3686 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3687 gfc_typename (&op2->ts));
3690 case INTRINSIC_CONCAT:
3691 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3692 && op1->ts.kind == op2->ts.kind)
3694 e->ts.type = BT_CHARACTER;
3695 e->ts.kind = op1->ts.kind;
3700 _("Operands of string concatenation operator at %%L are %s/%s"),
3701 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3707 case INTRINSIC_NEQV:
3708 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3710 e->ts.type = BT_LOGICAL;
3711 e->ts.kind = gfc_kind_max (op1, op2);
3712 if (op1->ts.kind < e->ts.kind)
3713 gfc_convert_type (op1, &e->ts, 2);
3714 else if (op2->ts.kind < e->ts.kind)
3715 gfc_convert_type (op2, &e->ts, 2);
3719 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3720 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3721 gfc_typename (&op2->ts));
3726 if (op1->ts.type == BT_LOGICAL)
3728 e->ts.type = BT_LOGICAL;
3729 e->ts.kind = op1->ts.kind;
3733 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3734 gfc_typename (&op1->ts));
3738 case INTRINSIC_GT_OS:
3740 case INTRINSIC_GE_OS:
3742 case INTRINSIC_LT_OS:
3744 case INTRINSIC_LE_OS:
3745 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3747 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3751 /* Fall through... */
3754 case INTRINSIC_EQ_OS:
3756 case INTRINSIC_NE_OS:
3757 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3758 && op1->ts.kind == op2->ts.kind)
3760 e->ts.type = BT_LOGICAL;
3761 e->ts.kind = gfc_default_logical_kind;
3765 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3767 gfc_type_convert_binary (e, 1);
3769 e->ts.type = BT_LOGICAL;
3770 e->ts.kind = gfc_default_logical_kind;
3774 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3776 _("Logicals at %%L must be compared with %s instead of %s"),
3777 (e->value.op.op == INTRINSIC_EQ
3778 || e->value.op.op == INTRINSIC_EQ_OS)
3779 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3782 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3783 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3784 gfc_typename (&op2->ts));
3788 case INTRINSIC_USER:
3789 if (e->value.op.uop->op == NULL)
3790 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3791 else if (op2 == NULL)
3792 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3793 e->value.op.uop->name, gfc_typename (&op1->ts));
3795 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3796 e->value.op.uop->name, gfc_typename (&op1->ts),
3797 gfc_typename (&op2->ts));
3801 case INTRINSIC_PARENTHESES:
3803 if (e->ts.type == BT_CHARACTER)
3804 e->ts.u.cl = op1->ts.u.cl;
3808 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3811 /* Deal with arrayness of an operand through an operator. */
3815 switch (e->value.op.op)
3817 case INTRINSIC_PLUS:
3818 case INTRINSIC_MINUS:
3819 case INTRINSIC_TIMES:
3820 case INTRINSIC_DIVIDE:
3821 case INTRINSIC_POWER:
3822 case INTRINSIC_CONCAT:
3826 case INTRINSIC_NEQV:
3828 case INTRINSIC_EQ_OS:
3830 case INTRINSIC_NE_OS:
3832 case INTRINSIC_GT_OS:
3834 case INTRINSIC_GE_OS:
3836 case INTRINSIC_LT_OS:
3838 case INTRINSIC_LE_OS:
3840 if (op1->rank == 0 && op2->rank == 0)
3843 if (op1->rank == 0 && op2->rank != 0)
3845 e->rank = op2->rank;
3847 if (e->shape == NULL)
3848 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3851 if (op1->rank != 0 && op2->rank == 0)
3853 e->rank = op1->rank;
3855 if (e->shape == NULL)
3856 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3859 if (op1->rank != 0 && op2->rank != 0)
3861 if (op1->rank == op2->rank)
3863 e->rank = op1->rank;
3864 if (e->shape == NULL)
3866 t = compare_shapes (op1, op2);
3870 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3875 /* Allow higher level expressions to work. */
3878 /* Try user-defined operators, and otherwise throw an error. */
3879 dual_locus_error = true;
3881 _("Inconsistent ranks for operator at %%L and %%L"));
3888 case INTRINSIC_PARENTHESES:
3890 case INTRINSIC_UPLUS:
3891 case INTRINSIC_UMINUS:
3892 /* Simply copy arrayness attribute */
3893 e->rank = op1->rank;
3895 if (e->shape == NULL)
3896 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3904 /* Attempt to simplify the expression. */
3907 t = gfc_simplify_expr (e, 0);
3908 /* Some calls do not succeed in simplification and return FAILURE
3909 even though there is no error; e.g. variable references to
3910 PARAMETER arrays. */
3911 if (!gfc_is_constant_expr (e))
3920 if (gfc_extend_expr (e, &real_error) == SUCCESS)
3927 if (dual_locus_error)
3928 gfc_error (msg, &op1->where, &op2->where);
3930 gfc_error (msg, &e->where);
3936 /************** Array resolution subroutines **************/
3939 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3942 /* Compare two integer expressions. */
3945 compare_bound (gfc_expr *a, gfc_expr *b)
3949 if (a == NULL || a->expr_type != EXPR_CONSTANT
3950 || b == NULL || b->expr_type != EXPR_CONSTANT)
3953 /* If either of the types isn't INTEGER, we must have
3954 raised an error earlier. */
3956 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3959 i = mpz_cmp (a->value.integer, b->value.integer);
3969 /* Compare an integer expression with an integer. */
3972 compare_bound_int (gfc_expr *a, int b)
3976 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3979 if (a->ts.type != BT_INTEGER)
3980 gfc_internal_error ("compare_bound_int(): Bad expression");
3982 i = mpz_cmp_si (a->value.integer, b);
3992 /* Compare an integer expression with a mpz_t. */
3995 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3999 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4002 if (a->ts.type != BT_INTEGER)
4003 gfc_internal_error ("compare_bound_int(): Bad expression");
4005 i = mpz_cmp (a->value.integer, b);
4015 /* Compute the last value of a sequence given by a triplet.
4016 Return 0 if it wasn't able to compute the last value, or if the
4017 sequence if empty, and 1 otherwise. */
4020 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4021 gfc_expr *stride, mpz_t last)
4025 if (start == NULL || start->expr_type != EXPR_CONSTANT
4026 || end == NULL || end->expr_type != EXPR_CONSTANT
4027 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4030 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4031 || (stride != NULL && stride->ts.type != BT_INTEGER))
4034 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
4036 if (compare_bound (start, end) == CMP_GT)
4038 mpz_set (last, end->value.integer);
4042 if (compare_bound_int (stride, 0) == CMP_GT)
4044 /* Stride is positive */
4045 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4050 /* Stride is negative */
4051 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4056 mpz_sub (rem, end->value.integer, start->value.integer);
4057 mpz_tdiv_r (rem, rem, stride->value.integer);
4058 mpz_sub (last, end->value.integer, rem);
4065 /* Compare a single dimension of an array reference to the array
4069 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4073 if (ar->dimen_type[i] == DIMEN_STAR)
4075 gcc_assert (ar->stride[i] == NULL);
4076 /* This implies [*] as [*:] and [*:3] are not possible. */
4077 if (ar->start[i] == NULL)
4079 gcc_assert (ar->end[i] == NULL);
4084 /* Given start, end and stride values, calculate the minimum and
4085 maximum referenced indexes. */
4087 switch (ar->dimen_type[i])
4094 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4097 gfc_warning ("Array reference at %L is out of bounds "
4098 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4099 mpz_get_si (ar->start[i]->value.integer),
4100 mpz_get_si (as->lower[i]->value.integer), i+1);
4102 gfc_warning ("Array reference at %L is out of bounds "
4103 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4104 mpz_get_si (ar->start[i]->value.integer),
4105 mpz_get_si (as->lower[i]->value.integer),
4109 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4112 gfc_warning ("Array reference at %L is out of bounds "
4113 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4114 mpz_get_si (ar->start[i]->value.integer),
4115 mpz_get_si (as->upper[i]->value.integer), i+1);
4117 gfc_warning ("Array reference at %L is out of bounds "
4118 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4119 mpz_get_si (ar->start[i]->value.integer),
4120 mpz_get_si (as->upper[i]->value.integer),
4129 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4130 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4132 comparison comp_start_end = compare_bound (AR_START, AR_END);
4134 /* Check for zero stride, which is not allowed. */
4135 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4137 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4141 /* if start == len || (stride > 0 && start < len)
4142 || (stride < 0 && start > len),
4143 then the array section contains at least one element. In this
4144 case, there is an out-of-bounds access if
4145 (start < lower || start > upper). */
4146 if (compare_bound (AR_START, AR_END) == CMP_EQ
4147 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4148 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4149 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4150 && comp_start_end == CMP_GT))
4152 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4154 gfc_warning ("Lower array reference at %L is out of bounds "
4155 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4156 mpz_get_si (AR_START->value.integer),
4157 mpz_get_si (as->lower[i]->value.integer), i+1);
4160 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4162 gfc_warning ("Lower array reference at %L is out of bounds "
4163 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4164 mpz_get_si (AR_START->value.integer),
4165 mpz_get_si (as->upper[i]->value.integer), i+1);
4170 /* If we can compute the highest index of the array section,
4171 then it also has to be between lower and upper. */
4172 mpz_init (last_value);
4173 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4176 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4178 gfc_warning ("Upper array reference at %L is out of bounds "
4179 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4180 mpz_get_si (last_value),
4181 mpz_get_si (as->lower[i]->value.integer), i+1);
4182 mpz_clear (last_value);
4185 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4187 gfc_warning ("Upper array reference at %L is out of bounds "
4188 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4189 mpz_get_si (last_value),
4190 mpz_get_si (as->upper[i]->value.integer), i+1);
4191 mpz_clear (last_value);
4195 mpz_clear (last_value);
4203 gfc_internal_error ("check_dimension(): Bad array reference");
4210 /* Compare an array reference with an array specification. */
4213 compare_spec_to_ref (gfc_array_ref *ar)
4220 /* TODO: Full array sections are only allowed as actual parameters. */
4221 if (as->type == AS_ASSUMED_SIZE
4222 && (/*ar->type == AR_FULL
4223 ||*/ (ar->type == AR_SECTION
4224 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4226 gfc_error ("Rightmost upper bound of assumed size array section "
4227 "not specified at %L", &ar->where);
4231 if (ar->type == AR_FULL)
4234 if (as->rank != ar->dimen)
4236 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4237 &ar->where, ar->dimen, as->rank);
4241 /* ar->codimen == 0 is a local array. */
4242 if (as->corank != ar->codimen && ar->codimen != 0)
4244 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4245 &ar->where, ar->codimen, as->corank);
4249 for (i = 0; i < as->rank; i++)
4250 if (check_dimension (i, ar, as) == FAILURE)
4253 /* Local access has no coarray spec. */
4254 if (ar->codimen != 0)
4255 for (i = as->rank; i < as->rank + as->corank; i++)
4257 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
4259 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4260 i + 1 - as->rank, &ar->where);
4263 if (check_dimension (i, ar, as) == FAILURE)
4271 /* Resolve one part of an array index. */
4274 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4275 int force_index_integer_kind)
4282 if (gfc_resolve_expr (index) == FAILURE)
4285 if (check_scalar && index->rank != 0)
4287 gfc_error ("Array index at %L must be scalar", &index->where);
4291 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4293 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4294 &index->where, gfc_basic_typename (index->ts.type));
4298 if (index->ts.type == BT_REAL)
4299 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
4300 &index->where) == FAILURE)
4303 if ((index->ts.kind != gfc_index_integer_kind
4304 && force_index_integer_kind)
4305 || index->ts.type != BT_INTEGER)
4308 ts.type = BT_INTEGER;
4309 ts.kind = gfc_index_integer_kind;
4311 gfc_convert_type_warn (index, &ts, 2, 0);
4317 /* Resolve one part of an array index. */
4320 gfc_resolve_index (gfc_expr *index, int check_scalar)
4322 return gfc_resolve_index_1 (index, check_scalar, 1);
4325 /* Resolve a dim argument to an intrinsic function. */
4328 gfc_resolve_dim_arg (gfc_expr *dim)
4333 if (gfc_resolve_expr (dim) == FAILURE)
4338 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4343 if (dim->ts.type != BT_INTEGER)
4345 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4349 if (dim->ts.kind != gfc_index_integer_kind)
4354 ts.type = BT_INTEGER;
4355 ts.kind = gfc_index_integer_kind;
4357 gfc_convert_type_warn (dim, &ts, 2, 0);
4363 /* Given an expression that contains array references, update those array
4364 references to point to the right array specifications. While this is
4365 filled in during matching, this information is difficult to save and load
4366 in a module, so we take care of it here.
4368 The idea here is that the original array reference comes from the
4369 base symbol. We traverse the list of reference structures, setting
4370 the stored reference to references. Component references can
4371 provide an additional array specification. */
4374 find_array_spec (gfc_expr *e)
4378 gfc_symbol *derived;
4381 if (e->symtree->n.sym->ts.type == BT_CLASS)
4382 as = CLASS_DATA (e->symtree->n.sym)->as;
4384 as = e->symtree->n.sym->as;
4387 for (ref = e->ref; ref; ref = ref->next)
4392 gfc_internal_error ("find_array_spec(): Missing spec");
4399 if (derived == NULL)
4400 derived = e->symtree->n.sym->ts.u.derived;
4402 if (derived->attr.is_class)
4403 derived = derived->components->ts.u.derived;
4405 c = derived->components;
4407 for (; c; c = c->next)
4408 if (c == ref->u.c.component)
4410 /* Track the sequence of component references. */
4411 if (c->ts.type == BT_DERIVED)
4412 derived = c->ts.u.derived;
4417 gfc_internal_error ("find_array_spec(): Component not found");
4419 if (c->attr.dimension)
4422 gfc_internal_error ("find_array_spec(): unused as(1)");
4433 gfc_internal_error ("find_array_spec(): unused as(2)");
4437 /* Resolve an array reference. */
4440 resolve_array_ref (gfc_array_ref *ar)
4442 int i, check_scalar;
4445 for (i = 0; i < ar->dimen + ar->codimen; i++)
4447 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4449 /* Do not force gfc_index_integer_kind for the start. We can
4450 do fine with any integer kind. This avoids temporary arrays
4451 created for indexing with a vector. */
4452 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4454 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4456 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4461 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4465 ar->dimen_type[i] = DIMEN_ELEMENT;
4469 ar->dimen_type[i] = DIMEN_VECTOR;
4470 if (e->expr_type == EXPR_VARIABLE
4471 && e->symtree->n.sym->ts.type == BT_DERIVED)
4472 ar->start[i] = gfc_get_parentheses (e);
4476 gfc_error ("Array index at %L is an array of rank %d",
4477 &ar->c_where[i], e->rank);
4481 /* Fill in the upper bound, which may be lower than the
4482 specified one for something like a(2:10:5), which is
4483 identical to a(2:7:5). Only relevant for strides not equal
4485 if (ar->dimen_type[i] == DIMEN_RANGE
4486 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4487 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0)
4491 if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4493 if (ar->end[i] == NULL)
4496 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4498 mpz_set (ar->end[i]->value.integer, end);
4500 else if (ar->end[i]->ts.type == BT_INTEGER
4501 && ar->end[i]->expr_type == EXPR_CONSTANT)
4503 mpz_set (ar->end[i]->value.integer, end);
4514 if (ar->type == AR_FULL && ar->as->rank == 0)
4515 ar->type = AR_ELEMENT;
4517 /* If the reference type is unknown, figure out what kind it is. */
4519 if (ar->type == AR_UNKNOWN)
4521 ar->type = AR_ELEMENT;
4522 for (i = 0; i < ar->dimen; i++)
4523 if (ar->dimen_type[i] == DIMEN_RANGE
4524 || ar->dimen_type[i] == DIMEN_VECTOR)
4526 ar->type = AR_SECTION;
4531 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4539 resolve_substring (gfc_ref *ref)
4541 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4543 if (ref->u.ss.start != NULL)
4545 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4548 if (ref->u.ss.start->ts.type != BT_INTEGER)
4550 gfc_error ("Substring start index at %L must be of type INTEGER",
4551 &ref->u.ss.start->where);
4555 if (ref->u.ss.start->rank != 0)
4557 gfc_error ("Substring start index at %L must be scalar",
4558 &ref->u.ss.start->where);
4562 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4563 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4564 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4566 gfc_error ("Substring start index at %L is less than one",
4567 &ref->u.ss.start->where);
4572 if (ref->u.ss.end != NULL)
4574 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4577 if (ref->u.ss.end->ts.type != BT_INTEGER)
4579 gfc_error ("Substring end index at %L must be of type INTEGER",
4580 &ref->u.ss.end->where);
4584 if (ref->u.ss.end->rank != 0)
4586 gfc_error ("Substring end index at %L must be scalar",
4587 &ref->u.ss.end->where);
4591 if (ref->u.ss.length != NULL
4592 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4593 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4594 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4596 gfc_error ("Substring end index at %L exceeds the string length",
4597 &ref->u.ss.start->where);
4601 if (compare_bound_mpz_t (ref->u.ss.end,
4602 gfc_integer_kinds[k].huge) == CMP_GT
4603 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4604 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4606 gfc_error ("Substring end index at %L is too large",
4607 &ref->u.ss.end->where);
4616 /* This function supplies missing substring charlens. */
4619 gfc_resolve_substring_charlen (gfc_expr *e)
4622 gfc_expr *start, *end;
4624 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4625 if (char_ref->type == REF_SUBSTRING)
4631 gcc_assert (char_ref->next == NULL);
4635 if (e->ts.u.cl->length)
4636 gfc_free_expr (e->ts.u.cl->length);
4637 else if (e->expr_type == EXPR_VARIABLE
4638 && e->symtree->n.sym->attr.dummy)
4642 e->ts.type = BT_CHARACTER;
4643 e->ts.kind = gfc_default_character_kind;
4646 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4648 if (char_ref->u.ss.start)
4649 start = gfc_copy_expr (char_ref->u.ss.start);
4651 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4653 if (char_ref->u.ss.end)
4654 end = gfc_copy_expr (char_ref->u.ss.end);
4655 else if (e->expr_type == EXPR_VARIABLE)
4656 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4663 /* Length = (end - start +1). */
4664 e->ts.u.cl->length = gfc_subtract (end, start);
4665 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4666 gfc_get_int_expr (gfc_default_integer_kind,
4669 e->ts.u.cl->length->ts.type = BT_INTEGER;
4670 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4672 /* Make sure that the length is simplified. */
4673 gfc_simplify_expr (e->ts.u.cl->length, 1);
4674 gfc_resolve_expr (e->ts.u.cl->length);
4678 /* Resolve subtype references. */
4681 resolve_ref (gfc_expr *expr)
4683 int current_part_dimension, n_components, seen_part_dimension;
4686 for (ref = expr->ref; ref; ref = ref->next)
4687 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4689 find_array_spec (expr);
4693 for (ref = expr->ref; ref; ref = ref->next)
4697 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4705 resolve_substring (ref);
4709 /* Check constraints on part references. */
4711 current_part_dimension = 0;
4712 seen_part_dimension = 0;
4715 for (ref = expr->ref; ref; ref = ref->next)
4720 switch (ref->u.ar.type)
4723 /* Coarray scalar. */
4724 if (ref->u.ar.as->rank == 0)
4726 current_part_dimension = 0;
4731 current_part_dimension = 1;
4735 current_part_dimension = 0;
4739 gfc_internal_error ("resolve_ref(): Bad array reference");
4745 if (current_part_dimension || seen_part_dimension)
4748 if (ref->u.c.component->attr.pointer
4749 || ref->u.c.component->attr.proc_pointer)
4751 gfc_error ("Component to the right of a part reference "
4752 "with nonzero rank must not have the POINTER "
4753 "attribute at %L", &expr->where);
4756 else if (ref->u.c.component->attr.allocatable)
4758 gfc_error ("Component to the right of a part reference "
4759 "with nonzero rank must not have the ALLOCATABLE "
4760 "attribute at %L", &expr->where);
4772 if (((ref->type == REF_COMPONENT && n_components > 1)
4773 || ref->next == NULL)
4774 && current_part_dimension
4775 && seen_part_dimension)
4777 gfc_error ("Two or more part references with nonzero rank must "
4778 "not be specified at %L", &expr->where);
4782 if (ref->type == REF_COMPONENT)
4784 if (current_part_dimension)
4785 seen_part_dimension = 1;
4787 /* reset to make sure */
4788 current_part_dimension = 0;
4796 /* Given an expression, determine its shape. This is easier than it sounds.
4797 Leaves the shape array NULL if it is not possible to determine the shape. */
4800 expression_shape (gfc_expr *e)
4802 mpz_t array[GFC_MAX_DIMENSIONS];
4805 if (e->rank == 0 || e->shape != NULL)
4808 for (i = 0; i < e->rank; i++)
4809 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4812 e->shape = gfc_get_shape (e->rank);
4814 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4819 for (i--; i >= 0; i--)
4820 mpz_clear (array[i]);
4824 /* Given a variable expression node, compute the rank of the expression by
4825 examining the base symbol and any reference structures it may have. */
4828 expression_rank (gfc_expr *e)
4833 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4834 could lead to serious confusion... */
4835 gcc_assert (e->expr_type != EXPR_COMPCALL);
4839 if (e->expr_type == EXPR_ARRAY)
4841 /* Constructors can have a rank different from one via RESHAPE(). */
4843 if (e->symtree == NULL)
4849 e->rank = (e->symtree->n.sym->as == NULL)
4850 ? 0 : e->symtree->n.sym->as->rank;
4856 for (ref = e->ref; ref; ref = ref->next)
4858 if (ref->type != REF_ARRAY)
4861 if (ref->u.ar.type == AR_FULL)
4863 rank = ref->u.ar.as->rank;
4867 if (ref->u.ar.type == AR_SECTION)
4869 /* Figure out the rank of the section. */
4871 gfc_internal_error ("expression_rank(): Two array specs");
4873 for (i = 0; i < ref->u.ar.dimen; i++)
4874 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4875 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4885 expression_shape (e);
4889 /* Resolve a variable expression. */
4892 resolve_variable (gfc_expr *e)
4899 if (e->symtree == NULL)
4901 sym = e->symtree->n.sym;
4903 /* If this is an associate-name, it may be parsed with an array reference
4904 in error even though the target is scalar. Fail directly in this case. */
4905 if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
4908 /* On the other hand, the parser may not have known this is an array;
4909 in this case, we have to add a FULL reference. */
4910 if (sym->assoc && sym->attr.dimension && !e->ref)
4912 e->ref = gfc_get_ref ();
4913 e->ref->type = REF_ARRAY;
4914 e->ref->u.ar.type = AR_FULL;
4915 e->ref->u.ar.dimen = 0;
4918 if (e->ref && resolve_ref (e) == FAILURE)
4921 if (sym->attr.flavor == FL_PROCEDURE
4922 && (!sym->attr.function
4923 || (sym->attr.function && sym->result
4924 && sym->result->attr.proc_pointer
4925 && !sym->result->attr.function)))
4927 e->ts.type = BT_PROCEDURE;
4928 goto resolve_procedure;
4931 if (sym->ts.type != BT_UNKNOWN)
4932 gfc_variable_attr (e, &e->ts);
4935 /* Must be a simple variable reference. */
4936 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4941 if (check_assumed_size_reference (sym, e))
4944 /* Deal with forward references to entries during resolve_code, to
4945 satisfy, at least partially, 12.5.2.5. */
4946 if (gfc_current_ns->entries
4947 && current_entry_id == sym->entry_id
4950 && cs_base->current->op != EXEC_ENTRY)
4952 gfc_entry_list *entry;
4953 gfc_formal_arglist *formal;
4957 /* If the symbol is a dummy... */
4958 if (sym->attr.dummy && sym->ns == gfc_current_ns)
4960 entry = gfc_current_ns->entries;
4963 /* ...test if the symbol is a parameter of previous entries. */
4964 for (; entry && entry->id <= current_entry_id; entry = entry->next)
4965 for (formal = entry->sym->formal; formal; formal = formal->next)
4967 if (formal->sym && sym->name == formal->sym->name)
4971 /* If it has not been seen as a dummy, this is an error. */
4974 if (specification_expr)
4975 gfc_error ("Variable '%s', used in a specification expression"
4976 ", is referenced at %L before the ENTRY statement "
4977 "in which it is a parameter",
4978 sym->name, &cs_base->current->loc);
4980 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4981 "statement in which it is a parameter",
4982 sym->name, &cs_base->current->loc);
4987 /* Now do the same check on the specification expressions. */
4988 specification_expr = 1;
4989 if (sym->ts.type == BT_CHARACTER
4990 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
4994 for (n = 0; n < sym->as->rank; n++)
4996 specification_expr = 1;
4997 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
4999 specification_expr = 1;
5000 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
5003 specification_expr = 0;
5006 /* Update the symbol's entry level. */
5007 sym->entry_id = current_entry_id + 1;
5010 /* If a symbol has been host_associated mark it. This is used latter,
5011 to identify if aliasing is possible via host association. */
5012 if (sym->attr.flavor == FL_VARIABLE
5013 && gfc_current_ns->parent
5014 && (gfc_current_ns->parent == sym->ns
5015 || (gfc_current_ns->parent->parent
5016 && gfc_current_ns->parent->parent == sym->ns)))
5017 sym->attr.host_assoc = 1;
5020 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
5023 /* F2008, C617 and C1229. */
5024 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5025 && gfc_is_coindexed (e))
5027 gfc_ref *ref, *ref2 = NULL;
5029 if (e->ts.type == BT_CLASS)
5031 gfc_error ("Polymorphic subobject of coindexed object at %L",
5036 for (ref = e->ref; ref; ref = ref->next)
5038 if (ref->type == REF_COMPONENT)
5040 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5044 for ( ; ref; ref = ref->next)
5045 if (ref->type == REF_COMPONENT)
5048 /* Expression itself is coindexed object. */
5052 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5053 for ( ; c; c = c->next)
5054 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5056 gfc_error ("Coindexed object with polymorphic allocatable "
5057 "subcomponent at %L", &e->where);
5068 /* Checks to see that the correct symbol has been host associated.
5069 The only situation where this arises is that in which a twice
5070 contained function is parsed after the host association is made.
5071 Therefore, on detecting this, change the symbol in the expression
5072 and convert the array reference into an actual arglist if the old
5073 symbol is a variable. */
5075 check_host_association (gfc_expr *e)
5077 gfc_symbol *sym, *old_sym;
5081 gfc_actual_arglist *arg, *tail = NULL;
5082 bool retval = e->expr_type == EXPR_FUNCTION;
5084 /* If the expression is the result of substitution in
5085 interface.c(gfc_extend_expr) because there is no way in
5086 which the host association can be wrong. */
5087 if (e->symtree == NULL
5088 || e->symtree->n.sym == NULL
5089 || e->user_operator)
5092 old_sym = e->symtree->n.sym;
5094 if (gfc_current_ns->parent
5095 && old_sym->ns != gfc_current_ns)
5097 /* Use the 'USE' name so that renamed module symbols are
5098 correctly handled. */
5099 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5101 if (sym && old_sym != sym
5102 && sym->ts.type == old_sym->ts.type
5103 && sym->attr.flavor == FL_PROCEDURE
5104 && sym->attr.contained)
5106 /* Clear the shape, since it might not be valid. */
5107 if (e->shape != NULL)
5109 for (n = 0; n < e->rank; n++)
5110 mpz_clear (e->shape[n]);
5112 gfc_free (e->shape);
5115 /* Give the expression the right symtree! */
5116 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5117 gcc_assert (st != NULL);
5119 if (old_sym->attr.flavor == FL_PROCEDURE
5120 || e->expr_type == EXPR_FUNCTION)
5122 /* Original was function so point to the new symbol, since
5123 the actual argument list is already attached to the
5125 e->value.function.esym = NULL;
5130 /* Original was variable so convert array references into
5131 an actual arglist. This does not need any checking now
5132 since gfc_resolve_function will take care of it. */
5133 e->value.function.actual = NULL;
5134 e->expr_type = EXPR_FUNCTION;
5137 /* Ambiguity will not arise if the array reference is not
5138 the last reference. */
5139 for (ref = e->ref; ref; ref = ref->next)
5140 if (ref->type == REF_ARRAY && ref->next == NULL)
5143 gcc_assert (ref->type == REF_ARRAY);
5145 /* Grab the start expressions from the array ref and
5146 copy them into actual arguments. */
5147 for (n = 0; n < ref->u.ar.dimen; n++)
5149 arg = gfc_get_actual_arglist ();
5150 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5151 if (e->value.function.actual == NULL)
5152 tail = e->value.function.actual = arg;
5160 /* Dump the reference list and set the rank. */
5161 gfc_free_ref_list (e->ref);
5163 e->rank = sym->as ? sym->as->rank : 0;
5166 gfc_resolve_expr (e);
5170 /* This might have changed! */
5171 return e->expr_type == EXPR_FUNCTION;
5176 gfc_resolve_character_operator (gfc_expr *e)
5178 gfc_expr *op1 = e->value.op.op1;
5179 gfc_expr *op2 = e->value.op.op2;
5180 gfc_expr *e1 = NULL;
5181 gfc_expr *e2 = NULL;
5183 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5185 if (op1->ts.u.cl && op1->ts.u.cl->length)
5186 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5187 else if (op1->expr_type == EXPR_CONSTANT)
5188 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5189 op1->value.character.length);
5191 if (op2->ts.u.cl && op2->ts.u.cl->length)
5192 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5193 else if (op2->expr_type == EXPR_CONSTANT)
5194 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5195 op2->value.character.length);
5197 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5202 e->ts.u.cl->length = gfc_add (e1, e2);
5203 e->ts.u.cl->length->ts.type = BT_INTEGER;
5204 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5205 gfc_simplify_expr (e->ts.u.cl->length, 0);
5206 gfc_resolve_expr (e->ts.u.cl->length);
5212 /* Ensure that an character expression has a charlen and, if possible, a
5213 length expression. */
5216 fixup_charlen (gfc_expr *e)
5218 /* The cases fall through so that changes in expression type and the need
5219 for multiple fixes are picked up. In all circumstances, a charlen should
5220 be available for the middle end to hang a backend_decl on. */
5221 switch (e->expr_type)
5224 gfc_resolve_character_operator (e);
5227 if (e->expr_type == EXPR_ARRAY)
5228 gfc_resolve_character_array_constructor (e);
5230 case EXPR_SUBSTRING:
5231 if (!e->ts.u.cl && e->ref)
5232 gfc_resolve_substring_charlen (e);
5236 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5243 /* Update an actual argument to include the passed-object for type-bound
5244 procedures at the right position. */
5246 static gfc_actual_arglist*
5247 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5250 gcc_assert (argpos > 0);
5254 gfc_actual_arglist* result;
5256 result = gfc_get_actual_arglist ();
5260 result->name = name;
5266 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5268 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5273 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5276 extract_compcall_passed_object (gfc_expr* e)
5280 gcc_assert (e->expr_type == EXPR_COMPCALL);
5282 if (e->value.compcall.base_object)
5283 po = gfc_copy_expr (e->value.compcall.base_object);
5286 po = gfc_get_expr ();
5287 po->expr_type = EXPR_VARIABLE;
5288 po->symtree = e->symtree;
5289 po->ref = gfc_copy_ref (e->ref);
5290 po->where = e->where;
5293 if (gfc_resolve_expr (po) == FAILURE)
5300 /* Update the arglist of an EXPR_COMPCALL expression to include the
5304 update_compcall_arglist (gfc_expr* e)
5307 gfc_typebound_proc* tbp;
5309 tbp = e->value.compcall.tbp;
5314 po = extract_compcall_passed_object (e);
5318 if (tbp->nopass || e->value.compcall.ignore_pass)
5324 gcc_assert (tbp->pass_arg_num > 0);
5325 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5333 /* Extract the passed object from a PPC call (a copy of it). */
5336 extract_ppc_passed_object (gfc_expr *e)
5341 po = gfc_get_expr ();
5342 po->expr_type = EXPR_VARIABLE;
5343 po->symtree = e->symtree;
5344 po->ref = gfc_copy_ref (e->ref);
5345 po->where = e->where;
5347 /* Remove PPC reference. */
5349 while ((*ref)->next)
5350 ref = &(*ref)->next;
5351 gfc_free_ref_list (*ref);
5354 if (gfc_resolve_expr (po) == FAILURE)
5361 /* Update the actual arglist of a procedure pointer component to include the
5365 update_ppc_arglist (gfc_expr* e)
5369 gfc_typebound_proc* tb;
5371 if (!gfc_is_proc_ptr_comp (e, &ppc))
5378 else if (tb->nopass)
5381 po = extract_ppc_passed_object (e);
5387 gfc_error ("Passed-object at %L must be scalar", &e->where);
5391 gcc_assert (tb->pass_arg_num > 0);
5392 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5400 /* Check that the object a TBP is called on is valid, i.e. it must not be
5401 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5404 check_typebound_baseobject (gfc_expr* e)
5407 gfc_try return_value = FAILURE;
5409 base = extract_compcall_passed_object (e);
5413 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5415 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5417 gfc_error ("Base object for type-bound procedure call at %L is of"
5418 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5422 /* If the procedure called is NOPASS, the base object must be scalar. */
5423 if (e->value.compcall.tbp->nopass && base->rank > 0)
5425 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5426 " be scalar", &e->where);
5430 /* FIXME: Remove once PR 41177 (this problem) is fixed completely. */
5433 gfc_error ("Non-scalar base object at %L currently not implemented",
5438 return_value = SUCCESS;
5441 gfc_free_expr (base);
5442 return return_value;
5446 /* Resolve a call to a type-bound procedure, either function or subroutine,
5447 statically from the data in an EXPR_COMPCALL expression. The adapted
5448 arglist and the target-procedure symtree are returned. */
5451 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5452 gfc_actual_arglist** actual)
5454 gcc_assert (e->expr_type == EXPR_COMPCALL);
5455 gcc_assert (!e->value.compcall.tbp->is_generic);
5457 /* Update the actual arglist for PASS. */
5458 if (update_compcall_arglist (e) == FAILURE)
5461 *actual = e->value.compcall.actual;
5462 *target = e->value.compcall.tbp->u.specific;
5464 gfc_free_ref_list (e->ref);
5466 e->value.compcall.actual = NULL;
5472 /* Get the ultimate declared type from an expression. In addition,
5473 return the last class/derived type reference and the copy of the
5476 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5479 gfc_symbol *declared;
5486 *new_ref = gfc_copy_ref (e->ref);
5488 for (ref = e->ref; ref; ref = ref->next)
5490 if (ref->type != REF_COMPONENT)
5493 if (ref->u.c.component->ts.type == BT_CLASS
5494 || ref->u.c.component->ts.type == BT_DERIVED)
5496 declared = ref->u.c.component->ts.u.derived;
5502 if (declared == NULL)
5503 declared = e->symtree->n.sym->ts.u.derived;
5509 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5510 which of the specific bindings (if any) matches the arglist and transform
5511 the expression into a call of that binding. */
5514 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5516 gfc_typebound_proc* genproc;
5517 const char* genname;
5519 gfc_symbol *derived;
5521 gcc_assert (e->expr_type == EXPR_COMPCALL);
5522 genname = e->value.compcall.name;
5523 genproc = e->value.compcall.tbp;
5525 if (!genproc->is_generic)
5528 /* Try the bindings on this type and in the inheritance hierarchy. */
5529 for (; genproc; genproc = genproc->overridden)
5533 gcc_assert (genproc->is_generic);
5534 for (g = genproc->u.generic; g; g = g->next)
5537 gfc_actual_arglist* args;
5540 gcc_assert (g->specific);
5542 if (g->specific->error)
5545 target = g->specific->u.specific->n.sym;
5547 /* Get the right arglist by handling PASS/NOPASS. */
5548 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5549 if (!g->specific->nopass)
5552 po = extract_compcall_passed_object (e);
5556 gcc_assert (g->specific->pass_arg_num > 0);
5557 gcc_assert (!g->specific->error);
5558 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5559 g->specific->pass_arg);
5561 resolve_actual_arglist (args, target->attr.proc,
5562 is_external_proc (target) && !target->formal);
5564 /* Check if this arglist matches the formal. */
5565 matches = gfc_arglist_matches_symbol (&args, target);
5567 /* Clean up and break out of the loop if we've found it. */
5568 gfc_free_actual_arglist (args);
5571 e->value.compcall.tbp = g->specific;
5572 genname = g->specific_st->name;
5573 /* Pass along the name for CLASS methods, where the vtab
5574 procedure pointer component has to be referenced. */
5582 /* Nothing matching found! */
5583 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5584 " '%s' at %L", genname, &e->where);
5588 /* Make sure that we have the right specific instance for the name. */
5589 derived = get_declared_from_expr (NULL, NULL, e);
5591 st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where);
5593 e->value.compcall.tbp = st->n.tb;
5599 /* Resolve a call to a type-bound subroutine. */
5602 resolve_typebound_call (gfc_code* c, const char **name)
5604 gfc_actual_arglist* newactual;
5605 gfc_symtree* target;
5607 /* Check that's really a SUBROUTINE. */
5608 if (!c->expr1->value.compcall.tbp->subroutine)
5610 gfc_error ("'%s' at %L should be a SUBROUTINE",
5611 c->expr1->value.compcall.name, &c->loc);
5615 if (check_typebound_baseobject (c->expr1) == FAILURE)
5618 /* Pass along the name for CLASS methods, where the vtab
5619 procedure pointer component has to be referenced. */
5621 *name = c->expr1->value.compcall.name;
5623 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5626 /* Transform into an ordinary EXEC_CALL for now. */
5628 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5631 c->ext.actual = newactual;
5632 c->symtree = target;
5633 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5635 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5637 gfc_free_expr (c->expr1);
5638 c->expr1 = gfc_get_expr ();
5639 c->expr1->expr_type = EXPR_FUNCTION;
5640 c->expr1->symtree = target;
5641 c->expr1->where = c->loc;
5643 return resolve_call (c);
5647 /* Resolve a component-call expression. */
5649 resolve_compcall (gfc_expr* e, const char **name)
5651 gfc_actual_arglist* newactual;
5652 gfc_symtree* target;
5654 /* Check that's really a FUNCTION. */
5655 if (!e->value.compcall.tbp->function)
5657 gfc_error ("'%s' at %L should be a FUNCTION",
5658 e->value.compcall.name, &e->where);
5662 /* These must not be assign-calls! */
5663 gcc_assert (!e->value.compcall.assign);
5665 if (check_typebound_baseobject (e) == FAILURE)
5668 /* Pass along the name for CLASS methods, where the vtab
5669 procedure pointer component has to be referenced. */
5671 *name = e->value.compcall.name;
5673 if (resolve_typebound_generic_call (e, name) == FAILURE)
5675 gcc_assert (!e->value.compcall.tbp->is_generic);
5677 /* Take the rank from the function's symbol. */
5678 if (e->value.compcall.tbp->u.specific->n.sym->as)
5679 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5681 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5682 arglist to the TBP's binding target. */
5684 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5687 e->value.function.actual = newactual;
5688 e->value.function.name = NULL;
5689 e->value.function.esym = target->n.sym;
5690 e->value.function.isym = NULL;
5691 e->symtree = target;
5692 e->ts = target->n.sym->ts;
5693 e->expr_type = EXPR_FUNCTION;
5695 /* Resolution is not necessary if this is a class subroutine; this
5696 function only has to identify the specific proc. Resolution of
5697 the call will be done next in resolve_typebound_call. */
5698 return gfc_resolve_expr (e);
5703 /* Resolve a typebound function, or 'method'. First separate all
5704 the non-CLASS references by calling resolve_compcall directly. */
5707 resolve_typebound_function (gfc_expr* e)
5709 gfc_symbol *declared;
5720 /* Deal with typebound operators for CLASS objects. */
5721 expr = e->value.compcall.base_object;
5722 if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
5723 && e->value.compcall.name)
5725 /* Since the typebound operators are generic, we have to ensure
5726 that any delays in resolution are corrected and that the vtab
5728 ts = expr->symtree->n.sym->ts;
5729 declared = ts.u.derived;
5730 c = gfc_find_component (declared, "$vptr", true, true);
5731 if (c->ts.u.derived == NULL)
5732 c->ts.u.derived = gfc_find_derived_vtab (declared);
5734 if (resolve_compcall (e, &name) == FAILURE)
5737 /* Use the generic name if it is there. */
5738 name = name ? name : e->value.function.esym->name;
5739 e->symtree = expr->symtree;
5740 expr->symtree->n.sym->ts.u.derived = declared;
5741 gfc_add_component_ref (e, "$vptr");
5742 gfc_add_component_ref (e, name);
5743 e->value.function.esym = NULL;
5748 return resolve_compcall (e, NULL);
5750 if (resolve_ref (e) == FAILURE)
5753 /* Get the CLASS declared type. */
5754 declared = get_declared_from_expr (&class_ref, &new_ref, e);
5756 /* Weed out cases of the ultimate component being a derived type. */
5757 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5758 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5760 gfc_free_ref_list (new_ref);
5761 return resolve_compcall (e, NULL);
5764 c = gfc_find_component (declared, "$data", true, true);
5765 declared = c->ts.u.derived;
5767 /* Treat the call as if it is a typebound procedure, in order to roll
5768 out the correct name for the specific function. */
5769 if (resolve_compcall (e, &name) == FAILURE)
5773 /* Then convert the expression to a procedure pointer component call. */
5774 e->value.function.esym = NULL;
5780 /* '$vptr' points to the vtab, which contains the procedure pointers. */
5781 gfc_add_component_ref (e, "$vptr");
5782 gfc_add_component_ref (e, name);
5784 /* Recover the typespec for the expression. This is really only
5785 necessary for generic procedures, where the additional call
5786 to gfc_add_component_ref seems to throw the collection of the
5787 correct typespec. */
5792 /* Resolve a typebound subroutine, or 'method'. First separate all
5793 the non-CLASS references by calling resolve_typebound_call
5797 resolve_typebound_subroutine (gfc_code *code)
5799 gfc_symbol *declared;
5808 st = code->expr1->symtree;
5810 /* Deal with typebound operators for CLASS objects. */
5811 expr = code->expr1->value.compcall.base_object;
5812 if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
5813 && code->expr1->value.compcall.name)
5815 /* Since the typebound operators are generic, we have to ensure
5816 that any delays in resolution are corrected and that the vtab
5818 ts = expr->symtree->n.sym->ts;
5819 declared = ts.u.derived;
5820 c = gfc_find_component (declared, "$vptr", true, true);
5821 if (c->ts.u.derived == NULL)
5822 c->ts.u.derived = gfc_find_derived_vtab (declared);
5824 if (resolve_typebound_call (code, &name) == FAILURE)
5827 /* Use the generic name if it is there. */
5828 name = name ? name : code->expr1->value.function.esym->name;
5829 code->expr1->symtree = expr->symtree;
5830 expr->symtree->n.sym->ts.u.derived = declared;
5831 gfc_add_component_ref (code->expr1, "$vptr");
5832 gfc_add_component_ref (code->expr1, name);
5833 code->expr1->value.function.esym = NULL;
5838 return resolve_typebound_call (code, NULL);
5840 if (resolve_ref (code->expr1) == FAILURE)
5843 /* Get the CLASS declared type. */
5844 get_declared_from_expr (&class_ref, &new_ref, code->expr1);
5846 /* Weed out cases of the ultimate component being a derived type. */
5847 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5848 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5850 gfc_free_ref_list (new_ref);
5851 return resolve_typebound_call (code, NULL);
5854 if (resolve_typebound_call (code, &name) == FAILURE)
5856 ts = code->expr1->ts;
5858 /* Then convert the expression to a procedure pointer component call. */
5859 code->expr1->value.function.esym = NULL;
5860 code->expr1->symtree = st;
5863 code->expr1->ref = new_ref;
5865 /* '$vptr' points to the vtab, which contains the procedure pointers. */
5866 gfc_add_component_ref (code->expr1, "$vptr");
5867 gfc_add_component_ref (code->expr1, name);
5869 /* Recover the typespec for the expression. This is really only
5870 necessary for generic procedures, where the additional call
5871 to gfc_add_component_ref seems to throw the collection of the
5872 correct typespec. */
5873 code->expr1->ts = ts;
5878 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5881 resolve_ppc_call (gfc_code* c)
5883 gfc_component *comp;
5886 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
5889 c->resolved_sym = c->expr1->symtree->n.sym;
5890 c->expr1->expr_type = EXPR_VARIABLE;
5892 if (!comp->attr.subroutine)
5893 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
5895 if (resolve_ref (c->expr1) == FAILURE)
5898 if (update_ppc_arglist (c->expr1) == FAILURE)
5901 c->ext.actual = c->expr1->value.compcall.actual;
5903 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
5904 comp->formal == NULL) == FAILURE)
5907 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
5913 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5916 resolve_expr_ppc (gfc_expr* e)
5918 gfc_component *comp;
5921 b = gfc_is_proc_ptr_comp (e, &comp);
5924 /* Convert to EXPR_FUNCTION. */
5925 e->expr_type = EXPR_FUNCTION;
5926 e->value.function.isym = NULL;
5927 e->value.function.actual = e->value.compcall.actual;
5929 if (comp->as != NULL)
5930 e->rank = comp->as->rank;
5932 if (!comp->attr.function)
5933 gfc_add_function (&comp->attr, comp->name, &e->where);
5935 if (resolve_ref (e) == FAILURE)
5938 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
5939 comp->formal == NULL) == FAILURE)
5942 if (update_ppc_arglist (e) == FAILURE)
5945 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
5952 gfc_is_expandable_expr (gfc_expr *e)
5954 gfc_constructor *con;
5956 if (e->expr_type == EXPR_ARRAY)
5958 /* Traverse the constructor looking for variables that are flavor
5959 parameter. Parameters must be expanded since they are fully used at
5961 con = gfc_constructor_first (e->value.constructor);
5962 for (; con; con = gfc_constructor_next (con))
5964 if (con->expr->expr_type == EXPR_VARIABLE
5965 && con->expr->symtree
5966 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
5967 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
5969 if (con->expr->expr_type == EXPR_ARRAY
5970 && gfc_is_expandable_expr (con->expr))
5978 /* Resolve an expression. That is, make sure that types of operands agree
5979 with their operators, intrinsic operators are converted to function calls
5980 for overloaded types and unresolved function references are resolved. */
5983 gfc_resolve_expr (gfc_expr *e)
5991 /* inquiry_argument only applies to variables. */
5992 inquiry_save = inquiry_argument;
5993 if (e->expr_type != EXPR_VARIABLE)
5994 inquiry_argument = false;
5996 switch (e->expr_type)
5999 t = resolve_operator (e);
6005 if (check_host_association (e))
6006 t = resolve_function (e);
6009 t = resolve_variable (e);
6011 expression_rank (e);
6014 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6015 && e->ref->type != REF_SUBSTRING)
6016 gfc_resolve_substring_charlen (e);
6021 t = resolve_typebound_function (e);
6024 case EXPR_SUBSTRING:
6025 t = resolve_ref (e);
6034 t = resolve_expr_ppc (e);
6039 if (resolve_ref (e) == FAILURE)
6042 t = gfc_resolve_array_constructor (e);
6043 /* Also try to expand a constructor. */
6046 expression_rank (e);
6047 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6048 gfc_expand_constructor (e, false);
6051 /* This provides the opportunity for the length of constructors with
6052 character valued function elements to propagate the string length
6053 to the expression. */
6054 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6056 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6057 here rather then add a duplicate test for it above. */
6058 gfc_expand_constructor (e, false);
6059 t = gfc_resolve_character_array_constructor (e);
6064 case EXPR_STRUCTURE:
6065 t = resolve_ref (e);
6069 t = resolve_structure_cons (e, 0);
6073 t = gfc_simplify_expr (e, 0);
6077 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6080 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6083 inquiry_argument = inquiry_save;
6089 /* Resolve an expression from an iterator. They must be scalar and have
6090 INTEGER or (optionally) REAL type. */
6093 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6094 const char *name_msgid)
6096 if (gfc_resolve_expr (expr) == FAILURE)
6099 if (expr->rank != 0)
6101 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6105 if (expr->ts.type != BT_INTEGER)
6107 if (expr->ts.type == BT_REAL)
6110 return gfc_notify_std (GFC_STD_F95_DEL,
6111 "Deleted feature: %s at %L must be integer",
6112 _(name_msgid), &expr->where);
6115 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6122 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6130 /* Resolve the expressions in an iterator structure. If REAL_OK is
6131 false allow only INTEGER type iterators, otherwise allow REAL types. */
6134 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6136 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6140 if (gfc_check_vardef_context (iter->var, false, _("iterator variable"))
6144 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6145 "Start expression in DO loop") == FAILURE)
6148 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6149 "End expression in DO loop") == FAILURE)
6152 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6153 "Step expression in DO loop") == FAILURE)
6156 if (iter->step->expr_type == EXPR_CONSTANT)
6158 if ((iter->step->ts.type == BT_INTEGER
6159 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6160 || (iter->step->ts.type == BT_REAL
6161 && mpfr_sgn (iter->step->value.real) == 0))
6163 gfc_error ("Step expression in DO loop at %L cannot be zero",
6164 &iter->step->where);
6169 /* Convert start, end, and step to the same type as var. */
6170 if (iter->start->ts.kind != iter->var->ts.kind
6171 || iter->start->ts.type != iter->var->ts.type)
6172 gfc_convert_type (iter->start, &iter->var->ts, 2);
6174 if (iter->end->ts.kind != iter->var->ts.kind
6175 || iter->end->ts.type != iter->var->ts.type)
6176 gfc_convert_type (iter->end, &iter->var->ts, 2);
6178 if (iter->step->ts.kind != iter->var->ts.kind
6179 || iter->step->ts.type != iter->var->ts.type)
6180 gfc_convert_type (iter->step, &iter->var->ts, 2);
6182 if (iter->start->expr_type == EXPR_CONSTANT
6183 && iter->end->expr_type == EXPR_CONSTANT
6184 && iter->step->expr_type == EXPR_CONSTANT)
6187 if (iter->start->ts.type == BT_INTEGER)
6189 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6190 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6194 sgn = mpfr_sgn (iter->step->value.real);
6195 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6197 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6198 gfc_warning ("DO loop at %L will be executed zero times",
6199 &iter->step->where);
6206 /* Traversal function for find_forall_index. f == 2 signals that
6207 that variable itself is not to be checked - only the references. */
6210 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6212 if (expr->expr_type != EXPR_VARIABLE)
6215 /* A scalar assignment */
6216 if (!expr->ref || *f == 1)
6218 if (expr->symtree->n.sym == sym)
6230 /* Check whether the FORALL index appears in the expression or not.
6231 Returns SUCCESS if SYM is found in EXPR. */
6234 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6236 if (gfc_traverse_expr (expr, sym, forall_index, f))
6243 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6244 to be a scalar INTEGER variable. The subscripts and stride are scalar
6245 INTEGERs, and if stride is a constant it must be nonzero.
6246 Furthermore "A subscript or stride in a forall-triplet-spec shall
6247 not contain a reference to any index-name in the
6248 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6251 resolve_forall_iterators (gfc_forall_iterator *it)
6253 gfc_forall_iterator *iter, *iter2;
6255 for (iter = it; iter; iter = iter->next)
6257 if (gfc_resolve_expr (iter->var) == SUCCESS
6258 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6259 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6262 if (gfc_resolve_expr (iter->start) == SUCCESS
6263 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6264 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6265 &iter->start->where);
6266 if (iter->var->ts.kind != iter->start->ts.kind)
6267 gfc_convert_type (iter->start, &iter->var->ts, 2);
6269 if (gfc_resolve_expr (iter->end) == SUCCESS
6270 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6271 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6273 if (iter->var->ts.kind != iter->end->ts.kind)
6274 gfc_convert_type (iter->end, &iter->var->ts, 2);
6276 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6278 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6279 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6280 &iter->stride->where, "INTEGER");
6282 if (iter->stride->expr_type == EXPR_CONSTANT
6283 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6284 gfc_error ("FORALL stride expression at %L cannot be zero",
6285 &iter->stride->where);
6287 if (iter->var->ts.kind != iter->stride->ts.kind)
6288 gfc_convert_type (iter->stride, &iter->var->ts, 2);
6291 for (iter = it; iter; iter = iter->next)
6292 for (iter2 = iter; iter2; iter2 = iter2->next)
6294 if (find_forall_index (iter2->start,
6295 iter->var->symtree->n.sym, 0) == SUCCESS
6296 || find_forall_index (iter2->end,
6297 iter->var->symtree->n.sym, 0) == SUCCESS
6298 || find_forall_index (iter2->stride,
6299 iter->var->symtree->n.sym, 0) == SUCCESS)
6300 gfc_error ("FORALL index '%s' may not appear in triplet "
6301 "specification at %L", iter->var->symtree->name,
6302 &iter2->start->where);
6307 /* Given a pointer to a symbol that is a derived type, see if it's
6308 inaccessible, i.e. if it's defined in another module and the components are
6309 PRIVATE. The search is recursive if necessary. Returns zero if no
6310 inaccessible components are found, nonzero otherwise. */
6313 derived_inaccessible (gfc_symbol *sym)
6317 if (sym->attr.use_assoc && sym->attr.private_comp)
6320 for (c = sym->components; c; c = c->next)
6322 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6330 /* Resolve the argument of a deallocate expression. The expression must be
6331 a pointer or a full array. */
6334 resolve_deallocate_expr (gfc_expr *e)
6336 symbol_attribute attr;
6337 int allocatable, pointer;
6342 if (gfc_resolve_expr (e) == FAILURE)
6345 if (e->expr_type != EXPR_VARIABLE)
6348 sym = e->symtree->n.sym;
6350 if (sym->ts.type == BT_CLASS)
6352 allocatable = CLASS_DATA (sym)->attr.allocatable;
6353 pointer = CLASS_DATA (sym)->attr.class_pointer;
6357 allocatable = sym->attr.allocatable;
6358 pointer = sym->attr.pointer;
6360 for (ref = e->ref; ref; ref = ref->next)
6365 if (ref->u.ar.type != AR_FULL)
6370 c = ref->u.c.component;
6371 if (c->ts.type == BT_CLASS)
6373 allocatable = CLASS_DATA (c)->attr.allocatable;
6374 pointer = CLASS_DATA (c)->attr.class_pointer;
6378 allocatable = c->attr.allocatable;
6379 pointer = c->attr.pointer;
6389 attr = gfc_expr_attr (e);
6391 if (allocatable == 0 && attr.pointer == 0)
6394 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6400 && gfc_check_vardef_context (e, true, _("DEALLOCATE object")) == FAILURE)
6402 if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE)
6405 if (e->ts.type == BT_CLASS)
6407 /* Only deallocate the DATA component. */
6408 gfc_add_component_ref (e, "$data");
6415 /* Returns true if the expression e contains a reference to the symbol sym. */
6417 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6419 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6426 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6428 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6432 /* Given the expression node e for an allocatable/pointer of derived type to be
6433 allocated, get the expression node to be initialized afterwards (needed for
6434 derived types with default initializers, and derived types with allocatable
6435 components that need nullification.) */
6438 gfc_expr_to_initialize (gfc_expr *e)
6444 result = gfc_copy_expr (e);
6446 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6447 for (ref = result->ref; ref; ref = ref->next)
6448 if (ref->type == REF_ARRAY && ref->next == NULL)
6450 ref->u.ar.type = AR_FULL;
6452 for (i = 0; i < ref->u.ar.dimen; i++)
6453 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6455 result->rank = ref->u.ar.dimen;
6463 /* If the last ref of an expression is an array ref, return a copy of the
6464 expression with that one removed. Otherwise, a copy of the original
6465 expression. This is used for allocate-expressions and pointer assignment
6466 LHS, where there may be an array specification that needs to be stripped
6467 off when using gfc_check_vardef_context. */
6470 remove_last_array_ref (gfc_expr* e)
6475 e2 = gfc_copy_expr (e);
6476 for (r = &e2->ref; *r; r = &(*r)->next)
6477 if ((*r)->type == REF_ARRAY && !(*r)->next)
6479 gfc_free_ref_list (*r);
6488 /* Used in resolve_allocate_expr to check that a allocation-object and
6489 a source-expr are conformable. This does not catch all possible
6490 cases; in particular a runtime checking is needed. */
6493 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6496 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6498 /* First compare rank. */
6499 if (tail && e1->rank != tail->u.ar.as->rank)
6501 gfc_error ("Source-expr at %L must be scalar or have the "
6502 "same rank as the allocate-object at %L",
6503 &e1->where, &e2->where);
6514 for (i = 0; i < e1->rank; i++)
6516 if (tail->u.ar.end[i])
6518 mpz_set (s, tail->u.ar.end[i]->value.integer);
6519 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6520 mpz_add_ui (s, s, 1);
6524 mpz_set (s, tail->u.ar.start[i]->value.integer);
6527 if (mpz_cmp (e1->shape[i], s) != 0)
6529 gfc_error ("Source-expr at %L and allocate-object at %L must "
6530 "have the same shape", &e1->where, &e2->where);
6543 /* Resolve the expression in an ALLOCATE statement, doing the additional
6544 checks to see whether the expression is OK or not. The expression must
6545 have a trailing array reference that gives the size of the array. */
6548 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6550 int i, pointer, allocatable, dimension, is_abstract;
6552 symbol_attribute attr;
6553 gfc_ref *ref, *ref2;
6556 gfc_symbol *sym = NULL;
6561 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6562 checking of coarrays. */
6563 for (ref = e->ref; ref; ref = ref->next)
6564 if (ref->next == NULL)
6567 if (ref && ref->type == REF_ARRAY)
6568 ref->u.ar.in_allocate = true;
6570 if (gfc_resolve_expr (e) == FAILURE)
6573 /* Make sure the expression is allocatable or a pointer. If it is
6574 pointer, the next-to-last reference must be a pointer. */
6578 sym = e->symtree->n.sym;
6580 /* Check whether ultimate component is abstract and CLASS. */
6583 if (e->expr_type != EXPR_VARIABLE)
6586 attr = gfc_expr_attr (e);
6587 pointer = attr.pointer;
6588 dimension = attr.dimension;
6589 codimension = attr.codimension;
6593 if (sym->ts.type == BT_CLASS)
6595 allocatable = CLASS_DATA (sym)->attr.allocatable;
6596 pointer = CLASS_DATA (sym)->attr.class_pointer;
6597 dimension = CLASS_DATA (sym)->attr.dimension;
6598 codimension = CLASS_DATA (sym)->attr.codimension;
6599 is_abstract = CLASS_DATA (sym)->attr.abstract;
6603 allocatable = sym->attr.allocatable;
6604 pointer = sym->attr.pointer;
6605 dimension = sym->attr.dimension;
6606 codimension = sym->attr.codimension;
6609 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6614 if (ref->next != NULL)
6620 if (gfc_is_coindexed (e))
6622 gfc_error ("Coindexed allocatable object at %L",
6627 c = ref->u.c.component;
6628 if (c->ts.type == BT_CLASS)
6630 allocatable = CLASS_DATA (c)->attr.allocatable;
6631 pointer = CLASS_DATA (c)->attr.class_pointer;
6632 dimension = CLASS_DATA (c)->attr.dimension;
6633 codimension = CLASS_DATA (c)->attr.codimension;
6634 is_abstract = CLASS_DATA (c)->attr.abstract;
6638 allocatable = c->attr.allocatable;
6639 pointer = c->attr.pointer;
6640 dimension = c->attr.dimension;
6641 codimension = c->attr.codimension;
6642 is_abstract = c->attr.abstract;
6654 if (allocatable == 0 && pointer == 0)
6656 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6661 /* Some checks for the SOURCE tag. */
6664 /* Check F03:C631. */
6665 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6667 gfc_error ("Type of entity at %L is type incompatible with "
6668 "source-expr at %L", &e->where, &code->expr3->where);
6672 /* Check F03:C632 and restriction following Note 6.18. */
6673 if (code->expr3->rank > 0
6674 && conformable_arrays (code->expr3, e) == FAILURE)
6677 /* Check F03:C633. */
6678 if (code->expr3->ts.kind != e->ts.kind)
6680 gfc_error ("The allocate-object at %L and the source-expr at %L "
6681 "shall have the same kind type parameter",
6682 &e->where, &code->expr3->where);
6687 /* Check F08:C629. */
6688 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
6691 gcc_assert (e->ts.type == BT_CLASS);
6692 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6693 "type-spec or source-expr", sym->name, &e->where);
6697 /* In the variable definition context checks, gfc_expr_attr is used
6698 on the expression. This is fooled by the array specification
6699 present in e, thus we have to eliminate that one temporarily. */
6700 e2 = remove_last_array_ref (e);
6702 if (t == SUCCESS && pointer)
6703 t = gfc_check_vardef_context (e2, true, _("ALLOCATE object"));
6705 t = gfc_check_vardef_context (e2, false, _("ALLOCATE object"));
6712 /* Set up default initializer if needed. */
6716 if (code->ext.alloc.ts.type == BT_DERIVED)
6717 ts = code->ext.alloc.ts;
6721 if (ts.type == BT_CLASS)
6722 ts = ts.u.derived->components->ts;
6724 if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
6726 gfc_code *init_st = gfc_get_code ();
6727 init_st->loc = code->loc;
6728 init_st->op = EXEC_INIT_ASSIGN;
6729 init_st->expr1 = gfc_expr_to_initialize (e);
6730 init_st->expr2 = init_e;
6731 init_st->next = code->next;
6732 code->next = init_st;
6735 else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
6737 /* Default initialization via MOLD (non-polymorphic). */
6738 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
6739 gfc_resolve_expr (rhs);
6740 gfc_free_expr (code->expr3);
6744 if (e->ts.type == BT_CLASS)
6746 /* Make sure the vtab symbol is present when
6747 the module variables are generated. */
6748 gfc_typespec ts = e->ts;
6750 ts = code->expr3->ts;
6751 else if (code->ext.alloc.ts.type == BT_DERIVED)
6752 ts = code->ext.alloc.ts;
6753 gfc_find_derived_vtab (ts.u.derived);
6756 if (pointer || (dimension == 0 && codimension == 0))
6759 /* Make sure the last reference node is an array specifiction. */
6761 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
6762 || (dimension && ref2->u.ar.dimen == 0))
6764 gfc_error ("Array specification required in ALLOCATE statement "
6765 "at %L", &e->where);
6769 /* Make sure that the array section reference makes sense in the
6770 context of an ALLOCATE specification. */
6774 if (codimension && ar->codimen == 0)
6776 gfc_error ("Coarray specification required in ALLOCATE statement "
6777 "at %L", &e->where);
6781 for (i = 0; i < ar->dimen; i++)
6783 if (ref2->u.ar.type == AR_ELEMENT)
6786 switch (ar->dimen_type[i])
6792 if (ar->start[i] != NULL
6793 && ar->end[i] != NULL
6794 && ar->stride[i] == NULL)
6797 /* Fall Through... */
6802 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6808 for (a = code->ext.alloc.list; a; a = a->next)
6810 sym = a->expr->symtree->n.sym;
6812 /* TODO - check derived type components. */
6813 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6816 if ((ar->start[i] != NULL
6817 && gfc_find_sym_in_expr (sym, ar->start[i]))
6818 || (ar->end[i] != NULL
6819 && gfc_find_sym_in_expr (sym, ar->end[i])))
6821 gfc_error ("'%s' must not appear in the array specification at "
6822 "%L in the same ALLOCATE statement where it is "
6823 "itself allocated", sym->name, &ar->where);
6829 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
6831 if (ar->dimen_type[i] == DIMEN_ELEMENT
6832 || ar->dimen_type[i] == DIMEN_RANGE)
6834 if (i == (ar->dimen + ar->codimen - 1))
6836 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
6837 "statement at %L", &e->where);
6843 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
6844 && ar->stride[i] == NULL)
6847 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
6852 if (codimension && ar->as->rank == 0)
6854 gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
6855 "at %L", &e->where);
6867 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
6869 gfc_expr *stat, *errmsg, *pe, *qe;
6870 gfc_alloc *a, *p, *q;
6873 errmsg = code->expr2;
6875 /* Check the stat variable. */
6878 gfc_check_vardef_context (stat, false, _("STAT variable"));
6880 if ((stat->ts.type != BT_INTEGER
6881 && !(stat->ref && (stat->ref->type == REF_ARRAY
6882 || stat->ref->type == REF_COMPONENT)))
6884 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
6885 "variable", &stat->where);
6887 for (p = code->ext.alloc.list; p; p = p->next)
6888 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
6890 gfc_ref *ref1, *ref2;
6893 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
6894 ref1 = ref1->next, ref2 = ref2->next)
6896 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6898 if (ref1->u.c.component->name != ref2->u.c.component->name)
6907 gfc_error ("Stat-variable at %L shall not be %sd within "
6908 "the same %s statement", &stat->where, fcn, fcn);
6914 /* Check the errmsg variable. */
6918 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
6921 gfc_check_vardef_context (errmsg, false, _("ERRMSG variable"));
6923 if ((errmsg->ts.type != BT_CHARACTER
6925 && (errmsg->ref->type == REF_ARRAY
6926 || errmsg->ref->type == REF_COMPONENT)))
6927 || errmsg->rank > 0 )
6928 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
6929 "variable", &errmsg->where);
6931 for (p = code->ext.alloc.list; p; p = p->next)
6932 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
6934 gfc_ref *ref1, *ref2;
6937 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
6938 ref1 = ref1->next, ref2 = ref2->next)
6940 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6942 if (ref1->u.c.component->name != ref2->u.c.component->name)
6951 gfc_error ("Errmsg-variable at %L shall not be %sd within "
6952 "the same %s statement", &errmsg->where, fcn, fcn);
6958 /* Check that an allocate-object appears only once in the statement.
6959 FIXME: Checking derived types is disabled. */
6960 for (p = code->ext.alloc.list; p; p = p->next)
6963 if ((pe->ref && pe->ref->type != REF_COMPONENT)
6964 && (pe->symtree->n.sym->ts.type != BT_DERIVED))
6966 for (q = p->next; q; q = q->next)
6969 if ((qe->ref && qe->ref->type != REF_COMPONENT)
6970 && (qe->symtree->n.sym->ts.type != BT_DERIVED)
6971 && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
6972 gfc_error ("Allocate-object at %L also appears at %L",
6973 &pe->where, &qe->where);
6978 if (strcmp (fcn, "ALLOCATE") == 0)
6980 for (a = code->ext.alloc.list; a; a = a->next)
6981 resolve_allocate_expr (a->expr, code);
6985 for (a = code->ext.alloc.list; a; a = a->next)
6986 resolve_deallocate_expr (a->expr);
6991 /************ SELECT CASE resolution subroutines ************/
6993 /* Callback function for our mergesort variant. Determines interval
6994 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
6995 op1 > op2. Assumes we're not dealing with the default case.
6996 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
6997 There are nine situations to check. */
7000 compare_cases (const gfc_case *op1, const gfc_case *op2)
7004 if (op1->low == NULL) /* op1 = (:L) */
7006 /* op2 = (:N), so overlap. */
7008 /* op2 = (M:) or (M:N), L < M */
7009 if (op2->low != NULL
7010 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7013 else if (op1->high == NULL) /* op1 = (K:) */
7015 /* op2 = (M:), so overlap. */
7017 /* op2 = (:N) or (M:N), K > N */
7018 if (op2->high != NULL
7019 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7022 else /* op1 = (K:L) */
7024 if (op2->low == NULL) /* op2 = (:N), K > N */
7025 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7027 else if (op2->high == NULL) /* op2 = (M:), L < M */
7028 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7030 else /* op2 = (M:N) */
7034 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7037 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7046 /* Merge-sort a double linked case list, detecting overlap in the
7047 process. LIST is the head of the double linked case list before it
7048 is sorted. Returns the head of the sorted list if we don't see any
7049 overlap, or NULL otherwise. */
7052 check_case_overlap (gfc_case *list)
7054 gfc_case *p, *q, *e, *tail;
7055 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7057 /* If the passed list was empty, return immediately. */
7064 /* Loop unconditionally. The only exit from this loop is a return
7065 statement, when we've finished sorting the case list. */
7072 /* Count the number of merges we do in this pass. */
7075 /* Loop while there exists a merge to be done. */
7080 /* Count this merge. */
7083 /* Cut the list in two pieces by stepping INSIZE places
7084 forward in the list, starting from P. */
7087 for (i = 0; i < insize; i++)
7096 /* Now we have two lists. Merge them! */
7097 while (psize > 0 || (qsize > 0 && q != NULL))
7099 /* See from which the next case to merge comes from. */
7102 /* P is empty so the next case must come from Q. */
7107 else if (qsize == 0 || q == NULL)
7116 cmp = compare_cases (p, q);
7119 /* The whole case range for P is less than the
7127 /* The whole case range for Q is greater than
7128 the case range for P. */
7135 /* The cases overlap, or they are the same
7136 element in the list. Either way, we must
7137 issue an error and get the next case from P. */
7138 /* FIXME: Sort P and Q by line number. */
7139 gfc_error ("CASE label at %L overlaps with CASE "
7140 "label at %L", &p->where, &q->where);
7148 /* Add the next element to the merged list. */
7157 /* P has now stepped INSIZE places along, and so has Q. So
7158 they're the same. */
7163 /* If we have done only one merge or none at all, we've
7164 finished sorting the cases. */
7173 /* Otherwise repeat, merging lists twice the size. */
7179 /* Check to see if an expression is suitable for use in a CASE statement.
7180 Makes sure that all case expressions are scalar constants of the same
7181 type. Return FAILURE if anything is wrong. */
7184 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7186 if (e == NULL) return SUCCESS;
7188 if (e->ts.type != case_expr->ts.type)
7190 gfc_error ("Expression in CASE statement at %L must be of type %s",
7191 &e->where, gfc_basic_typename (case_expr->ts.type));
7195 /* C805 (R808) For a given case-construct, each case-value shall be of
7196 the same type as case-expr. For character type, length differences
7197 are allowed, but the kind type parameters shall be the same. */
7199 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7201 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7202 &e->where, case_expr->ts.kind);
7206 /* Convert the case value kind to that of case expression kind,
7209 if (e->ts.kind != case_expr->ts.kind)
7210 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7214 gfc_error ("Expression in CASE statement at %L must be scalar",
7223 /* Given a completely parsed select statement, we:
7225 - Validate all expressions and code within the SELECT.
7226 - Make sure that the selection expression is not of the wrong type.
7227 - Make sure that no case ranges overlap.
7228 - Eliminate unreachable cases and unreachable code resulting from
7229 removing case labels.
7231 The standard does allow unreachable cases, e.g. CASE (5:3). But
7232 they are a hassle for code generation, and to prevent that, we just
7233 cut them out here. This is not necessary for overlapping cases
7234 because they are illegal and we never even try to generate code.
7236 We have the additional caveat that a SELECT construct could have
7237 been a computed GOTO in the source code. Fortunately we can fairly
7238 easily work around that here: The case_expr for a "real" SELECT CASE
7239 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7240 we have to do is make sure that the case_expr is a scalar integer
7244 resolve_select (gfc_code *code)
7247 gfc_expr *case_expr;
7248 gfc_case *cp, *default_case, *tail, *head;
7249 int seen_unreachable;
7255 if (code->expr1 == NULL)
7257 /* This was actually a computed GOTO statement. */
7258 case_expr = code->expr2;
7259 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7260 gfc_error ("Selection expression in computed GOTO statement "
7261 "at %L must be a scalar integer expression",
7264 /* Further checking is not necessary because this SELECT was built
7265 by the compiler, so it should always be OK. Just move the
7266 case_expr from expr2 to expr so that we can handle computed
7267 GOTOs as normal SELECTs from here on. */
7268 code->expr1 = code->expr2;
7273 case_expr = code->expr1;
7275 type = case_expr->ts.type;
7276 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7278 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7279 &case_expr->where, gfc_typename (&case_expr->ts));
7281 /* Punt. Going on here just produce more garbage error messages. */
7285 if (case_expr->rank != 0)
7287 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7288 "expression", &case_expr->where);
7295 /* Raise a warning if an INTEGER case value exceeds the range of
7296 the case-expr. Later, all expressions will be promoted to the
7297 largest kind of all case-labels. */
7299 if (type == BT_INTEGER)
7300 for (body = code->block; body; body = body->block)
7301 for (cp = body->ext.case_list; cp; cp = cp->next)
7304 && gfc_check_integer_range (cp->low->value.integer,
7305 case_expr->ts.kind) != ARITH_OK)
7306 gfc_warning ("Expression in CASE statement at %L is "
7307 "not in the range of %s", &cp->low->where,
7308 gfc_typename (&case_expr->ts));
7311 && cp->low != cp->high
7312 && gfc_check_integer_range (cp->high->value.integer,
7313 case_expr->ts.kind) != ARITH_OK)
7314 gfc_warning ("Expression in CASE statement at %L is "
7315 "not in the range of %s", &cp->high->where,
7316 gfc_typename (&case_expr->ts));
7319 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7320 of the SELECT CASE expression and its CASE values. Walk the lists
7321 of case values, and if we find a mismatch, promote case_expr to
7322 the appropriate kind. */
7324 if (type == BT_LOGICAL || type == BT_INTEGER)
7326 for (body = code->block; body; body = body->block)
7328 /* Walk the case label list. */
7329 for (cp = body->ext.case_list; cp; cp = cp->next)
7331 /* Intercept the DEFAULT case. It does not have a kind. */
7332 if (cp->low == NULL && cp->high == NULL)
7335 /* Unreachable case ranges are discarded, so ignore. */
7336 if (cp->low != NULL && cp->high != NULL
7337 && cp->low != cp->high
7338 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7342 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7343 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7345 if (cp->high != NULL
7346 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7347 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7352 /* Assume there is no DEFAULT case. */
7353 default_case = NULL;
7358 for (body = code->block; body; body = body->block)
7360 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7362 seen_unreachable = 0;
7364 /* Walk the case label list, making sure that all case labels
7366 for (cp = body->ext.case_list; cp; cp = cp->next)
7368 /* Count the number of cases in the whole construct. */
7371 /* Intercept the DEFAULT case. */
7372 if (cp->low == NULL && cp->high == NULL)
7374 if (default_case != NULL)
7376 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7377 "by a second DEFAULT CASE at %L",
7378 &default_case->where, &cp->where);
7389 /* Deal with single value cases and case ranges. Errors are
7390 issued from the validation function. */
7391 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7392 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7398 if (type == BT_LOGICAL
7399 && ((cp->low == NULL || cp->high == NULL)
7400 || cp->low != cp->high))
7402 gfc_error ("Logical range in CASE statement at %L is not "
7403 "allowed", &cp->low->where);
7408 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7411 value = cp->low->value.logical == 0 ? 2 : 1;
7412 if (value & seen_logical)
7414 gfc_error ("Constant logical value in CASE statement "
7415 "is repeated at %L",
7420 seen_logical |= value;
7423 if (cp->low != NULL && cp->high != NULL
7424 && cp->low != cp->high
7425 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7427 if (gfc_option.warn_surprising)
7428 gfc_warning ("Range specification at %L can never "
7429 "be matched", &cp->where);
7431 cp->unreachable = 1;
7432 seen_unreachable = 1;
7436 /* If the case range can be matched, it can also overlap with
7437 other cases. To make sure it does not, we put it in a
7438 double linked list here. We sort that with a merge sort
7439 later on to detect any overlapping cases. */
7443 head->right = head->left = NULL;
7448 tail->right->left = tail;
7455 /* It there was a failure in the previous case label, give up
7456 for this case label list. Continue with the next block. */
7460 /* See if any case labels that are unreachable have been seen.
7461 If so, we eliminate them. This is a bit of a kludge because
7462 the case lists for a single case statement (label) is a
7463 single forward linked lists. */
7464 if (seen_unreachable)
7466 /* Advance until the first case in the list is reachable. */
7467 while (body->ext.case_list != NULL
7468 && body->ext.case_list->unreachable)
7470 gfc_case *n = body->ext.case_list;
7471 body->ext.case_list = body->ext.case_list->next;
7473 gfc_free_case_list (n);
7476 /* Strip all other unreachable cases. */
7477 if (body->ext.case_list)
7479 for (cp = body->ext.case_list; cp->next; cp = cp->next)
7481 if (cp->next->unreachable)
7483 gfc_case *n = cp->next;
7484 cp->next = cp->next->next;
7486 gfc_free_case_list (n);
7493 /* See if there were overlapping cases. If the check returns NULL,
7494 there was overlap. In that case we don't do anything. If head
7495 is non-NULL, we prepend the DEFAULT case. The sorted list can
7496 then used during code generation for SELECT CASE constructs with
7497 a case expression of a CHARACTER type. */
7500 head = check_case_overlap (head);
7502 /* Prepend the default_case if it is there. */
7503 if (head != NULL && default_case)
7505 default_case->left = NULL;
7506 default_case->right = head;
7507 head->left = default_case;
7511 /* Eliminate dead blocks that may be the result if we've seen
7512 unreachable case labels for a block. */
7513 for (body = code; body && body->block; body = body->block)
7515 if (body->block->ext.case_list == NULL)
7517 /* Cut the unreachable block from the code chain. */
7518 gfc_code *c = body->block;
7519 body->block = c->block;
7521 /* Kill the dead block, but not the blocks below it. */
7523 gfc_free_statements (c);
7527 /* More than two cases is legal but insane for logical selects.
7528 Issue a warning for it. */
7529 if (gfc_option.warn_surprising && type == BT_LOGICAL
7531 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7536 /* Check if a derived type is extensible. */
7539 gfc_type_is_extensible (gfc_symbol *sym)
7541 return !(sym->attr.is_bind_c || sym->attr.sequence);
7545 /* Resolve an associate name: Resolve target and ensure the type-spec is
7546 correct as well as possibly the array-spec. */
7549 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
7553 gcc_assert (sym->assoc);
7554 gcc_assert (sym->attr.flavor == FL_VARIABLE);
7556 /* If this is for SELECT TYPE, the target may not yet be set. In that
7557 case, return. Resolution will be called later manually again when
7559 target = sym->assoc->target;
7562 gcc_assert (!sym->assoc->dangling);
7564 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
7567 /* For variable targets, we get some attributes from the target. */
7568 if (target->expr_type == EXPR_VARIABLE)
7572 gcc_assert (target->symtree);
7573 tsym = target->symtree->n.sym;
7575 sym->attr.asynchronous = tsym->attr.asynchronous;
7576 sym->attr.volatile_ = tsym->attr.volatile_;
7578 sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
7581 /* Get type if this was not already set. Note that it can be
7582 some other type than the target in case this is a SELECT TYPE
7583 selector! So we must not update when the type is already there. */
7584 if (sym->ts.type == BT_UNKNOWN)
7585 sym->ts = target->ts;
7586 gcc_assert (sym->ts.type != BT_UNKNOWN);
7588 /* See if this is a valid association-to-variable. */
7589 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
7590 && !gfc_has_vector_subscript (target));
7592 /* Finally resolve if this is an array or not. */
7593 if (sym->attr.dimension && target->rank == 0)
7595 gfc_error ("Associate-name '%s' at %L is used as array",
7596 sym->name, &sym->declared_at);
7597 sym->attr.dimension = 0;
7600 if (target->rank > 0)
7601 sym->attr.dimension = 1;
7603 if (sym->attr.dimension)
7605 sym->as = gfc_get_array_spec ();
7606 sym->as->rank = target->rank;
7607 sym->as->type = AS_DEFERRED;
7609 /* Target must not be coindexed, thus the associate-variable
7611 sym->as->corank = 0;
7616 /* Resolve a SELECT TYPE statement. */
7619 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
7621 gfc_symbol *selector_type;
7622 gfc_code *body, *new_st, *if_st, *tail;
7623 gfc_code *class_is = NULL, *default_case = NULL;
7626 char name[GFC_MAX_SYMBOL_LEN];
7630 ns = code->ext.block.ns;
7633 /* Check for F03:C813. */
7634 if (code->expr1->ts.type != BT_CLASS
7635 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
7637 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7638 "at %L", &code->loc);
7644 if (code->expr1->symtree->n.sym->attr.untyped)
7645 code->expr1->symtree->n.sym->ts = code->expr2->ts;
7646 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
7649 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
7651 /* Loop over TYPE IS / CLASS IS cases. */
7652 for (body = code->block; body; body = body->block)
7654 c = body->ext.case_list;
7656 /* Check F03:C815. */
7657 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7658 && !gfc_type_is_extensible (c->ts.u.derived))
7660 gfc_error ("Derived type '%s' at %L must be extensible",
7661 c->ts.u.derived->name, &c->where);
7666 /* Check F03:C816. */
7667 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7668 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
7670 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7671 c->ts.u.derived->name, &c->where, selector_type->name);
7676 /* Intercept the DEFAULT case. */
7677 if (c->ts.type == BT_UNKNOWN)
7679 /* Check F03:C818. */
7682 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7683 "by a second DEFAULT CASE at %L",
7684 &default_case->ext.case_list->where, &c->where);
7689 default_case = body;
7696 /* Transform SELECT TYPE statement to BLOCK and associate selector to
7697 target if present. If there are any EXIT statements referring to the
7698 SELECT TYPE construct, this is no problem because the gfc_code
7699 reference stays the same and EXIT is equally possible from the BLOCK
7700 it is changed to. */
7701 code->op = EXEC_BLOCK;
7704 gfc_association_list* assoc;
7706 assoc = gfc_get_association_list ();
7707 assoc->st = code->expr1->symtree;
7708 assoc->target = gfc_copy_expr (code->expr2);
7709 /* assoc->variable will be set by resolve_assoc_var. */
7711 code->ext.block.assoc = assoc;
7712 code->expr1->symtree->n.sym->assoc = assoc;
7714 resolve_assoc_var (code->expr1->symtree->n.sym, false);
7717 code->ext.block.assoc = NULL;
7719 /* Add EXEC_SELECT to switch on type. */
7720 new_st = gfc_get_code ();
7721 new_st->op = code->op;
7722 new_st->expr1 = code->expr1;
7723 new_st->expr2 = code->expr2;
7724 new_st->block = code->block;
7725 code->expr1 = code->expr2 = NULL;
7730 ns->code->next = new_st;
7732 code->op = EXEC_SELECT;
7733 gfc_add_component_ref (code->expr1, "$vptr");
7734 gfc_add_component_ref (code->expr1, "$hash");
7736 /* Loop over TYPE IS / CLASS IS cases. */
7737 for (body = code->block; body; body = body->block)
7739 c = body->ext.case_list;
7741 if (c->ts.type == BT_DERIVED)
7742 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7743 c->ts.u.derived->hash_value);
7745 else if (c->ts.type == BT_UNKNOWN)
7748 /* Associate temporary to selector. This should only be done
7749 when this case is actually true, so build a new ASSOCIATE
7750 that does precisely this here (instead of using the
7753 if (c->ts.type == BT_CLASS)
7754 sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
7756 sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
7757 st = gfc_find_symtree (ns->sym_root, name);
7758 gcc_assert (st->n.sym->assoc);
7759 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
7760 if (c->ts.type == BT_DERIVED)
7761 gfc_add_component_ref (st->n.sym->assoc->target, "$data");
7763 new_st = gfc_get_code ();
7764 new_st->op = EXEC_BLOCK;
7765 new_st->ext.block.ns = gfc_build_block_ns (ns);
7766 new_st->ext.block.ns->code = body->next;
7767 body->next = new_st;
7769 /* Chain in the new list only if it is marked as dangling. Otherwise
7770 there is a CASE label overlap and this is already used. Just ignore,
7771 the error is diagonsed elsewhere. */
7772 if (st->n.sym->assoc->dangling)
7774 new_st->ext.block.assoc = st->n.sym->assoc;
7775 st->n.sym->assoc->dangling = 0;
7778 resolve_assoc_var (st->n.sym, false);
7781 /* Take out CLASS IS cases for separate treatment. */
7783 while (body && body->block)
7785 if (body->block->ext.case_list->ts.type == BT_CLASS)
7787 /* Add to class_is list. */
7788 if (class_is == NULL)
7790 class_is = body->block;
7795 for (tail = class_is; tail->block; tail = tail->block) ;
7796 tail->block = body->block;
7799 /* Remove from EXEC_SELECT list. */
7800 body->block = body->block->block;
7813 /* Add a default case to hold the CLASS IS cases. */
7814 for (tail = code; tail->block; tail = tail->block) ;
7815 tail->block = gfc_get_code ();
7817 tail->op = EXEC_SELECT_TYPE;
7818 tail->ext.case_list = gfc_get_case ();
7819 tail->ext.case_list->ts.type = BT_UNKNOWN;
7821 default_case = tail;
7824 /* More than one CLASS IS block? */
7825 if (class_is->block)
7829 /* Sort CLASS IS blocks by extension level. */
7833 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
7836 /* F03:C817 (check for doubles). */
7837 if ((*c1)->ext.case_list->ts.u.derived->hash_value
7838 == c2->ext.case_list->ts.u.derived->hash_value)
7840 gfc_error ("Double CLASS IS block in SELECT TYPE "
7841 "statement at %L", &c2->ext.case_list->where);
7844 if ((*c1)->ext.case_list->ts.u.derived->attr.extension
7845 < c2->ext.case_list->ts.u.derived->attr.extension)
7848 (*c1)->block = c2->block;
7858 /* Generate IF chain. */
7859 if_st = gfc_get_code ();
7860 if_st->op = EXEC_IF;
7862 for (body = class_is; body; body = body->block)
7864 new_st->block = gfc_get_code ();
7865 new_st = new_st->block;
7866 new_st->op = EXEC_IF;
7867 /* Set up IF condition: Call _gfortran_is_extension_of. */
7868 new_st->expr1 = gfc_get_expr ();
7869 new_st->expr1->expr_type = EXPR_FUNCTION;
7870 new_st->expr1->ts.type = BT_LOGICAL;
7871 new_st->expr1->ts.kind = 4;
7872 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
7873 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
7874 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
7875 /* Set up arguments. */
7876 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
7877 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
7878 gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
7879 vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
7880 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
7881 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
7882 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
7883 new_st->next = body->next;
7885 if (default_case->next)
7887 new_st->block = gfc_get_code ();
7888 new_st = new_st->block;
7889 new_st->op = EXEC_IF;
7890 new_st->next = default_case->next;
7893 /* Replace CLASS DEFAULT code by the IF chain. */
7894 default_case->next = if_st;
7897 /* Resolve the internal code. This can not be done earlier because
7898 it requires that the sym->assoc of selectors is set already. */
7899 gfc_current_ns = ns;
7900 gfc_resolve_blocks (code->block, gfc_current_ns);
7901 gfc_current_ns = old_ns;
7903 resolve_select (code);
7907 /* Resolve a transfer statement. This is making sure that:
7908 -- a derived type being transferred has only non-pointer components
7909 -- a derived type being transferred doesn't have private components, unless
7910 it's being transferred from the module where the type was defined
7911 -- we're not trying to transfer a whole assumed size array. */
7914 resolve_transfer (gfc_code *code)
7923 while (exp != NULL && exp->expr_type == EXPR_OP
7924 && exp->value.op.op == INTRINSIC_PARENTHESES)
7925 exp = exp->value.op.op1;
7927 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
7928 && exp->expr_type != EXPR_FUNCTION))
7931 /* If we are reading, the variable will be changed. Note that
7932 code->ext.dt may be NULL if the TRANSFER is related to
7933 an INQUIRE statement -- but in this case, we are not reading, either. */
7934 if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
7935 && gfc_check_vardef_context (exp, false, _("item in READ")) == FAILURE)
7938 sym = exp->symtree->n.sym;
7941 /* Go to actual component transferred. */
7942 for (ref = code->expr1->ref; ref; ref = ref->next)
7943 if (ref->type == REF_COMPONENT)
7944 ts = &ref->u.c.component->ts;
7946 if (ts->type == BT_DERIVED)
7948 /* Check that transferred derived type doesn't contain POINTER
7950 if (ts->u.derived->attr.pointer_comp)
7952 gfc_error ("Data transfer element at %L cannot have "
7953 "POINTER components", &code->loc);
7957 if (ts->u.derived->attr.alloc_comp)
7959 gfc_error ("Data transfer element at %L cannot have "
7960 "ALLOCATABLE components", &code->loc);
7964 if (derived_inaccessible (ts->u.derived))
7966 gfc_error ("Data transfer element at %L cannot have "
7967 "PRIVATE components",&code->loc);
7972 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
7973 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
7975 gfc_error ("Data transfer element at %L cannot be a full reference to "
7976 "an assumed-size array", &code->loc);
7982 /*********** Toplevel code resolution subroutines ***********/
7984 /* Find the set of labels that are reachable from this block. We also
7985 record the last statement in each block. */
7988 find_reachable_labels (gfc_code *block)
7995 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
7997 /* Collect labels in this block. We don't keep those corresponding
7998 to END {IF|SELECT}, these are checked in resolve_branch by going
7999 up through the code_stack. */
8000 for (c = block; c; c = c->next)
8002 if (c->here && c->op != EXEC_END_BLOCK)
8003 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8006 /* Merge with labels from parent block. */
8009 gcc_assert (cs_base->prev->reachable_labels);
8010 bitmap_ior_into (cs_base->reachable_labels,
8011 cs_base->prev->reachable_labels);
8017 resolve_sync (gfc_code *code)
8019 /* Check imageset. The * case matches expr1 == NULL. */
8022 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8023 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8024 "INTEGER expression", &code->expr1->where);
8025 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8026 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8027 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8028 &code->expr1->where);
8029 else if (code->expr1->expr_type == EXPR_ARRAY
8030 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8032 gfc_constructor *cons;
8033 cons = gfc_constructor_first (code->expr1->value.constructor);
8034 for (; cons; cons = gfc_constructor_next (cons))
8035 if (cons->expr->expr_type == EXPR_CONSTANT
8036 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8037 gfc_error ("Imageset argument at %L must between 1 and "
8038 "num_images()", &cons->expr->where);
8044 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8045 || code->expr2->expr_type != EXPR_VARIABLE))
8046 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8047 &code->expr2->where);
8051 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8052 || code->expr3->expr_type != EXPR_VARIABLE))
8053 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8054 &code->expr3->where);
8058 /* Given a branch to a label, see if the branch is conforming.
8059 The code node describes where the branch is located. */
8062 resolve_branch (gfc_st_label *label, gfc_code *code)
8069 /* Step one: is this a valid branching target? */
8071 if (label->defined == ST_LABEL_UNKNOWN)
8073 gfc_error ("Label %d referenced at %L is never defined", label->value,
8078 if (label->defined != ST_LABEL_TARGET)
8080 gfc_error ("Statement at %L is not a valid branch target statement "
8081 "for the branch statement at %L", &label->where, &code->loc);
8085 /* Step two: make sure this branch is not a branch to itself ;-) */
8087 if (code->here == label)
8089 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8093 /* Step three: See if the label is in the same block as the
8094 branching statement. The hard work has been done by setting up
8095 the bitmap reachable_labels. */
8097 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8099 /* Check now whether there is a CRITICAL construct; if so, check
8100 whether the label is still visible outside of the CRITICAL block,
8101 which is invalid. */
8102 for (stack = cs_base; stack; stack = stack->prev)
8103 if (stack->current->op == EXEC_CRITICAL
8104 && bitmap_bit_p (stack->reachable_labels, label->value))
8105 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8106 " at %L", &code->loc, &label->where);
8111 /* Step four: If we haven't found the label in the bitmap, it may
8112 still be the label of the END of the enclosing block, in which
8113 case we find it by going up the code_stack. */
8115 for (stack = cs_base; stack; stack = stack->prev)
8117 if (stack->current->next && stack->current->next->here == label)
8119 if (stack->current->op == EXEC_CRITICAL)
8121 /* Note: A label at END CRITICAL does not leave the CRITICAL
8122 construct as END CRITICAL is still part of it. */
8123 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8124 " at %L", &code->loc, &label->where);
8131 gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
8135 /* The label is not in an enclosing block, so illegal. This was
8136 allowed in Fortran 66, so we allow it as extension. No
8137 further checks are necessary in this case. */
8138 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
8139 "as the GOTO statement at %L", &label->where,
8145 /* Check whether EXPR1 has the same shape as EXPR2. */
8148 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
8150 mpz_t shape[GFC_MAX_DIMENSIONS];
8151 mpz_t shape2[GFC_MAX_DIMENSIONS];
8152 gfc_try result = FAILURE;
8155 /* Compare the rank. */
8156 if (expr1->rank != expr2->rank)
8159 /* Compare the size of each dimension. */
8160 for (i=0; i<expr1->rank; i++)
8162 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
8165 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
8168 if (mpz_cmp (shape[i], shape2[i]))
8172 /* When either of the two expression is an assumed size array, we
8173 ignore the comparison of dimension sizes. */
8178 for (i--; i >= 0; i--)
8180 mpz_clear (shape[i]);
8181 mpz_clear (shape2[i]);
8187 /* Check whether a WHERE assignment target or a WHERE mask expression
8188 has the same shape as the outmost WHERE mask expression. */
8191 resolve_where (gfc_code *code, gfc_expr *mask)
8197 cblock = code->block;
8199 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8200 In case of nested WHERE, only the outmost one is stored. */
8201 if (mask == NULL) /* outmost WHERE */
8203 else /* inner WHERE */
8210 /* Check if the mask-expr has a consistent shape with the
8211 outmost WHERE mask-expr. */
8212 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8213 gfc_error ("WHERE mask at %L has inconsistent shape",
8214 &cblock->expr1->where);
8217 /* the assignment statement of a WHERE statement, or the first
8218 statement in where-body-construct of a WHERE construct */
8219 cnext = cblock->next;
8224 /* WHERE assignment statement */
8227 /* Check shape consistent for WHERE assignment target. */
8228 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8229 gfc_error ("WHERE assignment target at %L has "
8230 "inconsistent shape", &cnext->expr1->where);
8234 case EXEC_ASSIGN_CALL:
8235 resolve_call (cnext);
8236 if (!cnext->resolved_sym->attr.elemental)
8237 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8238 &cnext->ext.actual->expr->where);
8241 /* WHERE or WHERE construct is part of a where-body-construct */
8243 resolve_where (cnext, e);
8247 gfc_error ("Unsupported statement inside WHERE at %L",
8250 /* the next statement within the same where-body-construct */
8251 cnext = cnext->next;
8253 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8254 cblock = cblock->block;
8259 /* Resolve assignment in FORALL construct.
8260 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8261 FORALL index variables. */
8264 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8268 for (n = 0; n < nvar; n++)
8270 gfc_symbol *forall_index;
8272 forall_index = var_expr[n]->symtree->n.sym;
8274 /* Check whether the assignment target is one of the FORALL index
8276 if ((code->expr1->expr_type == EXPR_VARIABLE)
8277 && (code->expr1->symtree->n.sym == forall_index))
8278 gfc_error ("Assignment to a FORALL index variable at %L",
8279 &code->expr1->where);
8282 /* If one of the FORALL index variables doesn't appear in the
8283 assignment variable, then there could be a many-to-one
8284 assignment. Emit a warning rather than an error because the
8285 mask could be resolving this problem. */
8286 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8287 gfc_warning ("The FORALL with index '%s' is not used on the "
8288 "left side of the assignment at %L and so might "
8289 "cause multiple assignment to this object",
8290 var_expr[n]->symtree->name, &code->expr1->where);
8296 /* Resolve WHERE statement in FORALL construct. */
8299 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8300 gfc_expr **var_expr)
8305 cblock = code->block;
8308 /* the assignment statement of a WHERE statement, or the first
8309 statement in where-body-construct of a WHERE construct */
8310 cnext = cblock->next;
8315 /* WHERE assignment statement */
8317 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8320 /* WHERE operator assignment statement */
8321 case EXEC_ASSIGN_CALL:
8322 resolve_call (cnext);
8323 if (!cnext->resolved_sym->attr.elemental)
8324 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8325 &cnext->ext.actual->expr->where);
8328 /* WHERE or WHERE construct is part of a where-body-construct */
8330 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8334 gfc_error ("Unsupported statement inside WHERE at %L",
8337 /* the next statement within the same where-body-construct */
8338 cnext = cnext->next;
8340 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8341 cblock = cblock->block;
8346 /* Traverse the FORALL body to check whether the following errors exist:
8347 1. For assignment, check if a many-to-one assignment happens.
8348 2. For WHERE statement, check the WHERE body to see if there is any
8349 many-to-one assignment. */
8352 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8356 c = code->block->next;
8362 case EXEC_POINTER_ASSIGN:
8363 gfc_resolve_assign_in_forall (c, nvar, var_expr);
8366 case EXEC_ASSIGN_CALL:
8370 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8371 there is no need to handle it here. */
8375 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8380 /* The next statement in the FORALL body. */
8386 /* Counts the number of iterators needed inside a forall construct, including
8387 nested forall constructs. This is used to allocate the needed memory
8388 in gfc_resolve_forall. */
8391 gfc_count_forall_iterators (gfc_code *code)
8393 int max_iters, sub_iters, current_iters;
8394 gfc_forall_iterator *fa;
8396 gcc_assert(code->op == EXEC_FORALL);
8400 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8403 code = code->block->next;
8407 if (code->op == EXEC_FORALL)
8409 sub_iters = gfc_count_forall_iterators (code);
8410 if (sub_iters > max_iters)
8411 max_iters = sub_iters;
8416 return current_iters + max_iters;
8420 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8421 gfc_resolve_forall_body to resolve the FORALL body. */
8424 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8426 static gfc_expr **var_expr;
8427 static int total_var = 0;
8428 static int nvar = 0;
8430 gfc_forall_iterator *fa;
8435 /* Start to resolve a FORALL construct */
8436 if (forall_save == 0)
8438 /* Count the total number of FORALL index in the nested FORALL
8439 construct in order to allocate the VAR_EXPR with proper size. */
8440 total_var = gfc_count_forall_iterators (code);
8442 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8443 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
8446 /* The information about FORALL iterator, including FORALL index start, end
8447 and stride. The FORALL index can not appear in start, end or stride. */
8448 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8450 /* Check if any outer FORALL index name is the same as the current
8452 for (i = 0; i < nvar; i++)
8454 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8456 gfc_error ("An outer FORALL construct already has an index "
8457 "with this name %L", &fa->var->where);
8461 /* Record the current FORALL index. */
8462 var_expr[nvar] = gfc_copy_expr (fa->var);
8466 /* No memory leak. */
8467 gcc_assert (nvar <= total_var);
8470 /* Resolve the FORALL body. */
8471 gfc_resolve_forall_body (code, nvar, var_expr);
8473 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8474 gfc_resolve_blocks (code->block, ns);
8478 /* Free only the VAR_EXPRs allocated in this frame. */
8479 for (i = nvar; i < tmp; i++)
8480 gfc_free_expr (var_expr[i]);
8484 /* We are in the outermost FORALL construct. */
8485 gcc_assert (forall_save == 0);
8487 /* VAR_EXPR is not needed any more. */
8488 gfc_free (var_expr);
8494 /* Resolve a BLOCK construct statement. */
8497 resolve_block_construct (gfc_code* code)
8499 /* Resolve the BLOCK's namespace. */
8500 gfc_resolve (code->ext.block.ns);
8502 /* For an ASSOCIATE block, the associations (and their targets) are already
8503 resolved during resolve_symbol. */
8507 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8510 static void resolve_code (gfc_code *, gfc_namespace *);
8513 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8517 for (; b; b = b->block)
8519 t = gfc_resolve_expr (b->expr1);
8520 if (gfc_resolve_expr (b->expr2) == FAILURE)
8526 if (t == SUCCESS && b->expr1 != NULL
8527 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
8528 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8535 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
8536 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8541 resolve_branch (b->label1, b);
8545 resolve_block_construct (b);
8549 case EXEC_SELECT_TYPE:
8560 case EXEC_OMP_ATOMIC:
8561 case EXEC_OMP_CRITICAL:
8563 case EXEC_OMP_MASTER:
8564 case EXEC_OMP_ORDERED:
8565 case EXEC_OMP_PARALLEL:
8566 case EXEC_OMP_PARALLEL_DO:
8567 case EXEC_OMP_PARALLEL_SECTIONS:
8568 case EXEC_OMP_PARALLEL_WORKSHARE:
8569 case EXEC_OMP_SECTIONS:
8570 case EXEC_OMP_SINGLE:
8572 case EXEC_OMP_TASKWAIT:
8573 case EXEC_OMP_WORKSHARE:
8577 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
8580 resolve_code (b->next, ns);
8585 /* Does everything to resolve an ordinary assignment. Returns true
8586 if this is an interface assignment. */
8588 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
8598 if (gfc_extend_assign (code, ns) == SUCCESS)
8602 if (code->op == EXEC_ASSIGN_CALL)
8604 lhs = code->ext.actual->expr;
8605 rhsptr = &code->ext.actual->next->expr;
8609 gfc_actual_arglist* args;
8610 gfc_typebound_proc* tbp;
8612 gcc_assert (code->op == EXEC_COMPCALL);
8614 args = code->expr1->value.compcall.actual;
8616 rhsptr = &args->next->expr;
8618 tbp = code->expr1->value.compcall.tbp;
8619 gcc_assert (!tbp->is_generic);
8622 /* Make a temporary rhs when there is a default initializer
8623 and rhs is the same symbol as the lhs. */
8624 if ((*rhsptr)->expr_type == EXPR_VARIABLE
8625 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
8626 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
8627 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
8628 *rhsptr = gfc_get_parentheses (*rhsptr);
8637 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
8638 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
8639 &code->loc) == FAILURE)
8642 /* Handle the case of a BOZ literal on the RHS. */
8643 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
8646 if (gfc_option.warn_surprising)
8647 gfc_warning ("BOZ literal at %L is bitwise transferred "
8648 "non-integer symbol '%s'", &code->loc,
8649 lhs->symtree->n.sym->name);
8651 if (!gfc_convert_boz (rhs, &lhs->ts))
8653 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
8655 if (rc == ARITH_UNDERFLOW)
8656 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
8657 ". This check can be disabled with the option "
8658 "-fno-range-check", &rhs->where);
8659 else if (rc == ARITH_OVERFLOW)
8660 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
8661 ". This check can be disabled with the option "
8662 "-fno-range-check", &rhs->where);
8663 else if (rc == ARITH_NAN)
8664 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
8665 ". This check can be disabled with the option "
8666 "-fno-range-check", &rhs->where);
8671 if (lhs->ts.type == BT_CHARACTER
8672 && gfc_option.warn_character_truncation)
8674 if (lhs->ts.u.cl != NULL
8675 && lhs->ts.u.cl->length != NULL
8676 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8677 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
8679 if (rhs->expr_type == EXPR_CONSTANT)
8680 rlen = rhs->value.character.length;
8682 else if (rhs->ts.u.cl != NULL
8683 && rhs->ts.u.cl->length != NULL
8684 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8685 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
8687 if (rlen && llen && rlen > llen)
8688 gfc_warning_now ("CHARACTER expression will be truncated "
8689 "in assignment (%d/%d) at %L",
8690 llen, rlen, &code->loc);
8693 /* Ensure that a vector index expression for the lvalue is evaluated
8694 to a temporary if the lvalue symbol is referenced in it. */
8697 for (ref = lhs->ref; ref; ref= ref->next)
8698 if (ref->type == REF_ARRAY)
8700 for (n = 0; n < ref->u.ar.dimen; n++)
8701 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
8702 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
8703 ref->u.ar.start[n]))
8705 = gfc_get_parentheses (ref->u.ar.start[n]);
8709 if (gfc_pure (NULL))
8711 if (lhs->ts.type == BT_DERIVED
8712 && lhs->expr_type == EXPR_VARIABLE
8713 && lhs->ts.u.derived->attr.pointer_comp
8714 && rhs->expr_type == EXPR_VARIABLE
8715 && (gfc_impure_variable (rhs->symtree->n.sym)
8716 || gfc_is_coindexed (rhs)))
8719 if (gfc_is_coindexed (rhs))
8720 gfc_error ("Coindexed expression at %L is assigned to "
8721 "a derived type variable with a POINTER "
8722 "component in a PURE procedure",
8725 gfc_error ("The impure variable at %L is assigned to "
8726 "a derived type variable with a POINTER "
8727 "component in a PURE procedure (12.6)",
8732 /* Fortran 2008, C1283. */
8733 if (gfc_is_coindexed (lhs))
8735 gfc_error ("Assignment to coindexed variable at %L in a PURE "
8736 "procedure", &rhs->where);
8742 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
8743 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
8744 if (lhs->ts.type == BT_CLASS)
8746 gfc_error ("Variable must not be polymorphic in assignment at %L",
8751 /* F2008, Section 7.2.1.2. */
8752 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
8754 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
8755 "component in assignment at %L", &lhs->where);
8759 gfc_check_assign (lhs, rhs, 1);
8764 /* Given a block of code, recursively resolve everything pointed to by this
8768 resolve_code (gfc_code *code, gfc_namespace *ns)
8770 int omp_workshare_save;
8775 frame.prev = cs_base;
8779 find_reachable_labels (code);
8781 for (; code; code = code->next)
8783 frame.current = code;
8784 forall_save = forall_flag;
8786 if (code->op == EXEC_FORALL)
8789 gfc_resolve_forall (code, ns, forall_save);
8792 else if (code->block)
8794 omp_workshare_save = -1;
8797 case EXEC_OMP_PARALLEL_WORKSHARE:
8798 omp_workshare_save = omp_workshare_flag;
8799 omp_workshare_flag = 1;
8800 gfc_resolve_omp_parallel_blocks (code, ns);
8802 case EXEC_OMP_PARALLEL:
8803 case EXEC_OMP_PARALLEL_DO:
8804 case EXEC_OMP_PARALLEL_SECTIONS:
8806 omp_workshare_save = omp_workshare_flag;
8807 omp_workshare_flag = 0;
8808 gfc_resolve_omp_parallel_blocks (code, ns);
8811 gfc_resolve_omp_do_blocks (code, ns);
8813 case EXEC_SELECT_TYPE:
8814 /* Blocks are handled in resolve_select_type because we have
8815 to transform the SELECT TYPE into ASSOCIATE first. */
8817 case EXEC_OMP_WORKSHARE:
8818 omp_workshare_save = omp_workshare_flag;
8819 omp_workshare_flag = 1;
8822 gfc_resolve_blocks (code->block, ns);
8826 if (omp_workshare_save != -1)
8827 omp_workshare_flag = omp_workshare_save;
8831 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
8832 t = gfc_resolve_expr (code->expr1);
8833 forall_flag = forall_save;
8835 if (gfc_resolve_expr (code->expr2) == FAILURE)
8838 if (code->op == EXEC_ALLOCATE
8839 && gfc_resolve_expr (code->expr3) == FAILURE)
8845 case EXEC_END_BLOCK:
8849 case EXEC_ERROR_STOP:
8853 case EXEC_ASSIGN_CALL:
8858 case EXEC_SYNC_IMAGES:
8859 case EXEC_SYNC_MEMORY:
8860 resolve_sync (code);
8864 /* Keep track of which entry we are up to. */
8865 current_entry_id = code->ext.entry->id;
8869 resolve_where (code, NULL);
8873 if (code->expr1 != NULL)
8875 if (code->expr1->ts.type != BT_INTEGER)
8876 gfc_error ("ASSIGNED GOTO statement at %L requires an "
8877 "INTEGER variable", &code->expr1->where);
8878 else if (code->expr1->symtree->n.sym->attr.assign != 1)
8879 gfc_error ("Variable '%s' has not been assigned a target "
8880 "label at %L", code->expr1->symtree->n.sym->name,
8881 &code->expr1->where);
8884 resolve_branch (code->label1, code);
8888 if (code->expr1 != NULL
8889 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
8890 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
8891 "INTEGER return specifier", &code->expr1->where);
8894 case EXEC_INIT_ASSIGN:
8895 case EXEC_END_PROCEDURE:
8902 if (gfc_check_vardef_context (code->expr1, false, _("assignment"))
8906 if (resolve_ordinary_assign (code, ns))
8908 if (code->op == EXEC_COMPCALL)
8915 case EXEC_LABEL_ASSIGN:
8916 if (code->label1->defined == ST_LABEL_UNKNOWN)
8917 gfc_error ("Label %d referenced at %L is never defined",
8918 code->label1->value, &code->label1->where);
8920 && (code->expr1->expr_type != EXPR_VARIABLE
8921 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
8922 || code->expr1->symtree->n.sym->ts.kind
8923 != gfc_default_integer_kind
8924 || code->expr1->symtree->n.sym->as != NULL))
8925 gfc_error ("ASSIGN statement at %L requires a scalar "
8926 "default INTEGER variable", &code->expr1->where);
8929 case EXEC_POINTER_ASSIGN:
8936 /* This is both a variable definition and pointer assignment
8937 context, so check both of them. For rank remapping, a final
8938 array ref may be present on the LHS and fool gfc_expr_attr
8939 used in gfc_check_vardef_context. Remove it. */
8940 e = remove_last_array_ref (code->expr1);
8941 t = gfc_check_vardef_context (e, true, _("pointer assignment"));
8943 t = gfc_check_vardef_context (e, false, _("pointer assignment"));
8948 gfc_check_pointer_assign (code->expr1, code->expr2);
8952 case EXEC_ARITHMETIC_IF:
8954 && code->expr1->ts.type != BT_INTEGER
8955 && code->expr1->ts.type != BT_REAL)
8956 gfc_error ("Arithmetic IF statement at %L requires a numeric "
8957 "expression", &code->expr1->where);
8959 resolve_branch (code->label1, code);
8960 resolve_branch (code->label2, code);
8961 resolve_branch (code->label3, code);
8965 if (t == SUCCESS && code->expr1 != NULL
8966 && (code->expr1->ts.type != BT_LOGICAL
8967 || code->expr1->rank != 0))
8968 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8969 &code->expr1->where);
8974 resolve_call (code);
8979 resolve_typebound_subroutine (code);
8983 resolve_ppc_call (code);
8987 /* Select is complicated. Also, a SELECT construct could be
8988 a transformed computed GOTO. */
8989 resolve_select (code);
8992 case EXEC_SELECT_TYPE:
8993 resolve_select_type (code, ns);
8997 resolve_block_construct (code);
9001 if (code->ext.iterator != NULL)
9003 gfc_iterator *iter = code->ext.iterator;
9004 if (gfc_resolve_iterator (iter, true) != FAILURE)
9005 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
9010 if (code->expr1 == NULL)
9011 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9013 && (code->expr1->rank != 0
9014 || code->expr1->ts.type != BT_LOGICAL))
9015 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9016 "a scalar LOGICAL expression", &code->expr1->where);
9021 resolve_allocate_deallocate (code, "ALLOCATE");
9025 case EXEC_DEALLOCATE:
9027 resolve_allocate_deallocate (code, "DEALLOCATE");
9032 if (gfc_resolve_open (code->ext.open) == FAILURE)
9035 resolve_branch (code->ext.open->err, code);
9039 if (gfc_resolve_close (code->ext.close) == FAILURE)
9042 resolve_branch (code->ext.close->err, code);
9045 case EXEC_BACKSPACE:
9049 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
9052 resolve_branch (code->ext.filepos->err, code);
9056 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9059 resolve_branch (code->ext.inquire->err, code);
9063 gcc_assert (code->ext.inquire != NULL);
9064 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9067 resolve_branch (code->ext.inquire->err, code);
9071 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
9074 resolve_branch (code->ext.wait->err, code);
9075 resolve_branch (code->ext.wait->end, code);
9076 resolve_branch (code->ext.wait->eor, code);
9081 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
9084 resolve_branch (code->ext.dt->err, code);
9085 resolve_branch (code->ext.dt->end, code);
9086 resolve_branch (code->ext.dt->eor, code);
9090 resolve_transfer (code);
9094 resolve_forall_iterators (code->ext.forall_iterator);
9096 if (code->expr1 != NULL && code->expr1->ts.type != BT_LOGICAL)
9097 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
9098 "expression", &code->expr1->where);
9101 case EXEC_OMP_ATOMIC:
9102 case EXEC_OMP_BARRIER:
9103 case EXEC_OMP_CRITICAL:
9104 case EXEC_OMP_FLUSH:
9106 case EXEC_OMP_MASTER:
9107 case EXEC_OMP_ORDERED:
9108 case EXEC_OMP_SECTIONS:
9109 case EXEC_OMP_SINGLE:
9110 case EXEC_OMP_TASKWAIT:
9111 case EXEC_OMP_WORKSHARE:
9112 gfc_resolve_omp_directive (code, ns);
9115 case EXEC_OMP_PARALLEL:
9116 case EXEC_OMP_PARALLEL_DO:
9117 case EXEC_OMP_PARALLEL_SECTIONS:
9118 case EXEC_OMP_PARALLEL_WORKSHARE:
9120 omp_workshare_save = omp_workshare_flag;
9121 omp_workshare_flag = 0;
9122 gfc_resolve_omp_directive (code, ns);
9123 omp_workshare_flag = omp_workshare_save;
9127 gfc_internal_error ("resolve_code(): Bad statement code");
9131 cs_base = frame.prev;
9135 /* Resolve initial values and make sure they are compatible with
9139 resolve_values (gfc_symbol *sym)
9143 if (sym->value == NULL)
9146 if (sym->value->expr_type == EXPR_STRUCTURE)
9147 t= resolve_structure_cons (sym->value, 1);
9149 t = gfc_resolve_expr (sym->value);
9154 gfc_check_assign_symbol (sym, sym->value);
9158 /* Verify the binding labels for common blocks that are BIND(C). The label
9159 for a BIND(C) common block must be identical in all scoping units in which
9160 the common block is declared. Further, the binding label can not collide
9161 with any other global entity in the program. */
9164 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
9166 if (comm_block_tree->n.common->is_bind_c == 1)
9168 gfc_gsymbol *binding_label_gsym;
9169 gfc_gsymbol *comm_name_gsym;
9171 /* See if a global symbol exists by the common block's name. It may
9172 be NULL if the common block is use-associated. */
9173 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
9174 comm_block_tree->n.common->name);
9175 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
9176 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9177 "with the global entity '%s' at %L",
9178 comm_block_tree->n.common->binding_label,
9179 comm_block_tree->n.common->name,
9180 &(comm_block_tree->n.common->where),
9181 comm_name_gsym->name, &(comm_name_gsym->where));
9182 else if (comm_name_gsym != NULL
9183 && strcmp (comm_name_gsym->name,
9184 comm_block_tree->n.common->name) == 0)
9186 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9188 if (comm_name_gsym->binding_label == NULL)
9189 /* No binding label for common block stored yet; save this one. */
9190 comm_name_gsym->binding_label =
9191 comm_block_tree->n.common->binding_label;
9193 if (strcmp (comm_name_gsym->binding_label,
9194 comm_block_tree->n.common->binding_label) != 0)
9196 /* Common block names match but binding labels do not. */
9197 gfc_error ("Binding label '%s' for common block '%s' at %L "
9198 "does not match the binding label '%s' for common "
9200 comm_block_tree->n.common->binding_label,
9201 comm_block_tree->n.common->name,
9202 &(comm_block_tree->n.common->where),
9203 comm_name_gsym->binding_label,
9204 comm_name_gsym->name,
9205 &(comm_name_gsym->where));
9210 /* There is no binding label (NAME="") so we have nothing further to
9211 check and nothing to add as a global symbol for the label. */
9212 if (comm_block_tree->n.common->binding_label[0] == '\0' )
9215 binding_label_gsym =
9216 gfc_find_gsymbol (gfc_gsym_root,
9217 comm_block_tree->n.common->binding_label);
9218 if (binding_label_gsym == NULL)
9220 /* Need to make a global symbol for the binding label to prevent
9221 it from colliding with another. */
9222 binding_label_gsym =
9223 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9224 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9225 binding_label_gsym->type = GSYM_COMMON;
9229 /* If comm_name_gsym is NULL, the name common block is use
9230 associated and the name could be colliding. */
9231 if (binding_label_gsym->type != GSYM_COMMON)
9232 gfc_error ("Binding label '%s' for common block '%s' at %L "
9233 "collides with the global entity '%s' at %L",
9234 comm_block_tree->n.common->binding_label,
9235 comm_block_tree->n.common->name,
9236 &(comm_block_tree->n.common->where),
9237 binding_label_gsym->name,
9238 &(binding_label_gsym->where));
9239 else if (comm_name_gsym != NULL
9240 && (strcmp (binding_label_gsym->name,
9241 comm_name_gsym->binding_label) != 0)
9242 && (strcmp (binding_label_gsym->sym_name,
9243 comm_name_gsym->name) != 0))
9244 gfc_error ("Binding label '%s' for common block '%s' at %L "
9245 "collides with global entity '%s' at %L",
9246 binding_label_gsym->name, binding_label_gsym->sym_name,
9247 &(comm_block_tree->n.common->where),
9248 comm_name_gsym->name, &(comm_name_gsym->where));
9256 /* Verify any BIND(C) derived types in the namespace so we can report errors
9257 for them once, rather than for each variable declared of that type. */
9260 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9262 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9263 && derived_sym->attr.is_bind_c == 1)
9264 verify_bind_c_derived_type (derived_sym);
9270 /* Verify that any binding labels used in a given namespace do not collide
9271 with the names or binding labels of any global symbols. */
9274 gfc_verify_binding_labels (gfc_symbol *sym)
9278 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9279 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
9281 gfc_gsymbol *bind_c_sym;
9283 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9284 if (bind_c_sym != NULL
9285 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9287 if (sym->attr.if_source == IFSRC_DECL
9288 && (bind_c_sym->type != GSYM_SUBROUTINE
9289 && bind_c_sym->type != GSYM_FUNCTION)
9290 && ((sym->attr.contained == 1
9291 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9292 || (sym->attr.use_assoc == 1
9293 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9295 /* Make sure global procedures don't collide with anything. */
9296 gfc_error ("Binding label '%s' at %L collides with the global "
9297 "entity '%s' at %L", sym->binding_label,
9298 &(sym->declared_at), bind_c_sym->name,
9299 &(bind_c_sym->where));
9302 else if (sym->attr.contained == 0
9303 && (sym->attr.if_source == IFSRC_IFBODY
9304 && sym->attr.flavor == FL_PROCEDURE)
9305 && (bind_c_sym->sym_name != NULL
9306 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9308 /* Make sure procedures in interface bodies don't collide. */
9309 gfc_error ("Binding label '%s' in interface body at %L collides "
9310 "with the global entity '%s' at %L",
9312 &(sym->declared_at), bind_c_sym->name,
9313 &(bind_c_sym->where));
9316 else if (sym->attr.contained == 0
9317 && sym->attr.if_source == IFSRC_UNKNOWN)
9318 if ((sym->attr.use_assoc && bind_c_sym->mod_name
9319 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9320 || sym->attr.use_assoc == 0)
9322 gfc_error ("Binding label '%s' at %L collides with global "
9323 "entity '%s' at %L", sym->binding_label,
9324 &(sym->declared_at), bind_c_sym->name,
9325 &(bind_c_sym->where));
9330 /* Clear the binding label to prevent checking multiple times. */
9331 sym->binding_label[0] = '\0';
9333 else if (bind_c_sym == NULL)
9335 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9336 bind_c_sym->where = sym->declared_at;
9337 bind_c_sym->sym_name = sym->name;
9339 if (sym->attr.use_assoc == 1)
9340 bind_c_sym->mod_name = sym->module;
9342 if (sym->ns->proc_name != NULL)
9343 bind_c_sym->mod_name = sym->ns->proc_name->name;
9345 if (sym->attr.contained == 0)
9347 if (sym->attr.subroutine)
9348 bind_c_sym->type = GSYM_SUBROUTINE;
9349 else if (sym->attr.function)
9350 bind_c_sym->type = GSYM_FUNCTION;
9358 /* Resolve an index expression. */
9361 resolve_index_expr (gfc_expr *e)
9363 if (gfc_resolve_expr (e) == FAILURE)
9366 if (gfc_simplify_expr (e, 0) == FAILURE)
9369 if (gfc_specification_expr (e) == FAILURE)
9375 /* Resolve a charlen structure. */
9378 resolve_charlen (gfc_charlen *cl)
9387 specification_expr = 1;
9389 if (resolve_index_expr (cl->length) == FAILURE)
9391 specification_expr = 0;
9395 /* "If the character length parameter value evaluates to a negative
9396 value, the length of character entities declared is zero." */
9397 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9399 if (gfc_option.warn_surprising)
9400 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9401 " the length has been set to zero",
9402 &cl->length->where, i);
9403 gfc_replace_expr (cl->length,
9404 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9407 /* Check that the character length is not too large. */
9408 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9409 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9410 && cl->length->ts.type == BT_INTEGER
9411 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9413 gfc_error ("String length at %L is too large", &cl->length->where);
9421 /* Test for non-constant shape arrays. */
9424 is_non_constant_shape_array (gfc_symbol *sym)
9430 not_constant = false;
9431 if (sym->as != NULL)
9433 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9434 has not been simplified; parameter array references. Do the
9435 simplification now. */
9436 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9438 e = sym->as->lower[i];
9439 if (e && (resolve_index_expr (e) == FAILURE
9440 || !gfc_is_constant_expr (e)))
9441 not_constant = true;
9442 e = sym->as->upper[i];
9443 if (e && (resolve_index_expr (e) == FAILURE
9444 || !gfc_is_constant_expr (e)))
9445 not_constant = true;
9448 return not_constant;
9451 /* Given a symbol and an initialization expression, add code to initialize
9452 the symbol to the function entry. */
9454 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9458 gfc_namespace *ns = sym->ns;
9460 /* Search for the function namespace if this is a contained
9461 function without an explicit result. */
9462 if (sym->attr.function && sym == sym->result
9463 && sym->name != sym->ns->proc_name->name)
9466 for (;ns; ns = ns->sibling)
9467 if (strcmp (ns->proc_name->name, sym->name) == 0)
9473 gfc_free_expr (init);
9477 /* Build an l-value expression for the result. */
9478 lval = gfc_lval_expr_from_sym (sym);
9480 /* Add the code at scope entry. */
9481 init_st = gfc_get_code ();
9482 init_st->next = ns->code;
9485 /* Assign the default initializer to the l-value. */
9486 init_st->loc = sym->declared_at;
9487 init_st->op = EXEC_INIT_ASSIGN;
9488 init_st->expr1 = lval;
9489 init_st->expr2 = init;
9492 /* Assign the default initializer to a derived type variable or result. */
9495 apply_default_init (gfc_symbol *sym)
9497 gfc_expr *init = NULL;
9499 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9502 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
9503 init = gfc_default_initializer (&sym->ts);
9505 if (init == NULL && sym->ts.type != BT_CLASS)
9508 build_init_assign (sym, init);
9509 sym->attr.referenced = 1;
9512 /* Build an initializer for a local integer, real, complex, logical, or
9513 character variable, based on the command line flags finit-local-zero,
9514 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
9515 null if the symbol should not have a default initialization. */
9517 build_default_init_expr (gfc_symbol *sym)
9520 gfc_expr *init_expr;
9523 /* These symbols should never have a default initialization. */
9524 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
9525 || sym->attr.external
9527 || sym->attr.pointer
9528 || sym->attr.in_equivalence
9529 || sym->attr.in_common
9532 || sym->attr.cray_pointee
9533 || sym->attr.cray_pointer)
9536 /* Now we'll try to build an initializer expression. */
9537 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
9540 /* We will only initialize integers, reals, complex, logicals, and
9541 characters, and only if the corresponding command-line flags
9542 were set. Otherwise, we free init_expr and return null. */
9543 switch (sym->ts.type)
9546 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
9547 mpz_set_si (init_expr->value.integer,
9548 gfc_option.flag_init_integer_value);
9551 gfc_free_expr (init_expr);
9557 switch (gfc_option.flag_init_real)
9559 case GFC_INIT_REAL_SNAN:
9560 init_expr->is_snan = 1;
9562 case GFC_INIT_REAL_NAN:
9563 mpfr_set_nan (init_expr->value.real);
9566 case GFC_INIT_REAL_INF:
9567 mpfr_set_inf (init_expr->value.real, 1);
9570 case GFC_INIT_REAL_NEG_INF:
9571 mpfr_set_inf (init_expr->value.real, -1);
9574 case GFC_INIT_REAL_ZERO:
9575 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
9579 gfc_free_expr (init_expr);
9586 switch (gfc_option.flag_init_real)
9588 case GFC_INIT_REAL_SNAN:
9589 init_expr->is_snan = 1;
9591 case GFC_INIT_REAL_NAN:
9592 mpfr_set_nan (mpc_realref (init_expr->value.complex));
9593 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
9596 case GFC_INIT_REAL_INF:
9597 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
9598 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
9601 case GFC_INIT_REAL_NEG_INF:
9602 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
9603 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
9606 case GFC_INIT_REAL_ZERO:
9607 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
9611 gfc_free_expr (init_expr);
9618 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
9619 init_expr->value.logical = 0;
9620 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
9621 init_expr->value.logical = 1;
9624 gfc_free_expr (init_expr);
9630 /* For characters, the length must be constant in order to
9631 create a default initializer. */
9632 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
9633 && sym->ts.u.cl->length
9634 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9636 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
9637 init_expr->value.character.length = char_len;
9638 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
9639 for (i = 0; i < char_len; i++)
9640 init_expr->value.character.string[i]
9641 = (unsigned char) gfc_option.flag_init_character_value;
9645 gfc_free_expr (init_expr);
9651 gfc_free_expr (init_expr);
9657 /* Add an initialization expression to a local variable. */
9659 apply_default_init_local (gfc_symbol *sym)
9661 gfc_expr *init = NULL;
9663 /* The symbol should be a variable or a function return value. */
9664 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9665 || (sym->attr.function && sym->result != sym))
9668 /* Try to build the initializer expression. If we can't initialize
9669 this symbol, then init will be NULL. */
9670 init = build_default_init_expr (sym);
9674 /* For saved variables, we don't want to add an initializer at
9675 function entry, so we just add a static initializer. */
9676 if (sym->attr.save || sym->ns->save_all
9677 || gfc_option.flag_max_stack_var_size == 0)
9679 /* Don't clobber an existing initializer! */
9680 gcc_assert (sym->value == NULL);
9685 build_init_assign (sym, init);
9688 /* Resolution of common features of flavors variable and procedure. */
9691 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
9693 /* Constraints on deferred shape variable. */
9694 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
9696 if (sym->attr.allocatable)
9698 if (sym->attr.dimension)
9700 gfc_error ("Allocatable array '%s' at %L must have "
9701 "a deferred shape", sym->name, &sym->declared_at);
9704 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
9705 "may not be ALLOCATABLE", sym->name,
9706 &sym->declared_at) == FAILURE)
9710 if (sym->attr.pointer && sym->attr.dimension)
9712 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
9713 sym->name, &sym->declared_at);
9719 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
9720 && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc)
9722 gfc_error ("Array '%s' at %L cannot have a deferred shape",
9723 sym->name, &sym->declared_at);
9728 /* Constraints on polymorphic variables. */
9729 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
9732 if (sym->attr.class_ok
9733 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
9735 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
9736 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
9742 /* Assume that use associated symbols were checked in the module ns.
9743 Class-variables that are associate-names are also something special
9744 and excepted from the test. */
9745 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
9747 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
9748 "or pointer", sym->name, &sym->declared_at);
9757 /* Additional checks for symbols with flavor variable and derived
9758 type. To be called from resolve_fl_variable. */
9761 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
9763 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
9765 /* Check to see if a derived type is blocked from being host
9766 associated by the presence of another class I symbol in the same
9767 namespace. 14.6.1.3 of the standard and the discussion on
9768 comp.lang.fortran. */
9769 if (sym->ns != sym->ts.u.derived->ns
9770 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
9773 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
9774 if (s && s->attr.flavor != FL_DERIVED)
9776 gfc_error ("The type '%s' cannot be host associated at %L "
9777 "because it is blocked by an incompatible object "
9778 "of the same name declared at %L",
9779 sym->ts.u.derived->name, &sym->declared_at,
9785 /* 4th constraint in section 11.3: "If an object of a type for which
9786 component-initialization is specified (R429) appears in the
9787 specification-part of a module and does not have the ALLOCATABLE
9788 or POINTER attribute, the object shall have the SAVE attribute."
9790 The check for initializers is performed with
9791 gfc_has_default_initializer because gfc_default_initializer generates
9792 a hidden default for allocatable components. */
9793 if (!(sym->value || no_init_flag) && sym->ns->proc_name
9794 && sym->ns->proc_name->attr.flavor == FL_MODULE
9795 && !sym->ns->save_all && !sym->attr.save
9796 && !sym->attr.pointer && !sym->attr.allocatable
9797 && gfc_has_default_initializer (sym->ts.u.derived)
9798 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
9799 "module variable '%s' at %L, needed due to "
9800 "the default initialization", sym->name,
9801 &sym->declared_at) == FAILURE)
9804 /* Assign default initializer. */
9805 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
9806 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
9808 sym->value = gfc_default_initializer (&sym->ts);
9815 /* Resolve symbols with flavor variable. */
9818 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
9820 int no_init_flag, automatic_flag;
9822 const char *auto_save_msg;
9824 auto_save_msg = "Automatic object '%s' at %L cannot have the "
9827 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9830 /* Set this flag to check that variables are parameters of all entries.
9831 This check is effected by the call to gfc_resolve_expr through
9832 is_non_constant_shape_array. */
9833 specification_expr = 1;
9835 if (sym->ns->proc_name
9836 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9837 || sym->ns->proc_name->attr.is_main_program)
9838 && !sym->attr.use_assoc
9839 && !sym->attr.allocatable
9840 && !sym->attr.pointer
9841 && is_non_constant_shape_array (sym))
9843 /* The shape of a main program or module array needs to be
9845 gfc_error ("The module or main program array '%s' at %L must "
9846 "have constant shape", sym->name, &sym->declared_at);
9847 specification_expr = 0;
9851 if (sym->ts.type == BT_CHARACTER)
9853 /* Make sure that character string variables with assumed length are
9855 e = sym->ts.u.cl->length;
9856 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
9858 gfc_error ("Entity with assumed character length at %L must be a "
9859 "dummy argument or a PARAMETER", &sym->declared_at);
9863 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
9865 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9869 if (!gfc_is_constant_expr (e)
9870 && !(e->expr_type == EXPR_VARIABLE
9871 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
9872 && sym->ns->proc_name
9873 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9874 || sym->ns->proc_name->attr.is_main_program)
9875 && !sym->attr.use_assoc)
9877 gfc_error ("'%s' at %L must have constant character length "
9878 "in this context", sym->name, &sym->declared_at);
9883 if (sym->value == NULL && sym->attr.referenced)
9884 apply_default_init_local (sym); /* Try to apply a default initialization. */
9886 /* Determine if the symbol may not have an initializer. */
9887 no_init_flag = automatic_flag = 0;
9888 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
9889 || sym->attr.intrinsic || sym->attr.result)
9891 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
9892 && is_non_constant_shape_array (sym))
9894 no_init_flag = automatic_flag = 1;
9896 /* Also, they must not have the SAVE attribute.
9897 SAVE_IMPLICIT is checked below. */
9898 if (sym->attr.save == SAVE_EXPLICIT)
9900 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9905 /* Ensure that any initializer is simplified. */
9907 gfc_simplify_expr (sym->value, 1);
9909 /* Reject illegal initializers. */
9910 if (!sym->mark && sym->value)
9912 if (sym->attr.allocatable)
9913 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
9914 sym->name, &sym->declared_at);
9915 else if (sym->attr.external)
9916 gfc_error ("External '%s' at %L cannot have an initializer",
9917 sym->name, &sym->declared_at);
9918 else if (sym->attr.dummy
9919 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
9920 gfc_error ("Dummy '%s' at %L cannot have an initializer",
9921 sym->name, &sym->declared_at);
9922 else if (sym->attr.intrinsic)
9923 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
9924 sym->name, &sym->declared_at);
9925 else if (sym->attr.result)
9926 gfc_error ("Function result '%s' at %L cannot have an initializer",
9927 sym->name, &sym->declared_at);
9928 else if (automatic_flag)
9929 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
9930 sym->name, &sym->declared_at);
9937 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
9938 return resolve_fl_variable_derived (sym, no_init_flag);
9944 /* Resolve a procedure. */
9947 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
9949 gfc_formal_arglist *arg;
9951 if (sym->attr.function
9952 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9955 if (sym->ts.type == BT_CHARACTER)
9957 gfc_charlen *cl = sym->ts.u.cl;
9959 if (cl && cl->length && gfc_is_constant_expr (cl->length)
9960 && resolve_charlen (cl) == FAILURE)
9963 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
9964 && sym->attr.proc == PROC_ST_FUNCTION)
9966 gfc_error ("Character-valued statement function '%s' at %L must "
9967 "have constant length", sym->name, &sym->declared_at);
9972 /* Ensure that derived type for are not of a private type. Internal
9973 module procedures are excluded by 2.2.3.3 - i.e., they are not
9974 externally accessible and can access all the objects accessible in
9976 if (!(sym->ns->parent
9977 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
9978 && gfc_check_access(sym->attr.access, sym->ns->default_access))
9980 gfc_interface *iface;
9982 for (arg = sym->formal; arg; arg = arg->next)
9985 && arg->sym->ts.type == BT_DERIVED
9986 && !arg->sym->ts.u.derived->attr.use_assoc
9987 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
9988 arg->sym->ts.u.derived->ns->default_access)
9989 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
9990 "PRIVATE type and cannot be a dummy argument"
9991 " of '%s', which is PUBLIC at %L",
9992 arg->sym->name, sym->name, &sym->declared_at)
9995 /* Stop this message from recurring. */
9996 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10001 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10002 PRIVATE to the containing module. */
10003 for (iface = sym->generic; iface; iface = iface->next)
10005 for (arg = iface->sym->formal; arg; arg = arg->next)
10008 && arg->sym->ts.type == BT_DERIVED
10009 && !arg->sym->ts.u.derived->attr.use_assoc
10010 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10011 arg->sym->ts.u.derived->ns->default_access)
10012 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10013 "'%s' in PUBLIC interface '%s' at %L "
10014 "takes dummy arguments of '%s' which is "
10015 "PRIVATE", iface->sym->name, sym->name,
10016 &iface->sym->declared_at,
10017 gfc_typename (&arg->sym->ts)) == FAILURE)
10019 /* Stop this message from recurring. */
10020 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10026 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10027 PRIVATE to the containing module. */
10028 for (iface = sym->generic; iface; iface = iface->next)
10030 for (arg = iface->sym->formal; arg; arg = arg->next)
10033 && arg->sym->ts.type == BT_DERIVED
10034 && !arg->sym->ts.u.derived->attr.use_assoc
10035 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10036 arg->sym->ts.u.derived->ns->default_access)
10037 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10038 "'%s' in PUBLIC interface '%s' at %L "
10039 "takes dummy arguments of '%s' which is "
10040 "PRIVATE", iface->sym->name, sym->name,
10041 &iface->sym->declared_at,
10042 gfc_typename (&arg->sym->ts)) == FAILURE)
10044 /* Stop this message from recurring. */
10045 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10052 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10053 && !sym->attr.proc_pointer)
10055 gfc_error ("Function '%s' at %L cannot have an initializer",
10056 sym->name, &sym->declared_at);
10060 /* An external symbol may not have an initializer because it is taken to be
10061 a procedure. Exception: Procedure Pointers. */
10062 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10064 gfc_error ("External object '%s' at %L may not have an initializer",
10065 sym->name, &sym->declared_at);
10069 /* An elemental function is required to return a scalar 12.7.1 */
10070 if (sym->attr.elemental && sym->attr.function && sym->as)
10072 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10073 "result", sym->name, &sym->declared_at);
10074 /* Reset so that the error only occurs once. */
10075 sym->attr.elemental = 0;
10079 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10080 char-len-param shall not be array-valued, pointer-valued, recursive
10081 or pure. ....snip... A character value of * may only be used in the
10082 following ways: (i) Dummy arg of procedure - dummy associates with
10083 actual length; (ii) To declare a named constant; or (iii) External
10084 function - but length must be declared in calling scoping unit. */
10085 if (sym->attr.function
10086 && sym->ts.type == BT_CHARACTER
10087 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10089 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10090 || (sym->attr.recursive) || (sym->attr.pure))
10092 if (sym->as && sym->as->rank)
10093 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10094 "array-valued", sym->name, &sym->declared_at);
10096 if (sym->attr.pointer)
10097 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10098 "pointer-valued", sym->name, &sym->declared_at);
10100 if (sym->attr.pure)
10101 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10102 "pure", sym->name, &sym->declared_at);
10104 if (sym->attr.recursive)
10105 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10106 "recursive", sym->name, &sym->declared_at);
10111 /* Appendix B.2 of the standard. Contained functions give an
10112 error anyway. Fixed-form is likely to be F77/legacy. */
10113 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
10114 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10115 "CHARACTER(*) function '%s' at %L",
10116 sym->name, &sym->declared_at);
10119 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10121 gfc_formal_arglist *curr_arg;
10122 int has_non_interop_arg = 0;
10124 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10125 sym->common_block) == FAILURE)
10127 /* Clear these to prevent looking at them again if there was an
10129 sym->attr.is_bind_c = 0;
10130 sym->attr.is_c_interop = 0;
10131 sym->ts.is_c_interop = 0;
10135 /* So far, no errors have been found. */
10136 sym->attr.is_c_interop = 1;
10137 sym->ts.is_c_interop = 1;
10140 curr_arg = sym->formal;
10141 while (curr_arg != NULL)
10143 /* Skip implicitly typed dummy args here. */
10144 if (curr_arg->sym->attr.implicit_type == 0)
10145 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
10146 /* If something is found to fail, record the fact so we
10147 can mark the symbol for the procedure as not being
10148 BIND(C) to try and prevent multiple errors being
10150 has_non_interop_arg = 1;
10152 curr_arg = curr_arg->next;
10155 /* See if any of the arguments were not interoperable and if so, clear
10156 the procedure symbol to prevent duplicate error messages. */
10157 if (has_non_interop_arg != 0)
10159 sym->attr.is_c_interop = 0;
10160 sym->ts.is_c_interop = 0;
10161 sym->attr.is_bind_c = 0;
10165 if (!sym->attr.proc_pointer)
10167 if (sym->attr.save == SAVE_EXPLICIT)
10169 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10170 "in '%s' at %L", sym->name, &sym->declared_at);
10173 if (sym->attr.intent)
10175 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10176 "in '%s' at %L", sym->name, &sym->declared_at);
10179 if (sym->attr.subroutine && sym->attr.result)
10181 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10182 "in '%s' at %L", sym->name, &sym->declared_at);
10185 if (sym->attr.external && sym->attr.function
10186 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10187 || sym->attr.contained))
10189 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10190 "in '%s' at %L", sym->name, &sym->declared_at);
10193 if (strcmp ("ppr@", sym->name) == 0)
10195 gfc_error ("Procedure pointer result '%s' at %L "
10196 "is missing the pointer attribute",
10197 sym->ns->proc_name->name, &sym->declared_at);
10206 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10207 been defined and we now know their defined arguments, check that they fulfill
10208 the requirements of the standard for procedures used as finalizers. */
10211 gfc_resolve_finalizers (gfc_symbol* derived)
10213 gfc_finalizer* list;
10214 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10215 gfc_try result = SUCCESS;
10216 bool seen_scalar = false;
10218 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10221 /* Walk over the list of finalizer-procedures, check them, and if any one
10222 does not fit in with the standard's definition, print an error and remove
10223 it from the list. */
10224 prev_link = &derived->f2k_derived->finalizers;
10225 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10231 /* Skip this finalizer if we already resolved it. */
10232 if (list->proc_tree)
10234 prev_link = &(list->next);
10238 /* Check this exists and is a SUBROUTINE. */
10239 if (!list->proc_sym->attr.subroutine)
10241 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10242 list->proc_sym->name, &list->where);
10246 /* We should have exactly one argument. */
10247 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10249 gfc_error ("FINAL procedure at %L must have exactly one argument",
10253 arg = list->proc_sym->formal->sym;
10255 /* This argument must be of our type. */
10256 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10258 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10259 &arg->declared_at, derived->name);
10263 /* It must neither be a pointer nor allocatable nor optional. */
10264 if (arg->attr.pointer)
10266 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10267 &arg->declared_at);
10270 if (arg->attr.allocatable)
10272 gfc_error ("Argument of FINAL procedure at %L must not be"
10273 " ALLOCATABLE", &arg->declared_at);
10276 if (arg->attr.optional)
10278 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10279 &arg->declared_at);
10283 /* It must not be INTENT(OUT). */
10284 if (arg->attr.intent == INTENT_OUT)
10286 gfc_error ("Argument of FINAL procedure at %L must not be"
10287 " INTENT(OUT)", &arg->declared_at);
10291 /* Warn if the procedure is non-scalar and not assumed shape. */
10292 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10293 && arg->as->type != AS_ASSUMED_SHAPE)
10294 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10295 " shape argument", &arg->declared_at);
10297 /* Check that it does not match in kind and rank with a FINAL procedure
10298 defined earlier. To really loop over the *earlier* declarations,
10299 we need to walk the tail of the list as new ones were pushed at the
10301 /* TODO: Handle kind parameters once they are implemented. */
10302 my_rank = (arg->as ? arg->as->rank : 0);
10303 for (i = list->next; i; i = i->next)
10305 /* Argument list might be empty; that is an error signalled earlier,
10306 but we nevertheless continued resolving. */
10307 if (i->proc_sym->formal)
10309 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10310 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10311 if (i_rank == my_rank)
10313 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10314 " rank (%d) as '%s'",
10315 list->proc_sym->name, &list->where, my_rank,
10316 i->proc_sym->name);
10322 /* Is this the/a scalar finalizer procedure? */
10323 if (!arg->as || arg->as->rank == 0)
10324 seen_scalar = true;
10326 /* Find the symtree for this procedure. */
10327 gcc_assert (!list->proc_tree);
10328 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10330 prev_link = &list->next;
10333 /* Remove wrong nodes immediately from the list so we don't risk any
10334 troubles in the future when they might fail later expectations. */
10338 *prev_link = list->next;
10339 gfc_free_finalizer (i);
10342 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10343 were nodes in the list, must have been for arrays. It is surely a good
10344 idea to have a scalar version there if there's something to finalize. */
10345 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10346 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10347 " defined at %L, suggest also scalar one",
10348 derived->name, &derived->declared_at);
10350 /* TODO: Remove this error when finalization is finished. */
10351 gfc_error ("Finalization at %L is not yet implemented",
10352 &derived->declared_at);
10358 /* Check that it is ok for the typebound procedure proc to override the
10362 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
10365 const gfc_symbol* proc_target;
10366 const gfc_symbol* old_target;
10367 unsigned proc_pass_arg, old_pass_arg, argpos;
10368 gfc_formal_arglist* proc_formal;
10369 gfc_formal_arglist* old_formal;
10371 /* This procedure should only be called for non-GENERIC proc. */
10372 gcc_assert (!proc->n.tb->is_generic);
10374 /* If the overwritten procedure is GENERIC, this is an error. */
10375 if (old->n.tb->is_generic)
10377 gfc_error ("Can't overwrite GENERIC '%s' at %L",
10378 old->name, &proc->n.tb->where);
10382 where = proc->n.tb->where;
10383 proc_target = proc->n.tb->u.specific->n.sym;
10384 old_target = old->n.tb->u.specific->n.sym;
10386 /* Check that overridden binding is not NON_OVERRIDABLE. */
10387 if (old->n.tb->non_overridable)
10389 gfc_error ("'%s' at %L overrides a procedure binding declared"
10390 " NON_OVERRIDABLE", proc->name, &where);
10394 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
10395 if (!old->n.tb->deferred && proc->n.tb->deferred)
10397 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
10398 " non-DEFERRED binding", proc->name, &where);
10402 /* If the overridden binding is PURE, the overriding must be, too. */
10403 if (old_target->attr.pure && !proc_target->attr.pure)
10405 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
10406 proc->name, &where);
10410 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
10411 is not, the overriding must not be either. */
10412 if (old_target->attr.elemental && !proc_target->attr.elemental)
10414 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
10415 " ELEMENTAL", proc->name, &where);
10418 if (!old_target->attr.elemental && proc_target->attr.elemental)
10420 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
10421 " be ELEMENTAL, either", proc->name, &where);
10425 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
10427 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
10429 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
10430 " SUBROUTINE", proc->name, &where);
10434 /* If the overridden binding is a FUNCTION, the overriding must also be a
10435 FUNCTION and have the same characteristics. */
10436 if (old_target->attr.function)
10438 if (!proc_target->attr.function)
10440 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
10441 " FUNCTION", proc->name, &where);
10445 /* FIXME: Do more comprehensive checking (including, for instance, the
10446 rank and array-shape). */
10447 gcc_assert (proc_target->result && old_target->result);
10448 if (!gfc_compare_types (&proc_target->result->ts,
10449 &old_target->result->ts))
10451 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
10452 " matching result types", proc->name, &where);
10457 /* If the overridden binding is PUBLIC, the overriding one must not be
10459 if (old->n.tb->access == ACCESS_PUBLIC
10460 && proc->n.tb->access == ACCESS_PRIVATE)
10462 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
10463 " PRIVATE", proc->name, &where);
10467 /* Compare the formal argument lists of both procedures. This is also abused
10468 to find the position of the passed-object dummy arguments of both
10469 bindings as at least the overridden one might not yet be resolved and we
10470 need those positions in the check below. */
10471 proc_pass_arg = old_pass_arg = 0;
10472 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
10474 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
10477 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
10478 proc_formal && old_formal;
10479 proc_formal = proc_formal->next, old_formal = old_formal->next)
10481 if (proc->n.tb->pass_arg
10482 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
10483 proc_pass_arg = argpos;
10484 if (old->n.tb->pass_arg
10485 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
10486 old_pass_arg = argpos;
10488 /* Check that the names correspond. */
10489 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
10491 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
10492 " to match the corresponding argument of the overridden"
10493 " procedure", proc_formal->sym->name, proc->name, &where,
10494 old_formal->sym->name);
10498 /* Check that the types correspond if neither is the passed-object
10500 /* FIXME: Do more comprehensive testing here. */
10501 if (proc_pass_arg != argpos && old_pass_arg != argpos
10502 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
10504 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
10505 "in respect to the overridden procedure",
10506 proc_formal->sym->name, proc->name, &where);
10512 if (proc_formal || old_formal)
10514 gfc_error ("'%s' at %L must have the same number of formal arguments as"
10515 " the overridden procedure", proc->name, &where);
10519 /* If the overridden binding is NOPASS, the overriding one must also be
10521 if (old->n.tb->nopass && !proc->n.tb->nopass)
10523 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
10524 " NOPASS", proc->name, &where);
10528 /* If the overridden binding is PASS(x), the overriding one must also be
10529 PASS and the passed-object dummy arguments must correspond. */
10530 if (!old->n.tb->nopass)
10532 if (proc->n.tb->nopass)
10534 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
10535 " PASS", proc->name, &where);
10539 if (proc_pass_arg != old_pass_arg)
10541 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
10542 " the same position as the passed-object dummy argument of"
10543 " the overridden procedure", proc->name, &where);
10552 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10555 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10556 const char* generic_name, locus where)
10561 gcc_assert (t1->specific && t2->specific);
10562 gcc_assert (!t1->specific->is_generic);
10563 gcc_assert (!t2->specific->is_generic);
10565 sym1 = t1->specific->u.specific->n.sym;
10566 sym2 = t2->specific->u.specific->n.sym;
10571 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10572 if (sym1->attr.subroutine != sym2->attr.subroutine
10573 || sym1->attr.function != sym2->attr.function)
10575 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10576 " GENERIC '%s' at %L",
10577 sym1->name, sym2->name, generic_name, &where);
10581 /* Compare the interfaces. */
10582 if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
10584 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10585 sym1->name, sym2->name, generic_name, &where);
10593 /* Worker function for resolving a generic procedure binding; this is used to
10594 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10596 The difference between those cases is finding possible inherited bindings
10597 that are overridden, as one has to look for them in tb_sym_root,
10598 tb_uop_root or tb_op, respectively. Thus the caller must already find
10599 the super-type and set p->overridden correctly. */
10602 resolve_tb_generic_targets (gfc_symbol* super_type,
10603 gfc_typebound_proc* p, const char* name)
10605 gfc_tbp_generic* target;
10606 gfc_symtree* first_target;
10607 gfc_symtree* inherited;
10609 gcc_assert (p && p->is_generic);
10611 /* Try to find the specific bindings for the symtrees in our target-list. */
10612 gcc_assert (p->u.generic);
10613 for (target = p->u.generic; target; target = target->next)
10614 if (!target->specific)
10616 gfc_typebound_proc* overridden_tbp;
10617 gfc_tbp_generic* g;
10618 const char* target_name;
10620 target_name = target->specific_st->name;
10622 /* Defined for this type directly. */
10623 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
10625 target->specific = target->specific_st->n.tb;
10626 goto specific_found;
10629 /* Look for an inherited specific binding. */
10632 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
10637 gcc_assert (inherited->n.tb);
10638 target->specific = inherited->n.tb;
10639 goto specific_found;
10643 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
10644 " at %L", target_name, name, &p->where);
10647 /* Once we've found the specific binding, check it is not ambiguous with
10648 other specifics already found or inherited for the same GENERIC. */
10650 gcc_assert (target->specific);
10652 /* This must really be a specific binding! */
10653 if (target->specific->is_generic)
10655 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
10656 " '%s' is GENERIC, too", name, &p->where, target_name);
10660 /* Check those already resolved on this type directly. */
10661 for (g = p->u.generic; g; g = g->next)
10662 if (g != target && g->specific
10663 && check_generic_tbp_ambiguity (target, g, name, p->where)
10667 /* Check for ambiguity with inherited specific targets. */
10668 for (overridden_tbp = p->overridden; overridden_tbp;
10669 overridden_tbp = overridden_tbp->overridden)
10670 if (overridden_tbp->is_generic)
10672 for (g = overridden_tbp->u.generic; g; g = g->next)
10674 gcc_assert (g->specific);
10675 if (check_generic_tbp_ambiguity (target, g,
10676 name, p->where) == FAILURE)
10682 /* If we attempt to "overwrite" a specific binding, this is an error. */
10683 if (p->overridden && !p->overridden->is_generic)
10685 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
10686 " the same name", name, &p->where);
10690 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
10691 all must have the same attributes here. */
10692 first_target = p->u.generic->specific->u.specific;
10693 gcc_assert (first_target);
10694 p->subroutine = first_target->n.sym->attr.subroutine;
10695 p->function = first_target->n.sym->attr.function;
10701 /* Resolve a GENERIC procedure binding for a derived type. */
10704 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
10706 gfc_symbol* super_type;
10708 /* Find the overridden binding if any. */
10709 st->n.tb->overridden = NULL;
10710 super_type = gfc_get_derived_super_type (derived);
10713 gfc_symtree* overridden;
10714 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
10717 if (overridden && overridden->n.tb)
10718 st->n.tb->overridden = overridden->n.tb;
10721 /* Resolve using worker function. */
10722 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
10726 /* Retrieve the target-procedure of an operator binding and do some checks in
10727 common for intrinsic and user-defined type-bound operators. */
10730 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
10732 gfc_symbol* target_proc;
10734 gcc_assert (target->specific && !target->specific->is_generic);
10735 target_proc = target->specific->u.specific->n.sym;
10736 gcc_assert (target_proc);
10738 /* All operator bindings must have a passed-object dummy argument. */
10739 if (target->specific->nopass)
10741 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
10745 return target_proc;
10749 /* Resolve a type-bound intrinsic operator. */
10752 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
10753 gfc_typebound_proc* p)
10755 gfc_symbol* super_type;
10756 gfc_tbp_generic* target;
10758 /* If there's already an error here, do nothing (but don't fail again). */
10762 /* Operators should always be GENERIC bindings. */
10763 gcc_assert (p->is_generic);
10765 /* Look for an overridden binding. */
10766 super_type = gfc_get_derived_super_type (derived);
10767 if (super_type && super_type->f2k_derived)
10768 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
10771 p->overridden = NULL;
10773 /* Resolve general GENERIC properties using worker function. */
10774 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
10777 /* Check the targets to be procedures of correct interface. */
10778 for (target = p->u.generic; target; target = target->next)
10780 gfc_symbol* target_proc;
10782 target_proc = get_checked_tb_operator_target (target, p->where);
10786 if (!gfc_check_operator_interface (target_proc, op, p->where))
10798 /* Resolve a type-bound user operator (tree-walker callback). */
10800 static gfc_symbol* resolve_bindings_derived;
10801 static gfc_try resolve_bindings_result;
10803 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
10806 resolve_typebound_user_op (gfc_symtree* stree)
10808 gfc_symbol* super_type;
10809 gfc_tbp_generic* target;
10811 gcc_assert (stree && stree->n.tb);
10813 if (stree->n.tb->error)
10816 /* Operators should always be GENERIC bindings. */
10817 gcc_assert (stree->n.tb->is_generic);
10819 /* Find overridden procedure, if any. */
10820 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10821 if (super_type && super_type->f2k_derived)
10823 gfc_symtree* overridden;
10824 overridden = gfc_find_typebound_user_op (super_type, NULL,
10825 stree->name, true, NULL);
10827 if (overridden && overridden->n.tb)
10828 stree->n.tb->overridden = overridden->n.tb;
10831 stree->n.tb->overridden = NULL;
10833 /* Resolve basically using worker function. */
10834 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
10838 /* Check the targets to be functions of correct interface. */
10839 for (target = stree->n.tb->u.generic; target; target = target->next)
10841 gfc_symbol* target_proc;
10843 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
10847 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
10854 resolve_bindings_result = FAILURE;
10855 stree->n.tb->error = 1;
10859 /* Resolve the type-bound procedures for a derived type. */
10862 resolve_typebound_procedure (gfc_symtree* stree)
10866 gfc_symbol* me_arg;
10867 gfc_symbol* super_type;
10868 gfc_component* comp;
10870 gcc_assert (stree);
10872 /* Undefined specific symbol from GENERIC target definition. */
10876 if (stree->n.tb->error)
10879 /* If this is a GENERIC binding, use that routine. */
10880 if (stree->n.tb->is_generic)
10882 if (resolve_typebound_generic (resolve_bindings_derived, stree)
10888 /* Get the target-procedure to check it. */
10889 gcc_assert (!stree->n.tb->is_generic);
10890 gcc_assert (stree->n.tb->u.specific);
10891 proc = stree->n.tb->u.specific->n.sym;
10892 where = stree->n.tb->where;
10894 /* Default access should already be resolved from the parser. */
10895 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
10897 /* It should be a module procedure or an external procedure with explicit
10898 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
10899 if ((!proc->attr.subroutine && !proc->attr.function)
10900 || (proc->attr.proc != PROC_MODULE
10901 && proc->attr.if_source != IFSRC_IFBODY)
10902 || (proc->attr.abstract && !stree->n.tb->deferred))
10904 gfc_error ("'%s' must be a module procedure or an external procedure with"
10905 " an explicit interface at %L", proc->name, &where);
10908 stree->n.tb->subroutine = proc->attr.subroutine;
10909 stree->n.tb->function = proc->attr.function;
10911 /* Find the super-type of the current derived type. We could do this once and
10912 store in a global if speed is needed, but as long as not I believe this is
10913 more readable and clearer. */
10914 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10916 /* If PASS, resolve and check arguments if not already resolved / loaded
10917 from a .mod file. */
10918 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
10920 if (stree->n.tb->pass_arg)
10922 gfc_formal_arglist* i;
10924 /* If an explicit passing argument name is given, walk the arg-list
10925 and look for it. */
10928 stree->n.tb->pass_arg_num = 1;
10929 for (i = proc->formal; i; i = i->next)
10931 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
10936 ++stree->n.tb->pass_arg_num;
10941 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
10943 proc->name, stree->n.tb->pass_arg, &where,
10944 stree->n.tb->pass_arg);
10950 /* Otherwise, take the first one; there should in fact be at least
10952 stree->n.tb->pass_arg_num = 1;
10955 gfc_error ("Procedure '%s' with PASS at %L must have at"
10956 " least one argument", proc->name, &where);
10959 me_arg = proc->formal->sym;
10962 /* Now check that the argument-type matches and the passed-object
10963 dummy argument is generally fine. */
10965 gcc_assert (me_arg);
10967 if (me_arg->ts.type != BT_CLASS)
10969 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
10970 " at %L", proc->name, &where);
10974 if (CLASS_DATA (me_arg)->ts.u.derived
10975 != resolve_bindings_derived)
10977 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
10978 " the derived-type '%s'", me_arg->name, proc->name,
10979 me_arg->name, &where, resolve_bindings_derived->name);
10983 gcc_assert (me_arg->ts.type == BT_CLASS);
10984 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
10986 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
10987 " scalar", proc->name, &where);
10990 if (CLASS_DATA (me_arg)->attr.allocatable)
10992 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
10993 " be ALLOCATABLE", proc->name, &where);
10996 if (CLASS_DATA (me_arg)->attr.class_pointer)
10998 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
10999 " be POINTER", proc->name, &where);
11004 /* If we are extending some type, check that we don't override a procedure
11005 flagged NON_OVERRIDABLE. */
11006 stree->n.tb->overridden = NULL;
11009 gfc_symtree* overridden;
11010 overridden = gfc_find_typebound_proc (super_type, NULL,
11011 stree->name, true, NULL);
11013 if (overridden && overridden->n.tb)
11014 stree->n.tb->overridden = overridden->n.tb;
11016 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
11020 /* See if there's a name collision with a component directly in this type. */
11021 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11022 if (!strcmp (comp->name, stree->name))
11024 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11026 stree->name, &where, resolve_bindings_derived->name);
11030 /* Try to find a name collision with an inherited component. */
11031 if (super_type && gfc_find_component (super_type, stree->name, true, true))
11033 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11034 " component of '%s'",
11035 stree->name, &where, resolve_bindings_derived->name);
11039 stree->n.tb->error = 0;
11043 resolve_bindings_result = FAILURE;
11044 stree->n.tb->error = 1;
11049 resolve_typebound_procedures (gfc_symbol* derived)
11053 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11056 resolve_bindings_derived = derived;
11057 resolve_bindings_result = SUCCESS;
11059 /* Make sure the vtab has been generated. */
11060 gfc_find_derived_vtab (derived);
11062 if (derived->f2k_derived->tb_sym_root)
11063 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11064 &resolve_typebound_procedure);
11066 if (derived->f2k_derived->tb_uop_root)
11067 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11068 &resolve_typebound_user_op);
11070 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11072 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11073 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11075 resolve_bindings_result = FAILURE;
11078 return resolve_bindings_result;
11082 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11083 to give all identical derived types the same backend_decl. */
11085 add_dt_to_dt_list (gfc_symbol *derived)
11087 gfc_dt_list *dt_list;
11089 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11090 if (derived == dt_list->derived)
11093 dt_list = gfc_get_dt_list ();
11094 dt_list->next = gfc_derived_types;
11095 dt_list->derived = derived;
11096 gfc_derived_types = dt_list;
11100 /* Ensure that a derived-type is really not abstract, meaning that every
11101 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11104 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11109 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11111 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11114 if (st->n.tb && st->n.tb->deferred)
11116 gfc_symtree* overriding;
11117 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11120 gcc_assert (overriding->n.tb);
11121 if (overriding->n.tb->deferred)
11123 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11124 " '%s' is DEFERRED and not overridden",
11125 sub->name, &sub->declared_at, st->name);
11134 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11136 /* The algorithm used here is to recursively travel up the ancestry of sub
11137 and for each ancestor-type, check all bindings. If any of them is
11138 DEFERRED, look it up starting from sub and see if the found (overriding)
11139 binding is not DEFERRED.
11140 This is not the most efficient way to do this, but it should be ok and is
11141 clearer than something sophisticated. */
11143 gcc_assert (ancestor && !sub->attr.abstract);
11145 if (!ancestor->attr.abstract)
11148 /* Walk bindings of this ancestor. */
11149 if (ancestor->f2k_derived)
11152 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11157 /* Find next ancestor type and recurse on it. */
11158 ancestor = gfc_get_derived_super_type (ancestor);
11160 return ensure_not_abstract (sub, ancestor);
11166 /* Resolve the components of a derived type. */
11169 resolve_fl_derived (gfc_symbol *sym)
11171 gfc_symbol* super_type;
11174 super_type = gfc_get_derived_super_type (sym);
11176 if (sym->attr.is_class && sym->ts.u.derived == NULL)
11178 /* Fix up incomplete CLASS symbols. */
11179 gfc_component *data = gfc_find_component (sym, "$data", true, true);
11180 gfc_component *vptr = gfc_find_component (sym, "$vptr", true, true);
11181 if (vptr->ts.u.derived == NULL)
11183 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
11185 vptr->ts.u.derived = vtab->ts.u.derived;
11190 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11192 gfc_error ("As extending type '%s' at %L has a coarray component, "
11193 "parent type '%s' shall also have one", sym->name,
11194 &sym->declared_at, super_type->name);
11198 /* Ensure the extended type gets resolved before we do. */
11199 if (super_type && resolve_fl_derived (super_type) == FAILURE)
11202 /* An ABSTRACT type must be extensible. */
11203 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11205 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11206 sym->name, &sym->declared_at);
11210 for (c = sym->components; c != NULL; c = c->next)
11213 if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */
11214 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11216 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11217 "deferred shape", c->name, &c->loc);
11222 if (c->attr.codimension && c->ts.type == BT_DERIVED
11223 && c->ts.u.derived->ts.is_iso_c)
11225 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11226 "shall not be a coarray", c->name, &c->loc);
11231 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11232 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11233 || c->attr.allocatable))
11235 gfc_error ("Component '%s' at %L with coarray component "
11236 "shall be a nonpointer, nonallocatable scalar",
11242 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11244 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11245 "is not an array pointer", c->name, &c->loc);
11249 if (c->attr.proc_pointer && c->ts.interface)
11251 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11252 gfc_error ("Interface '%s', used by procedure pointer component "
11253 "'%s' at %L, is declared in a later PROCEDURE statement",
11254 c->ts.interface->name, c->name, &c->loc);
11256 /* Get the attributes from the interface (now resolved). */
11257 if (c->ts.interface->attr.if_source
11258 || c->ts.interface->attr.intrinsic)
11260 gfc_symbol *ifc = c->ts.interface;
11262 if (ifc->formal && !ifc->formal_ns)
11263 resolve_symbol (ifc);
11265 if (ifc->attr.intrinsic)
11266 resolve_intrinsic (ifc, &ifc->declared_at);
11270 c->ts = ifc->result->ts;
11271 c->attr.allocatable = ifc->result->attr.allocatable;
11272 c->attr.pointer = ifc->result->attr.pointer;
11273 c->attr.dimension = ifc->result->attr.dimension;
11274 c->as = gfc_copy_array_spec (ifc->result->as);
11279 c->attr.allocatable = ifc->attr.allocatable;
11280 c->attr.pointer = ifc->attr.pointer;
11281 c->attr.dimension = ifc->attr.dimension;
11282 c->as = gfc_copy_array_spec (ifc->as);
11284 c->ts.interface = ifc;
11285 c->attr.function = ifc->attr.function;
11286 c->attr.subroutine = ifc->attr.subroutine;
11287 gfc_copy_formal_args_ppc (c, ifc);
11289 c->attr.pure = ifc->attr.pure;
11290 c->attr.elemental = ifc->attr.elemental;
11291 c->attr.recursive = ifc->attr.recursive;
11292 c->attr.always_explicit = ifc->attr.always_explicit;
11293 c->attr.ext_attr |= ifc->attr.ext_attr;
11294 /* Replace symbols in array spec. */
11298 for (i = 0; i < c->as->rank; i++)
11300 gfc_expr_replace_comp (c->as->lower[i], c);
11301 gfc_expr_replace_comp (c->as->upper[i], c);
11304 /* Copy char length. */
11305 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11307 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11308 gfc_expr_replace_comp (cl->length, c);
11309 if (cl->length && !cl->resolved
11310 && gfc_resolve_expr (cl->length) == FAILURE)
11315 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11317 gfc_error ("Interface '%s' of procedure pointer component "
11318 "'%s' at %L must be explicit", c->ts.interface->name,
11323 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11325 /* Since PPCs are not implicitly typed, a PPC without an explicit
11326 interface must be a subroutine. */
11327 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11330 /* Procedure pointer components: Check PASS arg. */
11331 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11332 && !sym->attr.vtype)
11334 gfc_symbol* me_arg;
11336 if (c->tb->pass_arg)
11338 gfc_formal_arglist* i;
11340 /* If an explicit passing argument name is given, walk the arg-list
11341 and look for it. */
11344 c->tb->pass_arg_num = 1;
11345 for (i = c->formal; i; i = i->next)
11347 if (!strcmp (i->sym->name, c->tb->pass_arg))
11352 c->tb->pass_arg_num++;
11357 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11358 "at %L has no argument '%s'", c->name,
11359 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11366 /* Otherwise, take the first one; there should in fact be at least
11368 c->tb->pass_arg_num = 1;
11371 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11372 "must have at least one argument",
11377 me_arg = c->formal->sym;
11380 /* Now check that the argument-type matches. */
11381 gcc_assert (me_arg);
11382 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11383 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11384 || (me_arg->ts.type == BT_CLASS
11385 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11387 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11388 " the derived type '%s'", me_arg->name, c->name,
11389 me_arg->name, &c->loc, sym->name);
11394 /* Check for C453. */
11395 if (me_arg->attr.dimension)
11397 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11398 "must be scalar", me_arg->name, c->name, me_arg->name,
11404 if (me_arg->attr.pointer)
11406 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11407 "may not have the POINTER attribute", me_arg->name,
11408 c->name, me_arg->name, &c->loc);
11413 if (me_arg->attr.allocatable)
11415 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11416 "may not be ALLOCATABLE", me_arg->name, c->name,
11417 me_arg->name, &c->loc);
11422 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11423 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11424 " at %L", c->name, &c->loc);
11428 /* Check type-spec if this is not the parent-type component. */
11429 if ((!sym->attr.extension || c != sym->components) && !sym->attr.vtype
11430 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11433 /* If this type is an extension, set the accessibility of the parent
11435 if (super_type && c == sym->components
11436 && strcmp (super_type->name, c->name) == 0)
11437 c->attr.access = super_type->attr.access;
11439 /* If this type is an extension, see if this component has the same name
11440 as an inherited type-bound procedure. */
11441 if (super_type && !sym->attr.is_class
11442 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11444 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11445 " inherited type-bound procedure",
11446 c->name, sym->name, &c->loc);
11450 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
11452 if (c->ts.u.cl->length == NULL
11453 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11454 || !gfc_is_constant_expr (c->ts.u.cl->length))
11456 gfc_error ("Character length of component '%s' needs to "
11457 "be a constant specification expression at %L",
11459 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11464 if (c->ts.type == BT_DERIVED
11465 && sym->component_access != ACCESS_PRIVATE
11466 && gfc_check_access (sym->attr.access, sym->ns->default_access)
11467 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11468 && !c->ts.u.derived->attr.use_assoc
11469 && !gfc_check_access (c->ts.u.derived->attr.access,
11470 c->ts.u.derived->ns->default_access)
11471 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11472 "is a PRIVATE type and cannot be a component of "
11473 "'%s', which is PUBLIC at %L", c->name,
11474 sym->name, &sym->declared_at) == FAILURE)
11477 if (sym->attr.sequence)
11479 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11481 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11482 "not have the SEQUENCE attribute",
11483 c->ts.u.derived->name, &sym->declared_at);
11488 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
11489 && c->attr.pointer && c->ts.u.derived->components == NULL
11490 && !c->ts.u.derived->attr.zero_comp)
11492 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11493 "that has not been declared", c->name, sym->name,
11498 if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer
11499 && CLASS_DATA (c)->ts.u.derived->components == NULL
11500 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11502 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11503 "that has not been declared", c->name, sym->name,
11509 if (c->ts.type == BT_CLASS
11510 && !(CLASS_DATA (c)->attr.class_pointer
11511 || CLASS_DATA (c)->attr.allocatable))
11513 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11514 "or pointer", c->name, &c->loc);
11518 /* Ensure that all the derived type components are put on the
11519 derived type list; even in formal namespaces, where derived type
11520 pointer components might not have been declared. */
11521 if (c->ts.type == BT_DERIVED
11523 && c->ts.u.derived->components
11525 && sym != c->ts.u.derived)
11526 add_dt_to_dt_list (c->ts.u.derived);
11528 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11529 || c->attr.proc_pointer
11530 || c->attr.allocatable)) == FAILURE)
11534 /* Resolve the type-bound procedures. */
11535 if (resolve_typebound_procedures (sym) == FAILURE)
11538 /* Resolve the finalizer procedures. */
11539 if (gfc_resolve_finalizers (sym) == FAILURE)
11542 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11543 all DEFERRED bindings are overridden. */
11544 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11545 && !sym->attr.is_class
11546 && ensure_not_abstract (sym, super_type) == FAILURE)
11549 /* Add derived type to the derived type list. */
11550 add_dt_to_dt_list (sym);
11557 resolve_fl_namelist (gfc_symbol *sym)
11562 for (nl = sym->namelist; nl; nl = nl->next)
11564 /* Reject namelist arrays of assumed shape. */
11565 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
11566 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
11567 "must not have assumed shape in namelist "
11568 "'%s' at %L", nl->sym->name, sym->name,
11569 &sym->declared_at) == FAILURE)
11572 /* Reject namelist arrays that are not constant shape. */
11573 if (is_non_constant_shape_array (nl->sym))
11575 gfc_error ("NAMELIST array object '%s' must have constant "
11576 "shape in namelist '%s' at %L", nl->sym->name,
11577 sym->name, &sym->declared_at);
11581 /* Namelist objects cannot have allocatable or pointer components. */
11582 if (nl->sym->ts.type != BT_DERIVED)
11585 if (nl->sym->ts.u.derived->attr.alloc_comp)
11587 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11588 "have ALLOCATABLE components",
11589 nl->sym->name, sym->name, &sym->declared_at);
11593 if (nl->sym->ts.u.derived->attr.pointer_comp)
11595 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11596 "have POINTER components",
11597 nl->sym->name, sym->name, &sym->declared_at);
11602 /* Reject PRIVATE objects in a PUBLIC namelist. */
11603 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
11605 for (nl = sym->namelist; nl; nl = nl->next)
11607 if (!nl->sym->attr.use_assoc
11608 && !is_sym_host_assoc (nl->sym, sym->ns)
11609 && !gfc_check_access(nl->sym->attr.access,
11610 nl->sym->ns->default_access))
11612 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
11613 "cannot be member of PUBLIC namelist '%s' at %L",
11614 nl->sym->name, sym->name, &sym->declared_at);
11618 /* Types with private components that came here by USE-association. */
11619 if (nl->sym->ts.type == BT_DERIVED
11620 && derived_inaccessible (nl->sym->ts.u.derived))
11622 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
11623 "components and cannot be member of namelist '%s' at %L",
11624 nl->sym->name, sym->name, &sym->declared_at);
11628 /* Types with private components that are defined in the same module. */
11629 if (nl->sym->ts.type == BT_DERIVED
11630 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
11631 && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
11632 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
11633 nl->sym->ns->default_access))
11635 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
11636 "cannot be a member of PUBLIC namelist '%s' at %L",
11637 nl->sym->name, sym->name, &sym->declared_at);
11644 /* 14.1.2 A module or internal procedure represent local entities
11645 of the same type as a namelist member and so are not allowed. */
11646 for (nl = sym->namelist; nl; nl = nl->next)
11648 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
11651 if (nl->sym->attr.function && nl->sym == nl->sym->result)
11652 if ((nl->sym == sym->ns->proc_name)
11654 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
11658 if (nl->sym && nl->sym->name)
11659 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
11660 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
11662 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
11663 "attribute in '%s' at %L", nlsym->name,
11664 &sym->declared_at);
11674 resolve_fl_parameter (gfc_symbol *sym)
11676 /* A parameter array's shape needs to be constant. */
11677 if (sym->as != NULL
11678 && (sym->as->type == AS_DEFERRED
11679 || is_non_constant_shape_array (sym)))
11681 gfc_error ("Parameter array '%s' at %L cannot be automatic "
11682 "or of deferred shape", sym->name, &sym->declared_at);
11686 /* Make sure a parameter that has been implicitly typed still
11687 matches the implicit type, since PARAMETER statements can precede
11688 IMPLICIT statements. */
11689 if (sym->attr.implicit_type
11690 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
11693 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
11694 "later IMPLICIT type", sym->name, &sym->declared_at);
11698 /* Make sure the types of derived parameters are consistent. This
11699 type checking is deferred until resolution because the type may
11700 refer to a derived type from the host. */
11701 if (sym->ts.type == BT_DERIVED
11702 && !gfc_compare_types (&sym->ts, &sym->value->ts))
11704 gfc_error ("Incompatible derived type in PARAMETER at %L",
11705 &sym->value->where);
11712 /* Do anything necessary to resolve a symbol. Right now, we just
11713 assume that an otherwise unknown symbol is a variable. This sort
11714 of thing commonly happens for symbols in module. */
11717 resolve_symbol (gfc_symbol *sym)
11719 int check_constant, mp_flag;
11720 gfc_symtree *symtree;
11721 gfc_symtree *this_symtree;
11725 /* Avoid double resolution of function result symbols. */
11726 if ((sym->result || sym->attr.result) && !sym->attr.dummy
11727 && (sym->ns != gfc_current_ns))
11730 if (sym->attr.flavor == FL_UNKNOWN)
11733 /* If we find that a flavorless symbol is an interface in one of the
11734 parent namespaces, find its symtree in this namespace, free the
11735 symbol and set the symtree to point to the interface symbol. */
11736 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
11738 symtree = gfc_find_symtree (ns->sym_root, sym->name);
11739 if (symtree && symtree->n.sym->generic)
11741 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
11743 gfc_release_symbol (sym);
11744 symtree->n.sym->refs++;
11745 this_symtree->n.sym = symtree->n.sym;
11750 /* Otherwise give it a flavor according to such attributes as
11752 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
11753 sym->attr.flavor = FL_VARIABLE;
11756 sym->attr.flavor = FL_PROCEDURE;
11757 if (sym->attr.dimension)
11758 sym->attr.function = 1;
11762 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
11763 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
11765 if (sym->attr.procedure && sym->ts.interface
11766 && sym->attr.if_source != IFSRC_DECL
11767 && resolve_procedure_interface (sym) == FAILURE)
11770 if (sym->attr.is_protected && !sym->attr.proc_pointer
11771 && (sym->attr.procedure || sym->attr.external))
11773 if (sym->attr.external)
11774 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
11775 "at %L", &sym->declared_at);
11777 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
11778 "at %L", &sym->declared_at);
11785 if (sym->attr.contiguous
11786 && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE
11787 && !sym->attr.pointer)))
11789 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
11790 "array pointer or an assumed-shape array", sym->name,
11791 &sym->declared_at);
11795 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
11798 /* Symbols that are module procedures with results (functions) have
11799 the types and array specification copied for type checking in
11800 procedures that call them, as well as for saving to a module
11801 file. These symbols can't stand the scrutiny that their results
11803 mp_flag = (sym->result != NULL && sym->result != sym);
11805 /* Make sure that the intrinsic is consistent with its internal
11806 representation. This needs to be done before assigning a default
11807 type to avoid spurious warnings. */
11808 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
11809 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
11812 /* Resolve associate names. */
11814 resolve_assoc_var (sym, true);
11816 /* Assign default type to symbols that need one and don't have one. */
11817 if (sym->ts.type == BT_UNKNOWN)
11819 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
11820 gfc_set_default_type (sym, 1, NULL);
11822 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
11823 && !sym->attr.function && !sym->attr.subroutine
11824 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
11825 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
11827 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
11829 /* The specific case of an external procedure should emit an error
11830 in the case that there is no implicit type. */
11832 gfc_set_default_type (sym, sym->attr.external, NULL);
11835 /* Result may be in another namespace. */
11836 resolve_symbol (sym->result);
11838 if (!sym->result->attr.proc_pointer)
11840 sym->ts = sym->result->ts;
11841 sym->as = gfc_copy_array_spec (sym->result->as);
11842 sym->attr.dimension = sym->result->attr.dimension;
11843 sym->attr.pointer = sym->result->attr.pointer;
11844 sym->attr.allocatable = sym->result->attr.allocatable;
11845 sym->attr.contiguous = sym->result->attr.contiguous;
11851 /* Assumed size arrays and assumed shape arrays must be dummy
11852 arguments. Array-spec's of implied-shape should have been resolved to
11853 AS_EXPLICIT already. */
11857 gcc_assert (sym->as->type != AS_IMPLIED_SHAPE);
11858 if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
11859 || sym->as->type == AS_ASSUMED_SHAPE)
11860 && sym->attr.dummy == 0)
11862 if (sym->as->type == AS_ASSUMED_SIZE)
11863 gfc_error ("Assumed size array at %L must be a dummy argument",
11864 &sym->declared_at);
11866 gfc_error ("Assumed shape array at %L must be a dummy argument",
11867 &sym->declared_at);
11872 /* Make sure symbols with known intent or optional are really dummy
11873 variable. Because of ENTRY statement, this has to be deferred
11874 until resolution time. */
11876 if (!sym->attr.dummy
11877 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
11879 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
11883 if (sym->attr.value && !sym->attr.dummy)
11885 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
11886 "it is not a dummy argument", sym->name, &sym->declared_at);
11890 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
11892 gfc_charlen *cl = sym->ts.u.cl;
11893 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
11895 gfc_error ("Character dummy variable '%s' at %L with VALUE "
11896 "attribute must have constant length",
11897 sym->name, &sym->declared_at);
11901 if (sym->ts.is_c_interop
11902 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
11904 gfc_error ("C interoperable character dummy variable '%s' at %L "
11905 "with VALUE attribute must have length one",
11906 sym->name, &sym->declared_at);
11911 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
11912 do this for something that was implicitly typed because that is handled
11913 in gfc_set_default_type. Handle dummy arguments and procedure
11914 definitions separately. Also, anything that is use associated is not
11915 handled here but instead is handled in the module it is declared in.
11916 Finally, derived type definitions are allowed to be BIND(C) since that
11917 only implies that they're interoperable, and they are checked fully for
11918 interoperability when a variable is declared of that type. */
11919 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
11920 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
11921 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
11923 gfc_try t = SUCCESS;
11925 /* First, make sure the variable is declared at the
11926 module-level scope (J3/04-007, Section 15.3). */
11927 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
11928 sym->attr.in_common == 0)
11930 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
11931 "is neither a COMMON block nor declared at the "
11932 "module level scope", sym->name, &(sym->declared_at));
11935 else if (sym->common_head != NULL)
11937 t = verify_com_block_vars_c_interop (sym->common_head);
11941 /* If type() declaration, we need to verify that the components
11942 of the given type are all C interoperable, etc. */
11943 if (sym->ts.type == BT_DERIVED &&
11944 sym->ts.u.derived->attr.is_c_interop != 1)
11946 /* Make sure the user marked the derived type as BIND(C). If
11947 not, call the verify routine. This could print an error
11948 for the derived type more than once if multiple variables
11949 of that type are declared. */
11950 if (sym->ts.u.derived->attr.is_bind_c != 1)
11951 verify_bind_c_derived_type (sym->ts.u.derived);
11955 /* Verify the variable itself as C interoperable if it
11956 is BIND(C). It is not possible for this to succeed if
11957 the verify_bind_c_derived_type failed, so don't have to handle
11958 any error returned by verify_bind_c_derived_type. */
11959 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
11960 sym->common_block);
11965 /* clear the is_bind_c flag to prevent reporting errors more than
11966 once if something failed. */
11967 sym->attr.is_bind_c = 0;
11972 /* If a derived type symbol has reached this point, without its
11973 type being declared, we have an error. Notice that most
11974 conditions that produce undefined derived types have already
11975 been dealt with. However, the likes of:
11976 implicit type(t) (t) ..... call foo (t) will get us here if
11977 the type is not declared in the scope of the implicit
11978 statement. Change the type to BT_UNKNOWN, both because it is so
11979 and to prevent an ICE. */
11980 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
11981 && !sym->ts.u.derived->attr.zero_comp)
11983 gfc_error ("The derived type '%s' at %L is of type '%s', "
11984 "which has not been defined", sym->name,
11985 &sym->declared_at, sym->ts.u.derived->name);
11986 sym->ts.type = BT_UNKNOWN;
11990 /* Make sure that the derived type has been resolved and that the
11991 derived type is visible in the symbol's namespace, if it is a
11992 module function and is not PRIVATE. */
11993 if (sym->ts.type == BT_DERIVED
11994 && sym->ts.u.derived->attr.use_assoc
11995 && sym->ns->proc_name
11996 && sym->ns->proc_name->attr.flavor == FL_MODULE)
12000 if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
12003 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
12004 if (!ds && sym->attr.function
12005 && gfc_check_access (sym->attr.access, sym->ns->default_access))
12007 symtree = gfc_new_symtree (&sym->ns->sym_root,
12008 sym->ts.u.derived->name);
12009 symtree->n.sym = sym->ts.u.derived;
12010 sym->ts.u.derived->refs++;
12014 /* Unless the derived-type declaration is use associated, Fortran 95
12015 does not allow public entries of private derived types.
12016 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12017 161 in 95-006r3. */
12018 if (sym->ts.type == BT_DERIVED
12019 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12020 && !sym->ts.u.derived->attr.use_assoc
12021 && gfc_check_access (sym->attr.access, sym->ns->default_access)
12022 && !gfc_check_access (sym->ts.u.derived->attr.access,
12023 sym->ts.u.derived->ns->default_access)
12024 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12025 "of PRIVATE derived type '%s'",
12026 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12027 : "variable", sym->name, &sym->declared_at,
12028 sym->ts.u.derived->name) == FAILURE)
12031 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12032 default initialization is defined (5.1.2.4.4). */
12033 if (sym->ts.type == BT_DERIVED
12035 && sym->attr.intent == INTENT_OUT
12037 && sym->as->type == AS_ASSUMED_SIZE)
12039 for (c = sym->ts.u.derived->components; c; c = c->next)
12041 if (c->initializer)
12043 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12044 "ASSUMED SIZE and so cannot have a default initializer",
12045 sym->name, &sym->declared_at);
12052 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12053 || sym->attr.codimension)
12054 && sym->attr.result)
12055 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12056 "a coarray component", sym->name, &sym->declared_at);
12059 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12060 && sym->ts.u.derived->ts.is_iso_c)
12061 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12062 "shall not be a coarray", sym->name, &sym->declared_at);
12065 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
12066 && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
12067 || sym->attr.allocatable))
12068 gfc_error ("Variable '%s' at %L with coarray component "
12069 "shall be a nonpointer, nonallocatable scalar",
12070 sym->name, &sym->declared_at);
12072 /* F2008, C526. The function-result case was handled above. */
12073 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12074 || sym->attr.codimension)
12075 && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
12076 || sym->ns->proc_name->attr.flavor == FL_MODULE
12077 || sym->ns->proc_name->attr.is_main_program
12078 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12079 gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
12080 "component and is not ALLOCATABLE, SAVE nor a "
12081 "dummy argument", sym->name, &sym->declared_at);
12082 /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
12083 else if (sym->attr.codimension && !sym->attr.allocatable
12084 && sym->as && sym->as->cotype == AS_DEFERRED)
12085 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12086 "deferred shape", sym->name, &sym->declared_at);
12087 else if (sym->attr.codimension && sym->attr.allocatable
12088 && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
12089 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12090 "deferred shape", sym->name, &sym->declared_at);
12094 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12095 || (sym->attr.codimension && sym->attr.allocatable))
12096 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12097 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12098 "allocatable coarray or have coarray components",
12099 sym->name, &sym->declared_at);
12101 if (sym->attr.codimension && sym->attr.dummy
12102 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12103 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12104 "procedure '%s'", sym->name, &sym->declared_at,
12105 sym->ns->proc_name->name);
12107 switch (sym->attr.flavor)
12110 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12115 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12120 if (resolve_fl_namelist (sym) == FAILURE)
12125 if (resolve_fl_parameter (sym) == FAILURE)
12133 /* Resolve array specifier. Check as well some constraints
12134 on COMMON blocks. */
12136 check_constant = sym->attr.in_common && !sym->attr.pointer;
12138 /* Set the formal_arg_flag so that check_conflict will not throw
12139 an error for host associated variables in the specification
12140 expression for an array_valued function. */
12141 if (sym->attr.function && sym->as)
12142 formal_arg_flag = 1;
12144 gfc_resolve_array_spec (sym->as, check_constant);
12146 formal_arg_flag = 0;
12148 /* Resolve formal namespaces. */
12149 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12150 && !sym->attr.contained && !sym->attr.intrinsic)
12151 gfc_resolve (sym->formal_ns);
12153 /* Make sure the formal namespace is present. */
12154 if (sym->formal && !sym->formal_ns)
12156 gfc_formal_arglist *formal = sym->formal;
12157 while (formal && !formal->sym)
12158 formal = formal->next;
12162 sym->formal_ns = formal->sym->ns;
12163 sym->formal_ns->refs++;
12167 /* Check threadprivate restrictions. */
12168 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12169 && (!sym->attr.in_common
12170 && sym->module == NULL
12171 && (sym->ns->proc_name == NULL
12172 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12173 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12175 /* If we have come this far we can apply default-initializers, as
12176 described in 14.7.5, to those variables that have not already
12177 been assigned one. */
12178 if (sym->ts.type == BT_DERIVED
12179 && sym->ns == gfc_current_ns
12181 && !sym->attr.allocatable
12182 && !sym->attr.alloc_comp)
12184 symbol_attribute *a = &sym->attr;
12186 if ((!a->save && !a->dummy && !a->pointer
12187 && !a->in_common && !a->use_assoc
12188 && (a->referenced || a->result)
12189 && !(a->function && sym != sym->result))
12190 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12191 apply_default_init (sym);
12194 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
12195 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
12196 && !CLASS_DATA (sym)->attr.class_pointer
12197 && !CLASS_DATA (sym)->attr.allocatable)
12198 apply_default_init (sym);
12200 /* If this symbol has a type-spec, check it. */
12201 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12202 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12203 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12209 /************* Resolve DATA statements *************/
12213 gfc_data_value *vnode;
12219 /* Advance the values structure to point to the next value in the data list. */
12222 next_data_value (void)
12224 while (mpz_cmp_ui (values.left, 0) == 0)
12227 if (values.vnode->next == NULL)
12230 values.vnode = values.vnode->next;
12231 mpz_set (values.left, values.vnode->repeat);
12239 check_data_variable (gfc_data_variable *var, locus *where)
12245 ar_type mark = AR_UNKNOWN;
12247 mpz_t section_index[GFC_MAX_DIMENSIONS];
12253 if (gfc_resolve_expr (var->expr) == FAILURE)
12257 mpz_init_set_si (offset, 0);
12260 if (e->expr_type != EXPR_VARIABLE)
12261 gfc_internal_error ("check_data_variable(): Bad expression");
12263 sym = e->symtree->n.sym;
12265 if (sym->ns->is_block_data && !sym->attr.in_common)
12267 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12268 sym->name, &sym->declared_at);
12271 if (e->ref == NULL && sym->as)
12273 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12274 " declaration", sym->name, where);
12278 has_pointer = sym->attr.pointer;
12280 for (ref = e->ref; ref; ref = ref->next)
12282 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12285 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
12287 gfc_error ("DATA element '%s' at %L cannot have a coindex",
12293 && ref->type == REF_ARRAY
12294 && ref->u.ar.type != AR_FULL)
12296 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12297 "be a full array", sym->name, where);
12302 if (e->rank == 0 || has_pointer)
12304 mpz_init_set_ui (size, 1);
12311 /* Find the array section reference. */
12312 for (ref = e->ref; ref; ref = ref->next)
12314 if (ref->type != REF_ARRAY)
12316 if (ref->u.ar.type == AR_ELEMENT)
12322 /* Set marks according to the reference pattern. */
12323 switch (ref->u.ar.type)
12331 /* Get the start position of array section. */
12332 gfc_get_section_index (ar, section_index, &offset);
12337 gcc_unreachable ();
12340 if (gfc_array_size (e, &size) == FAILURE)
12342 gfc_error ("Nonconstant array section at %L in DATA statement",
12344 mpz_clear (offset);
12351 while (mpz_cmp_ui (size, 0) > 0)
12353 if (next_data_value () == FAILURE)
12355 gfc_error ("DATA statement at %L has more variables than values",
12361 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12365 /* If we have more than one element left in the repeat count,
12366 and we have more than one element left in the target variable,
12367 then create a range assignment. */
12368 /* FIXME: Only done for full arrays for now, since array sections
12370 if (mark == AR_FULL && ref && ref->next == NULL
12371 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12375 if (mpz_cmp (size, values.left) >= 0)
12377 mpz_init_set (range, values.left);
12378 mpz_sub (size, size, values.left);
12379 mpz_set_ui (values.left, 0);
12383 mpz_init_set (range, size);
12384 mpz_sub (values.left, values.left, size);
12385 mpz_set_ui (size, 0);
12388 t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
12391 mpz_add (offset, offset, range);
12398 /* Assign initial value to symbol. */
12401 mpz_sub_ui (values.left, values.left, 1);
12402 mpz_sub_ui (size, size, 1);
12404 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
12408 if (mark == AR_FULL)
12409 mpz_add_ui (offset, offset, 1);
12411 /* Modify the array section indexes and recalculate the offset
12412 for next element. */
12413 else if (mark == AR_SECTION)
12414 gfc_advance_section (section_index, ar, &offset);
12418 if (mark == AR_SECTION)
12420 for (i = 0; i < ar->dimen; i++)
12421 mpz_clear (section_index[i]);
12425 mpz_clear (offset);
12431 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
12433 /* Iterate over a list of elements in a DATA statement. */
12436 traverse_data_list (gfc_data_variable *var, locus *where)
12439 iterator_stack frame;
12440 gfc_expr *e, *start, *end, *step;
12441 gfc_try retval = SUCCESS;
12443 mpz_init (frame.value);
12446 start = gfc_copy_expr (var->iter.start);
12447 end = gfc_copy_expr (var->iter.end);
12448 step = gfc_copy_expr (var->iter.step);
12450 if (gfc_simplify_expr (start, 1) == FAILURE
12451 || start->expr_type != EXPR_CONSTANT)
12453 gfc_error ("start of implied-do loop at %L could not be "
12454 "simplified to a constant value", &start->where);
12458 if (gfc_simplify_expr (end, 1) == FAILURE
12459 || end->expr_type != EXPR_CONSTANT)
12461 gfc_error ("end of implied-do loop at %L could not be "
12462 "simplified to a constant value", &start->where);
12466 if (gfc_simplify_expr (step, 1) == FAILURE
12467 || step->expr_type != EXPR_CONSTANT)
12469 gfc_error ("step of implied-do loop at %L could not be "
12470 "simplified to a constant value", &start->where);
12475 mpz_set (trip, end->value.integer);
12476 mpz_sub (trip, trip, start->value.integer);
12477 mpz_add (trip, trip, step->value.integer);
12479 mpz_div (trip, trip, step->value.integer);
12481 mpz_set (frame.value, start->value.integer);
12483 frame.prev = iter_stack;
12484 frame.variable = var->iter.var->symtree;
12485 iter_stack = &frame;
12487 while (mpz_cmp_ui (trip, 0) > 0)
12489 if (traverse_data_var (var->list, where) == FAILURE)
12495 e = gfc_copy_expr (var->expr);
12496 if (gfc_simplify_expr (e, 1) == FAILURE)
12503 mpz_add (frame.value, frame.value, step->value.integer);
12505 mpz_sub_ui (trip, trip, 1);
12509 mpz_clear (frame.value);
12512 gfc_free_expr (start);
12513 gfc_free_expr (end);
12514 gfc_free_expr (step);
12516 iter_stack = frame.prev;
12521 /* Type resolve variables in the variable list of a DATA statement. */
12524 traverse_data_var (gfc_data_variable *var, locus *where)
12528 for (; var; var = var->next)
12530 if (var->expr == NULL)
12531 t = traverse_data_list (var, where);
12533 t = check_data_variable (var, where);
12543 /* Resolve the expressions and iterators associated with a data statement.
12544 This is separate from the assignment checking because data lists should
12545 only be resolved once. */
12548 resolve_data_variables (gfc_data_variable *d)
12550 for (; d; d = d->next)
12552 if (d->list == NULL)
12554 if (gfc_resolve_expr (d->expr) == FAILURE)
12559 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
12562 if (resolve_data_variables (d->list) == FAILURE)
12571 /* Resolve a single DATA statement. We implement this by storing a pointer to
12572 the value list into static variables, and then recursively traversing the
12573 variables list, expanding iterators and such. */
12576 resolve_data (gfc_data *d)
12579 if (resolve_data_variables (d->var) == FAILURE)
12582 values.vnode = d->value;
12583 if (d->value == NULL)
12584 mpz_set_ui (values.left, 0);
12586 mpz_set (values.left, d->value->repeat);
12588 if (traverse_data_var (d->var, &d->where) == FAILURE)
12591 /* At this point, we better not have any values left. */
12593 if (next_data_value () == SUCCESS)
12594 gfc_error ("DATA statement at %L has more values than variables",
12599 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
12600 accessed by host or use association, is a dummy argument to a pure function,
12601 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
12602 is storage associated with any such variable, shall not be used in the
12603 following contexts: (clients of this function). */
12605 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
12606 procedure. Returns zero if assignment is OK, nonzero if there is a
12609 gfc_impure_variable (gfc_symbol *sym)
12614 if (sym->attr.use_assoc || sym->attr.in_common)
12617 /* Check if the symbol's ns is inside the pure procedure. */
12618 for (ns = gfc_current_ns; ns; ns = ns->parent)
12622 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
12626 proc = sym->ns->proc_name;
12627 if (sym->attr.dummy && gfc_pure (proc)
12628 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
12630 proc->attr.function))
12633 /* TODO: Sort out what can be storage associated, if anything, and include
12634 it here. In principle equivalences should be scanned but it does not
12635 seem to be possible to storage associate an impure variable this way. */
12640 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
12641 current namespace is inside a pure procedure. */
12644 gfc_pure (gfc_symbol *sym)
12646 symbol_attribute attr;
12651 /* Check if the current namespace or one of its parents
12652 belongs to a pure procedure. */
12653 for (ns = gfc_current_ns; ns; ns = ns->parent)
12655 sym = ns->proc_name;
12659 if (attr.flavor == FL_PROCEDURE && attr.pure)
12667 return attr.flavor == FL_PROCEDURE && attr.pure;
12671 /* Test whether the current procedure is elemental or not. */
12674 gfc_elemental (gfc_symbol *sym)
12676 symbol_attribute attr;
12679 sym = gfc_current_ns->proc_name;
12684 return attr.flavor == FL_PROCEDURE && attr.elemental;
12688 /* Warn about unused labels. */
12691 warn_unused_fortran_label (gfc_st_label *label)
12696 warn_unused_fortran_label (label->left);
12698 if (label->defined == ST_LABEL_UNKNOWN)
12701 switch (label->referenced)
12703 case ST_LABEL_UNKNOWN:
12704 gfc_warning ("Label %d at %L defined but not used", label->value,
12708 case ST_LABEL_BAD_TARGET:
12709 gfc_warning ("Label %d at %L defined but cannot be used",
12710 label->value, &label->where);
12717 warn_unused_fortran_label (label->right);
12721 /* Returns the sequence type of a symbol or sequence. */
12724 sequence_type (gfc_typespec ts)
12733 if (ts.u.derived->components == NULL)
12734 return SEQ_NONDEFAULT;
12736 result = sequence_type (ts.u.derived->components->ts);
12737 for (c = ts.u.derived->components->next; c; c = c->next)
12738 if (sequence_type (c->ts) != result)
12744 if (ts.kind != gfc_default_character_kind)
12745 return SEQ_NONDEFAULT;
12747 return SEQ_CHARACTER;
12750 if (ts.kind != gfc_default_integer_kind)
12751 return SEQ_NONDEFAULT;
12753 return SEQ_NUMERIC;
12756 if (!(ts.kind == gfc_default_real_kind
12757 || ts.kind == gfc_default_double_kind))
12758 return SEQ_NONDEFAULT;
12760 return SEQ_NUMERIC;
12763 if (ts.kind != gfc_default_complex_kind)
12764 return SEQ_NONDEFAULT;
12766 return SEQ_NUMERIC;
12769 if (ts.kind != gfc_default_logical_kind)
12770 return SEQ_NONDEFAULT;
12772 return SEQ_NUMERIC;
12775 return SEQ_NONDEFAULT;
12780 /* Resolve derived type EQUIVALENCE object. */
12783 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
12785 gfc_component *c = derived->components;
12790 /* Shall not be an object of nonsequence derived type. */
12791 if (!derived->attr.sequence)
12793 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
12794 "attribute to be an EQUIVALENCE object", sym->name,
12799 /* Shall not have allocatable components. */
12800 if (derived->attr.alloc_comp)
12802 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
12803 "components to be an EQUIVALENCE object",sym->name,
12808 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
12810 gfc_error ("Derived type variable '%s' at %L with default "
12811 "initialization cannot be in EQUIVALENCE with a variable "
12812 "in COMMON", sym->name, &e->where);
12816 for (; c ; c = c->next)
12818 if (c->ts.type == BT_DERIVED
12819 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
12822 /* Shall not be an object of sequence derived type containing a pointer
12823 in the structure. */
12824 if (c->attr.pointer)
12826 gfc_error ("Derived type variable '%s' at %L with pointer "
12827 "component(s) cannot be an EQUIVALENCE object",
12828 sym->name, &e->where);
12836 /* Resolve equivalence object.
12837 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
12838 an allocatable array, an object of nonsequence derived type, an object of
12839 sequence derived type containing a pointer at any level of component
12840 selection, an automatic object, a function name, an entry name, a result
12841 name, a named constant, a structure component, or a subobject of any of
12842 the preceding objects. A substring shall not have length zero. A
12843 derived type shall not have components with default initialization nor
12844 shall two objects of an equivalence group be initialized.
12845 Either all or none of the objects shall have an protected attribute.
12846 The simple constraints are done in symbol.c(check_conflict) and the rest
12847 are implemented here. */
12850 resolve_equivalence (gfc_equiv *eq)
12853 gfc_symbol *first_sym;
12856 locus *last_where = NULL;
12857 seq_type eq_type, last_eq_type;
12858 gfc_typespec *last_ts;
12859 int object, cnt_protected;
12862 last_ts = &eq->expr->symtree->n.sym->ts;
12864 first_sym = eq->expr->symtree->n.sym;
12868 for (object = 1; eq; eq = eq->eq, object++)
12872 e->ts = e->symtree->n.sym->ts;
12873 /* match_varspec might not know yet if it is seeing
12874 array reference or substring reference, as it doesn't
12876 if (e->ref && e->ref->type == REF_ARRAY)
12878 gfc_ref *ref = e->ref;
12879 sym = e->symtree->n.sym;
12881 if (sym->attr.dimension)
12883 ref->u.ar.as = sym->as;
12887 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
12888 if (e->ts.type == BT_CHARACTER
12890 && ref->type == REF_ARRAY
12891 && ref->u.ar.dimen == 1
12892 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
12893 && ref->u.ar.stride[0] == NULL)
12895 gfc_expr *start = ref->u.ar.start[0];
12896 gfc_expr *end = ref->u.ar.end[0];
12899 /* Optimize away the (:) reference. */
12900 if (start == NULL && end == NULL)
12903 e->ref = ref->next;
12905 e->ref->next = ref->next;
12910 ref->type = REF_SUBSTRING;
12912 start = gfc_get_int_expr (gfc_default_integer_kind,
12914 ref->u.ss.start = start;
12915 if (end == NULL && e->ts.u.cl)
12916 end = gfc_copy_expr (e->ts.u.cl->length);
12917 ref->u.ss.end = end;
12918 ref->u.ss.length = e->ts.u.cl;
12925 /* Any further ref is an error. */
12928 gcc_assert (ref->type == REF_ARRAY);
12929 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
12935 if (gfc_resolve_expr (e) == FAILURE)
12938 sym = e->symtree->n.sym;
12940 if (sym->attr.is_protected)
12942 if (cnt_protected > 0 && cnt_protected != object)
12944 gfc_error ("Either all or none of the objects in the "
12945 "EQUIVALENCE set at %L shall have the "
12946 "PROTECTED attribute",
12951 /* Shall not equivalence common block variables in a PURE procedure. */
12952 if (sym->ns->proc_name
12953 && sym->ns->proc_name->attr.pure
12954 && sym->attr.in_common)
12956 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
12957 "object in the pure procedure '%s'",
12958 sym->name, &e->where, sym->ns->proc_name->name);
12962 /* Shall not be a named constant. */
12963 if (e->expr_type == EXPR_CONSTANT)
12965 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
12966 "object", sym->name, &e->where);
12970 if (e->ts.type == BT_DERIVED
12971 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
12974 /* Check that the types correspond correctly:
12976 A numeric sequence structure may be equivalenced to another sequence
12977 structure, an object of default integer type, default real type, double
12978 precision real type, default logical type such that components of the
12979 structure ultimately only become associated to objects of the same
12980 kind. A character sequence structure may be equivalenced to an object
12981 of default character kind or another character sequence structure.
12982 Other objects may be equivalenced only to objects of the same type and
12983 kind parameters. */
12985 /* Identical types are unconditionally OK. */
12986 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
12987 goto identical_types;
12989 last_eq_type = sequence_type (*last_ts);
12990 eq_type = sequence_type (sym->ts);
12992 /* Since the pair of objects is not of the same type, mixed or
12993 non-default sequences can be rejected. */
12995 msg = "Sequence %s with mixed components in EQUIVALENCE "
12996 "statement at %L with different type objects";
12998 && last_eq_type == SEQ_MIXED
12999 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
13001 || (eq_type == SEQ_MIXED
13002 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13003 &e->where) == FAILURE))
13006 msg = "Non-default type object or sequence %s in EQUIVALENCE "
13007 "statement at %L with objects of different type";
13009 && last_eq_type == SEQ_NONDEFAULT
13010 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
13011 last_where) == FAILURE)
13012 || (eq_type == SEQ_NONDEFAULT
13013 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13014 &e->where) == FAILURE))
13017 msg ="Non-CHARACTER object '%s' in default CHARACTER "
13018 "EQUIVALENCE statement at %L";
13019 if (last_eq_type == SEQ_CHARACTER
13020 && eq_type != SEQ_CHARACTER
13021 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13022 &e->where) == FAILURE)
13025 msg ="Non-NUMERIC object '%s' in default NUMERIC "
13026 "EQUIVALENCE statement at %L";
13027 if (last_eq_type == SEQ_NUMERIC
13028 && eq_type != SEQ_NUMERIC
13029 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13030 &e->where) == FAILURE)
13035 last_where = &e->where;
13040 /* Shall not be an automatic array. */
13041 if (e->ref->type == REF_ARRAY
13042 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
13044 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13045 "an EQUIVALENCE object", sym->name, &e->where);
13052 /* Shall not be a structure component. */
13053 if (r->type == REF_COMPONENT)
13055 gfc_error ("Structure component '%s' at %L cannot be an "
13056 "EQUIVALENCE object",
13057 r->u.c.component->name, &e->where);
13061 /* A substring shall not have length zero. */
13062 if (r->type == REF_SUBSTRING)
13064 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13066 gfc_error ("Substring at %L has length zero",
13067 &r->u.ss.start->where);
13077 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13080 resolve_fntype (gfc_namespace *ns)
13082 gfc_entry_list *el;
13085 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13088 /* If there are any entries, ns->proc_name is the entry master
13089 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13091 sym = ns->entries->sym;
13093 sym = ns->proc_name;
13094 if (sym->result == sym
13095 && sym->ts.type == BT_UNKNOWN
13096 && gfc_set_default_type (sym, 0, NULL) == FAILURE
13097 && !sym->attr.untyped)
13099 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13100 sym->name, &sym->declared_at);
13101 sym->attr.untyped = 1;
13104 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13105 && !sym->attr.contained
13106 && !gfc_check_access (sym->ts.u.derived->attr.access,
13107 sym->ts.u.derived->ns->default_access)
13108 && gfc_check_access (sym->attr.access, sym->ns->default_access))
13110 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13111 "%L of PRIVATE type '%s'", sym->name,
13112 &sym->declared_at, sym->ts.u.derived->name);
13116 for (el = ns->entries->next; el; el = el->next)
13118 if (el->sym->result == el->sym
13119 && el->sym->ts.type == BT_UNKNOWN
13120 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13121 && !el->sym->attr.untyped)
13123 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13124 el->sym->name, &el->sym->declared_at);
13125 el->sym->attr.untyped = 1;
13131 /* 12.3.2.1.1 Defined operators. */
13134 check_uop_procedure (gfc_symbol *sym, locus where)
13136 gfc_formal_arglist *formal;
13138 if (!sym->attr.function)
13140 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13141 sym->name, &where);
13145 if (sym->ts.type == BT_CHARACTER
13146 && !(sym->ts.u.cl && sym->ts.u.cl->length)
13147 && !(sym->result && sym->result->ts.u.cl
13148 && sym->result->ts.u.cl->length))
13150 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13151 "character length", sym->name, &where);
13155 formal = sym->formal;
13156 if (!formal || !formal->sym)
13158 gfc_error ("User operator procedure '%s' at %L must have at least "
13159 "one argument", sym->name, &where);
13163 if (formal->sym->attr.intent != INTENT_IN)
13165 gfc_error ("First argument of operator interface at %L must be "
13166 "INTENT(IN)", &where);
13170 if (formal->sym->attr.optional)
13172 gfc_error ("First argument of operator interface at %L cannot be "
13173 "optional", &where);
13177 formal = formal->next;
13178 if (!formal || !formal->sym)
13181 if (formal->sym->attr.intent != INTENT_IN)
13183 gfc_error ("Second argument of operator interface at %L must be "
13184 "INTENT(IN)", &where);
13188 if (formal->sym->attr.optional)
13190 gfc_error ("Second argument of operator interface at %L cannot be "
13191 "optional", &where);
13197 gfc_error ("Operator interface at %L must have, at most, two "
13198 "arguments", &where);
13206 gfc_resolve_uops (gfc_symtree *symtree)
13208 gfc_interface *itr;
13210 if (symtree == NULL)
13213 gfc_resolve_uops (symtree->left);
13214 gfc_resolve_uops (symtree->right);
13216 for (itr = symtree->n.uop->op; itr; itr = itr->next)
13217 check_uop_procedure (itr->sym, itr->sym->declared_at);
13221 /* Examine all of the expressions associated with a program unit,
13222 assign types to all intermediate expressions, make sure that all
13223 assignments are to compatible types and figure out which names
13224 refer to which functions or subroutines. It doesn't check code
13225 block, which is handled by resolve_code. */
13228 resolve_types (gfc_namespace *ns)
13234 gfc_namespace* old_ns = gfc_current_ns;
13236 /* Check that all IMPLICIT types are ok. */
13237 if (!ns->seen_implicit_none)
13240 for (letter = 0; letter != GFC_LETTERS; ++letter)
13241 if (ns->set_flag[letter]
13242 && resolve_typespec_used (&ns->default_type[letter],
13243 &ns->implicit_loc[letter],
13248 gfc_current_ns = ns;
13250 resolve_entries (ns);
13252 resolve_common_vars (ns->blank_common.head, false);
13253 resolve_common_blocks (ns->common_root);
13255 resolve_contained_functions (ns);
13257 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13259 for (cl = ns->cl_list; cl; cl = cl->next)
13260 resolve_charlen (cl);
13262 gfc_traverse_ns (ns, resolve_symbol);
13264 resolve_fntype (ns);
13266 for (n = ns->contained; n; n = n->sibling)
13268 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13269 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13270 "also be PURE", n->proc_name->name,
13271 &n->proc_name->declared_at);
13277 gfc_check_interfaces (ns);
13279 gfc_traverse_ns (ns, resolve_values);
13285 for (d = ns->data; d; d = d->next)
13289 gfc_traverse_ns (ns, gfc_formalize_init_value);
13291 gfc_traverse_ns (ns, gfc_verify_binding_labels);
13293 if (ns->common_root != NULL)
13294 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13296 for (eq = ns->equiv; eq; eq = eq->next)
13297 resolve_equivalence (eq);
13299 /* Warn about unused labels. */
13300 if (warn_unused_label)
13301 warn_unused_fortran_label (ns->st_labels);
13303 gfc_resolve_uops (ns->uop_root);
13305 gfc_current_ns = old_ns;
13309 /* Call resolve_code recursively. */
13312 resolve_codes (gfc_namespace *ns)
13315 bitmap_obstack old_obstack;
13317 for (n = ns->contained; n; n = n->sibling)
13320 gfc_current_ns = ns;
13322 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13323 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13326 /* Set to an out of range value. */
13327 current_entry_id = -1;
13329 old_obstack = labels_obstack;
13330 bitmap_obstack_initialize (&labels_obstack);
13332 resolve_code (ns->code, ns);
13334 bitmap_obstack_release (&labels_obstack);
13335 labels_obstack = old_obstack;
13339 /* This function is called after a complete program unit has been compiled.
13340 Its purpose is to examine all of the expressions associated with a program
13341 unit, assign types to all intermediate expressions, make sure that all
13342 assignments are to compatible types and figure out which names refer to
13343 which functions or subroutines. */
13346 gfc_resolve (gfc_namespace *ns)
13348 gfc_namespace *old_ns;
13349 code_stack *old_cs_base;
13355 old_ns = gfc_current_ns;
13356 old_cs_base = cs_base;
13358 resolve_types (ns);
13359 resolve_codes (ns);
13361 gfc_current_ns = old_ns;
13362 cs_base = old_cs_base;
13365 gfc_run_passes (ns);