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)
302 if (!sym->attr.function || sym->result == sym)
303 gfc_set_default_type (sym, 1, sym->ns);
306 gfc_resolve_array_spec (sym->as, 0);
308 /* We can't tell if an array with dimension (:) is assumed or deferred
309 shape until we know if it has the pointer or allocatable attributes.
311 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
312 && !(sym->attr.pointer || sym->attr.allocatable))
314 sym->as->type = AS_ASSUMED_SHAPE;
315 for (i = 0; i < sym->as->rank; i++)
316 sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
320 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
321 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
322 || sym->attr.optional)
324 proc->attr.always_explicit = 1;
326 proc->result->attr.always_explicit = 1;
329 /* If the flavor is unknown at this point, it has to be a variable.
330 A procedure specification would have already set the type. */
332 if (sym->attr.flavor == FL_UNKNOWN)
333 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
335 if (gfc_pure (proc) && !sym->attr.pointer
336 && sym->attr.flavor != FL_PROCEDURE)
338 if (proc->attr.function && sym->attr.intent != INTENT_IN)
339 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
340 "INTENT(IN)", sym->name, proc->name,
343 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
344 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
345 "have its INTENT specified", sym->name, proc->name,
349 if (gfc_elemental (proc))
352 if (sym->attr.codimension)
354 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
355 "procedure", sym->name, &sym->declared_at);
361 gfc_error ("Argument '%s' of elemental procedure at %L must "
362 "be scalar", sym->name, &sym->declared_at);
366 if (sym->attr.allocatable)
368 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
369 "have the ALLOCATABLE attribute", sym->name,
374 if (sym->attr.pointer)
376 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
377 "have the POINTER attribute", sym->name,
382 if (sym->attr.flavor == FL_PROCEDURE)
384 gfc_error ("Dummy procedure '%s' not allowed in elemental "
385 "procedure '%s' at %L", sym->name, proc->name,
390 if (sym->attr.intent == INTENT_UNKNOWN)
392 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
393 "have its INTENT specified", sym->name, proc->name,
399 /* Each dummy shall be specified to be scalar. */
400 if (proc->attr.proc == PROC_ST_FUNCTION)
404 gfc_error ("Argument '%s' of statement function at %L must "
405 "be scalar", sym->name, &sym->declared_at);
409 if (sym->ts.type == BT_CHARACTER)
411 gfc_charlen *cl = sym->ts.u.cl;
412 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
414 gfc_error ("Character-valued argument '%s' of statement "
415 "function at %L must have constant length",
416 sym->name, &sym->declared_at);
426 /* Work function called when searching for symbols that have argument lists
427 associated with them. */
430 find_arglists (gfc_symbol *sym)
432 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
435 resolve_formal_arglist (sym);
439 /* Given a namespace, resolve all formal argument lists within the namespace.
443 resolve_formal_arglists (gfc_namespace *ns)
448 gfc_traverse_ns (ns, find_arglists);
453 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
457 /* If this namespace is not a function or an entry master function,
459 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
460 || sym->attr.entry_master)
463 /* Try to find out of what the return type is. */
464 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
466 t = gfc_set_default_type (sym->result, 0, ns);
468 if (t == FAILURE && !sym->result->attr.untyped)
470 if (sym->result == sym)
471 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
472 sym->name, &sym->declared_at);
473 else if (!sym->result->attr.proc_pointer)
474 gfc_error ("Result '%s' of contained function '%s' at %L has "
475 "no IMPLICIT type", sym->result->name, sym->name,
476 &sym->result->declared_at);
477 sym->result->attr.untyped = 1;
481 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
482 type, lists the only ways a character length value of * can be used:
483 dummy arguments of procedures, named constants, and function results
484 in external functions. Internal function results and results of module
485 procedures are not on this list, ergo, not permitted. */
487 if (sym->result->ts.type == BT_CHARACTER)
489 gfc_charlen *cl = sym->result->ts.u.cl;
490 if (!cl || !cl->length)
492 /* See if this is a module-procedure and adapt error message
495 gcc_assert (ns->parent && ns->parent->proc_name);
496 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
498 gfc_error ("Character-valued %s '%s' at %L must not be"
500 module_proc ? _("module procedure")
501 : _("internal function"),
502 sym->name, &sym->declared_at);
508 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
509 introduce duplicates. */
512 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
514 gfc_formal_arglist *f, *new_arglist;
517 for (; new_args != NULL; new_args = new_args->next)
519 new_sym = new_args->sym;
520 /* See if this arg is already in the formal argument list. */
521 for (f = proc->formal; f; f = f->next)
523 if (new_sym == f->sym)
530 /* Add a new argument. Argument order is not important. */
531 new_arglist = gfc_get_formal_arglist ();
532 new_arglist->sym = new_sym;
533 new_arglist->next = proc->formal;
534 proc->formal = new_arglist;
539 /* Flag the arguments that are not present in all entries. */
542 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
544 gfc_formal_arglist *f, *head;
547 for (f = proc->formal; f; f = f->next)
552 for (new_args = head; new_args; new_args = new_args->next)
554 if (new_args->sym == f->sym)
561 f->sym->attr.not_always_present = 1;
566 /* Resolve alternate entry points. If a symbol has multiple entry points we
567 create a new master symbol for the main routine, and turn the existing
568 symbol into an entry point. */
571 resolve_entries (gfc_namespace *ns)
573 gfc_namespace *old_ns;
577 char name[GFC_MAX_SYMBOL_LEN + 1];
578 static int master_count = 0;
580 if (ns->proc_name == NULL)
583 /* No need to do anything if this procedure doesn't have alternate entry
588 /* We may already have resolved alternate entry points. */
589 if (ns->proc_name->attr.entry_master)
592 /* If this isn't a procedure something has gone horribly wrong. */
593 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
595 /* Remember the current namespace. */
596 old_ns = gfc_current_ns;
600 /* Add the main entry point to the list of entry points. */
601 el = gfc_get_entry_list ();
602 el->sym = ns->proc_name;
604 el->next = ns->entries;
606 ns->proc_name->attr.entry = 1;
608 /* If it is a module function, it needs to be in the right namespace
609 so that gfc_get_fake_result_decl can gather up the results. The
610 need for this arose in get_proc_name, where these beasts were
611 left in their own namespace, to keep prior references linked to
612 the entry declaration.*/
613 if (ns->proc_name->attr.function
614 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
617 /* Do the same for entries where the master is not a module
618 procedure. These are retained in the module namespace because
619 of the module procedure declaration. */
620 for (el = el->next; el; el = el->next)
621 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
622 && el->sym->attr.mod_proc)
626 /* Add an entry statement for it. */
633 /* Create a new symbol for the master function. */
634 /* Give the internal function a unique name (within this file).
635 Also include the function name so the user has some hope of figuring
636 out what is going on. */
637 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
638 master_count++, ns->proc_name->name);
639 gfc_get_ha_symbol (name, &proc);
640 gcc_assert (proc != NULL);
642 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
643 if (ns->proc_name->attr.subroutine)
644 gfc_add_subroutine (&proc->attr, proc->name, NULL);
648 gfc_typespec *ts, *fts;
649 gfc_array_spec *as, *fas;
650 gfc_add_function (&proc->attr, proc->name, NULL);
652 fas = ns->entries->sym->as;
653 fas = fas ? fas : ns->entries->sym->result->as;
654 fts = &ns->entries->sym->result->ts;
655 if (fts->type == BT_UNKNOWN)
656 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
657 for (el = ns->entries->next; el; el = el->next)
659 ts = &el->sym->result->ts;
661 as = as ? as : el->sym->result->as;
662 if (ts->type == BT_UNKNOWN)
663 ts = gfc_get_default_type (el->sym->result->name, NULL);
665 if (! gfc_compare_types (ts, fts)
666 || (el->sym->result->attr.dimension
667 != ns->entries->sym->result->attr.dimension)
668 || (el->sym->result->attr.pointer
669 != ns->entries->sym->result->attr.pointer))
671 else if (as && fas && ns->entries->sym->result != el->sym->result
672 && gfc_compare_array_spec (as, fas) == 0)
673 gfc_error ("Function %s at %L has entries with mismatched "
674 "array specifications", ns->entries->sym->name,
675 &ns->entries->sym->declared_at);
676 /* The characteristics need to match and thus both need to have
677 the same string length, i.e. both len=*, or both len=4.
678 Having both len=<variable> is also possible, but difficult to
679 check at compile time. */
680 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
681 && (((ts->u.cl->length && !fts->u.cl->length)
682 ||(!ts->u.cl->length && fts->u.cl->length))
684 && ts->u.cl->length->expr_type
685 != fts->u.cl->length->expr_type)
687 && ts->u.cl->length->expr_type == EXPR_CONSTANT
688 && mpz_cmp (ts->u.cl->length->value.integer,
689 fts->u.cl->length->value.integer) != 0)))
690 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
691 "entries returning variables of different "
692 "string lengths", ns->entries->sym->name,
693 &ns->entries->sym->declared_at);
698 sym = ns->entries->sym->result;
699 /* All result types the same. */
701 if (sym->attr.dimension)
702 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
703 if (sym->attr.pointer)
704 gfc_add_pointer (&proc->attr, NULL);
708 /* Otherwise the result will be passed through a union by
710 proc->attr.mixed_entry_master = 1;
711 for (el = ns->entries; el; el = el->next)
713 sym = el->sym->result;
714 if (sym->attr.dimension)
716 if (el == ns->entries)
717 gfc_error ("FUNCTION result %s can't be an array in "
718 "FUNCTION %s at %L", sym->name,
719 ns->entries->sym->name, &sym->declared_at);
721 gfc_error ("ENTRY result %s can't be an array in "
722 "FUNCTION %s at %L", sym->name,
723 ns->entries->sym->name, &sym->declared_at);
725 else if (sym->attr.pointer)
727 if (el == ns->entries)
728 gfc_error ("FUNCTION result %s can't be a POINTER in "
729 "FUNCTION %s at %L", sym->name,
730 ns->entries->sym->name, &sym->declared_at);
732 gfc_error ("ENTRY result %s can't be a POINTER in "
733 "FUNCTION %s at %L", sym->name,
734 ns->entries->sym->name, &sym->declared_at);
739 if (ts->type == BT_UNKNOWN)
740 ts = gfc_get_default_type (sym->name, NULL);
744 if (ts->kind == gfc_default_integer_kind)
748 if (ts->kind == gfc_default_real_kind
749 || ts->kind == gfc_default_double_kind)
753 if (ts->kind == gfc_default_complex_kind)
757 if (ts->kind == gfc_default_logical_kind)
761 /* We will issue error elsewhere. */
769 if (el == ns->entries)
770 gfc_error ("FUNCTION result %s can't be of type %s "
771 "in FUNCTION %s at %L", sym->name,
772 gfc_typename (ts), ns->entries->sym->name,
775 gfc_error ("ENTRY result %s can't be of type %s "
776 "in FUNCTION %s at %L", sym->name,
777 gfc_typename (ts), ns->entries->sym->name,
784 proc->attr.access = ACCESS_PRIVATE;
785 proc->attr.entry_master = 1;
787 /* Merge all the entry point arguments. */
788 for (el = ns->entries; el; el = el->next)
789 merge_argument_lists (proc, el->sym->formal);
791 /* Check the master formal arguments for any that are not
792 present in all entry points. */
793 for (el = ns->entries; el; el = el->next)
794 check_argument_lists (proc, el->sym->formal);
796 /* Use the master function for the function body. */
797 ns->proc_name = proc;
799 /* Finalize the new symbols. */
800 gfc_commit_symbols ();
802 /* Restore the original namespace. */
803 gfc_current_ns = old_ns;
807 /* Resolve common variables. */
809 resolve_common_vars (gfc_symbol *sym, bool named_common)
811 gfc_symbol *csym = sym;
813 for (; csym; csym = csym->common_next)
815 if (csym->value || csym->attr.data)
817 if (!csym->ns->is_block_data)
818 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
819 "but only in BLOCK DATA initialization is "
820 "allowed", csym->name, &csym->declared_at);
821 else if (!named_common)
822 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
823 "in a blank COMMON but initialization is only "
824 "allowed in named common blocks", csym->name,
828 if (csym->ts.type != BT_DERIVED)
831 if (!(csym->ts.u.derived->attr.sequence
832 || csym->ts.u.derived->attr.is_bind_c))
833 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
834 "has neither the SEQUENCE nor the BIND(C) "
835 "attribute", csym->name, &csym->declared_at);
836 if (csym->ts.u.derived->attr.alloc_comp)
837 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
838 "has an ultimate component that is "
839 "allocatable", csym->name, &csym->declared_at);
840 if (gfc_has_default_initializer (csym->ts.u.derived))
841 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
842 "may not have default initializer", csym->name,
845 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
846 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
850 /* Resolve common blocks. */
852 resolve_common_blocks (gfc_symtree *common_root)
856 if (common_root == NULL)
859 if (common_root->left)
860 resolve_common_blocks (common_root->left);
861 if (common_root->right)
862 resolve_common_blocks (common_root->right);
864 resolve_common_vars (common_root->n.common->head, true);
866 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
870 if (sym->attr.flavor == FL_PARAMETER)
871 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
872 sym->name, &common_root->n.common->where, &sym->declared_at);
874 if (sym->attr.intrinsic)
875 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
876 sym->name, &common_root->n.common->where);
877 else if (sym->attr.result
878 || gfc_is_function_return_value (sym, gfc_current_ns))
879 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
880 "that is also a function result", sym->name,
881 &common_root->n.common->where);
882 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
883 && sym->attr.proc != PROC_ST_FUNCTION)
884 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
885 "that is also a global procedure", sym->name,
886 &common_root->n.common->where);
890 /* Resolve contained function types. Because contained functions can call one
891 another, they have to be worked out before any of the contained procedures
894 The good news is that if a function doesn't already have a type, the only
895 way it can get one is through an IMPLICIT type or a RESULT variable, because
896 by definition contained functions are contained namespace they're contained
897 in, not in a sibling or parent namespace. */
900 resolve_contained_functions (gfc_namespace *ns)
902 gfc_namespace *child;
905 resolve_formal_arglists (ns);
907 for (child = ns->contained; child; child = child->sibling)
909 /* Resolve alternate entry points first. */
910 resolve_entries (child);
912 /* Then check function return types. */
913 resolve_contained_fntype (child->proc_name, child);
914 for (el = child->entries; el; el = el->next)
915 resolve_contained_fntype (el->sym, child);
920 /* Resolve all of the elements of a structure constructor and make sure that
921 the types are correct. The 'init' flag indicates that the given
922 constructor is an initializer. */
925 resolve_structure_cons (gfc_expr *expr, int init)
927 gfc_constructor *cons;
934 if (expr->ts.type == BT_DERIVED)
935 resolve_symbol (expr->ts.u.derived);
937 cons = gfc_constructor_first (expr->value.constructor);
938 /* A constructor may have references if it is the result of substituting a
939 parameter variable. In this case we just pull out the component we
942 comp = expr->ref->u.c.sym->components;
944 comp = expr->ts.u.derived->components;
946 /* See if the user is trying to invoke a structure constructor for one of
947 the iso_c_binding derived types. */
948 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
949 && expr->ts.u.derived->ts.is_iso_c && cons
950 && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
952 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
953 expr->ts.u.derived->name, &(expr->where));
957 /* Return if structure constructor is c_null_(fun)prt. */
958 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
959 && expr->ts.u.derived->ts.is_iso_c && cons
960 && cons->expr && cons->expr->expr_type == EXPR_NULL)
963 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
970 if (gfc_resolve_expr (cons->expr) == FAILURE)
976 rank = comp->as ? comp->as->rank : 0;
977 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
978 && (comp->attr.allocatable || cons->expr->rank))
980 gfc_error ("The rank of the element in the derived type "
981 "constructor at %L does not match that of the "
982 "component (%d/%d)", &cons->expr->where,
983 cons->expr->rank, rank);
987 /* If we don't have the right type, try to convert it. */
989 if (!comp->attr.proc_pointer &&
990 !gfc_compare_types (&cons->expr->ts, &comp->ts))
993 if (strcmp (comp->name, "$extends") == 0)
995 /* Can afford to be brutal with the $extends initializer.
996 The derived type can get lost because it is PRIVATE
997 but it is not usage constrained by the standard. */
998 cons->expr->ts = comp->ts;
1001 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1002 gfc_error ("The element in the derived type constructor at %L, "
1003 "for pointer component '%s', is %s but should be %s",
1004 &cons->expr->where, comp->name,
1005 gfc_basic_typename (cons->expr->ts.type),
1006 gfc_basic_typename (comp->ts.type));
1008 t = gfc_convert_type (cons->expr, &comp->ts, 1);
1011 /* For strings, the length of the constructor should be the same as
1012 the one of the structure, ensure this if the lengths are known at
1013 compile time and when we are dealing with PARAMETER or structure
1015 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1016 && comp->ts.u.cl->length
1017 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1018 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1019 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1020 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1021 comp->ts.u.cl->length->value.integer) != 0)
1023 if (cons->expr->expr_type == EXPR_VARIABLE
1024 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1026 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1027 to make use of the gfc_resolve_character_array_constructor
1028 machinery. The expression is later simplified away to
1029 an array of string literals. */
1030 gfc_expr *para = cons->expr;
1031 cons->expr = gfc_get_expr ();
1032 cons->expr->ts = para->ts;
1033 cons->expr->where = para->where;
1034 cons->expr->expr_type = EXPR_ARRAY;
1035 cons->expr->rank = para->rank;
1036 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1037 gfc_constructor_append_expr (&cons->expr->value.constructor,
1038 para, &cons->expr->where);
1040 if (cons->expr->expr_type == EXPR_ARRAY)
1043 p = gfc_constructor_first (cons->expr->value.constructor);
1044 if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
1046 gfc_charlen *cl, *cl2;
1049 for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
1051 if (cl == cons->expr->ts.u.cl)
1059 cl2->next = cl->next;
1061 gfc_free_expr (cl->length);
1065 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1066 cons->expr->ts.u.cl->length_from_typespec = true;
1067 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1068 gfc_resolve_character_array_constructor (cons->expr);
1072 if (cons->expr->expr_type == EXPR_NULL
1073 && !(comp->attr.pointer || comp->attr.allocatable
1074 || comp->attr.proc_pointer
1075 || (comp->ts.type == BT_CLASS
1076 && (CLASS_DATA (comp)->attr.class_pointer
1077 || CLASS_DATA (comp)->attr.allocatable))))
1080 gfc_error ("The NULL in the derived type constructor at %L is "
1081 "being applied to component '%s', which is neither "
1082 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1086 if (!comp->attr.pointer || comp->attr.proc_pointer
1087 || cons->expr->expr_type == EXPR_NULL)
1090 a = gfc_expr_attr (cons->expr);
1092 if (!a.pointer && !a.target)
1095 gfc_error ("The element in the derived type constructor at %L, "
1096 "for pointer component '%s' should be a POINTER or "
1097 "a TARGET", &cons->expr->where, comp->name);
1102 /* F08:C461. Additional checks for pointer initialization. */
1106 gfc_error ("Pointer initialization target at %L "
1107 "must not be ALLOCATABLE ", &cons->expr->where);
1112 gfc_error ("Pointer initialization target at %L "
1113 "must have the SAVE attribute", &cons->expr->where);
1117 /* F2003, C1272 (3). */
1118 if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
1119 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1120 || gfc_is_coindexed (cons->expr)))
1123 gfc_error ("Invalid expression in the derived type constructor for "
1124 "pointer component '%s' at %L in PURE procedure",
1125 comp->name, &cons->expr->where);
1134 /****************** Expression name resolution ******************/
1136 /* Returns 0 if a symbol was not declared with a type or
1137 attribute declaration statement, nonzero otherwise. */
1140 was_declared (gfc_symbol *sym)
1146 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1149 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1150 || a.optional || a.pointer || a.save || a.target || a.volatile_
1151 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1152 || a.asynchronous || a.codimension)
1159 /* Determine if a symbol is generic or not. */
1162 generic_sym (gfc_symbol *sym)
1166 if (sym->attr.generic ||
1167 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1170 if (was_declared (sym) || sym->ns->parent == NULL)
1173 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1180 return generic_sym (s);
1187 /* Determine if a symbol is specific or not. */
1190 specific_sym (gfc_symbol *sym)
1194 if (sym->attr.if_source == IFSRC_IFBODY
1195 || sym->attr.proc == PROC_MODULE
1196 || sym->attr.proc == PROC_INTERNAL
1197 || sym->attr.proc == PROC_ST_FUNCTION
1198 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1199 || sym->attr.external)
1202 if (was_declared (sym) || sym->ns->parent == NULL)
1205 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1207 return (s == NULL) ? 0 : specific_sym (s);
1211 /* Figure out if the procedure is specific, generic or unknown. */
1214 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1218 procedure_kind (gfc_symbol *sym)
1220 if (generic_sym (sym))
1221 return PTYPE_GENERIC;
1223 if (specific_sym (sym))
1224 return PTYPE_SPECIFIC;
1226 return PTYPE_UNKNOWN;
1229 /* Check references to assumed size arrays. The flag need_full_assumed_size
1230 is nonzero when matching actual arguments. */
1232 static int need_full_assumed_size = 0;
1235 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1237 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1240 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1241 What should it be? */
1242 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1243 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1244 && (e->ref->u.ar.type == AR_FULL))
1246 gfc_error ("The upper bound in the last dimension must "
1247 "appear in the reference to the assumed size "
1248 "array '%s' at %L", sym->name, &e->where);
1255 /* Look for bad assumed size array references in argument expressions
1256 of elemental and array valued intrinsic procedures. Since this is
1257 called from procedure resolution functions, it only recurses at
1261 resolve_assumed_size_actual (gfc_expr *e)
1266 switch (e->expr_type)
1269 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1274 if (resolve_assumed_size_actual (e->value.op.op1)
1275 || resolve_assumed_size_actual (e->value.op.op2))
1286 /* Check a generic procedure, passed as an actual argument, to see if
1287 there is a matching specific name. If none, it is an error, and if
1288 more than one, the reference is ambiguous. */
1290 count_specific_procs (gfc_expr *e)
1297 sym = e->symtree->n.sym;
1299 for (p = sym->generic; p; p = p->next)
1300 if (strcmp (sym->name, p->sym->name) == 0)
1302 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1308 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1312 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1313 "argument at %L", sym->name, &e->where);
1319 /* See if a call to sym could possibly be a not allowed RECURSION because of
1320 a missing RECURIVE declaration. This means that either sym is the current
1321 context itself, or sym is the parent of a contained procedure calling its
1322 non-RECURSIVE containing procedure.
1323 This also works if sym is an ENTRY. */
1326 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1328 gfc_symbol* proc_sym;
1329 gfc_symbol* context_proc;
1330 gfc_namespace* real_context;
1332 if (sym->attr.flavor == FL_PROGRAM)
1335 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1337 /* If we've got an ENTRY, find real procedure. */
1338 if (sym->attr.entry && sym->ns->entries)
1339 proc_sym = sym->ns->entries->sym;
1343 /* If sym is RECURSIVE, all is well of course. */
1344 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1347 /* Find the context procedure's "real" symbol if it has entries.
1348 We look for a procedure symbol, so recurse on the parents if we don't
1349 find one (like in case of a BLOCK construct). */
1350 for (real_context = context; ; real_context = real_context->parent)
1352 /* We should find something, eventually! */
1353 gcc_assert (real_context);
1355 context_proc = (real_context->entries ? real_context->entries->sym
1356 : real_context->proc_name);
1358 /* In some special cases, there may not be a proc_name, like for this
1360 real(bad_kind()) function foo () ...
1361 when checking the call to bad_kind ().
1362 In these cases, we simply return here and assume that the
1367 if (context_proc->attr.flavor != FL_LABEL)
1371 /* A call from sym's body to itself is recursion, of course. */
1372 if (context_proc == proc_sym)
1375 /* The same is true if context is a contained procedure and sym the
1377 if (context_proc->attr.contained)
1379 gfc_symbol* parent_proc;
1381 gcc_assert (context->parent);
1382 parent_proc = (context->parent->entries ? context->parent->entries->sym
1383 : context->parent->proc_name);
1385 if (parent_proc == proc_sym)
1393 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1394 its typespec and formal argument list. */
1397 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1399 gfc_intrinsic_sym* isym;
1405 /* We already know this one is an intrinsic, so we don't call
1406 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1407 gfc_find_subroutine directly to check whether it is a function or
1410 if ((isym = gfc_find_function (sym->name)))
1412 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1413 && !sym->attr.implicit_type)
1414 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1415 " ignored", sym->name, &sym->declared_at);
1417 if (!sym->attr.function &&
1418 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1423 else if ((isym = gfc_find_subroutine (sym->name)))
1425 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1427 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1428 " specifier", sym->name, &sym->declared_at);
1432 if (!sym->attr.subroutine &&
1433 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1438 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1443 gfc_copy_formal_args_intr (sym, isym);
1445 /* Check it is actually available in the standard settings. */
1446 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1449 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1450 " available in the current standard settings but %s. Use"
1451 " an appropriate -std=* option or enable -fall-intrinsics"
1452 " in order to use it.",
1453 sym->name, &sym->declared_at, symstd);
1461 /* Resolve a procedure expression, like passing it to a called procedure or as
1462 RHS for a procedure pointer assignment. */
1465 resolve_procedure_expression (gfc_expr* expr)
1469 if (expr->expr_type != EXPR_VARIABLE)
1471 gcc_assert (expr->symtree);
1473 sym = expr->symtree->n.sym;
1475 if (sym->attr.intrinsic)
1476 resolve_intrinsic (sym, &expr->where);
1478 if (sym->attr.flavor != FL_PROCEDURE
1479 || (sym->attr.function && sym->result == sym))
1482 /* A non-RECURSIVE procedure that is used as procedure expression within its
1483 own body is in danger of being called recursively. */
1484 if (is_illegal_recursion (sym, gfc_current_ns))
1485 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1486 " itself recursively. Declare it RECURSIVE or use"
1487 " -frecursive", sym->name, &expr->where);
1493 /* Resolve an actual argument list. Most of the time, this is just
1494 resolving the expressions in the list.
1495 The exception is that we sometimes have to decide whether arguments
1496 that look like procedure arguments are really simple variable
1500 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1501 bool no_formal_args)
1504 gfc_symtree *parent_st;
1506 int save_need_full_assumed_size;
1507 gfc_component *comp;
1509 for (; arg; arg = arg->next)
1514 /* Check the label is a valid branching target. */
1517 if (arg->label->defined == ST_LABEL_UNKNOWN)
1519 gfc_error ("Label %d referenced at %L is never defined",
1520 arg->label->value, &arg->label->where);
1527 if (gfc_is_proc_ptr_comp (e, &comp))
1530 if (e->expr_type == EXPR_PPC)
1532 if (comp->as != NULL)
1533 e->rank = comp->as->rank;
1534 e->expr_type = EXPR_FUNCTION;
1536 if (gfc_resolve_expr (e) == FAILURE)
1541 if (e->expr_type == EXPR_VARIABLE
1542 && e->symtree->n.sym->attr.generic
1544 && count_specific_procs (e) != 1)
1547 if (e->ts.type != BT_PROCEDURE)
1549 save_need_full_assumed_size = need_full_assumed_size;
1550 if (e->expr_type != EXPR_VARIABLE)
1551 need_full_assumed_size = 0;
1552 if (gfc_resolve_expr (e) != SUCCESS)
1554 need_full_assumed_size = save_need_full_assumed_size;
1558 /* See if the expression node should really be a variable reference. */
1560 sym = e->symtree->n.sym;
1562 if (sym->attr.flavor == FL_PROCEDURE
1563 || sym->attr.intrinsic
1564 || sym->attr.external)
1568 /* If a procedure is not already determined to be something else
1569 check if it is intrinsic. */
1570 if (!sym->attr.intrinsic
1571 && !(sym->attr.external || sym->attr.use_assoc
1572 || sym->attr.if_source == IFSRC_IFBODY)
1573 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1574 sym->attr.intrinsic = 1;
1576 if (sym->attr.proc == PROC_ST_FUNCTION)
1578 gfc_error ("Statement function '%s' at %L is not allowed as an "
1579 "actual argument", sym->name, &e->where);
1582 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1583 sym->attr.subroutine);
1584 if (sym->attr.intrinsic && actual_ok == 0)
1586 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1587 "actual argument", sym->name, &e->where);
1590 if (sym->attr.contained && !sym->attr.use_assoc
1591 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1593 if (gfc_notify_std (GFC_STD_F2008,
1594 "Fortran 2008: Internal procedure '%s' is"
1595 " used as actual argument at %L",
1596 sym->name, &e->where) == FAILURE)
1600 if (sym->attr.elemental && !sym->attr.intrinsic)
1602 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1603 "allowed as an actual argument at %L", sym->name,
1607 /* Check if a generic interface has a specific procedure
1608 with the same name before emitting an error. */
1609 if (sym->attr.generic && count_specific_procs (e) != 1)
1612 /* Just in case a specific was found for the expression. */
1613 sym = e->symtree->n.sym;
1615 /* If the symbol is the function that names the current (or
1616 parent) scope, then we really have a variable reference. */
1618 if (gfc_is_function_return_value (sym, sym->ns))
1621 /* If all else fails, see if we have a specific intrinsic. */
1622 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1624 gfc_intrinsic_sym *isym;
1626 isym = gfc_find_function (sym->name);
1627 if (isym == NULL || !isym->specific)
1629 gfc_error ("Unable to find a specific INTRINSIC procedure "
1630 "for the reference '%s' at %L", sym->name,
1635 sym->attr.intrinsic = 1;
1636 sym->attr.function = 1;
1639 if (gfc_resolve_expr (e) == FAILURE)
1644 /* See if the name is a module procedure in a parent unit. */
1646 if (was_declared (sym) || sym->ns->parent == NULL)
1649 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1651 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1655 if (parent_st == NULL)
1658 sym = parent_st->n.sym;
1659 e->symtree = parent_st; /* Point to the right thing. */
1661 if (sym->attr.flavor == FL_PROCEDURE
1662 || sym->attr.intrinsic
1663 || sym->attr.external)
1665 if (gfc_resolve_expr (e) == FAILURE)
1671 e->expr_type = EXPR_VARIABLE;
1673 if (sym->as != NULL)
1675 e->rank = sym->as->rank;
1676 e->ref = gfc_get_ref ();
1677 e->ref->type = REF_ARRAY;
1678 e->ref->u.ar.type = AR_FULL;
1679 e->ref->u.ar.as = sym->as;
1682 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1683 primary.c (match_actual_arg). If above code determines that it
1684 is a variable instead, it needs to be resolved as it was not
1685 done at the beginning of this function. */
1686 save_need_full_assumed_size = need_full_assumed_size;
1687 if (e->expr_type != EXPR_VARIABLE)
1688 need_full_assumed_size = 0;
1689 if (gfc_resolve_expr (e) != SUCCESS)
1691 need_full_assumed_size = save_need_full_assumed_size;
1694 /* Check argument list functions %VAL, %LOC and %REF. There is
1695 nothing to do for %REF. */
1696 if (arg->name && arg->name[0] == '%')
1698 if (strncmp ("%VAL", arg->name, 4) == 0)
1700 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1702 gfc_error ("By-value argument at %L is not of numeric "
1709 gfc_error ("By-value argument at %L cannot be an array or "
1710 "an array section", &e->where);
1714 /* Intrinsics are still PROC_UNKNOWN here. However,
1715 since same file external procedures are not resolvable
1716 in gfortran, it is a good deal easier to leave them to
1718 if (ptype != PROC_UNKNOWN
1719 && ptype != PROC_DUMMY
1720 && ptype != PROC_EXTERNAL
1721 && ptype != PROC_MODULE)
1723 gfc_error ("By-value argument at %L is not allowed "
1724 "in this context", &e->where);
1729 /* Statement functions have already been excluded above. */
1730 else if (strncmp ("%LOC", arg->name, 4) == 0
1731 && e->ts.type == BT_PROCEDURE)
1733 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1735 gfc_error ("Passing internal procedure at %L by location "
1736 "not allowed", &e->where);
1742 /* Fortran 2008, C1237. */
1743 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1744 && gfc_has_ultimate_pointer (e))
1746 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1747 "component", &e->where);
1756 /* Do the checks of the actual argument list that are specific to elemental
1757 procedures. If called with c == NULL, we have a function, otherwise if
1758 expr == NULL, we have a subroutine. */
1761 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1763 gfc_actual_arglist *arg0;
1764 gfc_actual_arglist *arg;
1765 gfc_symbol *esym = NULL;
1766 gfc_intrinsic_sym *isym = NULL;
1768 gfc_intrinsic_arg *iformal = NULL;
1769 gfc_formal_arglist *eformal = NULL;
1770 bool formal_optional = false;
1771 bool set_by_optional = false;
1775 /* Is this an elemental procedure? */
1776 if (expr && expr->value.function.actual != NULL)
1778 if (expr->value.function.esym != NULL
1779 && expr->value.function.esym->attr.elemental)
1781 arg0 = expr->value.function.actual;
1782 esym = expr->value.function.esym;
1784 else if (expr->value.function.isym != NULL
1785 && expr->value.function.isym->elemental)
1787 arg0 = expr->value.function.actual;
1788 isym = expr->value.function.isym;
1793 else if (c && c->ext.actual != NULL)
1795 arg0 = c->ext.actual;
1797 if (c->resolved_sym)
1798 esym = c->resolved_sym;
1800 esym = c->symtree->n.sym;
1803 if (!esym->attr.elemental)
1809 /* The rank of an elemental is the rank of its array argument(s). */
1810 for (arg = arg0; arg; arg = arg->next)
1812 if (arg->expr != NULL && arg->expr->rank > 0)
1814 rank = arg->expr->rank;
1815 if (arg->expr->expr_type == EXPR_VARIABLE
1816 && arg->expr->symtree->n.sym->attr.optional)
1817 set_by_optional = true;
1819 /* Function specific; set the result rank and shape. */
1823 if (!expr->shape && arg->expr->shape)
1825 expr->shape = gfc_get_shape (rank);
1826 for (i = 0; i < rank; i++)
1827 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1834 /* If it is an array, it shall not be supplied as an actual argument
1835 to an elemental procedure unless an array of the same rank is supplied
1836 as an actual argument corresponding to a nonoptional dummy argument of
1837 that elemental procedure(12.4.1.5). */
1838 formal_optional = false;
1840 iformal = isym->formal;
1842 eformal = esym->formal;
1844 for (arg = arg0; arg; arg = arg->next)
1848 if (eformal->sym && eformal->sym->attr.optional)
1849 formal_optional = true;
1850 eformal = eformal->next;
1852 else if (isym && iformal)
1854 if (iformal->optional)
1855 formal_optional = true;
1856 iformal = iformal->next;
1859 formal_optional = true;
1861 if (pedantic && arg->expr != NULL
1862 && arg->expr->expr_type == EXPR_VARIABLE
1863 && arg->expr->symtree->n.sym->attr.optional
1866 && (set_by_optional || arg->expr->rank != rank)
1867 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1869 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1870 "MISSING, it cannot be the actual argument of an "
1871 "ELEMENTAL procedure unless there is a non-optional "
1872 "argument with the same rank (12.4.1.5)",
1873 arg->expr->symtree->n.sym->name, &arg->expr->where);
1878 for (arg = arg0; arg; arg = arg->next)
1880 if (arg->expr == NULL || arg->expr->rank == 0)
1883 /* Being elemental, the last upper bound of an assumed size array
1884 argument must be present. */
1885 if (resolve_assumed_size_actual (arg->expr))
1888 /* Elemental procedure's array actual arguments must conform. */
1891 if (gfc_check_conformance (arg->expr, e,
1892 "elemental procedure") == FAILURE)
1899 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1900 is an array, the intent inout/out variable needs to be also an array. */
1901 if (rank > 0 && esym && expr == NULL)
1902 for (eformal = esym->formal, arg = arg0; arg && eformal;
1903 arg = arg->next, eformal = eformal->next)
1904 if ((eformal->sym->attr.intent == INTENT_OUT
1905 || eformal->sym->attr.intent == INTENT_INOUT)
1906 && arg->expr && arg->expr->rank == 0)
1908 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1909 "ELEMENTAL subroutine '%s' is a scalar, but another "
1910 "actual argument is an array", &arg->expr->where,
1911 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1912 : "INOUT", eformal->sym->name, esym->name);
1919 /* This function does the checking of references to global procedures
1920 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1921 77 and 95 standards. It checks for a gsymbol for the name, making
1922 one if it does not already exist. If it already exists, then the
1923 reference being resolved must correspond to the type of gsymbol.
1924 Otherwise, the new symbol is equipped with the attributes of the
1925 reference. The corresponding code that is called in creating
1926 global entities is parse.c.
1928 In addition, for all but -std=legacy, the gsymbols are used to
1929 check the interfaces of external procedures from the same file.
1930 The namespace of the gsymbol is resolved and then, once this is
1931 done the interface is checked. */
1935 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
1937 if (!gsym_ns->proc_name->attr.recursive)
1940 if (sym->ns == gsym_ns)
1943 if (sym->ns->parent && sym->ns->parent == gsym_ns)
1950 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
1952 if (gsym_ns->entries)
1954 gfc_entry_list *entry = gsym_ns->entries;
1956 for (; entry; entry = entry->next)
1958 if (strcmp (sym->name, entry->sym->name) == 0)
1960 if (strcmp (gsym_ns->proc_name->name,
1961 sym->ns->proc_name->name) == 0)
1965 && strcmp (gsym_ns->proc_name->name,
1966 sym->ns->parent->proc_name->name) == 0)
1975 resolve_global_procedure (gfc_symbol *sym, locus *where,
1976 gfc_actual_arglist **actual, int sub)
1980 enum gfc_symbol_type type;
1982 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1984 gsym = gfc_get_gsymbol (sym->name);
1986 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1987 gfc_global_used (gsym, where);
1989 if (gfc_option.flag_whole_file
1990 && (sym->attr.if_source == IFSRC_UNKNOWN
1991 || sym->attr.if_source == IFSRC_IFBODY)
1992 && gsym->type != GSYM_UNKNOWN
1994 && gsym->ns->resolved != -1
1995 && gsym->ns->proc_name
1996 && not_in_recursive (sym, gsym->ns)
1997 && not_entry_self_reference (sym, gsym->ns))
1999 gfc_symbol *def_sym;
2001 /* Resolve the gsymbol namespace if needed. */
2002 if (!gsym->ns->resolved)
2004 gfc_dt_list *old_dt_list;
2006 /* Stash away derived types so that the backend_decls do not
2008 old_dt_list = gfc_derived_types;
2009 gfc_derived_types = NULL;
2011 gfc_resolve (gsym->ns);
2013 /* Store the new derived types with the global namespace. */
2014 if (gfc_derived_types)
2015 gsym->ns->derived_types = gfc_derived_types;
2017 /* Restore the derived types of this namespace. */
2018 gfc_derived_types = old_dt_list;
2021 /* Make sure that translation for the gsymbol occurs before
2022 the procedure currently being resolved. */
2023 ns = gfc_global_ns_list;
2024 for (; ns && ns != gsym->ns; ns = ns->sibling)
2026 if (ns->sibling == gsym->ns)
2028 ns->sibling = gsym->ns->sibling;
2029 gsym->ns->sibling = gfc_global_ns_list;
2030 gfc_global_ns_list = gsym->ns;
2035 def_sym = gsym->ns->proc_name;
2036 if (def_sym->attr.entry_master)
2038 gfc_entry_list *entry;
2039 for (entry = gsym->ns->entries; entry; entry = entry->next)
2040 if (strcmp (entry->sym->name, sym->name) == 0)
2042 def_sym = entry->sym;
2047 /* Differences in constant character lengths. */
2048 if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2050 long int l1 = 0, l2 = 0;
2051 gfc_charlen *cl1 = sym->ts.u.cl;
2052 gfc_charlen *cl2 = def_sym->ts.u.cl;
2055 && cl1->length != NULL
2056 && cl1->length->expr_type == EXPR_CONSTANT)
2057 l1 = mpz_get_si (cl1->length->value.integer);
2060 && cl2->length != NULL
2061 && cl2->length->expr_type == EXPR_CONSTANT)
2062 l2 = mpz_get_si (cl2->length->value.integer);
2064 if (l1 && l2 && l1 != l2)
2065 gfc_error ("Character length mismatch in return type of "
2066 "function '%s' at %L (%ld/%ld)", sym->name,
2067 &sym->declared_at, l1, l2);
2070 /* Type mismatch of function return type and expected type. */
2071 if (sym->attr.function
2072 && !gfc_compare_types (&sym->ts, &def_sym->ts))
2073 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2074 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2075 gfc_typename (&def_sym->ts));
2077 if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2079 gfc_formal_arglist *arg = def_sym->formal;
2080 for ( ; arg; arg = arg->next)
2083 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2084 else if (arg->sym->attr.allocatable
2085 || arg->sym->attr.asynchronous
2086 || arg->sym->attr.optional
2087 || arg->sym->attr.pointer
2088 || arg->sym->attr.target
2089 || arg->sym->attr.value
2090 || arg->sym->attr.volatile_)
2092 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2093 "has an attribute that requires an explicit "
2094 "interface for this procedure", arg->sym->name,
2095 sym->name, &sym->declared_at);
2098 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2099 else if (arg->sym && arg->sym->as
2100 && arg->sym->as->type == AS_ASSUMED_SHAPE)
2102 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2103 "argument '%s' must have an explicit interface",
2104 sym->name, &sym->declared_at, arg->sym->name);
2107 /* F2008, 12.4.2.2 (2c) */
2108 else if (arg->sym->attr.codimension)
2110 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2111 "'%s' must have an explicit interface",
2112 sym->name, &sym->declared_at, arg->sym->name);
2115 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2116 else if (false) /* TODO: is a parametrized derived type */
2118 gfc_error ("Procedure '%s' at %L with parametrized derived "
2119 "type argument '%s' must have an explicit "
2120 "interface", sym->name, &sym->declared_at,
2124 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2125 else if (arg->sym->ts.type == BT_CLASS)
2127 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2128 "argument '%s' must have an explicit interface",
2129 sym->name, &sym->declared_at, arg->sym->name);
2134 if (def_sym->attr.function)
2136 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2137 if (def_sym->as && def_sym->as->rank
2138 && (!sym->as || sym->as->rank != def_sym->as->rank))
2139 gfc_error ("The reference to function '%s' at %L either needs an "
2140 "explicit INTERFACE or the rank is incorrect", sym->name,
2143 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2144 if ((def_sym->result->attr.pointer
2145 || def_sym->result->attr.allocatable)
2146 && (sym->attr.if_source != IFSRC_IFBODY
2147 || def_sym->result->attr.pointer
2148 != sym->result->attr.pointer
2149 || def_sym->result->attr.allocatable
2150 != sym->result->attr.allocatable))
2151 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2152 "result must have an explicit interface", sym->name,
2155 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2156 if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2157 && def_sym->ts.u.cl->length != NULL)
2159 gfc_charlen *cl = sym->ts.u.cl;
2161 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2162 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2164 gfc_error ("Nonconstant character-length function '%s' at %L "
2165 "must have an explicit interface", sym->name,
2171 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2172 if (def_sym->attr.elemental && !sym->attr.elemental)
2174 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2175 "interface", sym->name, &sym->declared_at);
2178 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2179 if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2181 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2182 "an explicit interface", sym->name, &sym->declared_at);
2185 if (gfc_option.flag_whole_file == 1
2186 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2187 && !(gfc_option.warn_std & GFC_STD_GNU)))
2188 gfc_errors_to_warnings (1);
2190 if (sym->attr.if_source != IFSRC_IFBODY)
2191 gfc_procedure_use (def_sym, actual, where);
2193 gfc_errors_to_warnings (0);
2196 if (gsym->type == GSYM_UNKNOWN)
2199 gsym->where = *where;
2206 /************* Function resolution *************/
2208 /* Resolve a function call known to be generic.
2209 Section 14.1.2.4.1. */
2212 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2216 if (sym->attr.generic)
2218 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2221 expr->value.function.name = s->name;
2222 expr->value.function.esym = s;
2224 if (s->ts.type != BT_UNKNOWN)
2226 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2227 expr->ts = s->result->ts;
2230 expr->rank = s->as->rank;
2231 else if (s->result != NULL && s->result->as != NULL)
2232 expr->rank = s->result->as->rank;
2234 gfc_set_sym_referenced (expr->value.function.esym);
2239 /* TODO: Need to search for elemental references in generic
2243 if (sym->attr.intrinsic)
2244 return gfc_intrinsic_func_interface (expr, 0);
2251 resolve_generic_f (gfc_expr *expr)
2256 sym = expr->symtree->n.sym;
2260 m = resolve_generic_f0 (expr, sym);
2263 else if (m == MATCH_ERROR)
2267 if (sym->ns->parent == NULL)
2269 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2273 if (!generic_sym (sym))
2277 /* Last ditch attempt. See if the reference is to an intrinsic
2278 that possesses a matching interface. 14.1.2.4 */
2279 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
2281 gfc_error ("There is no specific function for the generic '%s' at %L",
2282 expr->symtree->n.sym->name, &expr->where);
2286 m = gfc_intrinsic_func_interface (expr, 0);
2290 gfc_error ("Generic function '%s' at %L is not consistent with a "
2291 "specific intrinsic interface", expr->symtree->n.sym->name,
2298 /* Resolve a function call known to be specific. */
2301 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2305 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2307 if (sym->attr.dummy)
2309 sym->attr.proc = PROC_DUMMY;
2313 sym->attr.proc = PROC_EXTERNAL;
2317 if (sym->attr.proc == PROC_MODULE
2318 || sym->attr.proc == PROC_ST_FUNCTION
2319 || sym->attr.proc == PROC_INTERNAL)
2322 if (sym->attr.intrinsic)
2324 m = gfc_intrinsic_func_interface (expr, 1);
2328 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2329 "with an intrinsic", sym->name, &expr->where);
2337 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2340 expr->ts = sym->result->ts;
2343 expr->value.function.name = sym->name;
2344 expr->value.function.esym = sym;
2345 if (sym->as != NULL)
2346 expr->rank = sym->as->rank;
2353 resolve_specific_f (gfc_expr *expr)
2358 sym = expr->symtree->n.sym;
2362 m = resolve_specific_f0 (sym, expr);
2365 if (m == MATCH_ERROR)
2368 if (sym->ns->parent == NULL)
2371 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2377 gfc_error ("Unable to resolve the specific function '%s' at %L",
2378 expr->symtree->n.sym->name, &expr->where);
2384 /* Resolve a procedure call not known to be generic nor specific. */
2387 resolve_unknown_f (gfc_expr *expr)
2392 sym = expr->symtree->n.sym;
2394 if (sym->attr.dummy)
2396 sym->attr.proc = PROC_DUMMY;
2397 expr->value.function.name = sym->name;
2401 /* See if we have an intrinsic function reference. */
2403 if (gfc_is_intrinsic (sym, 0, expr->where))
2405 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2410 /* The reference is to an external name. */
2412 sym->attr.proc = PROC_EXTERNAL;
2413 expr->value.function.name = sym->name;
2414 expr->value.function.esym = expr->symtree->n.sym;
2416 if (sym->as != NULL)
2417 expr->rank = sym->as->rank;
2419 /* Type of the expression is either the type of the symbol or the
2420 default type of the symbol. */
2423 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2425 if (sym->ts.type != BT_UNKNOWN)
2429 ts = gfc_get_default_type (sym->name, sym->ns);
2431 if (ts->type == BT_UNKNOWN)
2433 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2434 sym->name, &expr->where);
2445 /* Return true, if the symbol is an external procedure. */
2447 is_external_proc (gfc_symbol *sym)
2449 if (!sym->attr.dummy && !sym->attr.contained
2450 && !(sym->attr.intrinsic
2451 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2452 && sym->attr.proc != PROC_ST_FUNCTION
2453 && !sym->attr.proc_pointer
2454 && !sym->attr.use_assoc
2462 /* Figure out if a function reference is pure or not. Also set the name
2463 of the function for a potential error message. Return nonzero if the
2464 function is PURE, zero if not. */
2466 pure_stmt_function (gfc_expr *, gfc_symbol *);
2469 pure_function (gfc_expr *e, const char **name)
2475 if (e->symtree != NULL
2476 && e->symtree->n.sym != NULL
2477 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2478 return pure_stmt_function (e, e->symtree->n.sym);
2480 if (e->value.function.esym)
2482 pure = gfc_pure (e->value.function.esym);
2483 *name = e->value.function.esym->name;
2485 else if (e->value.function.isym)
2487 pure = e->value.function.isym->pure
2488 || e->value.function.isym->elemental;
2489 *name = e->value.function.isym->name;
2493 /* Implicit functions are not pure. */
2495 *name = e->value.function.name;
2503 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2504 int *f ATTRIBUTE_UNUSED)
2508 /* Don't bother recursing into other statement functions
2509 since they will be checked individually for purity. */
2510 if (e->expr_type != EXPR_FUNCTION
2512 || e->symtree->n.sym == sym
2513 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2516 return pure_function (e, &name) ? false : true;
2521 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2523 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2528 is_scalar_expr_ptr (gfc_expr *expr)
2530 gfc_try retval = SUCCESS;
2535 /* See if we have a gfc_ref, which means we have a substring, array
2536 reference, or a component. */
2537 if (expr->ref != NULL)
2540 while (ref->next != NULL)
2546 if (ref->u.ss.length != NULL
2547 && ref->u.ss.length->length != NULL
2549 && ref->u.ss.start->expr_type == EXPR_CONSTANT
2551 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
2553 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
2554 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
2555 if (end - start + 1 != 1)
2562 if (ref->u.ar.type == AR_ELEMENT)
2564 else if (ref->u.ar.type == AR_FULL)
2566 /* The user can give a full array if the array is of size 1. */
2567 if (ref->u.ar.as != NULL
2568 && ref->u.ar.as->rank == 1
2569 && ref->u.ar.as->type == AS_EXPLICIT
2570 && ref->u.ar.as->lower[0] != NULL
2571 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2572 && ref->u.ar.as->upper[0] != NULL
2573 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2575 /* If we have a character string, we need to check if
2576 its length is one. */
2577 if (expr->ts.type == BT_CHARACTER)
2579 if (expr->ts.u.cl == NULL
2580 || expr->ts.u.cl->length == NULL
2581 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2587 /* We have constant lower and upper bounds. If the
2588 difference between is 1, it can be considered a
2590 start = (int) mpz_get_si
2591 (ref->u.ar.as->lower[0]->value.integer);
2592 end = (int) mpz_get_si
2593 (ref->u.ar.as->upper[0]->value.integer);
2594 if (end - start + 1 != 1)
2609 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2611 /* Character string. Make sure it's of length 1. */
2612 if (expr->ts.u.cl == NULL
2613 || expr->ts.u.cl->length == NULL
2614 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2617 else if (expr->rank != 0)
2624 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2625 and, in the case of c_associated, set the binding label based on
2629 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2630 gfc_symbol **new_sym)
2632 char name[GFC_MAX_SYMBOL_LEN + 1];
2633 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2634 int optional_arg = 0;
2635 gfc_try retval = SUCCESS;
2636 gfc_symbol *args_sym;
2637 gfc_typespec *arg_ts;
2638 symbol_attribute arg_attr;
2640 if (args->expr->expr_type == EXPR_CONSTANT
2641 || args->expr->expr_type == EXPR_OP
2642 || args->expr->expr_type == EXPR_NULL)
2644 gfc_error ("Argument to '%s' at %L is not a variable",
2645 sym->name, &(args->expr->where));
2649 args_sym = args->expr->symtree->n.sym;
2651 /* The typespec for the actual arg should be that stored in the expr
2652 and not necessarily that of the expr symbol (args_sym), because
2653 the actual expression could be a part-ref of the expr symbol. */
2654 arg_ts = &(args->expr->ts);
2655 arg_attr = gfc_expr_attr (args->expr);
2657 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2659 /* If the user gave two args then they are providing something for
2660 the optional arg (the second cptr). Therefore, set the name and
2661 binding label to the c_associated for two cptrs. Otherwise,
2662 set c_associated to expect one cptr. */
2666 sprintf (name, "%s_2", sym->name);
2667 sprintf (binding_label, "%s_2", sym->binding_label);
2673 sprintf (name, "%s_1", sym->name);
2674 sprintf (binding_label, "%s_1", sym->binding_label);
2678 /* Get a new symbol for the version of c_associated that
2680 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2682 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2683 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2685 sprintf (name, "%s", sym->name);
2686 sprintf (binding_label, "%s", sym->binding_label);
2688 /* Error check the call. */
2689 if (args->next != NULL)
2691 gfc_error_now ("More actual than formal arguments in '%s' "
2692 "call at %L", name, &(args->expr->where));
2695 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2697 /* Make sure we have either the target or pointer attribute. */
2698 if (!arg_attr.target && !arg_attr.pointer)
2700 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2701 "a TARGET or an associated pointer",
2703 sym->name, &(args->expr->where));
2707 /* See if we have interoperable type and type param. */
2708 if (verify_c_interop (arg_ts) == SUCCESS
2709 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2711 if (args_sym->attr.target == 1)
2713 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2714 has the target attribute and is interoperable. */
2715 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2716 allocatable variable that has the TARGET attribute and
2717 is not an array of zero size. */
2718 if (args_sym->attr.allocatable == 1)
2720 if (args_sym->attr.dimension != 0
2721 && (args_sym->as && args_sym->as->rank == 0))
2723 gfc_error_now ("Allocatable variable '%s' used as a "
2724 "parameter to '%s' at %L must not be "
2725 "an array of zero size",
2726 args_sym->name, sym->name,
2727 &(args->expr->where));
2733 /* A non-allocatable target variable with C
2734 interoperable type and type parameters must be
2736 if (args_sym && args_sym->attr.dimension)
2738 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2740 gfc_error ("Assumed-shape array '%s' at %L "
2741 "cannot be an argument to the "
2742 "procedure '%s' because "
2743 "it is not C interoperable",
2745 &(args->expr->where), sym->name);
2748 else if (args_sym->as->type == AS_DEFERRED)
2750 gfc_error ("Deferred-shape array '%s' at %L "
2751 "cannot be an argument to the "
2752 "procedure '%s' because "
2753 "it is not C interoperable",
2755 &(args->expr->where), sym->name);
2760 /* Make sure it's not a character string. Arrays of
2761 any type should be ok if the variable is of a C
2762 interoperable type. */
2763 if (arg_ts->type == BT_CHARACTER)
2764 if (arg_ts->u.cl != NULL
2765 && (arg_ts->u.cl->length == NULL
2766 || arg_ts->u.cl->length->expr_type
2769 (arg_ts->u.cl->length->value.integer, 1)
2771 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2773 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2774 "at %L must have a length of 1",
2775 args_sym->name, sym->name,
2776 &(args->expr->where));
2781 else if (arg_attr.pointer
2782 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2784 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2786 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2787 "associated scalar POINTER", args_sym->name,
2788 sym->name, &(args->expr->where));
2794 /* The parameter is not required to be C interoperable. If it
2795 is not C interoperable, it must be a nonpolymorphic scalar
2796 with no length type parameters. It still must have either
2797 the pointer or target attribute, and it can be
2798 allocatable (but must be allocated when c_loc is called). */
2799 if (args->expr->rank != 0
2800 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2802 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2803 "scalar", args_sym->name, sym->name,
2804 &(args->expr->where));
2807 else if (arg_ts->type == BT_CHARACTER
2808 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2810 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2811 "%L must have a length of 1",
2812 args_sym->name, sym->name,
2813 &(args->expr->where));
2816 else if (arg_ts->type == BT_CLASS)
2818 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2819 "polymorphic", args_sym->name, sym->name,
2820 &(args->expr->where));
2825 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2827 if (args_sym->attr.flavor != FL_PROCEDURE)
2829 /* TODO: Update this error message to allow for procedure
2830 pointers once they are implemented. */
2831 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2833 args_sym->name, sym->name,
2834 &(args->expr->where));
2837 else if (args_sym->attr.is_bind_c != 1)
2839 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2841 args_sym->name, sym->name,
2842 &(args->expr->where));
2847 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2852 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2853 "iso_c_binding function: '%s'!\n", sym->name);
2860 /* Resolve a function call, which means resolving the arguments, then figuring
2861 out which entity the name refers to. */
2864 resolve_function (gfc_expr *expr)
2866 gfc_actual_arglist *arg;
2871 procedure_type p = PROC_INTRINSIC;
2872 bool no_formal_args;
2876 sym = expr->symtree->n.sym;
2878 /* If this is a procedure pointer component, it has already been resolved. */
2879 if (gfc_is_proc_ptr_comp (expr, NULL))
2882 if (sym && sym->attr.intrinsic
2883 && resolve_intrinsic (sym, &expr->where) == FAILURE)
2886 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2888 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2892 /* If this ia a deferred TBP with an abstract interface (which may
2893 of course be referenced), expr->value.function.esym will be set. */
2894 if (sym && sym->attr.abstract && !expr->value.function.esym)
2896 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2897 sym->name, &expr->where);
2901 /* Switch off assumed size checking and do this again for certain kinds
2902 of procedure, once the procedure itself is resolved. */
2903 need_full_assumed_size++;
2905 if (expr->symtree && expr->symtree->n.sym)
2906 p = expr->symtree->n.sym->attr.proc;
2908 if (expr->value.function.isym && expr->value.function.isym->inquiry)
2909 inquiry_argument = true;
2910 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2912 if (resolve_actual_arglist (expr->value.function.actual,
2913 p, no_formal_args) == FAILURE)
2915 inquiry_argument = false;
2919 inquiry_argument = false;
2921 /* Need to setup the call to the correct c_associated, depending on
2922 the number of cptrs to user gives to compare. */
2923 if (sym && sym->attr.is_iso_c == 1)
2925 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2929 /* Get the symtree for the new symbol (resolved func).
2930 the old one will be freed later, when it's no longer used. */
2931 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2934 /* Resume assumed_size checking. */
2935 need_full_assumed_size--;
2937 /* If the procedure is external, check for usage. */
2938 if (sym && is_external_proc (sym))
2939 resolve_global_procedure (sym, &expr->where,
2940 &expr->value.function.actual, 0);
2942 if (sym && sym->ts.type == BT_CHARACTER
2944 && sym->ts.u.cl->length == NULL
2946 && expr->value.function.esym == NULL
2947 && !sym->attr.contained)
2949 /* Internal procedures are taken care of in resolve_contained_fntype. */
2950 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2951 "be used at %L since it is not a dummy argument",
2952 sym->name, &expr->where);
2956 /* See if function is already resolved. */
2958 if (expr->value.function.name != NULL)
2960 if (expr->ts.type == BT_UNKNOWN)
2966 /* Apply the rules of section 14.1.2. */
2968 switch (procedure_kind (sym))
2971 t = resolve_generic_f (expr);
2974 case PTYPE_SPECIFIC:
2975 t = resolve_specific_f (expr);
2979 t = resolve_unknown_f (expr);
2983 gfc_internal_error ("resolve_function(): bad function type");
2987 /* If the expression is still a function (it might have simplified),
2988 then we check to see if we are calling an elemental function. */
2990 if (expr->expr_type != EXPR_FUNCTION)
2993 temp = need_full_assumed_size;
2994 need_full_assumed_size = 0;
2996 if (resolve_elemental_actual (expr, NULL) == FAILURE)
2999 if (omp_workshare_flag
3000 && expr->value.function.esym
3001 && ! gfc_elemental (expr->value.function.esym))
3003 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3004 "in WORKSHARE construct", expr->value.function.esym->name,
3009 #define GENERIC_ID expr->value.function.isym->id
3010 else if (expr->value.function.actual != NULL
3011 && expr->value.function.isym != NULL
3012 && GENERIC_ID != GFC_ISYM_LBOUND
3013 && GENERIC_ID != GFC_ISYM_LEN
3014 && GENERIC_ID != GFC_ISYM_LOC
3015 && GENERIC_ID != GFC_ISYM_PRESENT)
3017 /* Array intrinsics must also have the last upper bound of an
3018 assumed size array argument. UBOUND and SIZE have to be
3019 excluded from the check if the second argument is anything
3022 for (arg = expr->value.function.actual; arg; arg = arg->next)
3024 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3025 && arg->next != NULL && arg->next->expr)
3027 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3030 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3033 if ((int)mpz_get_si (arg->next->expr->value.integer)
3038 if (arg->expr != NULL
3039 && arg->expr->rank > 0
3040 && resolve_assumed_size_actual (arg->expr))
3046 need_full_assumed_size = temp;
3049 if (!pure_function (expr, &name) && name)
3053 gfc_error ("reference to non-PURE function '%s' at %L inside a "
3054 "FORALL %s", name, &expr->where,
3055 forall_flag == 2 ? "mask" : "block");
3058 else if (gfc_pure (NULL))
3060 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3061 "procedure within a PURE procedure", name, &expr->where);
3066 /* Functions without the RECURSIVE attribution are not allowed to
3067 * call themselves. */
3068 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3071 esym = expr->value.function.esym;
3073 if (is_illegal_recursion (esym, gfc_current_ns))
3075 if (esym->attr.entry && esym->ns->entries)
3076 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3077 " function '%s' is not RECURSIVE",
3078 esym->name, &expr->where, esym->ns->entries->sym->name);
3080 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3081 " is not RECURSIVE", esym->name, &expr->where);
3087 /* Character lengths of use associated functions may contains references to
3088 symbols not referenced from the current program unit otherwise. Make sure
3089 those symbols are marked as referenced. */
3091 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3092 && expr->value.function.esym->attr.use_assoc)
3094 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3097 /* Make sure that the expression has a typespec that works. */
3098 if (expr->ts.type == BT_UNKNOWN)
3100 if (expr->symtree->n.sym->result
3101 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3102 && !expr->symtree->n.sym->result->attr.proc_pointer)
3103 expr->ts = expr->symtree->n.sym->result->ts;
3110 /************* Subroutine resolution *************/
3113 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3119 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3120 sym->name, &c->loc);
3121 else if (gfc_pure (NULL))
3122 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3128 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3132 if (sym->attr.generic)
3134 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3137 c->resolved_sym = s;
3138 pure_subroutine (c, s);
3142 /* TODO: Need to search for elemental references in generic interface. */
3145 if (sym->attr.intrinsic)
3146 return gfc_intrinsic_sub_interface (c, 0);
3153 resolve_generic_s (gfc_code *c)
3158 sym = c->symtree->n.sym;
3162 m = resolve_generic_s0 (c, sym);
3165 else if (m == MATCH_ERROR)
3169 if (sym->ns->parent == NULL)
3171 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3175 if (!generic_sym (sym))
3179 /* Last ditch attempt. See if the reference is to an intrinsic
3180 that possesses a matching interface. 14.1.2.4 */
3181 sym = c->symtree->n.sym;
3183 if (!gfc_is_intrinsic (sym, 1, c->loc))
3185 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3186 sym->name, &c->loc);
3190 m = gfc_intrinsic_sub_interface (c, 0);
3194 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3195 "intrinsic subroutine interface", sym->name, &c->loc);
3201 /* Set the name and binding label of the subroutine symbol in the call
3202 expression represented by 'c' to include the type and kind of the
3203 second parameter. This function is for resolving the appropriate
3204 version of c_f_pointer() and c_f_procpointer(). For example, a
3205 call to c_f_pointer() for a default integer pointer could have a
3206 name of c_f_pointer_i4. If no second arg exists, which is an error
3207 for these two functions, it defaults to the generic symbol's name
3208 and binding label. */
3211 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3212 char *name, char *binding_label)
3214 gfc_expr *arg = NULL;
3218 /* The second arg of c_f_pointer and c_f_procpointer determines
3219 the type and kind for the procedure name. */
3220 arg = c->ext.actual->next->expr;
3224 /* Set up the name to have the given symbol's name,
3225 plus the type and kind. */
3226 /* a derived type is marked with the type letter 'u' */
3227 if (arg->ts.type == BT_DERIVED)
3230 kind = 0; /* set the kind as 0 for now */
3234 type = gfc_type_letter (arg->ts.type);
3235 kind = arg->ts.kind;
3238 if (arg->ts.type == BT_CHARACTER)
3239 /* Kind info for character strings not needed. */
3242 sprintf (name, "%s_%c%d", sym->name, type, kind);
3243 /* Set up the binding label as the given symbol's label plus
3244 the type and kind. */
3245 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
3249 /* If the second arg is missing, set the name and label as
3250 was, cause it should at least be found, and the missing
3251 arg error will be caught by compare_parameters(). */
3252 sprintf (name, "%s", sym->name);
3253 sprintf (binding_label, "%s", sym->binding_label);
3260 /* Resolve a generic version of the iso_c_binding procedure given
3261 (sym) to the specific one based on the type and kind of the
3262 argument(s). Currently, this function resolves c_f_pointer() and
3263 c_f_procpointer based on the type and kind of the second argument
3264 (FPTR). Other iso_c_binding procedures aren't specially handled.
3265 Upon successfully exiting, c->resolved_sym will hold the resolved
3266 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3270 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3272 gfc_symbol *new_sym;
3273 /* this is fine, since we know the names won't use the max */
3274 char name[GFC_MAX_SYMBOL_LEN + 1];
3275 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
3276 /* default to success; will override if find error */
3277 match m = MATCH_YES;
3279 /* Make sure the actual arguments are in the necessary order (based on the
3280 formal args) before resolving. */
3281 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3283 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3284 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3286 set_name_and_label (c, sym, name, binding_label);
3288 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3290 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3292 /* Make sure we got a third arg if the second arg has non-zero
3293 rank. We must also check that the type and rank are
3294 correct since we short-circuit this check in
3295 gfc_procedure_use() (called above to sort actual args). */
3296 if (c->ext.actual->next->expr->rank != 0)
3298 if(c->ext.actual->next->next == NULL
3299 || c->ext.actual->next->next->expr == NULL)
3302 gfc_error ("Missing SHAPE parameter for call to %s "
3303 "at %L", sym->name, &(c->loc));
3305 else if (c->ext.actual->next->next->expr->ts.type
3307 || c->ext.actual->next->next->expr->rank != 1)
3310 gfc_error ("SHAPE parameter for call to %s at %L must "
3311 "be a rank 1 INTEGER array", sym->name,
3318 if (m != MATCH_ERROR)
3320 /* the 1 means to add the optional arg to formal list */
3321 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3323 /* for error reporting, say it's declared where the original was */
3324 new_sym->declared_at = sym->declared_at;
3329 /* no differences for c_loc or c_funloc */
3333 /* set the resolved symbol */
3334 if (m != MATCH_ERROR)
3335 c->resolved_sym = new_sym;
3337 c->resolved_sym = sym;
3343 /* Resolve a subroutine call known to be specific. */
3346 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3350 if(sym->attr.is_iso_c)
3352 m = gfc_iso_c_sub_interface (c,sym);
3356 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3358 if (sym->attr.dummy)
3360 sym->attr.proc = PROC_DUMMY;
3364 sym->attr.proc = PROC_EXTERNAL;
3368 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3371 if (sym->attr.intrinsic)
3373 m = gfc_intrinsic_sub_interface (c, 1);
3377 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3378 "with an intrinsic", sym->name, &c->loc);
3386 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3388 c->resolved_sym = sym;
3389 pure_subroutine (c, sym);
3396 resolve_specific_s (gfc_code *c)
3401 sym = c->symtree->n.sym;
3405 m = resolve_specific_s0 (c, sym);
3408 if (m == MATCH_ERROR)
3411 if (sym->ns->parent == NULL)
3414 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3420 sym = c->symtree->n.sym;
3421 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3422 sym->name, &c->loc);
3428 /* Resolve a subroutine call not known to be generic nor specific. */
3431 resolve_unknown_s (gfc_code *c)
3435 sym = c->symtree->n.sym;
3437 if (sym->attr.dummy)
3439 sym->attr.proc = PROC_DUMMY;
3443 /* See if we have an intrinsic function reference. */
3445 if (gfc_is_intrinsic (sym, 1, c->loc))
3447 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3452 /* The reference is to an external name. */
3455 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3457 c->resolved_sym = sym;
3459 pure_subroutine (c, sym);
3465 /* Resolve a subroutine call. Although it was tempting to use the same code
3466 for functions, subroutines and functions are stored differently and this
3467 makes things awkward. */
3470 resolve_call (gfc_code *c)
3473 procedure_type ptype = PROC_INTRINSIC;
3474 gfc_symbol *csym, *sym;
3475 bool no_formal_args;
3477 csym = c->symtree ? c->symtree->n.sym : NULL;
3479 if (csym && csym->ts.type != BT_UNKNOWN)
3481 gfc_error ("'%s' at %L has a type, which is not consistent with "
3482 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3486 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3489 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3490 sym = st ? st->n.sym : NULL;
3491 if (sym && csym != sym
3492 && sym->ns == gfc_current_ns
3493 && sym->attr.flavor == FL_PROCEDURE
3494 && sym->attr.contained)
3497 if (csym->attr.generic)
3498 c->symtree->n.sym = sym;
3501 csym = c->symtree->n.sym;
3505 /* If this ia a deferred TBP with an abstract interface
3506 (which may of course be referenced), c->expr1 will be set. */
3507 if (csym && csym->attr.abstract && !c->expr1)
3509 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3510 csym->name, &c->loc);
3514 /* Subroutines without the RECURSIVE attribution are not allowed to
3515 * call themselves. */
3516 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3518 if (csym->attr.entry && csym->ns->entries)
3519 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3520 " subroutine '%s' is not RECURSIVE",
3521 csym->name, &c->loc, csym->ns->entries->sym->name);
3523 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3524 " is not RECURSIVE", csym->name, &c->loc);
3529 /* Switch off assumed size checking and do this again for certain kinds
3530 of procedure, once the procedure itself is resolved. */
3531 need_full_assumed_size++;
3534 ptype = csym->attr.proc;
3536 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3537 if (resolve_actual_arglist (c->ext.actual, ptype,
3538 no_formal_args) == FAILURE)
3541 /* Resume assumed_size checking. */
3542 need_full_assumed_size--;
3544 /* If external, check for usage. */
3545 if (csym && is_external_proc (csym))
3546 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3549 if (c->resolved_sym == NULL)
3551 c->resolved_isym = NULL;
3552 switch (procedure_kind (csym))
3555 t = resolve_generic_s (c);
3558 case PTYPE_SPECIFIC:
3559 t = resolve_specific_s (c);
3563 t = resolve_unknown_s (c);
3567 gfc_internal_error ("resolve_subroutine(): bad function type");
3571 /* Some checks of elemental subroutine actual arguments. */
3572 if (resolve_elemental_actual (NULL, c) == FAILURE)
3579 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3580 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3581 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3582 if their shapes do not match. If either op1->shape or op2->shape is
3583 NULL, return SUCCESS. */
3586 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3593 if (op1->shape != NULL && op2->shape != NULL)
3595 for (i = 0; i < op1->rank; i++)
3597 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3599 gfc_error ("Shapes for operands at %L and %L are not conformable",
3600 &op1->where, &op2->where);
3611 /* Resolve an operator expression node. This can involve replacing the
3612 operation with a user defined function call. */
3615 resolve_operator (gfc_expr *e)
3617 gfc_expr *op1, *op2;
3619 bool dual_locus_error;
3622 /* Resolve all subnodes-- give them types. */
3624 switch (e->value.op.op)
3627 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3630 /* Fall through... */
3633 case INTRINSIC_UPLUS:
3634 case INTRINSIC_UMINUS:
3635 case INTRINSIC_PARENTHESES:
3636 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3641 /* Typecheck the new node. */
3643 op1 = e->value.op.op1;
3644 op2 = e->value.op.op2;
3645 dual_locus_error = false;
3647 if ((op1 && op1->expr_type == EXPR_NULL)
3648 || (op2 && op2->expr_type == EXPR_NULL))
3650 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3654 switch (e->value.op.op)
3656 case INTRINSIC_UPLUS:
3657 case INTRINSIC_UMINUS:
3658 if (op1->ts.type == BT_INTEGER
3659 || op1->ts.type == BT_REAL
3660 || op1->ts.type == BT_COMPLEX)
3666 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3667 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3670 case INTRINSIC_PLUS:
3671 case INTRINSIC_MINUS:
3672 case INTRINSIC_TIMES:
3673 case INTRINSIC_DIVIDE:
3674 case INTRINSIC_POWER:
3675 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3677 gfc_type_convert_binary (e, 1);
3682 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3683 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3684 gfc_typename (&op2->ts));
3687 case INTRINSIC_CONCAT:
3688 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3689 && op1->ts.kind == op2->ts.kind)
3691 e->ts.type = BT_CHARACTER;
3692 e->ts.kind = op1->ts.kind;
3697 _("Operands of string concatenation operator at %%L are %s/%s"),
3698 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3704 case INTRINSIC_NEQV:
3705 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3707 e->ts.type = BT_LOGICAL;
3708 e->ts.kind = gfc_kind_max (op1, op2);
3709 if (op1->ts.kind < e->ts.kind)
3710 gfc_convert_type (op1, &e->ts, 2);
3711 else if (op2->ts.kind < e->ts.kind)
3712 gfc_convert_type (op2, &e->ts, 2);
3716 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3717 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3718 gfc_typename (&op2->ts));
3723 if (op1->ts.type == BT_LOGICAL)
3725 e->ts.type = BT_LOGICAL;
3726 e->ts.kind = op1->ts.kind;
3730 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3731 gfc_typename (&op1->ts));
3735 case INTRINSIC_GT_OS:
3737 case INTRINSIC_GE_OS:
3739 case INTRINSIC_LT_OS:
3741 case INTRINSIC_LE_OS:
3742 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3744 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3748 /* Fall through... */
3751 case INTRINSIC_EQ_OS:
3753 case INTRINSIC_NE_OS:
3754 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3755 && op1->ts.kind == op2->ts.kind)
3757 e->ts.type = BT_LOGICAL;
3758 e->ts.kind = gfc_default_logical_kind;
3762 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3764 gfc_type_convert_binary (e, 1);
3766 e->ts.type = BT_LOGICAL;
3767 e->ts.kind = gfc_default_logical_kind;
3771 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3773 _("Logicals at %%L must be compared with %s instead of %s"),
3774 (e->value.op.op == INTRINSIC_EQ
3775 || e->value.op.op == INTRINSIC_EQ_OS)
3776 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3779 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3780 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3781 gfc_typename (&op2->ts));
3785 case INTRINSIC_USER:
3786 if (e->value.op.uop->op == NULL)
3787 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3788 else if (op2 == NULL)
3789 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3790 e->value.op.uop->name, gfc_typename (&op1->ts));
3792 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3793 e->value.op.uop->name, gfc_typename (&op1->ts),
3794 gfc_typename (&op2->ts));
3798 case INTRINSIC_PARENTHESES:
3800 if (e->ts.type == BT_CHARACTER)
3801 e->ts.u.cl = op1->ts.u.cl;
3805 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3808 /* Deal with arrayness of an operand through an operator. */
3812 switch (e->value.op.op)
3814 case INTRINSIC_PLUS:
3815 case INTRINSIC_MINUS:
3816 case INTRINSIC_TIMES:
3817 case INTRINSIC_DIVIDE:
3818 case INTRINSIC_POWER:
3819 case INTRINSIC_CONCAT:
3823 case INTRINSIC_NEQV:
3825 case INTRINSIC_EQ_OS:
3827 case INTRINSIC_NE_OS:
3829 case INTRINSIC_GT_OS:
3831 case INTRINSIC_GE_OS:
3833 case INTRINSIC_LT_OS:
3835 case INTRINSIC_LE_OS:
3837 if (op1->rank == 0 && op2->rank == 0)
3840 if (op1->rank == 0 && op2->rank != 0)
3842 e->rank = op2->rank;
3844 if (e->shape == NULL)
3845 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3848 if (op1->rank != 0 && op2->rank == 0)
3850 e->rank = op1->rank;
3852 if (e->shape == NULL)
3853 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3856 if (op1->rank != 0 && op2->rank != 0)
3858 if (op1->rank == op2->rank)
3860 e->rank = op1->rank;
3861 if (e->shape == NULL)
3863 t = compare_shapes (op1, op2);
3867 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3872 /* Allow higher level expressions to work. */
3875 /* Try user-defined operators, and otherwise throw an error. */
3876 dual_locus_error = true;
3878 _("Inconsistent ranks for operator at %%L and %%L"));
3885 case INTRINSIC_PARENTHESES:
3887 case INTRINSIC_UPLUS:
3888 case INTRINSIC_UMINUS:
3889 /* Simply copy arrayness attribute */
3890 e->rank = op1->rank;
3892 if (e->shape == NULL)
3893 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3901 /* Attempt to simplify the expression. */
3904 t = gfc_simplify_expr (e, 0);
3905 /* Some calls do not succeed in simplification and return FAILURE
3906 even though there is no error; e.g. variable references to
3907 PARAMETER arrays. */
3908 if (!gfc_is_constant_expr (e))
3917 if (gfc_extend_expr (e, &real_error) == SUCCESS)
3924 if (dual_locus_error)
3925 gfc_error (msg, &op1->where, &op2->where);
3927 gfc_error (msg, &e->where);
3933 /************** Array resolution subroutines **************/
3936 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3939 /* Compare two integer expressions. */
3942 compare_bound (gfc_expr *a, gfc_expr *b)
3946 if (a == NULL || a->expr_type != EXPR_CONSTANT
3947 || b == NULL || b->expr_type != EXPR_CONSTANT)
3950 /* If either of the types isn't INTEGER, we must have
3951 raised an error earlier. */
3953 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3956 i = mpz_cmp (a->value.integer, b->value.integer);
3966 /* Compare an integer expression with an integer. */
3969 compare_bound_int (gfc_expr *a, int b)
3973 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3976 if (a->ts.type != BT_INTEGER)
3977 gfc_internal_error ("compare_bound_int(): Bad expression");
3979 i = mpz_cmp_si (a->value.integer, b);
3989 /* Compare an integer expression with a mpz_t. */
3992 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3996 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3999 if (a->ts.type != BT_INTEGER)
4000 gfc_internal_error ("compare_bound_int(): Bad expression");
4002 i = mpz_cmp (a->value.integer, b);
4012 /* Compute the last value of a sequence given by a triplet.
4013 Return 0 if it wasn't able to compute the last value, or if the
4014 sequence if empty, and 1 otherwise. */
4017 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4018 gfc_expr *stride, mpz_t last)
4022 if (start == NULL || start->expr_type != EXPR_CONSTANT
4023 || end == NULL || end->expr_type != EXPR_CONSTANT
4024 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4027 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4028 || (stride != NULL && stride->ts.type != BT_INTEGER))
4031 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
4033 if (compare_bound (start, end) == CMP_GT)
4035 mpz_set (last, end->value.integer);
4039 if (compare_bound_int (stride, 0) == CMP_GT)
4041 /* Stride is positive */
4042 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4047 /* Stride is negative */
4048 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4053 mpz_sub (rem, end->value.integer, start->value.integer);
4054 mpz_tdiv_r (rem, rem, stride->value.integer);
4055 mpz_sub (last, end->value.integer, rem);
4062 /* Compare a single dimension of an array reference to the array
4066 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4070 if (ar->dimen_type[i] == DIMEN_STAR)
4072 gcc_assert (ar->stride[i] == NULL);
4073 /* This implies [*] as [*:] and [*:3] are not possible. */
4074 if (ar->start[i] == NULL)
4076 gcc_assert (ar->end[i] == NULL);
4081 /* Given start, end and stride values, calculate the minimum and
4082 maximum referenced indexes. */
4084 switch (ar->dimen_type[i])
4091 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4094 gfc_warning ("Array reference at %L is out of bounds "
4095 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4096 mpz_get_si (ar->start[i]->value.integer),
4097 mpz_get_si (as->lower[i]->value.integer), i+1);
4099 gfc_warning ("Array reference at %L is out of bounds "
4100 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4101 mpz_get_si (ar->start[i]->value.integer),
4102 mpz_get_si (as->lower[i]->value.integer),
4106 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4109 gfc_warning ("Array reference at %L is out of bounds "
4110 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4111 mpz_get_si (ar->start[i]->value.integer),
4112 mpz_get_si (as->upper[i]->value.integer), i+1);
4114 gfc_warning ("Array reference at %L is out of bounds "
4115 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4116 mpz_get_si (ar->start[i]->value.integer),
4117 mpz_get_si (as->upper[i]->value.integer),
4126 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4127 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4129 comparison comp_start_end = compare_bound (AR_START, AR_END);
4131 /* Check for zero stride, which is not allowed. */
4132 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4134 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4138 /* if start == len || (stride > 0 && start < len)
4139 || (stride < 0 && start > len),
4140 then the array section contains at least one element. In this
4141 case, there is an out-of-bounds access if
4142 (start < lower || start > upper). */
4143 if (compare_bound (AR_START, AR_END) == CMP_EQ
4144 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4145 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4146 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4147 && comp_start_end == CMP_GT))
4149 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4151 gfc_warning ("Lower array reference at %L is out of bounds "
4152 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4153 mpz_get_si (AR_START->value.integer),
4154 mpz_get_si (as->lower[i]->value.integer), i+1);
4157 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4159 gfc_warning ("Lower array reference at %L is out of bounds "
4160 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4161 mpz_get_si (AR_START->value.integer),
4162 mpz_get_si (as->upper[i]->value.integer), i+1);
4167 /* If we can compute the highest index of the array section,
4168 then it also has to be between lower and upper. */
4169 mpz_init (last_value);
4170 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4173 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4175 gfc_warning ("Upper array reference at %L is out of bounds "
4176 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4177 mpz_get_si (last_value),
4178 mpz_get_si (as->lower[i]->value.integer), i+1);
4179 mpz_clear (last_value);
4182 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4184 gfc_warning ("Upper array reference at %L is out of bounds "
4185 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4186 mpz_get_si (last_value),
4187 mpz_get_si (as->upper[i]->value.integer), i+1);
4188 mpz_clear (last_value);
4192 mpz_clear (last_value);
4200 gfc_internal_error ("check_dimension(): Bad array reference");
4207 /* Compare an array reference with an array specification. */
4210 compare_spec_to_ref (gfc_array_ref *ar)
4217 /* TODO: Full array sections are only allowed as actual parameters. */
4218 if (as->type == AS_ASSUMED_SIZE
4219 && (/*ar->type == AR_FULL
4220 ||*/ (ar->type == AR_SECTION
4221 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4223 gfc_error ("Rightmost upper bound of assumed size array section "
4224 "not specified at %L", &ar->where);
4228 if (ar->type == AR_FULL)
4231 if (as->rank != ar->dimen)
4233 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4234 &ar->where, ar->dimen, as->rank);
4238 /* ar->codimen == 0 is a local array. */
4239 if (as->corank != ar->codimen && ar->codimen != 0)
4241 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4242 &ar->where, ar->codimen, as->corank);
4246 for (i = 0; i < as->rank; i++)
4247 if (check_dimension (i, ar, as) == FAILURE)
4250 /* Local access has no coarray spec. */
4251 if (ar->codimen != 0)
4252 for (i = as->rank; i < as->rank + as->corank; i++)
4254 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
4256 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4257 i + 1 - as->rank, &ar->where);
4260 if (check_dimension (i, ar, as) == FAILURE)
4268 /* Resolve one part of an array index. */
4271 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4272 int force_index_integer_kind)
4279 if (gfc_resolve_expr (index) == FAILURE)
4282 if (check_scalar && index->rank != 0)
4284 gfc_error ("Array index at %L must be scalar", &index->where);
4288 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4290 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4291 &index->where, gfc_basic_typename (index->ts.type));
4295 if (index->ts.type == BT_REAL)
4296 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
4297 &index->where) == FAILURE)
4300 if ((index->ts.kind != gfc_index_integer_kind
4301 && force_index_integer_kind)
4302 || index->ts.type != BT_INTEGER)
4305 ts.type = BT_INTEGER;
4306 ts.kind = gfc_index_integer_kind;
4308 gfc_convert_type_warn (index, &ts, 2, 0);
4314 /* Resolve one part of an array index. */
4317 gfc_resolve_index (gfc_expr *index, int check_scalar)
4319 return gfc_resolve_index_1 (index, check_scalar, 1);
4322 /* Resolve a dim argument to an intrinsic function. */
4325 gfc_resolve_dim_arg (gfc_expr *dim)
4330 if (gfc_resolve_expr (dim) == FAILURE)
4335 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4340 if (dim->ts.type != BT_INTEGER)
4342 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4346 if (dim->ts.kind != gfc_index_integer_kind)
4351 ts.type = BT_INTEGER;
4352 ts.kind = gfc_index_integer_kind;
4354 gfc_convert_type_warn (dim, &ts, 2, 0);
4360 /* Given an expression that contains array references, update those array
4361 references to point to the right array specifications. While this is
4362 filled in during matching, this information is difficult to save and load
4363 in a module, so we take care of it here.
4365 The idea here is that the original array reference comes from the
4366 base symbol. We traverse the list of reference structures, setting
4367 the stored reference to references. Component references can
4368 provide an additional array specification. */
4371 find_array_spec (gfc_expr *e)
4375 gfc_symbol *derived;
4378 if (e->symtree->n.sym->ts.type == BT_CLASS)
4379 as = CLASS_DATA (e->symtree->n.sym)->as;
4381 as = e->symtree->n.sym->as;
4384 for (ref = e->ref; ref; ref = ref->next)
4389 gfc_internal_error ("find_array_spec(): Missing spec");
4396 if (derived == NULL)
4397 derived = e->symtree->n.sym->ts.u.derived;
4399 if (derived->attr.is_class)
4400 derived = derived->components->ts.u.derived;
4402 c = derived->components;
4404 for (; c; c = c->next)
4405 if (c == ref->u.c.component)
4407 /* Track the sequence of component references. */
4408 if (c->ts.type == BT_DERIVED)
4409 derived = c->ts.u.derived;
4414 gfc_internal_error ("find_array_spec(): Component not found");
4416 if (c->attr.dimension)
4419 gfc_internal_error ("find_array_spec(): unused as(1)");
4430 gfc_internal_error ("find_array_spec(): unused as(2)");
4434 /* Resolve an array reference. */
4437 resolve_array_ref (gfc_array_ref *ar)
4439 int i, check_scalar;
4442 for (i = 0; i < ar->dimen + ar->codimen; i++)
4444 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4446 /* Do not force gfc_index_integer_kind for the start. We can
4447 do fine with any integer kind. This avoids temporary arrays
4448 created for indexing with a vector. */
4449 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4451 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4453 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4458 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4462 ar->dimen_type[i] = DIMEN_ELEMENT;
4466 ar->dimen_type[i] = DIMEN_VECTOR;
4467 if (e->expr_type == EXPR_VARIABLE
4468 && e->symtree->n.sym->ts.type == BT_DERIVED)
4469 ar->start[i] = gfc_get_parentheses (e);
4473 gfc_error ("Array index at %L is an array of rank %d",
4474 &ar->c_where[i], e->rank);
4478 /* Fill in the upper bound, which may be lower than the
4479 specified one for something like a(2:10:5), which is
4480 identical to a(2:7:5). Only relevant for strides not equal
4482 if (ar->dimen_type[i] == DIMEN_RANGE
4483 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4484 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0)
4488 if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4490 if (ar->end[i] == NULL)
4493 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4495 mpz_set (ar->end[i]->value.integer, end);
4497 else if (ar->end[i]->ts.type == BT_INTEGER
4498 && ar->end[i]->expr_type == EXPR_CONSTANT)
4500 mpz_set (ar->end[i]->value.integer, end);
4511 if (ar->type == AR_FULL && ar->as->rank == 0)
4512 ar->type = AR_ELEMENT;
4514 /* If the reference type is unknown, figure out what kind it is. */
4516 if (ar->type == AR_UNKNOWN)
4518 ar->type = AR_ELEMENT;
4519 for (i = 0; i < ar->dimen; i++)
4520 if (ar->dimen_type[i] == DIMEN_RANGE
4521 || ar->dimen_type[i] == DIMEN_VECTOR)
4523 ar->type = AR_SECTION;
4528 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4536 resolve_substring (gfc_ref *ref)
4538 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4540 if (ref->u.ss.start != NULL)
4542 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4545 if (ref->u.ss.start->ts.type != BT_INTEGER)
4547 gfc_error ("Substring start index at %L must be of type INTEGER",
4548 &ref->u.ss.start->where);
4552 if (ref->u.ss.start->rank != 0)
4554 gfc_error ("Substring start index at %L must be scalar",
4555 &ref->u.ss.start->where);
4559 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4560 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4561 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4563 gfc_error ("Substring start index at %L is less than one",
4564 &ref->u.ss.start->where);
4569 if (ref->u.ss.end != NULL)
4571 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4574 if (ref->u.ss.end->ts.type != BT_INTEGER)
4576 gfc_error ("Substring end index at %L must be of type INTEGER",
4577 &ref->u.ss.end->where);
4581 if (ref->u.ss.end->rank != 0)
4583 gfc_error ("Substring end index at %L must be scalar",
4584 &ref->u.ss.end->where);
4588 if (ref->u.ss.length != NULL
4589 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4590 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4591 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4593 gfc_error ("Substring end index at %L exceeds the string length",
4594 &ref->u.ss.start->where);
4598 if (compare_bound_mpz_t (ref->u.ss.end,
4599 gfc_integer_kinds[k].huge) == CMP_GT
4600 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4601 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4603 gfc_error ("Substring end index at %L is too large",
4604 &ref->u.ss.end->where);
4613 /* This function supplies missing substring charlens. */
4616 gfc_resolve_substring_charlen (gfc_expr *e)
4619 gfc_expr *start, *end;
4621 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4622 if (char_ref->type == REF_SUBSTRING)
4628 gcc_assert (char_ref->next == NULL);
4632 if (e->ts.u.cl->length)
4633 gfc_free_expr (e->ts.u.cl->length);
4634 else if (e->expr_type == EXPR_VARIABLE
4635 && e->symtree->n.sym->attr.dummy)
4639 e->ts.type = BT_CHARACTER;
4640 e->ts.kind = gfc_default_character_kind;
4643 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4645 if (char_ref->u.ss.start)
4646 start = gfc_copy_expr (char_ref->u.ss.start);
4648 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4650 if (char_ref->u.ss.end)
4651 end = gfc_copy_expr (char_ref->u.ss.end);
4652 else if (e->expr_type == EXPR_VARIABLE)
4653 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4660 /* Length = (end - start +1). */
4661 e->ts.u.cl->length = gfc_subtract (end, start);
4662 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4663 gfc_get_int_expr (gfc_default_integer_kind,
4666 e->ts.u.cl->length->ts.type = BT_INTEGER;
4667 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4669 /* Make sure that the length is simplified. */
4670 gfc_simplify_expr (e->ts.u.cl->length, 1);
4671 gfc_resolve_expr (e->ts.u.cl->length);
4675 /* Resolve subtype references. */
4678 resolve_ref (gfc_expr *expr)
4680 int current_part_dimension, n_components, seen_part_dimension;
4683 for (ref = expr->ref; ref; ref = ref->next)
4684 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4686 find_array_spec (expr);
4690 for (ref = expr->ref; ref; ref = ref->next)
4694 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4702 resolve_substring (ref);
4706 /* Check constraints on part references. */
4708 current_part_dimension = 0;
4709 seen_part_dimension = 0;
4712 for (ref = expr->ref; ref; ref = ref->next)
4717 switch (ref->u.ar.type)
4720 /* Coarray scalar. */
4721 if (ref->u.ar.as->rank == 0)
4723 current_part_dimension = 0;
4728 current_part_dimension = 1;
4732 current_part_dimension = 0;
4736 gfc_internal_error ("resolve_ref(): Bad array reference");
4742 if (current_part_dimension || seen_part_dimension)
4745 if (ref->u.c.component->attr.pointer
4746 || ref->u.c.component->attr.proc_pointer)
4748 gfc_error ("Component to the right of a part reference "
4749 "with nonzero rank must not have the POINTER "
4750 "attribute at %L", &expr->where);
4753 else if (ref->u.c.component->attr.allocatable)
4755 gfc_error ("Component to the right of a part reference "
4756 "with nonzero rank must not have the ALLOCATABLE "
4757 "attribute at %L", &expr->where);
4769 if (((ref->type == REF_COMPONENT && n_components > 1)
4770 || ref->next == NULL)
4771 && current_part_dimension
4772 && seen_part_dimension)
4774 gfc_error ("Two or more part references with nonzero rank must "
4775 "not be specified at %L", &expr->where);
4779 if (ref->type == REF_COMPONENT)
4781 if (current_part_dimension)
4782 seen_part_dimension = 1;
4784 /* reset to make sure */
4785 current_part_dimension = 0;
4793 /* Given an expression, determine its shape. This is easier than it sounds.
4794 Leaves the shape array NULL if it is not possible to determine the shape. */
4797 expression_shape (gfc_expr *e)
4799 mpz_t array[GFC_MAX_DIMENSIONS];
4802 if (e->rank == 0 || e->shape != NULL)
4805 for (i = 0; i < e->rank; i++)
4806 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4809 e->shape = gfc_get_shape (e->rank);
4811 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4816 for (i--; i >= 0; i--)
4817 mpz_clear (array[i]);
4821 /* Given a variable expression node, compute the rank of the expression by
4822 examining the base symbol and any reference structures it may have. */
4825 expression_rank (gfc_expr *e)
4830 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4831 could lead to serious confusion... */
4832 gcc_assert (e->expr_type != EXPR_COMPCALL);
4836 if (e->expr_type == EXPR_ARRAY)
4838 /* Constructors can have a rank different from one via RESHAPE(). */
4840 if (e->symtree == NULL)
4846 e->rank = (e->symtree->n.sym->as == NULL)
4847 ? 0 : e->symtree->n.sym->as->rank;
4853 for (ref = e->ref; ref; ref = ref->next)
4855 if (ref->type != REF_ARRAY)
4858 if (ref->u.ar.type == AR_FULL)
4860 rank = ref->u.ar.as->rank;
4864 if (ref->u.ar.type == AR_SECTION)
4866 /* Figure out the rank of the section. */
4868 gfc_internal_error ("expression_rank(): Two array specs");
4870 for (i = 0; i < ref->u.ar.dimen; i++)
4871 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4872 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4882 expression_shape (e);
4886 /* Resolve a variable expression. */
4889 resolve_variable (gfc_expr *e)
4896 if (e->symtree == NULL)
4898 sym = e->symtree->n.sym;
4900 /* If this is an associate-name, it may be parsed with an array reference
4901 in error even though the target is scalar. Fail directly in this case. */
4902 if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
4905 /* On the other hand, the parser may not have known this is an array;
4906 in this case, we have to add a FULL reference. */
4907 if (sym->assoc && sym->attr.dimension && !e->ref)
4909 e->ref = gfc_get_ref ();
4910 e->ref->type = REF_ARRAY;
4911 e->ref->u.ar.type = AR_FULL;
4912 e->ref->u.ar.dimen = 0;
4915 if (e->ref && resolve_ref (e) == FAILURE)
4918 if (sym->attr.flavor == FL_PROCEDURE
4919 && (!sym->attr.function
4920 || (sym->attr.function && sym->result
4921 && sym->result->attr.proc_pointer
4922 && !sym->result->attr.function)))
4924 e->ts.type = BT_PROCEDURE;
4925 goto resolve_procedure;
4928 if (sym->ts.type != BT_UNKNOWN)
4929 gfc_variable_attr (e, &e->ts);
4932 /* Must be a simple variable reference. */
4933 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4938 if (check_assumed_size_reference (sym, e))
4941 /* Deal with forward references to entries during resolve_code, to
4942 satisfy, at least partially, 12.5.2.5. */
4943 if (gfc_current_ns->entries
4944 && current_entry_id == sym->entry_id
4947 && cs_base->current->op != EXEC_ENTRY)
4949 gfc_entry_list *entry;
4950 gfc_formal_arglist *formal;
4954 /* If the symbol is a dummy... */
4955 if (sym->attr.dummy && sym->ns == gfc_current_ns)
4957 entry = gfc_current_ns->entries;
4960 /* ...test if the symbol is a parameter of previous entries. */
4961 for (; entry && entry->id <= current_entry_id; entry = entry->next)
4962 for (formal = entry->sym->formal; formal; formal = formal->next)
4964 if (formal->sym && sym->name == formal->sym->name)
4968 /* If it has not been seen as a dummy, this is an error. */
4971 if (specification_expr)
4972 gfc_error ("Variable '%s', used in a specification expression"
4973 ", is referenced at %L before the ENTRY statement "
4974 "in which it is a parameter",
4975 sym->name, &cs_base->current->loc);
4977 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4978 "statement in which it is a parameter",
4979 sym->name, &cs_base->current->loc);
4984 /* Now do the same check on the specification expressions. */
4985 specification_expr = 1;
4986 if (sym->ts.type == BT_CHARACTER
4987 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
4991 for (n = 0; n < sym->as->rank; n++)
4993 specification_expr = 1;
4994 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
4996 specification_expr = 1;
4997 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
5000 specification_expr = 0;
5003 /* Update the symbol's entry level. */
5004 sym->entry_id = current_entry_id + 1;
5007 /* If a symbol has been host_associated mark it. This is used latter,
5008 to identify if aliasing is possible via host association. */
5009 if (sym->attr.flavor == FL_VARIABLE
5010 && gfc_current_ns->parent
5011 && (gfc_current_ns->parent == sym->ns
5012 || (gfc_current_ns->parent->parent
5013 && gfc_current_ns->parent->parent == sym->ns)))
5014 sym->attr.host_assoc = 1;
5017 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
5020 /* F2008, C617 and C1229. */
5021 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5022 && gfc_is_coindexed (e))
5024 gfc_ref *ref, *ref2 = NULL;
5026 if (e->ts.type == BT_CLASS)
5028 gfc_error ("Polymorphic subobject of coindexed object at %L",
5033 for (ref = e->ref; ref; ref = ref->next)
5035 if (ref->type == REF_COMPONENT)
5037 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5041 for ( ; ref; ref = ref->next)
5042 if (ref->type == REF_COMPONENT)
5045 /* Expression itself is coindexed object. */
5049 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5050 for ( ; c; c = c->next)
5051 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5053 gfc_error ("Coindexed object with polymorphic allocatable "
5054 "subcomponent at %L", &e->where);
5065 /* Checks to see that the correct symbol has been host associated.
5066 The only situation where this arises is that in which a twice
5067 contained function is parsed after the host association is made.
5068 Therefore, on detecting this, change the symbol in the expression
5069 and convert the array reference into an actual arglist if the old
5070 symbol is a variable. */
5072 check_host_association (gfc_expr *e)
5074 gfc_symbol *sym, *old_sym;
5078 gfc_actual_arglist *arg, *tail = NULL;
5079 bool retval = e->expr_type == EXPR_FUNCTION;
5081 /* If the expression is the result of substitution in
5082 interface.c(gfc_extend_expr) because there is no way in
5083 which the host association can be wrong. */
5084 if (e->symtree == NULL
5085 || e->symtree->n.sym == NULL
5086 || e->user_operator)
5089 old_sym = e->symtree->n.sym;
5091 if (gfc_current_ns->parent
5092 && old_sym->ns != gfc_current_ns)
5094 /* Use the 'USE' name so that renamed module symbols are
5095 correctly handled. */
5096 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5098 if (sym && old_sym != sym
5099 && sym->ts.type == old_sym->ts.type
5100 && sym->attr.flavor == FL_PROCEDURE
5101 && sym->attr.contained)
5103 /* Clear the shape, since it might not be valid. */
5104 if (e->shape != NULL)
5106 for (n = 0; n < e->rank; n++)
5107 mpz_clear (e->shape[n]);
5109 gfc_free (e->shape);
5112 /* Give the expression the right symtree! */
5113 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5114 gcc_assert (st != NULL);
5116 if (old_sym->attr.flavor == FL_PROCEDURE
5117 || e->expr_type == EXPR_FUNCTION)
5119 /* Original was function so point to the new symbol, since
5120 the actual argument list is already attached to the
5122 e->value.function.esym = NULL;
5127 /* Original was variable so convert array references into
5128 an actual arglist. This does not need any checking now
5129 since gfc_resolve_function will take care of it. */
5130 e->value.function.actual = NULL;
5131 e->expr_type = EXPR_FUNCTION;
5134 /* Ambiguity will not arise if the array reference is not
5135 the last reference. */
5136 for (ref = e->ref; ref; ref = ref->next)
5137 if (ref->type == REF_ARRAY && ref->next == NULL)
5140 gcc_assert (ref->type == REF_ARRAY);
5142 /* Grab the start expressions from the array ref and
5143 copy them into actual arguments. */
5144 for (n = 0; n < ref->u.ar.dimen; n++)
5146 arg = gfc_get_actual_arglist ();
5147 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5148 if (e->value.function.actual == NULL)
5149 tail = e->value.function.actual = arg;
5157 /* Dump the reference list and set the rank. */
5158 gfc_free_ref_list (e->ref);
5160 e->rank = sym->as ? sym->as->rank : 0;
5163 gfc_resolve_expr (e);
5167 /* This might have changed! */
5168 return e->expr_type == EXPR_FUNCTION;
5173 gfc_resolve_character_operator (gfc_expr *e)
5175 gfc_expr *op1 = e->value.op.op1;
5176 gfc_expr *op2 = e->value.op.op2;
5177 gfc_expr *e1 = NULL;
5178 gfc_expr *e2 = NULL;
5180 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5182 if (op1->ts.u.cl && op1->ts.u.cl->length)
5183 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5184 else if (op1->expr_type == EXPR_CONSTANT)
5185 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5186 op1->value.character.length);
5188 if (op2->ts.u.cl && op2->ts.u.cl->length)
5189 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5190 else if (op2->expr_type == EXPR_CONSTANT)
5191 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5192 op2->value.character.length);
5194 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5199 e->ts.u.cl->length = gfc_add (e1, e2);
5200 e->ts.u.cl->length->ts.type = BT_INTEGER;
5201 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5202 gfc_simplify_expr (e->ts.u.cl->length, 0);
5203 gfc_resolve_expr (e->ts.u.cl->length);
5209 /* Ensure that an character expression has a charlen and, if possible, a
5210 length expression. */
5213 fixup_charlen (gfc_expr *e)
5215 /* The cases fall through so that changes in expression type and the need
5216 for multiple fixes are picked up. In all circumstances, a charlen should
5217 be available for the middle end to hang a backend_decl on. */
5218 switch (e->expr_type)
5221 gfc_resolve_character_operator (e);
5224 if (e->expr_type == EXPR_ARRAY)
5225 gfc_resolve_character_array_constructor (e);
5227 case EXPR_SUBSTRING:
5228 if (!e->ts.u.cl && e->ref)
5229 gfc_resolve_substring_charlen (e);
5233 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5240 /* Update an actual argument to include the passed-object for type-bound
5241 procedures at the right position. */
5243 static gfc_actual_arglist*
5244 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5247 gcc_assert (argpos > 0);
5251 gfc_actual_arglist* result;
5253 result = gfc_get_actual_arglist ();
5257 result->name = name;
5263 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5265 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5270 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5273 extract_compcall_passed_object (gfc_expr* e)
5277 gcc_assert (e->expr_type == EXPR_COMPCALL);
5279 if (e->value.compcall.base_object)
5280 po = gfc_copy_expr (e->value.compcall.base_object);
5283 po = gfc_get_expr ();
5284 po->expr_type = EXPR_VARIABLE;
5285 po->symtree = e->symtree;
5286 po->ref = gfc_copy_ref (e->ref);
5287 po->where = e->where;
5290 if (gfc_resolve_expr (po) == FAILURE)
5297 /* Update the arglist of an EXPR_COMPCALL expression to include the
5301 update_compcall_arglist (gfc_expr* e)
5304 gfc_typebound_proc* tbp;
5306 tbp = e->value.compcall.tbp;
5311 po = extract_compcall_passed_object (e);
5315 if (tbp->nopass || e->value.compcall.ignore_pass)
5321 gcc_assert (tbp->pass_arg_num > 0);
5322 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5330 /* Extract the passed object from a PPC call (a copy of it). */
5333 extract_ppc_passed_object (gfc_expr *e)
5338 po = gfc_get_expr ();
5339 po->expr_type = EXPR_VARIABLE;
5340 po->symtree = e->symtree;
5341 po->ref = gfc_copy_ref (e->ref);
5342 po->where = e->where;
5344 /* Remove PPC reference. */
5346 while ((*ref)->next)
5347 ref = &(*ref)->next;
5348 gfc_free_ref_list (*ref);
5351 if (gfc_resolve_expr (po) == FAILURE)
5358 /* Update the actual arglist of a procedure pointer component to include the
5362 update_ppc_arglist (gfc_expr* e)
5366 gfc_typebound_proc* tb;
5368 if (!gfc_is_proc_ptr_comp (e, &ppc))
5375 else if (tb->nopass)
5378 po = extract_ppc_passed_object (e);
5384 gfc_error ("Passed-object at %L must be scalar", &e->where);
5388 gcc_assert (tb->pass_arg_num > 0);
5389 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5397 /* Check that the object a TBP is called on is valid, i.e. it must not be
5398 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5401 check_typebound_baseobject (gfc_expr* e)
5405 base = extract_compcall_passed_object (e);
5409 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5411 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5413 gfc_error ("Base object for type-bound procedure call at %L is of"
5414 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5418 /* If the procedure called is NOPASS, the base object must be scalar. */
5419 if (e->value.compcall.tbp->nopass && base->rank > 0)
5421 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5422 " be scalar", &e->where);
5426 /* FIXME: Remove once PR 41177 (this problem) is fixed completely. */
5429 gfc_error ("Non-scalar base object at %L currently not implemented",
5438 /* Resolve a call to a type-bound procedure, either function or subroutine,
5439 statically from the data in an EXPR_COMPCALL expression. The adapted
5440 arglist and the target-procedure symtree are returned. */
5443 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5444 gfc_actual_arglist** actual)
5446 gcc_assert (e->expr_type == EXPR_COMPCALL);
5447 gcc_assert (!e->value.compcall.tbp->is_generic);
5449 /* Update the actual arglist for PASS. */
5450 if (update_compcall_arglist (e) == FAILURE)
5453 *actual = e->value.compcall.actual;
5454 *target = e->value.compcall.tbp->u.specific;
5456 gfc_free_ref_list (e->ref);
5458 e->value.compcall.actual = NULL;
5464 /* Get the ultimate declared type from an expression. In addition,
5465 return the last class/derived type reference and the copy of the
5468 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5471 gfc_symbol *declared;
5478 *new_ref = gfc_copy_ref (e->ref);
5480 for (ref = e->ref; ref; ref = ref->next)
5482 if (ref->type != REF_COMPONENT)
5485 if (ref->u.c.component->ts.type == BT_CLASS
5486 || ref->u.c.component->ts.type == BT_DERIVED)
5488 declared = ref->u.c.component->ts.u.derived;
5494 if (declared == NULL)
5495 declared = e->symtree->n.sym->ts.u.derived;
5501 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5502 which of the specific bindings (if any) matches the arglist and transform
5503 the expression into a call of that binding. */
5506 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5508 gfc_typebound_proc* genproc;
5509 const char* genname;
5511 gfc_symbol *derived;
5513 gcc_assert (e->expr_type == EXPR_COMPCALL);
5514 genname = e->value.compcall.name;
5515 genproc = e->value.compcall.tbp;
5517 if (!genproc->is_generic)
5520 /* Try the bindings on this type and in the inheritance hierarchy. */
5521 for (; genproc; genproc = genproc->overridden)
5525 gcc_assert (genproc->is_generic);
5526 for (g = genproc->u.generic; g; g = g->next)
5529 gfc_actual_arglist* args;
5532 gcc_assert (g->specific);
5534 if (g->specific->error)
5537 target = g->specific->u.specific->n.sym;
5539 /* Get the right arglist by handling PASS/NOPASS. */
5540 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5541 if (!g->specific->nopass)
5544 po = extract_compcall_passed_object (e);
5548 gcc_assert (g->specific->pass_arg_num > 0);
5549 gcc_assert (!g->specific->error);
5550 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5551 g->specific->pass_arg);
5553 resolve_actual_arglist (args, target->attr.proc,
5554 is_external_proc (target) && !target->formal);
5556 /* Check if this arglist matches the formal. */
5557 matches = gfc_arglist_matches_symbol (&args, target);
5559 /* Clean up and break out of the loop if we've found it. */
5560 gfc_free_actual_arglist (args);
5563 e->value.compcall.tbp = g->specific;
5564 genname = g->specific_st->name;
5565 /* Pass along the name for CLASS methods, where the vtab
5566 procedure pointer component has to be referenced. */
5574 /* Nothing matching found! */
5575 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5576 " '%s' at %L", genname, &e->where);
5580 /* Make sure that we have the right specific instance for the name. */
5581 derived = get_declared_from_expr (NULL, NULL, e);
5583 st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where);
5585 e->value.compcall.tbp = st->n.tb;
5591 /* Resolve a call to a type-bound subroutine. */
5594 resolve_typebound_call (gfc_code* c, const char **name)
5596 gfc_actual_arglist* newactual;
5597 gfc_symtree* target;
5599 /* Check that's really a SUBROUTINE. */
5600 if (!c->expr1->value.compcall.tbp->subroutine)
5602 gfc_error ("'%s' at %L should be a SUBROUTINE",
5603 c->expr1->value.compcall.name, &c->loc);
5607 if (check_typebound_baseobject (c->expr1) == FAILURE)
5610 /* Pass along the name for CLASS methods, where the vtab
5611 procedure pointer component has to be referenced. */
5613 *name = c->expr1->value.compcall.name;
5615 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5618 /* Transform into an ordinary EXEC_CALL for now. */
5620 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5623 c->ext.actual = newactual;
5624 c->symtree = target;
5625 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5627 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5629 gfc_free_expr (c->expr1);
5630 c->expr1 = gfc_get_expr ();
5631 c->expr1->expr_type = EXPR_FUNCTION;
5632 c->expr1->symtree = target;
5633 c->expr1->where = c->loc;
5635 return resolve_call (c);
5639 /* Resolve a component-call expression. */
5641 resolve_compcall (gfc_expr* e, const char **name)
5643 gfc_actual_arglist* newactual;
5644 gfc_symtree* target;
5646 /* Check that's really a FUNCTION. */
5647 if (!e->value.compcall.tbp->function)
5649 gfc_error ("'%s' at %L should be a FUNCTION",
5650 e->value.compcall.name, &e->where);
5654 /* These must not be assign-calls! */
5655 gcc_assert (!e->value.compcall.assign);
5657 if (check_typebound_baseobject (e) == FAILURE)
5660 /* Pass along the name for CLASS methods, where the vtab
5661 procedure pointer component has to be referenced. */
5663 *name = e->value.compcall.name;
5665 if (resolve_typebound_generic_call (e, name) == FAILURE)
5667 gcc_assert (!e->value.compcall.tbp->is_generic);
5669 /* Take the rank from the function's symbol. */
5670 if (e->value.compcall.tbp->u.specific->n.sym->as)
5671 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5673 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5674 arglist to the TBP's binding target. */
5676 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5679 e->value.function.actual = newactual;
5680 e->value.function.name = NULL;
5681 e->value.function.esym = target->n.sym;
5682 e->value.function.isym = NULL;
5683 e->symtree = target;
5684 e->ts = target->n.sym->ts;
5685 e->expr_type = EXPR_FUNCTION;
5687 /* Resolution is not necessary if this is a class subroutine; this
5688 function only has to identify the specific proc. Resolution of
5689 the call will be done next in resolve_typebound_call. */
5690 return gfc_resolve_expr (e);
5695 /* Resolve a typebound function, or 'method'. First separate all
5696 the non-CLASS references by calling resolve_compcall directly. */
5699 resolve_typebound_function (gfc_expr* e)
5701 gfc_symbol *declared;
5712 /* Deal with typebound operators for CLASS objects. */
5713 expr = e->value.compcall.base_object;
5714 if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
5715 && e->value.compcall.name)
5717 /* Since the typebound operators are generic, we have to ensure
5718 that any delays in resolution are corrected and that the vtab
5720 ts = expr->symtree->n.sym->ts;
5721 declared = ts.u.derived;
5722 c = gfc_find_component (declared, "$vptr", true, true);
5723 if (c->ts.u.derived == NULL)
5724 c->ts.u.derived = gfc_find_derived_vtab (declared);
5726 if (resolve_compcall (e, &name) == FAILURE)
5729 /* Use the generic name if it is there. */
5730 name = name ? name : e->value.function.esym->name;
5731 e->symtree = expr->symtree;
5732 expr->symtree->n.sym->ts.u.derived = declared;
5733 gfc_add_component_ref (e, "$vptr");
5734 gfc_add_component_ref (e, name);
5735 e->value.function.esym = NULL;
5740 return resolve_compcall (e, NULL);
5742 if (resolve_ref (e) == FAILURE)
5745 /* Get the CLASS declared type. */
5746 declared = get_declared_from_expr (&class_ref, &new_ref, e);
5748 /* Weed out cases of the ultimate component being a derived type. */
5749 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5750 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5752 gfc_free_ref_list (new_ref);
5753 return resolve_compcall (e, NULL);
5756 c = gfc_find_component (declared, "$data", true, true);
5757 declared = c->ts.u.derived;
5759 /* Treat the call as if it is a typebound procedure, in order to roll
5760 out the correct name for the specific function. */
5761 if (resolve_compcall (e, &name) == FAILURE)
5765 /* Then convert the expression to a procedure pointer component call. */
5766 e->value.function.esym = NULL;
5772 /* '$vptr' points to the vtab, which contains the procedure pointers. */
5773 gfc_add_component_ref (e, "$vptr");
5774 gfc_add_component_ref (e, name);
5776 /* Recover the typespec for the expression. This is really only
5777 necessary for generic procedures, where the additional call
5778 to gfc_add_component_ref seems to throw the collection of the
5779 correct typespec. */
5784 /* Resolve a typebound subroutine, or 'method'. First separate all
5785 the non-CLASS references by calling resolve_typebound_call
5789 resolve_typebound_subroutine (gfc_code *code)
5791 gfc_symbol *declared;
5800 st = code->expr1->symtree;
5802 /* Deal with typebound operators for CLASS objects. */
5803 expr = code->expr1->value.compcall.base_object;
5804 if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
5805 && code->expr1->value.compcall.name)
5807 /* Since the typebound operators are generic, we have to ensure
5808 that any delays in resolution are corrected and that the vtab
5810 ts = expr->symtree->n.sym->ts;
5811 declared = ts.u.derived;
5812 c = gfc_find_component (declared, "$vptr", true, true);
5813 if (c->ts.u.derived == NULL)
5814 c->ts.u.derived = gfc_find_derived_vtab (declared);
5816 if (resolve_typebound_call (code, &name) == FAILURE)
5819 /* Use the generic name if it is there. */
5820 name = name ? name : code->expr1->value.function.esym->name;
5821 code->expr1->symtree = expr->symtree;
5822 expr->symtree->n.sym->ts.u.derived = declared;
5823 gfc_add_component_ref (code->expr1, "$vptr");
5824 gfc_add_component_ref (code->expr1, name);
5825 code->expr1->value.function.esym = NULL;
5830 return resolve_typebound_call (code, NULL);
5832 if (resolve_ref (code->expr1) == FAILURE)
5835 /* Get the CLASS declared type. */
5836 get_declared_from_expr (&class_ref, &new_ref, code->expr1);
5838 /* Weed out cases of the ultimate component being a derived type. */
5839 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5840 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5842 gfc_free_ref_list (new_ref);
5843 return resolve_typebound_call (code, NULL);
5846 if (resolve_typebound_call (code, &name) == FAILURE)
5848 ts = code->expr1->ts;
5850 /* Then convert the expression to a procedure pointer component call. */
5851 code->expr1->value.function.esym = NULL;
5852 code->expr1->symtree = st;
5855 code->expr1->ref = new_ref;
5857 /* '$vptr' points to the vtab, which contains the procedure pointers. */
5858 gfc_add_component_ref (code->expr1, "$vptr");
5859 gfc_add_component_ref (code->expr1, name);
5861 /* Recover the typespec for the expression. This is really only
5862 necessary for generic procedures, where the additional call
5863 to gfc_add_component_ref seems to throw the collection of the
5864 correct typespec. */
5865 code->expr1->ts = ts;
5870 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5873 resolve_ppc_call (gfc_code* c)
5875 gfc_component *comp;
5878 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
5881 c->resolved_sym = c->expr1->symtree->n.sym;
5882 c->expr1->expr_type = EXPR_VARIABLE;
5884 if (!comp->attr.subroutine)
5885 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
5887 if (resolve_ref (c->expr1) == FAILURE)
5890 if (update_ppc_arglist (c->expr1) == FAILURE)
5893 c->ext.actual = c->expr1->value.compcall.actual;
5895 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
5896 comp->formal == NULL) == FAILURE)
5899 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
5905 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5908 resolve_expr_ppc (gfc_expr* e)
5910 gfc_component *comp;
5913 b = gfc_is_proc_ptr_comp (e, &comp);
5916 /* Convert to EXPR_FUNCTION. */
5917 e->expr_type = EXPR_FUNCTION;
5918 e->value.function.isym = NULL;
5919 e->value.function.actual = e->value.compcall.actual;
5921 if (comp->as != NULL)
5922 e->rank = comp->as->rank;
5924 if (!comp->attr.function)
5925 gfc_add_function (&comp->attr, comp->name, &e->where);
5927 if (resolve_ref (e) == FAILURE)
5930 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
5931 comp->formal == NULL) == FAILURE)
5934 if (update_ppc_arglist (e) == FAILURE)
5937 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
5944 gfc_is_expandable_expr (gfc_expr *e)
5946 gfc_constructor *con;
5948 if (e->expr_type == EXPR_ARRAY)
5950 /* Traverse the constructor looking for variables that are flavor
5951 parameter. Parameters must be expanded since they are fully used at
5953 con = gfc_constructor_first (e->value.constructor);
5954 for (; con; con = gfc_constructor_next (con))
5956 if (con->expr->expr_type == EXPR_VARIABLE
5957 && con->expr->symtree
5958 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
5959 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
5961 if (con->expr->expr_type == EXPR_ARRAY
5962 && gfc_is_expandable_expr (con->expr))
5970 /* Resolve an expression. That is, make sure that types of operands agree
5971 with their operators, intrinsic operators are converted to function calls
5972 for overloaded types and unresolved function references are resolved. */
5975 gfc_resolve_expr (gfc_expr *e)
5983 /* inquiry_argument only applies to variables. */
5984 inquiry_save = inquiry_argument;
5985 if (e->expr_type != EXPR_VARIABLE)
5986 inquiry_argument = false;
5988 switch (e->expr_type)
5991 t = resolve_operator (e);
5997 if (check_host_association (e))
5998 t = resolve_function (e);
6001 t = resolve_variable (e);
6003 expression_rank (e);
6006 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6007 && e->ref->type != REF_SUBSTRING)
6008 gfc_resolve_substring_charlen (e);
6013 t = resolve_typebound_function (e);
6016 case EXPR_SUBSTRING:
6017 t = resolve_ref (e);
6026 t = resolve_expr_ppc (e);
6031 if (resolve_ref (e) == FAILURE)
6034 t = gfc_resolve_array_constructor (e);
6035 /* Also try to expand a constructor. */
6038 expression_rank (e);
6039 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6040 gfc_expand_constructor (e, false);
6043 /* This provides the opportunity for the length of constructors with
6044 character valued function elements to propagate the string length
6045 to the expression. */
6046 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6048 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6049 here rather then add a duplicate test for it above. */
6050 gfc_expand_constructor (e, false);
6051 t = gfc_resolve_character_array_constructor (e);
6056 case EXPR_STRUCTURE:
6057 t = resolve_ref (e);
6061 t = resolve_structure_cons (e, 0);
6065 t = gfc_simplify_expr (e, 0);
6069 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6072 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6075 inquiry_argument = inquiry_save;
6081 /* Resolve an expression from an iterator. They must be scalar and have
6082 INTEGER or (optionally) REAL type. */
6085 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6086 const char *name_msgid)
6088 if (gfc_resolve_expr (expr) == FAILURE)
6091 if (expr->rank != 0)
6093 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6097 if (expr->ts.type != BT_INTEGER)
6099 if (expr->ts.type == BT_REAL)
6102 return gfc_notify_std (GFC_STD_F95_DEL,
6103 "Deleted feature: %s at %L must be integer",
6104 _(name_msgid), &expr->where);
6107 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6114 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6122 /* Resolve the expressions in an iterator structure. If REAL_OK is
6123 false allow only INTEGER type iterators, otherwise allow REAL types. */
6126 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6128 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6132 if (gfc_check_vardef_context (iter->var, false, _("iterator variable"))
6136 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6137 "Start expression in DO loop") == FAILURE)
6140 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6141 "End expression in DO loop") == FAILURE)
6144 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6145 "Step expression in DO loop") == FAILURE)
6148 if (iter->step->expr_type == EXPR_CONSTANT)
6150 if ((iter->step->ts.type == BT_INTEGER
6151 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6152 || (iter->step->ts.type == BT_REAL
6153 && mpfr_sgn (iter->step->value.real) == 0))
6155 gfc_error ("Step expression in DO loop at %L cannot be zero",
6156 &iter->step->where);
6161 /* Convert start, end, and step to the same type as var. */
6162 if (iter->start->ts.kind != iter->var->ts.kind
6163 || iter->start->ts.type != iter->var->ts.type)
6164 gfc_convert_type (iter->start, &iter->var->ts, 2);
6166 if (iter->end->ts.kind != iter->var->ts.kind
6167 || iter->end->ts.type != iter->var->ts.type)
6168 gfc_convert_type (iter->end, &iter->var->ts, 2);
6170 if (iter->step->ts.kind != iter->var->ts.kind
6171 || iter->step->ts.type != iter->var->ts.type)
6172 gfc_convert_type (iter->step, &iter->var->ts, 2);
6174 if (iter->start->expr_type == EXPR_CONSTANT
6175 && iter->end->expr_type == EXPR_CONSTANT
6176 && iter->step->expr_type == EXPR_CONSTANT)
6179 if (iter->start->ts.type == BT_INTEGER)
6181 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6182 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6186 sgn = mpfr_sgn (iter->step->value.real);
6187 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6189 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6190 gfc_warning ("DO loop at %L will be executed zero times",
6191 &iter->step->where);
6198 /* Traversal function for find_forall_index. f == 2 signals that
6199 that variable itself is not to be checked - only the references. */
6202 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6204 if (expr->expr_type != EXPR_VARIABLE)
6207 /* A scalar assignment */
6208 if (!expr->ref || *f == 1)
6210 if (expr->symtree->n.sym == sym)
6222 /* Check whether the FORALL index appears in the expression or not.
6223 Returns SUCCESS if SYM is found in EXPR. */
6226 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6228 if (gfc_traverse_expr (expr, sym, forall_index, f))
6235 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6236 to be a scalar INTEGER variable. The subscripts and stride are scalar
6237 INTEGERs, and if stride is a constant it must be nonzero.
6238 Furthermore "A subscript or stride in a forall-triplet-spec shall
6239 not contain a reference to any index-name in the
6240 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6243 resolve_forall_iterators (gfc_forall_iterator *it)
6245 gfc_forall_iterator *iter, *iter2;
6247 for (iter = it; iter; iter = iter->next)
6249 if (gfc_resolve_expr (iter->var) == SUCCESS
6250 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6251 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6254 if (gfc_resolve_expr (iter->start) == SUCCESS
6255 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6256 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6257 &iter->start->where);
6258 if (iter->var->ts.kind != iter->start->ts.kind)
6259 gfc_convert_type (iter->start, &iter->var->ts, 2);
6261 if (gfc_resolve_expr (iter->end) == SUCCESS
6262 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6263 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6265 if (iter->var->ts.kind != iter->end->ts.kind)
6266 gfc_convert_type (iter->end, &iter->var->ts, 2);
6268 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6270 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6271 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6272 &iter->stride->where, "INTEGER");
6274 if (iter->stride->expr_type == EXPR_CONSTANT
6275 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6276 gfc_error ("FORALL stride expression at %L cannot be zero",
6277 &iter->stride->where);
6279 if (iter->var->ts.kind != iter->stride->ts.kind)
6280 gfc_convert_type (iter->stride, &iter->var->ts, 2);
6283 for (iter = it; iter; iter = iter->next)
6284 for (iter2 = iter; iter2; iter2 = iter2->next)
6286 if (find_forall_index (iter2->start,
6287 iter->var->symtree->n.sym, 0) == SUCCESS
6288 || find_forall_index (iter2->end,
6289 iter->var->symtree->n.sym, 0) == SUCCESS
6290 || find_forall_index (iter2->stride,
6291 iter->var->symtree->n.sym, 0) == SUCCESS)
6292 gfc_error ("FORALL index '%s' may not appear in triplet "
6293 "specification at %L", iter->var->symtree->name,
6294 &iter2->start->where);
6299 /* Given a pointer to a symbol that is a derived type, see if it's
6300 inaccessible, i.e. if it's defined in another module and the components are
6301 PRIVATE. The search is recursive if necessary. Returns zero if no
6302 inaccessible components are found, nonzero otherwise. */
6305 derived_inaccessible (gfc_symbol *sym)
6309 if (sym->attr.use_assoc && sym->attr.private_comp)
6312 for (c = sym->components; c; c = c->next)
6314 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6322 /* Resolve the argument of a deallocate expression. The expression must be
6323 a pointer or a full array. */
6326 resolve_deallocate_expr (gfc_expr *e)
6328 symbol_attribute attr;
6329 int allocatable, pointer;
6334 if (gfc_resolve_expr (e) == FAILURE)
6337 if (e->expr_type != EXPR_VARIABLE)
6340 sym = e->symtree->n.sym;
6342 if (sym->ts.type == BT_CLASS)
6344 allocatable = CLASS_DATA (sym)->attr.allocatable;
6345 pointer = CLASS_DATA (sym)->attr.class_pointer;
6349 allocatable = sym->attr.allocatable;
6350 pointer = sym->attr.pointer;
6352 for (ref = e->ref; ref; ref = ref->next)
6357 if (ref->u.ar.type != AR_FULL)
6362 c = ref->u.c.component;
6363 if (c->ts.type == BT_CLASS)
6365 allocatable = CLASS_DATA (c)->attr.allocatable;
6366 pointer = CLASS_DATA (c)->attr.class_pointer;
6370 allocatable = c->attr.allocatable;
6371 pointer = c->attr.pointer;
6381 attr = gfc_expr_attr (e);
6383 if (allocatable == 0 && attr.pointer == 0)
6386 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6392 && gfc_check_vardef_context (e, true, _("DEALLOCATE object")) == FAILURE)
6394 if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE)
6397 if (e->ts.type == BT_CLASS)
6399 /* Only deallocate the DATA component. */
6400 gfc_add_component_ref (e, "$data");
6407 /* Returns true if the expression e contains a reference to the symbol sym. */
6409 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6411 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6418 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6420 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6424 /* Given the expression node e for an allocatable/pointer of derived type to be
6425 allocated, get the expression node to be initialized afterwards (needed for
6426 derived types with default initializers, and derived types with allocatable
6427 components that need nullification.) */
6430 gfc_expr_to_initialize (gfc_expr *e)
6436 result = gfc_copy_expr (e);
6438 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6439 for (ref = result->ref; ref; ref = ref->next)
6440 if (ref->type == REF_ARRAY && ref->next == NULL)
6442 ref->u.ar.type = AR_FULL;
6444 for (i = 0; i < ref->u.ar.dimen; i++)
6445 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6447 result->rank = ref->u.ar.dimen;
6455 /* If the last ref of an expression is an array ref, return a copy of the
6456 expression with that one removed. Otherwise, a copy of the original
6457 expression. This is used for allocate-expressions and pointer assignment
6458 LHS, where there may be an array specification that needs to be stripped
6459 off when using gfc_check_vardef_context. */
6462 remove_last_array_ref (gfc_expr* e)
6467 e2 = gfc_copy_expr (e);
6468 for (r = &e2->ref; *r; r = &(*r)->next)
6469 if ((*r)->type == REF_ARRAY && !(*r)->next)
6471 gfc_free_ref_list (*r);
6480 /* Used in resolve_allocate_expr to check that a allocation-object and
6481 a source-expr are conformable. This does not catch all possible
6482 cases; in particular a runtime checking is needed. */
6485 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6488 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6490 /* First compare rank. */
6491 if (tail && e1->rank != tail->u.ar.as->rank)
6493 gfc_error ("Source-expr at %L must be scalar or have the "
6494 "same rank as the allocate-object at %L",
6495 &e1->where, &e2->where);
6506 for (i = 0; i < e1->rank; i++)
6508 if (tail->u.ar.end[i])
6510 mpz_set (s, tail->u.ar.end[i]->value.integer);
6511 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6512 mpz_add_ui (s, s, 1);
6516 mpz_set (s, tail->u.ar.start[i]->value.integer);
6519 if (mpz_cmp (e1->shape[i], s) != 0)
6521 gfc_error ("Source-expr at %L and allocate-object at %L must "
6522 "have the same shape", &e1->where, &e2->where);
6535 /* Resolve the expression in an ALLOCATE statement, doing the additional
6536 checks to see whether the expression is OK or not. The expression must
6537 have a trailing array reference that gives the size of the array. */
6540 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6542 int i, pointer, allocatable, dimension, is_abstract;
6544 symbol_attribute attr;
6545 gfc_ref *ref, *ref2;
6548 gfc_symbol *sym = NULL;
6553 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6554 checking of coarrays. */
6555 for (ref = e->ref; ref; ref = ref->next)
6556 if (ref->next == NULL)
6559 if (ref && ref->type == REF_ARRAY)
6560 ref->u.ar.in_allocate = true;
6562 if (gfc_resolve_expr (e) == FAILURE)
6565 /* Make sure the expression is allocatable or a pointer. If it is
6566 pointer, the next-to-last reference must be a pointer. */
6570 sym = e->symtree->n.sym;
6572 /* Check whether ultimate component is abstract and CLASS. */
6575 if (e->expr_type != EXPR_VARIABLE)
6578 attr = gfc_expr_attr (e);
6579 pointer = attr.pointer;
6580 dimension = attr.dimension;
6581 codimension = attr.codimension;
6585 if (sym->ts.type == BT_CLASS)
6587 allocatable = CLASS_DATA (sym)->attr.allocatable;
6588 pointer = CLASS_DATA (sym)->attr.class_pointer;
6589 dimension = CLASS_DATA (sym)->attr.dimension;
6590 codimension = CLASS_DATA (sym)->attr.codimension;
6591 is_abstract = CLASS_DATA (sym)->attr.abstract;
6595 allocatable = sym->attr.allocatable;
6596 pointer = sym->attr.pointer;
6597 dimension = sym->attr.dimension;
6598 codimension = sym->attr.codimension;
6601 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6606 if (ref->next != NULL)
6612 if (gfc_is_coindexed (e))
6614 gfc_error ("Coindexed allocatable object at %L",
6619 c = ref->u.c.component;
6620 if (c->ts.type == BT_CLASS)
6622 allocatable = CLASS_DATA (c)->attr.allocatable;
6623 pointer = CLASS_DATA (c)->attr.class_pointer;
6624 dimension = CLASS_DATA (c)->attr.dimension;
6625 codimension = CLASS_DATA (c)->attr.codimension;
6626 is_abstract = CLASS_DATA (c)->attr.abstract;
6630 allocatable = c->attr.allocatable;
6631 pointer = c->attr.pointer;
6632 dimension = c->attr.dimension;
6633 codimension = c->attr.codimension;
6634 is_abstract = c->attr.abstract;
6646 if (allocatable == 0 && pointer == 0)
6648 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6653 /* Some checks for the SOURCE tag. */
6656 /* Check F03:C631. */
6657 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6659 gfc_error ("Type of entity at %L is type incompatible with "
6660 "source-expr at %L", &e->where, &code->expr3->where);
6664 /* Check F03:C632 and restriction following Note 6.18. */
6665 if (code->expr3->rank > 0
6666 && conformable_arrays (code->expr3, e) == FAILURE)
6669 /* Check F03:C633. */
6670 if (code->expr3->ts.kind != e->ts.kind)
6672 gfc_error ("The allocate-object at %L and the source-expr at %L "
6673 "shall have the same kind type parameter",
6674 &e->where, &code->expr3->where);
6679 /* Check F08:C629. */
6680 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
6683 gcc_assert (e->ts.type == BT_CLASS);
6684 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6685 "type-spec or source-expr", sym->name, &e->where);
6689 /* In the variable definition context checks, gfc_expr_attr is used
6690 on the expression. This is fooled by the array specification
6691 present in e, thus we have to eliminate that one temporarily. */
6692 e2 = remove_last_array_ref (e);
6694 if (t == SUCCESS && pointer)
6695 t = gfc_check_vardef_context (e2, true, _("ALLOCATE object"));
6697 t = gfc_check_vardef_context (e2, false, _("ALLOCATE object"));
6704 /* Set up default initializer if needed. */
6707 if (code->ext.alloc.ts.type == BT_DERIVED)
6708 ts = code->ext.alloc.ts;
6712 if (ts.type == BT_CLASS)
6713 ts = ts.u.derived->components->ts;
6715 if (ts.type == BT_DERIVED && gfc_has_default_initializer(ts.u.derived))
6717 gfc_expr *init_e = gfc_default_initializer (&ts);
6718 gfc_code *init_st = gfc_get_code ();
6719 init_st->loc = code->loc;
6720 init_st->op = EXEC_INIT_ASSIGN;
6721 init_st->expr1 = gfc_expr_to_initialize (e);
6722 init_st->expr2 = init_e;
6723 init_st->next = code->next;
6724 code->next = init_st;
6727 else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
6729 /* Default initialization via MOLD (non-polymorphic). */
6730 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
6731 gfc_resolve_expr (rhs);
6732 gfc_free_expr (code->expr3);
6736 if (e->ts.type == BT_CLASS)
6738 /* Make sure the vtab symbol is present when
6739 the module variables are generated. */
6740 gfc_typespec ts = e->ts;
6742 ts = code->expr3->ts;
6743 else if (code->ext.alloc.ts.type == BT_DERIVED)
6744 ts = code->ext.alloc.ts;
6745 gfc_find_derived_vtab (ts.u.derived);
6748 if (pointer || (dimension == 0 && codimension == 0))
6751 /* Make sure the last reference node is an array specifiction. */
6753 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
6754 || (dimension && ref2->u.ar.dimen == 0))
6756 gfc_error ("Array specification required in ALLOCATE statement "
6757 "at %L", &e->where);
6761 /* Make sure that the array section reference makes sense in the
6762 context of an ALLOCATE specification. */
6766 if (codimension && ar->codimen == 0)
6768 gfc_error ("Coarray specification required in ALLOCATE statement "
6769 "at %L", &e->where);
6773 for (i = 0; i < ar->dimen; i++)
6775 if (ref2->u.ar.type == AR_ELEMENT)
6778 switch (ar->dimen_type[i])
6784 if (ar->start[i] != NULL
6785 && ar->end[i] != NULL
6786 && ar->stride[i] == NULL)
6789 /* Fall Through... */
6794 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6800 for (a = code->ext.alloc.list; a; a = a->next)
6802 sym = a->expr->symtree->n.sym;
6804 /* TODO - check derived type components. */
6805 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6808 if ((ar->start[i] != NULL
6809 && gfc_find_sym_in_expr (sym, ar->start[i]))
6810 || (ar->end[i] != NULL
6811 && gfc_find_sym_in_expr (sym, ar->end[i])))
6813 gfc_error ("'%s' must not appear in the array specification at "
6814 "%L in the same ALLOCATE statement where it is "
6815 "itself allocated", sym->name, &ar->where);
6821 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
6823 if (ar->dimen_type[i] == DIMEN_ELEMENT
6824 || ar->dimen_type[i] == DIMEN_RANGE)
6826 if (i == (ar->dimen + ar->codimen - 1))
6828 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
6829 "statement at %L", &e->where);
6835 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
6836 && ar->stride[i] == NULL)
6839 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
6844 if (codimension && ar->as->rank == 0)
6846 gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
6847 "at %L", &e->where);
6859 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
6861 gfc_expr *stat, *errmsg, *pe, *qe;
6862 gfc_alloc *a, *p, *q;
6865 errmsg = code->expr2;
6867 /* Check the stat variable. */
6870 gfc_check_vardef_context (stat, false, _("STAT variable"));
6872 if ((stat->ts.type != BT_INTEGER
6873 && !(stat->ref && (stat->ref->type == REF_ARRAY
6874 || stat->ref->type == REF_COMPONENT)))
6876 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
6877 "variable", &stat->where);
6879 for (p = code->ext.alloc.list; p; p = p->next)
6880 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
6882 gfc_ref *ref1, *ref2;
6885 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
6886 ref1 = ref1->next, ref2 = ref2->next)
6888 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6890 if (ref1->u.c.component->name != ref2->u.c.component->name)
6899 gfc_error ("Stat-variable at %L shall not be %sd within "
6900 "the same %s statement", &stat->where, fcn, fcn);
6906 /* Check the errmsg variable. */
6910 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
6913 gfc_check_vardef_context (errmsg, false, _("ERRMSG variable"));
6915 if ((errmsg->ts.type != BT_CHARACTER
6917 && (errmsg->ref->type == REF_ARRAY
6918 || errmsg->ref->type == REF_COMPONENT)))
6919 || errmsg->rank > 0 )
6920 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
6921 "variable", &errmsg->where);
6923 for (p = code->ext.alloc.list; p; p = p->next)
6924 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
6926 gfc_ref *ref1, *ref2;
6929 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
6930 ref1 = ref1->next, ref2 = ref2->next)
6932 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6934 if (ref1->u.c.component->name != ref2->u.c.component->name)
6943 gfc_error ("Errmsg-variable at %L shall not be %sd within "
6944 "the same %s statement", &errmsg->where, fcn, fcn);
6950 /* Check that an allocate-object appears only once in the statement.
6951 FIXME: Checking derived types is disabled. */
6952 for (p = code->ext.alloc.list; p; p = p->next)
6955 if ((pe->ref && pe->ref->type != REF_COMPONENT)
6956 && (pe->symtree->n.sym->ts.type != BT_DERIVED))
6958 for (q = p->next; q; q = q->next)
6961 if ((qe->ref && qe->ref->type != REF_COMPONENT)
6962 && (qe->symtree->n.sym->ts.type != BT_DERIVED)
6963 && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
6964 gfc_error ("Allocate-object at %L also appears at %L",
6965 &pe->where, &qe->where);
6970 if (strcmp (fcn, "ALLOCATE") == 0)
6972 for (a = code->ext.alloc.list; a; a = a->next)
6973 resolve_allocate_expr (a->expr, code);
6977 for (a = code->ext.alloc.list; a; a = a->next)
6978 resolve_deallocate_expr (a->expr);
6983 /************ SELECT CASE resolution subroutines ************/
6985 /* Callback function for our mergesort variant. Determines interval
6986 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
6987 op1 > op2. Assumes we're not dealing with the default case.
6988 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
6989 There are nine situations to check. */
6992 compare_cases (const gfc_case *op1, const gfc_case *op2)
6996 if (op1->low == NULL) /* op1 = (:L) */
6998 /* op2 = (:N), so overlap. */
7000 /* op2 = (M:) or (M:N), L < M */
7001 if (op2->low != NULL
7002 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7005 else if (op1->high == NULL) /* op1 = (K:) */
7007 /* op2 = (M:), so overlap. */
7009 /* op2 = (:N) or (M:N), K > N */
7010 if (op2->high != NULL
7011 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7014 else /* op1 = (K:L) */
7016 if (op2->low == NULL) /* op2 = (:N), K > N */
7017 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7019 else if (op2->high == NULL) /* op2 = (M:), L < M */
7020 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7022 else /* op2 = (M:N) */
7026 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7029 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7038 /* Merge-sort a double linked case list, detecting overlap in the
7039 process. LIST is the head of the double linked case list before it
7040 is sorted. Returns the head of the sorted list if we don't see any
7041 overlap, or NULL otherwise. */
7044 check_case_overlap (gfc_case *list)
7046 gfc_case *p, *q, *e, *tail;
7047 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7049 /* If the passed list was empty, return immediately. */
7056 /* Loop unconditionally. The only exit from this loop is a return
7057 statement, when we've finished sorting the case list. */
7064 /* Count the number of merges we do in this pass. */
7067 /* Loop while there exists a merge to be done. */
7072 /* Count this merge. */
7075 /* Cut the list in two pieces by stepping INSIZE places
7076 forward in the list, starting from P. */
7079 for (i = 0; i < insize; i++)
7088 /* Now we have two lists. Merge them! */
7089 while (psize > 0 || (qsize > 0 && q != NULL))
7091 /* See from which the next case to merge comes from. */
7094 /* P is empty so the next case must come from Q. */
7099 else if (qsize == 0 || q == NULL)
7108 cmp = compare_cases (p, q);
7111 /* The whole case range for P is less than the
7119 /* The whole case range for Q is greater than
7120 the case range for P. */
7127 /* The cases overlap, or they are the same
7128 element in the list. Either way, we must
7129 issue an error and get the next case from P. */
7130 /* FIXME: Sort P and Q by line number. */
7131 gfc_error ("CASE label at %L overlaps with CASE "
7132 "label at %L", &p->where, &q->where);
7140 /* Add the next element to the merged list. */
7149 /* P has now stepped INSIZE places along, and so has Q. So
7150 they're the same. */
7155 /* If we have done only one merge or none at all, we've
7156 finished sorting the cases. */
7165 /* Otherwise repeat, merging lists twice the size. */
7171 /* Check to see if an expression is suitable for use in a CASE statement.
7172 Makes sure that all case expressions are scalar constants of the same
7173 type. Return FAILURE if anything is wrong. */
7176 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7178 if (e == NULL) return SUCCESS;
7180 if (e->ts.type != case_expr->ts.type)
7182 gfc_error ("Expression in CASE statement at %L must be of type %s",
7183 &e->where, gfc_basic_typename (case_expr->ts.type));
7187 /* C805 (R808) For a given case-construct, each case-value shall be of
7188 the same type as case-expr. For character type, length differences
7189 are allowed, but the kind type parameters shall be the same. */
7191 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7193 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7194 &e->where, case_expr->ts.kind);
7198 /* Convert the case value kind to that of case expression kind,
7201 if (e->ts.kind != case_expr->ts.kind)
7202 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7206 gfc_error ("Expression in CASE statement at %L must be scalar",
7215 /* Given a completely parsed select statement, we:
7217 - Validate all expressions and code within the SELECT.
7218 - Make sure that the selection expression is not of the wrong type.
7219 - Make sure that no case ranges overlap.
7220 - Eliminate unreachable cases and unreachable code resulting from
7221 removing case labels.
7223 The standard does allow unreachable cases, e.g. CASE (5:3). But
7224 they are a hassle for code generation, and to prevent that, we just
7225 cut them out here. This is not necessary for overlapping cases
7226 because they are illegal and we never even try to generate code.
7228 We have the additional caveat that a SELECT construct could have
7229 been a computed GOTO in the source code. Fortunately we can fairly
7230 easily work around that here: The case_expr for a "real" SELECT CASE
7231 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7232 we have to do is make sure that the case_expr is a scalar integer
7236 resolve_select (gfc_code *code)
7239 gfc_expr *case_expr;
7240 gfc_case *cp, *default_case, *tail, *head;
7241 int seen_unreachable;
7247 if (code->expr1 == NULL)
7249 /* This was actually a computed GOTO statement. */
7250 case_expr = code->expr2;
7251 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7252 gfc_error ("Selection expression in computed GOTO statement "
7253 "at %L must be a scalar integer expression",
7256 /* Further checking is not necessary because this SELECT was built
7257 by the compiler, so it should always be OK. Just move the
7258 case_expr from expr2 to expr so that we can handle computed
7259 GOTOs as normal SELECTs from here on. */
7260 code->expr1 = code->expr2;
7265 case_expr = code->expr1;
7267 type = case_expr->ts.type;
7268 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7270 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7271 &case_expr->where, gfc_typename (&case_expr->ts));
7273 /* Punt. Going on here just produce more garbage error messages. */
7277 if (case_expr->rank != 0)
7279 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7280 "expression", &case_expr->where);
7287 /* Raise a warning if an INTEGER case value exceeds the range of
7288 the case-expr. Later, all expressions will be promoted to the
7289 largest kind of all case-labels. */
7291 if (type == BT_INTEGER)
7292 for (body = code->block; body; body = body->block)
7293 for (cp = body->ext.case_list; cp; cp = cp->next)
7296 && gfc_check_integer_range (cp->low->value.integer,
7297 case_expr->ts.kind) != ARITH_OK)
7298 gfc_warning ("Expression in CASE statement at %L is "
7299 "not in the range of %s", &cp->low->where,
7300 gfc_typename (&case_expr->ts));
7303 && cp->low != cp->high
7304 && gfc_check_integer_range (cp->high->value.integer,
7305 case_expr->ts.kind) != ARITH_OK)
7306 gfc_warning ("Expression in CASE statement at %L is "
7307 "not in the range of %s", &cp->high->where,
7308 gfc_typename (&case_expr->ts));
7311 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7312 of the SELECT CASE expression and its CASE values. Walk the lists
7313 of case values, and if we find a mismatch, promote case_expr to
7314 the appropriate kind. */
7316 if (type == BT_LOGICAL || type == BT_INTEGER)
7318 for (body = code->block; body; body = body->block)
7320 /* Walk the case label list. */
7321 for (cp = body->ext.case_list; cp; cp = cp->next)
7323 /* Intercept the DEFAULT case. It does not have a kind. */
7324 if (cp->low == NULL && cp->high == NULL)
7327 /* Unreachable case ranges are discarded, so ignore. */
7328 if (cp->low != NULL && cp->high != NULL
7329 && cp->low != cp->high
7330 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7334 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7335 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7337 if (cp->high != NULL
7338 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7339 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7344 /* Assume there is no DEFAULT case. */
7345 default_case = NULL;
7350 for (body = code->block; body; body = body->block)
7352 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7354 seen_unreachable = 0;
7356 /* Walk the case label list, making sure that all case labels
7358 for (cp = body->ext.case_list; cp; cp = cp->next)
7360 /* Count the number of cases in the whole construct. */
7363 /* Intercept the DEFAULT case. */
7364 if (cp->low == NULL && cp->high == NULL)
7366 if (default_case != NULL)
7368 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7369 "by a second DEFAULT CASE at %L",
7370 &default_case->where, &cp->where);
7381 /* Deal with single value cases and case ranges. Errors are
7382 issued from the validation function. */
7383 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7384 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7390 if (type == BT_LOGICAL
7391 && ((cp->low == NULL || cp->high == NULL)
7392 || cp->low != cp->high))
7394 gfc_error ("Logical range in CASE statement at %L is not "
7395 "allowed", &cp->low->where);
7400 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7403 value = cp->low->value.logical == 0 ? 2 : 1;
7404 if (value & seen_logical)
7406 gfc_error ("Constant logical value in CASE statement "
7407 "is repeated at %L",
7412 seen_logical |= value;
7415 if (cp->low != NULL && cp->high != NULL
7416 && cp->low != cp->high
7417 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7419 if (gfc_option.warn_surprising)
7420 gfc_warning ("Range specification at %L can never "
7421 "be matched", &cp->where);
7423 cp->unreachable = 1;
7424 seen_unreachable = 1;
7428 /* If the case range can be matched, it can also overlap with
7429 other cases. To make sure it does not, we put it in a
7430 double linked list here. We sort that with a merge sort
7431 later on to detect any overlapping cases. */
7435 head->right = head->left = NULL;
7440 tail->right->left = tail;
7447 /* It there was a failure in the previous case label, give up
7448 for this case label list. Continue with the next block. */
7452 /* See if any case labels that are unreachable have been seen.
7453 If so, we eliminate them. This is a bit of a kludge because
7454 the case lists for a single case statement (label) is a
7455 single forward linked lists. */
7456 if (seen_unreachable)
7458 /* Advance until the first case in the list is reachable. */
7459 while (body->ext.case_list != NULL
7460 && body->ext.case_list->unreachable)
7462 gfc_case *n = body->ext.case_list;
7463 body->ext.case_list = body->ext.case_list->next;
7465 gfc_free_case_list (n);
7468 /* Strip all other unreachable cases. */
7469 if (body->ext.case_list)
7471 for (cp = body->ext.case_list; cp->next; cp = cp->next)
7473 if (cp->next->unreachable)
7475 gfc_case *n = cp->next;
7476 cp->next = cp->next->next;
7478 gfc_free_case_list (n);
7485 /* See if there were overlapping cases. If the check returns NULL,
7486 there was overlap. In that case we don't do anything. If head
7487 is non-NULL, we prepend the DEFAULT case. The sorted list can
7488 then used during code generation for SELECT CASE constructs with
7489 a case expression of a CHARACTER type. */
7492 head = check_case_overlap (head);
7494 /* Prepend the default_case if it is there. */
7495 if (head != NULL && default_case)
7497 default_case->left = NULL;
7498 default_case->right = head;
7499 head->left = default_case;
7503 /* Eliminate dead blocks that may be the result if we've seen
7504 unreachable case labels for a block. */
7505 for (body = code; body && body->block; body = body->block)
7507 if (body->block->ext.case_list == NULL)
7509 /* Cut the unreachable block from the code chain. */
7510 gfc_code *c = body->block;
7511 body->block = c->block;
7513 /* Kill the dead block, but not the blocks below it. */
7515 gfc_free_statements (c);
7519 /* More than two cases is legal but insane for logical selects.
7520 Issue a warning for it. */
7521 if (gfc_option.warn_surprising && type == BT_LOGICAL
7523 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7528 /* Check if a derived type is extensible. */
7531 gfc_type_is_extensible (gfc_symbol *sym)
7533 return !(sym->attr.is_bind_c || sym->attr.sequence);
7537 /* Resolve an associate name: Resolve target and ensure the type-spec is
7538 correct as well as possibly the array-spec. */
7541 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
7545 gcc_assert (sym->assoc);
7546 gcc_assert (sym->attr.flavor == FL_VARIABLE);
7548 /* If this is for SELECT TYPE, the target may not yet be set. In that
7549 case, return. Resolution will be called later manually again when
7551 target = sym->assoc->target;
7554 gcc_assert (!sym->assoc->dangling);
7556 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
7559 /* For variable targets, we get some attributes from the target. */
7560 if (target->expr_type == EXPR_VARIABLE)
7564 gcc_assert (target->symtree);
7565 tsym = target->symtree->n.sym;
7567 sym->attr.asynchronous = tsym->attr.asynchronous;
7568 sym->attr.volatile_ = tsym->attr.volatile_;
7570 sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
7573 sym->ts = target->ts;
7574 gcc_assert (sym->ts.type != BT_UNKNOWN);
7576 /* See if this is a valid association-to-variable. */
7577 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
7578 && !gfc_has_vector_subscript (target));
7580 /* Finally resolve if this is an array or not. */
7581 if (sym->attr.dimension && target->rank == 0)
7583 gfc_error ("Associate-name '%s' at %L is used as array",
7584 sym->name, &sym->declared_at);
7585 sym->attr.dimension = 0;
7588 if (target->rank > 0)
7589 sym->attr.dimension = 1;
7591 if (sym->attr.dimension)
7593 sym->as = gfc_get_array_spec ();
7594 sym->as->rank = target->rank;
7595 sym->as->type = AS_DEFERRED;
7597 /* Target must not be coindexed, thus the associate-variable
7599 sym->as->corank = 0;
7604 /* Resolve a SELECT TYPE statement. */
7607 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
7609 gfc_symbol *selector_type;
7610 gfc_code *body, *new_st, *if_st, *tail;
7611 gfc_code *class_is = NULL, *default_case = NULL;
7614 char name[GFC_MAX_SYMBOL_LEN];
7618 ns = code->ext.block.ns;
7621 /* Check for F03:C813. */
7622 if (code->expr1->ts.type != BT_CLASS
7623 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
7625 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7626 "at %L", &code->loc);
7632 if (code->expr1->symtree->n.sym->attr.untyped)
7633 code->expr1->symtree->n.sym->ts = code->expr2->ts;
7634 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
7637 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
7639 /* Loop over TYPE IS / CLASS IS cases. */
7640 for (body = code->block; body; body = body->block)
7642 c = body->ext.case_list;
7644 /* Check F03:C815. */
7645 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7646 && !gfc_type_is_extensible (c->ts.u.derived))
7648 gfc_error ("Derived type '%s' at %L must be extensible",
7649 c->ts.u.derived->name, &c->where);
7654 /* Check F03:C816. */
7655 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7656 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
7658 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7659 c->ts.u.derived->name, &c->where, selector_type->name);
7664 /* Intercept the DEFAULT case. */
7665 if (c->ts.type == BT_UNKNOWN)
7667 /* Check F03:C818. */
7670 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7671 "by a second DEFAULT CASE at %L",
7672 &default_case->ext.case_list->where, &c->where);
7677 default_case = body;
7684 /* Transform SELECT TYPE statement to BLOCK and associate selector to
7685 target if present. If there are any EXIT statements referring to the
7686 SELECT TYPE construct, this is no problem because the gfc_code
7687 reference stays the same and EXIT is equally possible from the BLOCK
7688 it is changed to. */
7689 code->op = EXEC_BLOCK;
7692 gfc_association_list* assoc;
7694 assoc = gfc_get_association_list ();
7695 assoc->st = code->expr1->symtree;
7696 assoc->target = gfc_copy_expr (code->expr2);
7697 /* assoc->variable will be set by resolve_assoc_var. */
7699 code->ext.block.assoc = assoc;
7700 code->expr1->symtree->n.sym->assoc = assoc;
7702 resolve_assoc_var (code->expr1->symtree->n.sym, false);
7705 code->ext.block.assoc = NULL;
7707 /* Add EXEC_SELECT to switch on type. */
7708 new_st = gfc_get_code ();
7709 new_st->op = code->op;
7710 new_st->expr1 = code->expr1;
7711 new_st->expr2 = code->expr2;
7712 new_st->block = code->block;
7713 code->expr1 = code->expr2 = NULL;
7718 ns->code->next = new_st;
7720 code->op = EXEC_SELECT;
7721 gfc_add_component_ref (code->expr1, "$vptr");
7722 gfc_add_component_ref (code->expr1, "$hash");
7724 /* Loop over TYPE IS / CLASS IS cases. */
7725 for (body = code->block; body; body = body->block)
7727 c = body->ext.case_list;
7729 if (c->ts.type == BT_DERIVED)
7730 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7731 c->ts.u.derived->hash_value);
7733 else if (c->ts.type == BT_UNKNOWN)
7736 /* Associate temporary to selector. This should only be done
7737 when this case is actually true, so build a new ASSOCIATE
7738 that does precisely this here (instead of using the
7741 if (c->ts.type == BT_CLASS)
7742 sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
7744 sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
7745 st = gfc_find_symtree (ns->sym_root, name);
7746 gcc_assert (st->n.sym->assoc);
7747 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
7748 if (c->ts.type == BT_DERIVED)
7749 gfc_add_component_ref (st->n.sym->assoc->target, "$data");
7751 new_st = gfc_get_code ();
7752 new_st->op = EXEC_BLOCK;
7753 new_st->ext.block.ns = gfc_build_block_ns (ns);
7754 new_st->ext.block.ns->code = body->next;
7755 body->next = new_st;
7757 /* Chain in the new list only if it is marked as dangling. Otherwise
7758 there is a CASE label overlap and this is already used. Just ignore,
7759 the error is diagonsed elsewhere. */
7760 if (st->n.sym->assoc->dangling)
7762 new_st->ext.block.assoc = st->n.sym->assoc;
7763 st->n.sym->assoc->dangling = 0;
7766 resolve_assoc_var (st->n.sym, false);
7769 /* Take out CLASS IS cases for separate treatment. */
7771 while (body && body->block)
7773 if (body->block->ext.case_list->ts.type == BT_CLASS)
7775 /* Add to class_is list. */
7776 if (class_is == NULL)
7778 class_is = body->block;
7783 for (tail = class_is; tail->block; tail = tail->block) ;
7784 tail->block = body->block;
7787 /* Remove from EXEC_SELECT list. */
7788 body->block = body->block->block;
7801 /* Add a default case to hold the CLASS IS cases. */
7802 for (tail = code; tail->block; tail = tail->block) ;
7803 tail->block = gfc_get_code ();
7805 tail->op = EXEC_SELECT_TYPE;
7806 tail->ext.case_list = gfc_get_case ();
7807 tail->ext.case_list->ts.type = BT_UNKNOWN;
7809 default_case = tail;
7812 /* More than one CLASS IS block? */
7813 if (class_is->block)
7817 /* Sort CLASS IS blocks by extension level. */
7821 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
7824 /* F03:C817 (check for doubles). */
7825 if ((*c1)->ext.case_list->ts.u.derived->hash_value
7826 == c2->ext.case_list->ts.u.derived->hash_value)
7828 gfc_error ("Double CLASS IS block in SELECT TYPE "
7829 "statement at %L", &c2->ext.case_list->where);
7832 if ((*c1)->ext.case_list->ts.u.derived->attr.extension
7833 < c2->ext.case_list->ts.u.derived->attr.extension)
7836 (*c1)->block = c2->block;
7846 /* Generate IF chain. */
7847 if_st = gfc_get_code ();
7848 if_st->op = EXEC_IF;
7850 for (body = class_is; body; body = body->block)
7852 new_st->block = gfc_get_code ();
7853 new_st = new_st->block;
7854 new_st->op = EXEC_IF;
7855 /* Set up IF condition: Call _gfortran_is_extension_of. */
7856 new_st->expr1 = gfc_get_expr ();
7857 new_st->expr1->expr_type = EXPR_FUNCTION;
7858 new_st->expr1->ts.type = BT_LOGICAL;
7859 new_st->expr1->ts.kind = 4;
7860 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
7861 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
7862 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
7863 /* Set up arguments. */
7864 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
7865 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
7866 gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
7867 vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
7868 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
7869 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
7870 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
7871 new_st->next = body->next;
7873 if (default_case->next)
7875 new_st->block = gfc_get_code ();
7876 new_st = new_st->block;
7877 new_st->op = EXEC_IF;
7878 new_st->next = default_case->next;
7881 /* Replace CLASS DEFAULT code by the IF chain. */
7882 default_case->next = if_st;
7885 /* Resolve the internal code. This can not be done earlier because
7886 it requires that the sym->assoc of selectors is set already. */
7887 gfc_current_ns = ns;
7888 gfc_resolve_blocks (code->block, gfc_current_ns);
7889 gfc_current_ns = old_ns;
7891 resolve_select (code);
7895 /* Resolve a transfer statement. This is making sure that:
7896 -- a derived type being transferred has only non-pointer components
7897 -- a derived type being transferred doesn't have private components, unless
7898 it's being transferred from the module where the type was defined
7899 -- we're not trying to transfer a whole assumed size array. */
7902 resolve_transfer (gfc_code *code)
7911 while (exp != NULL && exp->expr_type == EXPR_OP
7912 && exp->value.op.op == INTRINSIC_PARENTHESES)
7913 exp = exp->value.op.op1;
7915 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
7916 && exp->expr_type != EXPR_FUNCTION))
7919 sym = exp->symtree->n.sym;
7922 /* Go to actual component transferred. */
7923 for (ref = code->expr1->ref; ref; ref = ref->next)
7924 if (ref->type == REF_COMPONENT)
7925 ts = &ref->u.c.component->ts;
7927 if (ts->type == BT_DERIVED)
7929 /* Check that transferred derived type doesn't contain POINTER
7931 if (ts->u.derived->attr.pointer_comp)
7933 gfc_error ("Data transfer element at %L cannot have "
7934 "POINTER components", &code->loc);
7938 if (ts->u.derived->attr.alloc_comp)
7940 gfc_error ("Data transfer element at %L cannot have "
7941 "ALLOCATABLE components", &code->loc);
7945 if (derived_inaccessible (ts->u.derived))
7947 gfc_error ("Data transfer element at %L cannot have "
7948 "PRIVATE components",&code->loc);
7953 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
7954 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
7956 gfc_error ("Data transfer element at %L cannot be a full reference to "
7957 "an assumed-size array", &code->loc);
7963 /*********** Toplevel code resolution subroutines ***********/
7965 /* Find the set of labels that are reachable from this block. We also
7966 record the last statement in each block. */
7969 find_reachable_labels (gfc_code *block)
7976 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
7978 /* Collect labels in this block. We don't keep those corresponding
7979 to END {IF|SELECT}, these are checked in resolve_branch by going
7980 up through the code_stack. */
7981 for (c = block; c; c = c->next)
7983 if (c->here && c->op != EXEC_END_BLOCK)
7984 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
7987 /* Merge with labels from parent block. */
7990 gcc_assert (cs_base->prev->reachable_labels);
7991 bitmap_ior_into (cs_base->reachable_labels,
7992 cs_base->prev->reachable_labels);
7998 resolve_sync (gfc_code *code)
8000 /* Check imageset. The * case matches expr1 == NULL. */
8003 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8004 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8005 "INTEGER expression", &code->expr1->where);
8006 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8007 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8008 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8009 &code->expr1->where);
8010 else if (code->expr1->expr_type == EXPR_ARRAY
8011 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8013 gfc_constructor *cons;
8014 cons = gfc_constructor_first (code->expr1->value.constructor);
8015 for (; cons; cons = gfc_constructor_next (cons))
8016 if (cons->expr->expr_type == EXPR_CONSTANT
8017 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8018 gfc_error ("Imageset argument at %L must between 1 and "
8019 "num_images()", &cons->expr->where);
8025 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8026 || code->expr2->expr_type != EXPR_VARIABLE))
8027 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8028 &code->expr2->where);
8032 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8033 || code->expr3->expr_type != EXPR_VARIABLE))
8034 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8035 &code->expr3->where);
8039 /* Given a branch to a label, see if the branch is conforming.
8040 The code node describes where the branch is located. */
8043 resolve_branch (gfc_st_label *label, gfc_code *code)
8050 /* Step one: is this a valid branching target? */
8052 if (label->defined == ST_LABEL_UNKNOWN)
8054 gfc_error ("Label %d referenced at %L is never defined", label->value,
8059 if (label->defined != ST_LABEL_TARGET)
8061 gfc_error ("Statement at %L is not a valid branch target statement "
8062 "for the branch statement at %L", &label->where, &code->loc);
8066 /* Step two: make sure this branch is not a branch to itself ;-) */
8068 if (code->here == label)
8070 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8074 /* Step three: See if the label is in the same block as the
8075 branching statement. The hard work has been done by setting up
8076 the bitmap reachable_labels. */
8078 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8080 /* Check now whether there is a CRITICAL construct; if so, check
8081 whether the label is still visible outside of the CRITICAL block,
8082 which is invalid. */
8083 for (stack = cs_base; stack; stack = stack->prev)
8084 if (stack->current->op == EXEC_CRITICAL
8085 && bitmap_bit_p (stack->reachable_labels, label->value))
8086 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8087 " at %L", &code->loc, &label->where);
8092 /* Step four: If we haven't found the label in the bitmap, it may
8093 still be the label of the END of the enclosing block, in which
8094 case we find it by going up the code_stack. */
8096 for (stack = cs_base; stack; stack = stack->prev)
8098 if (stack->current->next && stack->current->next->here == label)
8100 if (stack->current->op == EXEC_CRITICAL)
8102 /* Note: A label at END CRITICAL does not leave the CRITICAL
8103 construct as END CRITICAL is still part of it. */
8104 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8105 " at %L", &code->loc, &label->where);
8112 gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
8116 /* The label is not in an enclosing block, so illegal. This was
8117 allowed in Fortran 66, so we allow it as extension. No
8118 further checks are necessary in this case. */
8119 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
8120 "as the GOTO statement at %L", &label->where,
8126 /* Check whether EXPR1 has the same shape as EXPR2. */
8129 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
8131 mpz_t shape[GFC_MAX_DIMENSIONS];
8132 mpz_t shape2[GFC_MAX_DIMENSIONS];
8133 gfc_try result = FAILURE;
8136 /* Compare the rank. */
8137 if (expr1->rank != expr2->rank)
8140 /* Compare the size of each dimension. */
8141 for (i=0; i<expr1->rank; i++)
8143 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
8146 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
8149 if (mpz_cmp (shape[i], shape2[i]))
8153 /* When either of the two expression is an assumed size array, we
8154 ignore the comparison of dimension sizes. */
8159 for (i--; i >= 0; i--)
8161 mpz_clear (shape[i]);
8162 mpz_clear (shape2[i]);
8168 /* Check whether a WHERE assignment target or a WHERE mask expression
8169 has the same shape as the outmost WHERE mask expression. */
8172 resolve_where (gfc_code *code, gfc_expr *mask)
8178 cblock = code->block;
8180 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8181 In case of nested WHERE, only the outmost one is stored. */
8182 if (mask == NULL) /* outmost WHERE */
8184 else /* inner WHERE */
8191 /* Check if the mask-expr has a consistent shape with the
8192 outmost WHERE mask-expr. */
8193 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8194 gfc_error ("WHERE mask at %L has inconsistent shape",
8195 &cblock->expr1->where);
8198 /* the assignment statement of a WHERE statement, or the first
8199 statement in where-body-construct of a WHERE construct */
8200 cnext = cblock->next;
8205 /* WHERE assignment statement */
8208 /* Check shape consistent for WHERE assignment target. */
8209 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8210 gfc_error ("WHERE assignment target at %L has "
8211 "inconsistent shape", &cnext->expr1->where);
8215 case EXEC_ASSIGN_CALL:
8216 resolve_call (cnext);
8217 if (!cnext->resolved_sym->attr.elemental)
8218 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8219 &cnext->ext.actual->expr->where);
8222 /* WHERE or WHERE construct is part of a where-body-construct */
8224 resolve_where (cnext, e);
8228 gfc_error ("Unsupported statement inside WHERE at %L",
8231 /* the next statement within the same where-body-construct */
8232 cnext = cnext->next;
8234 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8235 cblock = cblock->block;
8240 /* Resolve assignment in FORALL construct.
8241 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8242 FORALL index variables. */
8245 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8249 for (n = 0; n < nvar; n++)
8251 gfc_symbol *forall_index;
8253 forall_index = var_expr[n]->symtree->n.sym;
8255 /* Check whether the assignment target is one of the FORALL index
8257 if ((code->expr1->expr_type == EXPR_VARIABLE)
8258 && (code->expr1->symtree->n.sym == forall_index))
8259 gfc_error ("Assignment to a FORALL index variable at %L",
8260 &code->expr1->where);
8263 /* If one of the FORALL index variables doesn't appear in the
8264 assignment variable, then there could be a many-to-one
8265 assignment. Emit a warning rather than an error because the
8266 mask could be resolving this problem. */
8267 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8268 gfc_warning ("The FORALL with index '%s' is not used on the "
8269 "left side of the assignment at %L and so might "
8270 "cause multiple assignment to this object",
8271 var_expr[n]->symtree->name, &code->expr1->where);
8277 /* Resolve WHERE statement in FORALL construct. */
8280 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8281 gfc_expr **var_expr)
8286 cblock = code->block;
8289 /* the assignment statement of a WHERE statement, or the first
8290 statement in where-body-construct of a WHERE construct */
8291 cnext = cblock->next;
8296 /* WHERE assignment statement */
8298 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8301 /* WHERE operator assignment statement */
8302 case EXEC_ASSIGN_CALL:
8303 resolve_call (cnext);
8304 if (!cnext->resolved_sym->attr.elemental)
8305 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8306 &cnext->ext.actual->expr->where);
8309 /* WHERE or WHERE construct is part of a where-body-construct */
8311 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8315 gfc_error ("Unsupported statement inside WHERE at %L",
8318 /* the next statement within the same where-body-construct */
8319 cnext = cnext->next;
8321 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8322 cblock = cblock->block;
8327 /* Traverse the FORALL body to check whether the following errors exist:
8328 1. For assignment, check if a many-to-one assignment happens.
8329 2. For WHERE statement, check the WHERE body to see if there is any
8330 many-to-one assignment. */
8333 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8337 c = code->block->next;
8343 case EXEC_POINTER_ASSIGN:
8344 gfc_resolve_assign_in_forall (c, nvar, var_expr);
8347 case EXEC_ASSIGN_CALL:
8351 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8352 there is no need to handle it here. */
8356 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8361 /* The next statement in the FORALL body. */
8367 /* Counts the number of iterators needed inside a forall construct, including
8368 nested forall constructs. This is used to allocate the needed memory
8369 in gfc_resolve_forall. */
8372 gfc_count_forall_iterators (gfc_code *code)
8374 int max_iters, sub_iters, current_iters;
8375 gfc_forall_iterator *fa;
8377 gcc_assert(code->op == EXEC_FORALL);
8381 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8384 code = code->block->next;
8388 if (code->op == EXEC_FORALL)
8390 sub_iters = gfc_count_forall_iterators (code);
8391 if (sub_iters > max_iters)
8392 max_iters = sub_iters;
8397 return current_iters + max_iters;
8401 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8402 gfc_resolve_forall_body to resolve the FORALL body. */
8405 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8407 static gfc_expr **var_expr;
8408 static int total_var = 0;
8409 static int nvar = 0;
8411 gfc_forall_iterator *fa;
8416 /* Start to resolve a FORALL construct */
8417 if (forall_save == 0)
8419 /* Count the total number of FORALL index in the nested FORALL
8420 construct in order to allocate the VAR_EXPR with proper size. */
8421 total_var = gfc_count_forall_iterators (code);
8423 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8424 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
8427 /* The information about FORALL iterator, including FORALL index start, end
8428 and stride. The FORALL index can not appear in start, end or stride. */
8429 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8431 /* Check if any outer FORALL index name is the same as the current
8433 for (i = 0; i < nvar; i++)
8435 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8437 gfc_error ("An outer FORALL construct already has an index "
8438 "with this name %L", &fa->var->where);
8442 /* Record the current FORALL index. */
8443 var_expr[nvar] = gfc_copy_expr (fa->var);
8447 /* No memory leak. */
8448 gcc_assert (nvar <= total_var);
8451 /* Resolve the FORALL body. */
8452 gfc_resolve_forall_body (code, nvar, var_expr);
8454 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8455 gfc_resolve_blocks (code->block, ns);
8459 /* Free only the VAR_EXPRs allocated in this frame. */
8460 for (i = nvar; i < tmp; i++)
8461 gfc_free_expr (var_expr[i]);
8465 /* We are in the outermost FORALL construct. */
8466 gcc_assert (forall_save == 0);
8468 /* VAR_EXPR is not needed any more. */
8469 gfc_free (var_expr);
8475 /* Resolve a BLOCK construct statement. */
8478 resolve_block_construct (gfc_code* code)
8480 /* Resolve the BLOCK's namespace. */
8481 gfc_resolve (code->ext.block.ns);
8483 /* For an ASSOCIATE block, the associations (and their targets) are already
8484 resolved during resolve_symbol. */
8488 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8491 static void resolve_code (gfc_code *, gfc_namespace *);
8494 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8498 for (; b; b = b->block)
8500 t = gfc_resolve_expr (b->expr1);
8501 if (gfc_resolve_expr (b->expr2) == FAILURE)
8507 if (t == SUCCESS && b->expr1 != NULL
8508 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
8509 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8516 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
8517 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8522 resolve_branch (b->label1, b);
8526 resolve_block_construct (b);
8530 case EXEC_SELECT_TYPE:
8541 case EXEC_OMP_ATOMIC:
8542 case EXEC_OMP_CRITICAL:
8544 case EXEC_OMP_MASTER:
8545 case EXEC_OMP_ORDERED:
8546 case EXEC_OMP_PARALLEL:
8547 case EXEC_OMP_PARALLEL_DO:
8548 case EXEC_OMP_PARALLEL_SECTIONS:
8549 case EXEC_OMP_PARALLEL_WORKSHARE:
8550 case EXEC_OMP_SECTIONS:
8551 case EXEC_OMP_SINGLE:
8553 case EXEC_OMP_TASKWAIT:
8554 case EXEC_OMP_WORKSHARE:
8558 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
8561 resolve_code (b->next, ns);
8566 /* Does everything to resolve an ordinary assignment. Returns true
8567 if this is an interface assignment. */
8569 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
8579 if (gfc_extend_assign (code, ns) == SUCCESS)
8583 if (code->op == EXEC_ASSIGN_CALL)
8585 lhs = code->ext.actual->expr;
8586 rhsptr = &code->ext.actual->next->expr;
8590 gfc_actual_arglist* args;
8591 gfc_typebound_proc* tbp;
8593 gcc_assert (code->op == EXEC_COMPCALL);
8595 args = code->expr1->value.compcall.actual;
8597 rhsptr = &args->next->expr;
8599 tbp = code->expr1->value.compcall.tbp;
8600 gcc_assert (!tbp->is_generic);
8603 /* Make a temporary rhs when there is a default initializer
8604 and rhs is the same symbol as the lhs. */
8605 if ((*rhsptr)->expr_type == EXPR_VARIABLE
8606 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
8607 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
8608 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
8609 *rhsptr = gfc_get_parentheses (*rhsptr);
8618 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
8619 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
8620 &code->loc) == FAILURE)
8623 /* Handle the case of a BOZ literal on the RHS. */
8624 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
8627 if (gfc_option.warn_surprising)
8628 gfc_warning ("BOZ literal at %L is bitwise transferred "
8629 "non-integer symbol '%s'", &code->loc,
8630 lhs->symtree->n.sym->name);
8632 if (!gfc_convert_boz (rhs, &lhs->ts))
8634 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
8636 if (rc == ARITH_UNDERFLOW)
8637 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
8638 ". This check can be disabled with the option "
8639 "-fno-range-check", &rhs->where);
8640 else if (rc == ARITH_OVERFLOW)
8641 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
8642 ". This check can be disabled with the option "
8643 "-fno-range-check", &rhs->where);
8644 else if (rc == ARITH_NAN)
8645 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
8646 ". This check can be disabled with the option "
8647 "-fno-range-check", &rhs->where);
8652 if (lhs->ts.type == BT_CHARACTER
8653 && gfc_option.warn_character_truncation)
8655 if (lhs->ts.u.cl != NULL
8656 && lhs->ts.u.cl->length != NULL
8657 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8658 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
8660 if (rhs->expr_type == EXPR_CONSTANT)
8661 rlen = rhs->value.character.length;
8663 else if (rhs->ts.u.cl != NULL
8664 && rhs->ts.u.cl->length != NULL
8665 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8666 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
8668 if (rlen && llen && rlen > llen)
8669 gfc_warning_now ("CHARACTER expression will be truncated "
8670 "in assignment (%d/%d) at %L",
8671 llen, rlen, &code->loc);
8674 /* Ensure that a vector index expression for the lvalue is evaluated
8675 to a temporary if the lvalue symbol is referenced in it. */
8678 for (ref = lhs->ref; ref; ref= ref->next)
8679 if (ref->type == REF_ARRAY)
8681 for (n = 0; n < ref->u.ar.dimen; n++)
8682 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
8683 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
8684 ref->u.ar.start[n]))
8686 = gfc_get_parentheses (ref->u.ar.start[n]);
8690 if (gfc_pure (NULL))
8692 if (lhs->ts.type == BT_DERIVED
8693 && lhs->expr_type == EXPR_VARIABLE
8694 && lhs->ts.u.derived->attr.pointer_comp
8695 && rhs->expr_type == EXPR_VARIABLE
8696 && (gfc_impure_variable (rhs->symtree->n.sym)
8697 || gfc_is_coindexed (rhs)))
8700 if (gfc_is_coindexed (rhs))
8701 gfc_error ("Coindexed expression at %L is assigned to "
8702 "a derived type variable with a POINTER "
8703 "component in a PURE procedure",
8706 gfc_error ("The impure variable at %L is assigned to "
8707 "a derived type variable with a POINTER "
8708 "component in a PURE procedure (12.6)",
8713 /* Fortran 2008, C1283. */
8714 if (gfc_is_coindexed (lhs))
8716 gfc_error ("Assignment to coindexed variable at %L in a PURE "
8717 "procedure", &rhs->where);
8723 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
8724 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
8725 if (lhs->ts.type == BT_CLASS)
8727 gfc_error ("Variable must not be polymorphic in assignment at %L",
8732 /* F2008, Section 7.2.1.2. */
8733 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
8735 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
8736 "component in assignment at %L", &lhs->where);
8740 gfc_check_assign (lhs, rhs, 1);
8745 /* Given a block of code, recursively resolve everything pointed to by this
8749 resolve_code (gfc_code *code, gfc_namespace *ns)
8751 int omp_workshare_save;
8756 frame.prev = cs_base;
8760 find_reachable_labels (code);
8762 for (; code; code = code->next)
8764 frame.current = code;
8765 forall_save = forall_flag;
8767 if (code->op == EXEC_FORALL)
8770 gfc_resolve_forall (code, ns, forall_save);
8773 else if (code->block)
8775 omp_workshare_save = -1;
8778 case EXEC_OMP_PARALLEL_WORKSHARE:
8779 omp_workshare_save = omp_workshare_flag;
8780 omp_workshare_flag = 1;
8781 gfc_resolve_omp_parallel_blocks (code, ns);
8783 case EXEC_OMP_PARALLEL:
8784 case EXEC_OMP_PARALLEL_DO:
8785 case EXEC_OMP_PARALLEL_SECTIONS:
8787 omp_workshare_save = omp_workshare_flag;
8788 omp_workshare_flag = 0;
8789 gfc_resolve_omp_parallel_blocks (code, ns);
8792 gfc_resolve_omp_do_blocks (code, ns);
8794 case EXEC_SELECT_TYPE:
8795 /* Blocks are handled in resolve_select_type because we have
8796 to transform the SELECT TYPE into ASSOCIATE first. */
8798 case EXEC_OMP_WORKSHARE:
8799 omp_workshare_save = omp_workshare_flag;
8800 omp_workshare_flag = 1;
8803 gfc_resolve_blocks (code->block, ns);
8807 if (omp_workshare_save != -1)
8808 omp_workshare_flag = omp_workshare_save;
8812 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
8813 t = gfc_resolve_expr (code->expr1);
8814 forall_flag = forall_save;
8816 if (gfc_resolve_expr (code->expr2) == FAILURE)
8819 if (code->op == EXEC_ALLOCATE
8820 && gfc_resolve_expr (code->expr3) == FAILURE)
8826 case EXEC_END_BLOCK:
8830 case EXEC_ERROR_STOP:
8834 case EXEC_ASSIGN_CALL:
8839 case EXEC_SYNC_IMAGES:
8840 case EXEC_SYNC_MEMORY:
8841 resolve_sync (code);
8845 /* Keep track of which entry we are up to. */
8846 current_entry_id = code->ext.entry->id;
8850 resolve_where (code, NULL);
8854 if (code->expr1 != NULL)
8856 if (code->expr1->ts.type != BT_INTEGER)
8857 gfc_error ("ASSIGNED GOTO statement at %L requires an "
8858 "INTEGER variable", &code->expr1->where);
8859 else if (code->expr1->symtree->n.sym->attr.assign != 1)
8860 gfc_error ("Variable '%s' has not been assigned a target "
8861 "label at %L", code->expr1->symtree->n.sym->name,
8862 &code->expr1->where);
8865 resolve_branch (code->label1, code);
8869 if (code->expr1 != NULL
8870 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
8871 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
8872 "INTEGER return specifier", &code->expr1->where);
8875 case EXEC_INIT_ASSIGN:
8876 case EXEC_END_PROCEDURE:
8883 if (gfc_check_vardef_context (code->expr1, false, _("assignment"))
8887 if (resolve_ordinary_assign (code, ns))
8889 if (code->op == EXEC_COMPCALL)
8896 case EXEC_LABEL_ASSIGN:
8897 if (code->label1->defined == ST_LABEL_UNKNOWN)
8898 gfc_error ("Label %d referenced at %L is never defined",
8899 code->label1->value, &code->label1->where);
8901 && (code->expr1->expr_type != EXPR_VARIABLE
8902 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
8903 || code->expr1->symtree->n.sym->ts.kind
8904 != gfc_default_integer_kind
8905 || code->expr1->symtree->n.sym->as != NULL))
8906 gfc_error ("ASSIGN statement at %L requires a scalar "
8907 "default INTEGER variable", &code->expr1->where);
8910 case EXEC_POINTER_ASSIGN:
8917 /* This is both a variable definition and pointer assignment
8918 context, so check both of them. For rank remapping, a final
8919 array ref may be present on the LHS and fool gfc_expr_attr
8920 used in gfc_check_vardef_context. Remove it. */
8921 e = remove_last_array_ref (code->expr1);
8922 t = gfc_check_vardef_context (e, true, _("pointer assignment"));
8924 t = gfc_check_vardef_context (e, false, _("pointer assignment"));
8929 gfc_check_pointer_assign (code->expr1, code->expr2);
8933 case EXEC_ARITHMETIC_IF:
8935 && code->expr1->ts.type != BT_INTEGER
8936 && code->expr1->ts.type != BT_REAL)
8937 gfc_error ("Arithmetic IF statement at %L requires a numeric "
8938 "expression", &code->expr1->where);
8940 resolve_branch (code->label1, code);
8941 resolve_branch (code->label2, code);
8942 resolve_branch (code->label3, code);
8946 if (t == SUCCESS && code->expr1 != NULL
8947 && (code->expr1->ts.type != BT_LOGICAL
8948 || code->expr1->rank != 0))
8949 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8950 &code->expr1->where);
8955 resolve_call (code);
8960 resolve_typebound_subroutine (code);
8964 resolve_ppc_call (code);
8968 /* Select is complicated. Also, a SELECT construct could be
8969 a transformed computed GOTO. */
8970 resolve_select (code);
8973 case EXEC_SELECT_TYPE:
8974 resolve_select_type (code, ns);
8978 resolve_block_construct (code);
8982 if (code->ext.iterator != NULL)
8984 gfc_iterator *iter = code->ext.iterator;
8985 if (gfc_resolve_iterator (iter, true) != FAILURE)
8986 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
8991 if (code->expr1 == NULL)
8992 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
8994 && (code->expr1->rank != 0
8995 || code->expr1->ts.type != BT_LOGICAL))
8996 gfc_error ("Exit condition of DO WHILE loop at %L must be "
8997 "a scalar LOGICAL expression", &code->expr1->where);
9002 resolve_allocate_deallocate (code, "ALLOCATE");
9006 case EXEC_DEALLOCATE:
9008 resolve_allocate_deallocate (code, "DEALLOCATE");
9013 if (gfc_resolve_open (code->ext.open) == FAILURE)
9016 resolve_branch (code->ext.open->err, code);
9020 if (gfc_resolve_close (code->ext.close) == FAILURE)
9023 resolve_branch (code->ext.close->err, code);
9026 case EXEC_BACKSPACE:
9030 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
9033 resolve_branch (code->ext.filepos->err, code);
9037 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9040 resolve_branch (code->ext.inquire->err, code);
9044 gcc_assert (code->ext.inquire != NULL);
9045 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9048 resolve_branch (code->ext.inquire->err, code);
9052 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
9055 resolve_branch (code->ext.wait->err, code);
9056 resolve_branch (code->ext.wait->end, code);
9057 resolve_branch (code->ext.wait->eor, code);
9062 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
9065 resolve_branch (code->ext.dt->err, code);
9066 resolve_branch (code->ext.dt->end, code);
9067 resolve_branch (code->ext.dt->eor, code);
9071 resolve_transfer (code);
9075 resolve_forall_iterators (code->ext.forall_iterator);
9077 if (code->expr1 != NULL && code->expr1->ts.type != BT_LOGICAL)
9078 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
9079 "expression", &code->expr1->where);
9082 case EXEC_OMP_ATOMIC:
9083 case EXEC_OMP_BARRIER:
9084 case EXEC_OMP_CRITICAL:
9085 case EXEC_OMP_FLUSH:
9087 case EXEC_OMP_MASTER:
9088 case EXEC_OMP_ORDERED:
9089 case EXEC_OMP_SECTIONS:
9090 case EXEC_OMP_SINGLE:
9091 case EXEC_OMP_TASKWAIT:
9092 case EXEC_OMP_WORKSHARE:
9093 gfc_resolve_omp_directive (code, ns);
9096 case EXEC_OMP_PARALLEL:
9097 case EXEC_OMP_PARALLEL_DO:
9098 case EXEC_OMP_PARALLEL_SECTIONS:
9099 case EXEC_OMP_PARALLEL_WORKSHARE:
9101 omp_workshare_save = omp_workshare_flag;
9102 omp_workshare_flag = 0;
9103 gfc_resolve_omp_directive (code, ns);
9104 omp_workshare_flag = omp_workshare_save;
9108 gfc_internal_error ("resolve_code(): Bad statement code");
9112 cs_base = frame.prev;
9116 /* Resolve initial values and make sure they are compatible with
9120 resolve_values (gfc_symbol *sym)
9124 if (sym->value == NULL)
9127 if (sym->value->expr_type == EXPR_STRUCTURE)
9128 t= resolve_structure_cons (sym->value, 1);
9130 t = gfc_resolve_expr (sym->value);
9135 gfc_check_assign_symbol (sym, sym->value);
9139 /* Verify the binding labels for common blocks that are BIND(C). The label
9140 for a BIND(C) common block must be identical in all scoping units in which
9141 the common block is declared. Further, the binding label can not collide
9142 with any other global entity in the program. */
9145 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
9147 if (comm_block_tree->n.common->is_bind_c == 1)
9149 gfc_gsymbol *binding_label_gsym;
9150 gfc_gsymbol *comm_name_gsym;
9152 /* See if a global symbol exists by the common block's name. It may
9153 be NULL if the common block is use-associated. */
9154 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
9155 comm_block_tree->n.common->name);
9156 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
9157 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9158 "with the global entity '%s' at %L",
9159 comm_block_tree->n.common->binding_label,
9160 comm_block_tree->n.common->name,
9161 &(comm_block_tree->n.common->where),
9162 comm_name_gsym->name, &(comm_name_gsym->where));
9163 else if (comm_name_gsym != NULL
9164 && strcmp (comm_name_gsym->name,
9165 comm_block_tree->n.common->name) == 0)
9167 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9169 if (comm_name_gsym->binding_label == NULL)
9170 /* No binding label for common block stored yet; save this one. */
9171 comm_name_gsym->binding_label =
9172 comm_block_tree->n.common->binding_label;
9174 if (strcmp (comm_name_gsym->binding_label,
9175 comm_block_tree->n.common->binding_label) != 0)
9177 /* Common block names match but binding labels do not. */
9178 gfc_error ("Binding label '%s' for common block '%s' at %L "
9179 "does not match the binding label '%s' for common "
9181 comm_block_tree->n.common->binding_label,
9182 comm_block_tree->n.common->name,
9183 &(comm_block_tree->n.common->where),
9184 comm_name_gsym->binding_label,
9185 comm_name_gsym->name,
9186 &(comm_name_gsym->where));
9191 /* There is no binding label (NAME="") so we have nothing further to
9192 check and nothing to add as a global symbol for the label. */
9193 if (comm_block_tree->n.common->binding_label[0] == '\0' )
9196 binding_label_gsym =
9197 gfc_find_gsymbol (gfc_gsym_root,
9198 comm_block_tree->n.common->binding_label);
9199 if (binding_label_gsym == NULL)
9201 /* Need to make a global symbol for the binding label to prevent
9202 it from colliding with another. */
9203 binding_label_gsym =
9204 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9205 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9206 binding_label_gsym->type = GSYM_COMMON;
9210 /* If comm_name_gsym is NULL, the name common block is use
9211 associated and the name could be colliding. */
9212 if (binding_label_gsym->type != GSYM_COMMON)
9213 gfc_error ("Binding label '%s' for common block '%s' at %L "
9214 "collides with the global entity '%s' at %L",
9215 comm_block_tree->n.common->binding_label,
9216 comm_block_tree->n.common->name,
9217 &(comm_block_tree->n.common->where),
9218 binding_label_gsym->name,
9219 &(binding_label_gsym->where));
9220 else if (comm_name_gsym != NULL
9221 && (strcmp (binding_label_gsym->name,
9222 comm_name_gsym->binding_label) != 0)
9223 && (strcmp (binding_label_gsym->sym_name,
9224 comm_name_gsym->name) != 0))
9225 gfc_error ("Binding label '%s' for common block '%s' at %L "
9226 "collides with global entity '%s' at %L",
9227 binding_label_gsym->name, binding_label_gsym->sym_name,
9228 &(comm_block_tree->n.common->where),
9229 comm_name_gsym->name, &(comm_name_gsym->where));
9237 /* Verify any BIND(C) derived types in the namespace so we can report errors
9238 for them once, rather than for each variable declared of that type. */
9241 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9243 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9244 && derived_sym->attr.is_bind_c == 1)
9245 verify_bind_c_derived_type (derived_sym);
9251 /* Verify that any binding labels used in a given namespace do not collide
9252 with the names or binding labels of any global symbols. */
9255 gfc_verify_binding_labels (gfc_symbol *sym)
9259 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9260 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
9262 gfc_gsymbol *bind_c_sym;
9264 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9265 if (bind_c_sym != NULL
9266 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9268 if (sym->attr.if_source == IFSRC_DECL
9269 && (bind_c_sym->type != GSYM_SUBROUTINE
9270 && bind_c_sym->type != GSYM_FUNCTION)
9271 && ((sym->attr.contained == 1
9272 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9273 || (sym->attr.use_assoc == 1
9274 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9276 /* Make sure global procedures don't collide with anything. */
9277 gfc_error ("Binding label '%s' at %L collides with the global "
9278 "entity '%s' at %L", sym->binding_label,
9279 &(sym->declared_at), bind_c_sym->name,
9280 &(bind_c_sym->where));
9283 else if (sym->attr.contained == 0
9284 && (sym->attr.if_source == IFSRC_IFBODY
9285 && sym->attr.flavor == FL_PROCEDURE)
9286 && (bind_c_sym->sym_name != NULL
9287 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9289 /* Make sure procedures in interface bodies don't collide. */
9290 gfc_error ("Binding label '%s' in interface body at %L collides "
9291 "with the global entity '%s' at %L",
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_UNKNOWN)
9299 if ((sym->attr.use_assoc && bind_c_sym->mod_name
9300 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9301 || sym->attr.use_assoc == 0)
9303 gfc_error ("Binding label '%s' at %L collides with global "
9304 "entity '%s' at %L", sym->binding_label,
9305 &(sym->declared_at), bind_c_sym->name,
9306 &(bind_c_sym->where));
9311 /* Clear the binding label to prevent checking multiple times. */
9312 sym->binding_label[0] = '\0';
9314 else if (bind_c_sym == NULL)
9316 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9317 bind_c_sym->where = sym->declared_at;
9318 bind_c_sym->sym_name = sym->name;
9320 if (sym->attr.use_assoc == 1)
9321 bind_c_sym->mod_name = sym->module;
9323 if (sym->ns->proc_name != NULL)
9324 bind_c_sym->mod_name = sym->ns->proc_name->name;
9326 if (sym->attr.contained == 0)
9328 if (sym->attr.subroutine)
9329 bind_c_sym->type = GSYM_SUBROUTINE;
9330 else if (sym->attr.function)
9331 bind_c_sym->type = GSYM_FUNCTION;
9339 /* Resolve an index expression. */
9342 resolve_index_expr (gfc_expr *e)
9344 if (gfc_resolve_expr (e) == FAILURE)
9347 if (gfc_simplify_expr (e, 0) == FAILURE)
9350 if (gfc_specification_expr (e) == FAILURE)
9356 /* Resolve a charlen structure. */
9359 resolve_charlen (gfc_charlen *cl)
9368 specification_expr = 1;
9370 if (resolve_index_expr (cl->length) == FAILURE)
9372 specification_expr = 0;
9376 /* "If the character length parameter value evaluates to a negative
9377 value, the length of character entities declared is zero." */
9378 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9380 if (gfc_option.warn_surprising)
9381 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9382 " the length has been set to zero",
9383 &cl->length->where, i);
9384 gfc_replace_expr (cl->length,
9385 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9388 /* Check that the character length is not too large. */
9389 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9390 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9391 && cl->length->ts.type == BT_INTEGER
9392 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9394 gfc_error ("String length at %L is too large", &cl->length->where);
9402 /* Test for non-constant shape arrays. */
9405 is_non_constant_shape_array (gfc_symbol *sym)
9411 not_constant = false;
9412 if (sym->as != NULL)
9414 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9415 has not been simplified; parameter array references. Do the
9416 simplification now. */
9417 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9419 e = sym->as->lower[i];
9420 if (e && (resolve_index_expr (e) == FAILURE
9421 || !gfc_is_constant_expr (e)))
9422 not_constant = true;
9423 e = sym->as->upper[i];
9424 if (e && (resolve_index_expr (e) == FAILURE
9425 || !gfc_is_constant_expr (e)))
9426 not_constant = true;
9429 return not_constant;
9432 /* Given a symbol and an initialization expression, add code to initialize
9433 the symbol to the function entry. */
9435 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9439 gfc_namespace *ns = sym->ns;
9441 /* Search for the function namespace if this is a contained
9442 function without an explicit result. */
9443 if (sym->attr.function && sym == sym->result
9444 && sym->name != sym->ns->proc_name->name)
9447 for (;ns; ns = ns->sibling)
9448 if (strcmp (ns->proc_name->name, sym->name) == 0)
9454 gfc_free_expr (init);
9458 /* Build an l-value expression for the result. */
9459 lval = gfc_lval_expr_from_sym (sym);
9461 /* Add the code at scope entry. */
9462 init_st = gfc_get_code ();
9463 init_st->next = ns->code;
9466 /* Assign the default initializer to the l-value. */
9467 init_st->loc = sym->declared_at;
9468 init_st->op = EXEC_INIT_ASSIGN;
9469 init_st->expr1 = lval;
9470 init_st->expr2 = init;
9473 /* Assign the default initializer to a derived type variable or result. */
9476 apply_default_init (gfc_symbol *sym)
9478 gfc_expr *init = NULL;
9480 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9483 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
9484 init = gfc_default_initializer (&sym->ts);
9486 if (init == NULL && sym->ts.type != BT_CLASS)
9489 build_init_assign (sym, init);
9490 sym->attr.referenced = 1;
9493 /* Build an initializer for a local integer, real, complex, logical, or
9494 character variable, based on the command line flags finit-local-zero,
9495 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
9496 null if the symbol should not have a default initialization. */
9498 build_default_init_expr (gfc_symbol *sym)
9501 gfc_expr *init_expr;
9504 /* These symbols should never have a default initialization. */
9505 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
9506 || sym->attr.external
9508 || sym->attr.pointer
9509 || sym->attr.in_equivalence
9510 || sym->attr.in_common
9513 || sym->attr.cray_pointee
9514 || sym->attr.cray_pointer)
9517 /* Now we'll try to build an initializer expression. */
9518 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
9521 /* We will only initialize integers, reals, complex, logicals, and
9522 characters, and only if the corresponding command-line flags
9523 were set. Otherwise, we free init_expr and return null. */
9524 switch (sym->ts.type)
9527 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
9528 mpz_set_si (init_expr->value.integer,
9529 gfc_option.flag_init_integer_value);
9532 gfc_free_expr (init_expr);
9538 switch (gfc_option.flag_init_real)
9540 case GFC_INIT_REAL_SNAN:
9541 init_expr->is_snan = 1;
9543 case GFC_INIT_REAL_NAN:
9544 mpfr_set_nan (init_expr->value.real);
9547 case GFC_INIT_REAL_INF:
9548 mpfr_set_inf (init_expr->value.real, 1);
9551 case GFC_INIT_REAL_NEG_INF:
9552 mpfr_set_inf (init_expr->value.real, -1);
9555 case GFC_INIT_REAL_ZERO:
9556 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
9560 gfc_free_expr (init_expr);
9567 switch (gfc_option.flag_init_real)
9569 case GFC_INIT_REAL_SNAN:
9570 init_expr->is_snan = 1;
9572 case GFC_INIT_REAL_NAN:
9573 mpfr_set_nan (mpc_realref (init_expr->value.complex));
9574 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
9577 case GFC_INIT_REAL_INF:
9578 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
9579 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
9582 case GFC_INIT_REAL_NEG_INF:
9583 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
9584 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
9587 case GFC_INIT_REAL_ZERO:
9588 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
9592 gfc_free_expr (init_expr);
9599 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
9600 init_expr->value.logical = 0;
9601 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
9602 init_expr->value.logical = 1;
9605 gfc_free_expr (init_expr);
9611 /* For characters, the length must be constant in order to
9612 create a default initializer. */
9613 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
9614 && sym->ts.u.cl->length
9615 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9617 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
9618 init_expr->value.character.length = char_len;
9619 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
9620 for (i = 0; i < char_len; i++)
9621 init_expr->value.character.string[i]
9622 = (unsigned char) gfc_option.flag_init_character_value;
9626 gfc_free_expr (init_expr);
9632 gfc_free_expr (init_expr);
9638 /* Add an initialization expression to a local variable. */
9640 apply_default_init_local (gfc_symbol *sym)
9642 gfc_expr *init = NULL;
9644 /* The symbol should be a variable or a function return value. */
9645 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9646 || (sym->attr.function && sym->result != sym))
9649 /* Try to build the initializer expression. If we can't initialize
9650 this symbol, then init will be NULL. */
9651 init = build_default_init_expr (sym);
9655 /* For saved variables, we don't want to add an initializer at
9656 function entry, so we just add a static initializer. */
9657 if (sym->attr.save || sym->ns->save_all
9658 || gfc_option.flag_max_stack_var_size == 0)
9660 /* Don't clobber an existing initializer! */
9661 gcc_assert (sym->value == NULL);
9666 build_init_assign (sym, init);
9669 /* Resolution of common features of flavors variable and procedure. */
9672 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
9674 /* Constraints on deferred shape variable. */
9675 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
9677 if (sym->attr.allocatable)
9679 if (sym->attr.dimension)
9681 gfc_error ("Allocatable array '%s' at %L must have "
9682 "a deferred shape", sym->name, &sym->declared_at);
9685 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
9686 "may not be ALLOCATABLE", sym->name,
9687 &sym->declared_at) == FAILURE)
9691 if (sym->attr.pointer && sym->attr.dimension)
9693 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
9694 sym->name, &sym->declared_at);
9700 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
9701 && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc)
9703 gfc_error ("Array '%s' at %L cannot have a deferred shape",
9704 sym->name, &sym->declared_at);
9709 /* Constraints on polymorphic variables. */
9710 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
9713 if (sym->attr.class_ok
9714 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
9716 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
9717 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
9723 /* Assume that use associated symbols were checked in the module ns.
9724 Class-variables that are associate-names are also something special
9725 and excepted from the test. */
9726 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
9728 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
9729 "or pointer", sym->name, &sym->declared_at);
9738 /* Additional checks for symbols with flavor variable and derived
9739 type. To be called from resolve_fl_variable. */
9742 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
9744 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
9746 /* Check to see if a derived type is blocked from being host
9747 associated by the presence of another class I symbol in the same
9748 namespace. 14.6.1.3 of the standard and the discussion on
9749 comp.lang.fortran. */
9750 if (sym->ns != sym->ts.u.derived->ns
9751 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
9754 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
9755 if (s && s->attr.flavor != FL_DERIVED)
9757 gfc_error ("The type '%s' cannot be host associated at %L "
9758 "because it is blocked by an incompatible object "
9759 "of the same name declared at %L",
9760 sym->ts.u.derived->name, &sym->declared_at,
9766 /* 4th constraint in section 11.3: "If an object of a type for which
9767 component-initialization is specified (R429) appears in the
9768 specification-part of a module and does not have the ALLOCATABLE
9769 or POINTER attribute, the object shall have the SAVE attribute."
9771 The check for initializers is performed with
9772 gfc_has_default_initializer because gfc_default_initializer generates
9773 a hidden default for allocatable components. */
9774 if (!(sym->value || no_init_flag) && sym->ns->proc_name
9775 && sym->ns->proc_name->attr.flavor == FL_MODULE
9776 && !sym->ns->save_all && !sym->attr.save
9777 && !sym->attr.pointer && !sym->attr.allocatable
9778 && gfc_has_default_initializer (sym->ts.u.derived)
9779 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
9780 "module variable '%s' at %L, needed due to "
9781 "the default initialization", sym->name,
9782 &sym->declared_at) == FAILURE)
9785 /* Assign default initializer. */
9786 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
9787 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
9789 sym->value = gfc_default_initializer (&sym->ts);
9796 /* Resolve symbols with flavor variable. */
9799 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
9801 int no_init_flag, automatic_flag;
9803 const char *auto_save_msg;
9805 auto_save_msg = "Automatic object '%s' at %L cannot have the "
9808 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9811 /* Set this flag to check that variables are parameters of all entries.
9812 This check is effected by the call to gfc_resolve_expr through
9813 is_non_constant_shape_array. */
9814 specification_expr = 1;
9816 if (sym->ns->proc_name
9817 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9818 || sym->ns->proc_name->attr.is_main_program)
9819 && !sym->attr.use_assoc
9820 && !sym->attr.allocatable
9821 && !sym->attr.pointer
9822 && is_non_constant_shape_array (sym))
9824 /* The shape of a main program or module array needs to be
9826 gfc_error ("The module or main program array '%s' at %L must "
9827 "have constant shape", sym->name, &sym->declared_at);
9828 specification_expr = 0;
9832 if (sym->ts.type == BT_CHARACTER)
9834 /* Make sure that character string variables with assumed length are
9836 e = sym->ts.u.cl->length;
9837 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
9839 gfc_error ("Entity with assumed character length at %L must be a "
9840 "dummy argument or a PARAMETER", &sym->declared_at);
9844 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
9846 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9850 if (!gfc_is_constant_expr (e)
9851 && !(e->expr_type == EXPR_VARIABLE
9852 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
9853 && sym->ns->proc_name
9854 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9855 || sym->ns->proc_name->attr.is_main_program)
9856 && !sym->attr.use_assoc)
9858 gfc_error ("'%s' at %L must have constant character length "
9859 "in this context", sym->name, &sym->declared_at);
9864 if (sym->value == NULL && sym->attr.referenced)
9865 apply_default_init_local (sym); /* Try to apply a default initialization. */
9867 /* Determine if the symbol may not have an initializer. */
9868 no_init_flag = automatic_flag = 0;
9869 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
9870 || sym->attr.intrinsic || sym->attr.result)
9872 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
9873 && is_non_constant_shape_array (sym))
9875 no_init_flag = automatic_flag = 1;
9877 /* Also, they must not have the SAVE attribute.
9878 SAVE_IMPLICIT is checked below. */
9879 if (sym->attr.save == SAVE_EXPLICIT)
9881 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9886 /* Ensure that any initializer is simplified. */
9888 gfc_simplify_expr (sym->value, 1);
9890 /* Reject illegal initializers. */
9891 if (!sym->mark && sym->value)
9893 if (sym->attr.allocatable)
9894 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
9895 sym->name, &sym->declared_at);
9896 else if (sym->attr.external)
9897 gfc_error ("External '%s' at %L cannot have an initializer",
9898 sym->name, &sym->declared_at);
9899 else if (sym->attr.dummy
9900 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
9901 gfc_error ("Dummy '%s' at %L cannot have an initializer",
9902 sym->name, &sym->declared_at);
9903 else if (sym->attr.intrinsic)
9904 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
9905 sym->name, &sym->declared_at);
9906 else if (sym->attr.result)
9907 gfc_error ("Function result '%s' at %L cannot have an initializer",
9908 sym->name, &sym->declared_at);
9909 else if (automatic_flag)
9910 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
9911 sym->name, &sym->declared_at);
9918 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
9919 return resolve_fl_variable_derived (sym, no_init_flag);
9925 /* Resolve a procedure. */
9928 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
9930 gfc_formal_arglist *arg;
9932 if (sym->attr.function
9933 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9936 if (sym->ts.type == BT_CHARACTER)
9938 gfc_charlen *cl = sym->ts.u.cl;
9940 if (cl && cl->length && gfc_is_constant_expr (cl->length)
9941 && resolve_charlen (cl) == FAILURE)
9944 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
9945 && sym->attr.proc == PROC_ST_FUNCTION)
9947 gfc_error ("Character-valued statement function '%s' at %L must "
9948 "have constant length", sym->name, &sym->declared_at);
9953 /* Ensure that derived type for are not of a private type. Internal
9954 module procedures are excluded by 2.2.3.3 - i.e., they are not
9955 externally accessible and can access all the objects accessible in
9957 if (!(sym->ns->parent
9958 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
9959 && gfc_check_access(sym->attr.access, sym->ns->default_access))
9961 gfc_interface *iface;
9963 for (arg = sym->formal; arg; arg = arg->next)
9966 && arg->sym->ts.type == BT_DERIVED
9967 && !arg->sym->ts.u.derived->attr.use_assoc
9968 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
9969 arg->sym->ts.u.derived->ns->default_access)
9970 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
9971 "PRIVATE type and cannot be a dummy argument"
9972 " of '%s', which is PUBLIC at %L",
9973 arg->sym->name, sym->name, &sym->declared_at)
9976 /* Stop this message from recurring. */
9977 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
9982 /* PUBLIC interfaces may expose PRIVATE procedures that take types
9983 PRIVATE to the containing module. */
9984 for (iface = sym->generic; iface; iface = iface->next)
9986 for (arg = iface->sym->formal; arg; arg = arg->next)
9989 && arg->sym->ts.type == BT_DERIVED
9990 && !arg->sym->ts.u.derived->attr.use_assoc
9991 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
9992 arg->sym->ts.u.derived->ns->default_access)
9993 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
9994 "'%s' in PUBLIC interface '%s' at %L "
9995 "takes dummy arguments of '%s' which is "
9996 "PRIVATE", iface->sym->name, sym->name,
9997 &iface->sym->declared_at,
9998 gfc_typename (&arg->sym->ts)) == FAILURE)
10000 /* Stop this message from recurring. */
10001 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10007 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10008 PRIVATE to the containing module. */
10009 for (iface = sym->generic; iface; iface = iface->next)
10011 for (arg = iface->sym->formal; arg; arg = arg->next)
10014 && arg->sym->ts.type == BT_DERIVED
10015 && !arg->sym->ts.u.derived->attr.use_assoc
10016 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10017 arg->sym->ts.u.derived->ns->default_access)
10018 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10019 "'%s' in PUBLIC interface '%s' at %L "
10020 "takes dummy arguments of '%s' which is "
10021 "PRIVATE", iface->sym->name, sym->name,
10022 &iface->sym->declared_at,
10023 gfc_typename (&arg->sym->ts)) == FAILURE)
10025 /* Stop this message from recurring. */
10026 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10033 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10034 && !sym->attr.proc_pointer)
10036 gfc_error ("Function '%s' at %L cannot have an initializer",
10037 sym->name, &sym->declared_at);
10041 /* An external symbol may not have an initializer because it is taken to be
10042 a procedure. Exception: Procedure Pointers. */
10043 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10045 gfc_error ("External object '%s' at %L may not have an initializer",
10046 sym->name, &sym->declared_at);
10050 /* An elemental function is required to return a scalar 12.7.1 */
10051 if (sym->attr.elemental && sym->attr.function && sym->as)
10053 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10054 "result", sym->name, &sym->declared_at);
10055 /* Reset so that the error only occurs once. */
10056 sym->attr.elemental = 0;
10060 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10061 char-len-param shall not be array-valued, pointer-valued, recursive
10062 or pure. ....snip... A character value of * may only be used in the
10063 following ways: (i) Dummy arg of procedure - dummy associates with
10064 actual length; (ii) To declare a named constant; or (iii) External
10065 function - but length must be declared in calling scoping unit. */
10066 if (sym->attr.function
10067 && sym->ts.type == BT_CHARACTER
10068 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10070 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10071 || (sym->attr.recursive) || (sym->attr.pure))
10073 if (sym->as && sym->as->rank)
10074 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10075 "array-valued", sym->name, &sym->declared_at);
10077 if (sym->attr.pointer)
10078 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10079 "pointer-valued", sym->name, &sym->declared_at);
10081 if (sym->attr.pure)
10082 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10083 "pure", sym->name, &sym->declared_at);
10085 if (sym->attr.recursive)
10086 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10087 "recursive", sym->name, &sym->declared_at);
10092 /* Appendix B.2 of the standard. Contained functions give an
10093 error anyway. Fixed-form is likely to be F77/legacy. */
10094 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
10095 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10096 "CHARACTER(*) function '%s' at %L",
10097 sym->name, &sym->declared_at);
10100 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10102 gfc_formal_arglist *curr_arg;
10103 int has_non_interop_arg = 0;
10105 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10106 sym->common_block) == FAILURE)
10108 /* Clear these to prevent looking at them again if there was an
10110 sym->attr.is_bind_c = 0;
10111 sym->attr.is_c_interop = 0;
10112 sym->ts.is_c_interop = 0;
10116 /* So far, no errors have been found. */
10117 sym->attr.is_c_interop = 1;
10118 sym->ts.is_c_interop = 1;
10121 curr_arg = sym->formal;
10122 while (curr_arg != NULL)
10124 /* Skip implicitly typed dummy args here. */
10125 if (curr_arg->sym->attr.implicit_type == 0)
10126 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
10127 /* If something is found to fail, record the fact so we
10128 can mark the symbol for the procedure as not being
10129 BIND(C) to try and prevent multiple errors being
10131 has_non_interop_arg = 1;
10133 curr_arg = curr_arg->next;
10136 /* See if any of the arguments were not interoperable and if so, clear
10137 the procedure symbol to prevent duplicate error messages. */
10138 if (has_non_interop_arg != 0)
10140 sym->attr.is_c_interop = 0;
10141 sym->ts.is_c_interop = 0;
10142 sym->attr.is_bind_c = 0;
10146 if (!sym->attr.proc_pointer)
10148 if (sym->attr.save == SAVE_EXPLICIT)
10150 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10151 "in '%s' at %L", sym->name, &sym->declared_at);
10154 if (sym->attr.intent)
10156 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10157 "in '%s' at %L", sym->name, &sym->declared_at);
10160 if (sym->attr.subroutine && sym->attr.result)
10162 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10163 "in '%s' at %L", sym->name, &sym->declared_at);
10166 if (sym->attr.external && sym->attr.function
10167 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10168 || sym->attr.contained))
10170 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10171 "in '%s' at %L", sym->name, &sym->declared_at);
10174 if (strcmp ("ppr@", sym->name) == 0)
10176 gfc_error ("Procedure pointer result '%s' at %L "
10177 "is missing the pointer attribute",
10178 sym->ns->proc_name->name, &sym->declared_at);
10187 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10188 been defined and we now know their defined arguments, check that they fulfill
10189 the requirements of the standard for procedures used as finalizers. */
10192 gfc_resolve_finalizers (gfc_symbol* derived)
10194 gfc_finalizer* list;
10195 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10196 gfc_try result = SUCCESS;
10197 bool seen_scalar = false;
10199 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10202 /* Walk over the list of finalizer-procedures, check them, and if any one
10203 does not fit in with the standard's definition, print an error and remove
10204 it from the list. */
10205 prev_link = &derived->f2k_derived->finalizers;
10206 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10212 /* Skip this finalizer if we already resolved it. */
10213 if (list->proc_tree)
10215 prev_link = &(list->next);
10219 /* Check this exists and is a SUBROUTINE. */
10220 if (!list->proc_sym->attr.subroutine)
10222 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10223 list->proc_sym->name, &list->where);
10227 /* We should have exactly one argument. */
10228 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10230 gfc_error ("FINAL procedure at %L must have exactly one argument",
10234 arg = list->proc_sym->formal->sym;
10236 /* This argument must be of our type. */
10237 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10239 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10240 &arg->declared_at, derived->name);
10244 /* It must neither be a pointer nor allocatable nor optional. */
10245 if (arg->attr.pointer)
10247 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10248 &arg->declared_at);
10251 if (arg->attr.allocatable)
10253 gfc_error ("Argument of FINAL procedure at %L must not be"
10254 " ALLOCATABLE", &arg->declared_at);
10257 if (arg->attr.optional)
10259 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10260 &arg->declared_at);
10264 /* It must not be INTENT(OUT). */
10265 if (arg->attr.intent == INTENT_OUT)
10267 gfc_error ("Argument of FINAL procedure at %L must not be"
10268 " INTENT(OUT)", &arg->declared_at);
10272 /* Warn if the procedure is non-scalar and not assumed shape. */
10273 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10274 && arg->as->type != AS_ASSUMED_SHAPE)
10275 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10276 " shape argument", &arg->declared_at);
10278 /* Check that it does not match in kind and rank with a FINAL procedure
10279 defined earlier. To really loop over the *earlier* declarations,
10280 we need to walk the tail of the list as new ones were pushed at the
10282 /* TODO: Handle kind parameters once they are implemented. */
10283 my_rank = (arg->as ? arg->as->rank : 0);
10284 for (i = list->next; i; i = i->next)
10286 /* Argument list might be empty; that is an error signalled earlier,
10287 but we nevertheless continued resolving. */
10288 if (i->proc_sym->formal)
10290 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10291 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10292 if (i_rank == my_rank)
10294 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10295 " rank (%d) as '%s'",
10296 list->proc_sym->name, &list->where, my_rank,
10297 i->proc_sym->name);
10303 /* Is this the/a scalar finalizer procedure? */
10304 if (!arg->as || arg->as->rank == 0)
10305 seen_scalar = true;
10307 /* Find the symtree for this procedure. */
10308 gcc_assert (!list->proc_tree);
10309 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10311 prev_link = &list->next;
10314 /* Remove wrong nodes immediately from the list so we don't risk any
10315 troubles in the future when they might fail later expectations. */
10319 *prev_link = list->next;
10320 gfc_free_finalizer (i);
10323 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10324 were nodes in the list, must have been for arrays. It is surely a good
10325 idea to have a scalar version there if there's something to finalize. */
10326 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10327 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10328 " defined at %L, suggest also scalar one",
10329 derived->name, &derived->declared_at);
10331 /* TODO: Remove this error when finalization is finished. */
10332 gfc_error ("Finalization at %L is not yet implemented",
10333 &derived->declared_at);
10339 /* Check that it is ok for the typebound procedure proc to override the
10343 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
10346 const gfc_symbol* proc_target;
10347 const gfc_symbol* old_target;
10348 unsigned proc_pass_arg, old_pass_arg, argpos;
10349 gfc_formal_arglist* proc_formal;
10350 gfc_formal_arglist* old_formal;
10352 /* This procedure should only be called for non-GENERIC proc. */
10353 gcc_assert (!proc->n.tb->is_generic);
10355 /* If the overwritten procedure is GENERIC, this is an error. */
10356 if (old->n.tb->is_generic)
10358 gfc_error ("Can't overwrite GENERIC '%s' at %L",
10359 old->name, &proc->n.tb->where);
10363 where = proc->n.tb->where;
10364 proc_target = proc->n.tb->u.specific->n.sym;
10365 old_target = old->n.tb->u.specific->n.sym;
10367 /* Check that overridden binding is not NON_OVERRIDABLE. */
10368 if (old->n.tb->non_overridable)
10370 gfc_error ("'%s' at %L overrides a procedure binding declared"
10371 " NON_OVERRIDABLE", proc->name, &where);
10375 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
10376 if (!old->n.tb->deferred && proc->n.tb->deferred)
10378 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
10379 " non-DEFERRED binding", proc->name, &where);
10383 /* If the overridden binding is PURE, the overriding must be, too. */
10384 if (old_target->attr.pure && !proc_target->attr.pure)
10386 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
10387 proc->name, &where);
10391 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
10392 is not, the overriding must not be either. */
10393 if (old_target->attr.elemental && !proc_target->attr.elemental)
10395 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
10396 " ELEMENTAL", proc->name, &where);
10399 if (!old_target->attr.elemental && proc_target->attr.elemental)
10401 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
10402 " be ELEMENTAL, either", proc->name, &where);
10406 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
10408 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
10410 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
10411 " SUBROUTINE", proc->name, &where);
10415 /* If the overridden binding is a FUNCTION, the overriding must also be a
10416 FUNCTION and have the same characteristics. */
10417 if (old_target->attr.function)
10419 if (!proc_target->attr.function)
10421 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
10422 " FUNCTION", proc->name, &where);
10426 /* FIXME: Do more comprehensive checking (including, for instance, the
10427 rank and array-shape). */
10428 gcc_assert (proc_target->result && old_target->result);
10429 if (!gfc_compare_types (&proc_target->result->ts,
10430 &old_target->result->ts))
10432 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
10433 " matching result types", proc->name, &where);
10438 /* If the overridden binding is PUBLIC, the overriding one must not be
10440 if (old->n.tb->access == ACCESS_PUBLIC
10441 && proc->n.tb->access == ACCESS_PRIVATE)
10443 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
10444 " PRIVATE", proc->name, &where);
10448 /* Compare the formal argument lists of both procedures. This is also abused
10449 to find the position of the passed-object dummy arguments of both
10450 bindings as at least the overridden one might not yet be resolved and we
10451 need those positions in the check below. */
10452 proc_pass_arg = old_pass_arg = 0;
10453 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
10455 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
10458 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
10459 proc_formal && old_formal;
10460 proc_formal = proc_formal->next, old_formal = old_formal->next)
10462 if (proc->n.tb->pass_arg
10463 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
10464 proc_pass_arg = argpos;
10465 if (old->n.tb->pass_arg
10466 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
10467 old_pass_arg = argpos;
10469 /* Check that the names correspond. */
10470 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
10472 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
10473 " to match the corresponding argument of the overridden"
10474 " procedure", proc_formal->sym->name, proc->name, &where,
10475 old_formal->sym->name);
10479 /* Check that the types correspond if neither is the passed-object
10481 /* FIXME: Do more comprehensive testing here. */
10482 if (proc_pass_arg != argpos && old_pass_arg != argpos
10483 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
10485 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
10486 "in respect to the overridden procedure",
10487 proc_formal->sym->name, proc->name, &where);
10493 if (proc_formal || old_formal)
10495 gfc_error ("'%s' at %L must have the same number of formal arguments as"
10496 " the overridden procedure", proc->name, &where);
10500 /* If the overridden binding is NOPASS, the overriding one must also be
10502 if (old->n.tb->nopass && !proc->n.tb->nopass)
10504 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
10505 " NOPASS", proc->name, &where);
10509 /* If the overridden binding is PASS(x), the overriding one must also be
10510 PASS and the passed-object dummy arguments must correspond. */
10511 if (!old->n.tb->nopass)
10513 if (proc->n.tb->nopass)
10515 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
10516 " PASS", proc->name, &where);
10520 if (proc_pass_arg != old_pass_arg)
10522 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
10523 " the same position as the passed-object dummy argument of"
10524 " the overridden procedure", proc->name, &where);
10533 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10536 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10537 const char* generic_name, locus where)
10542 gcc_assert (t1->specific && t2->specific);
10543 gcc_assert (!t1->specific->is_generic);
10544 gcc_assert (!t2->specific->is_generic);
10546 sym1 = t1->specific->u.specific->n.sym;
10547 sym2 = t2->specific->u.specific->n.sym;
10552 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10553 if (sym1->attr.subroutine != sym2->attr.subroutine
10554 || sym1->attr.function != sym2->attr.function)
10556 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10557 " GENERIC '%s' at %L",
10558 sym1->name, sym2->name, generic_name, &where);
10562 /* Compare the interfaces. */
10563 if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
10565 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10566 sym1->name, sym2->name, generic_name, &where);
10574 /* Worker function for resolving a generic procedure binding; this is used to
10575 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10577 The difference between those cases is finding possible inherited bindings
10578 that are overridden, as one has to look for them in tb_sym_root,
10579 tb_uop_root or tb_op, respectively. Thus the caller must already find
10580 the super-type and set p->overridden correctly. */
10583 resolve_tb_generic_targets (gfc_symbol* super_type,
10584 gfc_typebound_proc* p, const char* name)
10586 gfc_tbp_generic* target;
10587 gfc_symtree* first_target;
10588 gfc_symtree* inherited;
10590 gcc_assert (p && p->is_generic);
10592 /* Try to find the specific bindings for the symtrees in our target-list. */
10593 gcc_assert (p->u.generic);
10594 for (target = p->u.generic; target; target = target->next)
10595 if (!target->specific)
10597 gfc_typebound_proc* overridden_tbp;
10598 gfc_tbp_generic* g;
10599 const char* target_name;
10601 target_name = target->specific_st->name;
10603 /* Defined for this type directly. */
10604 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
10606 target->specific = target->specific_st->n.tb;
10607 goto specific_found;
10610 /* Look for an inherited specific binding. */
10613 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
10618 gcc_assert (inherited->n.tb);
10619 target->specific = inherited->n.tb;
10620 goto specific_found;
10624 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
10625 " at %L", target_name, name, &p->where);
10628 /* Once we've found the specific binding, check it is not ambiguous with
10629 other specifics already found or inherited for the same GENERIC. */
10631 gcc_assert (target->specific);
10633 /* This must really be a specific binding! */
10634 if (target->specific->is_generic)
10636 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
10637 " '%s' is GENERIC, too", name, &p->where, target_name);
10641 /* Check those already resolved on this type directly. */
10642 for (g = p->u.generic; g; g = g->next)
10643 if (g != target && g->specific
10644 && check_generic_tbp_ambiguity (target, g, name, p->where)
10648 /* Check for ambiguity with inherited specific targets. */
10649 for (overridden_tbp = p->overridden; overridden_tbp;
10650 overridden_tbp = overridden_tbp->overridden)
10651 if (overridden_tbp->is_generic)
10653 for (g = overridden_tbp->u.generic; g; g = g->next)
10655 gcc_assert (g->specific);
10656 if (check_generic_tbp_ambiguity (target, g,
10657 name, p->where) == FAILURE)
10663 /* If we attempt to "overwrite" a specific binding, this is an error. */
10664 if (p->overridden && !p->overridden->is_generic)
10666 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
10667 " the same name", name, &p->where);
10671 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
10672 all must have the same attributes here. */
10673 first_target = p->u.generic->specific->u.specific;
10674 gcc_assert (first_target);
10675 p->subroutine = first_target->n.sym->attr.subroutine;
10676 p->function = first_target->n.sym->attr.function;
10682 /* Resolve a GENERIC procedure binding for a derived type. */
10685 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
10687 gfc_symbol* super_type;
10689 /* Find the overridden binding if any. */
10690 st->n.tb->overridden = NULL;
10691 super_type = gfc_get_derived_super_type (derived);
10694 gfc_symtree* overridden;
10695 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
10698 if (overridden && overridden->n.tb)
10699 st->n.tb->overridden = overridden->n.tb;
10702 /* Resolve using worker function. */
10703 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
10707 /* Retrieve the target-procedure of an operator binding and do some checks in
10708 common for intrinsic and user-defined type-bound operators. */
10711 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
10713 gfc_symbol* target_proc;
10715 gcc_assert (target->specific && !target->specific->is_generic);
10716 target_proc = target->specific->u.specific->n.sym;
10717 gcc_assert (target_proc);
10719 /* All operator bindings must have a passed-object dummy argument. */
10720 if (target->specific->nopass)
10722 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
10726 return target_proc;
10730 /* Resolve a type-bound intrinsic operator. */
10733 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
10734 gfc_typebound_proc* p)
10736 gfc_symbol* super_type;
10737 gfc_tbp_generic* target;
10739 /* If there's already an error here, do nothing (but don't fail again). */
10743 /* Operators should always be GENERIC bindings. */
10744 gcc_assert (p->is_generic);
10746 /* Look for an overridden binding. */
10747 super_type = gfc_get_derived_super_type (derived);
10748 if (super_type && super_type->f2k_derived)
10749 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
10752 p->overridden = NULL;
10754 /* Resolve general GENERIC properties using worker function. */
10755 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
10758 /* Check the targets to be procedures of correct interface. */
10759 for (target = p->u.generic; target; target = target->next)
10761 gfc_symbol* target_proc;
10763 target_proc = get_checked_tb_operator_target (target, p->where);
10767 if (!gfc_check_operator_interface (target_proc, op, p->where))
10779 /* Resolve a type-bound user operator (tree-walker callback). */
10781 static gfc_symbol* resolve_bindings_derived;
10782 static gfc_try resolve_bindings_result;
10784 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
10787 resolve_typebound_user_op (gfc_symtree* stree)
10789 gfc_symbol* super_type;
10790 gfc_tbp_generic* target;
10792 gcc_assert (stree && stree->n.tb);
10794 if (stree->n.tb->error)
10797 /* Operators should always be GENERIC bindings. */
10798 gcc_assert (stree->n.tb->is_generic);
10800 /* Find overridden procedure, if any. */
10801 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10802 if (super_type && super_type->f2k_derived)
10804 gfc_symtree* overridden;
10805 overridden = gfc_find_typebound_user_op (super_type, NULL,
10806 stree->name, true, NULL);
10808 if (overridden && overridden->n.tb)
10809 stree->n.tb->overridden = overridden->n.tb;
10812 stree->n.tb->overridden = NULL;
10814 /* Resolve basically using worker function. */
10815 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
10819 /* Check the targets to be functions of correct interface. */
10820 for (target = stree->n.tb->u.generic; target; target = target->next)
10822 gfc_symbol* target_proc;
10824 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
10828 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
10835 resolve_bindings_result = FAILURE;
10836 stree->n.tb->error = 1;
10840 /* Resolve the type-bound procedures for a derived type. */
10843 resolve_typebound_procedure (gfc_symtree* stree)
10847 gfc_symbol* me_arg;
10848 gfc_symbol* super_type;
10849 gfc_component* comp;
10851 gcc_assert (stree);
10853 /* Undefined specific symbol from GENERIC target definition. */
10857 if (stree->n.tb->error)
10860 /* If this is a GENERIC binding, use that routine. */
10861 if (stree->n.tb->is_generic)
10863 if (resolve_typebound_generic (resolve_bindings_derived, stree)
10869 /* Get the target-procedure to check it. */
10870 gcc_assert (!stree->n.tb->is_generic);
10871 gcc_assert (stree->n.tb->u.specific);
10872 proc = stree->n.tb->u.specific->n.sym;
10873 where = stree->n.tb->where;
10875 /* Default access should already be resolved from the parser. */
10876 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
10878 /* It should be a module procedure or an external procedure with explicit
10879 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
10880 if ((!proc->attr.subroutine && !proc->attr.function)
10881 || (proc->attr.proc != PROC_MODULE
10882 && proc->attr.if_source != IFSRC_IFBODY)
10883 || (proc->attr.abstract && !stree->n.tb->deferred))
10885 gfc_error ("'%s' must be a module procedure or an external procedure with"
10886 " an explicit interface at %L", proc->name, &where);
10889 stree->n.tb->subroutine = proc->attr.subroutine;
10890 stree->n.tb->function = proc->attr.function;
10892 /* Find the super-type of the current derived type. We could do this once and
10893 store in a global if speed is needed, but as long as not I believe this is
10894 more readable and clearer. */
10895 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10897 /* If PASS, resolve and check arguments if not already resolved / loaded
10898 from a .mod file. */
10899 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
10901 if (stree->n.tb->pass_arg)
10903 gfc_formal_arglist* i;
10905 /* If an explicit passing argument name is given, walk the arg-list
10906 and look for it. */
10909 stree->n.tb->pass_arg_num = 1;
10910 for (i = proc->formal; i; i = i->next)
10912 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
10917 ++stree->n.tb->pass_arg_num;
10922 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
10924 proc->name, stree->n.tb->pass_arg, &where,
10925 stree->n.tb->pass_arg);
10931 /* Otherwise, take the first one; there should in fact be at least
10933 stree->n.tb->pass_arg_num = 1;
10936 gfc_error ("Procedure '%s' with PASS at %L must have at"
10937 " least one argument", proc->name, &where);
10940 me_arg = proc->formal->sym;
10943 /* Now check that the argument-type matches and the passed-object
10944 dummy argument is generally fine. */
10946 gcc_assert (me_arg);
10948 if (me_arg->ts.type != BT_CLASS)
10950 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
10951 " at %L", proc->name, &where);
10955 if (CLASS_DATA (me_arg)->ts.u.derived
10956 != resolve_bindings_derived)
10958 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
10959 " the derived-type '%s'", me_arg->name, proc->name,
10960 me_arg->name, &where, resolve_bindings_derived->name);
10964 gcc_assert (me_arg->ts.type == BT_CLASS);
10965 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
10967 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
10968 " scalar", proc->name, &where);
10971 if (CLASS_DATA (me_arg)->attr.allocatable)
10973 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
10974 " be ALLOCATABLE", proc->name, &where);
10977 if (CLASS_DATA (me_arg)->attr.class_pointer)
10979 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
10980 " be POINTER", proc->name, &where);
10985 /* If we are extending some type, check that we don't override a procedure
10986 flagged NON_OVERRIDABLE. */
10987 stree->n.tb->overridden = NULL;
10990 gfc_symtree* overridden;
10991 overridden = gfc_find_typebound_proc (super_type, NULL,
10992 stree->name, true, NULL);
10994 if (overridden && overridden->n.tb)
10995 stree->n.tb->overridden = overridden->n.tb;
10997 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
11001 /* See if there's a name collision with a component directly in this type. */
11002 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11003 if (!strcmp (comp->name, stree->name))
11005 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11007 stree->name, &where, resolve_bindings_derived->name);
11011 /* Try to find a name collision with an inherited component. */
11012 if (super_type && gfc_find_component (super_type, stree->name, true, true))
11014 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11015 " component of '%s'",
11016 stree->name, &where, resolve_bindings_derived->name);
11020 stree->n.tb->error = 0;
11024 resolve_bindings_result = FAILURE;
11025 stree->n.tb->error = 1;
11030 resolve_typebound_procedures (gfc_symbol* derived)
11034 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11037 resolve_bindings_derived = derived;
11038 resolve_bindings_result = SUCCESS;
11040 /* Make sure the vtab has been generated. */
11041 gfc_find_derived_vtab (derived);
11043 if (derived->f2k_derived->tb_sym_root)
11044 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11045 &resolve_typebound_procedure);
11047 if (derived->f2k_derived->tb_uop_root)
11048 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11049 &resolve_typebound_user_op);
11051 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11053 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11054 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11056 resolve_bindings_result = FAILURE;
11059 return resolve_bindings_result;
11063 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11064 to give all identical derived types the same backend_decl. */
11066 add_dt_to_dt_list (gfc_symbol *derived)
11068 gfc_dt_list *dt_list;
11070 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11071 if (derived == dt_list->derived)
11074 if (dt_list == NULL)
11076 dt_list = gfc_get_dt_list ();
11077 dt_list->next = gfc_derived_types;
11078 dt_list->derived = derived;
11079 gfc_derived_types = dt_list;
11084 /* Ensure that a derived-type is really not abstract, meaning that every
11085 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11088 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11093 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11095 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11098 if (st->n.tb && st->n.tb->deferred)
11100 gfc_symtree* overriding;
11101 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11104 gcc_assert (overriding->n.tb);
11105 if (overriding->n.tb->deferred)
11107 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11108 " '%s' is DEFERRED and not overridden",
11109 sub->name, &sub->declared_at, st->name);
11118 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11120 /* The algorithm used here is to recursively travel up the ancestry of sub
11121 and for each ancestor-type, check all bindings. If any of them is
11122 DEFERRED, look it up starting from sub and see if the found (overriding)
11123 binding is not DEFERRED.
11124 This is not the most efficient way to do this, but it should be ok and is
11125 clearer than something sophisticated. */
11127 gcc_assert (ancestor && !sub->attr.abstract);
11129 if (!ancestor->attr.abstract)
11132 /* Walk bindings of this ancestor. */
11133 if (ancestor->f2k_derived)
11136 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11141 /* Find next ancestor type and recurse on it. */
11142 ancestor = gfc_get_derived_super_type (ancestor);
11144 return ensure_not_abstract (sub, ancestor);
11150 /* Resolve the components of a derived type. */
11153 resolve_fl_derived (gfc_symbol *sym)
11155 gfc_symbol* super_type;
11158 super_type = gfc_get_derived_super_type (sym);
11160 if (sym->attr.is_class && sym->ts.u.derived == NULL)
11162 /* Fix up incomplete CLASS symbols. */
11163 gfc_component *data = gfc_find_component (sym, "$data", true, true);
11164 gfc_component *vptr = gfc_find_component (sym, "$vptr", true, true);
11165 if (vptr->ts.u.derived == NULL)
11167 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
11169 vptr->ts.u.derived = vtab->ts.u.derived;
11174 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11176 gfc_error ("As extending type '%s' at %L has a coarray component, "
11177 "parent type '%s' shall also have one", sym->name,
11178 &sym->declared_at, super_type->name);
11182 /* Ensure the extended type gets resolved before we do. */
11183 if (super_type && resolve_fl_derived (super_type) == FAILURE)
11186 /* An ABSTRACT type must be extensible. */
11187 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11189 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11190 sym->name, &sym->declared_at);
11194 for (c = sym->components; c != NULL; c = c->next)
11197 if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */
11198 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11200 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11201 "deferred shape", c->name, &c->loc);
11206 if (c->attr.codimension && c->ts.type == BT_DERIVED
11207 && c->ts.u.derived->ts.is_iso_c)
11209 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11210 "shall not be a coarray", c->name, &c->loc);
11215 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11216 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11217 || c->attr.allocatable))
11219 gfc_error ("Component '%s' at %L with coarray component "
11220 "shall be a nonpointer, nonallocatable scalar",
11226 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11228 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11229 "is not an array pointer", c->name, &c->loc);
11233 if (c->attr.proc_pointer && c->ts.interface)
11235 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11236 gfc_error ("Interface '%s', used by procedure pointer component "
11237 "'%s' at %L, is declared in a later PROCEDURE statement",
11238 c->ts.interface->name, c->name, &c->loc);
11240 /* Get the attributes from the interface (now resolved). */
11241 if (c->ts.interface->attr.if_source
11242 || c->ts.interface->attr.intrinsic)
11244 gfc_symbol *ifc = c->ts.interface;
11246 if (ifc->formal && !ifc->formal_ns)
11247 resolve_symbol (ifc);
11249 if (ifc->attr.intrinsic)
11250 resolve_intrinsic (ifc, &ifc->declared_at);
11254 c->ts = ifc->result->ts;
11255 c->attr.allocatable = ifc->result->attr.allocatable;
11256 c->attr.pointer = ifc->result->attr.pointer;
11257 c->attr.dimension = ifc->result->attr.dimension;
11258 c->as = gfc_copy_array_spec (ifc->result->as);
11263 c->attr.allocatable = ifc->attr.allocatable;
11264 c->attr.pointer = ifc->attr.pointer;
11265 c->attr.dimension = ifc->attr.dimension;
11266 c->as = gfc_copy_array_spec (ifc->as);
11268 c->ts.interface = ifc;
11269 c->attr.function = ifc->attr.function;
11270 c->attr.subroutine = ifc->attr.subroutine;
11271 gfc_copy_formal_args_ppc (c, ifc);
11273 c->attr.pure = ifc->attr.pure;
11274 c->attr.elemental = ifc->attr.elemental;
11275 c->attr.recursive = ifc->attr.recursive;
11276 c->attr.always_explicit = ifc->attr.always_explicit;
11277 c->attr.ext_attr |= ifc->attr.ext_attr;
11278 /* Replace symbols in array spec. */
11282 for (i = 0; i < c->as->rank; i++)
11284 gfc_expr_replace_comp (c->as->lower[i], c);
11285 gfc_expr_replace_comp (c->as->upper[i], c);
11288 /* Copy char length. */
11289 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11291 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11292 gfc_expr_replace_comp (cl->length, c);
11293 if (cl->length && !cl->resolved
11294 && gfc_resolve_expr (cl->length) == FAILURE)
11299 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11301 gfc_error ("Interface '%s' of procedure pointer component "
11302 "'%s' at %L must be explicit", c->ts.interface->name,
11307 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11309 /* Since PPCs are not implicitly typed, a PPC without an explicit
11310 interface must be a subroutine. */
11311 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11314 /* Procedure pointer components: Check PASS arg. */
11315 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11316 && !sym->attr.vtype)
11318 gfc_symbol* me_arg;
11320 if (c->tb->pass_arg)
11322 gfc_formal_arglist* i;
11324 /* If an explicit passing argument name is given, walk the arg-list
11325 and look for it. */
11328 c->tb->pass_arg_num = 1;
11329 for (i = c->formal; i; i = i->next)
11331 if (!strcmp (i->sym->name, c->tb->pass_arg))
11336 c->tb->pass_arg_num++;
11341 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11342 "at %L has no argument '%s'", c->name,
11343 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11350 /* Otherwise, take the first one; there should in fact be at least
11352 c->tb->pass_arg_num = 1;
11355 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11356 "must have at least one argument",
11361 me_arg = c->formal->sym;
11364 /* Now check that the argument-type matches. */
11365 gcc_assert (me_arg);
11366 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11367 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11368 || (me_arg->ts.type == BT_CLASS
11369 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11371 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11372 " the derived type '%s'", me_arg->name, c->name,
11373 me_arg->name, &c->loc, sym->name);
11378 /* Check for C453. */
11379 if (me_arg->attr.dimension)
11381 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11382 "must be scalar", me_arg->name, c->name, me_arg->name,
11388 if (me_arg->attr.pointer)
11390 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11391 "may not have the POINTER attribute", me_arg->name,
11392 c->name, me_arg->name, &c->loc);
11397 if (me_arg->attr.allocatable)
11399 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11400 "may not be ALLOCATABLE", me_arg->name, c->name,
11401 me_arg->name, &c->loc);
11406 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11407 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11408 " at %L", c->name, &c->loc);
11412 /* Check type-spec if this is not the parent-type component. */
11413 if ((!sym->attr.extension || c != sym->components) && !sym->attr.vtype
11414 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11417 /* If this type is an extension, set the accessibility of the parent
11419 if (super_type && c == sym->components
11420 && strcmp (super_type->name, c->name) == 0)
11421 c->attr.access = super_type->attr.access;
11423 /* If this type is an extension, see if this component has the same name
11424 as an inherited type-bound procedure. */
11425 if (super_type && !sym->attr.is_class
11426 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11428 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11429 " inherited type-bound procedure",
11430 c->name, sym->name, &c->loc);
11434 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
11436 if (c->ts.u.cl->length == NULL
11437 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11438 || !gfc_is_constant_expr (c->ts.u.cl->length))
11440 gfc_error ("Character length of component '%s' needs to "
11441 "be a constant specification expression at %L",
11443 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11448 if (c->ts.type == BT_DERIVED
11449 && sym->component_access != ACCESS_PRIVATE
11450 && gfc_check_access (sym->attr.access, sym->ns->default_access)
11451 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11452 && !c->ts.u.derived->attr.use_assoc
11453 && !gfc_check_access (c->ts.u.derived->attr.access,
11454 c->ts.u.derived->ns->default_access)
11455 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11456 "is a PRIVATE type and cannot be a component of "
11457 "'%s', which is PUBLIC at %L", c->name,
11458 sym->name, &sym->declared_at) == FAILURE)
11461 if (sym->attr.sequence)
11463 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11465 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11466 "not have the SEQUENCE attribute",
11467 c->ts.u.derived->name, &sym->declared_at);
11472 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
11473 && c->attr.pointer && c->ts.u.derived->components == NULL
11474 && !c->ts.u.derived->attr.zero_comp)
11476 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11477 "that has not been declared", c->name, sym->name,
11482 if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer
11483 && CLASS_DATA (c)->ts.u.derived->components == NULL
11484 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11486 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11487 "that has not been declared", c->name, sym->name,
11493 if (c->ts.type == BT_CLASS
11494 && !(CLASS_DATA (c)->attr.class_pointer
11495 || CLASS_DATA (c)->attr.allocatable))
11497 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11498 "or pointer", c->name, &c->loc);
11502 /* Ensure that all the derived type components are put on the
11503 derived type list; even in formal namespaces, where derived type
11504 pointer components might not have been declared. */
11505 if (c->ts.type == BT_DERIVED
11507 && c->ts.u.derived->components
11509 && sym != c->ts.u.derived)
11510 add_dt_to_dt_list (c->ts.u.derived);
11512 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11513 || c->attr.proc_pointer
11514 || c->attr.allocatable)) == FAILURE)
11518 /* Resolve the type-bound procedures. */
11519 if (resolve_typebound_procedures (sym) == FAILURE)
11522 /* Resolve the finalizer procedures. */
11523 if (gfc_resolve_finalizers (sym) == FAILURE)
11526 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11527 all DEFERRED bindings are overridden. */
11528 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11529 && !sym->attr.is_class
11530 && ensure_not_abstract (sym, super_type) == FAILURE)
11533 /* Add derived type to the derived type list. */
11534 add_dt_to_dt_list (sym);
11541 resolve_fl_namelist (gfc_symbol *sym)
11546 for (nl = sym->namelist; nl; nl = nl->next)
11548 /* Reject namelist arrays of assumed shape. */
11549 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
11550 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
11551 "must not have assumed shape in namelist "
11552 "'%s' at %L", nl->sym->name, sym->name,
11553 &sym->declared_at) == FAILURE)
11556 /* Reject namelist arrays that are not constant shape. */
11557 if (is_non_constant_shape_array (nl->sym))
11559 gfc_error ("NAMELIST array object '%s' must have constant "
11560 "shape in namelist '%s' at %L", nl->sym->name,
11561 sym->name, &sym->declared_at);
11565 /* Namelist objects cannot have allocatable or pointer components. */
11566 if (nl->sym->ts.type != BT_DERIVED)
11569 if (nl->sym->ts.u.derived->attr.alloc_comp)
11571 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11572 "have ALLOCATABLE components",
11573 nl->sym->name, sym->name, &sym->declared_at);
11577 if (nl->sym->ts.u.derived->attr.pointer_comp)
11579 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11580 "have POINTER components",
11581 nl->sym->name, sym->name, &sym->declared_at);
11586 /* Reject PRIVATE objects in a PUBLIC namelist. */
11587 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
11589 for (nl = sym->namelist; nl; nl = nl->next)
11591 if (!nl->sym->attr.use_assoc
11592 && !is_sym_host_assoc (nl->sym, sym->ns)
11593 && !gfc_check_access(nl->sym->attr.access,
11594 nl->sym->ns->default_access))
11596 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
11597 "cannot be member of PUBLIC namelist '%s' at %L",
11598 nl->sym->name, sym->name, &sym->declared_at);
11602 /* Types with private components that came here by USE-association. */
11603 if (nl->sym->ts.type == BT_DERIVED
11604 && derived_inaccessible (nl->sym->ts.u.derived))
11606 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
11607 "components and cannot be member of namelist '%s' at %L",
11608 nl->sym->name, sym->name, &sym->declared_at);
11612 /* Types with private components that are defined in the same module. */
11613 if (nl->sym->ts.type == BT_DERIVED
11614 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
11615 && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
11616 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
11617 nl->sym->ns->default_access))
11619 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
11620 "cannot be a member of PUBLIC namelist '%s' at %L",
11621 nl->sym->name, sym->name, &sym->declared_at);
11628 /* 14.1.2 A module or internal procedure represent local entities
11629 of the same type as a namelist member and so are not allowed. */
11630 for (nl = sym->namelist; nl; nl = nl->next)
11632 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
11635 if (nl->sym->attr.function && nl->sym == nl->sym->result)
11636 if ((nl->sym == sym->ns->proc_name)
11638 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
11642 if (nl->sym && nl->sym->name)
11643 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
11644 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
11646 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
11647 "attribute in '%s' at %L", nlsym->name,
11648 &sym->declared_at);
11658 resolve_fl_parameter (gfc_symbol *sym)
11660 /* A parameter array's shape needs to be constant. */
11661 if (sym->as != NULL
11662 && (sym->as->type == AS_DEFERRED
11663 || is_non_constant_shape_array (sym)))
11665 gfc_error ("Parameter array '%s' at %L cannot be automatic "
11666 "or of deferred shape", sym->name, &sym->declared_at);
11670 /* Make sure a parameter that has been implicitly typed still
11671 matches the implicit type, since PARAMETER statements can precede
11672 IMPLICIT statements. */
11673 if (sym->attr.implicit_type
11674 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
11677 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
11678 "later IMPLICIT type", sym->name, &sym->declared_at);
11682 /* Make sure the types of derived parameters are consistent. This
11683 type checking is deferred until resolution because the type may
11684 refer to a derived type from the host. */
11685 if (sym->ts.type == BT_DERIVED
11686 && !gfc_compare_types (&sym->ts, &sym->value->ts))
11688 gfc_error ("Incompatible derived type in PARAMETER at %L",
11689 &sym->value->where);
11696 /* Do anything necessary to resolve a symbol. Right now, we just
11697 assume that an otherwise unknown symbol is a variable. This sort
11698 of thing commonly happens for symbols in module. */
11701 resolve_symbol (gfc_symbol *sym)
11703 int check_constant, mp_flag;
11704 gfc_symtree *symtree;
11705 gfc_symtree *this_symtree;
11709 /* Avoid double resolution of function result symbols. */
11710 if ((sym->result || sym->attr.result) && !sym->attr.dummy
11711 && (sym->ns != gfc_current_ns))
11714 if (sym->attr.flavor == FL_UNKNOWN)
11717 /* If we find that a flavorless symbol is an interface in one of the
11718 parent namespaces, find its symtree in this namespace, free the
11719 symbol and set the symtree to point to the interface symbol. */
11720 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
11722 symtree = gfc_find_symtree (ns->sym_root, sym->name);
11723 if (symtree && symtree->n.sym->generic)
11725 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
11727 gfc_release_symbol (sym);
11728 symtree->n.sym->refs++;
11729 this_symtree->n.sym = symtree->n.sym;
11734 /* Otherwise give it a flavor according to such attributes as
11736 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
11737 sym->attr.flavor = FL_VARIABLE;
11740 sym->attr.flavor = FL_PROCEDURE;
11741 if (sym->attr.dimension)
11742 sym->attr.function = 1;
11746 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
11747 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
11749 if (sym->attr.procedure && sym->ts.interface
11750 && sym->attr.if_source != IFSRC_DECL
11751 && resolve_procedure_interface (sym) == FAILURE)
11754 if (sym->attr.is_protected && !sym->attr.proc_pointer
11755 && (sym->attr.procedure || sym->attr.external))
11757 if (sym->attr.external)
11758 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
11759 "at %L", &sym->declared_at);
11761 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
11762 "at %L", &sym->declared_at);
11769 if (sym->attr.contiguous
11770 && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE
11771 && !sym->attr.pointer)))
11773 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
11774 "array pointer or an assumed-shape array", sym->name,
11775 &sym->declared_at);
11779 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
11782 /* Symbols that are module procedures with results (functions) have
11783 the types and array specification copied for type checking in
11784 procedures that call them, as well as for saving to a module
11785 file. These symbols can't stand the scrutiny that their results
11787 mp_flag = (sym->result != NULL && sym->result != sym);
11789 /* Make sure that the intrinsic is consistent with its internal
11790 representation. This needs to be done before assigning a default
11791 type to avoid spurious warnings. */
11792 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
11793 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
11796 /* Resolve associate names. */
11798 resolve_assoc_var (sym, true);
11800 /* Assign default type to symbols that need one and don't have one. */
11801 if (sym->ts.type == BT_UNKNOWN)
11803 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
11804 gfc_set_default_type (sym, 1, NULL);
11806 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
11807 && !sym->attr.function && !sym->attr.subroutine
11808 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
11809 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
11811 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
11813 /* The specific case of an external procedure should emit an error
11814 in the case that there is no implicit type. */
11816 gfc_set_default_type (sym, sym->attr.external, NULL);
11819 /* Result may be in another namespace. */
11820 resolve_symbol (sym->result);
11822 if (!sym->result->attr.proc_pointer)
11824 sym->ts = sym->result->ts;
11825 sym->as = gfc_copy_array_spec (sym->result->as);
11826 sym->attr.dimension = sym->result->attr.dimension;
11827 sym->attr.pointer = sym->result->attr.pointer;
11828 sym->attr.allocatable = sym->result->attr.allocatable;
11829 sym->attr.contiguous = sym->result->attr.contiguous;
11835 /* Assumed size arrays and assumed shape arrays must be dummy
11836 arguments. Array-spec's of implied-shape should have been resolved to
11837 AS_EXPLICIT already. */
11841 gcc_assert (sym->as->type != AS_IMPLIED_SHAPE);
11842 if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
11843 || sym->as->type == AS_ASSUMED_SHAPE)
11844 && sym->attr.dummy == 0)
11846 if (sym->as->type == AS_ASSUMED_SIZE)
11847 gfc_error ("Assumed size array at %L must be a dummy argument",
11848 &sym->declared_at);
11850 gfc_error ("Assumed shape array at %L must be a dummy argument",
11851 &sym->declared_at);
11856 /* Make sure symbols with known intent or optional are really dummy
11857 variable. Because of ENTRY statement, this has to be deferred
11858 until resolution time. */
11860 if (!sym->attr.dummy
11861 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
11863 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
11867 if (sym->attr.value && !sym->attr.dummy)
11869 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
11870 "it is not a dummy argument", sym->name, &sym->declared_at);
11874 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
11876 gfc_charlen *cl = sym->ts.u.cl;
11877 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
11879 gfc_error ("Character dummy variable '%s' at %L with VALUE "
11880 "attribute must have constant length",
11881 sym->name, &sym->declared_at);
11885 if (sym->ts.is_c_interop
11886 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
11888 gfc_error ("C interoperable character dummy variable '%s' at %L "
11889 "with VALUE attribute must have length one",
11890 sym->name, &sym->declared_at);
11895 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
11896 do this for something that was implicitly typed because that is handled
11897 in gfc_set_default_type. Handle dummy arguments and procedure
11898 definitions separately. Also, anything that is use associated is not
11899 handled here but instead is handled in the module it is declared in.
11900 Finally, derived type definitions are allowed to be BIND(C) since that
11901 only implies that they're interoperable, and they are checked fully for
11902 interoperability when a variable is declared of that type. */
11903 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
11904 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
11905 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
11907 gfc_try t = SUCCESS;
11909 /* First, make sure the variable is declared at the
11910 module-level scope (J3/04-007, Section 15.3). */
11911 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
11912 sym->attr.in_common == 0)
11914 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
11915 "is neither a COMMON block nor declared at the "
11916 "module level scope", sym->name, &(sym->declared_at));
11919 else if (sym->common_head != NULL)
11921 t = verify_com_block_vars_c_interop (sym->common_head);
11925 /* If type() declaration, we need to verify that the components
11926 of the given type are all C interoperable, etc. */
11927 if (sym->ts.type == BT_DERIVED &&
11928 sym->ts.u.derived->attr.is_c_interop != 1)
11930 /* Make sure the user marked the derived type as BIND(C). If
11931 not, call the verify routine. This could print an error
11932 for the derived type more than once if multiple variables
11933 of that type are declared. */
11934 if (sym->ts.u.derived->attr.is_bind_c != 1)
11935 verify_bind_c_derived_type (sym->ts.u.derived);
11939 /* Verify the variable itself as C interoperable if it
11940 is BIND(C). It is not possible for this to succeed if
11941 the verify_bind_c_derived_type failed, so don't have to handle
11942 any error returned by verify_bind_c_derived_type. */
11943 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
11944 sym->common_block);
11949 /* clear the is_bind_c flag to prevent reporting errors more than
11950 once if something failed. */
11951 sym->attr.is_bind_c = 0;
11956 /* If a derived type symbol has reached this point, without its
11957 type being declared, we have an error. Notice that most
11958 conditions that produce undefined derived types have already
11959 been dealt with. However, the likes of:
11960 implicit type(t) (t) ..... call foo (t) will get us here if
11961 the type is not declared in the scope of the implicit
11962 statement. Change the type to BT_UNKNOWN, both because it is so
11963 and to prevent an ICE. */
11964 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
11965 && !sym->ts.u.derived->attr.zero_comp)
11967 gfc_error ("The derived type '%s' at %L is of type '%s', "
11968 "which has not been defined", sym->name,
11969 &sym->declared_at, sym->ts.u.derived->name);
11970 sym->ts.type = BT_UNKNOWN;
11974 /* Make sure that the derived type has been resolved and that the
11975 derived type is visible in the symbol's namespace, if it is a
11976 module function and is not PRIVATE. */
11977 if (sym->ts.type == BT_DERIVED
11978 && sym->ts.u.derived->attr.use_assoc
11979 && sym->ns->proc_name
11980 && sym->ns->proc_name->attr.flavor == FL_MODULE)
11984 if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
11987 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
11988 if (!ds && sym->attr.function
11989 && gfc_check_access (sym->attr.access, sym->ns->default_access))
11991 symtree = gfc_new_symtree (&sym->ns->sym_root,
11992 sym->ts.u.derived->name);
11993 symtree->n.sym = sym->ts.u.derived;
11994 sym->ts.u.derived->refs++;
11998 /* Unless the derived-type declaration is use associated, Fortran 95
11999 does not allow public entries of private derived types.
12000 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12001 161 in 95-006r3. */
12002 if (sym->ts.type == BT_DERIVED
12003 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12004 && !sym->ts.u.derived->attr.use_assoc
12005 && gfc_check_access (sym->attr.access, sym->ns->default_access)
12006 && !gfc_check_access (sym->ts.u.derived->attr.access,
12007 sym->ts.u.derived->ns->default_access)
12008 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12009 "of PRIVATE derived type '%s'",
12010 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12011 : "variable", sym->name, &sym->declared_at,
12012 sym->ts.u.derived->name) == FAILURE)
12015 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12016 default initialization is defined (5.1.2.4.4). */
12017 if (sym->ts.type == BT_DERIVED
12019 && sym->attr.intent == INTENT_OUT
12021 && sym->as->type == AS_ASSUMED_SIZE)
12023 for (c = sym->ts.u.derived->components; c; c = c->next)
12025 if (c->initializer)
12027 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12028 "ASSUMED SIZE and so cannot have a default initializer",
12029 sym->name, &sym->declared_at);
12036 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12037 || sym->attr.codimension)
12038 && sym->attr.result)
12039 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12040 "a coarray component", sym->name, &sym->declared_at);
12043 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12044 && sym->ts.u.derived->ts.is_iso_c)
12045 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12046 "shall not be a coarray", sym->name, &sym->declared_at);
12049 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
12050 && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
12051 || sym->attr.allocatable))
12052 gfc_error ("Variable '%s' at %L with coarray component "
12053 "shall be a nonpointer, nonallocatable scalar",
12054 sym->name, &sym->declared_at);
12056 /* F2008, C526. The function-result case was handled above. */
12057 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12058 || sym->attr.codimension)
12059 && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
12060 || sym->ns->proc_name->attr.flavor == FL_MODULE
12061 || sym->ns->proc_name->attr.is_main_program
12062 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12063 gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
12064 "component and is not ALLOCATABLE, SAVE nor a "
12065 "dummy argument", sym->name, &sym->declared_at);
12066 /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
12067 else if (sym->attr.codimension && !sym->attr.allocatable
12068 && sym->as && sym->as->cotype == AS_DEFERRED)
12069 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12070 "deferred shape", sym->name, &sym->declared_at);
12071 else if (sym->attr.codimension && sym->attr.allocatable
12072 && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
12073 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12074 "deferred shape", sym->name, &sym->declared_at);
12078 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12079 || (sym->attr.codimension && sym->attr.allocatable))
12080 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12081 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12082 "allocatable coarray or have coarray components",
12083 sym->name, &sym->declared_at);
12085 if (sym->attr.codimension && sym->attr.dummy
12086 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12087 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12088 "procedure '%s'", sym->name, &sym->declared_at,
12089 sym->ns->proc_name->name);
12091 switch (sym->attr.flavor)
12094 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12099 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12104 if (resolve_fl_namelist (sym) == FAILURE)
12109 if (resolve_fl_parameter (sym) == FAILURE)
12117 /* Resolve array specifier. Check as well some constraints
12118 on COMMON blocks. */
12120 check_constant = sym->attr.in_common && !sym->attr.pointer;
12122 /* Set the formal_arg_flag so that check_conflict will not throw
12123 an error for host associated variables in the specification
12124 expression for an array_valued function. */
12125 if (sym->attr.function && sym->as)
12126 formal_arg_flag = 1;
12128 gfc_resolve_array_spec (sym->as, check_constant);
12130 formal_arg_flag = 0;
12132 /* Resolve formal namespaces. */
12133 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12134 && !sym->attr.contained && !sym->attr.intrinsic)
12135 gfc_resolve (sym->formal_ns);
12137 /* Make sure the formal namespace is present. */
12138 if (sym->formal && !sym->formal_ns)
12140 gfc_formal_arglist *formal = sym->formal;
12141 while (formal && !formal->sym)
12142 formal = formal->next;
12146 sym->formal_ns = formal->sym->ns;
12147 sym->formal_ns->refs++;
12151 /* Check threadprivate restrictions. */
12152 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12153 && (!sym->attr.in_common
12154 && sym->module == NULL
12155 && (sym->ns->proc_name == NULL
12156 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12157 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12159 /* If we have come this far we can apply default-initializers, as
12160 described in 14.7.5, to those variables that have not already
12161 been assigned one. */
12162 if (sym->ts.type == BT_DERIVED
12163 && sym->ns == gfc_current_ns
12165 && !sym->attr.allocatable
12166 && !sym->attr.alloc_comp)
12168 symbol_attribute *a = &sym->attr;
12170 if ((!a->save && !a->dummy && !a->pointer
12171 && !a->in_common && !a->use_assoc
12172 && (a->referenced || a->result)
12173 && !(a->function && sym != sym->result))
12174 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12175 apply_default_init (sym);
12178 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
12179 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
12180 && !CLASS_DATA (sym)->attr.class_pointer
12181 && !CLASS_DATA (sym)->attr.allocatable)
12182 apply_default_init (sym);
12184 /* If this symbol has a type-spec, check it. */
12185 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12186 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12187 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12193 /************* Resolve DATA statements *************/
12197 gfc_data_value *vnode;
12203 /* Advance the values structure to point to the next value in the data list. */
12206 next_data_value (void)
12208 while (mpz_cmp_ui (values.left, 0) == 0)
12211 if (values.vnode->next == NULL)
12214 values.vnode = values.vnode->next;
12215 mpz_set (values.left, values.vnode->repeat);
12223 check_data_variable (gfc_data_variable *var, locus *where)
12229 ar_type mark = AR_UNKNOWN;
12231 mpz_t section_index[GFC_MAX_DIMENSIONS];
12237 if (gfc_resolve_expr (var->expr) == FAILURE)
12241 mpz_init_set_si (offset, 0);
12244 if (e->expr_type != EXPR_VARIABLE)
12245 gfc_internal_error ("check_data_variable(): Bad expression");
12247 sym = e->symtree->n.sym;
12249 if (sym->ns->is_block_data && !sym->attr.in_common)
12251 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12252 sym->name, &sym->declared_at);
12255 if (e->ref == NULL && sym->as)
12257 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12258 " declaration", sym->name, where);
12262 has_pointer = sym->attr.pointer;
12264 for (ref = e->ref; ref; ref = ref->next)
12266 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12269 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
12271 gfc_error ("DATA element '%s' at %L cannot have a coindex",
12277 && ref->type == REF_ARRAY
12278 && ref->u.ar.type != AR_FULL)
12280 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12281 "be a full array", sym->name, where);
12286 if (e->rank == 0 || has_pointer)
12288 mpz_init_set_ui (size, 1);
12295 /* Find the array section reference. */
12296 for (ref = e->ref; ref; ref = ref->next)
12298 if (ref->type != REF_ARRAY)
12300 if (ref->u.ar.type == AR_ELEMENT)
12306 /* Set marks according to the reference pattern. */
12307 switch (ref->u.ar.type)
12315 /* Get the start position of array section. */
12316 gfc_get_section_index (ar, section_index, &offset);
12321 gcc_unreachable ();
12324 if (gfc_array_size (e, &size) == FAILURE)
12326 gfc_error ("Nonconstant array section at %L in DATA statement",
12328 mpz_clear (offset);
12335 while (mpz_cmp_ui (size, 0) > 0)
12337 if (next_data_value () == FAILURE)
12339 gfc_error ("DATA statement at %L has more variables than values",
12345 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12349 /* If we have more than one element left in the repeat count,
12350 and we have more than one element left in the target variable,
12351 then create a range assignment. */
12352 /* FIXME: Only done for full arrays for now, since array sections
12354 if (mark == AR_FULL && ref && ref->next == NULL
12355 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12359 if (mpz_cmp (size, values.left) >= 0)
12361 mpz_init_set (range, values.left);
12362 mpz_sub (size, size, values.left);
12363 mpz_set_ui (values.left, 0);
12367 mpz_init_set (range, size);
12368 mpz_sub (values.left, values.left, size);
12369 mpz_set_ui (size, 0);
12372 t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
12375 mpz_add (offset, offset, range);
12382 /* Assign initial value to symbol. */
12385 mpz_sub_ui (values.left, values.left, 1);
12386 mpz_sub_ui (size, size, 1);
12388 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
12392 if (mark == AR_FULL)
12393 mpz_add_ui (offset, offset, 1);
12395 /* Modify the array section indexes and recalculate the offset
12396 for next element. */
12397 else if (mark == AR_SECTION)
12398 gfc_advance_section (section_index, ar, &offset);
12402 if (mark == AR_SECTION)
12404 for (i = 0; i < ar->dimen; i++)
12405 mpz_clear (section_index[i]);
12409 mpz_clear (offset);
12415 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
12417 /* Iterate over a list of elements in a DATA statement. */
12420 traverse_data_list (gfc_data_variable *var, locus *where)
12423 iterator_stack frame;
12424 gfc_expr *e, *start, *end, *step;
12425 gfc_try retval = SUCCESS;
12427 mpz_init (frame.value);
12430 start = gfc_copy_expr (var->iter.start);
12431 end = gfc_copy_expr (var->iter.end);
12432 step = gfc_copy_expr (var->iter.step);
12434 if (gfc_simplify_expr (start, 1) == FAILURE
12435 || start->expr_type != EXPR_CONSTANT)
12437 gfc_error ("start of implied-do loop at %L could not be "
12438 "simplified to a constant value", &start->where);
12442 if (gfc_simplify_expr (end, 1) == FAILURE
12443 || end->expr_type != EXPR_CONSTANT)
12445 gfc_error ("end of implied-do loop at %L could not be "
12446 "simplified to a constant value", &start->where);
12450 if (gfc_simplify_expr (step, 1) == FAILURE
12451 || step->expr_type != EXPR_CONSTANT)
12453 gfc_error ("step of implied-do loop at %L could not be "
12454 "simplified to a constant value", &start->where);
12459 mpz_set (trip, end->value.integer);
12460 mpz_sub (trip, trip, start->value.integer);
12461 mpz_add (trip, trip, step->value.integer);
12463 mpz_div (trip, trip, step->value.integer);
12465 mpz_set (frame.value, start->value.integer);
12467 frame.prev = iter_stack;
12468 frame.variable = var->iter.var->symtree;
12469 iter_stack = &frame;
12471 while (mpz_cmp_ui (trip, 0) > 0)
12473 if (traverse_data_var (var->list, where) == FAILURE)
12479 e = gfc_copy_expr (var->expr);
12480 if (gfc_simplify_expr (e, 1) == FAILURE)
12487 mpz_add (frame.value, frame.value, step->value.integer);
12489 mpz_sub_ui (trip, trip, 1);
12493 mpz_clear (frame.value);
12496 gfc_free_expr (start);
12497 gfc_free_expr (end);
12498 gfc_free_expr (step);
12500 iter_stack = frame.prev;
12505 /* Type resolve variables in the variable list of a DATA statement. */
12508 traverse_data_var (gfc_data_variable *var, locus *where)
12512 for (; var; var = var->next)
12514 if (var->expr == NULL)
12515 t = traverse_data_list (var, where);
12517 t = check_data_variable (var, where);
12527 /* Resolve the expressions and iterators associated with a data statement.
12528 This is separate from the assignment checking because data lists should
12529 only be resolved once. */
12532 resolve_data_variables (gfc_data_variable *d)
12534 for (; d; d = d->next)
12536 if (d->list == NULL)
12538 if (gfc_resolve_expr (d->expr) == FAILURE)
12543 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
12546 if (resolve_data_variables (d->list) == FAILURE)
12555 /* Resolve a single DATA statement. We implement this by storing a pointer to
12556 the value list into static variables, and then recursively traversing the
12557 variables list, expanding iterators and such. */
12560 resolve_data (gfc_data *d)
12563 if (resolve_data_variables (d->var) == FAILURE)
12566 values.vnode = d->value;
12567 if (d->value == NULL)
12568 mpz_set_ui (values.left, 0);
12570 mpz_set (values.left, d->value->repeat);
12572 if (traverse_data_var (d->var, &d->where) == FAILURE)
12575 /* At this point, we better not have any values left. */
12577 if (next_data_value () == SUCCESS)
12578 gfc_error ("DATA statement at %L has more values than variables",
12583 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
12584 accessed by host or use association, is a dummy argument to a pure function,
12585 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
12586 is storage associated with any such variable, shall not be used in the
12587 following contexts: (clients of this function). */
12589 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
12590 procedure. Returns zero if assignment is OK, nonzero if there is a
12593 gfc_impure_variable (gfc_symbol *sym)
12598 if (sym->attr.use_assoc || sym->attr.in_common)
12601 /* Check if the symbol's ns is inside the pure procedure. */
12602 for (ns = gfc_current_ns; ns; ns = ns->parent)
12606 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
12610 proc = sym->ns->proc_name;
12611 if (sym->attr.dummy && gfc_pure (proc)
12612 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
12614 proc->attr.function))
12617 /* TODO: Sort out what can be storage associated, if anything, and include
12618 it here. In principle equivalences should be scanned but it does not
12619 seem to be possible to storage associate an impure variable this way. */
12624 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
12625 current namespace is inside a pure procedure. */
12628 gfc_pure (gfc_symbol *sym)
12630 symbol_attribute attr;
12635 /* Check if the current namespace or one of its parents
12636 belongs to a pure procedure. */
12637 for (ns = gfc_current_ns; ns; ns = ns->parent)
12639 sym = ns->proc_name;
12643 if (attr.flavor == FL_PROCEDURE && attr.pure)
12651 return attr.flavor == FL_PROCEDURE && attr.pure;
12655 /* Test whether the current procedure is elemental or not. */
12658 gfc_elemental (gfc_symbol *sym)
12660 symbol_attribute attr;
12663 sym = gfc_current_ns->proc_name;
12668 return attr.flavor == FL_PROCEDURE && attr.elemental;
12672 /* Warn about unused labels. */
12675 warn_unused_fortran_label (gfc_st_label *label)
12680 warn_unused_fortran_label (label->left);
12682 if (label->defined == ST_LABEL_UNKNOWN)
12685 switch (label->referenced)
12687 case ST_LABEL_UNKNOWN:
12688 gfc_warning ("Label %d at %L defined but not used", label->value,
12692 case ST_LABEL_BAD_TARGET:
12693 gfc_warning ("Label %d at %L defined but cannot be used",
12694 label->value, &label->where);
12701 warn_unused_fortran_label (label->right);
12705 /* Returns the sequence type of a symbol or sequence. */
12708 sequence_type (gfc_typespec ts)
12717 if (ts.u.derived->components == NULL)
12718 return SEQ_NONDEFAULT;
12720 result = sequence_type (ts.u.derived->components->ts);
12721 for (c = ts.u.derived->components->next; c; c = c->next)
12722 if (sequence_type (c->ts) != result)
12728 if (ts.kind != gfc_default_character_kind)
12729 return SEQ_NONDEFAULT;
12731 return SEQ_CHARACTER;
12734 if (ts.kind != gfc_default_integer_kind)
12735 return SEQ_NONDEFAULT;
12737 return SEQ_NUMERIC;
12740 if (!(ts.kind == gfc_default_real_kind
12741 || ts.kind == gfc_default_double_kind))
12742 return SEQ_NONDEFAULT;
12744 return SEQ_NUMERIC;
12747 if (ts.kind != gfc_default_complex_kind)
12748 return SEQ_NONDEFAULT;
12750 return SEQ_NUMERIC;
12753 if (ts.kind != gfc_default_logical_kind)
12754 return SEQ_NONDEFAULT;
12756 return SEQ_NUMERIC;
12759 return SEQ_NONDEFAULT;
12764 /* Resolve derived type EQUIVALENCE object. */
12767 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
12769 gfc_component *c = derived->components;
12774 /* Shall not be an object of nonsequence derived type. */
12775 if (!derived->attr.sequence)
12777 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
12778 "attribute to be an EQUIVALENCE object", sym->name,
12783 /* Shall not have allocatable components. */
12784 if (derived->attr.alloc_comp)
12786 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
12787 "components to be an EQUIVALENCE object",sym->name,
12792 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
12794 gfc_error ("Derived type variable '%s' at %L with default "
12795 "initialization cannot be in EQUIVALENCE with a variable "
12796 "in COMMON", sym->name, &e->where);
12800 for (; c ; c = c->next)
12802 if (c->ts.type == BT_DERIVED
12803 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
12806 /* Shall not be an object of sequence derived type containing a pointer
12807 in the structure. */
12808 if (c->attr.pointer)
12810 gfc_error ("Derived type variable '%s' at %L with pointer "
12811 "component(s) cannot be an EQUIVALENCE object",
12812 sym->name, &e->where);
12820 /* Resolve equivalence object.
12821 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
12822 an allocatable array, an object of nonsequence derived type, an object of
12823 sequence derived type containing a pointer at any level of component
12824 selection, an automatic object, a function name, an entry name, a result
12825 name, a named constant, a structure component, or a subobject of any of
12826 the preceding objects. A substring shall not have length zero. A
12827 derived type shall not have components with default initialization nor
12828 shall two objects of an equivalence group be initialized.
12829 Either all or none of the objects shall have an protected attribute.
12830 The simple constraints are done in symbol.c(check_conflict) and the rest
12831 are implemented here. */
12834 resolve_equivalence (gfc_equiv *eq)
12837 gfc_symbol *first_sym;
12840 locus *last_where = NULL;
12841 seq_type eq_type, last_eq_type;
12842 gfc_typespec *last_ts;
12843 int object, cnt_protected;
12846 last_ts = &eq->expr->symtree->n.sym->ts;
12848 first_sym = eq->expr->symtree->n.sym;
12852 for (object = 1; eq; eq = eq->eq, object++)
12856 e->ts = e->symtree->n.sym->ts;
12857 /* match_varspec might not know yet if it is seeing
12858 array reference or substring reference, as it doesn't
12860 if (e->ref && e->ref->type == REF_ARRAY)
12862 gfc_ref *ref = e->ref;
12863 sym = e->symtree->n.sym;
12865 if (sym->attr.dimension)
12867 ref->u.ar.as = sym->as;
12871 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
12872 if (e->ts.type == BT_CHARACTER
12874 && ref->type == REF_ARRAY
12875 && ref->u.ar.dimen == 1
12876 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
12877 && ref->u.ar.stride[0] == NULL)
12879 gfc_expr *start = ref->u.ar.start[0];
12880 gfc_expr *end = ref->u.ar.end[0];
12883 /* Optimize away the (:) reference. */
12884 if (start == NULL && end == NULL)
12887 e->ref = ref->next;
12889 e->ref->next = ref->next;
12894 ref->type = REF_SUBSTRING;
12896 start = gfc_get_int_expr (gfc_default_integer_kind,
12898 ref->u.ss.start = start;
12899 if (end == NULL && e->ts.u.cl)
12900 end = gfc_copy_expr (e->ts.u.cl->length);
12901 ref->u.ss.end = end;
12902 ref->u.ss.length = e->ts.u.cl;
12909 /* Any further ref is an error. */
12912 gcc_assert (ref->type == REF_ARRAY);
12913 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
12919 if (gfc_resolve_expr (e) == FAILURE)
12922 sym = e->symtree->n.sym;
12924 if (sym->attr.is_protected)
12926 if (cnt_protected > 0 && cnt_protected != object)
12928 gfc_error ("Either all or none of the objects in the "
12929 "EQUIVALENCE set at %L shall have the "
12930 "PROTECTED attribute",
12935 /* Shall not equivalence common block variables in a PURE procedure. */
12936 if (sym->ns->proc_name
12937 && sym->ns->proc_name->attr.pure
12938 && sym->attr.in_common)
12940 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
12941 "object in the pure procedure '%s'",
12942 sym->name, &e->where, sym->ns->proc_name->name);
12946 /* Shall not be a named constant. */
12947 if (e->expr_type == EXPR_CONSTANT)
12949 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
12950 "object", sym->name, &e->where);
12954 if (e->ts.type == BT_DERIVED
12955 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
12958 /* Check that the types correspond correctly:
12960 A numeric sequence structure may be equivalenced to another sequence
12961 structure, an object of default integer type, default real type, double
12962 precision real type, default logical type such that components of the
12963 structure ultimately only become associated to objects of the same
12964 kind. A character sequence structure may be equivalenced to an object
12965 of default character kind or another character sequence structure.
12966 Other objects may be equivalenced only to objects of the same type and
12967 kind parameters. */
12969 /* Identical types are unconditionally OK. */
12970 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
12971 goto identical_types;
12973 last_eq_type = sequence_type (*last_ts);
12974 eq_type = sequence_type (sym->ts);
12976 /* Since the pair of objects is not of the same type, mixed or
12977 non-default sequences can be rejected. */
12979 msg = "Sequence %s with mixed components in EQUIVALENCE "
12980 "statement at %L with different type objects";
12982 && last_eq_type == SEQ_MIXED
12983 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
12985 || (eq_type == SEQ_MIXED
12986 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
12987 &e->where) == FAILURE))
12990 msg = "Non-default type object or sequence %s in EQUIVALENCE "
12991 "statement at %L with objects of different type";
12993 && last_eq_type == SEQ_NONDEFAULT
12994 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
12995 last_where) == FAILURE)
12996 || (eq_type == SEQ_NONDEFAULT
12997 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
12998 &e->where) == FAILURE))
13001 msg ="Non-CHARACTER object '%s' in default CHARACTER "
13002 "EQUIVALENCE statement at %L";
13003 if (last_eq_type == SEQ_CHARACTER
13004 && eq_type != SEQ_CHARACTER
13005 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13006 &e->where) == FAILURE)
13009 msg ="Non-NUMERIC object '%s' in default NUMERIC "
13010 "EQUIVALENCE statement at %L";
13011 if (last_eq_type == SEQ_NUMERIC
13012 && eq_type != SEQ_NUMERIC
13013 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13014 &e->where) == FAILURE)
13019 last_where = &e->where;
13024 /* Shall not be an automatic array. */
13025 if (e->ref->type == REF_ARRAY
13026 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
13028 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13029 "an EQUIVALENCE object", sym->name, &e->where);
13036 /* Shall not be a structure component. */
13037 if (r->type == REF_COMPONENT)
13039 gfc_error ("Structure component '%s' at %L cannot be an "
13040 "EQUIVALENCE object",
13041 r->u.c.component->name, &e->where);
13045 /* A substring shall not have length zero. */
13046 if (r->type == REF_SUBSTRING)
13048 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13050 gfc_error ("Substring at %L has length zero",
13051 &r->u.ss.start->where);
13061 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13064 resolve_fntype (gfc_namespace *ns)
13066 gfc_entry_list *el;
13069 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13072 /* If there are any entries, ns->proc_name is the entry master
13073 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13075 sym = ns->entries->sym;
13077 sym = ns->proc_name;
13078 if (sym->result == sym
13079 && sym->ts.type == BT_UNKNOWN
13080 && gfc_set_default_type (sym, 0, NULL) == FAILURE
13081 && !sym->attr.untyped)
13083 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13084 sym->name, &sym->declared_at);
13085 sym->attr.untyped = 1;
13088 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13089 && !sym->attr.contained
13090 && !gfc_check_access (sym->ts.u.derived->attr.access,
13091 sym->ts.u.derived->ns->default_access)
13092 && gfc_check_access (sym->attr.access, sym->ns->default_access))
13094 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13095 "%L of PRIVATE type '%s'", sym->name,
13096 &sym->declared_at, sym->ts.u.derived->name);
13100 for (el = ns->entries->next; el; el = el->next)
13102 if (el->sym->result == el->sym
13103 && el->sym->ts.type == BT_UNKNOWN
13104 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13105 && !el->sym->attr.untyped)
13107 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13108 el->sym->name, &el->sym->declared_at);
13109 el->sym->attr.untyped = 1;
13115 /* 12.3.2.1.1 Defined operators. */
13118 check_uop_procedure (gfc_symbol *sym, locus where)
13120 gfc_formal_arglist *formal;
13122 if (!sym->attr.function)
13124 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13125 sym->name, &where);
13129 if (sym->ts.type == BT_CHARACTER
13130 && !(sym->ts.u.cl && sym->ts.u.cl->length)
13131 && !(sym->result && sym->result->ts.u.cl
13132 && sym->result->ts.u.cl->length))
13134 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13135 "character length", sym->name, &where);
13139 formal = sym->formal;
13140 if (!formal || !formal->sym)
13142 gfc_error ("User operator procedure '%s' at %L must have at least "
13143 "one argument", sym->name, &where);
13147 if (formal->sym->attr.intent != INTENT_IN)
13149 gfc_error ("First argument of operator interface at %L must be "
13150 "INTENT(IN)", &where);
13154 if (formal->sym->attr.optional)
13156 gfc_error ("First argument of operator interface at %L cannot be "
13157 "optional", &where);
13161 formal = formal->next;
13162 if (!formal || !formal->sym)
13165 if (formal->sym->attr.intent != INTENT_IN)
13167 gfc_error ("Second argument of operator interface at %L must be "
13168 "INTENT(IN)", &where);
13172 if (formal->sym->attr.optional)
13174 gfc_error ("Second argument of operator interface at %L cannot be "
13175 "optional", &where);
13181 gfc_error ("Operator interface at %L must have, at most, two "
13182 "arguments", &where);
13190 gfc_resolve_uops (gfc_symtree *symtree)
13192 gfc_interface *itr;
13194 if (symtree == NULL)
13197 gfc_resolve_uops (symtree->left);
13198 gfc_resolve_uops (symtree->right);
13200 for (itr = symtree->n.uop->op; itr; itr = itr->next)
13201 check_uop_procedure (itr->sym, itr->sym->declared_at);
13205 /* Examine all of the expressions associated with a program unit,
13206 assign types to all intermediate expressions, make sure that all
13207 assignments are to compatible types and figure out which names
13208 refer to which functions or subroutines. It doesn't check code
13209 block, which is handled by resolve_code. */
13212 resolve_types (gfc_namespace *ns)
13218 gfc_namespace* old_ns = gfc_current_ns;
13220 /* Check that all IMPLICIT types are ok. */
13221 if (!ns->seen_implicit_none)
13224 for (letter = 0; letter != GFC_LETTERS; ++letter)
13225 if (ns->set_flag[letter]
13226 && resolve_typespec_used (&ns->default_type[letter],
13227 &ns->implicit_loc[letter],
13232 gfc_current_ns = ns;
13234 resolve_entries (ns);
13236 resolve_common_vars (ns->blank_common.head, false);
13237 resolve_common_blocks (ns->common_root);
13239 resolve_contained_functions (ns);
13241 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13243 for (cl = ns->cl_list; cl; cl = cl->next)
13244 resolve_charlen (cl);
13246 gfc_traverse_ns (ns, resolve_symbol);
13248 resolve_fntype (ns);
13250 for (n = ns->contained; n; n = n->sibling)
13252 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13253 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13254 "also be PURE", n->proc_name->name,
13255 &n->proc_name->declared_at);
13261 gfc_check_interfaces (ns);
13263 gfc_traverse_ns (ns, resolve_values);
13269 for (d = ns->data; d; d = d->next)
13273 gfc_traverse_ns (ns, gfc_formalize_init_value);
13275 gfc_traverse_ns (ns, gfc_verify_binding_labels);
13277 if (ns->common_root != NULL)
13278 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13280 for (eq = ns->equiv; eq; eq = eq->next)
13281 resolve_equivalence (eq);
13283 /* Warn about unused labels. */
13284 if (warn_unused_label)
13285 warn_unused_fortran_label (ns->st_labels);
13287 gfc_resolve_uops (ns->uop_root);
13289 gfc_current_ns = old_ns;
13293 /* Call resolve_code recursively. */
13296 resolve_codes (gfc_namespace *ns)
13299 bitmap_obstack old_obstack;
13301 for (n = ns->contained; n; n = n->sibling)
13304 gfc_current_ns = ns;
13306 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13307 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13310 /* Set to an out of range value. */
13311 current_entry_id = -1;
13313 old_obstack = labels_obstack;
13314 bitmap_obstack_initialize (&labels_obstack);
13316 resolve_code (ns->code, ns);
13318 bitmap_obstack_release (&labels_obstack);
13319 labels_obstack = old_obstack;
13323 /* This function is called after a complete program unit has been compiled.
13324 Its purpose is to examine all of the expressions associated with a program
13325 unit, assign types to all intermediate expressions, make sure that all
13326 assignments are to compatible types and figure out which names refer to
13327 which functions or subroutines. */
13330 gfc_resolve (gfc_namespace *ns)
13332 gfc_namespace *old_ns;
13333 code_stack *old_cs_base;
13339 old_ns = gfc_current_ns;
13340 old_cs_base = cs_base;
13342 resolve_types (ns);
13343 resolve_codes (ns);
13345 gfc_current_ns = old_ns;
13346 cs_base = old_cs_base;
13349 gfc_run_passes (ns);