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)
5408 base = extract_compcall_passed_object (e);
5412 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5414 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5416 gfc_error ("Base object for type-bound procedure call at %L is of"
5417 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5421 /* If the procedure called is NOPASS, the base object must be scalar. */
5422 if (e->value.compcall.tbp->nopass && base->rank > 0)
5424 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5425 " be scalar", &e->where);
5429 /* FIXME: Remove once PR 41177 (this problem) is fixed completely. */
5432 gfc_error ("Non-scalar base object at %L currently not implemented",
5441 /* Resolve a call to a type-bound procedure, either function or subroutine,
5442 statically from the data in an EXPR_COMPCALL expression. The adapted
5443 arglist and the target-procedure symtree are returned. */
5446 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5447 gfc_actual_arglist** actual)
5449 gcc_assert (e->expr_type == EXPR_COMPCALL);
5450 gcc_assert (!e->value.compcall.tbp->is_generic);
5452 /* Update the actual arglist for PASS. */
5453 if (update_compcall_arglist (e) == FAILURE)
5456 *actual = e->value.compcall.actual;
5457 *target = e->value.compcall.tbp->u.specific;
5459 gfc_free_ref_list (e->ref);
5461 e->value.compcall.actual = NULL;
5467 /* Get the ultimate declared type from an expression. In addition,
5468 return the last class/derived type reference and the copy of the
5471 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5474 gfc_symbol *declared;
5481 *new_ref = gfc_copy_ref (e->ref);
5483 for (ref = e->ref; ref; ref = ref->next)
5485 if (ref->type != REF_COMPONENT)
5488 if (ref->u.c.component->ts.type == BT_CLASS
5489 || ref->u.c.component->ts.type == BT_DERIVED)
5491 declared = ref->u.c.component->ts.u.derived;
5497 if (declared == NULL)
5498 declared = e->symtree->n.sym->ts.u.derived;
5504 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5505 which of the specific bindings (if any) matches the arglist and transform
5506 the expression into a call of that binding. */
5509 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5511 gfc_typebound_proc* genproc;
5512 const char* genname;
5514 gfc_symbol *derived;
5516 gcc_assert (e->expr_type == EXPR_COMPCALL);
5517 genname = e->value.compcall.name;
5518 genproc = e->value.compcall.tbp;
5520 if (!genproc->is_generic)
5523 /* Try the bindings on this type and in the inheritance hierarchy. */
5524 for (; genproc; genproc = genproc->overridden)
5528 gcc_assert (genproc->is_generic);
5529 for (g = genproc->u.generic; g; g = g->next)
5532 gfc_actual_arglist* args;
5535 gcc_assert (g->specific);
5537 if (g->specific->error)
5540 target = g->specific->u.specific->n.sym;
5542 /* Get the right arglist by handling PASS/NOPASS. */
5543 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5544 if (!g->specific->nopass)
5547 po = extract_compcall_passed_object (e);
5551 gcc_assert (g->specific->pass_arg_num > 0);
5552 gcc_assert (!g->specific->error);
5553 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5554 g->specific->pass_arg);
5556 resolve_actual_arglist (args, target->attr.proc,
5557 is_external_proc (target) && !target->formal);
5559 /* Check if this arglist matches the formal. */
5560 matches = gfc_arglist_matches_symbol (&args, target);
5562 /* Clean up and break out of the loop if we've found it. */
5563 gfc_free_actual_arglist (args);
5566 e->value.compcall.tbp = g->specific;
5567 genname = g->specific_st->name;
5568 /* Pass along the name for CLASS methods, where the vtab
5569 procedure pointer component has to be referenced. */
5577 /* Nothing matching found! */
5578 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5579 " '%s' at %L", genname, &e->where);
5583 /* Make sure that we have the right specific instance for the name. */
5584 derived = get_declared_from_expr (NULL, NULL, e);
5586 st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where);
5588 e->value.compcall.tbp = st->n.tb;
5594 /* Resolve a call to a type-bound subroutine. */
5597 resolve_typebound_call (gfc_code* c, const char **name)
5599 gfc_actual_arglist* newactual;
5600 gfc_symtree* target;
5602 /* Check that's really a SUBROUTINE. */
5603 if (!c->expr1->value.compcall.tbp->subroutine)
5605 gfc_error ("'%s' at %L should be a SUBROUTINE",
5606 c->expr1->value.compcall.name, &c->loc);
5610 if (check_typebound_baseobject (c->expr1) == FAILURE)
5613 /* Pass along the name for CLASS methods, where the vtab
5614 procedure pointer component has to be referenced. */
5616 *name = c->expr1->value.compcall.name;
5618 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5621 /* Transform into an ordinary EXEC_CALL for now. */
5623 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5626 c->ext.actual = newactual;
5627 c->symtree = target;
5628 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5630 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5632 gfc_free_expr (c->expr1);
5633 c->expr1 = gfc_get_expr ();
5634 c->expr1->expr_type = EXPR_FUNCTION;
5635 c->expr1->symtree = target;
5636 c->expr1->where = c->loc;
5638 return resolve_call (c);
5642 /* Resolve a component-call expression. */
5644 resolve_compcall (gfc_expr* e, const char **name)
5646 gfc_actual_arglist* newactual;
5647 gfc_symtree* target;
5649 /* Check that's really a FUNCTION. */
5650 if (!e->value.compcall.tbp->function)
5652 gfc_error ("'%s' at %L should be a FUNCTION",
5653 e->value.compcall.name, &e->where);
5657 /* These must not be assign-calls! */
5658 gcc_assert (!e->value.compcall.assign);
5660 if (check_typebound_baseobject (e) == FAILURE)
5663 /* Pass along the name for CLASS methods, where the vtab
5664 procedure pointer component has to be referenced. */
5666 *name = e->value.compcall.name;
5668 if (resolve_typebound_generic_call (e, name) == FAILURE)
5670 gcc_assert (!e->value.compcall.tbp->is_generic);
5672 /* Take the rank from the function's symbol. */
5673 if (e->value.compcall.tbp->u.specific->n.sym->as)
5674 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5676 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5677 arglist to the TBP's binding target. */
5679 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5682 e->value.function.actual = newactual;
5683 e->value.function.name = NULL;
5684 e->value.function.esym = target->n.sym;
5685 e->value.function.isym = NULL;
5686 e->symtree = target;
5687 e->ts = target->n.sym->ts;
5688 e->expr_type = EXPR_FUNCTION;
5690 /* Resolution is not necessary if this is a class subroutine; this
5691 function only has to identify the specific proc. Resolution of
5692 the call will be done next in resolve_typebound_call. */
5693 return gfc_resolve_expr (e);
5698 /* Resolve a typebound function, or 'method'. First separate all
5699 the non-CLASS references by calling resolve_compcall directly. */
5702 resolve_typebound_function (gfc_expr* e)
5704 gfc_symbol *declared;
5715 /* Deal with typebound operators for CLASS objects. */
5716 expr = e->value.compcall.base_object;
5717 if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
5718 && e->value.compcall.name)
5720 /* Since the typebound operators are generic, we have to ensure
5721 that any delays in resolution are corrected and that the vtab
5723 ts = expr->symtree->n.sym->ts;
5724 declared = ts.u.derived;
5725 c = gfc_find_component (declared, "$vptr", true, true);
5726 if (c->ts.u.derived == NULL)
5727 c->ts.u.derived = gfc_find_derived_vtab (declared);
5729 if (resolve_compcall (e, &name) == FAILURE)
5732 /* Use the generic name if it is there. */
5733 name = name ? name : e->value.function.esym->name;
5734 e->symtree = expr->symtree;
5735 expr->symtree->n.sym->ts.u.derived = declared;
5736 gfc_add_component_ref (e, "$vptr");
5737 gfc_add_component_ref (e, name);
5738 e->value.function.esym = NULL;
5743 return resolve_compcall (e, NULL);
5745 if (resolve_ref (e) == FAILURE)
5748 /* Get the CLASS declared type. */
5749 declared = get_declared_from_expr (&class_ref, &new_ref, e);
5751 /* Weed out cases of the ultimate component being a derived type. */
5752 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5753 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5755 gfc_free_ref_list (new_ref);
5756 return resolve_compcall (e, NULL);
5759 c = gfc_find_component (declared, "$data", true, true);
5760 declared = c->ts.u.derived;
5762 /* Treat the call as if it is a typebound procedure, in order to roll
5763 out the correct name for the specific function. */
5764 if (resolve_compcall (e, &name) == FAILURE)
5768 /* Then convert the expression to a procedure pointer component call. */
5769 e->value.function.esym = NULL;
5775 /* '$vptr' points to the vtab, which contains the procedure pointers. */
5776 gfc_add_component_ref (e, "$vptr");
5777 gfc_add_component_ref (e, name);
5779 /* Recover the typespec for the expression. This is really only
5780 necessary for generic procedures, where the additional call
5781 to gfc_add_component_ref seems to throw the collection of the
5782 correct typespec. */
5787 /* Resolve a typebound subroutine, or 'method'. First separate all
5788 the non-CLASS references by calling resolve_typebound_call
5792 resolve_typebound_subroutine (gfc_code *code)
5794 gfc_symbol *declared;
5803 st = code->expr1->symtree;
5805 /* Deal with typebound operators for CLASS objects. */
5806 expr = code->expr1->value.compcall.base_object;
5807 if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
5808 && code->expr1->value.compcall.name)
5810 /* Since the typebound operators are generic, we have to ensure
5811 that any delays in resolution are corrected and that the vtab
5813 ts = expr->symtree->n.sym->ts;
5814 declared = ts.u.derived;
5815 c = gfc_find_component (declared, "$vptr", true, true);
5816 if (c->ts.u.derived == NULL)
5817 c->ts.u.derived = gfc_find_derived_vtab (declared);
5819 if (resolve_typebound_call (code, &name) == FAILURE)
5822 /* Use the generic name if it is there. */
5823 name = name ? name : code->expr1->value.function.esym->name;
5824 code->expr1->symtree = expr->symtree;
5825 expr->symtree->n.sym->ts.u.derived = declared;
5826 gfc_add_component_ref (code->expr1, "$vptr");
5827 gfc_add_component_ref (code->expr1, name);
5828 code->expr1->value.function.esym = NULL;
5833 return resolve_typebound_call (code, NULL);
5835 if (resolve_ref (code->expr1) == FAILURE)
5838 /* Get the CLASS declared type. */
5839 get_declared_from_expr (&class_ref, &new_ref, code->expr1);
5841 /* Weed out cases of the ultimate component being a derived type. */
5842 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5843 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5845 gfc_free_ref_list (new_ref);
5846 return resolve_typebound_call (code, NULL);
5849 if (resolve_typebound_call (code, &name) == FAILURE)
5851 ts = code->expr1->ts;
5853 /* Then convert the expression to a procedure pointer component call. */
5854 code->expr1->value.function.esym = NULL;
5855 code->expr1->symtree = st;
5858 code->expr1->ref = new_ref;
5860 /* '$vptr' points to the vtab, which contains the procedure pointers. */
5861 gfc_add_component_ref (code->expr1, "$vptr");
5862 gfc_add_component_ref (code->expr1, name);
5864 /* Recover the typespec for the expression. This is really only
5865 necessary for generic procedures, where the additional call
5866 to gfc_add_component_ref seems to throw the collection of the
5867 correct typespec. */
5868 code->expr1->ts = ts;
5873 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5876 resolve_ppc_call (gfc_code* c)
5878 gfc_component *comp;
5881 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
5884 c->resolved_sym = c->expr1->symtree->n.sym;
5885 c->expr1->expr_type = EXPR_VARIABLE;
5887 if (!comp->attr.subroutine)
5888 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
5890 if (resolve_ref (c->expr1) == FAILURE)
5893 if (update_ppc_arglist (c->expr1) == FAILURE)
5896 c->ext.actual = c->expr1->value.compcall.actual;
5898 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
5899 comp->formal == NULL) == FAILURE)
5902 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
5908 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5911 resolve_expr_ppc (gfc_expr* e)
5913 gfc_component *comp;
5916 b = gfc_is_proc_ptr_comp (e, &comp);
5919 /* Convert to EXPR_FUNCTION. */
5920 e->expr_type = EXPR_FUNCTION;
5921 e->value.function.isym = NULL;
5922 e->value.function.actual = e->value.compcall.actual;
5924 if (comp->as != NULL)
5925 e->rank = comp->as->rank;
5927 if (!comp->attr.function)
5928 gfc_add_function (&comp->attr, comp->name, &e->where);
5930 if (resolve_ref (e) == FAILURE)
5933 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
5934 comp->formal == NULL) == FAILURE)
5937 if (update_ppc_arglist (e) == FAILURE)
5940 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
5947 gfc_is_expandable_expr (gfc_expr *e)
5949 gfc_constructor *con;
5951 if (e->expr_type == EXPR_ARRAY)
5953 /* Traverse the constructor looking for variables that are flavor
5954 parameter. Parameters must be expanded since they are fully used at
5956 con = gfc_constructor_first (e->value.constructor);
5957 for (; con; con = gfc_constructor_next (con))
5959 if (con->expr->expr_type == EXPR_VARIABLE
5960 && con->expr->symtree
5961 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
5962 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
5964 if (con->expr->expr_type == EXPR_ARRAY
5965 && gfc_is_expandable_expr (con->expr))
5973 /* Resolve an expression. That is, make sure that types of operands agree
5974 with their operators, intrinsic operators are converted to function calls
5975 for overloaded types and unresolved function references are resolved. */
5978 gfc_resolve_expr (gfc_expr *e)
5986 /* inquiry_argument only applies to variables. */
5987 inquiry_save = inquiry_argument;
5988 if (e->expr_type != EXPR_VARIABLE)
5989 inquiry_argument = false;
5991 switch (e->expr_type)
5994 t = resolve_operator (e);
6000 if (check_host_association (e))
6001 t = resolve_function (e);
6004 t = resolve_variable (e);
6006 expression_rank (e);
6009 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6010 && e->ref->type != REF_SUBSTRING)
6011 gfc_resolve_substring_charlen (e);
6016 t = resolve_typebound_function (e);
6019 case EXPR_SUBSTRING:
6020 t = resolve_ref (e);
6029 t = resolve_expr_ppc (e);
6034 if (resolve_ref (e) == FAILURE)
6037 t = gfc_resolve_array_constructor (e);
6038 /* Also try to expand a constructor. */
6041 expression_rank (e);
6042 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6043 gfc_expand_constructor (e, false);
6046 /* This provides the opportunity for the length of constructors with
6047 character valued function elements to propagate the string length
6048 to the expression. */
6049 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6051 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6052 here rather then add a duplicate test for it above. */
6053 gfc_expand_constructor (e, false);
6054 t = gfc_resolve_character_array_constructor (e);
6059 case EXPR_STRUCTURE:
6060 t = resolve_ref (e);
6064 t = resolve_structure_cons (e, 0);
6068 t = gfc_simplify_expr (e, 0);
6072 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6075 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6078 inquiry_argument = inquiry_save;
6084 /* Resolve an expression from an iterator. They must be scalar and have
6085 INTEGER or (optionally) REAL type. */
6088 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6089 const char *name_msgid)
6091 if (gfc_resolve_expr (expr) == FAILURE)
6094 if (expr->rank != 0)
6096 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6100 if (expr->ts.type != BT_INTEGER)
6102 if (expr->ts.type == BT_REAL)
6105 return gfc_notify_std (GFC_STD_F95_DEL,
6106 "Deleted feature: %s at %L must be integer",
6107 _(name_msgid), &expr->where);
6110 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6117 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6125 /* Resolve the expressions in an iterator structure. If REAL_OK is
6126 false allow only INTEGER type iterators, otherwise allow REAL types. */
6129 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6131 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6135 if (gfc_check_vardef_context (iter->var, false, _("iterator variable"))
6139 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6140 "Start expression in DO loop") == FAILURE)
6143 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6144 "End expression in DO loop") == FAILURE)
6147 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6148 "Step expression in DO loop") == FAILURE)
6151 if (iter->step->expr_type == EXPR_CONSTANT)
6153 if ((iter->step->ts.type == BT_INTEGER
6154 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6155 || (iter->step->ts.type == BT_REAL
6156 && mpfr_sgn (iter->step->value.real) == 0))
6158 gfc_error ("Step expression in DO loop at %L cannot be zero",
6159 &iter->step->where);
6164 /* Convert start, end, and step to the same type as var. */
6165 if (iter->start->ts.kind != iter->var->ts.kind
6166 || iter->start->ts.type != iter->var->ts.type)
6167 gfc_convert_type (iter->start, &iter->var->ts, 2);
6169 if (iter->end->ts.kind != iter->var->ts.kind
6170 || iter->end->ts.type != iter->var->ts.type)
6171 gfc_convert_type (iter->end, &iter->var->ts, 2);
6173 if (iter->step->ts.kind != iter->var->ts.kind
6174 || iter->step->ts.type != iter->var->ts.type)
6175 gfc_convert_type (iter->step, &iter->var->ts, 2);
6177 if (iter->start->expr_type == EXPR_CONSTANT
6178 && iter->end->expr_type == EXPR_CONSTANT
6179 && iter->step->expr_type == EXPR_CONSTANT)
6182 if (iter->start->ts.type == BT_INTEGER)
6184 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6185 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6189 sgn = mpfr_sgn (iter->step->value.real);
6190 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6192 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6193 gfc_warning ("DO loop at %L will be executed zero times",
6194 &iter->step->where);
6201 /* Traversal function for find_forall_index. f == 2 signals that
6202 that variable itself is not to be checked - only the references. */
6205 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6207 if (expr->expr_type != EXPR_VARIABLE)
6210 /* A scalar assignment */
6211 if (!expr->ref || *f == 1)
6213 if (expr->symtree->n.sym == sym)
6225 /* Check whether the FORALL index appears in the expression or not.
6226 Returns SUCCESS if SYM is found in EXPR. */
6229 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6231 if (gfc_traverse_expr (expr, sym, forall_index, f))
6238 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6239 to be a scalar INTEGER variable. The subscripts and stride are scalar
6240 INTEGERs, and if stride is a constant it must be nonzero.
6241 Furthermore "A subscript or stride in a forall-triplet-spec shall
6242 not contain a reference to any index-name in the
6243 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6246 resolve_forall_iterators (gfc_forall_iterator *it)
6248 gfc_forall_iterator *iter, *iter2;
6250 for (iter = it; iter; iter = iter->next)
6252 if (gfc_resolve_expr (iter->var) == SUCCESS
6253 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6254 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6257 if (gfc_resolve_expr (iter->start) == SUCCESS
6258 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6259 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6260 &iter->start->where);
6261 if (iter->var->ts.kind != iter->start->ts.kind)
6262 gfc_convert_type (iter->start, &iter->var->ts, 2);
6264 if (gfc_resolve_expr (iter->end) == SUCCESS
6265 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6266 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6268 if (iter->var->ts.kind != iter->end->ts.kind)
6269 gfc_convert_type (iter->end, &iter->var->ts, 2);
6271 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6273 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6274 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6275 &iter->stride->where, "INTEGER");
6277 if (iter->stride->expr_type == EXPR_CONSTANT
6278 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6279 gfc_error ("FORALL stride expression at %L cannot be zero",
6280 &iter->stride->where);
6282 if (iter->var->ts.kind != iter->stride->ts.kind)
6283 gfc_convert_type (iter->stride, &iter->var->ts, 2);
6286 for (iter = it; iter; iter = iter->next)
6287 for (iter2 = iter; iter2; iter2 = iter2->next)
6289 if (find_forall_index (iter2->start,
6290 iter->var->symtree->n.sym, 0) == SUCCESS
6291 || find_forall_index (iter2->end,
6292 iter->var->symtree->n.sym, 0) == SUCCESS
6293 || find_forall_index (iter2->stride,
6294 iter->var->symtree->n.sym, 0) == SUCCESS)
6295 gfc_error ("FORALL index '%s' may not appear in triplet "
6296 "specification at %L", iter->var->symtree->name,
6297 &iter2->start->where);
6302 /* Given a pointer to a symbol that is a derived type, see if it's
6303 inaccessible, i.e. if it's defined in another module and the components are
6304 PRIVATE. The search is recursive if necessary. Returns zero if no
6305 inaccessible components are found, nonzero otherwise. */
6308 derived_inaccessible (gfc_symbol *sym)
6312 if (sym->attr.use_assoc && sym->attr.private_comp)
6315 for (c = sym->components; c; c = c->next)
6317 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6325 /* Resolve the argument of a deallocate expression. The expression must be
6326 a pointer or a full array. */
6329 resolve_deallocate_expr (gfc_expr *e)
6331 symbol_attribute attr;
6332 int allocatable, pointer;
6337 if (gfc_resolve_expr (e) == FAILURE)
6340 if (e->expr_type != EXPR_VARIABLE)
6343 sym = e->symtree->n.sym;
6345 if (sym->ts.type == BT_CLASS)
6347 allocatable = CLASS_DATA (sym)->attr.allocatable;
6348 pointer = CLASS_DATA (sym)->attr.class_pointer;
6352 allocatable = sym->attr.allocatable;
6353 pointer = sym->attr.pointer;
6355 for (ref = e->ref; ref; ref = ref->next)
6360 if (ref->u.ar.type != AR_FULL)
6365 c = ref->u.c.component;
6366 if (c->ts.type == BT_CLASS)
6368 allocatable = CLASS_DATA (c)->attr.allocatable;
6369 pointer = CLASS_DATA (c)->attr.class_pointer;
6373 allocatable = c->attr.allocatable;
6374 pointer = c->attr.pointer;
6384 attr = gfc_expr_attr (e);
6386 if (allocatable == 0 && attr.pointer == 0)
6389 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6395 && gfc_check_vardef_context (e, true, _("DEALLOCATE object")) == FAILURE)
6397 if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE)
6400 if (e->ts.type == BT_CLASS)
6402 /* Only deallocate the DATA component. */
6403 gfc_add_component_ref (e, "$data");
6410 /* Returns true if the expression e contains a reference to the symbol sym. */
6412 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6414 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6421 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6423 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6427 /* Given the expression node e for an allocatable/pointer of derived type to be
6428 allocated, get the expression node to be initialized afterwards (needed for
6429 derived types with default initializers, and derived types with allocatable
6430 components that need nullification.) */
6433 gfc_expr_to_initialize (gfc_expr *e)
6439 result = gfc_copy_expr (e);
6441 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6442 for (ref = result->ref; ref; ref = ref->next)
6443 if (ref->type == REF_ARRAY && ref->next == NULL)
6445 ref->u.ar.type = AR_FULL;
6447 for (i = 0; i < ref->u.ar.dimen; i++)
6448 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6450 result->rank = ref->u.ar.dimen;
6458 /* If the last ref of an expression is an array ref, return a copy of the
6459 expression with that one removed. Otherwise, a copy of the original
6460 expression. This is used for allocate-expressions and pointer assignment
6461 LHS, where there may be an array specification that needs to be stripped
6462 off when using gfc_check_vardef_context. */
6465 remove_last_array_ref (gfc_expr* e)
6470 e2 = gfc_copy_expr (e);
6471 for (r = &e2->ref; *r; r = &(*r)->next)
6472 if ((*r)->type == REF_ARRAY && !(*r)->next)
6474 gfc_free_ref_list (*r);
6483 /* Used in resolve_allocate_expr to check that a allocation-object and
6484 a source-expr are conformable. This does not catch all possible
6485 cases; in particular a runtime checking is needed. */
6488 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6491 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6493 /* First compare rank. */
6494 if (tail && e1->rank != tail->u.ar.as->rank)
6496 gfc_error ("Source-expr at %L must be scalar or have the "
6497 "same rank as the allocate-object at %L",
6498 &e1->where, &e2->where);
6509 for (i = 0; i < e1->rank; i++)
6511 if (tail->u.ar.end[i])
6513 mpz_set (s, tail->u.ar.end[i]->value.integer);
6514 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6515 mpz_add_ui (s, s, 1);
6519 mpz_set (s, tail->u.ar.start[i]->value.integer);
6522 if (mpz_cmp (e1->shape[i], s) != 0)
6524 gfc_error ("Source-expr at %L and allocate-object at %L must "
6525 "have the same shape", &e1->where, &e2->where);
6538 /* Resolve the expression in an ALLOCATE statement, doing the additional
6539 checks to see whether the expression is OK or not. The expression must
6540 have a trailing array reference that gives the size of the array. */
6543 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6545 int i, pointer, allocatable, dimension, is_abstract;
6547 symbol_attribute attr;
6548 gfc_ref *ref, *ref2;
6551 gfc_symbol *sym = NULL;
6556 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6557 checking of coarrays. */
6558 for (ref = e->ref; ref; ref = ref->next)
6559 if (ref->next == NULL)
6562 if (ref && ref->type == REF_ARRAY)
6563 ref->u.ar.in_allocate = true;
6565 if (gfc_resolve_expr (e) == FAILURE)
6568 /* Make sure the expression is allocatable or a pointer. If it is
6569 pointer, the next-to-last reference must be a pointer. */
6573 sym = e->symtree->n.sym;
6575 /* Check whether ultimate component is abstract and CLASS. */
6578 if (e->expr_type != EXPR_VARIABLE)
6581 attr = gfc_expr_attr (e);
6582 pointer = attr.pointer;
6583 dimension = attr.dimension;
6584 codimension = attr.codimension;
6588 if (sym->ts.type == BT_CLASS)
6590 allocatable = CLASS_DATA (sym)->attr.allocatable;
6591 pointer = CLASS_DATA (sym)->attr.class_pointer;
6592 dimension = CLASS_DATA (sym)->attr.dimension;
6593 codimension = CLASS_DATA (sym)->attr.codimension;
6594 is_abstract = CLASS_DATA (sym)->attr.abstract;
6598 allocatable = sym->attr.allocatable;
6599 pointer = sym->attr.pointer;
6600 dimension = sym->attr.dimension;
6601 codimension = sym->attr.codimension;
6604 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6609 if (ref->next != NULL)
6615 if (gfc_is_coindexed (e))
6617 gfc_error ("Coindexed allocatable object at %L",
6622 c = ref->u.c.component;
6623 if (c->ts.type == BT_CLASS)
6625 allocatable = CLASS_DATA (c)->attr.allocatable;
6626 pointer = CLASS_DATA (c)->attr.class_pointer;
6627 dimension = CLASS_DATA (c)->attr.dimension;
6628 codimension = CLASS_DATA (c)->attr.codimension;
6629 is_abstract = CLASS_DATA (c)->attr.abstract;
6633 allocatable = c->attr.allocatable;
6634 pointer = c->attr.pointer;
6635 dimension = c->attr.dimension;
6636 codimension = c->attr.codimension;
6637 is_abstract = c->attr.abstract;
6649 if (allocatable == 0 && pointer == 0)
6651 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6656 /* Some checks for the SOURCE tag. */
6659 /* Check F03:C631. */
6660 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6662 gfc_error ("Type of entity at %L is type incompatible with "
6663 "source-expr at %L", &e->where, &code->expr3->where);
6667 /* Check F03:C632 and restriction following Note 6.18. */
6668 if (code->expr3->rank > 0
6669 && conformable_arrays (code->expr3, e) == FAILURE)
6672 /* Check F03:C633. */
6673 if (code->expr3->ts.kind != e->ts.kind)
6675 gfc_error ("The allocate-object at %L and the source-expr at %L "
6676 "shall have the same kind type parameter",
6677 &e->where, &code->expr3->where);
6682 /* Check F08:C629. */
6683 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
6686 gcc_assert (e->ts.type == BT_CLASS);
6687 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6688 "type-spec or source-expr", sym->name, &e->where);
6692 /* In the variable definition context checks, gfc_expr_attr is used
6693 on the expression. This is fooled by the array specification
6694 present in e, thus we have to eliminate that one temporarily. */
6695 e2 = remove_last_array_ref (e);
6697 if (t == SUCCESS && pointer)
6698 t = gfc_check_vardef_context (e2, true, _("ALLOCATE object"));
6700 t = gfc_check_vardef_context (e2, false, _("ALLOCATE object"));
6707 /* Set up default initializer if needed. */
6711 if (code->ext.alloc.ts.type == BT_DERIVED)
6712 ts = code->ext.alloc.ts;
6716 if (ts.type == BT_CLASS)
6717 ts = ts.u.derived->components->ts;
6719 if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
6721 gfc_code *init_st = gfc_get_code ();
6722 init_st->loc = code->loc;
6723 init_st->op = EXEC_INIT_ASSIGN;
6724 init_st->expr1 = gfc_expr_to_initialize (e);
6725 init_st->expr2 = init_e;
6726 init_st->next = code->next;
6727 code->next = init_st;
6730 else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
6732 /* Default initialization via MOLD (non-polymorphic). */
6733 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
6734 gfc_resolve_expr (rhs);
6735 gfc_free_expr (code->expr3);
6739 if (e->ts.type == BT_CLASS)
6741 /* Make sure the vtab symbol is present when
6742 the module variables are generated. */
6743 gfc_typespec ts = e->ts;
6745 ts = code->expr3->ts;
6746 else if (code->ext.alloc.ts.type == BT_DERIVED)
6747 ts = code->ext.alloc.ts;
6748 gfc_find_derived_vtab (ts.u.derived);
6751 if (pointer || (dimension == 0 && codimension == 0))
6754 /* Make sure the last reference node is an array specifiction. */
6756 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
6757 || (dimension && ref2->u.ar.dimen == 0))
6759 gfc_error ("Array specification required in ALLOCATE statement "
6760 "at %L", &e->where);
6764 /* Make sure that the array section reference makes sense in the
6765 context of an ALLOCATE specification. */
6769 if (codimension && ar->codimen == 0)
6771 gfc_error ("Coarray specification required in ALLOCATE statement "
6772 "at %L", &e->where);
6776 for (i = 0; i < ar->dimen; i++)
6778 if (ref2->u.ar.type == AR_ELEMENT)
6781 switch (ar->dimen_type[i])
6787 if (ar->start[i] != NULL
6788 && ar->end[i] != NULL
6789 && ar->stride[i] == NULL)
6792 /* Fall Through... */
6797 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6803 for (a = code->ext.alloc.list; a; a = a->next)
6805 sym = a->expr->symtree->n.sym;
6807 /* TODO - check derived type components. */
6808 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6811 if ((ar->start[i] != NULL
6812 && gfc_find_sym_in_expr (sym, ar->start[i]))
6813 || (ar->end[i] != NULL
6814 && gfc_find_sym_in_expr (sym, ar->end[i])))
6816 gfc_error ("'%s' must not appear in the array specification at "
6817 "%L in the same ALLOCATE statement where it is "
6818 "itself allocated", sym->name, &ar->where);
6824 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
6826 if (ar->dimen_type[i] == DIMEN_ELEMENT
6827 || ar->dimen_type[i] == DIMEN_RANGE)
6829 if (i == (ar->dimen + ar->codimen - 1))
6831 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
6832 "statement at %L", &e->where);
6838 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
6839 && ar->stride[i] == NULL)
6842 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
6847 if (codimension && ar->as->rank == 0)
6849 gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
6850 "at %L", &e->where);
6862 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
6864 gfc_expr *stat, *errmsg, *pe, *qe;
6865 gfc_alloc *a, *p, *q;
6868 errmsg = code->expr2;
6870 /* Check the stat variable. */
6873 gfc_check_vardef_context (stat, false, _("STAT variable"));
6875 if ((stat->ts.type != BT_INTEGER
6876 && !(stat->ref && (stat->ref->type == REF_ARRAY
6877 || stat->ref->type == REF_COMPONENT)))
6879 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
6880 "variable", &stat->where);
6882 for (p = code->ext.alloc.list; p; p = p->next)
6883 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
6885 gfc_ref *ref1, *ref2;
6888 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
6889 ref1 = ref1->next, ref2 = ref2->next)
6891 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6893 if (ref1->u.c.component->name != ref2->u.c.component->name)
6902 gfc_error ("Stat-variable at %L shall not be %sd within "
6903 "the same %s statement", &stat->where, fcn, fcn);
6909 /* Check the errmsg variable. */
6913 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
6916 gfc_check_vardef_context (errmsg, false, _("ERRMSG variable"));
6918 if ((errmsg->ts.type != BT_CHARACTER
6920 && (errmsg->ref->type == REF_ARRAY
6921 || errmsg->ref->type == REF_COMPONENT)))
6922 || errmsg->rank > 0 )
6923 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
6924 "variable", &errmsg->where);
6926 for (p = code->ext.alloc.list; p; p = p->next)
6927 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
6929 gfc_ref *ref1, *ref2;
6932 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
6933 ref1 = ref1->next, ref2 = ref2->next)
6935 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6937 if (ref1->u.c.component->name != ref2->u.c.component->name)
6946 gfc_error ("Errmsg-variable at %L shall not be %sd within "
6947 "the same %s statement", &errmsg->where, fcn, fcn);
6953 /* Check that an allocate-object appears only once in the statement.
6954 FIXME: Checking derived types is disabled. */
6955 for (p = code->ext.alloc.list; p; p = p->next)
6958 if ((pe->ref && pe->ref->type != REF_COMPONENT)
6959 && (pe->symtree->n.sym->ts.type != BT_DERIVED))
6961 for (q = p->next; q; q = q->next)
6964 if ((qe->ref && qe->ref->type != REF_COMPONENT)
6965 && (qe->symtree->n.sym->ts.type != BT_DERIVED)
6966 && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
6967 gfc_error ("Allocate-object at %L also appears at %L",
6968 &pe->where, &qe->where);
6973 if (strcmp (fcn, "ALLOCATE") == 0)
6975 for (a = code->ext.alloc.list; a; a = a->next)
6976 resolve_allocate_expr (a->expr, code);
6980 for (a = code->ext.alloc.list; a; a = a->next)
6981 resolve_deallocate_expr (a->expr);
6986 /************ SELECT CASE resolution subroutines ************/
6988 /* Callback function for our mergesort variant. Determines interval
6989 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
6990 op1 > op2. Assumes we're not dealing with the default case.
6991 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
6992 There are nine situations to check. */
6995 compare_cases (const gfc_case *op1, const gfc_case *op2)
6999 if (op1->low == NULL) /* op1 = (:L) */
7001 /* op2 = (:N), so overlap. */
7003 /* op2 = (M:) or (M:N), L < M */
7004 if (op2->low != NULL
7005 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7008 else if (op1->high == NULL) /* op1 = (K:) */
7010 /* op2 = (M:), so overlap. */
7012 /* op2 = (:N) or (M:N), K > N */
7013 if (op2->high != NULL
7014 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7017 else /* op1 = (K:L) */
7019 if (op2->low == NULL) /* op2 = (:N), K > N */
7020 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7022 else if (op2->high == NULL) /* op2 = (M:), L < M */
7023 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7025 else /* op2 = (M:N) */
7029 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7032 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7041 /* Merge-sort a double linked case list, detecting overlap in the
7042 process. LIST is the head of the double linked case list before it
7043 is sorted. Returns the head of the sorted list if we don't see any
7044 overlap, or NULL otherwise. */
7047 check_case_overlap (gfc_case *list)
7049 gfc_case *p, *q, *e, *tail;
7050 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7052 /* If the passed list was empty, return immediately. */
7059 /* Loop unconditionally. The only exit from this loop is a return
7060 statement, when we've finished sorting the case list. */
7067 /* Count the number of merges we do in this pass. */
7070 /* Loop while there exists a merge to be done. */
7075 /* Count this merge. */
7078 /* Cut the list in two pieces by stepping INSIZE places
7079 forward in the list, starting from P. */
7082 for (i = 0; i < insize; i++)
7091 /* Now we have two lists. Merge them! */
7092 while (psize > 0 || (qsize > 0 && q != NULL))
7094 /* See from which the next case to merge comes from. */
7097 /* P is empty so the next case must come from Q. */
7102 else if (qsize == 0 || q == NULL)
7111 cmp = compare_cases (p, q);
7114 /* The whole case range for P is less than the
7122 /* The whole case range for Q is greater than
7123 the case range for P. */
7130 /* The cases overlap, or they are the same
7131 element in the list. Either way, we must
7132 issue an error and get the next case from P. */
7133 /* FIXME: Sort P and Q by line number. */
7134 gfc_error ("CASE label at %L overlaps with CASE "
7135 "label at %L", &p->where, &q->where);
7143 /* Add the next element to the merged list. */
7152 /* P has now stepped INSIZE places along, and so has Q. So
7153 they're the same. */
7158 /* If we have done only one merge or none at all, we've
7159 finished sorting the cases. */
7168 /* Otherwise repeat, merging lists twice the size. */
7174 /* Check to see if an expression is suitable for use in a CASE statement.
7175 Makes sure that all case expressions are scalar constants of the same
7176 type. Return FAILURE if anything is wrong. */
7179 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7181 if (e == NULL) return SUCCESS;
7183 if (e->ts.type != case_expr->ts.type)
7185 gfc_error ("Expression in CASE statement at %L must be of type %s",
7186 &e->where, gfc_basic_typename (case_expr->ts.type));
7190 /* C805 (R808) For a given case-construct, each case-value shall be of
7191 the same type as case-expr. For character type, length differences
7192 are allowed, but the kind type parameters shall be the same. */
7194 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7196 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7197 &e->where, case_expr->ts.kind);
7201 /* Convert the case value kind to that of case expression kind,
7204 if (e->ts.kind != case_expr->ts.kind)
7205 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7209 gfc_error ("Expression in CASE statement at %L must be scalar",
7218 /* Given a completely parsed select statement, we:
7220 - Validate all expressions and code within the SELECT.
7221 - Make sure that the selection expression is not of the wrong type.
7222 - Make sure that no case ranges overlap.
7223 - Eliminate unreachable cases and unreachable code resulting from
7224 removing case labels.
7226 The standard does allow unreachable cases, e.g. CASE (5:3). But
7227 they are a hassle for code generation, and to prevent that, we just
7228 cut them out here. This is not necessary for overlapping cases
7229 because they are illegal and we never even try to generate code.
7231 We have the additional caveat that a SELECT construct could have
7232 been a computed GOTO in the source code. Fortunately we can fairly
7233 easily work around that here: The case_expr for a "real" SELECT CASE
7234 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7235 we have to do is make sure that the case_expr is a scalar integer
7239 resolve_select (gfc_code *code)
7242 gfc_expr *case_expr;
7243 gfc_case *cp, *default_case, *tail, *head;
7244 int seen_unreachable;
7250 if (code->expr1 == NULL)
7252 /* This was actually a computed GOTO statement. */
7253 case_expr = code->expr2;
7254 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7255 gfc_error ("Selection expression in computed GOTO statement "
7256 "at %L must be a scalar integer expression",
7259 /* Further checking is not necessary because this SELECT was built
7260 by the compiler, so it should always be OK. Just move the
7261 case_expr from expr2 to expr so that we can handle computed
7262 GOTOs as normal SELECTs from here on. */
7263 code->expr1 = code->expr2;
7268 case_expr = code->expr1;
7270 type = case_expr->ts.type;
7271 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7273 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7274 &case_expr->where, gfc_typename (&case_expr->ts));
7276 /* Punt. Going on here just produce more garbage error messages. */
7280 if (case_expr->rank != 0)
7282 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7283 "expression", &case_expr->where);
7290 /* Raise a warning if an INTEGER case value exceeds the range of
7291 the case-expr. Later, all expressions will be promoted to the
7292 largest kind of all case-labels. */
7294 if (type == BT_INTEGER)
7295 for (body = code->block; body; body = body->block)
7296 for (cp = body->ext.case_list; cp; cp = cp->next)
7299 && gfc_check_integer_range (cp->low->value.integer,
7300 case_expr->ts.kind) != ARITH_OK)
7301 gfc_warning ("Expression in CASE statement at %L is "
7302 "not in the range of %s", &cp->low->where,
7303 gfc_typename (&case_expr->ts));
7306 && cp->low != cp->high
7307 && gfc_check_integer_range (cp->high->value.integer,
7308 case_expr->ts.kind) != ARITH_OK)
7309 gfc_warning ("Expression in CASE statement at %L is "
7310 "not in the range of %s", &cp->high->where,
7311 gfc_typename (&case_expr->ts));
7314 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7315 of the SELECT CASE expression and its CASE values. Walk the lists
7316 of case values, and if we find a mismatch, promote case_expr to
7317 the appropriate kind. */
7319 if (type == BT_LOGICAL || type == BT_INTEGER)
7321 for (body = code->block; body; body = body->block)
7323 /* Walk the case label list. */
7324 for (cp = body->ext.case_list; cp; cp = cp->next)
7326 /* Intercept the DEFAULT case. It does not have a kind. */
7327 if (cp->low == NULL && cp->high == NULL)
7330 /* Unreachable case ranges are discarded, so ignore. */
7331 if (cp->low != NULL && cp->high != NULL
7332 && cp->low != cp->high
7333 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7337 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7338 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7340 if (cp->high != NULL
7341 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7342 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7347 /* Assume there is no DEFAULT case. */
7348 default_case = NULL;
7353 for (body = code->block; body; body = body->block)
7355 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7357 seen_unreachable = 0;
7359 /* Walk the case label list, making sure that all case labels
7361 for (cp = body->ext.case_list; cp; cp = cp->next)
7363 /* Count the number of cases in the whole construct. */
7366 /* Intercept the DEFAULT case. */
7367 if (cp->low == NULL && cp->high == NULL)
7369 if (default_case != NULL)
7371 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7372 "by a second DEFAULT CASE at %L",
7373 &default_case->where, &cp->where);
7384 /* Deal with single value cases and case ranges. Errors are
7385 issued from the validation function. */
7386 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7387 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7393 if (type == BT_LOGICAL
7394 && ((cp->low == NULL || cp->high == NULL)
7395 || cp->low != cp->high))
7397 gfc_error ("Logical range in CASE statement at %L is not "
7398 "allowed", &cp->low->where);
7403 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7406 value = cp->low->value.logical == 0 ? 2 : 1;
7407 if (value & seen_logical)
7409 gfc_error ("Constant logical value in CASE statement "
7410 "is repeated at %L",
7415 seen_logical |= value;
7418 if (cp->low != NULL && cp->high != NULL
7419 && cp->low != cp->high
7420 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7422 if (gfc_option.warn_surprising)
7423 gfc_warning ("Range specification at %L can never "
7424 "be matched", &cp->where);
7426 cp->unreachable = 1;
7427 seen_unreachable = 1;
7431 /* If the case range can be matched, it can also overlap with
7432 other cases. To make sure it does not, we put it in a
7433 double linked list here. We sort that with a merge sort
7434 later on to detect any overlapping cases. */
7438 head->right = head->left = NULL;
7443 tail->right->left = tail;
7450 /* It there was a failure in the previous case label, give up
7451 for this case label list. Continue with the next block. */
7455 /* See if any case labels that are unreachable have been seen.
7456 If so, we eliminate them. This is a bit of a kludge because
7457 the case lists for a single case statement (label) is a
7458 single forward linked lists. */
7459 if (seen_unreachable)
7461 /* Advance until the first case in the list is reachable. */
7462 while (body->ext.case_list != NULL
7463 && body->ext.case_list->unreachable)
7465 gfc_case *n = body->ext.case_list;
7466 body->ext.case_list = body->ext.case_list->next;
7468 gfc_free_case_list (n);
7471 /* Strip all other unreachable cases. */
7472 if (body->ext.case_list)
7474 for (cp = body->ext.case_list; cp->next; cp = cp->next)
7476 if (cp->next->unreachable)
7478 gfc_case *n = cp->next;
7479 cp->next = cp->next->next;
7481 gfc_free_case_list (n);
7488 /* See if there were overlapping cases. If the check returns NULL,
7489 there was overlap. In that case we don't do anything. If head
7490 is non-NULL, we prepend the DEFAULT case. The sorted list can
7491 then used during code generation for SELECT CASE constructs with
7492 a case expression of a CHARACTER type. */
7495 head = check_case_overlap (head);
7497 /* Prepend the default_case if it is there. */
7498 if (head != NULL && default_case)
7500 default_case->left = NULL;
7501 default_case->right = head;
7502 head->left = default_case;
7506 /* Eliminate dead blocks that may be the result if we've seen
7507 unreachable case labels for a block. */
7508 for (body = code; body && body->block; body = body->block)
7510 if (body->block->ext.case_list == NULL)
7512 /* Cut the unreachable block from the code chain. */
7513 gfc_code *c = body->block;
7514 body->block = c->block;
7516 /* Kill the dead block, but not the blocks below it. */
7518 gfc_free_statements (c);
7522 /* More than two cases is legal but insane for logical selects.
7523 Issue a warning for it. */
7524 if (gfc_option.warn_surprising && type == BT_LOGICAL
7526 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7531 /* Check if a derived type is extensible. */
7534 gfc_type_is_extensible (gfc_symbol *sym)
7536 return !(sym->attr.is_bind_c || sym->attr.sequence);
7540 /* Resolve an associate name: Resolve target and ensure the type-spec is
7541 correct as well as possibly the array-spec. */
7544 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
7548 gcc_assert (sym->assoc);
7549 gcc_assert (sym->attr.flavor == FL_VARIABLE);
7551 /* If this is for SELECT TYPE, the target may not yet be set. In that
7552 case, return. Resolution will be called later manually again when
7554 target = sym->assoc->target;
7557 gcc_assert (!sym->assoc->dangling);
7559 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
7562 /* For variable targets, we get some attributes from the target. */
7563 if (target->expr_type == EXPR_VARIABLE)
7567 gcc_assert (target->symtree);
7568 tsym = target->symtree->n.sym;
7570 sym->attr.asynchronous = tsym->attr.asynchronous;
7571 sym->attr.volatile_ = tsym->attr.volatile_;
7573 sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
7576 /* Get type if this was not already set. Note that it can be
7577 some other type than the target in case this is a SELECT TYPE
7578 selector! So we must not update when the type is already there. */
7579 if (sym->ts.type == BT_UNKNOWN)
7580 sym->ts = target->ts;
7581 gcc_assert (sym->ts.type != BT_UNKNOWN);
7583 /* See if this is a valid association-to-variable. */
7584 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
7585 && !gfc_has_vector_subscript (target));
7587 /* Finally resolve if this is an array or not. */
7588 if (sym->attr.dimension && target->rank == 0)
7590 gfc_error ("Associate-name '%s' at %L is used as array",
7591 sym->name, &sym->declared_at);
7592 sym->attr.dimension = 0;
7595 if (target->rank > 0)
7596 sym->attr.dimension = 1;
7598 if (sym->attr.dimension)
7600 sym->as = gfc_get_array_spec ();
7601 sym->as->rank = target->rank;
7602 sym->as->type = AS_DEFERRED;
7604 /* Target must not be coindexed, thus the associate-variable
7606 sym->as->corank = 0;
7611 /* Resolve a SELECT TYPE statement. */
7614 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
7616 gfc_symbol *selector_type;
7617 gfc_code *body, *new_st, *if_st, *tail;
7618 gfc_code *class_is = NULL, *default_case = NULL;
7621 char name[GFC_MAX_SYMBOL_LEN];
7625 ns = code->ext.block.ns;
7628 /* Check for F03:C813. */
7629 if (code->expr1->ts.type != BT_CLASS
7630 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
7632 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7633 "at %L", &code->loc);
7639 if (code->expr1->symtree->n.sym->attr.untyped)
7640 code->expr1->symtree->n.sym->ts = code->expr2->ts;
7641 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
7644 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
7646 /* Loop over TYPE IS / CLASS IS cases. */
7647 for (body = code->block; body; body = body->block)
7649 c = body->ext.case_list;
7651 /* Check F03:C815. */
7652 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7653 && !gfc_type_is_extensible (c->ts.u.derived))
7655 gfc_error ("Derived type '%s' at %L must be extensible",
7656 c->ts.u.derived->name, &c->where);
7661 /* Check F03:C816. */
7662 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7663 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
7665 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7666 c->ts.u.derived->name, &c->where, selector_type->name);
7671 /* Intercept the DEFAULT case. */
7672 if (c->ts.type == BT_UNKNOWN)
7674 /* Check F03:C818. */
7677 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7678 "by a second DEFAULT CASE at %L",
7679 &default_case->ext.case_list->where, &c->where);
7684 default_case = body;
7691 /* Transform SELECT TYPE statement to BLOCK and associate selector to
7692 target if present. If there are any EXIT statements referring to the
7693 SELECT TYPE construct, this is no problem because the gfc_code
7694 reference stays the same and EXIT is equally possible from the BLOCK
7695 it is changed to. */
7696 code->op = EXEC_BLOCK;
7699 gfc_association_list* assoc;
7701 assoc = gfc_get_association_list ();
7702 assoc->st = code->expr1->symtree;
7703 assoc->target = gfc_copy_expr (code->expr2);
7704 /* assoc->variable will be set by resolve_assoc_var. */
7706 code->ext.block.assoc = assoc;
7707 code->expr1->symtree->n.sym->assoc = assoc;
7709 resolve_assoc_var (code->expr1->symtree->n.sym, false);
7712 code->ext.block.assoc = NULL;
7714 /* Add EXEC_SELECT to switch on type. */
7715 new_st = gfc_get_code ();
7716 new_st->op = code->op;
7717 new_st->expr1 = code->expr1;
7718 new_st->expr2 = code->expr2;
7719 new_st->block = code->block;
7720 code->expr1 = code->expr2 = NULL;
7725 ns->code->next = new_st;
7727 code->op = EXEC_SELECT;
7728 gfc_add_component_ref (code->expr1, "$vptr");
7729 gfc_add_component_ref (code->expr1, "$hash");
7731 /* Loop over TYPE IS / CLASS IS cases. */
7732 for (body = code->block; body; body = body->block)
7734 c = body->ext.case_list;
7736 if (c->ts.type == BT_DERIVED)
7737 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7738 c->ts.u.derived->hash_value);
7740 else if (c->ts.type == BT_UNKNOWN)
7743 /* Associate temporary to selector. This should only be done
7744 when this case is actually true, so build a new ASSOCIATE
7745 that does precisely this here (instead of using the
7748 if (c->ts.type == BT_CLASS)
7749 sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
7751 sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
7752 st = gfc_find_symtree (ns->sym_root, name);
7753 gcc_assert (st->n.sym->assoc);
7754 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
7755 if (c->ts.type == BT_DERIVED)
7756 gfc_add_component_ref (st->n.sym->assoc->target, "$data");
7758 new_st = gfc_get_code ();
7759 new_st->op = EXEC_BLOCK;
7760 new_st->ext.block.ns = gfc_build_block_ns (ns);
7761 new_st->ext.block.ns->code = body->next;
7762 body->next = new_st;
7764 /* Chain in the new list only if it is marked as dangling. Otherwise
7765 there is a CASE label overlap and this is already used. Just ignore,
7766 the error is diagonsed elsewhere. */
7767 if (st->n.sym->assoc->dangling)
7769 new_st->ext.block.assoc = st->n.sym->assoc;
7770 st->n.sym->assoc->dangling = 0;
7773 resolve_assoc_var (st->n.sym, false);
7776 /* Take out CLASS IS cases for separate treatment. */
7778 while (body && body->block)
7780 if (body->block->ext.case_list->ts.type == BT_CLASS)
7782 /* Add to class_is list. */
7783 if (class_is == NULL)
7785 class_is = body->block;
7790 for (tail = class_is; tail->block; tail = tail->block) ;
7791 tail->block = body->block;
7794 /* Remove from EXEC_SELECT list. */
7795 body->block = body->block->block;
7808 /* Add a default case to hold the CLASS IS cases. */
7809 for (tail = code; tail->block; tail = tail->block) ;
7810 tail->block = gfc_get_code ();
7812 tail->op = EXEC_SELECT_TYPE;
7813 tail->ext.case_list = gfc_get_case ();
7814 tail->ext.case_list->ts.type = BT_UNKNOWN;
7816 default_case = tail;
7819 /* More than one CLASS IS block? */
7820 if (class_is->block)
7824 /* Sort CLASS IS blocks by extension level. */
7828 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
7831 /* F03:C817 (check for doubles). */
7832 if ((*c1)->ext.case_list->ts.u.derived->hash_value
7833 == c2->ext.case_list->ts.u.derived->hash_value)
7835 gfc_error ("Double CLASS IS block in SELECT TYPE "
7836 "statement at %L", &c2->ext.case_list->where);
7839 if ((*c1)->ext.case_list->ts.u.derived->attr.extension
7840 < c2->ext.case_list->ts.u.derived->attr.extension)
7843 (*c1)->block = c2->block;
7853 /* Generate IF chain. */
7854 if_st = gfc_get_code ();
7855 if_st->op = EXEC_IF;
7857 for (body = class_is; body; body = body->block)
7859 new_st->block = gfc_get_code ();
7860 new_st = new_st->block;
7861 new_st->op = EXEC_IF;
7862 /* Set up IF condition: Call _gfortran_is_extension_of. */
7863 new_st->expr1 = gfc_get_expr ();
7864 new_st->expr1->expr_type = EXPR_FUNCTION;
7865 new_st->expr1->ts.type = BT_LOGICAL;
7866 new_st->expr1->ts.kind = 4;
7867 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
7868 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
7869 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
7870 /* Set up arguments. */
7871 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
7872 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
7873 gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
7874 vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
7875 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
7876 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
7877 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
7878 new_st->next = body->next;
7880 if (default_case->next)
7882 new_st->block = gfc_get_code ();
7883 new_st = new_st->block;
7884 new_st->op = EXEC_IF;
7885 new_st->next = default_case->next;
7888 /* Replace CLASS DEFAULT code by the IF chain. */
7889 default_case->next = if_st;
7892 /* Resolve the internal code. This can not be done earlier because
7893 it requires that the sym->assoc of selectors is set already. */
7894 gfc_current_ns = ns;
7895 gfc_resolve_blocks (code->block, gfc_current_ns);
7896 gfc_current_ns = old_ns;
7898 resolve_select (code);
7902 /* Resolve a transfer statement. This is making sure that:
7903 -- a derived type being transferred has only non-pointer components
7904 -- a derived type being transferred doesn't have private components, unless
7905 it's being transferred from the module where the type was defined
7906 -- we're not trying to transfer a whole assumed size array. */
7909 resolve_transfer (gfc_code *code)
7918 while (exp != NULL && exp->expr_type == EXPR_OP
7919 && exp->value.op.op == INTRINSIC_PARENTHESES)
7920 exp = exp->value.op.op1;
7922 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
7923 && exp->expr_type != EXPR_FUNCTION))
7926 /* If we are reading, the variable will be changed. Note that
7927 code->ext.dt may be NULL if the TRANSFER is related to
7928 an INQUIRE statement -- but in this case, we are not reading, either. */
7929 if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
7930 && gfc_check_vardef_context (exp, false, _("item in READ")) == FAILURE)
7933 sym = exp->symtree->n.sym;
7936 /* Go to actual component transferred. */
7937 for (ref = code->expr1->ref; ref; ref = ref->next)
7938 if (ref->type == REF_COMPONENT)
7939 ts = &ref->u.c.component->ts;
7941 if (ts->type == BT_DERIVED)
7943 /* Check that transferred derived type doesn't contain POINTER
7945 if (ts->u.derived->attr.pointer_comp)
7947 gfc_error ("Data transfer element at %L cannot have "
7948 "POINTER components", &code->loc);
7952 if (ts->u.derived->attr.alloc_comp)
7954 gfc_error ("Data transfer element at %L cannot have "
7955 "ALLOCATABLE components", &code->loc);
7959 if (derived_inaccessible (ts->u.derived))
7961 gfc_error ("Data transfer element at %L cannot have "
7962 "PRIVATE components",&code->loc);
7967 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
7968 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
7970 gfc_error ("Data transfer element at %L cannot be a full reference to "
7971 "an assumed-size array", &code->loc);
7977 /*********** Toplevel code resolution subroutines ***********/
7979 /* Find the set of labels that are reachable from this block. We also
7980 record the last statement in each block. */
7983 find_reachable_labels (gfc_code *block)
7990 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
7992 /* Collect labels in this block. We don't keep those corresponding
7993 to END {IF|SELECT}, these are checked in resolve_branch by going
7994 up through the code_stack. */
7995 for (c = block; c; c = c->next)
7997 if (c->here && c->op != EXEC_END_BLOCK)
7998 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8001 /* Merge with labels from parent block. */
8004 gcc_assert (cs_base->prev->reachable_labels);
8005 bitmap_ior_into (cs_base->reachable_labels,
8006 cs_base->prev->reachable_labels);
8012 resolve_sync (gfc_code *code)
8014 /* Check imageset. The * case matches expr1 == NULL. */
8017 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8018 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8019 "INTEGER expression", &code->expr1->where);
8020 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8021 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8022 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8023 &code->expr1->where);
8024 else if (code->expr1->expr_type == EXPR_ARRAY
8025 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8027 gfc_constructor *cons;
8028 cons = gfc_constructor_first (code->expr1->value.constructor);
8029 for (; cons; cons = gfc_constructor_next (cons))
8030 if (cons->expr->expr_type == EXPR_CONSTANT
8031 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8032 gfc_error ("Imageset argument at %L must between 1 and "
8033 "num_images()", &cons->expr->where);
8039 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8040 || code->expr2->expr_type != EXPR_VARIABLE))
8041 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8042 &code->expr2->where);
8046 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8047 || code->expr3->expr_type != EXPR_VARIABLE))
8048 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8049 &code->expr3->where);
8053 /* Given a branch to a label, see if the branch is conforming.
8054 The code node describes where the branch is located. */
8057 resolve_branch (gfc_st_label *label, gfc_code *code)
8064 /* Step one: is this a valid branching target? */
8066 if (label->defined == ST_LABEL_UNKNOWN)
8068 gfc_error ("Label %d referenced at %L is never defined", label->value,
8073 if (label->defined != ST_LABEL_TARGET)
8075 gfc_error ("Statement at %L is not a valid branch target statement "
8076 "for the branch statement at %L", &label->where, &code->loc);
8080 /* Step two: make sure this branch is not a branch to itself ;-) */
8082 if (code->here == label)
8084 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8088 /* Step three: See if the label is in the same block as the
8089 branching statement. The hard work has been done by setting up
8090 the bitmap reachable_labels. */
8092 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8094 /* Check now whether there is a CRITICAL construct; if so, check
8095 whether the label is still visible outside of the CRITICAL block,
8096 which is invalid. */
8097 for (stack = cs_base; stack; stack = stack->prev)
8098 if (stack->current->op == EXEC_CRITICAL
8099 && bitmap_bit_p (stack->reachable_labels, label->value))
8100 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8101 " at %L", &code->loc, &label->where);
8106 /* Step four: If we haven't found the label in the bitmap, it may
8107 still be the label of the END of the enclosing block, in which
8108 case we find it by going up the code_stack. */
8110 for (stack = cs_base; stack; stack = stack->prev)
8112 if (stack->current->next && stack->current->next->here == label)
8114 if (stack->current->op == EXEC_CRITICAL)
8116 /* Note: A label at END CRITICAL does not leave the CRITICAL
8117 construct as END CRITICAL is still part of it. */
8118 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8119 " at %L", &code->loc, &label->where);
8126 gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
8130 /* The label is not in an enclosing block, so illegal. This was
8131 allowed in Fortran 66, so we allow it as extension. No
8132 further checks are necessary in this case. */
8133 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
8134 "as the GOTO statement at %L", &label->where,
8140 /* Check whether EXPR1 has the same shape as EXPR2. */
8143 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
8145 mpz_t shape[GFC_MAX_DIMENSIONS];
8146 mpz_t shape2[GFC_MAX_DIMENSIONS];
8147 gfc_try result = FAILURE;
8150 /* Compare the rank. */
8151 if (expr1->rank != expr2->rank)
8154 /* Compare the size of each dimension. */
8155 for (i=0; i<expr1->rank; i++)
8157 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
8160 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
8163 if (mpz_cmp (shape[i], shape2[i]))
8167 /* When either of the two expression is an assumed size array, we
8168 ignore the comparison of dimension sizes. */
8173 for (i--; i >= 0; i--)
8175 mpz_clear (shape[i]);
8176 mpz_clear (shape2[i]);
8182 /* Check whether a WHERE assignment target or a WHERE mask expression
8183 has the same shape as the outmost WHERE mask expression. */
8186 resolve_where (gfc_code *code, gfc_expr *mask)
8192 cblock = code->block;
8194 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8195 In case of nested WHERE, only the outmost one is stored. */
8196 if (mask == NULL) /* outmost WHERE */
8198 else /* inner WHERE */
8205 /* Check if the mask-expr has a consistent shape with the
8206 outmost WHERE mask-expr. */
8207 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8208 gfc_error ("WHERE mask at %L has inconsistent shape",
8209 &cblock->expr1->where);
8212 /* the assignment statement of a WHERE statement, or the first
8213 statement in where-body-construct of a WHERE construct */
8214 cnext = cblock->next;
8219 /* WHERE assignment statement */
8222 /* Check shape consistent for WHERE assignment target. */
8223 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8224 gfc_error ("WHERE assignment target at %L has "
8225 "inconsistent shape", &cnext->expr1->where);
8229 case EXEC_ASSIGN_CALL:
8230 resolve_call (cnext);
8231 if (!cnext->resolved_sym->attr.elemental)
8232 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8233 &cnext->ext.actual->expr->where);
8236 /* WHERE or WHERE construct is part of a where-body-construct */
8238 resolve_where (cnext, e);
8242 gfc_error ("Unsupported statement inside WHERE at %L",
8245 /* the next statement within the same where-body-construct */
8246 cnext = cnext->next;
8248 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8249 cblock = cblock->block;
8254 /* Resolve assignment in FORALL construct.
8255 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8256 FORALL index variables. */
8259 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8263 for (n = 0; n < nvar; n++)
8265 gfc_symbol *forall_index;
8267 forall_index = var_expr[n]->symtree->n.sym;
8269 /* Check whether the assignment target is one of the FORALL index
8271 if ((code->expr1->expr_type == EXPR_VARIABLE)
8272 && (code->expr1->symtree->n.sym == forall_index))
8273 gfc_error ("Assignment to a FORALL index variable at %L",
8274 &code->expr1->where);
8277 /* If one of the FORALL index variables doesn't appear in the
8278 assignment variable, then there could be a many-to-one
8279 assignment. Emit a warning rather than an error because the
8280 mask could be resolving this problem. */
8281 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8282 gfc_warning ("The FORALL with index '%s' is not used on the "
8283 "left side of the assignment at %L and so might "
8284 "cause multiple assignment to this object",
8285 var_expr[n]->symtree->name, &code->expr1->where);
8291 /* Resolve WHERE statement in FORALL construct. */
8294 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8295 gfc_expr **var_expr)
8300 cblock = code->block;
8303 /* the assignment statement of a WHERE statement, or the first
8304 statement in where-body-construct of a WHERE construct */
8305 cnext = cblock->next;
8310 /* WHERE assignment statement */
8312 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8315 /* WHERE operator assignment statement */
8316 case EXEC_ASSIGN_CALL:
8317 resolve_call (cnext);
8318 if (!cnext->resolved_sym->attr.elemental)
8319 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8320 &cnext->ext.actual->expr->where);
8323 /* WHERE or WHERE construct is part of a where-body-construct */
8325 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8329 gfc_error ("Unsupported statement inside WHERE at %L",
8332 /* the next statement within the same where-body-construct */
8333 cnext = cnext->next;
8335 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8336 cblock = cblock->block;
8341 /* Traverse the FORALL body to check whether the following errors exist:
8342 1. For assignment, check if a many-to-one assignment happens.
8343 2. For WHERE statement, check the WHERE body to see if there is any
8344 many-to-one assignment. */
8347 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8351 c = code->block->next;
8357 case EXEC_POINTER_ASSIGN:
8358 gfc_resolve_assign_in_forall (c, nvar, var_expr);
8361 case EXEC_ASSIGN_CALL:
8365 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8366 there is no need to handle it here. */
8370 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8375 /* The next statement in the FORALL body. */
8381 /* Counts the number of iterators needed inside a forall construct, including
8382 nested forall constructs. This is used to allocate the needed memory
8383 in gfc_resolve_forall. */
8386 gfc_count_forall_iterators (gfc_code *code)
8388 int max_iters, sub_iters, current_iters;
8389 gfc_forall_iterator *fa;
8391 gcc_assert(code->op == EXEC_FORALL);
8395 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8398 code = code->block->next;
8402 if (code->op == EXEC_FORALL)
8404 sub_iters = gfc_count_forall_iterators (code);
8405 if (sub_iters > max_iters)
8406 max_iters = sub_iters;
8411 return current_iters + max_iters;
8415 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8416 gfc_resolve_forall_body to resolve the FORALL body. */
8419 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8421 static gfc_expr **var_expr;
8422 static int total_var = 0;
8423 static int nvar = 0;
8425 gfc_forall_iterator *fa;
8430 /* Start to resolve a FORALL construct */
8431 if (forall_save == 0)
8433 /* Count the total number of FORALL index in the nested FORALL
8434 construct in order to allocate the VAR_EXPR with proper size. */
8435 total_var = gfc_count_forall_iterators (code);
8437 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8438 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
8441 /* The information about FORALL iterator, including FORALL index start, end
8442 and stride. The FORALL index can not appear in start, end or stride. */
8443 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8445 /* Check if any outer FORALL index name is the same as the current
8447 for (i = 0; i < nvar; i++)
8449 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8451 gfc_error ("An outer FORALL construct already has an index "
8452 "with this name %L", &fa->var->where);
8456 /* Record the current FORALL index. */
8457 var_expr[nvar] = gfc_copy_expr (fa->var);
8461 /* No memory leak. */
8462 gcc_assert (nvar <= total_var);
8465 /* Resolve the FORALL body. */
8466 gfc_resolve_forall_body (code, nvar, var_expr);
8468 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8469 gfc_resolve_blocks (code->block, ns);
8473 /* Free only the VAR_EXPRs allocated in this frame. */
8474 for (i = nvar; i < tmp; i++)
8475 gfc_free_expr (var_expr[i]);
8479 /* We are in the outermost FORALL construct. */
8480 gcc_assert (forall_save == 0);
8482 /* VAR_EXPR is not needed any more. */
8483 gfc_free (var_expr);
8489 /* Resolve a BLOCK construct statement. */
8492 resolve_block_construct (gfc_code* code)
8494 /* Resolve the BLOCK's namespace. */
8495 gfc_resolve (code->ext.block.ns);
8497 /* For an ASSOCIATE block, the associations (and their targets) are already
8498 resolved during resolve_symbol. */
8502 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8505 static void resolve_code (gfc_code *, gfc_namespace *);
8508 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8512 for (; b; b = b->block)
8514 t = gfc_resolve_expr (b->expr1);
8515 if (gfc_resolve_expr (b->expr2) == FAILURE)
8521 if (t == SUCCESS && b->expr1 != NULL
8522 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
8523 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8530 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
8531 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8536 resolve_branch (b->label1, b);
8540 resolve_block_construct (b);
8544 case EXEC_SELECT_TYPE:
8555 case EXEC_OMP_ATOMIC:
8556 case EXEC_OMP_CRITICAL:
8558 case EXEC_OMP_MASTER:
8559 case EXEC_OMP_ORDERED:
8560 case EXEC_OMP_PARALLEL:
8561 case EXEC_OMP_PARALLEL_DO:
8562 case EXEC_OMP_PARALLEL_SECTIONS:
8563 case EXEC_OMP_PARALLEL_WORKSHARE:
8564 case EXEC_OMP_SECTIONS:
8565 case EXEC_OMP_SINGLE:
8567 case EXEC_OMP_TASKWAIT:
8568 case EXEC_OMP_WORKSHARE:
8572 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
8575 resolve_code (b->next, ns);
8580 /* Does everything to resolve an ordinary assignment. Returns true
8581 if this is an interface assignment. */
8583 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
8593 if (gfc_extend_assign (code, ns) == SUCCESS)
8597 if (code->op == EXEC_ASSIGN_CALL)
8599 lhs = code->ext.actual->expr;
8600 rhsptr = &code->ext.actual->next->expr;
8604 gfc_actual_arglist* args;
8605 gfc_typebound_proc* tbp;
8607 gcc_assert (code->op == EXEC_COMPCALL);
8609 args = code->expr1->value.compcall.actual;
8611 rhsptr = &args->next->expr;
8613 tbp = code->expr1->value.compcall.tbp;
8614 gcc_assert (!tbp->is_generic);
8617 /* Make a temporary rhs when there is a default initializer
8618 and rhs is the same symbol as the lhs. */
8619 if ((*rhsptr)->expr_type == EXPR_VARIABLE
8620 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
8621 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
8622 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
8623 *rhsptr = gfc_get_parentheses (*rhsptr);
8632 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
8633 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
8634 &code->loc) == FAILURE)
8637 /* Handle the case of a BOZ literal on the RHS. */
8638 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
8641 if (gfc_option.warn_surprising)
8642 gfc_warning ("BOZ literal at %L is bitwise transferred "
8643 "non-integer symbol '%s'", &code->loc,
8644 lhs->symtree->n.sym->name);
8646 if (!gfc_convert_boz (rhs, &lhs->ts))
8648 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
8650 if (rc == ARITH_UNDERFLOW)
8651 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
8652 ". This check can be disabled with the option "
8653 "-fno-range-check", &rhs->where);
8654 else if (rc == ARITH_OVERFLOW)
8655 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
8656 ". This check can be disabled with the option "
8657 "-fno-range-check", &rhs->where);
8658 else if (rc == ARITH_NAN)
8659 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
8660 ". This check can be disabled with the option "
8661 "-fno-range-check", &rhs->where);
8666 if (lhs->ts.type == BT_CHARACTER
8667 && gfc_option.warn_character_truncation)
8669 if (lhs->ts.u.cl != NULL
8670 && lhs->ts.u.cl->length != NULL
8671 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8672 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
8674 if (rhs->expr_type == EXPR_CONSTANT)
8675 rlen = rhs->value.character.length;
8677 else if (rhs->ts.u.cl != NULL
8678 && rhs->ts.u.cl->length != NULL
8679 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8680 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
8682 if (rlen && llen && rlen > llen)
8683 gfc_warning_now ("CHARACTER expression will be truncated "
8684 "in assignment (%d/%d) at %L",
8685 llen, rlen, &code->loc);
8688 /* Ensure that a vector index expression for the lvalue is evaluated
8689 to a temporary if the lvalue symbol is referenced in it. */
8692 for (ref = lhs->ref; ref; ref= ref->next)
8693 if (ref->type == REF_ARRAY)
8695 for (n = 0; n < ref->u.ar.dimen; n++)
8696 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
8697 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
8698 ref->u.ar.start[n]))
8700 = gfc_get_parentheses (ref->u.ar.start[n]);
8704 if (gfc_pure (NULL))
8706 if (lhs->ts.type == BT_DERIVED
8707 && lhs->expr_type == EXPR_VARIABLE
8708 && lhs->ts.u.derived->attr.pointer_comp
8709 && rhs->expr_type == EXPR_VARIABLE
8710 && (gfc_impure_variable (rhs->symtree->n.sym)
8711 || gfc_is_coindexed (rhs)))
8714 if (gfc_is_coindexed (rhs))
8715 gfc_error ("Coindexed expression at %L is assigned to "
8716 "a derived type variable with a POINTER "
8717 "component in a PURE procedure",
8720 gfc_error ("The impure variable at %L is assigned to "
8721 "a derived type variable with a POINTER "
8722 "component in a PURE procedure (12.6)",
8727 /* Fortran 2008, C1283. */
8728 if (gfc_is_coindexed (lhs))
8730 gfc_error ("Assignment to coindexed variable at %L in a PURE "
8731 "procedure", &rhs->where);
8737 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
8738 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
8739 if (lhs->ts.type == BT_CLASS)
8741 gfc_error ("Variable must not be polymorphic in assignment at %L",
8746 /* F2008, Section 7.2.1.2. */
8747 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
8749 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
8750 "component in assignment at %L", &lhs->where);
8754 gfc_check_assign (lhs, rhs, 1);
8759 /* Given a block of code, recursively resolve everything pointed to by this
8763 resolve_code (gfc_code *code, gfc_namespace *ns)
8765 int omp_workshare_save;
8770 frame.prev = cs_base;
8774 find_reachable_labels (code);
8776 for (; code; code = code->next)
8778 frame.current = code;
8779 forall_save = forall_flag;
8781 if (code->op == EXEC_FORALL)
8784 gfc_resolve_forall (code, ns, forall_save);
8787 else if (code->block)
8789 omp_workshare_save = -1;
8792 case EXEC_OMP_PARALLEL_WORKSHARE:
8793 omp_workshare_save = omp_workshare_flag;
8794 omp_workshare_flag = 1;
8795 gfc_resolve_omp_parallel_blocks (code, ns);
8797 case EXEC_OMP_PARALLEL:
8798 case EXEC_OMP_PARALLEL_DO:
8799 case EXEC_OMP_PARALLEL_SECTIONS:
8801 omp_workshare_save = omp_workshare_flag;
8802 omp_workshare_flag = 0;
8803 gfc_resolve_omp_parallel_blocks (code, ns);
8806 gfc_resolve_omp_do_blocks (code, ns);
8808 case EXEC_SELECT_TYPE:
8809 /* Blocks are handled in resolve_select_type because we have
8810 to transform the SELECT TYPE into ASSOCIATE first. */
8812 case EXEC_OMP_WORKSHARE:
8813 omp_workshare_save = omp_workshare_flag;
8814 omp_workshare_flag = 1;
8817 gfc_resolve_blocks (code->block, ns);
8821 if (omp_workshare_save != -1)
8822 omp_workshare_flag = omp_workshare_save;
8826 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
8827 t = gfc_resolve_expr (code->expr1);
8828 forall_flag = forall_save;
8830 if (gfc_resolve_expr (code->expr2) == FAILURE)
8833 if (code->op == EXEC_ALLOCATE
8834 && gfc_resolve_expr (code->expr3) == FAILURE)
8840 case EXEC_END_BLOCK:
8844 case EXEC_ERROR_STOP:
8848 case EXEC_ASSIGN_CALL:
8853 case EXEC_SYNC_IMAGES:
8854 case EXEC_SYNC_MEMORY:
8855 resolve_sync (code);
8859 /* Keep track of which entry we are up to. */
8860 current_entry_id = code->ext.entry->id;
8864 resolve_where (code, NULL);
8868 if (code->expr1 != NULL)
8870 if (code->expr1->ts.type != BT_INTEGER)
8871 gfc_error ("ASSIGNED GOTO statement at %L requires an "
8872 "INTEGER variable", &code->expr1->where);
8873 else if (code->expr1->symtree->n.sym->attr.assign != 1)
8874 gfc_error ("Variable '%s' has not been assigned a target "
8875 "label at %L", code->expr1->symtree->n.sym->name,
8876 &code->expr1->where);
8879 resolve_branch (code->label1, code);
8883 if (code->expr1 != NULL
8884 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
8885 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
8886 "INTEGER return specifier", &code->expr1->where);
8889 case EXEC_INIT_ASSIGN:
8890 case EXEC_END_PROCEDURE:
8897 if (gfc_check_vardef_context (code->expr1, false, _("assignment"))
8901 if (resolve_ordinary_assign (code, ns))
8903 if (code->op == EXEC_COMPCALL)
8910 case EXEC_LABEL_ASSIGN:
8911 if (code->label1->defined == ST_LABEL_UNKNOWN)
8912 gfc_error ("Label %d referenced at %L is never defined",
8913 code->label1->value, &code->label1->where);
8915 && (code->expr1->expr_type != EXPR_VARIABLE
8916 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
8917 || code->expr1->symtree->n.sym->ts.kind
8918 != gfc_default_integer_kind
8919 || code->expr1->symtree->n.sym->as != NULL))
8920 gfc_error ("ASSIGN statement at %L requires a scalar "
8921 "default INTEGER variable", &code->expr1->where);
8924 case EXEC_POINTER_ASSIGN:
8931 /* This is both a variable definition and pointer assignment
8932 context, so check both of them. For rank remapping, a final
8933 array ref may be present on the LHS and fool gfc_expr_attr
8934 used in gfc_check_vardef_context. Remove it. */
8935 e = remove_last_array_ref (code->expr1);
8936 t = gfc_check_vardef_context (e, true, _("pointer assignment"));
8938 t = gfc_check_vardef_context (e, false, _("pointer assignment"));
8943 gfc_check_pointer_assign (code->expr1, code->expr2);
8947 case EXEC_ARITHMETIC_IF:
8949 && code->expr1->ts.type != BT_INTEGER
8950 && code->expr1->ts.type != BT_REAL)
8951 gfc_error ("Arithmetic IF statement at %L requires a numeric "
8952 "expression", &code->expr1->where);
8954 resolve_branch (code->label1, code);
8955 resolve_branch (code->label2, code);
8956 resolve_branch (code->label3, code);
8960 if (t == SUCCESS && code->expr1 != NULL
8961 && (code->expr1->ts.type != BT_LOGICAL
8962 || code->expr1->rank != 0))
8963 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8964 &code->expr1->where);
8969 resolve_call (code);
8974 resolve_typebound_subroutine (code);
8978 resolve_ppc_call (code);
8982 /* Select is complicated. Also, a SELECT construct could be
8983 a transformed computed GOTO. */
8984 resolve_select (code);
8987 case EXEC_SELECT_TYPE:
8988 resolve_select_type (code, ns);
8992 resolve_block_construct (code);
8996 if (code->ext.iterator != NULL)
8998 gfc_iterator *iter = code->ext.iterator;
8999 if (gfc_resolve_iterator (iter, true) != FAILURE)
9000 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
9005 if (code->expr1 == NULL)
9006 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9008 && (code->expr1->rank != 0
9009 || code->expr1->ts.type != BT_LOGICAL))
9010 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9011 "a scalar LOGICAL expression", &code->expr1->where);
9016 resolve_allocate_deallocate (code, "ALLOCATE");
9020 case EXEC_DEALLOCATE:
9022 resolve_allocate_deallocate (code, "DEALLOCATE");
9027 if (gfc_resolve_open (code->ext.open) == FAILURE)
9030 resolve_branch (code->ext.open->err, code);
9034 if (gfc_resolve_close (code->ext.close) == FAILURE)
9037 resolve_branch (code->ext.close->err, code);
9040 case EXEC_BACKSPACE:
9044 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
9047 resolve_branch (code->ext.filepos->err, code);
9051 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9054 resolve_branch (code->ext.inquire->err, code);
9058 gcc_assert (code->ext.inquire != NULL);
9059 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9062 resolve_branch (code->ext.inquire->err, code);
9066 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
9069 resolve_branch (code->ext.wait->err, code);
9070 resolve_branch (code->ext.wait->end, code);
9071 resolve_branch (code->ext.wait->eor, code);
9076 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
9079 resolve_branch (code->ext.dt->err, code);
9080 resolve_branch (code->ext.dt->end, code);
9081 resolve_branch (code->ext.dt->eor, code);
9085 resolve_transfer (code);
9089 resolve_forall_iterators (code->ext.forall_iterator);
9091 if (code->expr1 != NULL && code->expr1->ts.type != BT_LOGICAL)
9092 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
9093 "expression", &code->expr1->where);
9096 case EXEC_OMP_ATOMIC:
9097 case EXEC_OMP_BARRIER:
9098 case EXEC_OMP_CRITICAL:
9099 case EXEC_OMP_FLUSH:
9101 case EXEC_OMP_MASTER:
9102 case EXEC_OMP_ORDERED:
9103 case EXEC_OMP_SECTIONS:
9104 case EXEC_OMP_SINGLE:
9105 case EXEC_OMP_TASKWAIT:
9106 case EXEC_OMP_WORKSHARE:
9107 gfc_resolve_omp_directive (code, ns);
9110 case EXEC_OMP_PARALLEL:
9111 case EXEC_OMP_PARALLEL_DO:
9112 case EXEC_OMP_PARALLEL_SECTIONS:
9113 case EXEC_OMP_PARALLEL_WORKSHARE:
9115 omp_workshare_save = omp_workshare_flag;
9116 omp_workshare_flag = 0;
9117 gfc_resolve_omp_directive (code, ns);
9118 omp_workshare_flag = omp_workshare_save;
9122 gfc_internal_error ("resolve_code(): Bad statement code");
9126 cs_base = frame.prev;
9130 /* Resolve initial values and make sure they are compatible with
9134 resolve_values (gfc_symbol *sym)
9138 if (sym->value == NULL)
9141 if (sym->value->expr_type == EXPR_STRUCTURE)
9142 t= resolve_structure_cons (sym->value, 1);
9144 t = gfc_resolve_expr (sym->value);
9149 gfc_check_assign_symbol (sym, sym->value);
9153 /* Verify the binding labels for common blocks that are BIND(C). The label
9154 for a BIND(C) common block must be identical in all scoping units in which
9155 the common block is declared. Further, the binding label can not collide
9156 with any other global entity in the program. */
9159 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
9161 if (comm_block_tree->n.common->is_bind_c == 1)
9163 gfc_gsymbol *binding_label_gsym;
9164 gfc_gsymbol *comm_name_gsym;
9166 /* See if a global symbol exists by the common block's name. It may
9167 be NULL if the common block is use-associated. */
9168 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
9169 comm_block_tree->n.common->name);
9170 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
9171 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9172 "with the global entity '%s' at %L",
9173 comm_block_tree->n.common->binding_label,
9174 comm_block_tree->n.common->name,
9175 &(comm_block_tree->n.common->where),
9176 comm_name_gsym->name, &(comm_name_gsym->where));
9177 else if (comm_name_gsym != NULL
9178 && strcmp (comm_name_gsym->name,
9179 comm_block_tree->n.common->name) == 0)
9181 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9183 if (comm_name_gsym->binding_label == NULL)
9184 /* No binding label for common block stored yet; save this one. */
9185 comm_name_gsym->binding_label =
9186 comm_block_tree->n.common->binding_label;
9188 if (strcmp (comm_name_gsym->binding_label,
9189 comm_block_tree->n.common->binding_label) != 0)
9191 /* Common block names match but binding labels do not. */
9192 gfc_error ("Binding label '%s' for common block '%s' at %L "
9193 "does not match the binding label '%s' for common "
9195 comm_block_tree->n.common->binding_label,
9196 comm_block_tree->n.common->name,
9197 &(comm_block_tree->n.common->where),
9198 comm_name_gsym->binding_label,
9199 comm_name_gsym->name,
9200 &(comm_name_gsym->where));
9205 /* There is no binding label (NAME="") so we have nothing further to
9206 check and nothing to add as a global symbol for the label. */
9207 if (comm_block_tree->n.common->binding_label[0] == '\0' )
9210 binding_label_gsym =
9211 gfc_find_gsymbol (gfc_gsym_root,
9212 comm_block_tree->n.common->binding_label);
9213 if (binding_label_gsym == NULL)
9215 /* Need to make a global symbol for the binding label to prevent
9216 it from colliding with another. */
9217 binding_label_gsym =
9218 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9219 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9220 binding_label_gsym->type = GSYM_COMMON;
9224 /* If comm_name_gsym is NULL, the name common block is use
9225 associated and the name could be colliding. */
9226 if (binding_label_gsym->type != GSYM_COMMON)
9227 gfc_error ("Binding label '%s' for common block '%s' at %L "
9228 "collides with the global entity '%s' at %L",
9229 comm_block_tree->n.common->binding_label,
9230 comm_block_tree->n.common->name,
9231 &(comm_block_tree->n.common->where),
9232 binding_label_gsym->name,
9233 &(binding_label_gsym->where));
9234 else if (comm_name_gsym != NULL
9235 && (strcmp (binding_label_gsym->name,
9236 comm_name_gsym->binding_label) != 0)
9237 && (strcmp (binding_label_gsym->sym_name,
9238 comm_name_gsym->name) != 0))
9239 gfc_error ("Binding label '%s' for common block '%s' at %L "
9240 "collides with global entity '%s' at %L",
9241 binding_label_gsym->name, binding_label_gsym->sym_name,
9242 &(comm_block_tree->n.common->where),
9243 comm_name_gsym->name, &(comm_name_gsym->where));
9251 /* Verify any BIND(C) derived types in the namespace so we can report errors
9252 for them once, rather than for each variable declared of that type. */
9255 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9257 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9258 && derived_sym->attr.is_bind_c == 1)
9259 verify_bind_c_derived_type (derived_sym);
9265 /* Verify that any binding labels used in a given namespace do not collide
9266 with the names or binding labels of any global symbols. */
9269 gfc_verify_binding_labels (gfc_symbol *sym)
9273 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9274 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
9276 gfc_gsymbol *bind_c_sym;
9278 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9279 if (bind_c_sym != NULL
9280 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9282 if (sym->attr.if_source == IFSRC_DECL
9283 && (bind_c_sym->type != GSYM_SUBROUTINE
9284 && bind_c_sym->type != GSYM_FUNCTION)
9285 && ((sym->attr.contained == 1
9286 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9287 || (sym->attr.use_assoc == 1
9288 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9290 /* Make sure global procedures don't collide with anything. */
9291 gfc_error ("Binding label '%s' at %L collides with the global "
9292 "entity '%s' at %L", sym->binding_label,
9293 &(sym->declared_at), bind_c_sym->name,
9294 &(bind_c_sym->where));
9297 else if (sym->attr.contained == 0
9298 && (sym->attr.if_source == IFSRC_IFBODY
9299 && sym->attr.flavor == FL_PROCEDURE)
9300 && (bind_c_sym->sym_name != NULL
9301 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9303 /* Make sure procedures in interface bodies don't collide. */
9304 gfc_error ("Binding label '%s' in interface body at %L collides "
9305 "with the global entity '%s' at %L",
9307 &(sym->declared_at), bind_c_sym->name,
9308 &(bind_c_sym->where));
9311 else if (sym->attr.contained == 0
9312 && sym->attr.if_source == IFSRC_UNKNOWN)
9313 if ((sym->attr.use_assoc && bind_c_sym->mod_name
9314 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9315 || sym->attr.use_assoc == 0)
9317 gfc_error ("Binding label '%s' at %L collides with global "
9318 "entity '%s' at %L", sym->binding_label,
9319 &(sym->declared_at), bind_c_sym->name,
9320 &(bind_c_sym->where));
9325 /* Clear the binding label to prevent checking multiple times. */
9326 sym->binding_label[0] = '\0';
9328 else if (bind_c_sym == NULL)
9330 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9331 bind_c_sym->where = sym->declared_at;
9332 bind_c_sym->sym_name = sym->name;
9334 if (sym->attr.use_assoc == 1)
9335 bind_c_sym->mod_name = sym->module;
9337 if (sym->ns->proc_name != NULL)
9338 bind_c_sym->mod_name = sym->ns->proc_name->name;
9340 if (sym->attr.contained == 0)
9342 if (sym->attr.subroutine)
9343 bind_c_sym->type = GSYM_SUBROUTINE;
9344 else if (sym->attr.function)
9345 bind_c_sym->type = GSYM_FUNCTION;
9353 /* Resolve an index expression. */
9356 resolve_index_expr (gfc_expr *e)
9358 if (gfc_resolve_expr (e) == FAILURE)
9361 if (gfc_simplify_expr (e, 0) == FAILURE)
9364 if (gfc_specification_expr (e) == FAILURE)
9370 /* Resolve a charlen structure. */
9373 resolve_charlen (gfc_charlen *cl)
9382 specification_expr = 1;
9384 if (resolve_index_expr (cl->length) == FAILURE)
9386 specification_expr = 0;
9390 /* "If the character length parameter value evaluates to a negative
9391 value, the length of character entities declared is zero." */
9392 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9394 if (gfc_option.warn_surprising)
9395 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9396 " the length has been set to zero",
9397 &cl->length->where, i);
9398 gfc_replace_expr (cl->length,
9399 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9402 /* Check that the character length is not too large. */
9403 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9404 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9405 && cl->length->ts.type == BT_INTEGER
9406 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9408 gfc_error ("String length at %L is too large", &cl->length->where);
9416 /* Test for non-constant shape arrays. */
9419 is_non_constant_shape_array (gfc_symbol *sym)
9425 not_constant = false;
9426 if (sym->as != NULL)
9428 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9429 has not been simplified; parameter array references. Do the
9430 simplification now. */
9431 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9433 e = sym->as->lower[i];
9434 if (e && (resolve_index_expr (e) == FAILURE
9435 || !gfc_is_constant_expr (e)))
9436 not_constant = true;
9437 e = sym->as->upper[i];
9438 if (e && (resolve_index_expr (e) == FAILURE
9439 || !gfc_is_constant_expr (e)))
9440 not_constant = true;
9443 return not_constant;
9446 /* Given a symbol and an initialization expression, add code to initialize
9447 the symbol to the function entry. */
9449 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9453 gfc_namespace *ns = sym->ns;
9455 /* Search for the function namespace if this is a contained
9456 function without an explicit result. */
9457 if (sym->attr.function && sym == sym->result
9458 && sym->name != sym->ns->proc_name->name)
9461 for (;ns; ns = ns->sibling)
9462 if (strcmp (ns->proc_name->name, sym->name) == 0)
9468 gfc_free_expr (init);
9472 /* Build an l-value expression for the result. */
9473 lval = gfc_lval_expr_from_sym (sym);
9475 /* Add the code at scope entry. */
9476 init_st = gfc_get_code ();
9477 init_st->next = ns->code;
9480 /* Assign the default initializer to the l-value. */
9481 init_st->loc = sym->declared_at;
9482 init_st->op = EXEC_INIT_ASSIGN;
9483 init_st->expr1 = lval;
9484 init_st->expr2 = init;
9487 /* Assign the default initializer to a derived type variable or result. */
9490 apply_default_init (gfc_symbol *sym)
9492 gfc_expr *init = NULL;
9494 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9497 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
9498 init = gfc_default_initializer (&sym->ts);
9500 if (init == NULL && sym->ts.type != BT_CLASS)
9503 build_init_assign (sym, init);
9504 sym->attr.referenced = 1;
9507 /* Build an initializer for a local integer, real, complex, logical, or
9508 character variable, based on the command line flags finit-local-zero,
9509 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
9510 null if the symbol should not have a default initialization. */
9512 build_default_init_expr (gfc_symbol *sym)
9515 gfc_expr *init_expr;
9518 /* These symbols should never have a default initialization. */
9519 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
9520 || sym->attr.external
9522 || sym->attr.pointer
9523 || sym->attr.in_equivalence
9524 || sym->attr.in_common
9527 || sym->attr.cray_pointee
9528 || sym->attr.cray_pointer)
9531 /* Now we'll try to build an initializer expression. */
9532 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
9535 /* We will only initialize integers, reals, complex, logicals, and
9536 characters, and only if the corresponding command-line flags
9537 were set. Otherwise, we free init_expr and return null. */
9538 switch (sym->ts.type)
9541 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
9542 mpz_set_si (init_expr->value.integer,
9543 gfc_option.flag_init_integer_value);
9546 gfc_free_expr (init_expr);
9552 switch (gfc_option.flag_init_real)
9554 case GFC_INIT_REAL_SNAN:
9555 init_expr->is_snan = 1;
9557 case GFC_INIT_REAL_NAN:
9558 mpfr_set_nan (init_expr->value.real);
9561 case GFC_INIT_REAL_INF:
9562 mpfr_set_inf (init_expr->value.real, 1);
9565 case GFC_INIT_REAL_NEG_INF:
9566 mpfr_set_inf (init_expr->value.real, -1);
9569 case GFC_INIT_REAL_ZERO:
9570 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
9574 gfc_free_expr (init_expr);
9581 switch (gfc_option.flag_init_real)
9583 case GFC_INIT_REAL_SNAN:
9584 init_expr->is_snan = 1;
9586 case GFC_INIT_REAL_NAN:
9587 mpfr_set_nan (mpc_realref (init_expr->value.complex));
9588 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
9591 case GFC_INIT_REAL_INF:
9592 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
9593 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
9596 case GFC_INIT_REAL_NEG_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_ZERO:
9602 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
9606 gfc_free_expr (init_expr);
9613 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
9614 init_expr->value.logical = 0;
9615 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
9616 init_expr->value.logical = 1;
9619 gfc_free_expr (init_expr);
9625 /* For characters, the length must be constant in order to
9626 create a default initializer. */
9627 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
9628 && sym->ts.u.cl->length
9629 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9631 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
9632 init_expr->value.character.length = char_len;
9633 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
9634 for (i = 0; i < char_len; i++)
9635 init_expr->value.character.string[i]
9636 = (unsigned char) gfc_option.flag_init_character_value;
9640 gfc_free_expr (init_expr);
9646 gfc_free_expr (init_expr);
9652 /* Add an initialization expression to a local variable. */
9654 apply_default_init_local (gfc_symbol *sym)
9656 gfc_expr *init = NULL;
9658 /* The symbol should be a variable or a function return value. */
9659 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9660 || (sym->attr.function && sym->result != sym))
9663 /* Try to build the initializer expression. If we can't initialize
9664 this symbol, then init will be NULL. */
9665 init = build_default_init_expr (sym);
9669 /* For saved variables, we don't want to add an initializer at
9670 function entry, so we just add a static initializer. */
9671 if (sym->attr.save || sym->ns->save_all
9672 || gfc_option.flag_max_stack_var_size == 0)
9674 /* Don't clobber an existing initializer! */
9675 gcc_assert (sym->value == NULL);
9680 build_init_assign (sym, init);
9683 /* Resolution of common features of flavors variable and procedure. */
9686 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
9688 /* Constraints on deferred shape variable. */
9689 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
9691 if (sym->attr.allocatable)
9693 if (sym->attr.dimension)
9695 gfc_error ("Allocatable array '%s' at %L must have "
9696 "a deferred shape", sym->name, &sym->declared_at);
9699 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
9700 "may not be ALLOCATABLE", sym->name,
9701 &sym->declared_at) == FAILURE)
9705 if (sym->attr.pointer && sym->attr.dimension)
9707 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
9708 sym->name, &sym->declared_at);
9714 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
9715 && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc)
9717 gfc_error ("Array '%s' at %L cannot have a deferred shape",
9718 sym->name, &sym->declared_at);
9723 /* Constraints on polymorphic variables. */
9724 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
9727 if (sym->attr.class_ok
9728 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
9730 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
9731 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
9737 /* Assume that use associated symbols were checked in the module ns.
9738 Class-variables that are associate-names are also something special
9739 and excepted from the test. */
9740 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
9742 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
9743 "or pointer", sym->name, &sym->declared_at);
9752 /* Additional checks for symbols with flavor variable and derived
9753 type. To be called from resolve_fl_variable. */
9756 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
9758 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
9760 /* Check to see if a derived type is blocked from being host
9761 associated by the presence of another class I symbol in the same
9762 namespace. 14.6.1.3 of the standard and the discussion on
9763 comp.lang.fortran. */
9764 if (sym->ns != sym->ts.u.derived->ns
9765 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
9768 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
9769 if (s && s->attr.flavor != FL_DERIVED)
9771 gfc_error ("The type '%s' cannot be host associated at %L "
9772 "because it is blocked by an incompatible object "
9773 "of the same name declared at %L",
9774 sym->ts.u.derived->name, &sym->declared_at,
9780 /* 4th constraint in section 11.3: "If an object of a type for which
9781 component-initialization is specified (R429) appears in the
9782 specification-part of a module and does not have the ALLOCATABLE
9783 or POINTER attribute, the object shall have the SAVE attribute."
9785 The check for initializers is performed with
9786 gfc_has_default_initializer because gfc_default_initializer generates
9787 a hidden default for allocatable components. */
9788 if (!(sym->value || no_init_flag) && sym->ns->proc_name
9789 && sym->ns->proc_name->attr.flavor == FL_MODULE
9790 && !sym->ns->save_all && !sym->attr.save
9791 && !sym->attr.pointer && !sym->attr.allocatable
9792 && gfc_has_default_initializer (sym->ts.u.derived)
9793 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
9794 "module variable '%s' at %L, needed due to "
9795 "the default initialization", sym->name,
9796 &sym->declared_at) == FAILURE)
9799 /* Assign default initializer. */
9800 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
9801 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
9803 sym->value = gfc_default_initializer (&sym->ts);
9810 /* Resolve symbols with flavor variable. */
9813 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
9815 int no_init_flag, automatic_flag;
9817 const char *auto_save_msg;
9819 auto_save_msg = "Automatic object '%s' at %L cannot have the "
9822 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9825 /* Set this flag to check that variables are parameters of all entries.
9826 This check is effected by the call to gfc_resolve_expr through
9827 is_non_constant_shape_array. */
9828 specification_expr = 1;
9830 if (sym->ns->proc_name
9831 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9832 || sym->ns->proc_name->attr.is_main_program)
9833 && !sym->attr.use_assoc
9834 && !sym->attr.allocatable
9835 && !sym->attr.pointer
9836 && is_non_constant_shape_array (sym))
9838 /* The shape of a main program or module array needs to be
9840 gfc_error ("The module or main program array '%s' at %L must "
9841 "have constant shape", sym->name, &sym->declared_at);
9842 specification_expr = 0;
9846 if (sym->ts.type == BT_CHARACTER)
9848 /* Make sure that character string variables with assumed length are
9850 e = sym->ts.u.cl->length;
9851 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
9853 gfc_error ("Entity with assumed character length at %L must be a "
9854 "dummy argument or a PARAMETER", &sym->declared_at);
9858 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
9860 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9864 if (!gfc_is_constant_expr (e)
9865 && !(e->expr_type == EXPR_VARIABLE
9866 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
9867 && sym->ns->proc_name
9868 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9869 || sym->ns->proc_name->attr.is_main_program)
9870 && !sym->attr.use_assoc)
9872 gfc_error ("'%s' at %L must have constant character length "
9873 "in this context", sym->name, &sym->declared_at);
9878 if (sym->value == NULL && sym->attr.referenced)
9879 apply_default_init_local (sym); /* Try to apply a default initialization. */
9881 /* Determine if the symbol may not have an initializer. */
9882 no_init_flag = automatic_flag = 0;
9883 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
9884 || sym->attr.intrinsic || sym->attr.result)
9886 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
9887 && is_non_constant_shape_array (sym))
9889 no_init_flag = automatic_flag = 1;
9891 /* Also, they must not have the SAVE attribute.
9892 SAVE_IMPLICIT is checked below. */
9893 if (sym->attr.save == SAVE_EXPLICIT)
9895 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9900 /* Ensure that any initializer is simplified. */
9902 gfc_simplify_expr (sym->value, 1);
9904 /* Reject illegal initializers. */
9905 if (!sym->mark && sym->value)
9907 if (sym->attr.allocatable)
9908 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
9909 sym->name, &sym->declared_at);
9910 else if (sym->attr.external)
9911 gfc_error ("External '%s' at %L cannot have an initializer",
9912 sym->name, &sym->declared_at);
9913 else if (sym->attr.dummy
9914 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
9915 gfc_error ("Dummy '%s' at %L cannot have an initializer",
9916 sym->name, &sym->declared_at);
9917 else if (sym->attr.intrinsic)
9918 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
9919 sym->name, &sym->declared_at);
9920 else if (sym->attr.result)
9921 gfc_error ("Function result '%s' at %L cannot have an initializer",
9922 sym->name, &sym->declared_at);
9923 else if (automatic_flag)
9924 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
9925 sym->name, &sym->declared_at);
9932 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
9933 return resolve_fl_variable_derived (sym, no_init_flag);
9939 /* Resolve a procedure. */
9942 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
9944 gfc_formal_arglist *arg;
9946 if (sym->attr.function
9947 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9950 if (sym->ts.type == BT_CHARACTER)
9952 gfc_charlen *cl = sym->ts.u.cl;
9954 if (cl && cl->length && gfc_is_constant_expr (cl->length)
9955 && resolve_charlen (cl) == FAILURE)
9958 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
9959 && sym->attr.proc == PROC_ST_FUNCTION)
9961 gfc_error ("Character-valued statement function '%s' at %L must "
9962 "have constant length", sym->name, &sym->declared_at);
9967 /* Ensure that derived type for are not of a private type. Internal
9968 module procedures are excluded by 2.2.3.3 - i.e., they are not
9969 externally accessible and can access all the objects accessible in
9971 if (!(sym->ns->parent
9972 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
9973 && gfc_check_access(sym->attr.access, sym->ns->default_access))
9975 gfc_interface *iface;
9977 for (arg = sym->formal; arg; arg = arg->next)
9980 && arg->sym->ts.type == BT_DERIVED
9981 && !arg->sym->ts.u.derived->attr.use_assoc
9982 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
9983 arg->sym->ts.u.derived->ns->default_access)
9984 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
9985 "PRIVATE type and cannot be a dummy argument"
9986 " of '%s', which is PUBLIC at %L",
9987 arg->sym->name, sym->name, &sym->declared_at)
9990 /* Stop this message from recurring. */
9991 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
9996 /* PUBLIC interfaces may expose PRIVATE procedures that take types
9997 PRIVATE to the containing module. */
9998 for (iface = sym->generic; iface; iface = iface->next)
10000 for (arg = iface->sym->formal; arg; arg = arg->next)
10003 && arg->sym->ts.type == BT_DERIVED
10004 && !arg->sym->ts.u.derived->attr.use_assoc
10005 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10006 arg->sym->ts.u.derived->ns->default_access)
10007 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10008 "'%s' in PUBLIC interface '%s' at %L "
10009 "takes dummy arguments of '%s' which is "
10010 "PRIVATE", iface->sym->name, sym->name,
10011 &iface->sym->declared_at,
10012 gfc_typename (&arg->sym->ts)) == FAILURE)
10014 /* Stop this message from recurring. */
10015 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10021 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10022 PRIVATE to the containing module. */
10023 for (iface = sym->generic; iface; iface = iface->next)
10025 for (arg = iface->sym->formal; arg; arg = arg->next)
10028 && arg->sym->ts.type == BT_DERIVED
10029 && !arg->sym->ts.u.derived->attr.use_assoc
10030 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10031 arg->sym->ts.u.derived->ns->default_access)
10032 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10033 "'%s' in PUBLIC interface '%s' at %L "
10034 "takes dummy arguments of '%s' which is "
10035 "PRIVATE", iface->sym->name, sym->name,
10036 &iface->sym->declared_at,
10037 gfc_typename (&arg->sym->ts)) == FAILURE)
10039 /* Stop this message from recurring. */
10040 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10047 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10048 && !sym->attr.proc_pointer)
10050 gfc_error ("Function '%s' at %L cannot have an initializer",
10051 sym->name, &sym->declared_at);
10055 /* An external symbol may not have an initializer because it is taken to be
10056 a procedure. Exception: Procedure Pointers. */
10057 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10059 gfc_error ("External object '%s' at %L may not have an initializer",
10060 sym->name, &sym->declared_at);
10064 /* An elemental function is required to return a scalar 12.7.1 */
10065 if (sym->attr.elemental && sym->attr.function && sym->as)
10067 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10068 "result", sym->name, &sym->declared_at);
10069 /* Reset so that the error only occurs once. */
10070 sym->attr.elemental = 0;
10074 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10075 char-len-param shall not be array-valued, pointer-valued, recursive
10076 or pure. ....snip... A character value of * may only be used in the
10077 following ways: (i) Dummy arg of procedure - dummy associates with
10078 actual length; (ii) To declare a named constant; or (iii) External
10079 function - but length must be declared in calling scoping unit. */
10080 if (sym->attr.function
10081 && sym->ts.type == BT_CHARACTER
10082 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10084 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10085 || (sym->attr.recursive) || (sym->attr.pure))
10087 if (sym->as && sym->as->rank)
10088 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10089 "array-valued", sym->name, &sym->declared_at);
10091 if (sym->attr.pointer)
10092 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10093 "pointer-valued", sym->name, &sym->declared_at);
10095 if (sym->attr.pure)
10096 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10097 "pure", sym->name, &sym->declared_at);
10099 if (sym->attr.recursive)
10100 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10101 "recursive", sym->name, &sym->declared_at);
10106 /* Appendix B.2 of the standard. Contained functions give an
10107 error anyway. Fixed-form is likely to be F77/legacy. */
10108 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
10109 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10110 "CHARACTER(*) function '%s' at %L",
10111 sym->name, &sym->declared_at);
10114 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10116 gfc_formal_arglist *curr_arg;
10117 int has_non_interop_arg = 0;
10119 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10120 sym->common_block) == FAILURE)
10122 /* Clear these to prevent looking at them again if there was an
10124 sym->attr.is_bind_c = 0;
10125 sym->attr.is_c_interop = 0;
10126 sym->ts.is_c_interop = 0;
10130 /* So far, no errors have been found. */
10131 sym->attr.is_c_interop = 1;
10132 sym->ts.is_c_interop = 1;
10135 curr_arg = sym->formal;
10136 while (curr_arg != NULL)
10138 /* Skip implicitly typed dummy args here. */
10139 if (curr_arg->sym->attr.implicit_type == 0)
10140 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
10141 /* If something is found to fail, record the fact so we
10142 can mark the symbol for the procedure as not being
10143 BIND(C) to try and prevent multiple errors being
10145 has_non_interop_arg = 1;
10147 curr_arg = curr_arg->next;
10150 /* See if any of the arguments were not interoperable and if so, clear
10151 the procedure symbol to prevent duplicate error messages. */
10152 if (has_non_interop_arg != 0)
10154 sym->attr.is_c_interop = 0;
10155 sym->ts.is_c_interop = 0;
10156 sym->attr.is_bind_c = 0;
10160 if (!sym->attr.proc_pointer)
10162 if (sym->attr.save == SAVE_EXPLICIT)
10164 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10165 "in '%s' at %L", sym->name, &sym->declared_at);
10168 if (sym->attr.intent)
10170 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10171 "in '%s' at %L", sym->name, &sym->declared_at);
10174 if (sym->attr.subroutine && sym->attr.result)
10176 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10177 "in '%s' at %L", sym->name, &sym->declared_at);
10180 if (sym->attr.external && sym->attr.function
10181 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10182 || sym->attr.contained))
10184 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10185 "in '%s' at %L", sym->name, &sym->declared_at);
10188 if (strcmp ("ppr@", sym->name) == 0)
10190 gfc_error ("Procedure pointer result '%s' at %L "
10191 "is missing the pointer attribute",
10192 sym->ns->proc_name->name, &sym->declared_at);
10201 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10202 been defined and we now know their defined arguments, check that they fulfill
10203 the requirements of the standard for procedures used as finalizers. */
10206 gfc_resolve_finalizers (gfc_symbol* derived)
10208 gfc_finalizer* list;
10209 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10210 gfc_try result = SUCCESS;
10211 bool seen_scalar = false;
10213 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10216 /* Walk over the list of finalizer-procedures, check them, and if any one
10217 does not fit in with the standard's definition, print an error and remove
10218 it from the list. */
10219 prev_link = &derived->f2k_derived->finalizers;
10220 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10226 /* Skip this finalizer if we already resolved it. */
10227 if (list->proc_tree)
10229 prev_link = &(list->next);
10233 /* Check this exists and is a SUBROUTINE. */
10234 if (!list->proc_sym->attr.subroutine)
10236 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10237 list->proc_sym->name, &list->where);
10241 /* We should have exactly one argument. */
10242 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10244 gfc_error ("FINAL procedure at %L must have exactly one argument",
10248 arg = list->proc_sym->formal->sym;
10250 /* This argument must be of our type. */
10251 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10253 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10254 &arg->declared_at, derived->name);
10258 /* It must neither be a pointer nor allocatable nor optional. */
10259 if (arg->attr.pointer)
10261 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10262 &arg->declared_at);
10265 if (arg->attr.allocatable)
10267 gfc_error ("Argument of FINAL procedure at %L must not be"
10268 " ALLOCATABLE", &arg->declared_at);
10271 if (arg->attr.optional)
10273 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10274 &arg->declared_at);
10278 /* It must not be INTENT(OUT). */
10279 if (arg->attr.intent == INTENT_OUT)
10281 gfc_error ("Argument of FINAL procedure at %L must not be"
10282 " INTENT(OUT)", &arg->declared_at);
10286 /* Warn if the procedure is non-scalar and not assumed shape. */
10287 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10288 && arg->as->type != AS_ASSUMED_SHAPE)
10289 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10290 " shape argument", &arg->declared_at);
10292 /* Check that it does not match in kind and rank with a FINAL procedure
10293 defined earlier. To really loop over the *earlier* declarations,
10294 we need to walk the tail of the list as new ones were pushed at the
10296 /* TODO: Handle kind parameters once they are implemented. */
10297 my_rank = (arg->as ? arg->as->rank : 0);
10298 for (i = list->next; i; i = i->next)
10300 /* Argument list might be empty; that is an error signalled earlier,
10301 but we nevertheless continued resolving. */
10302 if (i->proc_sym->formal)
10304 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10305 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10306 if (i_rank == my_rank)
10308 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10309 " rank (%d) as '%s'",
10310 list->proc_sym->name, &list->where, my_rank,
10311 i->proc_sym->name);
10317 /* Is this the/a scalar finalizer procedure? */
10318 if (!arg->as || arg->as->rank == 0)
10319 seen_scalar = true;
10321 /* Find the symtree for this procedure. */
10322 gcc_assert (!list->proc_tree);
10323 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10325 prev_link = &list->next;
10328 /* Remove wrong nodes immediately from the list so we don't risk any
10329 troubles in the future when they might fail later expectations. */
10333 *prev_link = list->next;
10334 gfc_free_finalizer (i);
10337 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10338 were nodes in the list, must have been for arrays. It is surely a good
10339 idea to have a scalar version there if there's something to finalize. */
10340 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10341 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10342 " defined at %L, suggest also scalar one",
10343 derived->name, &derived->declared_at);
10345 /* TODO: Remove this error when finalization is finished. */
10346 gfc_error ("Finalization at %L is not yet implemented",
10347 &derived->declared_at);
10353 /* Check that it is ok for the typebound procedure proc to override the
10357 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
10360 const gfc_symbol* proc_target;
10361 const gfc_symbol* old_target;
10362 unsigned proc_pass_arg, old_pass_arg, argpos;
10363 gfc_formal_arglist* proc_formal;
10364 gfc_formal_arglist* old_formal;
10366 /* This procedure should only be called for non-GENERIC proc. */
10367 gcc_assert (!proc->n.tb->is_generic);
10369 /* If the overwritten procedure is GENERIC, this is an error. */
10370 if (old->n.tb->is_generic)
10372 gfc_error ("Can't overwrite GENERIC '%s' at %L",
10373 old->name, &proc->n.tb->where);
10377 where = proc->n.tb->where;
10378 proc_target = proc->n.tb->u.specific->n.sym;
10379 old_target = old->n.tb->u.specific->n.sym;
10381 /* Check that overridden binding is not NON_OVERRIDABLE. */
10382 if (old->n.tb->non_overridable)
10384 gfc_error ("'%s' at %L overrides a procedure binding declared"
10385 " NON_OVERRIDABLE", proc->name, &where);
10389 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
10390 if (!old->n.tb->deferred && proc->n.tb->deferred)
10392 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
10393 " non-DEFERRED binding", proc->name, &where);
10397 /* If the overridden binding is PURE, the overriding must be, too. */
10398 if (old_target->attr.pure && !proc_target->attr.pure)
10400 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
10401 proc->name, &where);
10405 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
10406 is not, the overriding must not be either. */
10407 if (old_target->attr.elemental && !proc_target->attr.elemental)
10409 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
10410 " ELEMENTAL", proc->name, &where);
10413 if (!old_target->attr.elemental && proc_target->attr.elemental)
10415 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
10416 " be ELEMENTAL, either", proc->name, &where);
10420 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
10422 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
10424 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
10425 " SUBROUTINE", proc->name, &where);
10429 /* If the overridden binding is a FUNCTION, the overriding must also be a
10430 FUNCTION and have the same characteristics. */
10431 if (old_target->attr.function)
10433 if (!proc_target->attr.function)
10435 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
10436 " FUNCTION", proc->name, &where);
10440 /* FIXME: Do more comprehensive checking (including, for instance, the
10441 rank and array-shape). */
10442 gcc_assert (proc_target->result && old_target->result);
10443 if (!gfc_compare_types (&proc_target->result->ts,
10444 &old_target->result->ts))
10446 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
10447 " matching result types", proc->name, &where);
10452 /* If the overridden binding is PUBLIC, the overriding one must not be
10454 if (old->n.tb->access == ACCESS_PUBLIC
10455 && proc->n.tb->access == ACCESS_PRIVATE)
10457 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
10458 " PRIVATE", proc->name, &where);
10462 /* Compare the formal argument lists of both procedures. This is also abused
10463 to find the position of the passed-object dummy arguments of both
10464 bindings as at least the overridden one might not yet be resolved and we
10465 need those positions in the check below. */
10466 proc_pass_arg = old_pass_arg = 0;
10467 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
10469 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
10472 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
10473 proc_formal && old_formal;
10474 proc_formal = proc_formal->next, old_formal = old_formal->next)
10476 if (proc->n.tb->pass_arg
10477 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
10478 proc_pass_arg = argpos;
10479 if (old->n.tb->pass_arg
10480 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
10481 old_pass_arg = argpos;
10483 /* Check that the names correspond. */
10484 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
10486 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
10487 " to match the corresponding argument of the overridden"
10488 " procedure", proc_formal->sym->name, proc->name, &where,
10489 old_formal->sym->name);
10493 /* Check that the types correspond if neither is the passed-object
10495 /* FIXME: Do more comprehensive testing here. */
10496 if (proc_pass_arg != argpos && old_pass_arg != argpos
10497 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
10499 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
10500 "in respect to the overridden procedure",
10501 proc_formal->sym->name, proc->name, &where);
10507 if (proc_formal || old_formal)
10509 gfc_error ("'%s' at %L must have the same number of formal arguments as"
10510 " the overridden procedure", proc->name, &where);
10514 /* If the overridden binding is NOPASS, the overriding one must also be
10516 if (old->n.tb->nopass && !proc->n.tb->nopass)
10518 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
10519 " NOPASS", proc->name, &where);
10523 /* If the overridden binding is PASS(x), the overriding one must also be
10524 PASS and the passed-object dummy arguments must correspond. */
10525 if (!old->n.tb->nopass)
10527 if (proc->n.tb->nopass)
10529 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
10530 " PASS", proc->name, &where);
10534 if (proc_pass_arg != old_pass_arg)
10536 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
10537 " the same position as the passed-object dummy argument of"
10538 " the overridden procedure", proc->name, &where);
10547 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10550 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10551 const char* generic_name, locus where)
10556 gcc_assert (t1->specific && t2->specific);
10557 gcc_assert (!t1->specific->is_generic);
10558 gcc_assert (!t2->specific->is_generic);
10560 sym1 = t1->specific->u.specific->n.sym;
10561 sym2 = t2->specific->u.specific->n.sym;
10566 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10567 if (sym1->attr.subroutine != sym2->attr.subroutine
10568 || sym1->attr.function != sym2->attr.function)
10570 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10571 " GENERIC '%s' at %L",
10572 sym1->name, sym2->name, generic_name, &where);
10576 /* Compare the interfaces. */
10577 if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
10579 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10580 sym1->name, sym2->name, generic_name, &where);
10588 /* Worker function for resolving a generic procedure binding; this is used to
10589 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10591 The difference between those cases is finding possible inherited bindings
10592 that are overridden, as one has to look for them in tb_sym_root,
10593 tb_uop_root or tb_op, respectively. Thus the caller must already find
10594 the super-type and set p->overridden correctly. */
10597 resolve_tb_generic_targets (gfc_symbol* super_type,
10598 gfc_typebound_proc* p, const char* name)
10600 gfc_tbp_generic* target;
10601 gfc_symtree* first_target;
10602 gfc_symtree* inherited;
10604 gcc_assert (p && p->is_generic);
10606 /* Try to find the specific bindings for the symtrees in our target-list. */
10607 gcc_assert (p->u.generic);
10608 for (target = p->u.generic; target; target = target->next)
10609 if (!target->specific)
10611 gfc_typebound_proc* overridden_tbp;
10612 gfc_tbp_generic* g;
10613 const char* target_name;
10615 target_name = target->specific_st->name;
10617 /* Defined for this type directly. */
10618 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
10620 target->specific = target->specific_st->n.tb;
10621 goto specific_found;
10624 /* Look for an inherited specific binding. */
10627 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
10632 gcc_assert (inherited->n.tb);
10633 target->specific = inherited->n.tb;
10634 goto specific_found;
10638 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
10639 " at %L", target_name, name, &p->where);
10642 /* Once we've found the specific binding, check it is not ambiguous with
10643 other specifics already found or inherited for the same GENERIC. */
10645 gcc_assert (target->specific);
10647 /* This must really be a specific binding! */
10648 if (target->specific->is_generic)
10650 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
10651 " '%s' is GENERIC, too", name, &p->where, target_name);
10655 /* Check those already resolved on this type directly. */
10656 for (g = p->u.generic; g; g = g->next)
10657 if (g != target && g->specific
10658 && check_generic_tbp_ambiguity (target, g, name, p->where)
10662 /* Check for ambiguity with inherited specific targets. */
10663 for (overridden_tbp = p->overridden; overridden_tbp;
10664 overridden_tbp = overridden_tbp->overridden)
10665 if (overridden_tbp->is_generic)
10667 for (g = overridden_tbp->u.generic; g; g = g->next)
10669 gcc_assert (g->specific);
10670 if (check_generic_tbp_ambiguity (target, g,
10671 name, p->where) == FAILURE)
10677 /* If we attempt to "overwrite" a specific binding, this is an error. */
10678 if (p->overridden && !p->overridden->is_generic)
10680 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
10681 " the same name", name, &p->where);
10685 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
10686 all must have the same attributes here. */
10687 first_target = p->u.generic->specific->u.specific;
10688 gcc_assert (first_target);
10689 p->subroutine = first_target->n.sym->attr.subroutine;
10690 p->function = first_target->n.sym->attr.function;
10696 /* Resolve a GENERIC procedure binding for a derived type. */
10699 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
10701 gfc_symbol* super_type;
10703 /* Find the overridden binding if any. */
10704 st->n.tb->overridden = NULL;
10705 super_type = gfc_get_derived_super_type (derived);
10708 gfc_symtree* overridden;
10709 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
10712 if (overridden && overridden->n.tb)
10713 st->n.tb->overridden = overridden->n.tb;
10716 /* Resolve using worker function. */
10717 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
10721 /* Retrieve the target-procedure of an operator binding and do some checks in
10722 common for intrinsic and user-defined type-bound operators. */
10725 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
10727 gfc_symbol* target_proc;
10729 gcc_assert (target->specific && !target->specific->is_generic);
10730 target_proc = target->specific->u.specific->n.sym;
10731 gcc_assert (target_proc);
10733 /* All operator bindings must have a passed-object dummy argument. */
10734 if (target->specific->nopass)
10736 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
10740 return target_proc;
10744 /* Resolve a type-bound intrinsic operator. */
10747 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
10748 gfc_typebound_proc* p)
10750 gfc_symbol* super_type;
10751 gfc_tbp_generic* target;
10753 /* If there's already an error here, do nothing (but don't fail again). */
10757 /* Operators should always be GENERIC bindings. */
10758 gcc_assert (p->is_generic);
10760 /* Look for an overridden binding. */
10761 super_type = gfc_get_derived_super_type (derived);
10762 if (super_type && super_type->f2k_derived)
10763 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
10766 p->overridden = NULL;
10768 /* Resolve general GENERIC properties using worker function. */
10769 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
10772 /* Check the targets to be procedures of correct interface. */
10773 for (target = p->u.generic; target; target = target->next)
10775 gfc_symbol* target_proc;
10777 target_proc = get_checked_tb_operator_target (target, p->where);
10781 if (!gfc_check_operator_interface (target_proc, op, p->where))
10793 /* Resolve a type-bound user operator (tree-walker callback). */
10795 static gfc_symbol* resolve_bindings_derived;
10796 static gfc_try resolve_bindings_result;
10798 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
10801 resolve_typebound_user_op (gfc_symtree* stree)
10803 gfc_symbol* super_type;
10804 gfc_tbp_generic* target;
10806 gcc_assert (stree && stree->n.tb);
10808 if (stree->n.tb->error)
10811 /* Operators should always be GENERIC bindings. */
10812 gcc_assert (stree->n.tb->is_generic);
10814 /* Find overridden procedure, if any. */
10815 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10816 if (super_type && super_type->f2k_derived)
10818 gfc_symtree* overridden;
10819 overridden = gfc_find_typebound_user_op (super_type, NULL,
10820 stree->name, true, NULL);
10822 if (overridden && overridden->n.tb)
10823 stree->n.tb->overridden = overridden->n.tb;
10826 stree->n.tb->overridden = NULL;
10828 /* Resolve basically using worker function. */
10829 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
10833 /* Check the targets to be functions of correct interface. */
10834 for (target = stree->n.tb->u.generic; target; target = target->next)
10836 gfc_symbol* target_proc;
10838 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
10842 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
10849 resolve_bindings_result = FAILURE;
10850 stree->n.tb->error = 1;
10854 /* Resolve the type-bound procedures for a derived type. */
10857 resolve_typebound_procedure (gfc_symtree* stree)
10861 gfc_symbol* me_arg;
10862 gfc_symbol* super_type;
10863 gfc_component* comp;
10865 gcc_assert (stree);
10867 /* Undefined specific symbol from GENERIC target definition. */
10871 if (stree->n.tb->error)
10874 /* If this is a GENERIC binding, use that routine. */
10875 if (stree->n.tb->is_generic)
10877 if (resolve_typebound_generic (resolve_bindings_derived, stree)
10883 /* Get the target-procedure to check it. */
10884 gcc_assert (!stree->n.tb->is_generic);
10885 gcc_assert (stree->n.tb->u.specific);
10886 proc = stree->n.tb->u.specific->n.sym;
10887 where = stree->n.tb->where;
10889 /* Default access should already be resolved from the parser. */
10890 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
10892 /* It should be a module procedure or an external procedure with explicit
10893 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
10894 if ((!proc->attr.subroutine && !proc->attr.function)
10895 || (proc->attr.proc != PROC_MODULE
10896 && proc->attr.if_source != IFSRC_IFBODY)
10897 || (proc->attr.abstract && !stree->n.tb->deferred))
10899 gfc_error ("'%s' must be a module procedure or an external procedure with"
10900 " an explicit interface at %L", proc->name, &where);
10903 stree->n.tb->subroutine = proc->attr.subroutine;
10904 stree->n.tb->function = proc->attr.function;
10906 /* Find the super-type of the current derived type. We could do this once and
10907 store in a global if speed is needed, but as long as not I believe this is
10908 more readable and clearer. */
10909 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10911 /* If PASS, resolve and check arguments if not already resolved / loaded
10912 from a .mod file. */
10913 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
10915 if (stree->n.tb->pass_arg)
10917 gfc_formal_arglist* i;
10919 /* If an explicit passing argument name is given, walk the arg-list
10920 and look for it. */
10923 stree->n.tb->pass_arg_num = 1;
10924 for (i = proc->formal; i; i = i->next)
10926 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
10931 ++stree->n.tb->pass_arg_num;
10936 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
10938 proc->name, stree->n.tb->pass_arg, &where,
10939 stree->n.tb->pass_arg);
10945 /* Otherwise, take the first one; there should in fact be at least
10947 stree->n.tb->pass_arg_num = 1;
10950 gfc_error ("Procedure '%s' with PASS at %L must have at"
10951 " least one argument", proc->name, &where);
10954 me_arg = proc->formal->sym;
10957 /* Now check that the argument-type matches and the passed-object
10958 dummy argument is generally fine. */
10960 gcc_assert (me_arg);
10962 if (me_arg->ts.type != BT_CLASS)
10964 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
10965 " at %L", proc->name, &where);
10969 if (CLASS_DATA (me_arg)->ts.u.derived
10970 != resolve_bindings_derived)
10972 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
10973 " the derived-type '%s'", me_arg->name, proc->name,
10974 me_arg->name, &where, resolve_bindings_derived->name);
10978 gcc_assert (me_arg->ts.type == BT_CLASS);
10979 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
10981 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
10982 " scalar", proc->name, &where);
10985 if (CLASS_DATA (me_arg)->attr.allocatable)
10987 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
10988 " be ALLOCATABLE", proc->name, &where);
10991 if (CLASS_DATA (me_arg)->attr.class_pointer)
10993 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
10994 " be POINTER", proc->name, &where);
10999 /* If we are extending some type, check that we don't override a procedure
11000 flagged NON_OVERRIDABLE. */
11001 stree->n.tb->overridden = NULL;
11004 gfc_symtree* overridden;
11005 overridden = gfc_find_typebound_proc (super_type, NULL,
11006 stree->name, true, NULL);
11008 if (overridden && overridden->n.tb)
11009 stree->n.tb->overridden = overridden->n.tb;
11011 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
11015 /* See if there's a name collision with a component directly in this type. */
11016 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11017 if (!strcmp (comp->name, stree->name))
11019 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11021 stree->name, &where, resolve_bindings_derived->name);
11025 /* Try to find a name collision with an inherited component. */
11026 if (super_type && gfc_find_component (super_type, stree->name, true, true))
11028 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11029 " component of '%s'",
11030 stree->name, &where, resolve_bindings_derived->name);
11034 stree->n.tb->error = 0;
11038 resolve_bindings_result = FAILURE;
11039 stree->n.tb->error = 1;
11044 resolve_typebound_procedures (gfc_symbol* derived)
11048 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11051 resolve_bindings_derived = derived;
11052 resolve_bindings_result = SUCCESS;
11054 /* Make sure the vtab has been generated. */
11055 gfc_find_derived_vtab (derived);
11057 if (derived->f2k_derived->tb_sym_root)
11058 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11059 &resolve_typebound_procedure);
11061 if (derived->f2k_derived->tb_uop_root)
11062 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11063 &resolve_typebound_user_op);
11065 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11067 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11068 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11070 resolve_bindings_result = FAILURE;
11073 return resolve_bindings_result;
11077 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11078 to give all identical derived types the same backend_decl. */
11080 add_dt_to_dt_list (gfc_symbol *derived)
11082 gfc_dt_list *dt_list;
11084 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11085 if (derived == dt_list->derived)
11088 if (dt_list == NULL)
11090 dt_list = gfc_get_dt_list ();
11091 dt_list->next = gfc_derived_types;
11092 dt_list->derived = derived;
11093 gfc_derived_types = dt_list;
11098 /* Ensure that a derived-type is really not abstract, meaning that every
11099 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11102 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11107 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11109 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11112 if (st->n.tb && st->n.tb->deferred)
11114 gfc_symtree* overriding;
11115 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11118 gcc_assert (overriding->n.tb);
11119 if (overriding->n.tb->deferred)
11121 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11122 " '%s' is DEFERRED and not overridden",
11123 sub->name, &sub->declared_at, st->name);
11132 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11134 /* The algorithm used here is to recursively travel up the ancestry of sub
11135 and for each ancestor-type, check all bindings. If any of them is
11136 DEFERRED, look it up starting from sub and see if the found (overriding)
11137 binding is not DEFERRED.
11138 This is not the most efficient way to do this, but it should be ok and is
11139 clearer than something sophisticated. */
11141 gcc_assert (ancestor && !sub->attr.abstract);
11143 if (!ancestor->attr.abstract)
11146 /* Walk bindings of this ancestor. */
11147 if (ancestor->f2k_derived)
11150 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11155 /* Find next ancestor type and recurse on it. */
11156 ancestor = gfc_get_derived_super_type (ancestor);
11158 return ensure_not_abstract (sub, ancestor);
11164 /* Resolve the components of a derived type. */
11167 resolve_fl_derived (gfc_symbol *sym)
11169 gfc_symbol* super_type;
11172 super_type = gfc_get_derived_super_type (sym);
11174 if (sym->attr.is_class && sym->ts.u.derived == NULL)
11176 /* Fix up incomplete CLASS symbols. */
11177 gfc_component *data = gfc_find_component (sym, "$data", true, true);
11178 gfc_component *vptr = gfc_find_component (sym, "$vptr", true, true);
11179 if (vptr->ts.u.derived == NULL)
11181 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
11183 vptr->ts.u.derived = vtab->ts.u.derived;
11188 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11190 gfc_error ("As extending type '%s' at %L has a coarray component, "
11191 "parent type '%s' shall also have one", sym->name,
11192 &sym->declared_at, super_type->name);
11196 /* Ensure the extended type gets resolved before we do. */
11197 if (super_type && resolve_fl_derived (super_type) == FAILURE)
11200 /* An ABSTRACT type must be extensible. */
11201 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11203 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11204 sym->name, &sym->declared_at);
11208 for (c = sym->components; c != NULL; c = c->next)
11211 if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */
11212 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11214 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11215 "deferred shape", c->name, &c->loc);
11220 if (c->attr.codimension && c->ts.type == BT_DERIVED
11221 && c->ts.u.derived->ts.is_iso_c)
11223 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11224 "shall not be a coarray", c->name, &c->loc);
11229 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11230 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11231 || c->attr.allocatable))
11233 gfc_error ("Component '%s' at %L with coarray component "
11234 "shall be a nonpointer, nonallocatable scalar",
11240 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11242 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11243 "is not an array pointer", c->name, &c->loc);
11247 if (c->attr.proc_pointer && c->ts.interface)
11249 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11250 gfc_error ("Interface '%s', used by procedure pointer component "
11251 "'%s' at %L, is declared in a later PROCEDURE statement",
11252 c->ts.interface->name, c->name, &c->loc);
11254 /* Get the attributes from the interface (now resolved). */
11255 if (c->ts.interface->attr.if_source
11256 || c->ts.interface->attr.intrinsic)
11258 gfc_symbol *ifc = c->ts.interface;
11260 if (ifc->formal && !ifc->formal_ns)
11261 resolve_symbol (ifc);
11263 if (ifc->attr.intrinsic)
11264 resolve_intrinsic (ifc, &ifc->declared_at);
11268 c->ts = ifc->result->ts;
11269 c->attr.allocatable = ifc->result->attr.allocatable;
11270 c->attr.pointer = ifc->result->attr.pointer;
11271 c->attr.dimension = ifc->result->attr.dimension;
11272 c->as = gfc_copy_array_spec (ifc->result->as);
11277 c->attr.allocatable = ifc->attr.allocatable;
11278 c->attr.pointer = ifc->attr.pointer;
11279 c->attr.dimension = ifc->attr.dimension;
11280 c->as = gfc_copy_array_spec (ifc->as);
11282 c->ts.interface = ifc;
11283 c->attr.function = ifc->attr.function;
11284 c->attr.subroutine = ifc->attr.subroutine;
11285 gfc_copy_formal_args_ppc (c, ifc);
11287 c->attr.pure = ifc->attr.pure;
11288 c->attr.elemental = ifc->attr.elemental;
11289 c->attr.recursive = ifc->attr.recursive;
11290 c->attr.always_explicit = ifc->attr.always_explicit;
11291 c->attr.ext_attr |= ifc->attr.ext_attr;
11292 /* Replace symbols in array spec. */
11296 for (i = 0; i < c->as->rank; i++)
11298 gfc_expr_replace_comp (c->as->lower[i], c);
11299 gfc_expr_replace_comp (c->as->upper[i], c);
11302 /* Copy char length. */
11303 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11305 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11306 gfc_expr_replace_comp (cl->length, c);
11307 if (cl->length && !cl->resolved
11308 && gfc_resolve_expr (cl->length) == FAILURE)
11313 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11315 gfc_error ("Interface '%s' of procedure pointer component "
11316 "'%s' at %L must be explicit", c->ts.interface->name,
11321 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11323 /* Since PPCs are not implicitly typed, a PPC without an explicit
11324 interface must be a subroutine. */
11325 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11328 /* Procedure pointer components: Check PASS arg. */
11329 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11330 && !sym->attr.vtype)
11332 gfc_symbol* me_arg;
11334 if (c->tb->pass_arg)
11336 gfc_formal_arglist* i;
11338 /* If an explicit passing argument name is given, walk the arg-list
11339 and look for it. */
11342 c->tb->pass_arg_num = 1;
11343 for (i = c->formal; i; i = i->next)
11345 if (!strcmp (i->sym->name, c->tb->pass_arg))
11350 c->tb->pass_arg_num++;
11355 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11356 "at %L has no argument '%s'", c->name,
11357 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11364 /* Otherwise, take the first one; there should in fact be at least
11366 c->tb->pass_arg_num = 1;
11369 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11370 "must have at least one argument",
11375 me_arg = c->formal->sym;
11378 /* Now check that the argument-type matches. */
11379 gcc_assert (me_arg);
11380 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11381 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11382 || (me_arg->ts.type == BT_CLASS
11383 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11385 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11386 " the derived type '%s'", me_arg->name, c->name,
11387 me_arg->name, &c->loc, sym->name);
11392 /* Check for C453. */
11393 if (me_arg->attr.dimension)
11395 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11396 "must be scalar", me_arg->name, c->name, me_arg->name,
11402 if (me_arg->attr.pointer)
11404 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11405 "may not have the POINTER attribute", me_arg->name,
11406 c->name, me_arg->name, &c->loc);
11411 if (me_arg->attr.allocatable)
11413 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11414 "may not be ALLOCATABLE", me_arg->name, c->name,
11415 me_arg->name, &c->loc);
11420 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11421 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11422 " at %L", c->name, &c->loc);
11426 /* Check type-spec if this is not the parent-type component. */
11427 if ((!sym->attr.extension || c != sym->components) && !sym->attr.vtype
11428 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11431 /* If this type is an extension, set the accessibility of the parent
11433 if (super_type && c == sym->components
11434 && strcmp (super_type->name, c->name) == 0)
11435 c->attr.access = super_type->attr.access;
11437 /* If this type is an extension, see if this component has the same name
11438 as an inherited type-bound procedure. */
11439 if (super_type && !sym->attr.is_class
11440 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11442 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11443 " inherited type-bound procedure",
11444 c->name, sym->name, &c->loc);
11448 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
11450 if (c->ts.u.cl->length == NULL
11451 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11452 || !gfc_is_constant_expr (c->ts.u.cl->length))
11454 gfc_error ("Character length of component '%s' needs to "
11455 "be a constant specification expression at %L",
11457 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11462 if (c->ts.type == BT_DERIVED
11463 && sym->component_access != ACCESS_PRIVATE
11464 && gfc_check_access (sym->attr.access, sym->ns->default_access)
11465 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11466 && !c->ts.u.derived->attr.use_assoc
11467 && !gfc_check_access (c->ts.u.derived->attr.access,
11468 c->ts.u.derived->ns->default_access)
11469 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11470 "is a PRIVATE type and cannot be a component of "
11471 "'%s', which is PUBLIC at %L", c->name,
11472 sym->name, &sym->declared_at) == FAILURE)
11475 if (sym->attr.sequence)
11477 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11479 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11480 "not have the SEQUENCE attribute",
11481 c->ts.u.derived->name, &sym->declared_at);
11486 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
11487 && c->attr.pointer && c->ts.u.derived->components == NULL
11488 && !c->ts.u.derived->attr.zero_comp)
11490 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11491 "that has not been declared", c->name, sym->name,
11496 if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer
11497 && CLASS_DATA (c)->ts.u.derived->components == NULL
11498 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11500 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11501 "that has not been declared", c->name, sym->name,
11507 if (c->ts.type == BT_CLASS
11508 && !(CLASS_DATA (c)->attr.class_pointer
11509 || CLASS_DATA (c)->attr.allocatable))
11511 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11512 "or pointer", c->name, &c->loc);
11516 /* Ensure that all the derived type components are put on the
11517 derived type list; even in formal namespaces, where derived type
11518 pointer components might not have been declared. */
11519 if (c->ts.type == BT_DERIVED
11521 && c->ts.u.derived->components
11523 && sym != c->ts.u.derived)
11524 add_dt_to_dt_list (c->ts.u.derived);
11526 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11527 || c->attr.proc_pointer
11528 || c->attr.allocatable)) == FAILURE)
11532 /* Resolve the type-bound procedures. */
11533 if (resolve_typebound_procedures (sym) == FAILURE)
11536 /* Resolve the finalizer procedures. */
11537 if (gfc_resolve_finalizers (sym) == FAILURE)
11540 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11541 all DEFERRED bindings are overridden. */
11542 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11543 && !sym->attr.is_class
11544 && ensure_not_abstract (sym, super_type) == FAILURE)
11547 /* Add derived type to the derived type list. */
11548 add_dt_to_dt_list (sym);
11555 resolve_fl_namelist (gfc_symbol *sym)
11560 for (nl = sym->namelist; nl; nl = nl->next)
11562 /* Reject namelist arrays of assumed shape. */
11563 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
11564 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
11565 "must not have assumed shape in namelist "
11566 "'%s' at %L", nl->sym->name, sym->name,
11567 &sym->declared_at) == FAILURE)
11570 /* Reject namelist arrays that are not constant shape. */
11571 if (is_non_constant_shape_array (nl->sym))
11573 gfc_error ("NAMELIST array object '%s' must have constant "
11574 "shape in namelist '%s' at %L", nl->sym->name,
11575 sym->name, &sym->declared_at);
11579 /* Namelist objects cannot have allocatable or pointer components. */
11580 if (nl->sym->ts.type != BT_DERIVED)
11583 if (nl->sym->ts.u.derived->attr.alloc_comp)
11585 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11586 "have ALLOCATABLE components",
11587 nl->sym->name, sym->name, &sym->declared_at);
11591 if (nl->sym->ts.u.derived->attr.pointer_comp)
11593 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11594 "have POINTER components",
11595 nl->sym->name, sym->name, &sym->declared_at);
11600 /* Reject PRIVATE objects in a PUBLIC namelist. */
11601 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
11603 for (nl = sym->namelist; nl; nl = nl->next)
11605 if (!nl->sym->attr.use_assoc
11606 && !is_sym_host_assoc (nl->sym, sym->ns)
11607 && !gfc_check_access(nl->sym->attr.access,
11608 nl->sym->ns->default_access))
11610 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
11611 "cannot be member of PUBLIC namelist '%s' at %L",
11612 nl->sym->name, sym->name, &sym->declared_at);
11616 /* Types with private components that came here by USE-association. */
11617 if (nl->sym->ts.type == BT_DERIVED
11618 && derived_inaccessible (nl->sym->ts.u.derived))
11620 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
11621 "components and cannot be member of namelist '%s' at %L",
11622 nl->sym->name, sym->name, &sym->declared_at);
11626 /* Types with private components that are defined in the same module. */
11627 if (nl->sym->ts.type == BT_DERIVED
11628 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
11629 && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
11630 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
11631 nl->sym->ns->default_access))
11633 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
11634 "cannot be a member of PUBLIC namelist '%s' at %L",
11635 nl->sym->name, sym->name, &sym->declared_at);
11642 /* 14.1.2 A module or internal procedure represent local entities
11643 of the same type as a namelist member and so are not allowed. */
11644 for (nl = sym->namelist; nl; nl = nl->next)
11646 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
11649 if (nl->sym->attr.function && nl->sym == nl->sym->result)
11650 if ((nl->sym == sym->ns->proc_name)
11652 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
11656 if (nl->sym && nl->sym->name)
11657 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
11658 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
11660 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
11661 "attribute in '%s' at %L", nlsym->name,
11662 &sym->declared_at);
11672 resolve_fl_parameter (gfc_symbol *sym)
11674 /* A parameter array's shape needs to be constant. */
11675 if (sym->as != NULL
11676 && (sym->as->type == AS_DEFERRED
11677 || is_non_constant_shape_array (sym)))
11679 gfc_error ("Parameter array '%s' at %L cannot be automatic "
11680 "or of deferred shape", sym->name, &sym->declared_at);
11684 /* Make sure a parameter that has been implicitly typed still
11685 matches the implicit type, since PARAMETER statements can precede
11686 IMPLICIT statements. */
11687 if (sym->attr.implicit_type
11688 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
11691 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
11692 "later IMPLICIT type", sym->name, &sym->declared_at);
11696 /* Make sure the types of derived parameters are consistent. This
11697 type checking is deferred until resolution because the type may
11698 refer to a derived type from the host. */
11699 if (sym->ts.type == BT_DERIVED
11700 && !gfc_compare_types (&sym->ts, &sym->value->ts))
11702 gfc_error ("Incompatible derived type in PARAMETER at %L",
11703 &sym->value->where);
11710 /* Do anything necessary to resolve a symbol. Right now, we just
11711 assume that an otherwise unknown symbol is a variable. This sort
11712 of thing commonly happens for symbols in module. */
11715 resolve_symbol (gfc_symbol *sym)
11717 int check_constant, mp_flag;
11718 gfc_symtree *symtree;
11719 gfc_symtree *this_symtree;
11723 /* Avoid double resolution of function result symbols. */
11724 if ((sym->result || sym->attr.result) && !sym->attr.dummy
11725 && (sym->ns != gfc_current_ns))
11728 if (sym->attr.flavor == FL_UNKNOWN)
11731 /* If we find that a flavorless symbol is an interface in one of the
11732 parent namespaces, find its symtree in this namespace, free the
11733 symbol and set the symtree to point to the interface symbol. */
11734 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
11736 symtree = gfc_find_symtree (ns->sym_root, sym->name);
11737 if (symtree && symtree->n.sym->generic)
11739 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
11741 gfc_release_symbol (sym);
11742 symtree->n.sym->refs++;
11743 this_symtree->n.sym = symtree->n.sym;
11748 /* Otherwise give it a flavor according to such attributes as
11750 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
11751 sym->attr.flavor = FL_VARIABLE;
11754 sym->attr.flavor = FL_PROCEDURE;
11755 if (sym->attr.dimension)
11756 sym->attr.function = 1;
11760 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
11761 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
11763 if (sym->attr.procedure && sym->ts.interface
11764 && sym->attr.if_source != IFSRC_DECL
11765 && resolve_procedure_interface (sym) == FAILURE)
11768 if (sym->attr.is_protected && !sym->attr.proc_pointer
11769 && (sym->attr.procedure || sym->attr.external))
11771 if (sym->attr.external)
11772 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
11773 "at %L", &sym->declared_at);
11775 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
11776 "at %L", &sym->declared_at);
11783 if (sym->attr.contiguous
11784 && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE
11785 && !sym->attr.pointer)))
11787 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
11788 "array pointer or an assumed-shape array", sym->name,
11789 &sym->declared_at);
11793 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
11796 /* Symbols that are module procedures with results (functions) have
11797 the types and array specification copied for type checking in
11798 procedures that call them, as well as for saving to a module
11799 file. These symbols can't stand the scrutiny that their results
11801 mp_flag = (sym->result != NULL && sym->result != sym);
11803 /* Make sure that the intrinsic is consistent with its internal
11804 representation. This needs to be done before assigning a default
11805 type to avoid spurious warnings. */
11806 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
11807 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
11810 /* Resolve associate names. */
11812 resolve_assoc_var (sym, true);
11814 /* Assign default type to symbols that need one and don't have one. */
11815 if (sym->ts.type == BT_UNKNOWN)
11817 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
11818 gfc_set_default_type (sym, 1, NULL);
11820 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
11821 && !sym->attr.function && !sym->attr.subroutine
11822 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
11823 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
11825 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
11827 /* The specific case of an external procedure should emit an error
11828 in the case that there is no implicit type. */
11830 gfc_set_default_type (sym, sym->attr.external, NULL);
11833 /* Result may be in another namespace. */
11834 resolve_symbol (sym->result);
11836 if (!sym->result->attr.proc_pointer)
11838 sym->ts = sym->result->ts;
11839 sym->as = gfc_copy_array_spec (sym->result->as);
11840 sym->attr.dimension = sym->result->attr.dimension;
11841 sym->attr.pointer = sym->result->attr.pointer;
11842 sym->attr.allocatable = sym->result->attr.allocatable;
11843 sym->attr.contiguous = sym->result->attr.contiguous;
11849 /* Assumed size arrays and assumed shape arrays must be dummy
11850 arguments. Array-spec's of implied-shape should have been resolved to
11851 AS_EXPLICIT already. */
11855 gcc_assert (sym->as->type != AS_IMPLIED_SHAPE);
11856 if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
11857 || sym->as->type == AS_ASSUMED_SHAPE)
11858 && sym->attr.dummy == 0)
11860 if (sym->as->type == AS_ASSUMED_SIZE)
11861 gfc_error ("Assumed size array at %L must be a dummy argument",
11862 &sym->declared_at);
11864 gfc_error ("Assumed shape array at %L must be a dummy argument",
11865 &sym->declared_at);
11870 /* Make sure symbols with known intent or optional are really dummy
11871 variable. Because of ENTRY statement, this has to be deferred
11872 until resolution time. */
11874 if (!sym->attr.dummy
11875 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
11877 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
11881 if (sym->attr.value && !sym->attr.dummy)
11883 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
11884 "it is not a dummy argument", sym->name, &sym->declared_at);
11888 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
11890 gfc_charlen *cl = sym->ts.u.cl;
11891 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
11893 gfc_error ("Character dummy variable '%s' at %L with VALUE "
11894 "attribute must have constant length",
11895 sym->name, &sym->declared_at);
11899 if (sym->ts.is_c_interop
11900 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
11902 gfc_error ("C interoperable character dummy variable '%s' at %L "
11903 "with VALUE attribute must have length one",
11904 sym->name, &sym->declared_at);
11909 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
11910 do this for something that was implicitly typed because that is handled
11911 in gfc_set_default_type. Handle dummy arguments and procedure
11912 definitions separately. Also, anything that is use associated is not
11913 handled here but instead is handled in the module it is declared in.
11914 Finally, derived type definitions are allowed to be BIND(C) since that
11915 only implies that they're interoperable, and they are checked fully for
11916 interoperability when a variable is declared of that type. */
11917 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
11918 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
11919 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
11921 gfc_try t = SUCCESS;
11923 /* First, make sure the variable is declared at the
11924 module-level scope (J3/04-007, Section 15.3). */
11925 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
11926 sym->attr.in_common == 0)
11928 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
11929 "is neither a COMMON block nor declared at the "
11930 "module level scope", sym->name, &(sym->declared_at));
11933 else if (sym->common_head != NULL)
11935 t = verify_com_block_vars_c_interop (sym->common_head);
11939 /* If type() declaration, we need to verify that the components
11940 of the given type are all C interoperable, etc. */
11941 if (sym->ts.type == BT_DERIVED &&
11942 sym->ts.u.derived->attr.is_c_interop != 1)
11944 /* Make sure the user marked the derived type as BIND(C). If
11945 not, call the verify routine. This could print an error
11946 for the derived type more than once if multiple variables
11947 of that type are declared. */
11948 if (sym->ts.u.derived->attr.is_bind_c != 1)
11949 verify_bind_c_derived_type (sym->ts.u.derived);
11953 /* Verify the variable itself as C interoperable if it
11954 is BIND(C). It is not possible for this to succeed if
11955 the verify_bind_c_derived_type failed, so don't have to handle
11956 any error returned by verify_bind_c_derived_type. */
11957 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
11958 sym->common_block);
11963 /* clear the is_bind_c flag to prevent reporting errors more than
11964 once if something failed. */
11965 sym->attr.is_bind_c = 0;
11970 /* If a derived type symbol has reached this point, without its
11971 type being declared, we have an error. Notice that most
11972 conditions that produce undefined derived types have already
11973 been dealt with. However, the likes of:
11974 implicit type(t) (t) ..... call foo (t) will get us here if
11975 the type is not declared in the scope of the implicit
11976 statement. Change the type to BT_UNKNOWN, both because it is so
11977 and to prevent an ICE. */
11978 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
11979 && !sym->ts.u.derived->attr.zero_comp)
11981 gfc_error ("The derived type '%s' at %L is of type '%s', "
11982 "which has not been defined", sym->name,
11983 &sym->declared_at, sym->ts.u.derived->name);
11984 sym->ts.type = BT_UNKNOWN;
11988 /* Make sure that the derived type has been resolved and that the
11989 derived type is visible in the symbol's namespace, if it is a
11990 module function and is not PRIVATE. */
11991 if (sym->ts.type == BT_DERIVED
11992 && sym->ts.u.derived->attr.use_assoc
11993 && sym->ns->proc_name
11994 && sym->ns->proc_name->attr.flavor == FL_MODULE)
11998 if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
12001 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
12002 if (!ds && sym->attr.function
12003 && gfc_check_access (sym->attr.access, sym->ns->default_access))
12005 symtree = gfc_new_symtree (&sym->ns->sym_root,
12006 sym->ts.u.derived->name);
12007 symtree->n.sym = sym->ts.u.derived;
12008 sym->ts.u.derived->refs++;
12012 /* Unless the derived-type declaration is use associated, Fortran 95
12013 does not allow public entries of private derived types.
12014 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12015 161 in 95-006r3. */
12016 if (sym->ts.type == BT_DERIVED
12017 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12018 && !sym->ts.u.derived->attr.use_assoc
12019 && gfc_check_access (sym->attr.access, sym->ns->default_access)
12020 && !gfc_check_access (sym->ts.u.derived->attr.access,
12021 sym->ts.u.derived->ns->default_access)
12022 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12023 "of PRIVATE derived type '%s'",
12024 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12025 : "variable", sym->name, &sym->declared_at,
12026 sym->ts.u.derived->name) == FAILURE)
12029 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12030 default initialization is defined (5.1.2.4.4). */
12031 if (sym->ts.type == BT_DERIVED
12033 && sym->attr.intent == INTENT_OUT
12035 && sym->as->type == AS_ASSUMED_SIZE)
12037 for (c = sym->ts.u.derived->components; c; c = c->next)
12039 if (c->initializer)
12041 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12042 "ASSUMED SIZE and so cannot have a default initializer",
12043 sym->name, &sym->declared_at);
12050 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12051 || sym->attr.codimension)
12052 && sym->attr.result)
12053 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12054 "a coarray component", sym->name, &sym->declared_at);
12057 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12058 && sym->ts.u.derived->ts.is_iso_c)
12059 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12060 "shall not be a coarray", sym->name, &sym->declared_at);
12063 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
12064 && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
12065 || sym->attr.allocatable))
12066 gfc_error ("Variable '%s' at %L with coarray component "
12067 "shall be a nonpointer, nonallocatable scalar",
12068 sym->name, &sym->declared_at);
12070 /* F2008, C526. The function-result case was handled above. */
12071 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12072 || sym->attr.codimension)
12073 && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
12074 || sym->ns->proc_name->attr.flavor == FL_MODULE
12075 || sym->ns->proc_name->attr.is_main_program
12076 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12077 gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
12078 "component and is not ALLOCATABLE, SAVE nor a "
12079 "dummy argument", sym->name, &sym->declared_at);
12080 /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
12081 else if (sym->attr.codimension && !sym->attr.allocatable
12082 && sym->as && sym->as->cotype == AS_DEFERRED)
12083 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12084 "deferred shape", sym->name, &sym->declared_at);
12085 else if (sym->attr.codimension && sym->attr.allocatable
12086 && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
12087 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12088 "deferred shape", sym->name, &sym->declared_at);
12092 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12093 || (sym->attr.codimension && sym->attr.allocatable))
12094 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12095 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12096 "allocatable coarray or have coarray components",
12097 sym->name, &sym->declared_at);
12099 if (sym->attr.codimension && sym->attr.dummy
12100 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12101 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12102 "procedure '%s'", sym->name, &sym->declared_at,
12103 sym->ns->proc_name->name);
12105 switch (sym->attr.flavor)
12108 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12113 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12118 if (resolve_fl_namelist (sym) == FAILURE)
12123 if (resolve_fl_parameter (sym) == FAILURE)
12131 /* Resolve array specifier. Check as well some constraints
12132 on COMMON blocks. */
12134 check_constant = sym->attr.in_common && !sym->attr.pointer;
12136 /* Set the formal_arg_flag so that check_conflict will not throw
12137 an error for host associated variables in the specification
12138 expression for an array_valued function. */
12139 if (sym->attr.function && sym->as)
12140 formal_arg_flag = 1;
12142 gfc_resolve_array_spec (sym->as, check_constant);
12144 formal_arg_flag = 0;
12146 /* Resolve formal namespaces. */
12147 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12148 && !sym->attr.contained && !sym->attr.intrinsic)
12149 gfc_resolve (sym->formal_ns);
12151 /* Make sure the formal namespace is present. */
12152 if (sym->formal && !sym->formal_ns)
12154 gfc_formal_arglist *formal = sym->formal;
12155 while (formal && !formal->sym)
12156 formal = formal->next;
12160 sym->formal_ns = formal->sym->ns;
12161 sym->formal_ns->refs++;
12165 /* Check threadprivate restrictions. */
12166 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12167 && (!sym->attr.in_common
12168 && sym->module == NULL
12169 && (sym->ns->proc_name == NULL
12170 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12171 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12173 /* If we have come this far we can apply default-initializers, as
12174 described in 14.7.5, to those variables that have not already
12175 been assigned one. */
12176 if (sym->ts.type == BT_DERIVED
12177 && sym->ns == gfc_current_ns
12179 && !sym->attr.allocatable
12180 && !sym->attr.alloc_comp)
12182 symbol_attribute *a = &sym->attr;
12184 if ((!a->save && !a->dummy && !a->pointer
12185 && !a->in_common && !a->use_assoc
12186 && (a->referenced || a->result)
12187 && !(a->function && sym != sym->result))
12188 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12189 apply_default_init (sym);
12192 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
12193 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
12194 && !CLASS_DATA (sym)->attr.class_pointer
12195 && !CLASS_DATA (sym)->attr.allocatable)
12196 apply_default_init (sym);
12198 /* If this symbol has a type-spec, check it. */
12199 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12200 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12201 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12207 /************* Resolve DATA statements *************/
12211 gfc_data_value *vnode;
12217 /* Advance the values structure to point to the next value in the data list. */
12220 next_data_value (void)
12222 while (mpz_cmp_ui (values.left, 0) == 0)
12225 if (values.vnode->next == NULL)
12228 values.vnode = values.vnode->next;
12229 mpz_set (values.left, values.vnode->repeat);
12237 check_data_variable (gfc_data_variable *var, locus *where)
12243 ar_type mark = AR_UNKNOWN;
12245 mpz_t section_index[GFC_MAX_DIMENSIONS];
12251 if (gfc_resolve_expr (var->expr) == FAILURE)
12255 mpz_init_set_si (offset, 0);
12258 if (e->expr_type != EXPR_VARIABLE)
12259 gfc_internal_error ("check_data_variable(): Bad expression");
12261 sym = e->symtree->n.sym;
12263 if (sym->ns->is_block_data && !sym->attr.in_common)
12265 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12266 sym->name, &sym->declared_at);
12269 if (e->ref == NULL && sym->as)
12271 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12272 " declaration", sym->name, where);
12276 has_pointer = sym->attr.pointer;
12278 for (ref = e->ref; ref; ref = ref->next)
12280 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12283 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
12285 gfc_error ("DATA element '%s' at %L cannot have a coindex",
12291 && ref->type == REF_ARRAY
12292 && ref->u.ar.type != AR_FULL)
12294 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12295 "be a full array", sym->name, where);
12300 if (e->rank == 0 || has_pointer)
12302 mpz_init_set_ui (size, 1);
12309 /* Find the array section reference. */
12310 for (ref = e->ref; ref; ref = ref->next)
12312 if (ref->type != REF_ARRAY)
12314 if (ref->u.ar.type == AR_ELEMENT)
12320 /* Set marks according to the reference pattern. */
12321 switch (ref->u.ar.type)
12329 /* Get the start position of array section. */
12330 gfc_get_section_index (ar, section_index, &offset);
12335 gcc_unreachable ();
12338 if (gfc_array_size (e, &size) == FAILURE)
12340 gfc_error ("Nonconstant array section at %L in DATA statement",
12342 mpz_clear (offset);
12349 while (mpz_cmp_ui (size, 0) > 0)
12351 if (next_data_value () == FAILURE)
12353 gfc_error ("DATA statement at %L has more variables than values",
12359 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12363 /* If we have more than one element left in the repeat count,
12364 and we have more than one element left in the target variable,
12365 then create a range assignment. */
12366 /* FIXME: Only done for full arrays for now, since array sections
12368 if (mark == AR_FULL && ref && ref->next == NULL
12369 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12373 if (mpz_cmp (size, values.left) >= 0)
12375 mpz_init_set (range, values.left);
12376 mpz_sub (size, size, values.left);
12377 mpz_set_ui (values.left, 0);
12381 mpz_init_set (range, size);
12382 mpz_sub (values.left, values.left, size);
12383 mpz_set_ui (size, 0);
12386 t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
12389 mpz_add (offset, offset, range);
12396 /* Assign initial value to symbol. */
12399 mpz_sub_ui (values.left, values.left, 1);
12400 mpz_sub_ui (size, size, 1);
12402 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
12406 if (mark == AR_FULL)
12407 mpz_add_ui (offset, offset, 1);
12409 /* Modify the array section indexes and recalculate the offset
12410 for next element. */
12411 else if (mark == AR_SECTION)
12412 gfc_advance_section (section_index, ar, &offset);
12416 if (mark == AR_SECTION)
12418 for (i = 0; i < ar->dimen; i++)
12419 mpz_clear (section_index[i]);
12423 mpz_clear (offset);
12429 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
12431 /* Iterate over a list of elements in a DATA statement. */
12434 traverse_data_list (gfc_data_variable *var, locus *where)
12437 iterator_stack frame;
12438 gfc_expr *e, *start, *end, *step;
12439 gfc_try retval = SUCCESS;
12441 mpz_init (frame.value);
12444 start = gfc_copy_expr (var->iter.start);
12445 end = gfc_copy_expr (var->iter.end);
12446 step = gfc_copy_expr (var->iter.step);
12448 if (gfc_simplify_expr (start, 1) == FAILURE
12449 || start->expr_type != EXPR_CONSTANT)
12451 gfc_error ("start of implied-do loop at %L could not be "
12452 "simplified to a constant value", &start->where);
12456 if (gfc_simplify_expr (end, 1) == FAILURE
12457 || end->expr_type != EXPR_CONSTANT)
12459 gfc_error ("end of implied-do loop at %L could not be "
12460 "simplified to a constant value", &start->where);
12464 if (gfc_simplify_expr (step, 1) == FAILURE
12465 || step->expr_type != EXPR_CONSTANT)
12467 gfc_error ("step of implied-do loop at %L could not be "
12468 "simplified to a constant value", &start->where);
12473 mpz_set (trip, end->value.integer);
12474 mpz_sub (trip, trip, start->value.integer);
12475 mpz_add (trip, trip, step->value.integer);
12477 mpz_div (trip, trip, step->value.integer);
12479 mpz_set (frame.value, start->value.integer);
12481 frame.prev = iter_stack;
12482 frame.variable = var->iter.var->symtree;
12483 iter_stack = &frame;
12485 while (mpz_cmp_ui (trip, 0) > 0)
12487 if (traverse_data_var (var->list, where) == FAILURE)
12493 e = gfc_copy_expr (var->expr);
12494 if (gfc_simplify_expr (e, 1) == FAILURE)
12501 mpz_add (frame.value, frame.value, step->value.integer);
12503 mpz_sub_ui (trip, trip, 1);
12507 mpz_clear (frame.value);
12510 gfc_free_expr (start);
12511 gfc_free_expr (end);
12512 gfc_free_expr (step);
12514 iter_stack = frame.prev;
12519 /* Type resolve variables in the variable list of a DATA statement. */
12522 traverse_data_var (gfc_data_variable *var, locus *where)
12526 for (; var; var = var->next)
12528 if (var->expr == NULL)
12529 t = traverse_data_list (var, where);
12531 t = check_data_variable (var, where);
12541 /* Resolve the expressions and iterators associated with a data statement.
12542 This is separate from the assignment checking because data lists should
12543 only be resolved once. */
12546 resolve_data_variables (gfc_data_variable *d)
12548 for (; d; d = d->next)
12550 if (d->list == NULL)
12552 if (gfc_resolve_expr (d->expr) == FAILURE)
12557 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
12560 if (resolve_data_variables (d->list) == FAILURE)
12569 /* Resolve a single DATA statement. We implement this by storing a pointer to
12570 the value list into static variables, and then recursively traversing the
12571 variables list, expanding iterators and such. */
12574 resolve_data (gfc_data *d)
12577 if (resolve_data_variables (d->var) == FAILURE)
12580 values.vnode = d->value;
12581 if (d->value == NULL)
12582 mpz_set_ui (values.left, 0);
12584 mpz_set (values.left, d->value->repeat);
12586 if (traverse_data_var (d->var, &d->where) == FAILURE)
12589 /* At this point, we better not have any values left. */
12591 if (next_data_value () == SUCCESS)
12592 gfc_error ("DATA statement at %L has more values than variables",
12597 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
12598 accessed by host or use association, is a dummy argument to a pure function,
12599 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
12600 is storage associated with any such variable, shall not be used in the
12601 following contexts: (clients of this function). */
12603 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
12604 procedure. Returns zero if assignment is OK, nonzero if there is a
12607 gfc_impure_variable (gfc_symbol *sym)
12612 if (sym->attr.use_assoc || sym->attr.in_common)
12615 /* Check if the symbol's ns is inside the pure procedure. */
12616 for (ns = gfc_current_ns; ns; ns = ns->parent)
12620 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
12624 proc = sym->ns->proc_name;
12625 if (sym->attr.dummy && gfc_pure (proc)
12626 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
12628 proc->attr.function))
12631 /* TODO: Sort out what can be storage associated, if anything, and include
12632 it here. In principle equivalences should be scanned but it does not
12633 seem to be possible to storage associate an impure variable this way. */
12638 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
12639 current namespace is inside a pure procedure. */
12642 gfc_pure (gfc_symbol *sym)
12644 symbol_attribute attr;
12649 /* Check if the current namespace or one of its parents
12650 belongs to a pure procedure. */
12651 for (ns = gfc_current_ns; ns; ns = ns->parent)
12653 sym = ns->proc_name;
12657 if (attr.flavor == FL_PROCEDURE && attr.pure)
12665 return attr.flavor == FL_PROCEDURE && attr.pure;
12669 /* Test whether the current procedure is elemental or not. */
12672 gfc_elemental (gfc_symbol *sym)
12674 symbol_attribute attr;
12677 sym = gfc_current_ns->proc_name;
12682 return attr.flavor == FL_PROCEDURE && attr.elemental;
12686 /* Warn about unused labels. */
12689 warn_unused_fortran_label (gfc_st_label *label)
12694 warn_unused_fortran_label (label->left);
12696 if (label->defined == ST_LABEL_UNKNOWN)
12699 switch (label->referenced)
12701 case ST_LABEL_UNKNOWN:
12702 gfc_warning ("Label %d at %L defined but not used", label->value,
12706 case ST_LABEL_BAD_TARGET:
12707 gfc_warning ("Label %d at %L defined but cannot be used",
12708 label->value, &label->where);
12715 warn_unused_fortran_label (label->right);
12719 /* Returns the sequence type of a symbol or sequence. */
12722 sequence_type (gfc_typespec ts)
12731 if (ts.u.derived->components == NULL)
12732 return SEQ_NONDEFAULT;
12734 result = sequence_type (ts.u.derived->components->ts);
12735 for (c = ts.u.derived->components->next; c; c = c->next)
12736 if (sequence_type (c->ts) != result)
12742 if (ts.kind != gfc_default_character_kind)
12743 return SEQ_NONDEFAULT;
12745 return SEQ_CHARACTER;
12748 if (ts.kind != gfc_default_integer_kind)
12749 return SEQ_NONDEFAULT;
12751 return SEQ_NUMERIC;
12754 if (!(ts.kind == gfc_default_real_kind
12755 || ts.kind == gfc_default_double_kind))
12756 return SEQ_NONDEFAULT;
12758 return SEQ_NUMERIC;
12761 if (ts.kind != gfc_default_complex_kind)
12762 return SEQ_NONDEFAULT;
12764 return SEQ_NUMERIC;
12767 if (ts.kind != gfc_default_logical_kind)
12768 return SEQ_NONDEFAULT;
12770 return SEQ_NUMERIC;
12773 return SEQ_NONDEFAULT;
12778 /* Resolve derived type EQUIVALENCE object. */
12781 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
12783 gfc_component *c = derived->components;
12788 /* Shall not be an object of nonsequence derived type. */
12789 if (!derived->attr.sequence)
12791 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
12792 "attribute to be an EQUIVALENCE object", sym->name,
12797 /* Shall not have allocatable components. */
12798 if (derived->attr.alloc_comp)
12800 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
12801 "components to be an EQUIVALENCE object",sym->name,
12806 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
12808 gfc_error ("Derived type variable '%s' at %L with default "
12809 "initialization cannot be in EQUIVALENCE with a variable "
12810 "in COMMON", sym->name, &e->where);
12814 for (; c ; c = c->next)
12816 if (c->ts.type == BT_DERIVED
12817 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
12820 /* Shall not be an object of sequence derived type containing a pointer
12821 in the structure. */
12822 if (c->attr.pointer)
12824 gfc_error ("Derived type variable '%s' at %L with pointer "
12825 "component(s) cannot be an EQUIVALENCE object",
12826 sym->name, &e->where);
12834 /* Resolve equivalence object.
12835 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
12836 an allocatable array, an object of nonsequence derived type, an object of
12837 sequence derived type containing a pointer at any level of component
12838 selection, an automatic object, a function name, an entry name, a result
12839 name, a named constant, a structure component, or a subobject of any of
12840 the preceding objects. A substring shall not have length zero. A
12841 derived type shall not have components with default initialization nor
12842 shall two objects of an equivalence group be initialized.
12843 Either all or none of the objects shall have an protected attribute.
12844 The simple constraints are done in symbol.c(check_conflict) and the rest
12845 are implemented here. */
12848 resolve_equivalence (gfc_equiv *eq)
12851 gfc_symbol *first_sym;
12854 locus *last_where = NULL;
12855 seq_type eq_type, last_eq_type;
12856 gfc_typespec *last_ts;
12857 int object, cnt_protected;
12860 last_ts = &eq->expr->symtree->n.sym->ts;
12862 first_sym = eq->expr->symtree->n.sym;
12866 for (object = 1; eq; eq = eq->eq, object++)
12870 e->ts = e->symtree->n.sym->ts;
12871 /* match_varspec might not know yet if it is seeing
12872 array reference or substring reference, as it doesn't
12874 if (e->ref && e->ref->type == REF_ARRAY)
12876 gfc_ref *ref = e->ref;
12877 sym = e->symtree->n.sym;
12879 if (sym->attr.dimension)
12881 ref->u.ar.as = sym->as;
12885 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
12886 if (e->ts.type == BT_CHARACTER
12888 && ref->type == REF_ARRAY
12889 && ref->u.ar.dimen == 1
12890 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
12891 && ref->u.ar.stride[0] == NULL)
12893 gfc_expr *start = ref->u.ar.start[0];
12894 gfc_expr *end = ref->u.ar.end[0];
12897 /* Optimize away the (:) reference. */
12898 if (start == NULL && end == NULL)
12901 e->ref = ref->next;
12903 e->ref->next = ref->next;
12908 ref->type = REF_SUBSTRING;
12910 start = gfc_get_int_expr (gfc_default_integer_kind,
12912 ref->u.ss.start = start;
12913 if (end == NULL && e->ts.u.cl)
12914 end = gfc_copy_expr (e->ts.u.cl->length);
12915 ref->u.ss.end = end;
12916 ref->u.ss.length = e->ts.u.cl;
12923 /* Any further ref is an error. */
12926 gcc_assert (ref->type == REF_ARRAY);
12927 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
12933 if (gfc_resolve_expr (e) == FAILURE)
12936 sym = e->symtree->n.sym;
12938 if (sym->attr.is_protected)
12940 if (cnt_protected > 0 && cnt_protected != object)
12942 gfc_error ("Either all or none of the objects in the "
12943 "EQUIVALENCE set at %L shall have the "
12944 "PROTECTED attribute",
12949 /* Shall not equivalence common block variables in a PURE procedure. */
12950 if (sym->ns->proc_name
12951 && sym->ns->proc_name->attr.pure
12952 && sym->attr.in_common)
12954 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
12955 "object in the pure procedure '%s'",
12956 sym->name, &e->where, sym->ns->proc_name->name);
12960 /* Shall not be a named constant. */
12961 if (e->expr_type == EXPR_CONSTANT)
12963 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
12964 "object", sym->name, &e->where);
12968 if (e->ts.type == BT_DERIVED
12969 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
12972 /* Check that the types correspond correctly:
12974 A numeric sequence structure may be equivalenced to another sequence
12975 structure, an object of default integer type, default real type, double
12976 precision real type, default logical type such that components of the
12977 structure ultimately only become associated to objects of the same
12978 kind. A character sequence structure may be equivalenced to an object
12979 of default character kind or another character sequence structure.
12980 Other objects may be equivalenced only to objects of the same type and
12981 kind parameters. */
12983 /* Identical types are unconditionally OK. */
12984 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
12985 goto identical_types;
12987 last_eq_type = sequence_type (*last_ts);
12988 eq_type = sequence_type (sym->ts);
12990 /* Since the pair of objects is not of the same type, mixed or
12991 non-default sequences can be rejected. */
12993 msg = "Sequence %s with mixed components in EQUIVALENCE "
12994 "statement at %L with different type objects";
12996 && last_eq_type == SEQ_MIXED
12997 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
12999 || (eq_type == SEQ_MIXED
13000 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13001 &e->where) == FAILURE))
13004 msg = "Non-default type object or sequence %s in EQUIVALENCE "
13005 "statement at %L with objects of different type";
13007 && last_eq_type == SEQ_NONDEFAULT
13008 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
13009 last_where) == FAILURE)
13010 || (eq_type == SEQ_NONDEFAULT
13011 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13012 &e->where) == FAILURE))
13015 msg ="Non-CHARACTER object '%s' in default CHARACTER "
13016 "EQUIVALENCE statement at %L";
13017 if (last_eq_type == SEQ_CHARACTER
13018 && eq_type != SEQ_CHARACTER
13019 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13020 &e->where) == FAILURE)
13023 msg ="Non-NUMERIC object '%s' in default NUMERIC "
13024 "EQUIVALENCE statement at %L";
13025 if (last_eq_type == SEQ_NUMERIC
13026 && eq_type != SEQ_NUMERIC
13027 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13028 &e->where) == FAILURE)
13033 last_where = &e->where;
13038 /* Shall not be an automatic array. */
13039 if (e->ref->type == REF_ARRAY
13040 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
13042 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13043 "an EQUIVALENCE object", sym->name, &e->where);
13050 /* Shall not be a structure component. */
13051 if (r->type == REF_COMPONENT)
13053 gfc_error ("Structure component '%s' at %L cannot be an "
13054 "EQUIVALENCE object",
13055 r->u.c.component->name, &e->where);
13059 /* A substring shall not have length zero. */
13060 if (r->type == REF_SUBSTRING)
13062 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13064 gfc_error ("Substring at %L has length zero",
13065 &r->u.ss.start->where);
13075 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13078 resolve_fntype (gfc_namespace *ns)
13080 gfc_entry_list *el;
13083 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13086 /* If there are any entries, ns->proc_name is the entry master
13087 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13089 sym = ns->entries->sym;
13091 sym = ns->proc_name;
13092 if (sym->result == sym
13093 && sym->ts.type == BT_UNKNOWN
13094 && gfc_set_default_type (sym, 0, NULL) == FAILURE
13095 && !sym->attr.untyped)
13097 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13098 sym->name, &sym->declared_at);
13099 sym->attr.untyped = 1;
13102 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13103 && !sym->attr.contained
13104 && !gfc_check_access (sym->ts.u.derived->attr.access,
13105 sym->ts.u.derived->ns->default_access)
13106 && gfc_check_access (sym->attr.access, sym->ns->default_access))
13108 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13109 "%L of PRIVATE type '%s'", sym->name,
13110 &sym->declared_at, sym->ts.u.derived->name);
13114 for (el = ns->entries->next; el; el = el->next)
13116 if (el->sym->result == el->sym
13117 && el->sym->ts.type == BT_UNKNOWN
13118 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13119 && !el->sym->attr.untyped)
13121 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13122 el->sym->name, &el->sym->declared_at);
13123 el->sym->attr.untyped = 1;
13129 /* 12.3.2.1.1 Defined operators. */
13132 check_uop_procedure (gfc_symbol *sym, locus where)
13134 gfc_formal_arglist *formal;
13136 if (!sym->attr.function)
13138 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13139 sym->name, &where);
13143 if (sym->ts.type == BT_CHARACTER
13144 && !(sym->ts.u.cl && sym->ts.u.cl->length)
13145 && !(sym->result && sym->result->ts.u.cl
13146 && sym->result->ts.u.cl->length))
13148 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13149 "character length", sym->name, &where);
13153 formal = sym->formal;
13154 if (!formal || !formal->sym)
13156 gfc_error ("User operator procedure '%s' at %L must have at least "
13157 "one argument", sym->name, &where);
13161 if (formal->sym->attr.intent != INTENT_IN)
13163 gfc_error ("First argument of operator interface at %L must be "
13164 "INTENT(IN)", &where);
13168 if (formal->sym->attr.optional)
13170 gfc_error ("First argument of operator interface at %L cannot be "
13171 "optional", &where);
13175 formal = formal->next;
13176 if (!formal || !formal->sym)
13179 if (formal->sym->attr.intent != INTENT_IN)
13181 gfc_error ("Second argument of operator interface at %L must be "
13182 "INTENT(IN)", &where);
13186 if (formal->sym->attr.optional)
13188 gfc_error ("Second argument of operator interface at %L cannot be "
13189 "optional", &where);
13195 gfc_error ("Operator interface at %L must have, at most, two "
13196 "arguments", &where);
13204 gfc_resolve_uops (gfc_symtree *symtree)
13206 gfc_interface *itr;
13208 if (symtree == NULL)
13211 gfc_resolve_uops (symtree->left);
13212 gfc_resolve_uops (symtree->right);
13214 for (itr = symtree->n.uop->op; itr; itr = itr->next)
13215 check_uop_procedure (itr->sym, itr->sym->declared_at);
13219 /* Examine all of the expressions associated with a program unit,
13220 assign types to all intermediate expressions, make sure that all
13221 assignments are to compatible types and figure out which names
13222 refer to which functions or subroutines. It doesn't check code
13223 block, which is handled by resolve_code. */
13226 resolve_types (gfc_namespace *ns)
13232 gfc_namespace* old_ns = gfc_current_ns;
13234 /* Check that all IMPLICIT types are ok. */
13235 if (!ns->seen_implicit_none)
13238 for (letter = 0; letter != GFC_LETTERS; ++letter)
13239 if (ns->set_flag[letter]
13240 && resolve_typespec_used (&ns->default_type[letter],
13241 &ns->implicit_loc[letter],
13246 gfc_current_ns = ns;
13248 resolve_entries (ns);
13250 resolve_common_vars (ns->blank_common.head, false);
13251 resolve_common_blocks (ns->common_root);
13253 resolve_contained_functions (ns);
13255 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13257 for (cl = ns->cl_list; cl; cl = cl->next)
13258 resolve_charlen (cl);
13260 gfc_traverse_ns (ns, resolve_symbol);
13262 resolve_fntype (ns);
13264 for (n = ns->contained; n; n = n->sibling)
13266 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13267 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13268 "also be PURE", n->proc_name->name,
13269 &n->proc_name->declared_at);
13275 gfc_check_interfaces (ns);
13277 gfc_traverse_ns (ns, resolve_values);
13283 for (d = ns->data; d; d = d->next)
13287 gfc_traverse_ns (ns, gfc_formalize_init_value);
13289 gfc_traverse_ns (ns, gfc_verify_binding_labels);
13291 if (ns->common_root != NULL)
13292 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13294 for (eq = ns->equiv; eq; eq = eq->next)
13295 resolve_equivalence (eq);
13297 /* Warn about unused labels. */
13298 if (warn_unused_label)
13299 warn_unused_fortran_label (ns->st_labels);
13301 gfc_resolve_uops (ns->uop_root);
13303 gfc_current_ns = old_ns;
13307 /* Call resolve_code recursively. */
13310 resolve_codes (gfc_namespace *ns)
13313 bitmap_obstack old_obstack;
13315 for (n = ns->contained; n; n = n->sibling)
13318 gfc_current_ns = ns;
13320 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13321 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13324 /* Set to an out of range value. */
13325 current_entry_id = -1;
13327 old_obstack = labels_obstack;
13328 bitmap_obstack_initialize (&labels_obstack);
13330 resolve_code (ns->code, ns);
13332 bitmap_obstack_release (&labels_obstack);
13333 labels_obstack = old_obstack;
13337 /* This function is called after a complete program unit has been compiled.
13338 Its purpose is to examine all of the expressions associated with a program
13339 unit, assign types to all intermediate expressions, make sure that all
13340 assignments are to compatible types and figure out which names refer to
13341 which functions or subroutines. */
13344 gfc_resolve (gfc_namespace *ns)
13346 gfc_namespace *old_ns;
13347 code_stack *old_cs_base;
13353 old_ns = gfc_current_ns;
13354 old_cs_base = cs_base;
13356 resolve_types (ns);
13357 resolve_codes (ns);
13359 gfc_current_ns = old_ns;
13360 cs_base = old_cs_base;
13363 gfc_run_passes (ns);