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 sym->attr.is_bind_c = ifc->attr.is_bind_c;
180 /* Copy array spec. */
181 sym->as = gfc_copy_array_spec (ifc->as);
185 for (i = 0; i < sym->as->rank; i++)
187 gfc_expr_replace_symbols (sym->as->lower[i], sym);
188 gfc_expr_replace_symbols (sym->as->upper[i], sym);
191 /* Copy char length. */
192 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
194 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
195 gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
196 if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
197 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
201 else if (sym->ts.interface->name[0] != '\0')
203 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
204 sym->ts.interface->name, sym->name, &sym->declared_at);
212 /* Resolve types of formal argument lists. These have to be done early so that
213 the formal argument lists of module procedures can be copied to the
214 containing module before the individual procedures are resolved
215 individually. We also resolve argument lists of procedures in interface
216 blocks because they are self-contained scoping units.
218 Since a dummy argument cannot be a non-dummy procedure, the only
219 resort left for untyped names are the IMPLICIT types. */
222 resolve_formal_arglist (gfc_symbol *proc)
224 gfc_formal_arglist *f;
228 if (proc->result != NULL)
233 if (gfc_elemental (proc)
234 || sym->attr.pointer || sym->attr.allocatable
235 || (sym->as && sym->as->rank > 0))
237 proc->attr.always_explicit = 1;
238 sym->attr.always_explicit = 1;
243 for (f = proc->formal; f; f = f->next)
249 /* Alternate return placeholder. */
250 if (gfc_elemental (proc))
251 gfc_error ("Alternate return specifier in elemental subroutine "
252 "'%s' at %L is not allowed", proc->name,
254 if (proc->attr.function)
255 gfc_error ("Alternate return specifier in function "
256 "'%s' at %L is not allowed", proc->name,
260 else if (sym->attr.procedure && sym->ts.interface
261 && sym->attr.if_source != IFSRC_DECL)
262 resolve_procedure_interface (sym);
264 if (sym->attr.if_source != IFSRC_UNKNOWN)
265 resolve_formal_arglist (sym);
267 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
269 if (gfc_pure (proc) && !gfc_pure (sym))
271 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
272 "also be PURE", sym->name, &sym->declared_at);
276 if (gfc_elemental (proc))
278 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
279 "procedure", &sym->declared_at);
283 if (sym->attr.function
284 && sym->ts.type == BT_UNKNOWN
285 && sym->attr.intrinsic)
287 gfc_intrinsic_sym *isym;
288 isym = gfc_find_function (sym->name);
289 if (isym == NULL || !isym->specific)
291 gfc_error ("Unable to find a specific INTRINSIC procedure "
292 "for the reference '%s' at %L", sym->name,
301 if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
302 && (!sym->attr.function || sym->result == sym))
303 gfc_set_default_type (sym, 1, sym->ns);
305 gfc_resolve_array_spec (sym->as, 0);
307 /* We can't tell if an array with dimension (:) is assumed or deferred
308 shape until we know if it has the pointer or allocatable attributes.
310 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
311 && !(sym->attr.pointer || sym->attr.allocatable))
313 sym->as->type = AS_ASSUMED_SHAPE;
314 for (i = 0; i < sym->as->rank; i++)
315 sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
319 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
320 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
321 || sym->attr.optional)
323 proc->attr.always_explicit = 1;
325 proc->result->attr.always_explicit = 1;
328 /* If the flavor is unknown at this point, it has to be a variable.
329 A procedure specification would have already set the type. */
331 if (sym->attr.flavor == FL_UNKNOWN)
332 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
334 if (gfc_pure (proc) && !sym->attr.pointer
335 && sym->attr.flavor != FL_PROCEDURE)
337 if (proc->attr.function && sym->attr.intent != INTENT_IN)
338 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
339 "INTENT(IN)", sym->name, proc->name,
342 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
343 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
344 "have its INTENT specified", sym->name, proc->name,
348 if (gfc_elemental (proc))
351 if (sym->attr.codimension)
353 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
354 "procedure", sym->name, &sym->declared_at);
360 gfc_error ("Argument '%s' of elemental procedure at %L must "
361 "be scalar", sym->name, &sym->declared_at);
365 if (sym->attr.allocatable)
367 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
368 "have the ALLOCATABLE attribute", sym->name,
373 if (sym->attr.pointer)
375 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
376 "have the POINTER attribute", sym->name,
381 if (sym->attr.flavor == FL_PROCEDURE)
383 gfc_error ("Dummy procedure '%s' not allowed in elemental "
384 "procedure '%s' at %L", sym->name, proc->name,
389 if (sym->attr.intent == INTENT_UNKNOWN)
391 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
392 "have its INTENT specified", sym->name, proc->name,
398 /* Each dummy shall be specified to be scalar. */
399 if (proc->attr.proc == PROC_ST_FUNCTION)
403 gfc_error ("Argument '%s' of statement function at %L must "
404 "be scalar", sym->name, &sym->declared_at);
408 if (sym->ts.type == BT_CHARACTER)
410 gfc_charlen *cl = sym->ts.u.cl;
411 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
413 gfc_error ("Character-valued argument '%s' of statement "
414 "function at %L must have constant length",
415 sym->name, &sym->declared_at);
425 /* Work function called when searching for symbols that have argument lists
426 associated with them. */
429 find_arglists (gfc_symbol *sym)
431 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
434 resolve_formal_arglist (sym);
438 /* Given a namespace, resolve all formal argument lists within the namespace.
442 resolve_formal_arglists (gfc_namespace *ns)
447 gfc_traverse_ns (ns, find_arglists);
452 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
456 /* If this namespace is not a function or an entry master function,
458 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
459 || sym->attr.entry_master)
462 /* Try to find out of what the return type is. */
463 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
465 t = gfc_set_default_type (sym->result, 0, ns);
467 if (t == FAILURE && !sym->result->attr.untyped)
469 if (sym->result == sym)
470 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
471 sym->name, &sym->declared_at);
472 else if (!sym->result->attr.proc_pointer)
473 gfc_error ("Result '%s' of contained function '%s' at %L has "
474 "no IMPLICIT type", sym->result->name, sym->name,
475 &sym->result->declared_at);
476 sym->result->attr.untyped = 1;
480 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
481 type, lists the only ways a character length value of * can be used:
482 dummy arguments of procedures, named constants, and function results
483 in external functions. Internal function results and results of module
484 procedures are not on this list, ergo, not permitted. */
486 if (sym->result->ts.type == BT_CHARACTER)
488 gfc_charlen *cl = sym->result->ts.u.cl;
489 if (!cl || !cl->length)
491 /* See if this is a module-procedure and adapt error message
494 gcc_assert (ns->parent && ns->parent->proc_name);
495 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
497 gfc_error ("Character-valued %s '%s' at %L must not be"
499 module_proc ? _("module procedure")
500 : _("internal function"),
501 sym->name, &sym->declared_at);
507 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
508 introduce duplicates. */
511 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
513 gfc_formal_arglist *f, *new_arglist;
516 for (; new_args != NULL; new_args = new_args->next)
518 new_sym = new_args->sym;
519 /* See if this arg is already in the formal argument list. */
520 for (f = proc->formal; f; f = f->next)
522 if (new_sym == f->sym)
529 /* Add a new argument. Argument order is not important. */
530 new_arglist = gfc_get_formal_arglist ();
531 new_arglist->sym = new_sym;
532 new_arglist->next = proc->formal;
533 proc->formal = new_arglist;
538 /* Flag the arguments that are not present in all entries. */
541 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
543 gfc_formal_arglist *f, *head;
546 for (f = proc->formal; f; f = f->next)
551 for (new_args = head; new_args; new_args = new_args->next)
553 if (new_args->sym == f->sym)
560 f->sym->attr.not_always_present = 1;
565 /* Resolve alternate entry points. If a symbol has multiple entry points we
566 create a new master symbol for the main routine, and turn the existing
567 symbol into an entry point. */
570 resolve_entries (gfc_namespace *ns)
572 gfc_namespace *old_ns;
576 char name[GFC_MAX_SYMBOL_LEN + 1];
577 static int master_count = 0;
579 if (ns->proc_name == NULL)
582 /* No need to do anything if this procedure doesn't have alternate entry
587 /* We may already have resolved alternate entry points. */
588 if (ns->proc_name->attr.entry_master)
591 /* If this isn't a procedure something has gone horribly wrong. */
592 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
594 /* Remember the current namespace. */
595 old_ns = gfc_current_ns;
599 /* Add the main entry point to the list of entry points. */
600 el = gfc_get_entry_list ();
601 el->sym = ns->proc_name;
603 el->next = ns->entries;
605 ns->proc_name->attr.entry = 1;
607 /* If it is a module function, it needs to be in the right namespace
608 so that gfc_get_fake_result_decl can gather up the results. The
609 need for this arose in get_proc_name, where these beasts were
610 left in their own namespace, to keep prior references linked to
611 the entry declaration.*/
612 if (ns->proc_name->attr.function
613 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
616 /* Do the same for entries where the master is not a module
617 procedure. These are retained in the module namespace because
618 of the module procedure declaration. */
619 for (el = el->next; el; el = el->next)
620 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
621 && el->sym->attr.mod_proc)
625 /* Add an entry statement for it. */
632 /* Create a new symbol for the master function. */
633 /* Give the internal function a unique name (within this file).
634 Also include the function name so the user has some hope of figuring
635 out what is going on. */
636 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
637 master_count++, ns->proc_name->name);
638 gfc_get_ha_symbol (name, &proc);
639 gcc_assert (proc != NULL);
641 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
642 if (ns->proc_name->attr.subroutine)
643 gfc_add_subroutine (&proc->attr, proc->name, NULL);
647 gfc_typespec *ts, *fts;
648 gfc_array_spec *as, *fas;
649 gfc_add_function (&proc->attr, proc->name, NULL);
651 fas = ns->entries->sym->as;
652 fas = fas ? fas : ns->entries->sym->result->as;
653 fts = &ns->entries->sym->result->ts;
654 if (fts->type == BT_UNKNOWN)
655 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
656 for (el = ns->entries->next; el; el = el->next)
658 ts = &el->sym->result->ts;
660 as = as ? as : el->sym->result->as;
661 if (ts->type == BT_UNKNOWN)
662 ts = gfc_get_default_type (el->sym->result->name, NULL);
664 if (! gfc_compare_types (ts, fts)
665 || (el->sym->result->attr.dimension
666 != ns->entries->sym->result->attr.dimension)
667 || (el->sym->result->attr.pointer
668 != ns->entries->sym->result->attr.pointer))
670 else if (as && fas && ns->entries->sym->result != el->sym->result
671 && gfc_compare_array_spec (as, fas) == 0)
672 gfc_error ("Function %s at %L has entries with mismatched "
673 "array specifications", ns->entries->sym->name,
674 &ns->entries->sym->declared_at);
675 /* The characteristics need to match and thus both need to have
676 the same string length, i.e. both len=*, or both len=4.
677 Having both len=<variable> is also possible, but difficult to
678 check at compile time. */
679 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
680 && (((ts->u.cl->length && !fts->u.cl->length)
681 ||(!ts->u.cl->length && fts->u.cl->length))
683 && ts->u.cl->length->expr_type
684 != fts->u.cl->length->expr_type)
686 && ts->u.cl->length->expr_type == EXPR_CONSTANT
687 && mpz_cmp (ts->u.cl->length->value.integer,
688 fts->u.cl->length->value.integer) != 0)))
689 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
690 "entries returning variables of different "
691 "string lengths", ns->entries->sym->name,
692 &ns->entries->sym->declared_at);
697 sym = ns->entries->sym->result;
698 /* All result types the same. */
700 if (sym->attr.dimension)
701 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
702 if (sym->attr.pointer)
703 gfc_add_pointer (&proc->attr, NULL);
707 /* Otherwise the result will be passed through a union by
709 proc->attr.mixed_entry_master = 1;
710 for (el = ns->entries; el; el = el->next)
712 sym = el->sym->result;
713 if (sym->attr.dimension)
715 if (el == ns->entries)
716 gfc_error ("FUNCTION result %s can't be an array in "
717 "FUNCTION %s at %L", sym->name,
718 ns->entries->sym->name, &sym->declared_at);
720 gfc_error ("ENTRY result %s can't be an array in "
721 "FUNCTION %s at %L", sym->name,
722 ns->entries->sym->name, &sym->declared_at);
724 else if (sym->attr.pointer)
726 if (el == ns->entries)
727 gfc_error ("FUNCTION result %s can't be a POINTER in "
728 "FUNCTION %s at %L", sym->name,
729 ns->entries->sym->name, &sym->declared_at);
731 gfc_error ("ENTRY result %s can't be a POINTER in "
732 "FUNCTION %s at %L", sym->name,
733 ns->entries->sym->name, &sym->declared_at);
738 if (ts->type == BT_UNKNOWN)
739 ts = gfc_get_default_type (sym->name, NULL);
743 if (ts->kind == gfc_default_integer_kind)
747 if (ts->kind == gfc_default_real_kind
748 || ts->kind == gfc_default_double_kind)
752 if (ts->kind == gfc_default_complex_kind)
756 if (ts->kind == gfc_default_logical_kind)
760 /* We will issue error elsewhere. */
768 if (el == ns->entries)
769 gfc_error ("FUNCTION result %s can't be of type %s "
770 "in FUNCTION %s at %L", sym->name,
771 gfc_typename (ts), ns->entries->sym->name,
774 gfc_error ("ENTRY result %s can't be of type %s "
775 "in FUNCTION %s at %L", sym->name,
776 gfc_typename (ts), ns->entries->sym->name,
783 proc->attr.access = ACCESS_PRIVATE;
784 proc->attr.entry_master = 1;
786 /* Merge all the entry point arguments. */
787 for (el = ns->entries; el; el = el->next)
788 merge_argument_lists (proc, el->sym->formal);
790 /* Check the master formal arguments for any that are not
791 present in all entry points. */
792 for (el = ns->entries; el; el = el->next)
793 check_argument_lists (proc, el->sym->formal);
795 /* Use the master function for the function body. */
796 ns->proc_name = proc;
798 /* Finalize the new symbols. */
799 gfc_commit_symbols ();
801 /* Restore the original namespace. */
802 gfc_current_ns = old_ns;
806 /* Resolve common variables. */
808 resolve_common_vars (gfc_symbol *sym, bool named_common)
810 gfc_symbol *csym = sym;
812 for (; csym; csym = csym->common_next)
814 if (csym->value || csym->attr.data)
816 if (!csym->ns->is_block_data)
817 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
818 "but only in BLOCK DATA initialization is "
819 "allowed", csym->name, &csym->declared_at);
820 else if (!named_common)
821 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
822 "in a blank COMMON but initialization is only "
823 "allowed in named common blocks", csym->name,
827 if (csym->ts.type != BT_DERIVED)
830 if (!(csym->ts.u.derived->attr.sequence
831 || csym->ts.u.derived->attr.is_bind_c))
832 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
833 "has neither the SEQUENCE nor the BIND(C) "
834 "attribute", csym->name, &csym->declared_at);
835 if (csym->ts.u.derived->attr.alloc_comp)
836 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
837 "has an ultimate component that is "
838 "allocatable", csym->name, &csym->declared_at);
839 if (gfc_has_default_initializer (csym->ts.u.derived))
840 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
841 "may not have default initializer", csym->name,
844 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
845 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
849 /* Resolve common blocks. */
851 resolve_common_blocks (gfc_symtree *common_root)
855 if (common_root == NULL)
858 if (common_root->left)
859 resolve_common_blocks (common_root->left);
860 if (common_root->right)
861 resolve_common_blocks (common_root->right);
863 resolve_common_vars (common_root->n.common->head, true);
865 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
869 if (sym->attr.flavor == FL_PARAMETER)
870 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
871 sym->name, &common_root->n.common->where, &sym->declared_at);
873 if (sym->attr.intrinsic)
874 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
875 sym->name, &common_root->n.common->where);
876 else if (sym->attr.result
877 || gfc_is_function_return_value (sym, gfc_current_ns))
878 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
879 "that is also a function result", sym->name,
880 &common_root->n.common->where);
881 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
882 && sym->attr.proc != PROC_ST_FUNCTION)
883 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
884 "that is also a global procedure", sym->name,
885 &common_root->n.common->where);
889 /* Resolve contained function types. Because contained functions can call one
890 another, they have to be worked out before any of the contained procedures
893 The good news is that if a function doesn't already have a type, the only
894 way it can get one is through an IMPLICIT type or a RESULT variable, because
895 by definition contained functions are contained namespace they're contained
896 in, not in a sibling or parent namespace. */
899 resolve_contained_functions (gfc_namespace *ns)
901 gfc_namespace *child;
904 resolve_formal_arglists (ns);
906 for (child = ns->contained; child; child = child->sibling)
908 /* Resolve alternate entry points first. */
909 resolve_entries (child);
911 /* Then check function return types. */
912 resolve_contained_fntype (child->proc_name, child);
913 for (el = child->entries; el; el = el->next)
914 resolve_contained_fntype (el->sym, child);
919 /* Resolve all of the elements of a structure constructor and make sure that
920 the types are correct. The 'init' flag indicates that the given
921 constructor is an initializer. */
924 resolve_structure_cons (gfc_expr *expr, int init)
926 gfc_constructor *cons;
933 if (expr->ts.type == BT_DERIVED)
934 resolve_symbol (expr->ts.u.derived);
936 cons = gfc_constructor_first (expr->value.constructor);
937 /* A constructor may have references if it is the result of substituting a
938 parameter variable. In this case we just pull out the component we
941 comp = expr->ref->u.c.sym->components;
943 comp = expr->ts.u.derived->components;
945 /* See if the user is trying to invoke a structure constructor for one of
946 the iso_c_binding derived types. */
947 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
948 && expr->ts.u.derived->ts.is_iso_c && cons
949 && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
951 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
952 expr->ts.u.derived->name, &(expr->where));
956 /* Return if structure constructor is c_null_(fun)prt. */
957 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
958 && expr->ts.u.derived->ts.is_iso_c && cons
959 && cons->expr && cons->expr->expr_type == EXPR_NULL)
962 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
969 if (gfc_resolve_expr (cons->expr) == FAILURE)
975 rank = comp->as ? comp->as->rank : 0;
976 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
977 && (comp->attr.allocatable || cons->expr->rank))
979 gfc_error ("The rank of the element in the derived type "
980 "constructor at %L does not match that of the "
981 "component (%d/%d)", &cons->expr->where,
982 cons->expr->rank, rank);
986 /* If we don't have the right type, try to convert it. */
988 if (!comp->attr.proc_pointer &&
989 !gfc_compare_types (&cons->expr->ts, &comp->ts))
992 if (strcmp (comp->name, "_extends") == 0)
994 /* Can afford to be brutal with the _extends initializer.
995 The derived type can get lost because it is PRIVATE
996 but it is not usage constrained by the standard. */
997 cons->expr->ts = comp->ts;
1000 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1001 gfc_error ("The element in the derived type constructor at %L, "
1002 "for pointer component '%s', is %s but should be %s",
1003 &cons->expr->where, comp->name,
1004 gfc_basic_typename (cons->expr->ts.type),
1005 gfc_basic_typename (comp->ts.type));
1007 t = gfc_convert_type (cons->expr, &comp->ts, 1);
1010 /* For strings, the length of the constructor should be the same as
1011 the one of the structure, ensure this if the lengths are known at
1012 compile time and when we are dealing with PARAMETER or structure
1014 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1015 && comp->ts.u.cl->length
1016 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1017 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1018 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1019 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1020 comp->ts.u.cl->length->value.integer) != 0)
1022 if (cons->expr->expr_type == EXPR_VARIABLE
1023 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1025 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1026 to make use of the gfc_resolve_character_array_constructor
1027 machinery. The expression is later simplified away to
1028 an array of string literals. */
1029 gfc_expr *para = cons->expr;
1030 cons->expr = gfc_get_expr ();
1031 cons->expr->ts = para->ts;
1032 cons->expr->where = para->where;
1033 cons->expr->expr_type = EXPR_ARRAY;
1034 cons->expr->rank = para->rank;
1035 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1036 gfc_constructor_append_expr (&cons->expr->value.constructor,
1037 para, &cons->expr->where);
1039 if (cons->expr->expr_type == EXPR_ARRAY)
1042 p = gfc_constructor_first (cons->expr->value.constructor);
1043 if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
1045 gfc_charlen *cl, *cl2;
1048 for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
1050 if (cl == cons->expr->ts.u.cl)
1058 cl2->next = cl->next;
1060 gfc_free_expr (cl->length);
1064 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1065 cons->expr->ts.u.cl->length_from_typespec = true;
1066 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1067 gfc_resolve_character_array_constructor (cons->expr);
1071 if (cons->expr->expr_type == EXPR_NULL
1072 && !(comp->attr.pointer || comp->attr.allocatable
1073 || comp->attr.proc_pointer
1074 || (comp->ts.type == BT_CLASS
1075 && (CLASS_DATA (comp)->attr.class_pointer
1076 || CLASS_DATA (comp)->attr.allocatable))))
1079 gfc_error ("The NULL in the derived type constructor at %L is "
1080 "being applied to component '%s', which is neither "
1081 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1085 if (!comp->attr.pointer || comp->attr.proc_pointer
1086 || cons->expr->expr_type == EXPR_NULL)
1089 a = gfc_expr_attr (cons->expr);
1091 if (!a.pointer && !a.target)
1094 gfc_error ("The element in the derived type constructor at %L, "
1095 "for pointer component '%s' should be a POINTER or "
1096 "a TARGET", &cons->expr->where, comp->name);
1101 /* F08:C461. Additional checks for pointer initialization. */
1105 gfc_error ("Pointer initialization target at %L "
1106 "must not be ALLOCATABLE ", &cons->expr->where);
1111 gfc_error ("Pointer initialization target at %L "
1112 "must have the SAVE attribute", &cons->expr->where);
1116 /* F2003, C1272 (3). */
1117 if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
1118 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1119 || gfc_is_coindexed (cons->expr)))
1122 gfc_error ("Invalid expression in the derived type constructor for "
1123 "pointer component '%s' at %L in PURE procedure",
1124 comp->name, &cons->expr->where);
1133 /****************** Expression name resolution ******************/
1135 /* Returns 0 if a symbol was not declared with a type or
1136 attribute declaration statement, nonzero otherwise. */
1139 was_declared (gfc_symbol *sym)
1145 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1148 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1149 || a.optional || a.pointer || a.save || a.target || a.volatile_
1150 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1151 || a.asynchronous || a.codimension)
1158 /* Determine if a symbol is generic or not. */
1161 generic_sym (gfc_symbol *sym)
1165 if (sym->attr.generic ||
1166 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1169 if (was_declared (sym) || sym->ns->parent == NULL)
1172 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1179 return generic_sym (s);
1186 /* Determine if a symbol is specific or not. */
1189 specific_sym (gfc_symbol *sym)
1193 if (sym->attr.if_source == IFSRC_IFBODY
1194 || sym->attr.proc == PROC_MODULE
1195 || sym->attr.proc == PROC_INTERNAL
1196 || sym->attr.proc == PROC_ST_FUNCTION
1197 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1198 || sym->attr.external)
1201 if (was_declared (sym) || sym->ns->parent == NULL)
1204 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1206 return (s == NULL) ? 0 : specific_sym (s);
1210 /* Figure out if the procedure is specific, generic or unknown. */
1213 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1217 procedure_kind (gfc_symbol *sym)
1219 if (generic_sym (sym))
1220 return PTYPE_GENERIC;
1222 if (specific_sym (sym))
1223 return PTYPE_SPECIFIC;
1225 return PTYPE_UNKNOWN;
1228 /* Check references to assumed size arrays. The flag need_full_assumed_size
1229 is nonzero when matching actual arguments. */
1231 static int need_full_assumed_size = 0;
1234 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1236 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1239 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1240 What should it be? */
1241 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1242 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1243 && (e->ref->u.ar.type == AR_FULL))
1245 gfc_error ("The upper bound in the last dimension must "
1246 "appear in the reference to the assumed size "
1247 "array '%s' at %L", sym->name, &e->where);
1254 /* Look for bad assumed size array references in argument expressions
1255 of elemental and array valued intrinsic procedures. Since this is
1256 called from procedure resolution functions, it only recurses at
1260 resolve_assumed_size_actual (gfc_expr *e)
1265 switch (e->expr_type)
1268 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1273 if (resolve_assumed_size_actual (e->value.op.op1)
1274 || resolve_assumed_size_actual (e->value.op.op2))
1285 /* Check a generic procedure, passed as an actual argument, to see if
1286 there is a matching specific name. If none, it is an error, and if
1287 more than one, the reference is ambiguous. */
1289 count_specific_procs (gfc_expr *e)
1296 sym = e->symtree->n.sym;
1298 for (p = sym->generic; p; p = p->next)
1299 if (strcmp (sym->name, p->sym->name) == 0)
1301 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1307 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1311 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1312 "argument at %L", sym->name, &e->where);
1318 /* See if a call to sym could possibly be a not allowed RECURSION because of
1319 a missing RECURIVE declaration. This means that either sym is the current
1320 context itself, or sym is the parent of a contained procedure calling its
1321 non-RECURSIVE containing procedure.
1322 This also works if sym is an ENTRY. */
1325 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1327 gfc_symbol* proc_sym;
1328 gfc_symbol* context_proc;
1329 gfc_namespace* real_context;
1331 if (sym->attr.flavor == FL_PROGRAM)
1334 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1336 /* If we've got an ENTRY, find real procedure. */
1337 if (sym->attr.entry && sym->ns->entries)
1338 proc_sym = sym->ns->entries->sym;
1342 /* If sym is RECURSIVE, all is well of course. */
1343 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1346 /* Find the context procedure's "real" symbol if it has entries.
1347 We look for a procedure symbol, so recurse on the parents if we don't
1348 find one (like in case of a BLOCK construct). */
1349 for (real_context = context; ; real_context = real_context->parent)
1351 /* We should find something, eventually! */
1352 gcc_assert (real_context);
1354 context_proc = (real_context->entries ? real_context->entries->sym
1355 : real_context->proc_name);
1357 /* In some special cases, there may not be a proc_name, like for this
1359 real(bad_kind()) function foo () ...
1360 when checking the call to bad_kind ().
1361 In these cases, we simply return here and assume that the
1366 if (context_proc->attr.flavor != FL_LABEL)
1370 /* A call from sym's body to itself is recursion, of course. */
1371 if (context_proc == proc_sym)
1374 /* The same is true if context is a contained procedure and sym the
1376 if (context_proc->attr.contained)
1378 gfc_symbol* parent_proc;
1380 gcc_assert (context->parent);
1381 parent_proc = (context->parent->entries ? context->parent->entries->sym
1382 : context->parent->proc_name);
1384 if (parent_proc == proc_sym)
1392 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1393 its typespec and formal argument list. */
1396 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1398 gfc_intrinsic_sym* isym = NULL;
1404 /* We already know this one is an intrinsic, so we don't call
1405 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1406 gfc_find_subroutine directly to check whether it is a function or
1409 if (sym->intmod_sym_id)
1410 isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
1412 isym = gfc_find_function (sym->name);
1416 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1417 && !sym->attr.implicit_type)
1418 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1419 " ignored", sym->name, &sym->declared_at);
1421 if (!sym->attr.function &&
1422 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1427 else if ((isym = gfc_find_subroutine (sym->name)))
1429 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1431 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1432 " specifier", sym->name, &sym->declared_at);
1436 if (!sym->attr.subroutine &&
1437 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1442 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1447 gfc_copy_formal_args_intr (sym, isym);
1449 /* Check it is actually available in the standard settings. */
1450 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1453 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1454 " available in the current standard settings but %s. Use"
1455 " an appropriate -std=* option or enable -fall-intrinsics"
1456 " in order to use it.",
1457 sym->name, &sym->declared_at, symstd);
1465 /* Resolve a procedure expression, like passing it to a called procedure or as
1466 RHS for a procedure pointer assignment. */
1469 resolve_procedure_expression (gfc_expr* expr)
1473 if (expr->expr_type != EXPR_VARIABLE)
1475 gcc_assert (expr->symtree);
1477 sym = expr->symtree->n.sym;
1479 if (sym->attr.intrinsic)
1480 resolve_intrinsic (sym, &expr->where);
1482 if (sym->attr.flavor != FL_PROCEDURE
1483 || (sym->attr.function && sym->result == sym))
1486 /* A non-RECURSIVE procedure that is used as procedure expression within its
1487 own body is in danger of being called recursively. */
1488 if (is_illegal_recursion (sym, gfc_current_ns))
1489 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1490 " itself recursively. Declare it RECURSIVE or use"
1491 " -frecursive", sym->name, &expr->where);
1497 /* Resolve an actual argument list. Most of the time, this is just
1498 resolving the expressions in the list.
1499 The exception is that we sometimes have to decide whether arguments
1500 that look like procedure arguments are really simple variable
1504 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1505 bool no_formal_args)
1508 gfc_symtree *parent_st;
1510 int save_need_full_assumed_size;
1511 gfc_component *comp;
1513 for (; arg; arg = arg->next)
1518 /* Check the label is a valid branching target. */
1521 if (arg->label->defined == ST_LABEL_UNKNOWN)
1523 gfc_error ("Label %d referenced at %L is never defined",
1524 arg->label->value, &arg->label->where);
1531 if (gfc_is_proc_ptr_comp (e, &comp))
1534 if (e->expr_type == EXPR_PPC)
1536 if (comp->as != NULL)
1537 e->rank = comp->as->rank;
1538 e->expr_type = EXPR_FUNCTION;
1540 if (gfc_resolve_expr (e) == FAILURE)
1545 if (e->expr_type == EXPR_VARIABLE
1546 && e->symtree->n.sym->attr.generic
1548 && count_specific_procs (e) != 1)
1551 if (e->ts.type != BT_PROCEDURE)
1553 save_need_full_assumed_size = need_full_assumed_size;
1554 if (e->expr_type != EXPR_VARIABLE)
1555 need_full_assumed_size = 0;
1556 if (gfc_resolve_expr (e) != SUCCESS)
1558 need_full_assumed_size = save_need_full_assumed_size;
1562 /* See if the expression node should really be a variable reference. */
1564 sym = e->symtree->n.sym;
1566 if (sym->attr.flavor == FL_PROCEDURE
1567 || sym->attr.intrinsic
1568 || sym->attr.external)
1572 /* If a procedure is not already determined to be something else
1573 check if it is intrinsic. */
1574 if (!sym->attr.intrinsic
1575 && !(sym->attr.external || sym->attr.use_assoc
1576 || sym->attr.if_source == IFSRC_IFBODY)
1577 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1578 sym->attr.intrinsic = 1;
1580 if (sym->attr.proc == PROC_ST_FUNCTION)
1582 gfc_error ("Statement function '%s' at %L is not allowed as an "
1583 "actual argument", sym->name, &e->where);
1586 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1587 sym->attr.subroutine);
1588 if (sym->attr.intrinsic && actual_ok == 0)
1590 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1591 "actual argument", sym->name, &e->where);
1594 if (sym->attr.contained && !sym->attr.use_assoc
1595 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1597 if (gfc_notify_std (GFC_STD_F2008,
1598 "Fortran 2008: Internal procedure '%s' is"
1599 " used as actual argument at %L",
1600 sym->name, &e->where) == FAILURE)
1604 if (sym->attr.elemental && !sym->attr.intrinsic)
1606 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1607 "allowed as an actual argument at %L", sym->name,
1611 /* Check if a generic interface has a specific procedure
1612 with the same name before emitting an error. */
1613 if (sym->attr.generic && count_specific_procs (e) != 1)
1616 /* Just in case a specific was found for the expression. */
1617 sym = e->symtree->n.sym;
1619 /* If the symbol is the function that names the current (or
1620 parent) scope, then we really have a variable reference. */
1622 if (gfc_is_function_return_value (sym, sym->ns))
1625 /* If all else fails, see if we have a specific intrinsic. */
1626 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1628 gfc_intrinsic_sym *isym;
1630 isym = gfc_find_function (sym->name);
1631 if (isym == NULL || !isym->specific)
1633 gfc_error ("Unable to find a specific INTRINSIC procedure "
1634 "for the reference '%s' at %L", sym->name,
1639 sym->attr.intrinsic = 1;
1640 sym->attr.function = 1;
1643 if (gfc_resolve_expr (e) == FAILURE)
1648 /* See if the name is a module procedure in a parent unit. */
1650 if (was_declared (sym) || sym->ns->parent == NULL)
1653 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1655 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1659 if (parent_st == NULL)
1662 sym = parent_st->n.sym;
1663 e->symtree = parent_st; /* Point to the right thing. */
1665 if (sym->attr.flavor == FL_PROCEDURE
1666 || sym->attr.intrinsic
1667 || sym->attr.external)
1669 if (gfc_resolve_expr (e) == FAILURE)
1675 e->expr_type = EXPR_VARIABLE;
1677 if (sym->as != NULL)
1679 e->rank = sym->as->rank;
1680 e->ref = gfc_get_ref ();
1681 e->ref->type = REF_ARRAY;
1682 e->ref->u.ar.type = AR_FULL;
1683 e->ref->u.ar.as = sym->as;
1686 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1687 primary.c (match_actual_arg). If above code determines that it
1688 is a variable instead, it needs to be resolved as it was not
1689 done at the beginning of this function. */
1690 save_need_full_assumed_size = need_full_assumed_size;
1691 if (e->expr_type != EXPR_VARIABLE)
1692 need_full_assumed_size = 0;
1693 if (gfc_resolve_expr (e) != SUCCESS)
1695 need_full_assumed_size = save_need_full_assumed_size;
1698 /* Check argument list functions %VAL, %LOC and %REF. There is
1699 nothing to do for %REF. */
1700 if (arg->name && arg->name[0] == '%')
1702 if (strncmp ("%VAL", arg->name, 4) == 0)
1704 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1706 gfc_error ("By-value argument at %L is not of numeric "
1713 gfc_error ("By-value argument at %L cannot be an array or "
1714 "an array section", &e->where);
1718 /* Intrinsics are still PROC_UNKNOWN here. However,
1719 since same file external procedures are not resolvable
1720 in gfortran, it is a good deal easier to leave them to
1722 if (ptype != PROC_UNKNOWN
1723 && ptype != PROC_DUMMY
1724 && ptype != PROC_EXTERNAL
1725 && ptype != PROC_MODULE)
1727 gfc_error ("By-value argument at %L is not allowed "
1728 "in this context", &e->where);
1733 /* Statement functions have already been excluded above. */
1734 else if (strncmp ("%LOC", arg->name, 4) == 0
1735 && e->ts.type == BT_PROCEDURE)
1737 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1739 gfc_error ("Passing internal procedure at %L by location "
1740 "not allowed", &e->where);
1746 /* Fortran 2008, C1237. */
1747 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1748 && gfc_has_ultimate_pointer (e))
1750 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1751 "component", &e->where);
1760 /* Do the checks of the actual argument list that are specific to elemental
1761 procedures. If called with c == NULL, we have a function, otherwise if
1762 expr == NULL, we have a subroutine. */
1765 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1767 gfc_actual_arglist *arg0;
1768 gfc_actual_arglist *arg;
1769 gfc_symbol *esym = NULL;
1770 gfc_intrinsic_sym *isym = NULL;
1772 gfc_intrinsic_arg *iformal = NULL;
1773 gfc_formal_arglist *eformal = NULL;
1774 bool formal_optional = false;
1775 bool set_by_optional = false;
1779 /* Is this an elemental procedure? */
1780 if (expr && expr->value.function.actual != NULL)
1782 if (expr->value.function.esym != NULL
1783 && expr->value.function.esym->attr.elemental)
1785 arg0 = expr->value.function.actual;
1786 esym = expr->value.function.esym;
1788 else if (expr->value.function.isym != NULL
1789 && expr->value.function.isym->elemental)
1791 arg0 = expr->value.function.actual;
1792 isym = expr->value.function.isym;
1797 else if (c && c->ext.actual != NULL)
1799 arg0 = c->ext.actual;
1801 if (c->resolved_sym)
1802 esym = c->resolved_sym;
1804 esym = c->symtree->n.sym;
1807 if (!esym->attr.elemental)
1813 /* The rank of an elemental is the rank of its array argument(s). */
1814 for (arg = arg0; arg; arg = arg->next)
1816 if (arg->expr != NULL && arg->expr->rank > 0)
1818 rank = arg->expr->rank;
1819 if (arg->expr->expr_type == EXPR_VARIABLE
1820 && arg->expr->symtree->n.sym->attr.optional)
1821 set_by_optional = true;
1823 /* Function specific; set the result rank and shape. */
1827 if (!expr->shape && arg->expr->shape)
1829 expr->shape = gfc_get_shape (rank);
1830 for (i = 0; i < rank; i++)
1831 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1838 /* If it is an array, it shall not be supplied as an actual argument
1839 to an elemental procedure unless an array of the same rank is supplied
1840 as an actual argument corresponding to a nonoptional dummy argument of
1841 that elemental procedure(12.4.1.5). */
1842 formal_optional = false;
1844 iformal = isym->formal;
1846 eformal = esym->formal;
1848 for (arg = arg0; arg; arg = arg->next)
1852 if (eformal->sym && eformal->sym->attr.optional)
1853 formal_optional = true;
1854 eformal = eformal->next;
1856 else if (isym && iformal)
1858 if (iformal->optional)
1859 formal_optional = true;
1860 iformal = iformal->next;
1863 formal_optional = true;
1865 if (pedantic && arg->expr != NULL
1866 && arg->expr->expr_type == EXPR_VARIABLE
1867 && arg->expr->symtree->n.sym->attr.optional
1870 && (set_by_optional || arg->expr->rank != rank)
1871 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1873 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1874 "MISSING, it cannot be the actual argument of an "
1875 "ELEMENTAL procedure unless there is a non-optional "
1876 "argument with the same rank (12.4.1.5)",
1877 arg->expr->symtree->n.sym->name, &arg->expr->where);
1882 for (arg = arg0; arg; arg = arg->next)
1884 if (arg->expr == NULL || arg->expr->rank == 0)
1887 /* Being elemental, the last upper bound of an assumed size array
1888 argument must be present. */
1889 if (resolve_assumed_size_actual (arg->expr))
1892 /* Elemental procedure's array actual arguments must conform. */
1895 if (gfc_check_conformance (arg->expr, e,
1896 "elemental procedure") == FAILURE)
1903 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1904 is an array, the intent inout/out variable needs to be also an array. */
1905 if (rank > 0 && esym && expr == NULL)
1906 for (eformal = esym->formal, arg = arg0; arg && eformal;
1907 arg = arg->next, eformal = eformal->next)
1908 if ((eformal->sym->attr.intent == INTENT_OUT
1909 || eformal->sym->attr.intent == INTENT_INOUT)
1910 && arg->expr && arg->expr->rank == 0)
1912 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1913 "ELEMENTAL subroutine '%s' is a scalar, but another "
1914 "actual argument is an array", &arg->expr->where,
1915 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1916 : "INOUT", eformal->sym->name, esym->name);
1923 /* This function does the checking of references to global procedures
1924 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1925 77 and 95 standards. It checks for a gsymbol for the name, making
1926 one if it does not already exist. If it already exists, then the
1927 reference being resolved must correspond to the type of gsymbol.
1928 Otherwise, the new symbol is equipped with the attributes of the
1929 reference. The corresponding code that is called in creating
1930 global entities is parse.c.
1932 In addition, for all but -std=legacy, the gsymbols are used to
1933 check the interfaces of external procedures from the same file.
1934 The namespace of the gsymbol is resolved and then, once this is
1935 done the interface is checked. */
1939 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
1941 if (!gsym_ns->proc_name->attr.recursive)
1944 if (sym->ns == gsym_ns)
1947 if (sym->ns->parent && sym->ns->parent == gsym_ns)
1954 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
1956 if (gsym_ns->entries)
1958 gfc_entry_list *entry = gsym_ns->entries;
1960 for (; entry; entry = entry->next)
1962 if (strcmp (sym->name, entry->sym->name) == 0)
1964 if (strcmp (gsym_ns->proc_name->name,
1965 sym->ns->proc_name->name) == 0)
1969 && strcmp (gsym_ns->proc_name->name,
1970 sym->ns->parent->proc_name->name) == 0)
1979 resolve_global_procedure (gfc_symbol *sym, locus *where,
1980 gfc_actual_arglist **actual, int sub)
1984 enum gfc_symbol_type type;
1986 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1988 gsym = gfc_get_gsymbol (sym->name);
1990 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1991 gfc_global_used (gsym, where);
1993 if (gfc_option.flag_whole_file
1994 && (sym->attr.if_source == IFSRC_UNKNOWN
1995 || sym->attr.if_source == IFSRC_IFBODY)
1996 && gsym->type != GSYM_UNKNOWN
1998 && gsym->ns->resolved != -1
1999 && gsym->ns->proc_name
2000 && not_in_recursive (sym, gsym->ns)
2001 && not_entry_self_reference (sym, gsym->ns))
2003 gfc_symbol *def_sym;
2005 /* Resolve the gsymbol namespace if needed. */
2006 if (!gsym->ns->resolved)
2008 gfc_dt_list *old_dt_list;
2010 /* Stash away derived types so that the backend_decls do not
2012 old_dt_list = gfc_derived_types;
2013 gfc_derived_types = NULL;
2015 gfc_resolve (gsym->ns);
2017 /* Store the new derived types with the global namespace. */
2018 if (gfc_derived_types)
2019 gsym->ns->derived_types = gfc_derived_types;
2021 /* Restore the derived types of this namespace. */
2022 gfc_derived_types = old_dt_list;
2025 /* Make sure that translation for the gsymbol occurs before
2026 the procedure currently being resolved. */
2027 ns = gfc_global_ns_list;
2028 for (; ns && ns != gsym->ns; ns = ns->sibling)
2030 if (ns->sibling == gsym->ns)
2032 ns->sibling = gsym->ns->sibling;
2033 gsym->ns->sibling = gfc_global_ns_list;
2034 gfc_global_ns_list = gsym->ns;
2039 def_sym = gsym->ns->proc_name;
2040 if (def_sym->attr.entry_master)
2042 gfc_entry_list *entry;
2043 for (entry = gsym->ns->entries; entry; entry = entry->next)
2044 if (strcmp (entry->sym->name, sym->name) == 0)
2046 def_sym = entry->sym;
2051 /* Differences in constant character lengths. */
2052 if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2054 long int l1 = 0, l2 = 0;
2055 gfc_charlen *cl1 = sym->ts.u.cl;
2056 gfc_charlen *cl2 = def_sym->ts.u.cl;
2059 && cl1->length != NULL
2060 && cl1->length->expr_type == EXPR_CONSTANT)
2061 l1 = mpz_get_si (cl1->length->value.integer);
2064 && cl2->length != NULL
2065 && cl2->length->expr_type == EXPR_CONSTANT)
2066 l2 = mpz_get_si (cl2->length->value.integer);
2068 if (l1 && l2 && l1 != l2)
2069 gfc_error ("Character length mismatch in return type of "
2070 "function '%s' at %L (%ld/%ld)", sym->name,
2071 &sym->declared_at, l1, l2);
2074 /* Type mismatch of function return type and expected type. */
2075 if (sym->attr.function
2076 && !gfc_compare_types (&sym->ts, &def_sym->ts))
2077 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2078 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2079 gfc_typename (&def_sym->ts));
2081 if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2083 gfc_formal_arglist *arg = def_sym->formal;
2084 for ( ; arg; arg = arg->next)
2087 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2088 else if (arg->sym->attr.allocatable
2089 || arg->sym->attr.asynchronous
2090 || arg->sym->attr.optional
2091 || arg->sym->attr.pointer
2092 || arg->sym->attr.target
2093 || arg->sym->attr.value
2094 || arg->sym->attr.volatile_)
2096 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2097 "has an attribute that requires an explicit "
2098 "interface for this procedure", arg->sym->name,
2099 sym->name, &sym->declared_at);
2102 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2103 else if (arg->sym && arg->sym->as
2104 && arg->sym->as->type == AS_ASSUMED_SHAPE)
2106 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2107 "argument '%s' must have an explicit interface",
2108 sym->name, &sym->declared_at, arg->sym->name);
2111 /* F2008, 12.4.2.2 (2c) */
2112 else if (arg->sym->attr.codimension)
2114 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2115 "'%s' must have an explicit interface",
2116 sym->name, &sym->declared_at, arg->sym->name);
2119 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2120 else if (false) /* TODO: is a parametrized derived type */
2122 gfc_error ("Procedure '%s' at %L with parametrized derived "
2123 "type argument '%s' must have an explicit "
2124 "interface", sym->name, &sym->declared_at,
2128 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2129 else if (arg->sym->ts.type == BT_CLASS)
2131 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2132 "argument '%s' must have an explicit interface",
2133 sym->name, &sym->declared_at, arg->sym->name);
2138 if (def_sym->attr.function)
2140 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2141 if (def_sym->as && def_sym->as->rank
2142 && (!sym->as || sym->as->rank != def_sym->as->rank))
2143 gfc_error ("The reference to function '%s' at %L either needs an "
2144 "explicit INTERFACE or the rank is incorrect", sym->name,
2147 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2148 if ((def_sym->result->attr.pointer
2149 || def_sym->result->attr.allocatable)
2150 && (sym->attr.if_source != IFSRC_IFBODY
2151 || def_sym->result->attr.pointer
2152 != sym->result->attr.pointer
2153 || def_sym->result->attr.allocatable
2154 != sym->result->attr.allocatable))
2155 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2156 "result must have an explicit interface", sym->name,
2159 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2160 if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2161 && def_sym->ts.u.cl->length != NULL)
2163 gfc_charlen *cl = sym->ts.u.cl;
2165 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2166 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2168 gfc_error ("Nonconstant character-length function '%s' at %L "
2169 "must have an explicit interface", sym->name,
2175 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2176 if (def_sym->attr.elemental && !sym->attr.elemental)
2178 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2179 "interface", sym->name, &sym->declared_at);
2182 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2183 if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2185 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2186 "an explicit interface", sym->name, &sym->declared_at);
2189 if (gfc_option.flag_whole_file == 1
2190 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2191 && !(gfc_option.warn_std & GFC_STD_GNU)))
2192 gfc_errors_to_warnings (1);
2194 if (sym->attr.if_source != IFSRC_IFBODY)
2195 gfc_procedure_use (def_sym, actual, where);
2197 gfc_errors_to_warnings (0);
2200 if (gsym->type == GSYM_UNKNOWN)
2203 gsym->where = *where;
2210 /************* Function resolution *************/
2212 /* Resolve a function call known to be generic.
2213 Section 14.1.2.4.1. */
2216 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2220 if (sym->attr.generic)
2222 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2225 expr->value.function.name = s->name;
2226 expr->value.function.esym = s;
2228 if (s->ts.type != BT_UNKNOWN)
2230 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2231 expr->ts = s->result->ts;
2234 expr->rank = s->as->rank;
2235 else if (s->result != NULL && s->result->as != NULL)
2236 expr->rank = s->result->as->rank;
2238 gfc_set_sym_referenced (expr->value.function.esym);
2243 /* TODO: Need to search for elemental references in generic
2247 if (sym->attr.intrinsic)
2248 return gfc_intrinsic_func_interface (expr, 0);
2255 resolve_generic_f (gfc_expr *expr)
2260 sym = expr->symtree->n.sym;
2264 m = resolve_generic_f0 (expr, sym);
2267 else if (m == MATCH_ERROR)
2271 if (sym->ns->parent == NULL)
2273 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2277 if (!generic_sym (sym))
2281 /* Last ditch attempt. See if the reference is to an intrinsic
2282 that possesses a matching interface. 14.1.2.4 */
2283 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
2285 gfc_error ("There is no specific function for the generic '%s' at %L",
2286 expr->symtree->n.sym->name, &expr->where);
2290 m = gfc_intrinsic_func_interface (expr, 0);
2294 gfc_error ("Generic function '%s' at %L is not consistent with a "
2295 "specific intrinsic interface", expr->symtree->n.sym->name,
2302 /* Resolve a function call known to be specific. */
2305 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2309 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2311 if (sym->attr.dummy)
2313 sym->attr.proc = PROC_DUMMY;
2317 sym->attr.proc = PROC_EXTERNAL;
2321 if (sym->attr.proc == PROC_MODULE
2322 || sym->attr.proc == PROC_ST_FUNCTION
2323 || sym->attr.proc == PROC_INTERNAL)
2326 if (sym->attr.intrinsic)
2328 m = gfc_intrinsic_func_interface (expr, 1);
2332 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2333 "with an intrinsic", sym->name, &expr->where);
2341 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2344 expr->ts = sym->result->ts;
2347 expr->value.function.name = sym->name;
2348 expr->value.function.esym = sym;
2349 if (sym->as != NULL)
2350 expr->rank = sym->as->rank;
2357 resolve_specific_f (gfc_expr *expr)
2362 sym = expr->symtree->n.sym;
2366 m = resolve_specific_f0 (sym, expr);
2369 if (m == MATCH_ERROR)
2372 if (sym->ns->parent == NULL)
2375 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2381 gfc_error ("Unable to resolve the specific function '%s' at %L",
2382 expr->symtree->n.sym->name, &expr->where);
2388 /* Resolve a procedure call not known to be generic nor specific. */
2391 resolve_unknown_f (gfc_expr *expr)
2396 sym = expr->symtree->n.sym;
2398 if (sym->attr.dummy)
2400 sym->attr.proc = PROC_DUMMY;
2401 expr->value.function.name = sym->name;
2405 /* See if we have an intrinsic function reference. */
2407 if (gfc_is_intrinsic (sym, 0, expr->where))
2409 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2414 /* The reference is to an external name. */
2416 sym->attr.proc = PROC_EXTERNAL;
2417 expr->value.function.name = sym->name;
2418 expr->value.function.esym = expr->symtree->n.sym;
2420 if (sym->as != NULL)
2421 expr->rank = sym->as->rank;
2423 /* Type of the expression is either the type of the symbol or the
2424 default type of the symbol. */
2427 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2429 if (sym->ts.type != BT_UNKNOWN)
2433 ts = gfc_get_default_type (sym->name, sym->ns);
2435 if (ts->type == BT_UNKNOWN)
2437 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2438 sym->name, &expr->where);
2449 /* Return true, if the symbol is an external procedure. */
2451 is_external_proc (gfc_symbol *sym)
2453 if (!sym->attr.dummy && !sym->attr.contained
2454 && !(sym->attr.intrinsic
2455 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2456 && sym->attr.proc != PROC_ST_FUNCTION
2457 && !sym->attr.proc_pointer
2458 && !sym->attr.use_assoc
2466 /* Figure out if a function reference is pure or not. Also set the name
2467 of the function for a potential error message. Return nonzero if the
2468 function is PURE, zero if not. */
2470 pure_stmt_function (gfc_expr *, gfc_symbol *);
2473 pure_function (gfc_expr *e, const char **name)
2479 if (e->symtree != NULL
2480 && e->symtree->n.sym != NULL
2481 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2482 return pure_stmt_function (e, e->symtree->n.sym);
2484 if (e->value.function.esym)
2486 pure = gfc_pure (e->value.function.esym);
2487 *name = e->value.function.esym->name;
2489 else if (e->value.function.isym)
2491 pure = e->value.function.isym->pure
2492 || e->value.function.isym->elemental;
2493 *name = e->value.function.isym->name;
2497 /* Implicit functions are not pure. */
2499 *name = e->value.function.name;
2507 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2508 int *f ATTRIBUTE_UNUSED)
2512 /* Don't bother recursing into other statement functions
2513 since they will be checked individually for purity. */
2514 if (e->expr_type != EXPR_FUNCTION
2516 || e->symtree->n.sym == sym
2517 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2520 return pure_function (e, &name) ? false : true;
2525 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2527 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2532 is_scalar_expr_ptr (gfc_expr *expr)
2534 gfc_try retval = SUCCESS;
2539 /* See if we have a gfc_ref, which means we have a substring, array
2540 reference, or a component. */
2541 if (expr->ref != NULL)
2544 while (ref->next != NULL)
2550 if (ref->u.ss.length != NULL
2551 && ref->u.ss.length->length != NULL
2553 && ref->u.ss.start->expr_type == EXPR_CONSTANT
2555 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
2557 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
2558 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
2559 if (end - start + 1 != 1)
2566 if (ref->u.ar.type == AR_ELEMENT)
2568 else if (ref->u.ar.type == AR_FULL)
2570 /* The user can give a full array if the array is of size 1. */
2571 if (ref->u.ar.as != NULL
2572 && ref->u.ar.as->rank == 1
2573 && ref->u.ar.as->type == AS_EXPLICIT
2574 && ref->u.ar.as->lower[0] != NULL
2575 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2576 && ref->u.ar.as->upper[0] != NULL
2577 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2579 /* If we have a character string, we need to check if
2580 its length is one. */
2581 if (expr->ts.type == BT_CHARACTER)
2583 if (expr->ts.u.cl == NULL
2584 || expr->ts.u.cl->length == NULL
2585 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2591 /* We have constant lower and upper bounds. If the
2592 difference between is 1, it can be considered a
2594 start = (int) mpz_get_si
2595 (ref->u.ar.as->lower[0]->value.integer);
2596 end = (int) mpz_get_si
2597 (ref->u.ar.as->upper[0]->value.integer);
2598 if (end - start + 1 != 1)
2613 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2615 /* Character string. Make sure it's of length 1. */
2616 if (expr->ts.u.cl == NULL
2617 || expr->ts.u.cl->length == NULL
2618 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2621 else if (expr->rank != 0)
2628 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2629 and, in the case of c_associated, set the binding label based on
2633 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2634 gfc_symbol **new_sym)
2636 char name[GFC_MAX_SYMBOL_LEN + 1];
2637 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2638 int optional_arg = 0;
2639 gfc_try retval = SUCCESS;
2640 gfc_symbol *args_sym;
2641 gfc_typespec *arg_ts;
2642 symbol_attribute arg_attr;
2644 if (args->expr->expr_type == EXPR_CONSTANT
2645 || args->expr->expr_type == EXPR_OP
2646 || args->expr->expr_type == EXPR_NULL)
2648 gfc_error ("Argument to '%s' at %L is not a variable",
2649 sym->name, &(args->expr->where));
2653 args_sym = args->expr->symtree->n.sym;
2655 /* The typespec for the actual arg should be that stored in the expr
2656 and not necessarily that of the expr symbol (args_sym), because
2657 the actual expression could be a part-ref of the expr symbol. */
2658 arg_ts = &(args->expr->ts);
2659 arg_attr = gfc_expr_attr (args->expr);
2661 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2663 /* If the user gave two args then they are providing something for
2664 the optional arg (the second cptr). Therefore, set the name and
2665 binding label to the c_associated for two cptrs. Otherwise,
2666 set c_associated to expect one cptr. */
2670 sprintf (name, "%s_2", sym->name);
2671 sprintf (binding_label, "%s_2", sym->binding_label);
2677 sprintf (name, "%s_1", sym->name);
2678 sprintf (binding_label, "%s_1", sym->binding_label);
2682 /* Get a new symbol for the version of c_associated that
2684 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2686 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2687 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2689 sprintf (name, "%s", sym->name);
2690 sprintf (binding_label, "%s", sym->binding_label);
2692 /* Error check the call. */
2693 if (args->next != NULL)
2695 gfc_error_now ("More actual than formal arguments in '%s' "
2696 "call at %L", name, &(args->expr->where));
2699 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2701 /* Make sure we have either the target or pointer attribute. */
2702 if (!arg_attr.target && !arg_attr.pointer)
2704 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2705 "a TARGET or an associated pointer",
2707 sym->name, &(args->expr->where));
2711 /* See if we have interoperable type and type param. */
2712 if (verify_c_interop (arg_ts) == SUCCESS
2713 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2715 if (args_sym->attr.target == 1)
2717 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2718 has the target attribute and is interoperable. */
2719 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2720 allocatable variable that has the TARGET attribute and
2721 is not an array of zero size. */
2722 if (args_sym->attr.allocatable == 1)
2724 if (args_sym->attr.dimension != 0
2725 && (args_sym->as && args_sym->as->rank == 0))
2727 gfc_error_now ("Allocatable variable '%s' used as a "
2728 "parameter to '%s' at %L must not be "
2729 "an array of zero size",
2730 args_sym->name, sym->name,
2731 &(args->expr->where));
2737 /* A non-allocatable target variable with C
2738 interoperable type and type parameters must be
2740 if (args_sym && args_sym->attr.dimension)
2742 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2744 gfc_error ("Assumed-shape array '%s' at %L "
2745 "cannot be an argument to the "
2746 "procedure '%s' because "
2747 "it is not C interoperable",
2749 &(args->expr->where), sym->name);
2752 else if (args_sym->as->type == AS_DEFERRED)
2754 gfc_error ("Deferred-shape array '%s' at %L "
2755 "cannot be an argument to the "
2756 "procedure '%s' because "
2757 "it is not C interoperable",
2759 &(args->expr->where), sym->name);
2764 /* Make sure it's not a character string. Arrays of
2765 any type should be ok if the variable is of a C
2766 interoperable type. */
2767 if (arg_ts->type == BT_CHARACTER)
2768 if (arg_ts->u.cl != NULL
2769 && (arg_ts->u.cl->length == NULL
2770 || arg_ts->u.cl->length->expr_type
2773 (arg_ts->u.cl->length->value.integer, 1)
2775 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2777 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2778 "at %L must have a length of 1",
2779 args_sym->name, sym->name,
2780 &(args->expr->where));
2785 else if (arg_attr.pointer
2786 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2788 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2790 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2791 "associated scalar POINTER", args_sym->name,
2792 sym->name, &(args->expr->where));
2798 /* The parameter is not required to be C interoperable. If it
2799 is not C interoperable, it must be a nonpolymorphic scalar
2800 with no length type parameters. It still must have either
2801 the pointer or target attribute, and it can be
2802 allocatable (but must be allocated when c_loc is called). */
2803 if (args->expr->rank != 0
2804 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2806 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2807 "scalar", args_sym->name, sym->name,
2808 &(args->expr->where));
2811 else if (arg_ts->type == BT_CHARACTER
2812 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2814 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2815 "%L must have a length of 1",
2816 args_sym->name, sym->name,
2817 &(args->expr->where));
2820 else if (arg_ts->type == BT_CLASS)
2822 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2823 "polymorphic", args_sym->name, sym->name,
2824 &(args->expr->where));
2829 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2831 if (args_sym->attr.flavor != FL_PROCEDURE)
2833 /* TODO: Update this error message to allow for procedure
2834 pointers once they are implemented. */
2835 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2837 args_sym->name, sym->name,
2838 &(args->expr->where));
2841 else if (args_sym->attr.is_bind_c != 1)
2843 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2845 args_sym->name, sym->name,
2846 &(args->expr->where));
2851 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2856 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2857 "iso_c_binding function: '%s'!\n", sym->name);
2864 /* Resolve a function call, which means resolving the arguments, then figuring
2865 out which entity the name refers to. */
2868 resolve_function (gfc_expr *expr)
2870 gfc_actual_arglist *arg;
2875 procedure_type p = PROC_INTRINSIC;
2876 bool no_formal_args;
2880 sym = expr->symtree->n.sym;
2882 /* If this is a procedure pointer component, it has already been resolved. */
2883 if (gfc_is_proc_ptr_comp (expr, NULL))
2886 if (sym && sym->attr.intrinsic
2887 && resolve_intrinsic (sym, &expr->where) == FAILURE)
2890 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2892 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2896 /* If this ia a deferred TBP with an abstract interface (which may
2897 of course be referenced), expr->value.function.esym will be set. */
2898 if (sym && sym->attr.abstract && !expr->value.function.esym)
2900 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2901 sym->name, &expr->where);
2905 /* Switch off assumed size checking and do this again for certain kinds
2906 of procedure, once the procedure itself is resolved. */
2907 need_full_assumed_size++;
2909 if (expr->symtree && expr->symtree->n.sym)
2910 p = expr->symtree->n.sym->attr.proc;
2912 if (expr->value.function.isym && expr->value.function.isym->inquiry)
2913 inquiry_argument = true;
2914 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2916 if (resolve_actual_arglist (expr->value.function.actual,
2917 p, no_formal_args) == FAILURE)
2919 inquiry_argument = false;
2923 inquiry_argument = false;
2925 /* Need to setup the call to the correct c_associated, depending on
2926 the number of cptrs to user gives to compare. */
2927 if (sym && sym->attr.is_iso_c == 1)
2929 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2933 /* Get the symtree for the new symbol (resolved func).
2934 the old one will be freed later, when it's no longer used. */
2935 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2938 /* Resume assumed_size checking. */
2939 need_full_assumed_size--;
2941 /* If the procedure is external, check for usage. */
2942 if (sym && is_external_proc (sym))
2943 resolve_global_procedure (sym, &expr->where,
2944 &expr->value.function.actual, 0);
2946 if (sym && sym->ts.type == BT_CHARACTER
2948 && sym->ts.u.cl->length == NULL
2950 && expr->value.function.esym == NULL
2951 && !sym->attr.contained)
2953 /* Internal procedures are taken care of in resolve_contained_fntype. */
2954 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2955 "be used at %L since it is not a dummy argument",
2956 sym->name, &expr->where);
2960 /* See if function is already resolved. */
2962 if (expr->value.function.name != NULL)
2964 if (expr->ts.type == BT_UNKNOWN)
2970 /* Apply the rules of section 14.1.2. */
2972 switch (procedure_kind (sym))
2975 t = resolve_generic_f (expr);
2978 case PTYPE_SPECIFIC:
2979 t = resolve_specific_f (expr);
2983 t = resolve_unknown_f (expr);
2987 gfc_internal_error ("resolve_function(): bad function type");
2991 /* If the expression is still a function (it might have simplified),
2992 then we check to see if we are calling an elemental function. */
2994 if (expr->expr_type != EXPR_FUNCTION)
2997 temp = need_full_assumed_size;
2998 need_full_assumed_size = 0;
3000 if (resolve_elemental_actual (expr, NULL) == FAILURE)
3003 if (omp_workshare_flag
3004 && expr->value.function.esym
3005 && ! gfc_elemental (expr->value.function.esym))
3007 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3008 "in WORKSHARE construct", expr->value.function.esym->name,
3013 #define GENERIC_ID expr->value.function.isym->id
3014 else if (expr->value.function.actual != NULL
3015 && expr->value.function.isym != NULL
3016 && GENERIC_ID != GFC_ISYM_LBOUND
3017 && GENERIC_ID != GFC_ISYM_LEN
3018 && GENERIC_ID != GFC_ISYM_LOC
3019 && GENERIC_ID != GFC_ISYM_PRESENT)
3021 /* Array intrinsics must also have the last upper bound of an
3022 assumed size array argument. UBOUND and SIZE have to be
3023 excluded from the check if the second argument is anything
3026 for (arg = expr->value.function.actual; arg; arg = arg->next)
3028 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3029 && arg->next != NULL && arg->next->expr)
3031 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3034 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3037 if ((int)mpz_get_si (arg->next->expr->value.integer)
3042 if (arg->expr != NULL
3043 && arg->expr->rank > 0
3044 && resolve_assumed_size_actual (arg->expr))
3050 need_full_assumed_size = temp;
3053 if (!pure_function (expr, &name) && name)
3057 gfc_error ("reference to non-PURE function '%s' at %L inside a "
3058 "FORALL %s", name, &expr->where,
3059 forall_flag == 2 ? "mask" : "block");
3062 else if (gfc_pure (NULL))
3064 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3065 "procedure within a PURE procedure", name, &expr->where);
3070 /* Functions without the RECURSIVE attribution are not allowed to
3071 * call themselves. */
3072 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3075 esym = expr->value.function.esym;
3077 if (is_illegal_recursion (esym, gfc_current_ns))
3079 if (esym->attr.entry && esym->ns->entries)
3080 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3081 " function '%s' is not RECURSIVE",
3082 esym->name, &expr->where, esym->ns->entries->sym->name);
3084 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3085 " is not RECURSIVE", esym->name, &expr->where);
3091 /* Character lengths of use associated functions may contains references to
3092 symbols not referenced from the current program unit otherwise. Make sure
3093 those symbols are marked as referenced. */
3095 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3096 && expr->value.function.esym->attr.use_assoc)
3098 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3101 /* Make sure that the expression has a typespec that works. */
3102 if (expr->ts.type == BT_UNKNOWN)
3104 if (expr->symtree->n.sym->result
3105 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3106 && !expr->symtree->n.sym->result->attr.proc_pointer)
3107 expr->ts = expr->symtree->n.sym->result->ts;
3114 /************* Subroutine resolution *************/
3117 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3123 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3124 sym->name, &c->loc);
3125 else if (gfc_pure (NULL))
3126 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3132 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3136 if (sym->attr.generic)
3138 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3141 c->resolved_sym = s;
3142 pure_subroutine (c, s);
3146 /* TODO: Need to search for elemental references in generic interface. */
3149 if (sym->attr.intrinsic)
3150 return gfc_intrinsic_sub_interface (c, 0);
3157 resolve_generic_s (gfc_code *c)
3162 sym = c->symtree->n.sym;
3166 m = resolve_generic_s0 (c, sym);
3169 else if (m == MATCH_ERROR)
3173 if (sym->ns->parent == NULL)
3175 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3179 if (!generic_sym (sym))
3183 /* Last ditch attempt. See if the reference is to an intrinsic
3184 that possesses a matching interface. 14.1.2.4 */
3185 sym = c->symtree->n.sym;
3187 if (!gfc_is_intrinsic (sym, 1, c->loc))
3189 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3190 sym->name, &c->loc);
3194 m = gfc_intrinsic_sub_interface (c, 0);
3198 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3199 "intrinsic subroutine interface", sym->name, &c->loc);
3205 /* Set the name and binding label of the subroutine symbol in the call
3206 expression represented by 'c' to include the type and kind of the
3207 second parameter. This function is for resolving the appropriate
3208 version of c_f_pointer() and c_f_procpointer(). For example, a
3209 call to c_f_pointer() for a default integer pointer could have a
3210 name of c_f_pointer_i4. If no second arg exists, which is an error
3211 for these two functions, it defaults to the generic symbol's name
3212 and binding label. */
3215 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3216 char *name, char *binding_label)
3218 gfc_expr *arg = NULL;
3222 /* The second arg of c_f_pointer and c_f_procpointer determines
3223 the type and kind for the procedure name. */
3224 arg = c->ext.actual->next->expr;
3228 /* Set up the name to have the given symbol's name,
3229 plus the type and kind. */
3230 /* a derived type is marked with the type letter 'u' */
3231 if (arg->ts.type == BT_DERIVED)
3234 kind = 0; /* set the kind as 0 for now */
3238 type = gfc_type_letter (arg->ts.type);
3239 kind = arg->ts.kind;
3242 if (arg->ts.type == BT_CHARACTER)
3243 /* Kind info for character strings not needed. */
3246 sprintf (name, "%s_%c%d", sym->name, type, kind);
3247 /* Set up the binding label as the given symbol's label plus
3248 the type and kind. */
3249 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
3253 /* If the second arg is missing, set the name and label as
3254 was, cause it should at least be found, and the missing
3255 arg error will be caught by compare_parameters(). */
3256 sprintf (name, "%s", sym->name);
3257 sprintf (binding_label, "%s", sym->binding_label);
3264 /* Resolve a generic version of the iso_c_binding procedure given
3265 (sym) to the specific one based on the type and kind of the
3266 argument(s). Currently, this function resolves c_f_pointer() and
3267 c_f_procpointer based on the type and kind of the second argument
3268 (FPTR). Other iso_c_binding procedures aren't specially handled.
3269 Upon successfully exiting, c->resolved_sym will hold the resolved
3270 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3274 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3276 gfc_symbol *new_sym;
3277 /* this is fine, since we know the names won't use the max */
3278 char name[GFC_MAX_SYMBOL_LEN + 1];
3279 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
3280 /* default to success; will override if find error */
3281 match m = MATCH_YES;
3283 /* Make sure the actual arguments are in the necessary order (based on the
3284 formal args) before resolving. */
3285 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3287 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3288 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3290 set_name_and_label (c, sym, name, binding_label);
3292 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3294 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3296 /* Make sure we got a third arg if the second arg has non-zero
3297 rank. We must also check that the type and rank are
3298 correct since we short-circuit this check in
3299 gfc_procedure_use() (called above to sort actual args). */
3300 if (c->ext.actual->next->expr->rank != 0)
3302 if(c->ext.actual->next->next == NULL
3303 || c->ext.actual->next->next->expr == NULL)
3306 gfc_error ("Missing SHAPE parameter for call to %s "
3307 "at %L", sym->name, &(c->loc));
3309 else if (c->ext.actual->next->next->expr->ts.type
3311 || c->ext.actual->next->next->expr->rank != 1)
3314 gfc_error ("SHAPE parameter for call to %s at %L must "
3315 "be a rank 1 INTEGER array", sym->name,
3322 if (m != MATCH_ERROR)
3324 /* the 1 means to add the optional arg to formal list */
3325 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3327 /* for error reporting, say it's declared where the original was */
3328 new_sym->declared_at = sym->declared_at;
3333 /* no differences for c_loc or c_funloc */
3337 /* set the resolved symbol */
3338 if (m != MATCH_ERROR)
3339 c->resolved_sym = new_sym;
3341 c->resolved_sym = sym;
3347 /* Resolve a subroutine call known to be specific. */
3350 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3354 if(sym->attr.is_iso_c)
3356 m = gfc_iso_c_sub_interface (c,sym);
3360 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3362 if (sym->attr.dummy)
3364 sym->attr.proc = PROC_DUMMY;
3368 sym->attr.proc = PROC_EXTERNAL;
3372 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3375 if (sym->attr.intrinsic)
3377 m = gfc_intrinsic_sub_interface (c, 1);
3381 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3382 "with an intrinsic", sym->name, &c->loc);
3390 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3392 c->resolved_sym = sym;
3393 pure_subroutine (c, sym);
3400 resolve_specific_s (gfc_code *c)
3405 sym = c->symtree->n.sym;
3409 m = resolve_specific_s0 (c, sym);
3412 if (m == MATCH_ERROR)
3415 if (sym->ns->parent == NULL)
3418 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3424 sym = c->symtree->n.sym;
3425 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3426 sym->name, &c->loc);
3432 /* Resolve a subroutine call not known to be generic nor specific. */
3435 resolve_unknown_s (gfc_code *c)
3439 sym = c->symtree->n.sym;
3441 if (sym->attr.dummy)
3443 sym->attr.proc = PROC_DUMMY;
3447 /* See if we have an intrinsic function reference. */
3449 if (gfc_is_intrinsic (sym, 1, c->loc))
3451 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3456 /* The reference is to an external name. */
3459 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3461 c->resolved_sym = sym;
3463 pure_subroutine (c, sym);
3469 /* Resolve a subroutine call. Although it was tempting to use the same code
3470 for functions, subroutines and functions are stored differently and this
3471 makes things awkward. */
3474 resolve_call (gfc_code *c)
3477 procedure_type ptype = PROC_INTRINSIC;
3478 gfc_symbol *csym, *sym;
3479 bool no_formal_args;
3481 csym = c->symtree ? c->symtree->n.sym : NULL;
3483 if (csym && csym->ts.type != BT_UNKNOWN)
3485 gfc_error ("'%s' at %L has a type, which is not consistent with "
3486 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3490 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3493 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3494 sym = st ? st->n.sym : NULL;
3495 if (sym && csym != sym
3496 && sym->ns == gfc_current_ns
3497 && sym->attr.flavor == FL_PROCEDURE
3498 && sym->attr.contained)
3501 if (csym->attr.generic)
3502 c->symtree->n.sym = sym;
3505 csym = c->symtree->n.sym;
3509 /* If this ia a deferred TBP with an abstract interface
3510 (which may of course be referenced), c->expr1 will be set. */
3511 if (csym && csym->attr.abstract && !c->expr1)
3513 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3514 csym->name, &c->loc);
3518 /* Subroutines without the RECURSIVE attribution are not allowed to
3519 * call themselves. */
3520 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3522 if (csym->attr.entry && csym->ns->entries)
3523 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3524 " subroutine '%s' is not RECURSIVE",
3525 csym->name, &c->loc, csym->ns->entries->sym->name);
3527 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3528 " is not RECURSIVE", csym->name, &c->loc);
3533 /* Switch off assumed size checking and do this again for certain kinds
3534 of procedure, once the procedure itself is resolved. */
3535 need_full_assumed_size++;
3538 ptype = csym->attr.proc;
3540 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3541 if (resolve_actual_arglist (c->ext.actual, ptype,
3542 no_formal_args) == FAILURE)
3545 /* Resume assumed_size checking. */
3546 need_full_assumed_size--;
3548 /* If external, check for usage. */
3549 if (csym && is_external_proc (csym))
3550 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3553 if (c->resolved_sym == NULL)
3555 c->resolved_isym = NULL;
3556 switch (procedure_kind (csym))
3559 t = resolve_generic_s (c);
3562 case PTYPE_SPECIFIC:
3563 t = resolve_specific_s (c);
3567 t = resolve_unknown_s (c);
3571 gfc_internal_error ("resolve_subroutine(): bad function type");
3575 /* Some checks of elemental subroutine actual arguments. */
3576 if (resolve_elemental_actual (NULL, c) == FAILURE)
3583 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3584 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3585 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3586 if their shapes do not match. If either op1->shape or op2->shape is
3587 NULL, return SUCCESS. */
3590 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3597 if (op1->shape != NULL && op2->shape != NULL)
3599 for (i = 0; i < op1->rank; i++)
3601 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3603 gfc_error ("Shapes for operands at %L and %L are not conformable",
3604 &op1->where, &op2->where);
3615 /* Resolve an operator expression node. This can involve replacing the
3616 operation with a user defined function call. */
3619 resolve_operator (gfc_expr *e)
3621 gfc_expr *op1, *op2;
3623 bool dual_locus_error;
3626 /* Resolve all subnodes-- give them types. */
3628 switch (e->value.op.op)
3631 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3634 /* Fall through... */
3637 case INTRINSIC_UPLUS:
3638 case INTRINSIC_UMINUS:
3639 case INTRINSIC_PARENTHESES:
3640 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3645 /* Typecheck the new node. */
3647 op1 = e->value.op.op1;
3648 op2 = e->value.op.op2;
3649 dual_locus_error = false;
3651 if ((op1 && op1->expr_type == EXPR_NULL)
3652 || (op2 && op2->expr_type == EXPR_NULL))
3654 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3658 switch (e->value.op.op)
3660 case INTRINSIC_UPLUS:
3661 case INTRINSIC_UMINUS:
3662 if (op1->ts.type == BT_INTEGER
3663 || op1->ts.type == BT_REAL
3664 || op1->ts.type == BT_COMPLEX)
3670 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3671 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3674 case INTRINSIC_PLUS:
3675 case INTRINSIC_MINUS:
3676 case INTRINSIC_TIMES:
3677 case INTRINSIC_DIVIDE:
3678 case INTRINSIC_POWER:
3679 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3681 gfc_type_convert_binary (e, 1);
3686 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3687 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3688 gfc_typename (&op2->ts));
3691 case INTRINSIC_CONCAT:
3692 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3693 && op1->ts.kind == op2->ts.kind)
3695 e->ts.type = BT_CHARACTER;
3696 e->ts.kind = op1->ts.kind;
3701 _("Operands of string concatenation operator at %%L are %s/%s"),
3702 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3708 case INTRINSIC_NEQV:
3709 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3711 e->ts.type = BT_LOGICAL;
3712 e->ts.kind = gfc_kind_max (op1, op2);
3713 if (op1->ts.kind < e->ts.kind)
3714 gfc_convert_type (op1, &e->ts, 2);
3715 else if (op2->ts.kind < e->ts.kind)
3716 gfc_convert_type (op2, &e->ts, 2);
3720 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3721 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3722 gfc_typename (&op2->ts));
3727 if (op1->ts.type == BT_LOGICAL)
3729 e->ts.type = BT_LOGICAL;
3730 e->ts.kind = op1->ts.kind;
3734 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3735 gfc_typename (&op1->ts));
3739 case INTRINSIC_GT_OS:
3741 case INTRINSIC_GE_OS:
3743 case INTRINSIC_LT_OS:
3745 case INTRINSIC_LE_OS:
3746 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3748 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3752 /* Fall through... */
3755 case INTRINSIC_EQ_OS:
3757 case INTRINSIC_NE_OS:
3758 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3759 && op1->ts.kind == op2->ts.kind)
3761 e->ts.type = BT_LOGICAL;
3762 e->ts.kind = gfc_default_logical_kind;
3766 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3768 gfc_type_convert_binary (e, 1);
3770 e->ts.type = BT_LOGICAL;
3771 e->ts.kind = gfc_default_logical_kind;
3775 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3777 _("Logicals at %%L must be compared with %s instead of %s"),
3778 (e->value.op.op == INTRINSIC_EQ
3779 || e->value.op.op == INTRINSIC_EQ_OS)
3780 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3783 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3784 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3785 gfc_typename (&op2->ts));
3789 case INTRINSIC_USER:
3790 if (e->value.op.uop->op == NULL)
3791 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3792 else if (op2 == NULL)
3793 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3794 e->value.op.uop->name, gfc_typename (&op1->ts));
3797 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3798 e->value.op.uop->name, gfc_typename (&op1->ts),
3799 gfc_typename (&op2->ts));
3800 e->value.op.uop->op->sym->attr.referenced = 1;
3805 case INTRINSIC_PARENTHESES:
3807 if (e->ts.type == BT_CHARACTER)
3808 e->ts.u.cl = op1->ts.u.cl;
3812 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3815 /* Deal with arrayness of an operand through an operator. */
3819 switch (e->value.op.op)
3821 case INTRINSIC_PLUS:
3822 case INTRINSIC_MINUS:
3823 case INTRINSIC_TIMES:
3824 case INTRINSIC_DIVIDE:
3825 case INTRINSIC_POWER:
3826 case INTRINSIC_CONCAT:
3830 case INTRINSIC_NEQV:
3832 case INTRINSIC_EQ_OS:
3834 case INTRINSIC_NE_OS:
3836 case INTRINSIC_GT_OS:
3838 case INTRINSIC_GE_OS:
3840 case INTRINSIC_LT_OS:
3842 case INTRINSIC_LE_OS:
3844 if (op1->rank == 0 && op2->rank == 0)
3847 if (op1->rank == 0 && op2->rank != 0)
3849 e->rank = op2->rank;
3851 if (e->shape == NULL)
3852 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3855 if (op1->rank != 0 && op2->rank == 0)
3857 e->rank = op1->rank;
3859 if (e->shape == NULL)
3860 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3863 if (op1->rank != 0 && op2->rank != 0)
3865 if (op1->rank == op2->rank)
3867 e->rank = op1->rank;
3868 if (e->shape == NULL)
3870 t = compare_shapes (op1, op2);
3874 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3879 /* Allow higher level expressions to work. */
3882 /* Try user-defined operators, and otherwise throw an error. */
3883 dual_locus_error = true;
3885 _("Inconsistent ranks for operator at %%L and %%L"));
3892 case INTRINSIC_PARENTHESES:
3894 case INTRINSIC_UPLUS:
3895 case INTRINSIC_UMINUS:
3896 /* Simply copy arrayness attribute */
3897 e->rank = op1->rank;
3899 if (e->shape == NULL)
3900 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3908 /* Attempt to simplify the expression. */
3911 t = gfc_simplify_expr (e, 0);
3912 /* Some calls do not succeed in simplification and return FAILURE
3913 even though there is no error; e.g. variable references to
3914 PARAMETER arrays. */
3915 if (!gfc_is_constant_expr (e))
3924 if (gfc_extend_expr (e, &real_error) == SUCCESS)
3931 if (dual_locus_error)
3932 gfc_error (msg, &op1->where, &op2->where);
3934 gfc_error (msg, &e->where);
3940 /************** Array resolution subroutines **************/
3943 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3946 /* Compare two integer expressions. */
3949 compare_bound (gfc_expr *a, gfc_expr *b)
3953 if (a == NULL || a->expr_type != EXPR_CONSTANT
3954 || b == NULL || b->expr_type != EXPR_CONSTANT)
3957 /* If either of the types isn't INTEGER, we must have
3958 raised an error earlier. */
3960 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3963 i = mpz_cmp (a->value.integer, b->value.integer);
3973 /* Compare an integer expression with an integer. */
3976 compare_bound_int (gfc_expr *a, int b)
3980 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3983 if (a->ts.type != BT_INTEGER)
3984 gfc_internal_error ("compare_bound_int(): Bad expression");
3986 i = mpz_cmp_si (a->value.integer, b);
3996 /* Compare an integer expression with a mpz_t. */
3999 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4003 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4006 if (a->ts.type != BT_INTEGER)
4007 gfc_internal_error ("compare_bound_int(): Bad expression");
4009 i = mpz_cmp (a->value.integer, b);
4019 /* Compute the last value of a sequence given by a triplet.
4020 Return 0 if it wasn't able to compute the last value, or if the
4021 sequence if empty, and 1 otherwise. */
4024 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4025 gfc_expr *stride, mpz_t last)
4029 if (start == NULL || start->expr_type != EXPR_CONSTANT
4030 || end == NULL || end->expr_type != EXPR_CONSTANT
4031 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4034 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4035 || (stride != NULL && stride->ts.type != BT_INTEGER))
4038 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
4040 if (compare_bound (start, end) == CMP_GT)
4042 mpz_set (last, end->value.integer);
4046 if (compare_bound_int (stride, 0) == CMP_GT)
4048 /* Stride is positive */
4049 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4054 /* Stride is negative */
4055 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4060 mpz_sub (rem, end->value.integer, start->value.integer);
4061 mpz_tdiv_r (rem, rem, stride->value.integer);
4062 mpz_sub (last, end->value.integer, rem);
4069 /* Compare a single dimension of an array reference to the array
4073 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4077 if (ar->dimen_type[i] == DIMEN_STAR)
4079 gcc_assert (ar->stride[i] == NULL);
4080 /* This implies [*] as [*:] and [*:3] are not possible. */
4081 if (ar->start[i] == NULL)
4083 gcc_assert (ar->end[i] == NULL);
4088 /* Given start, end and stride values, calculate the minimum and
4089 maximum referenced indexes. */
4091 switch (ar->dimen_type[i])
4098 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4101 gfc_warning ("Array reference at %L is out of bounds "
4102 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4103 mpz_get_si (ar->start[i]->value.integer),
4104 mpz_get_si (as->lower[i]->value.integer), i+1);
4106 gfc_warning ("Array reference at %L is out of bounds "
4107 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4108 mpz_get_si (ar->start[i]->value.integer),
4109 mpz_get_si (as->lower[i]->value.integer),
4113 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4116 gfc_warning ("Array reference at %L is out of bounds "
4117 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4118 mpz_get_si (ar->start[i]->value.integer),
4119 mpz_get_si (as->upper[i]->value.integer), i+1);
4121 gfc_warning ("Array reference at %L is out of bounds "
4122 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4123 mpz_get_si (ar->start[i]->value.integer),
4124 mpz_get_si (as->upper[i]->value.integer),
4133 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4134 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4136 comparison comp_start_end = compare_bound (AR_START, AR_END);
4138 /* Check for zero stride, which is not allowed. */
4139 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4141 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4145 /* if start == len || (stride > 0 && start < len)
4146 || (stride < 0 && start > len),
4147 then the array section contains at least one element. In this
4148 case, there is an out-of-bounds access if
4149 (start < lower || start > upper). */
4150 if (compare_bound (AR_START, AR_END) == CMP_EQ
4151 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4152 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4153 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4154 && comp_start_end == CMP_GT))
4156 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4158 gfc_warning ("Lower array reference at %L is out of bounds "
4159 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4160 mpz_get_si (AR_START->value.integer),
4161 mpz_get_si (as->lower[i]->value.integer), i+1);
4164 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4166 gfc_warning ("Lower array reference at %L is out of bounds "
4167 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4168 mpz_get_si (AR_START->value.integer),
4169 mpz_get_si (as->upper[i]->value.integer), i+1);
4174 /* If we can compute the highest index of the array section,
4175 then it also has to be between lower and upper. */
4176 mpz_init (last_value);
4177 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4180 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4182 gfc_warning ("Upper array reference at %L is out of bounds "
4183 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4184 mpz_get_si (last_value),
4185 mpz_get_si (as->lower[i]->value.integer), i+1);
4186 mpz_clear (last_value);
4189 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4191 gfc_warning ("Upper array reference at %L is out of bounds "
4192 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4193 mpz_get_si (last_value),
4194 mpz_get_si (as->upper[i]->value.integer), i+1);
4195 mpz_clear (last_value);
4199 mpz_clear (last_value);
4207 gfc_internal_error ("check_dimension(): Bad array reference");
4214 /* Compare an array reference with an array specification. */
4217 compare_spec_to_ref (gfc_array_ref *ar)
4224 /* TODO: Full array sections are only allowed as actual parameters. */
4225 if (as->type == AS_ASSUMED_SIZE
4226 && (/*ar->type == AR_FULL
4227 ||*/ (ar->type == AR_SECTION
4228 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4230 gfc_error ("Rightmost upper bound of assumed size array section "
4231 "not specified at %L", &ar->where);
4235 if (ar->type == AR_FULL)
4238 if (as->rank != ar->dimen)
4240 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4241 &ar->where, ar->dimen, as->rank);
4245 /* ar->codimen == 0 is a local array. */
4246 if (as->corank != ar->codimen && ar->codimen != 0)
4248 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4249 &ar->where, ar->codimen, as->corank);
4253 for (i = 0; i < as->rank; i++)
4254 if (check_dimension (i, ar, as) == FAILURE)
4257 /* Local access has no coarray spec. */
4258 if (ar->codimen != 0)
4259 for (i = as->rank; i < as->rank + as->corank; i++)
4261 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
4263 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4264 i + 1 - as->rank, &ar->where);
4267 if (check_dimension (i, ar, as) == FAILURE)
4275 /* Resolve one part of an array index. */
4278 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4279 int force_index_integer_kind)
4286 if (gfc_resolve_expr (index) == FAILURE)
4289 if (check_scalar && index->rank != 0)
4291 gfc_error ("Array index at %L must be scalar", &index->where);
4295 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4297 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4298 &index->where, gfc_basic_typename (index->ts.type));
4302 if (index->ts.type == BT_REAL)
4303 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
4304 &index->where) == FAILURE)
4307 if ((index->ts.kind != gfc_index_integer_kind
4308 && force_index_integer_kind)
4309 || index->ts.type != BT_INTEGER)
4312 ts.type = BT_INTEGER;
4313 ts.kind = gfc_index_integer_kind;
4315 gfc_convert_type_warn (index, &ts, 2, 0);
4321 /* Resolve one part of an array index. */
4324 gfc_resolve_index (gfc_expr *index, int check_scalar)
4326 return gfc_resolve_index_1 (index, check_scalar, 1);
4329 /* Resolve a dim argument to an intrinsic function. */
4332 gfc_resolve_dim_arg (gfc_expr *dim)
4337 if (gfc_resolve_expr (dim) == FAILURE)
4342 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4347 if (dim->ts.type != BT_INTEGER)
4349 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4353 if (dim->ts.kind != gfc_index_integer_kind)
4358 ts.type = BT_INTEGER;
4359 ts.kind = gfc_index_integer_kind;
4361 gfc_convert_type_warn (dim, &ts, 2, 0);
4367 /* Given an expression that contains array references, update those array
4368 references to point to the right array specifications. While this is
4369 filled in during matching, this information is difficult to save and load
4370 in a module, so we take care of it here.
4372 The idea here is that the original array reference comes from the
4373 base symbol. We traverse the list of reference structures, setting
4374 the stored reference to references. Component references can
4375 provide an additional array specification. */
4378 find_array_spec (gfc_expr *e)
4382 gfc_symbol *derived;
4385 if (e->symtree->n.sym->ts.type == BT_CLASS)
4386 as = CLASS_DATA (e->symtree->n.sym)->as;
4388 as = e->symtree->n.sym->as;
4391 for (ref = e->ref; ref; ref = ref->next)
4396 gfc_internal_error ("find_array_spec(): Missing spec");
4403 if (derived == NULL)
4404 derived = e->symtree->n.sym->ts.u.derived;
4406 if (derived->attr.is_class)
4407 derived = derived->components->ts.u.derived;
4409 c = derived->components;
4411 for (; c; c = c->next)
4412 if (c == ref->u.c.component)
4414 /* Track the sequence of component references. */
4415 if (c->ts.type == BT_DERIVED)
4416 derived = c->ts.u.derived;
4421 gfc_internal_error ("find_array_spec(): Component not found");
4423 if (c->attr.dimension)
4426 gfc_internal_error ("find_array_spec(): unused as(1)");
4437 gfc_internal_error ("find_array_spec(): unused as(2)");
4441 /* Resolve an array reference. */
4444 resolve_array_ref (gfc_array_ref *ar)
4446 int i, check_scalar;
4449 for (i = 0; i < ar->dimen + ar->codimen; i++)
4451 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4453 /* Do not force gfc_index_integer_kind for the start. We can
4454 do fine with any integer kind. This avoids temporary arrays
4455 created for indexing with a vector. */
4456 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4458 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4460 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4465 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4469 ar->dimen_type[i] = DIMEN_ELEMENT;
4473 ar->dimen_type[i] = DIMEN_VECTOR;
4474 if (e->expr_type == EXPR_VARIABLE
4475 && e->symtree->n.sym->ts.type == BT_DERIVED)
4476 ar->start[i] = gfc_get_parentheses (e);
4480 gfc_error ("Array index at %L is an array of rank %d",
4481 &ar->c_where[i], e->rank);
4485 /* Fill in the upper bound, which may be lower than the
4486 specified one for something like a(2:10:5), which is
4487 identical to a(2:7:5). Only relevant for strides not equal
4489 if (ar->dimen_type[i] == DIMEN_RANGE
4490 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4491 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0)
4495 if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4497 if (ar->end[i] == NULL)
4500 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4502 mpz_set (ar->end[i]->value.integer, end);
4504 else if (ar->end[i]->ts.type == BT_INTEGER
4505 && ar->end[i]->expr_type == EXPR_CONSTANT)
4507 mpz_set (ar->end[i]->value.integer, end);
4518 if (ar->type == AR_FULL && ar->as->rank == 0)
4519 ar->type = AR_ELEMENT;
4521 /* If the reference type is unknown, figure out what kind it is. */
4523 if (ar->type == AR_UNKNOWN)
4525 ar->type = AR_ELEMENT;
4526 for (i = 0; i < ar->dimen; i++)
4527 if (ar->dimen_type[i] == DIMEN_RANGE
4528 || ar->dimen_type[i] == DIMEN_VECTOR)
4530 ar->type = AR_SECTION;
4535 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4543 resolve_substring (gfc_ref *ref)
4545 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4547 if (ref->u.ss.start != NULL)
4549 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4552 if (ref->u.ss.start->ts.type != BT_INTEGER)
4554 gfc_error ("Substring start index at %L must be of type INTEGER",
4555 &ref->u.ss.start->where);
4559 if (ref->u.ss.start->rank != 0)
4561 gfc_error ("Substring start index at %L must be scalar",
4562 &ref->u.ss.start->where);
4566 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4567 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4568 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4570 gfc_error ("Substring start index at %L is less than one",
4571 &ref->u.ss.start->where);
4576 if (ref->u.ss.end != NULL)
4578 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4581 if (ref->u.ss.end->ts.type != BT_INTEGER)
4583 gfc_error ("Substring end index at %L must be of type INTEGER",
4584 &ref->u.ss.end->where);
4588 if (ref->u.ss.end->rank != 0)
4590 gfc_error ("Substring end index at %L must be scalar",
4591 &ref->u.ss.end->where);
4595 if (ref->u.ss.length != NULL
4596 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4597 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4598 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4600 gfc_error ("Substring end index at %L exceeds the string length",
4601 &ref->u.ss.start->where);
4605 if (compare_bound_mpz_t (ref->u.ss.end,
4606 gfc_integer_kinds[k].huge) == CMP_GT
4607 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4608 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4610 gfc_error ("Substring end index at %L is too large",
4611 &ref->u.ss.end->where);
4620 /* This function supplies missing substring charlens. */
4623 gfc_resolve_substring_charlen (gfc_expr *e)
4626 gfc_expr *start, *end;
4628 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4629 if (char_ref->type == REF_SUBSTRING)
4635 gcc_assert (char_ref->next == NULL);
4639 if (e->ts.u.cl->length)
4640 gfc_free_expr (e->ts.u.cl->length);
4641 else if (e->expr_type == EXPR_VARIABLE
4642 && e->symtree->n.sym->attr.dummy)
4646 e->ts.type = BT_CHARACTER;
4647 e->ts.kind = gfc_default_character_kind;
4650 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4652 if (char_ref->u.ss.start)
4653 start = gfc_copy_expr (char_ref->u.ss.start);
4655 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4657 if (char_ref->u.ss.end)
4658 end = gfc_copy_expr (char_ref->u.ss.end);
4659 else if (e->expr_type == EXPR_VARIABLE)
4660 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4667 /* Length = (end - start +1). */
4668 e->ts.u.cl->length = gfc_subtract (end, start);
4669 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4670 gfc_get_int_expr (gfc_default_integer_kind,
4673 e->ts.u.cl->length->ts.type = BT_INTEGER;
4674 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4676 /* Make sure that the length is simplified. */
4677 gfc_simplify_expr (e->ts.u.cl->length, 1);
4678 gfc_resolve_expr (e->ts.u.cl->length);
4682 /* Resolve subtype references. */
4685 resolve_ref (gfc_expr *expr)
4687 int current_part_dimension, n_components, seen_part_dimension;
4690 for (ref = expr->ref; ref; ref = ref->next)
4691 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4693 find_array_spec (expr);
4697 for (ref = expr->ref; ref; ref = ref->next)
4701 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4709 resolve_substring (ref);
4713 /* Check constraints on part references. */
4715 current_part_dimension = 0;
4716 seen_part_dimension = 0;
4719 for (ref = expr->ref; ref; ref = ref->next)
4724 switch (ref->u.ar.type)
4727 /* Coarray scalar. */
4728 if (ref->u.ar.as->rank == 0)
4730 current_part_dimension = 0;
4735 current_part_dimension = 1;
4739 current_part_dimension = 0;
4743 gfc_internal_error ("resolve_ref(): Bad array reference");
4749 if (current_part_dimension || seen_part_dimension)
4752 if (ref->u.c.component->attr.pointer
4753 || ref->u.c.component->attr.proc_pointer)
4755 gfc_error ("Component to the right of a part reference "
4756 "with nonzero rank must not have the POINTER "
4757 "attribute at %L", &expr->where);
4760 else if (ref->u.c.component->attr.allocatable)
4762 gfc_error ("Component to the right of a part reference "
4763 "with nonzero rank must not have the ALLOCATABLE "
4764 "attribute at %L", &expr->where);
4776 if (((ref->type == REF_COMPONENT && n_components > 1)
4777 || ref->next == NULL)
4778 && current_part_dimension
4779 && seen_part_dimension)
4781 gfc_error ("Two or more part references with nonzero rank must "
4782 "not be specified at %L", &expr->where);
4786 if (ref->type == REF_COMPONENT)
4788 if (current_part_dimension)
4789 seen_part_dimension = 1;
4791 /* reset to make sure */
4792 current_part_dimension = 0;
4800 /* Given an expression, determine its shape. This is easier than it sounds.
4801 Leaves the shape array NULL if it is not possible to determine the shape. */
4804 expression_shape (gfc_expr *e)
4806 mpz_t array[GFC_MAX_DIMENSIONS];
4809 if (e->rank == 0 || e->shape != NULL)
4812 for (i = 0; i < e->rank; i++)
4813 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4816 e->shape = gfc_get_shape (e->rank);
4818 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4823 for (i--; i >= 0; i--)
4824 mpz_clear (array[i]);
4828 /* Given a variable expression node, compute the rank of the expression by
4829 examining the base symbol and any reference structures it may have. */
4832 expression_rank (gfc_expr *e)
4837 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4838 could lead to serious confusion... */
4839 gcc_assert (e->expr_type != EXPR_COMPCALL);
4843 if (e->expr_type == EXPR_ARRAY)
4845 /* Constructors can have a rank different from one via RESHAPE(). */
4847 if (e->symtree == NULL)
4853 e->rank = (e->symtree->n.sym->as == NULL)
4854 ? 0 : e->symtree->n.sym->as->rank;
4860 for (ref = e->ref; ref; ref = ref->next)
4862 if (ref->type != REF_ARRAY)
4865 if (ref->u.ar.type == AR_FULL)
4867 rank = ref->u.ar.as->rank;
4871 if (ref->u.ar.type == AR_SECTION)
4873 /* Figure out the rank of the section. */
4875 gfc_internal_error ("expression_rank(): Two array specs");
4877 for (i = 0; i < ref->u.ar.dimen; i++)
4878 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4879 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4889 expression_shape (e);
4893 /* Resolve a variable expression. */
4896 resolve_variable (gfc_expr *e)
4903 if (e->symtree == NULL)
4905 sym = e->symtree->n.sym;
4907 /* If this is an associate-name, it may be parsed with an array reference
4908 in error even though the target is scalar. Fail directly in this case. */
4909 if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
4912 /* On the other hand, the parser may not have known this is an array;
4913 in this case, we have to add a FULL reference. */
4914 if (sym->assoc && sym->attr.dimension && !e->ref)
4916 e->ref = gfc_get_ref ();
4917 e->ref->type = REF_ARRAY;
4918 e->ref->u.ar.type = AR_FULL;
4919 e->ref->u.ar.dimen = 0;
4922 if (e->ref && resolve_ref (e) == FAILURE)
4925 if (sym->attr.flavor == FL_PROCEDURE
4926 && (!sym->attr.function
4927 || (sym->attr.function && sym->result
4928 && sym->result->attr.proc_pointer
4929 && !sym->result->attr.function)))
4931 e->ts.type = BT_PROCEDURE;
4932 goto resolve_procedure;
4935 if (sym->ts.type != BT_UNKNOWN)
4936 gfc_variable_attr (e, &e->ts);
4939 /* Must be a simple variable reference. */
4940 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4945 if (check_assumed_size_reference (sym, e))
4948 /* Deal with forward references to entries during resolve_code, to
4949 satisfy, at least partially, 12.5.2.5. */
4950 if (gfc_current_ns->entries
4951 && current_entry_id == sym->entry_id
4954 && cs_base->current->op != EXEC_ENTRY)
4956 gfc_entry_list *entry;
4957 gfc_formal_arglist *formal;
4961 /* If the symbol is a dummy... */
4962 if (sym->attr.dummy && sym->ns == gfc_current_ns)
4964 entry = gfc_current_ns->entries;
4967 /* ...test if the symbol is a parameter of previous entries. */
4968 for (; entry && entry->id <= current_entry_id; entry = entry->next)
4969 for (formal = entry->sym->formal; formal; formal = formal->next)
4971 if (formal->sym && sym->name == formal->sym->name)
4975 /* If it has not been seen as a dummy, this is an error. */
4978 if (specification_expr)
4979 gfc_error ("Variable '%s', used in a specification expression"
4980 ", is referenced at %L before the ENTRY statement "
4981 "in which it is a parameter",
4982 sym->name, &cs_base->current->loc);
4984 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4985 "statement in which it is a parameter",
4986 sym->name, &cs_base->current->loc);
4991 /* Now do the same check on the specification expressions. */
4992 specification_expr = 1;
4993 if (sym->ts.type == BT_CHARACTER
4994 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
4998 for (n = 0; n < sym->as->rank; n++)
5000 specification_expr = 1;
5001 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
5003 specification_expr = 1;
5004 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
5007 specification_expr = 0;
5010 /* Update the symbol's entry level. */
5011 sym->entry_id = current_entry_id + 1;
5014 /* If a symbol has been host_associated mark it. This is used latter,
5015 to identify if aliasing is possible via host association. */
5016 if (sym->attr.flavor == FL_VARIABLE
5017 && gfc_current_ns->parent
5018 && (gfc_current_ns->parent == sym->ns
5019 || (gfc_current_ns->parent->parent
5020 && gfc_current_ns->parent->parent == sym->ns)))
5021 sym->attr.host_assoc = 1;
5024 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
5027 /* F2008, C617 and C1229. */
5028 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5029 && gfc_is_coindexed (e))
5031 gfc_ref *ref, *ref2 = NULL;
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 not coindexed object. */
5046 if (ref && e->ts.type == BT_CLASS)
5048 gfc_error ("Polymorphic subobject of coindexed object at %L",
5053 /* Expression itself is coindexed object. */
5057 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5058 for ( ; c; c = c->next)
5059 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5061 gfc_error ("Coindexed object with polymorphic allocatable "
5062 "subcomponent at %L", &e->where);
5073 /* Checks to see that the correct symbol has been host associated.
5074 The only situation where this arises is that in which a twice
5075 contained function is parsed after the host association is made.
5076 Therefore, on detecting this, change the symbol in the expression
5077 and convert the array reference into an actual arglist if the old
5078 symbol is a variable. */
5080 check_host_association (gfc_expr *e)
5082 gfc_symbol *sym, *old_sym;
5086 gfc_actual_arglist *arg, *tail = NULL;
5087 bool retval = e->expr_type == EXPR_FUNCTION;
5089 /* If the expression is the result of substitution in
5090 interface.c(gfc_extend_expr) because there is no way in
5091 which the host association can be wrong. */
5092 if (e->symtree == NULL
5093 || e->symtree->n.sym == NULL
5094 || e->user_operator)
5097 old_sym = e->symtree->n.sym;
5099 if (gfc_current_ns->parent
5100 && old_sym->ns != gfc_current_ns)
5102 /* Use the 'USE' name so that renamed module symbols are
5103 correctly handled. */
5104 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5106 if (sym && old_sym != sym
5107 && sym->ts.type == old_sym->ts.type
5108 && sym->attr.flavor == FL_PROCEDURE
5109 && sym->attr.contained)
5111 /* Clear the shape, since it might not be valid. */
5112 if (e->shape != NULL)
5114 for (n = 0; n < e->rank; n++)
5115 mpz_clear (e->shape[n]);
5117 gfc_free (e->shape);
5120 /* Give the expression the right symtree! */
5121 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5122 gcc_assert (st != NULL);
5124 if (old_sym->attr.flavor == FL_PROCEDURE
5125 || e->expr_type == EXPR_FUNCTION)
5127 /* Original was function so point to the new symbol, since
5128 the actual argument list is already attached to the
5130 e->value.function.esym = NULL;
5135 /* Original was variable so convert array references into
5136 an actual arglist. This does not need any checking now
5137 since gfc_resolve_function will take care of it. */
5138 e->value.function.actual = NULL;
5139 e->expr_type = EXPR_FUNCTION;
5142 /* Ambiguity will not arise if the array reference is not
5143 the last reference. */
5144 for (ref = e->ref; ref; ref = ref->next)
5145 if (ref->type == REF_ARRAY && ref->next == NULL)
5148 gcc_assert (ref->type == REF_ARRAY);
5150 /* Grab the start expressions from the array ref and
5151 copy them into actual arguments. */
5152 for (n = 0; n < ref->u.ar.dimen; n++)
5154 arg = gfc_get_actual_arglist ();
5155 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5156 if (e->value.function.actual == NULL)
5157 tail = e->value.function.actual = arg;
5165 /* Dump the reference list and set the rank. */
5166 gfc_free_ref_list (e->ref);
5168 e->rank = sym->as ? sym->as->rank : 0;
5171 gfc_resolve_expr (e);
5175 /* This might have changed! */
5176 return e->expr_type == EXPR_FUNCTION;
5181 gfc_resolve_character_operator (gfc_expr *e)
5183 gfc_expr *op1 = e->value.op.op1;
5184 gfc_expr *op2 = e->value.op.op2;
5185 gfc_expr *e1 = NULL;
5186 gfc_expr *e2 = NULL;
5188 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5190 if (op1->ts.u.cl && op1->ts.u.cl->length)
5191 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5192 else if (op1->expr_type == EXPR_CONSTANT)
5193 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5194 op1->value.character.length);
5196 if (op2->ts.u.cl && op2->ts.u.cl->length)
5197 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5198 else if (op2->expr_type == EXPR_CONSTANT)
5199 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5200 op2->value.character.length);
5202 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5207 e->ts.u.cl->length = gfc_add (e1, e2);
5208 e->ts.u.cl->length->ts.type = BT_INTEGER;
5209 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5210 gfc_simplify_expr (e->ts.u.cl->length, 0);
5211 gfc_resolve_expr (e->ts.u.cl->length);
5217 /* Ensure that an character expression has a charlen and, if possible, a
5218 length expression. */
5221 fixup_charlen (gfc_expr *e)
5223 /* The cases fall through so that changes in expression type and the need
5224 for multiple fixes are picked up. In all circumstances, a charlen should
5225 be available for the middle end to hang a backend_decl on. */
5226 switch (e->expr_type)
5229 gfc_resolve_character_operator (e);
5232 if (e->expr_type == EXPR_ARRAY)
5233 gfc_resolve_character_array_constructor (e);
5235 case EXPR_SUBSTRING:
5236 if (!e->ts.u.cl && e->ref)
5237 gfc_resolve_substring_charlen (e);
5241 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5248 /* Update an actual argument to include the passed-object for type-bound
5249 procedures at the right position. */
5251 static gfc_actual_arglist*
5252 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5255 gcc_assert (argpos > 0);
5259 gfc_actual_arglist* result;
5261 result = gfc_get_actual_arglist ();
5265 result->name = name;
5271 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5273 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5278 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5281 extract_compcall_passed_object (gfc_expr* e)
5285 gcc_assert (e->expr_type == EXPR_COMPCALL);
5287 if (e->value.compcall.base_object)
5288 po = gfc_copy_expr (e->value.compcall.base_object);
5291 po = gfc_get_expr ();
5292 po->expr_type = EXPR_VARIABLE;
5293 po->symtree = e->symtree;
5294 po->ref = gfc_copy_ref (e->ref);
5295 po->where = e->where;
5298 if (gfc_resolve_expr (po) == FAILURE)
5305 /* Update the arglist of an EXPR_COMPCALL expression to include the
5309 update_compcall_arglist (gfc_expr* e)
5312 gfc_typebound_proc* tbp;
5314 tbp = e->value.compcall.tbp;
5319 po = extract_compcall_passed_object (e);
5323 if (tbp->nopass || e->value.compcall.ignore_pass)
5329 gcc_assert (tbp->pass_arg_num > 0);
5330 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5338 /* Extract the passed object from a PPC call (a copy of it). */
5341 extract_ppc_passed_object (gfc_expr *e)
5346 po = gfc_get_expr ();
5347 po->expr_type = EXPR_VARIABLE;
5348 po->symtree = e->symtree;
5349 po->ref = gfc_copy_ref (e->ref);
5350 po->where = e->where;
5352 /* Remove PPC reference. */
5354 while ((*ref)->next)
5355 ref = &(*ref)->next;
5356 gfc_free_ref_list (*ref);
5359 if (gfc_resolve_expr (po) == FAILURE)
5366 /* Update the actual arglist of a procedure pointer component to include the
5370 update_ppc_arglist (gfc_expr* e)
5374 gfc_typebound_proc* tb;
5376 if (!gfc_is_proc_ptr_comp (e, &ppc))
5383 else if (tb->nopass)
5386 po = extract_ppc_passed_object (e);
5393 gfc_error ("Passed-object at %L must be scalar", &e->where);
5398 if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
5400 gfc_error ("Base object for procedure-pointer component call at %L is of"
5401 " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name);
5405 gcc_assert (tb->pass_arg_num > 0);
5406 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5414 /* Check that the object a TBP is called on is valid, i.e. it must not be
5415 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5418 check_typebound_baseobject (gfc_expr* e)
5421 gfc_try return_value = FAILURE;
5423 base = extract_compcall_passed_object (e);
5427 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5430 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5432 gfc_error ("Base object for type-bound procedure call at %L is of"
5433 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5437 /* F08:C1230. If the procedure called is NOPASS,
5438 the base object must be scalar. */
5439 if (e->value.compcall.tbp->nopass && base->rank > 0)
5441 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5442 " be scalar", &e->where);
5446 /* FIXME: Remove once PR 43214 is fixed (TBP with non-scalar PASS). */
5449 gfc_error ("Non-scalar base object at %L currently not implemented",
5454 return_value = SUCCESS;
5457 gfc_free_expr (base);
5458 return return_value;
5462 /* Resolve a call to a type-bound procedure, either function or subroutine,
5463 statically from the data in an EXPR_COMPCALL expression. The adapted
5464 arglist and the target-procedure symtree are returned. */
5467 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5468 gfc_actual_arglist** actual)
5470 gcc_assert (e->expr_type == EXPR_COMPCALL);
5471 gcc_assert (!e->value.compcall.tbp->is_generic);
5473 /* Update the actual arglist for PASS. */
5474 if (update_compcall_arglist (e) == FAILURE)
5477 *actual = e->value.compcall.actual;
5478 *target = e->value.compcall.tbp->u.specific;
5480 gfc_free_ref_list (e->ref);
5482 e->value.compcall.actual = NULL;
5488 /* Get the ultimate declared type from an expression. In addition,
5489 return the last class/derived type reference and the copy of the
5492 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5495 gfc_symbol *declared;
5502 *new_ref = gfc_copy_ref (e->ref);
5504 for (ref = e->ref; ref; ref = ref->next)
5506 if (ref->type != REF_COMPONENT)
5509 if (ref->u.c.component->ts.type == BT_CLASS
5510 || ref->u.c.component->ts.type == BT_DERIVED)
5512 declared = ref->u.c.component->ts.u.derived;
5518 if (declared == NULL)
5519 declared = e->symtree->n.sym->ts.u.derived;
5525 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5526 which of the specific bindings (if any) matches the arglist and transform
5527 the expression into a call of that binding. */
5530 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5532 gfc_typebound_proc* genproc;
5533 const char* genname;
5535 gfc_symbol *derived;
5537 gcc_assert (e->expr_type == EXPR_COMPCALL);
5538 genname = e->value.compcall.name;
5539 genproc = e->value.compcall.tbp;
5541 if (!genproc->is_generic)
5544 /* Try the bindings on this type and in the inheritance hierarchy. */
5545 for (; genproc; genproc = genproc->overridden)
5549 gcc_assert (genproc->is_generic);
5550 for (g = genproc->u.generic; g; g = g->next)
5553 gfc_actual_arglist* args;
5556 gcc_assert (g->specific);
5558 if (g->specific->error)
5561 target = g->specific->u.specific->n.sym;
5563 /* Get the right arglist by handling PASS/NOPASS. */
5564 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5565 if (!g->specific->nopass)
5568 po = extract_compcall_passed_object (e);
5572 gcc_assert (g->specific->pass_arg_num > 0);
5573 gcc_assert (!g->specific->error);
5574 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5575 g->specific->pass_arg);
5577 resolve_actual_arglist (args, target->attr.proc,
5578 is_external_proc (target) && !target->formal);
5580 /* Check if this arglist matches the formal. */
5581 matches = gfc_arglist_matches_symbol (&args, target);
5583 /* Clean up and break out of the loop if we've found it. */
5584 gfc_free_actual_arglist (args);
5587 e->value.compcall.tbp = g->specific;
5588 genname = g->specific_st->name;
5589 /* Pass along the name for CLASS methods, where the vtab
5590 procedure pointer component has to be referenced. */
5598 /* Nothing matching found! */
5599 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5600 " '%s' at %L", genname, &e->where);
5604 /* Make sure that we have the right specific instance for the name. */
5605 derived = get_declared_from_expr (NULL, NULL, e);
5607 st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where);
5609 e->value.compcall.tbp = st->n.tb;
5615 /* Resolve a call to a type-bound subroutine. */
5618 resolve_typebound_call (gfc_code* c, const char **name)
5620 gfc_actual_arglist* newactual;
5621 gfc_symtree* target;
5623 /* Check that's really a SUBROUTINE. */
5624 if (!c->expr1->value.compcall.tbp->subroutine)
5626 gfc_error ("'%s' at %L should be a SUBROUTINE",
5627 c->expr1->value.compcall.name, &c->loc);
5631 if (check_typebound_baseobject (c->expr1) == FAILURE)
5634 /* Pass along the name for CLASS methods, where the vtab
5635 procedure pointer component has to be referenced. */
5637 *name = c->expr1->value.compcall.name;
5639 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5642 /* Transform into an ordinary EXEC_CALL for now. */
5644 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5647 c->ext.actual = newactual;
5648 c->symtree = target;
5649 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5651 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5653 gfc_free_expr (c->expr1);
5654 c->expr1 = gfc_get_expr ();
5655 c->expr1->expr_type = EXPR_FUNCTION;
5656 c->expr1->symtree = target;
5657 c->expr1->where = c->loc;
5659 return resolve_call (c);
5663 /* Resolve a component-call expression. */
5665 resolve_compcall (gfc_expr* e, const char **name)
5667 gfc_actual_arglist* newactual;
5668 gfc_symtree* target;
5670 /* Check that's really a FUNCTION. */
5671 if (!e->value.compcall.tbp->function)
5673 gfc_error ("'%s' at %L should be a FUNCTION",
5674 e->value.compcall.name, &e->where);
5678 /* These must not be assign-calls! */
5679 gcc_assert (!e->value.compcall.assign);
5681 if (check_typebound_baseobject (e) == FAILURE)
5684 /* Pass along the name for CLASS methods, where the vtab
5685 procedure pointer component has to be referenced. */
5687 *name = e->value.compcall.name;
5689 if (resolve_typebound_generic_call (e, name) == FAILURE)
5691 gcc_assert (!e->value.compcall.tbp->is_generic);
5693 /* Take the rank from the function's symbol. */
5694 if (e->value.compcall.tbp->u.specific->n.sym->as)
5695 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5697 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5698 arglist to the TBP's binding target. */
5700 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5703 e->value.function.actual = newactual;
5704 e->value.function.name = NULL;
5705 e->value.function.esym = target->n.sym;
5706 e->value.function.isym = NULL;
5707 e->symtree = target;
5708 e->ts = target->n.sym->ts;
5709 e->expr_type = EXPR_FUNCTION;
5711 /* Resolution is not necessary if this is a class subroutine; this
5712 function only has to identify the specific proc. Resolution of
5713 the call will be done next in resolve_typebound_call. */
5714 return gfc_resolve_expr (e);
5719 /* Resolve a typebound function, or 'method'. First separate all
5720 the non-CLASS references by calling resolve_compcall directly. */
5723 resolve_typebound_function (gfc_expr* e)
5725 gfc_symbol *declared;
5736 /* Deal with typebound operators for CLASS objects. */
5737 expr = e->value.compcall.base_object;
5738 if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
5740 /* Since the typebound operators are generic, we have to ensure
5741 that any delays in resolution are corrected and that the vtab
5744 declared = ts.u.derived;
5745 c = gfc_find_component (declared, "_vptr", true, true);
5746 if (c->ts.u.derived == NULL)
5747 c->ts.u.derived = gfc_find_derived_vtab (declared);
5749 if (resolve_compcall (e, &name) == FAILURE)
5752 /* Use the generic name if it is there. */
5753 name = name ? name : e->value.function.esym->name;
5754 e->symtree = expr->symtree;
5755 e->ref = gfc_copy_ref (expr->ref);
5756 gfc_add_vptr_component (e);
5757 gfc_add_component_ref (e, name);
5758 e->value.function.esym = NULL;
5763 return resolve_compcall (e, NULL);
5765 if (resolve_ref (e) == FAILURE)
5768 /* Get the CLASS declared type. */
5769 declared = get_declared_from_expr (&class_ref, &new_ref, e);
5771 /* Weed out cases of the ultimate component being a derived type. */
5772 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5773 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5775 gfc_free_ref_list (new_ref);
5776 return resolve_compcall (e, NULL);
5779 c = gfc_find_component (declared, "_data", true, true);
5780 declared = c->ts.u.derived;
5782 /* Treat the call as if it is a typebound procedure, in order to roll
5783 out the correct name for the specific function. */
5784 if (resolve_compcall (e, &name) == FAILURE)
5788 /* Then convert the expression to a procedure pointer component call. */
5789 e->value.function.esym = NULL;
5795 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5796 gfc_add_vptr_component (e);
5797 gfc_add_component_ref (e, name);
5799 /* Recover the typespec for the expression. This is really only
5800 necessary for generic procedures, where the additional call
5801 to gfc_add_component_ref seems to throw the collection of the
5802 correct typespec. */
5807 /* Resolve a typebound subroutine, or 'method'. First separate all
5808 the non-CLASS references by calling resolve_typebound_call
5812 resolve_typebound_subroutine (gfc_code *code)
5814 gfc_symbol *declared;
5823 st = code->expr1->symtree;
5825 /* Deal with typebound operators for CLASS objects. */
5826 expr = code->expr1->value.compcall.base_object;
5827 if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
5828 && code->expr1->value.compcall.name)
5830 /* Since the typebound operators are generic, we have to ensure
5831 that any delays in resolution are corrected and that the vtab
5833 ts = expr->symtree->n.sym->ts;
5834 declared = ts.u.derived;
5835 c = gfc_find_component (declared, "_vptr", true, true);
5836 if (c->ts.u.derived == NULL)
5837 c->ts.u.derived = gfc_find_derived_vtab (declared);
5839 if (resolve_typebound_call (code, &name) == FAILURE)
5842 /* Use the generic name if it is there. */
5843 name = name ? name : code->expr1->value.function.esym->name;
5844 code->expr1->symtree = expr->symtree;
5845 expr->symtree->n.sym->ts.u.derived = declared;
5846 gfc_add_vptr_component (code->expr1);
5847 gfc_add_component_ref (code->expr1, name);
5848 code->expr1->value.function.esym = NULL;
5853 return resolve_typebound_call (code, NULL);
5855 if (resolve_ref (code->expr1) == FAILURE)
5858 /* Get the CLASS declared type. */
5859 get_declared_from_expr (&class_ref, &new_ref, code->expr1);
5861 /* Weed out cases of the ultimate component being a derived type. */
5862 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5863 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5865 gfc_free_ref_list (new_ref);
5866 return resolve_typebound_call (code, NULL);
5869 if (resolve_typebound_call (code, &name) == FAILURE)
5871 ts = code->expr1->ts;
5873 /* Then convert the expression to a procedure pointer component call. */
5874 code->expr1->value.function.esym = NULL;
5875 code->expr1->symtree = st;
5878 code->expr1->ref = new_ref;
5880 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5881 gfc_add_vptr_component (code->expr1);
5882 gfc_add_component_ref (code->expr1, name);
5884 /* Recover the typespec for the expression. This is really only
5885 necessary for generic procedures, where the additional call
5886 to gfc_add_component_ref seems to throw the collection of the
5887 correct typespec. */
5888 code->expr1->ts = ts;
5893 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5896 resolve_ppc_call (gfc_code* c)
5898 gfc_component *comp;
5901 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
5904 c->resolved_sym = c->expr1->symtree->n.sym;
5905 c->expr1->expr_type = EXPR_VARIABLE;
5907 if (!comp->attr.subroutine)
5908 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
5910 if (resolve_ref (c->expr1) == FAILURE)
5913 if (update_ppc_arglist (c->expr1) == FAILURE)
5916 c->ext.actual = c->expr1->value.compcall.actual;
5918 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
5919 comp->formal == NULL) == FAILURE)
5922 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
5928 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5931 resolve_expr_ppc (gfc_expr* e)
5933 gfc_component *comp;
5936 b = gfc_is_proc_ptr_comp (e, &comp);
5939 /* Convert to EXPR_FUNCTION. */
5940 e->expr_type = EXPR_FUNCTION;
5941 e->value.function.isym = NULL;
5942 e->value.function.actual = e->value.compcall.actual;
5944 if (comp->as != NULL)
5945 e->rank = comp->as->rank;
5947 if (!comp->attr.function)
5948 gfc_add_function (&comp->attr, comp->name, &e->where);
5950 if (resolve_ref (e) == FAILURE)
5953 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
5954 comp->formal == NULL) == FAILURE)
5957 if (update_ppc_arglist (e) == FAILURE)
5960 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
5967 gfc_is_expandable_expr (gfc_expr *e)
5969 gfc_constructor *con;
5971 if (e->expr_type == EXPR_ARRAY)
5973 /* Traverse the constructor looking for variables that are flavor
5974 parameter. Parameters must be expanded since they are fully used at
5976 con = gfc_constructor_first (e->value.constructor);
5977 for (; con; con = gfc_constructor_next (con))
5979 if (con->expr->expr_type == EXPR_VARIABLE
5980 && con->expr->symtree
5981 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
5982 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
5984 if (con->expr->expr_type == EXPR_ARRAY
5985 && gfc_is_expandable_expr (con->expr))
5993 /* Resolve an expression. That is, make sure that types of operands agree
5994 with their operators, intrinsic operators are converted to function calls
5995 for overloaded types and unresolved function references are resolved. */
5998 gfc_resolve_expr (gfc_expr *e)
6006 /* inquiry_argument only applies to variables. */
6007 inquiry_save = inquiry_argument;
6008 if (e->expr_type != EXPR_VARIABLE)
6009 inquiry_argument = false;
6011 switch (e->expr_type)
6014 t = resolve_operator (e);
6020 if (check_host_association (e))
6021 t = resolve_function (e);
6024 t = resolve_variable (e);
6026 expression_rank (e);
6029 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6030 && e->ref->type != REF_SUBSTRING)
6031 gfc_resolve_substring_charlen (e);
6036 t = resolve_typebound_function (e);
6039 case EXPR_SUBSTRING:
6040 t = resolve_ref (e);
6049 t = resolve_expr_ppc (e);
6054 if (resolve_ref (e) == FAILURE)
6057 t = gfc_resolve_array_constructor (e);
6058 /* Also try to expand a constructor. */
6061 expression_rank (e);
6062 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6063 gfc_expand_constructor (e, false);
6066 /* This provides the opportunity for the length of constructors with
6067 character valued function elements to propagate the string length
6068 to the expression. */
6069 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6071 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6072 here rather then add a duplicate test for it above. */
6073 gfc_expand_constructor (e, false);
6074 t = gfc_resolve_character_array_constructor (e);
6079 case EXPR_STRUCTURE:
6080 t = resolve_ref (e);
6084 t = resolve_structure_cons (e, 0);
6088 t = gfc_simplify_expr (e, 0);
6092 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6095 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6098 inquiry_argument = inquiry_save;
6104 /* Resolve an expression from an iterator. They must be scalar and have
6105 INTEGER or (optionally) REAL type. */
6108 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6109 const char *name_msgid)
6111 if (gfc_resolve_expr (expr) == FAILURE)
6114 if (expr->rank != 0)
6116 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6120 if (expr->ts.type != BT_INTEGER)
6122 if (expr->ts.type == BT_REAL)
6125 return gfc_notify_std (GFC_STD_F95_DEL,
6126 "Deleted feature: %s at %L must be integer",
6127 _(name_msgid), &expr->where);
6130 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6137 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6145 /* Resolve the expressions in an iterator structure. If REAL_OK is
6146 false allow only INTEGER type iterators, otherwise allow REAL types. */
6149 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6151 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6155 if (gfc_check_vardef_context (iter->var, false, _("iterator variable"))
6159 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6160 "Start expression in DO loop") == FAILURE)
6163 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6164 "End expression in DO loop") == FAILURE)
6167 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6168 "Step expression in DO loop") == FAILURE)
6171 if (iter->step->expr_type == EXPR_CONSTANT)
6173 if ((iter->step->ts.type == BT_INTEGER
6174 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6175 || (iter->step->ts.type == BT_REAL
6176 && mpfr_sgn (iter->step->value.real) == 0))
6178 gfc_error ("Step expression in DO loop at %L cannot be zero",
6179 &iter->step->where);
6184 /* Convert start, end, and step to the same type as var. */
6185 if (iter->start->ts.kind != iter->var->ts.kind
6186 || iter->start->ts.type != iter->var->ts.type)
6187 gfc_convert_type (iter->start, &iter->var->ts, 2);
6189 if (iter->end->ts.kind != iter->var->ts.kind
6190 || iter->end->ts.type != iter->var->ts.type)
6191 gfc_convert_type (iter->end, &iter->var->ts, 2);
6193 if (iter->step->ts.kind != iter->var->ts.kind
6194 || iter->step->ts.type != iter->var->ts.type)
6195 gfc_convert_type (iter->step, &iter->var->ts, 2);
6197 if (iter->start->expr_type == EXPR_CONSTANT
6198 && iter->end->expr_type == EXPR_CONSTANT
6199 && iter->step->expr_type == EXPR_CONSTANT)
6202 if (iter->start->ts.type == BT_INTEGER)
6204 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6205 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6209 sgn = mpfr_sgn (iter->step->value.real);
6210 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6212 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6213 gfc_warning ("DO loop at %L will be executed zero times",
6214 &iter->step->where);
6221 /* Traversal function for find_forall_index. f == 2 signals that
6222 that variable itself is not to be checked - only the references. */
6225 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6227 if (expr->expr_type != EXPR_VARIABLE)
6230 /* A scalar assignment */
6231 if (!expr->ref || *f == 1)
6233 if (expr->symtree->n.sym == sym)
6245 /* Check whether the FORALL index appears in the expression or not.
6246 Returns SUCCESS if SYM is found in EXPR. */
6249 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6251 if (gfc_traverse_expr (expr, sym, forall_index, f))
6258 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6259 to be a scalar INTEGER variable. The subscripts and stride are scalar
6260 INTEGERs, and if stride is a constant it must be nonzero.
6261 Furthermore "A subscript or stride in a forall-triplet-spec shall
6262 not contain a reference to any index-name in the
6263 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6266 resolve_forall_iterators (gfc_forall_iterator *it)
6268 gfc_forall_iterator *iter, *iter2;
6270 for (iter = it; iter; iter = iter->next)
6272 if (gfc_resolve_expr (iter->var) == SUCCESS
6273 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6274 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6277 if (gfc_resolve_expr (iter->start) == SUCCESS
6278 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6279 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6280 &iter->start->where);
6281 if (iter->var->ts.kind != iter->start->ts.kind)
6282 gfc_convert_type (iter->start, &iter->var->ts, 2);
6284 if (gfc_resolve_expr (iter->end) == SUCCESS
6285 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6286 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6288 if (iter->var->ts.kind != iter->end->ts.kind)
6289 gfc_convert_type (iter->end, &iter->var->ts, 2);
6291 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6293 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6294 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6295 &iter->stride->where, "INTEGER");
6297 if (iter->stride->expr_type == EXPR_CONSTANT
6298 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6299 gfc_error ("FORALL stride expression at %L cannot be zero",
6300 &iter->stride->where);
6302 if (iter->var->ts.kind != iter->stride->ts.kind)
6303 gfc_convert_type (iter->stride, &iter->var->ts, 2);
6306 for (iter = it; iter; iter = iter->next)
6307 for (iter2 = iter; iter2; iter2 = iter2->next)
6309 if (find_forall_index (iter2->start,
6310 iter->var->symtree->n.sym, 0) == SUCCESS
6311 || find_forall_index (iter2->end,
6312 iter->var->symtree->n.sym, 0) == SUCCESS
6313 || find_forall_index (iter2->stride,
6314 iter->var->symtree->n.sym, 0) == SUCCESS)
6315 gfc_error ("FORALL index '%s' may not appear in triplet "
6316 "specification at %L", iter->var->symtree->name,
6317 &iter2->start->where);
6322 /* Given a pointer to a symbol that is a derived type, see if it's
6323 inaccessible, i.e. if it's defined in another module and the components are
6324 PRIVATE. The search is recursive if necessary. Returns zero if no
6325 inaccessible components are found, nonzero otherwise. */
6328 derived_inaccessible (gfc_symbol *sym)
6332 if (sym->attr.use_assoc && sym->attr.private_comp)
6335 for (c = sym->components; c; c = c->next)
6337 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6345 /* Resolve the argument of a deallocate expression. The expression must be
6346 a pointer or a full array. */
6349 resolve_deallocate_expr (gfc_expr *e)
6351 symbol_attribute attr;
6352 int allocatable, pointer;
6357 if (gfc_resolve_expr (e) == FAILURE)
6360 if (e->expr_type != EXPR_VARIABLE)
6363 sym = e->symtree->n.sym;
6365 if (sym->ts.type == BT_CLASS)
6367 allocatable = CLASS_DATA (sym)->attr.allocatable;
6368 pointer = CLASS_DATA (sym)->attr.class_pointer;
6372 allocatable = sym->attr.allocatable;
6373 pointer = sym->attr.pointer;
6375 for (ref = e->ref; ref; ref = ref->next)
6380 if (ref->u.ar.type != AR_FULL)
6385 c = ref->u.c.component;
6386 if (c->ts.type == BT_CLASS)
6388 allocatable = CLASS_DATA (c)->attr.allocatable;
6389 pointer = CLASS_DATA (c)->attr.class_pointer;
6393 allocatable = c->attr.allocatable;
6394 pointer = c->attr.pointer;
6404 attr = gfc_expr_attr (e);
6406 if (allocatable == 0 && attr.pointer == 0)
6409 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6415 && gfc_check_vardef_context (e, true, _("DEALLOCATE object")) == FAILURE)
6417 if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE)
6420 if (e->ts.type == BT_CLASS)
6422 /* Only deallocate the DATA component. */
6423 gfc_add_data_component (e);
6430 /* Returns true if the expression e contains a reference to the symbol sym. */
6432 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6434 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6441 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6443 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6447 /* Given the expression node e for an allocatable/pointer of derived type to be
6448 allocated, get the expression node to be initialized afterwards (needed for
6449 derived types with default initializers, and derived types with allocatable
6450 components that need nullification.) */
6453 gfc_expr_to_initialize (gfc_expr *e)
6459 result = gfc_copy_expr (e);
6461 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6462 for (ref = result->ref; ref; ref = ref->next)
6463 if (ref->type == REF_ARRAY && ref->next == NULL)
6465 ref->u.ar.type = AR_FULL;
6467 for (i = 0; i < ref->u.ar.dimen; i++)
6468 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6470 result->rank = ref->u.ar.dimen;
6478 /* If the last ref of an expression is an array ref, return a copy of the
6479 expression with that one removed. Otherwise, a copy of the original
6480 expression. This is used for allocate-expressions and pointer assignment
6481 LHS, where there may be an array specification that needs to be stripped
6482 off when using gfc_check_vardef_context. */
6485 remove_last_array_ref (gfc_expr* e)
6490 e2 = gfc_copy_expr (e);
6491 for (r = &e2->ref; *r; r = &(*r)->next)
6492 if ((*r)->type == REF_ARRAY && !(*r)->next)
6494 gfc_free_ref_list (*r);
6503 /* Used in resolve_allocate_expr to check that a allocation-object and
6504 a source-expr are conformable. This does not catch all possible
6505 cases; in particular a runtime checking is needed. */
6508 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6511 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6513 /* First compare rank. */
6514 if (tail && e1->rank != tail->u.ar.as->rank)
6516 gfc_error ("Source-expr at %L must be scalar or have the "
6517 "same rank as the allocate-object at %L",
6518 &e1->where, &e2->where);
6529 for (i = 0; i < e1->rank; i++)
6531 if (tail->u.ar.end[i])
6533 mpz_set (s, tail->u.ar.end[i]->value.integer);
6534 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6535 mpz_add_ui (s, s, 1);
6539 mpz_set (s, tail->u.ar.start[i]->value.integer);
6542 if (mpz_cmp (e1->shape[i], s) != 0)
6544 gfc_error ("Source-expr at %L and allocate-object at %L must "
6545 "have the same shape", &e1->where, &e2->where);
6558 /* Resolve the expression in an ALLOCATE statement, doing the additional
6559 checks to see whether the expression is OK or not. The expression must
6560 have a trailing array reference that gives the size of the array. */
6563 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6565 int i, pointer, allocatable, dimension, is_abstract;
6567 symbol_attribute attr;
6568 gfc_ref *ref, *ref2;
6571 gfc_symbol *sym = NULL;
6576 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6577 checking of coarrays. */
6578 for (ref = e->ref; ref; ref = ref->next)
6579 if (ref->next == NULL)
6582 if (ref && ref->type == REF_ARRAY)
6583 ref->u.ar.in_allocate = true;
6585 if (gfc_resolve_expr (e) == FAILURE)
6588 /* Make sure the expression is allocatable or a pointer. If it is
6589 pointer, the next-to-last reference must be a pointer. */
6593 sym = e->symtree->n.sym;
6595 /* Check whether ultimate component is abstract and CLASS. */
6598 if (e->expr_type != EXPR_VARIABLE)
6601 attr = gfc_expr_attr (e);
6602 pointer = attr.pointer;
6603 dimension = attr.dimension;
6604 codimension = attr.codimension;
6608 if (sym->ts.type == BT_CLASS)
6610 allocatable = CLASS_DATA (sym)->attr.allocatable;
6611 pointer = CLASS_DATA (sym)->attr.class_pointer;
6612 dimension = CLASS_DATA (sym)->attr.dimension;
6613 codimension = CLASS_DATA (sym)->attr.codimension;
6614 is_abstract = CLASS_DATA (sym)->attr.abstract;
6618 allocatable = sym->attr.allocatable;
6619 pointer = sym->attr.pointer;
6620 dimension = sym->attr.dimension;
6621 codimension = sym->attr.codimension;
6624 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6629 if (ref->next != NULL)
6635 if (gfc_is_coindexed (e))
6637 gfc_error ("Coindexed allocatable object at %L",
6642 c = ref->u.c.component;
6643 if (c->ts.type == BT_CLASS)
6645 allocatable = CLASS_DATA (c)->attr.allocatable;
6646 pointer = CLASS_DATA (c)->attr.class_pointer;
6647 dimension = CLASS_DATA (c)->attr.dimension;
6648 codimension = CLASS_DATA (c)->attr.codimension;
6649 is_abstract = CLASS_DATA (c)->attr.abstract;
6653 allocatable = c->attr.allocatable;
6654 pointer = c->attr.pointer;
6655 dimension = c->attr.dimension;
6656 codimension = c->attr.codimension;
6657 is_abstract = c->attr.abstract;
6669 if (allocatable == 0 && pointer == 0)
6671 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6676 /* Some checks for the SOURCE tag. */
6679 /* Check F03:C631. */
6680 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6682 gfc_error ("Type of entity at %L is type incompatible with "
6683 "source-expr at %L", &e->where, &code->expr3->where);
6687 /* Check F03:C632 and restriction following Note 6.18. */
6688 if (code->expr3->rank > 0
6689 && conformable_arrays (code->expr3, e) == FAILURE)
6692 /* Check F03:C633. */
6693 if (code->expr3->ts.kind != e->ts.kind)
6695 gfc_error ("The allocate-object at %L and the source-expr at %L "
6696 "shall have the same kind type parameter",
6697 &e->where, &code->expr3->where);
6702 /* Check F08:C629. */
6703 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
6706 gcc_assert (e->ts.type == BT_CLASS);
6707 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6708 "type-spec or source-expr", sym->name, &e->where);
6712 /* In the variable definition context checks, gfc_expr_attr is used
6713 on the expression. This is fooled by the array specification
6714 present in e, thus we have to eliminate that one temporarily. */
6715 e2 = remove_last_array_ref (e);
6717 if (t == SUCCESS && pointer)
6718 t = gfc_check_vardef_context (e2, true, _("ALLOCATE object"));
6720 t = gfc_check_vardef_context (e2, false, _("ALLOCATE object"));
6727 /* Set up default initializer if needed. */
6731 if (code->ext.alloc.ts.type == BT_DERIVED)
6732 ts = code->ext.alloc.ts;
6736 if (ts.type == BT_CLASS)
6737 ts = ts.u.derived->components->ts;
6739 if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
6741 gfc_code *init_st = gfc_get_code ();
6742 init_st->loc = code->loc;
6743 init_st->op = EXEC_INIT_ASSIGN;
6744 init_st->expr1 = gfc_expr_to_initialize (e);
6745 init_st->expr2 = init_e;
6746 init_st->next = code->next;
6747 code->next = init_st;
6750 else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
6752 /* Default initialization via MOLD (non-polymorphic). */
6753 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
6754 gfc_resolve_expr (rhs);
6755 gfc_free_expr (code->expr3);
6759 if (e->ts.type == BT_CLASS)
6761 /* Make sure the vtab symbol is present when
6762 the module variables are generated. */
6763 gfc_typespec ts = e->ts;
6765 ts = code->expr3->ts;
6766 else if (code->ext.alloc.ts.type == BT_DERIVED)
6767 ts = code->ext.alloc.ts;
6768 gfc_find_derived_vtab (ts.u.derived);
6771 if (pointer || (dimension == 0 && codimension == 0))
6774 /* Make sure the last reference node is an array specifiction. */
6776 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
6777 || (dimension && ref2->u.ar.dimen == 0))
6779 gfc_error ("Array specification required in ALLOCATE statement "
6780 "at %L", &e->where);
6784 /* Make sure that the array section reference makes sense in the
6785 context of an ALLOCATE specification. */
6789 if (codimension && ar->codimen == 0)
6791 gfc_error ("Coarray specification required in ALLOCATE statement "
6792 "at %L", &e->where);
6796 for (i = 0; i < ar->dimen; i++)
6798 if (ref2->u.ar.type == AR_ELEMENT)
6801 switch (ar->dimen_type[i])
6807 if (ar->start[i] != NULL
6808 && ar->end[i] != NULL
6809 && ar->stride[i] == NULL)
6812 /* Fall Through... */
6817 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6823 for (a = code->ext.alloc.list; a; a = a->next)
6825 sym = a->expr->symtree->n.sym;
6827 /* TODO - check derived type components. */
6828 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6831 if ((ar->start[i] != NULL
6832 && gfc_find_sym_in_expr (sym, ar->start[i]))
6833 || (ar->end[i] != NULL
6834 && gfc_find_sym_in_expr (sym, ar->end[i])))
6836 gfc_error ("'%s' must not appear in the array specification at "
6837 "%L in the same ALLOCATE statement where it is "
6838 "itself allocated", sym->name, &ar->where);
6844 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
6846 if (ar->dimen_type[i] == DIMEN_ELEMENT
6847 || ar->dimen_type[i] == DIMEN_RANGE)
6849 if (i == (ar->dimen + ar->codimen - 1))
6851 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
6852 "statement at %L", &e->where);
6858 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
6859 && ar->stride[i] == NULL)
6862 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
6867 if (codimension && ar->as->rank == 0)
6869 gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
6870 "at %L", &e->where);
6877 gfc_error ("Support for entity at %L with deferred type parameter "
6878 "not yet implemented", &e->where);
6888 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
6890 gfc_expr *stat, *errmsg, *pe, *qe;
6891 gfc_alloc *a, *p, *q;
6894 errmsg = code->expr2;
6896 /* Check the stat variable. */
6899 gfc_check_vardef_context (stat, false, _("STAT variable"));
6901 if ((stat->ts.type != BT_INTEGER
6902 && !(stat->ref && (stat->ref->type == REF_ARRAY
6903 || stat->ref->type == REF_COMPONENT)))
6905 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
6906 "variable", &stat->where);
6908 for (p = code->ext.alloc.list; p; p = p->next)
6909 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
6911 gfc_ref *ref1, *ref2;
6914 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
6915 ref1 = ref1->next, ref2 = ref2->next)
6917 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6919 if (ref1->u.c.component->name != ref2->u.c.component->name)
6928 gfc_error ("Stat-variable at %L shall not be %sd within "
6929 "the same %s statement", &stat->where, fcn, fcn);
6935 /* Check the errmsg variable. */
6939 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
6942 gfc_check_vardef_context (errmsg, false, _("ERRMSG variable"));
6944 if ((errmsg->ts.type != BT_CHARACTER
6946 && (errmsg->ref->type == REF_ARRAY
6947 || errmsg->ref->type == REF_COMPONENT)))
6948 || errmsg->rank > 0 )
6949 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
6950 "variable", &errmsg->where);
6952 for (p = code->ext.alloc.list; p; p = p->next)
6953 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
6955 gfc_ref *ref1, *ref2;
6958 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
6959 ref1 = ref1->next, ref2 = ref2->next)
6961 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6963 if (ref1->u.c.component->name != ref2->u.c.component->name)
6972 gfc_error ("Errmsg-variable at %L shall not be %sd within "
6973 "the same %s statement", &errmsg->where, fcn, fcn);
6979 /* Check that an allocate-object appears only once in the statement.
6980 FIXME: Checking derived types is disabled. */
6981 for (p = code->ext.alloc.list; p; p = p->next)
6984 if ((pe->ref && pe->ref->type != REF_COMPONENT)
6985 && (pe->symtree->n.sym->ts.type != BT_DERIVED))
6987 for (q = p->next; q; q = q->next)
6990 if ((qe->ref && qe->ref->type != REF_COMPONENT)
6991 && (qe->symtree->n.sym->ts.type != BT_DERIVED)
6992 && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
6993 gfc_error ("Allocate-object at %L also appears at %L",
6994 &pe->where, &qe->where);
6999 if (strcmp (fcn, "ALLOCATE") == 0)
7001 for (a = code->ext.alloc.list; a; a = a->next)
7002 resolve_allocate_expr (a->expr, code);
7006 for (a = code->ext.alloc.list; a; a = a->next)
7007 resolve_deallocate_expr (a->expr);
7012 /************ SELECT CASE resolution subroutines ************/
7014 /* Callback function for our mergesort variant. Determines interval
7015 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7016 op1 > op2. Assumes we're not dealing with the default case.
7017 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7018 There are nine situations to check. */
7021 compare_cases (const gfc_case *op1, const gfc_case *op2)
7025 if (op1->low == NULL) /* op1 = (:L) */
7027 /* op2 = (:N), so overlap. */
7029 /* op2 = (M:) or (M:N), L < M */
7030 if (op2->low != NULL
7031 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7034 else if (op1->high == NULL) /* op1 = (K:) */
7036 /* op2 = (M:), so overlap. */
7038 /* op2 = (:N) or (M:N), K > N */
7039 if (op2->high != NULL
7040 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7043 else /* op1 = (K:L) */
7045 if (op2->low == NULL) /* op2 = (:N), K > N */
7046 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7048 else if (op2->high == NULL) /* op2 = (M:), L < M */
7049 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7051 else /* op2 = (M:N) */
7055 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7058 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7067 /* Merge-sort a double linked case list, detecting overlap in the
7068 process. LIST is the head of the double linked case list before it
7069 is sorted. Returns the head of the sorted list if we don't see any
7070 overlap, or NULL otherwise. */
7073 check_case_overlap (gfc_case *list)
7075 gfc_case *p, *q, *e, *tail;
7076 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7078 /* If the passed list was empty, return immediately. */
7085 /* Loop unconditionally. The only exit from this loop is a return
7086 statement, when we've finished sorting the case list. */
7093 /* Count the number of merges we do in this pass. */
7096 /* Loop while there exists a merge to be done. */
7101 /* Count this merge. */
7104 /* Cut the list in two pieces by stepping INSIZE places
7105 forward in the list, starting from P. */
7108 for (i = 0; i < insize; i++)
7117 /* Now we have two lists. Merge them! */
7118 while (psize > 0 || (qsize > 0 && q != NULL))
7120 /* See from which the next case to merge comes from. */
7123 /* P is empty so the next case must come from Q. */
7128 else if (qsize == 0 || q == NULL)
7137 cmp = compare_cases (p, q);
7140 /* The whole case range for P is less than the
7148 /* The whole case range for Q is greater than
7149 the case range for P. */
7156 /* The cases overlap, or they are the same
7157 element in the list. Either way, we must
7158 issue an error and get the next case from P. */
7159 /* FIXME: Sort P and Q by line number. */
7160 gfc_error ("CASE label at %L overlaps with CASE "
7161 "label at %L", &p->where, &q->where);
7169 /* Add the next element to the merged list. */
7178 /* P has now stepped INSIZE places along, and so has Q. So
7179 they're the same. */
7184 /* If we have done only one merge or none at all, we've
7185 finished sorting the cases. */
7194 /* Otherwise repeat, merging lists twice the size. */
7200 /* Check to see if an expression is suitable for use in a CASE statement.
7201 Makes sure that all case expressions are scalar constants of the same
7202 type. Return FAILURE if anything is wrong. */
7205 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7207 if (e == NULL) return SUCCESS;
7209 if (e->ts.type != case_expr->ts.type)
7211 gfc_error ("Expression in CASE statement at %L must be of type %s",
7212 &e->where, gfc_basic_typename (case_expr->ts.type));
7216 /* C805 (R808) For a given case-construct, each case-value shall be of
7217 the same type as case-expr. For character type, length differences
7218 are allowed, but the kind type parameters shall be the same. */
7220 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7222 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7223 &e->where, case_expr->ts.kind);
7227 /* Convert the case value kind to that of case expression kind,
7230 if (e->ts.kind != case_expr->ts.kind)
7231 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7235 gfc_error ("Expression in CASE statement at %L must be scalar",
7244 /* Given a completely parsed select statement, we:
7246 - Validate all expressions and code within the SELECT.
7247 - Make sure that the selection expression is not of the wrong type.
7248 - Make sure that no case ranges overlap.
7249 - Eliminate unreachable cases and unreachable code resulting from
7250 removing case labels.
7252 The standard does allow unreachable cases, e.g. CASE (5:3). But
7253 they are a hassle for code generation, and to prevent that, we just
7254 cut them out here. This is not necessary for overlapping cases
7255 because they are illegal and we never even try to generate code.
7257 We have the additional caveat that a SELECT construct could have
7258 been a computed GOTO in the source code. Fortunately we can fairly
7259 easily work around that here: The case_expr for a "real" SELECT CASE
7260 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7261 we have to do is make sure that the case_expr is a scalar integer
7265 resolve_select (gfc_code *code)
7268 gfc_expr *case_expr;
7269 gfc_case *cp, *default_case, *tail, *head;
7270 int seen_unreachable;
7276 if (code->expr1 == NULL)
7278 /* This was actually a computed GOTO statement. */
7279 case_expr = code->expr2;
7280 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7281 gfc_error ("Selection expression in computed GOTO statement "
7282 "at %L must be a scalar integer expression",
7285 /* Further checking is not necessary because this SELECT was built
7286 by the compiler, so it should always be OK. Just move the
7287 case_expr from expr2 to expr so that we can handle computed
7288 GOTOs as normal SELECTs from here on. */
7289 code->expr1 = code->expr2;
7294 case_expr = code->expr1;
7296 type = case_expr->ts.type;
7297 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7299 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7300 &case_expr->where, gfc_typename (&case_expr->ts));
7302 /* Punt. Going on here just produce more garbage error messages. */
7306 if (case_expr->rank != 0)
7308 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7309 "expression", &case_expr->where);
7316 /* Raise a warning if an INTEGER case value exceeds the range of
7317 the case-expr. Later, all expressions will be promoted to the
7318 largest kind of all case-labels. */
7320 if (type == BT_INTEGER)
7321 for (body = code->block; body; body = body->block)
7322 for (cp = body->ext.case_list; cp; cp = cp->next)
7325 && gfc_check_integer_range (cp->low->value.integer,
7326 case_expr->ts.kind) != ARITH_OK)
7327 gfc_warning ("Expression in CASE statement at %L is "
7328 "not in the range of %s", &cp->low->where,
7329 gfc_typename (&case_expr->ts));
7332 && cp->low != cp->high
7333 && gfc_check_integer_range (cp->high->value.integer,
7334 case_expr->ts.kind) != ARITH_OK)
7335 gfc_warning ("Expression in CASE statement at %L is "
7336 "not in the range of %s", &cp->high->where,
7337 gfc_typename (&case_expr->ts));
7340 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7341 of the SELECT CASE expression and its CASE values. Walk the lists
7342 of case values, and if we find a mismatch, promote case_expr to
7343 the appropriate kind. */
7345 if (type == BT_LOGICAL || type == BT_INTEGER)
7347 for (body = code->block; body; body = body->block)
7349 /* Walk the case label list. */
7350 for (cp = body->ext.case_list; cp; cp = cp->next)
7352 /* Intercept the DEFAULT case. It does not have a kind. */
7353 if (cp->low == NULL && cp->high == NULL)
7356 /* Unreachable case ranges are discarded, so ignore. */
7357 if (cp->low != NULL && cp->high != NULL
7358 && cp->low != cp->high
7359 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7363 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7364 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7366 if (cp->high != NULL
7367 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7368 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7373 /* Assume there is no DEFAULT case. */
7374 default_case = NULL;
7379 for (body = code->block; body; body = body->block)
7381 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7383 seen_unreachable = 0;
7385 /* Walk the case label list, making sure that all case labels
7387 for (cp = body->ext.case_list; cp; cp = cp->next)
7389 /* Count the number of cases in the whole construct. */
7392 /* Intercept the DEFAULT case. */
7393 if (cp->low == NULL && cp->high == NULL)
7395 if (default_case != NULL)
7397 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7398 "by a second DEFAULT CASE at %L",
7399 &default_case->where, &cp->where);
7410 /* Deal with single value cases and case ranges. Errors are
7411 issued from the validation function. */
7412 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7413 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7419 if (type == BT_LOGICAL
7420 && ((cp->low == NULL || cp->high == NULL)
7421 || cp->low != cp->high))
7423 gfc_error ("Logical range in CASE statement at %L is not "
7424 "allowed", &cp->low->where);
7429 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7432 value = cp->low->value.logical == 0 ? 2 : 1;
7433 if (value & seen_logical)
7435 gfc_error ("Constant logical value in CASE statement "
7436 "is repeated at %L",
7441 seen_logical |= value;
7444 if (cp->low != NULL && cp->high != NULL
7445 && cp->low != cp->high
7446 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7448 if (gfc_option.warn_surprising)
7449 gfc_warning ("Range specification at %L can never "
7450 "be matched", &cp->where);
7452 cp->unreachable = 1;
7453 seen_unreachable = 1;
7457 /* If the case range can be matched, it can also overlap with
7458 other cases. To make sure it does not, we put it in a
7459 double linked list here. We sort that with a merge sort
7460 later on to detect any overlapping cases. */
7464 head->right = head->left = NULL;
7469 tail->right->left = tail;
7476 /* It there was a failure in the previous case label, give up
7477 for this case label list. Continue with the next block. */
7481 /* See if any case labels that are unreachable have been seen.
7482 If so, we eliminate them. This is a bit of a kludge because
7483 the case lists for a single case statement (label) is a
7484 single forward linked lists. */
7485 if (seen_unreachable)
7487 /* Advance until the first case in the list is reachable. */
7488 while (body->ext.case_list != NULL
7489 && body->ext.case_list->unreachable)
7491 gfc_case *n = body->ext.case_list;
7492 body->ext.case_list = body->ext.case_list->next;
7494 gfc_free_case_list (n);
7497 /* Strip all other unreachable cases. */
7498 if (body->ext.case_list)
7500 for (cp = body->ext.case_list; cp->next; cp = cp->next)
7502 if (cp->next->unreachable)
7504 gfc_case *n = cp->next;
7505 cp->next = cp->next->next;
7507 gfc_free_case_list (n);
7514 /* See if there were overlapping cases. If the check returns NULL,
7515 there was overlap. In that case we don't do anything. If head
7516 is non-NULL, we prepend the DEFAULT case. The sorted list can
7517 then used during code generation for SELECT CASE constructs with
7518 a case expression of a CHARACTER type. */
7521 head = check_case_overlap (head);
7523 /* Prepend the default_case if it is there. */
7524 if (head != NULL && default_case)
7526 default_case->left = NULL;
7527 default_case->right = head;
7528 head->left = default_case;
7532 /* Eliminate dead blocks that may be the result if we've seen
7533 unreachable case labels for a block. */
7534 for (body = code; body && body->block; body = body->block)
7536 if (body->block->ext.case_list == NULL)
7538 /* Cut the unreachable block from the code chain. */
7539 gfc_code *c = body->block;
7540 body->block = c->block;
7542 /* Kill the dead block, but not the blocks below it. */
7544 gfc_free_statements (c);
7548 /* More than two cases is legal but insane for logical selects.
7549 Issue a warning for it. */
7550 if (gfc_option.warn_surprising && type == BT_LOGICAL
7552 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7557 /* Check if a derived type is extensible. */
7560 gfc_type_is_extensible (gfc_symbol *sym)
7562 return !(sym->attr.is_bind_c || sym->attr.sequence);
7566 /* Resolve an associate name: Resolve target and ensure the type-spec is
7567 correct as well as possibly the array-spec. */
7570 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
7574 gcc_assert (sym->assoc);
7575 gcc_assert (sym->attr.flavor == FL_VARIABLE);
7577 /* If this is for SELECT TYPE, the target may not yet be set. In that
7578 case, return. Resolution will be called later manually again when
7580 target = sym->assoc->target;
7583 gcc_assert (!sym->assoc->dangling);
7585 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
7588 /* For variable targets, we get some attributes from the target. */
7589 if (target->expr_type == EXPR_VARIABLE)
7593 gcc_assert (target->symtree);
7594 tsym = target->symtree->n.sym;
7596 sym->attr.asynchronous = tsym->attr.asynchronous;
7597 sym->attr.volatile_ = tsym->attr.volatile_;
7599 sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
7602 /* Get type if this was not already set. Note that it can be
7603 some other type than the target in case this is a SELECT TYPE
7604 selector! So we must not update when the type is already there. */
7605 if (sym->ts.type == BT_UNKNOWN)
7606 sym->ts = target->ts;
7607 gcc_assert (sym->ts.type != BT_UNKNOWN);
7609 /* See if this is a valid association-to-variable. */
7610 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
7611 && !gfc_has_vector_subscript (target));
7613 /* Finally resolve if this is an array or not. */
7614 if (sym->attr.dimension && target->rank == 0)
7616 gfc_error ("Associate-name '%s' at %L is used as array",
7617 sym->name, &sym->declared_at);
7618 sym->attr.dimension = 0;
7621 if (target->rank > 0)
7622 sym->attr.dimension = 1;
7624 if (sym->attr.dimension)
7626 sym->as = gfc_get_array_spec ();
7627 sym->as->rank = target->rank;
7628 sym->as->type = AS_DEFERRED;
7630 /* Target must not be coindexed, thus the associate-variable
7632 sym->as->corank = 0;
7637 /* Resolve a SELECT TYPE statement. */
7640 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
7642 gfc_symbol *selector_type;
7643 gfc_code *body, *new_st, *if_st, *tail;
7644 gfc_code *class_is = NULL, *default_case = NULL;
7647 char name[GFC_MAX_SYMBOL_LEN];
7651 ns = code->ext.block.ns;
7654 /* Check for F03:C813. */
7655 if (code->expr1->ts.type != BT_CLASS
7656 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
7658 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7659 "at %L", &code->loc);
7665 if (code->expr1->symtree->n.sym->attr.untyped)
7666 code->expr1->symtree->n.sym->ts = code->expr2->ts;
7667 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
7670 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
7672 /* Loop over TYPE IS / CLASS IS cases. */
7673 for (body = code->block; body; body = body->block)
7675 c = body->ext.case_list;
7677 /* Check F03:C815. */
7678 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7679 && !gfc_type_is_extensible (c->ts.u.derived))
7681 gfc_error ("Derived type '%s' at %L must be extensible",
7682 c->ts.u.derived->name, &c->where);
7687 /* Check F03:C816. */
7688 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7689 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
7691 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7692 c->ts.u.derived->name, &c->where, selector_type->name);
7697 /* Intercept the DEFAULT case. */
7698 if (c->ts.type == BT_UNKNOWN)
7700 /* Check F03:C818. */
7703 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7704 "by a second DEFAULT CASE at %L",
7705 &default_case->ext.case_list->where, &c->where);
7710 default_case = body;
7717 /* Transform SELECT TYPE statement to BLOCK and associate selector to
7718 target if present. If there are any EXIT statements referring to the
7719 SELECT TYPE construct, this is no problem because the gfc_code
7720 reference stays the same and EXIT is equally possible from the BLOCK
7721 it is changed to. */
7722 code->op = EXEC_BLOCK;
7725 gfc_association_list* assoc;
7727 assoc = gfc_get_association_list ();
7728 assoc->st = code->expr1->symtree;
7729 assoc->target = gfc_copy_expr (code->expr2);
7730 /* assoc->variable will be set by resolve_assoc_var. */
7732 code->ext.block.assoc = assoc;
7733 code->expr1->symtree->n.sym->assoc = assoc;
7735 resolve_assoc_var (code->expr1->symtree->n.sym, false);
7738 code->ext.block.assoc = NULL;
7740 /* Add EXEC_SELECT to switch on type. */
7741 new_st = gfc_get_code ();
7742 new_st->op = code->op;
7743 new_st->expr1 = code->expr1;
7744 new_st->expr2 = code->expr2;
7745 new_st->block = code->block;
7746 code->expr1 = code->expr2 = NULL;
7751 ns->code->next = new_st;
7753 code->op = EXEC_SELECT;
7754 gfc_add_vptr_component (code->expr1);
7755 gfc_add_hash_component (code->expr1);
7757 /* Loop over TYPE IS / CLASS IS cases. */
7758 for (body = code->block; body; body = body->block)
7760 c = body->ext.case_list;
7762 if (c->ts.type == BT_DERIVED)
7763 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7764 c->ts.u.derived->hash_value);
7766 else if (c->ts.type == BT_UNKNOWN)
7769 /* Associate temporary to selector. This should only be done
7770 when this case is actually true, so build a new ASSOCIATE
7771 that does precisely this here (instead of using the
7774 if (c->ts.type == BT_CLASS)
7775 sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
7777 sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
7778 st = gfc_find_symtree (ns->sym_root, name);
7779 gcc_assert (st->n.sym->assoc);
7780 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
7781 if (c->ts.type == BT_DERIVED)
7782 gfc_add_data_component (st->n.sym->assoc->target);
7784 new_st = gfc_get_code ();
7785 new_st->op = EXEC_BLOCK;
7786 new_st->ext.block.ns = gfc_build_block_ns (ns);
7787 new_st->ext.block.ns->code = body->next;
7788 body->next = new_st;
7790 /* Chain in the new list only if it is marked as dangling. Otherwise
7791 there is a CASE label overlap and this is already used. Just ignore,
7792 the error is diagonsed elsewhere. */
7793 if (st->n.sym->assoc->dangling)
7795 new_st->ext.block.assoc = st->n.sym->assoc;
7796 st->n.sym->assoc->dangling = 0;
7799 resolve_assoc_var (st->n.sym, false);
7802 /* Take out CLASS IS cases for separate treatment. */
7804 while (body && body->block)
7806 if (body->block->ext.case_list->ts.type == BT_CLASS)
7808 /* Add to class_is list. */
7809 if (class_is == NULL)
7811 class_is = body->block;
7816 for (tail = class_is; tail->block; tail = tail->block) ;
7817 tail->block = body->block;
7820 /* Remove from EXEC_SELECT list. */
7821 body->block = body->block->block;
7834 /* Add a default case to hold the CLASS IS cases. */
7835 for (tail = code; tail->block; tail = tail->block) ;
7836 tail->block = gfc_get_code ();
7838 tail->op = EXEC_SELECT_TYPE;
7839 tail->ext.case_list = gfc_get_case ();
7840 tail->ext.case_list->ts.type = BT_UNKNOWN;
7842 default_case = tail;
7845 /* More than one CLASS IS block? */
7846 if (class_is->block)
7850 /* Sort CLASS IS blocks by extension level. */
7854 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
7857 /* F03:C817 (check for doubles). */
7858 if ((*c1)->ext.case_list->ts.u.derived->hash_value
7859 == c2->ext.case_list->ts.u.derived->hash_value)
7861 gfc_error ("Double CLASS IS block in SELECT TYPE "
7862 "statement at %L", &c2->ext.case_list->where);
7865 if ((*c1)->ext.case_list->ts.u.derived->attr.extension
7866 < c2->ext.case_list->ts.u.derived->attr.extension)
7869 (*c1)->block = c2->block;
7879 /* Generate IF chain. */
7880 if_st = gfc_get_code ();
7881 if_st->op = EXEC_IF;
7883 for (body = class_is; body; body = body->block)
7885 new_st->block = gfc_get_code ();
7886 new_st = new_st->block;
7887 new_st->op = EXEC_IF;
7888 /* Set up IF condition: Call _gfortran_is_extension_of. */
7889 new_st->expr1 = gfc_get_expr ();
7890 new_st->expr1->expr_type = EXPR_FUNCTION;
7891 new_st->expr1->ts.type = BT_LOGICAL;
7892 new_st->expr1->ts.kind = 4;
7893 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
7894 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
7895 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
7896 /* Set up arguments. */
7897 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
7898 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
7899 new_st->expr1->value.function.actual->expr->where = code->loc;
7900 gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
7901 vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
7902 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
7903 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
7904 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
7905 new_st->next = body->next;
7907 if (default_case->next)
7909 new_st->block = gfc_get_code ();
7910 new_st = new_st->block;
7911 new_st->op = EXEC_IF;
7912 new_st->next = default_case->next;
7915 /* Replace CLASS DEFAULT code by the IF chain. */
7916 default_case->next = if_st;
7919 /* Resolve the internal code. This can not be done earlier because
7920 it requires that the sym->assoc of selectors is set already. */
7921 gfc_current_ns = ns;
7922 gfc_resolve_blocks (code->block, gfc_current_ns);
7923 gfc_current_ns = old_ns;
7925 resolve_select (code);
7929 /* Resolve a transfer statement. This is making sure that:
7930 -- a derived type being transferred has only non-pointer components
7931 -- a derived type being transferred doesn't have private components, unless
7932 it's being transferred from the module where the type was defined
7933 -- we're not trying to transfer a whole assumed size array. */
7936 resolve_transfer (gfc_code *code)
7945 while (exp != NULL && exp->expr_type == EXPR_OP
7946 && exp->value.op.op == INTRINSIC_PARENTHESES)
7947 exp = exp->value.op.op1;
7949 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
7950 && exp->expr_type != EXPR_FUNCTION))
7953 /* If we are reading, the variable will be changed. Note that
7954 code->ext.dt may be NULL if the TRANSFER is related to
7955 an INQUIRE statement -- but in this case, we are not reading, either. */
7956 if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
7957 && gfc_check_vardef_context (exp, false, _("item in READ")) == FAILURE)
7960 sym = exp->symtree->n.sym;
7963 /* Go to actual component transferred. */
7964 for (ref = exp->ref; ref; ref = ref->next)
7965 if (ref->type == REF_COMPONENT)
7966 ts = &ref->u.c.component->ts;
7968 if (ts->type == BT_CLASS)
7970 /* FIXME: Test for defined input/output. */
7971 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
7972 "it is processed by a defined input/output procedure",
7977 if (ts->type == BT_DERIVED)
7979 /* Check that transferred derived type doesn't contain POINTER
7981 if (ts->u.derived->attr.pointer_comp)
7983 gfc_error ("Data transfer element at %L cannot have "
7984 "POINTER components", &code->loc);
7988 if (ts->u.derived->attr.alloc_comp)
7990 gfc_error ("Data transfer element at %L cannot have "
7991 "ALLOCATABLE components", &code->loc);
7995 if (derived_inaccessible (ts->u.derived))
7997 gfc_error ("Data transfer element at %L cannot have "
7998 "PRIVATE components",&code->loc);
8003 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
8004 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
8006 gfc_error ("Data transfer element at %L cannot be a full reference to "
8007 "an assumed-size array", &code->loc);
8013 /*********** Toplevel code resolution subroutines ***********/
8015 /* Find the set of labels that are reachable from this block. We also
8016 record the last statement in each block. */
8019 find_reachable_labels (gfc_code *block)
8026 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
8028 /* Collect labels in this block. We don't keep those corresponding
8029 to END {IF|SELECT}, these are checked in resolve_branch by going
8030 up through the code_stack. */
8031 for (c = block; c; c = c->next)
8033 if (c->here && c->op != EXEC_END_BLOCK)
8034 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8037 /* Merge with labels from parent block. */
8040 gcc_assert (cs_base->prev->reachable_labels);
8041 bitmap_ior_into (cs_base->reachable_labels,
8042 cs_base->prev->reachable_labels);
8048 resolve_sync (gfc_code *code)
8050 /* Check imageset. The * case matches expr1 == NULL. */
8053 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8054 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8055 "INTEGER expression", &code->expr1->where);
8056 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8057 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8058 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8059 &code->expr1->where);
8060 else if (code->expr1->expr_type == EXPR_ARRAY
8061 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8063 gfc_constructor *cons;
8064 cons = gfc_constructor_first (code->expr1->value.constructor);
8065 for (; cons; cons = gfc_constructor_next (cons))
8066 if (cons->expr->expr_type == EXPR_CONSTANT
8067 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8068 gfc_error ("Imageset argument at %L must between 1 and "
8069 "num_images()", &cons->expr->where);
8075 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8076 || code->expr2->expr_type != EXPR_VARIABLE))
8077 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8078 &code->expr2->where);
8082 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8083 || code->expr3->expr_type != EXPR_VARIABLE))
8084 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8085 &code->expr3->where);
8089 /* Given a branch to a label, see if the branch is conforming.
8090 The code node describes where the branch is located. */
8093 resolve_branch (gfc_st_label *label, gfc_code *code)
8100 /* Step one: is this a valid branching target? */
8102 if (label->defined == ST_LABEL_UNKNOWN)
8104 gfc_error ("Label %d referenced at %L is never defined", label->value,
8109 if (label->defined != ST_LABEL_TARGET)
8111 gfc_error ("Statement at %L is not a valid branch target statement "
8112 "for the branch statement at %L", &label->where, &code->loc);
8116 /* Step two: make sure this branch is not a branch to itself ;-) */
8118 if (code->here == label)
8120 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8124 /* Step three: See if the label is in the same block as the
8125 branching statement. The hard work has been done by setting up
8126 the bitmap reachable_labels. */
8128 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8130 /* Check now whether there is a CRITICAL construct; if so, check
8131 whether the label is still visible outside of the CRITICAL block,
8132 which is invalid. */
8133 for (stack = cs_base; stack; stack = stack->prev)
8134 if (stack->current->op == EXEC_CRITICAL
8135 && bitmap_bit_p (stack->reachable_labels, label->value))
8136 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8137 " at %L", &code->loc, &label->where);
8142 /* Step four: If we haven't found the label in the bitmap, it may
8143 still be the label of the END of the enclosing block, in which
8144 case we find it by going up the code_stack. */
8146 for (stack = cs_base; stack; stack = stack->prev)
8148 if (stack->current->next && stack->current->next->here == label)
8150 if (stack->current->op == EXEC_CRITICAL)
8152 /* Note: A label at END CRITICAL does not leave the CRITICAL
8153 construct as END CRITICAL is still part of it. */
8154 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8155 " at %L", &code->loc, &label->where);
8162 gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
8166 /* The label is not in an enclosing block, so illegal. This was
8167 allowed in Fortran 66, so we allow it as extension. No
8168 further checks are necessary in this case. */
8169 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
8170 "as the GOTO statement at %L", &label->where,
8176 /* Check whether EXPR1 has the same shape as EXPR2. */
8179 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
8181 mpz_t shape[GFC_MAX_DIMENSIONS];
8182 mpz_t shape2[GFC_MAX_DIMENSIONS];
8183 gfc_try result = FAILURE;
8186 /* Compare the rank. */
8187 if (expr1->rank != expr2->rank)
8190 /* Compare the size of each dimension. */
8191 for (i=0; i<expr1->rank; i++)
8193 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
8196 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
8199 if (mpz_cmp (shape[i], shape2[i]))
8203 /* When either of the two expression is an assumed size array, we
8204 ignore the comparison of dimension sizes. */
8209 for (i--; i >= 0; i--)
8211 mpz_clear (shape[i]);
8212 mpz_clear (shape2[i]);
8218 /* Check whether a WHERE assignment target or a WHERE mask expression
8219 has the same shape as the outmost WHERE mask expression. */
8222 resolve_where (gfc_code *code, gfc_expr *mask)
8228 cblock = code->block;
8230 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8231 In case of nested WHERE, only the outmost one is stored. */
8232 if (mask == NULL) /* outmost WHERE */
8234 else /* inner WHERE */
8241 /* Check if the mask-expr has a consistent shape with the
8242 outmost WHERE mask-expr. */
8243 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8244 gfc_error ("WHERE mask at %L has inconsistent shape",
8245 &cblock->expr1->where);
8248 /* the assignment statement of a WHERE statement, or the first
8249 statement in where-body-construct of a WHERE construct */
8250 cnext = cblock->next;
8255 /* WHERE assignment statement */
8258 /* Check shape consistent for WHERE assignment target. */
8259 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8260 gfc_error ("WHERE assignment target at %L has "
8261 "inconsistent shape", &cnext->expr1->where);
8265 case EXEC_ASSIGN_CALL:
8266 resolve_call (cnext);
8267 if (!cnext->resolved_sym->attr.elemental)
8268 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8269 &cnext->ext.actual->expr->where);
8272 /* WHERE or WHERE construct is part of a where-body-construct */
8274 resolve_where (cnext, e);
8278 gfc_error ("Unsupported statement inside WHERE at %L",
8281 /* the next statement within the same where-body-construct */
8282 cnext = cnext->next;
8284 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8285 cblock = cblock->block;
8290 /* Resolve assignment in FORALL construct.
8291 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8292 FORALL index variables. */
8295 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8299 for (n = 0; n < nvar; n++)
8301 gfc_symbol *forall_index;
8303 forall_index = var_expr[n]->symtree->n.sym;
8305 /* Check whether the assignment target is one of the FORALL index
8307 if ((code->expr1->expr_type == EXPR_VARIABLE)
8308 && (code->expr1->symtree->n.sym == forall_index))
8309 gfc_error ("Assignment to a FORALL index variable at %L",
8310 &code->expr1->where);
8313 /* If one of the FORALL index variables doesn't appear in the
8314 assignment variable, then there could be a many-to-one
8315 assignment. Emit a warning rather than an error because the
8316 mask could be resolving this problem. */
8317 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8318 gfc_warning ("The FORALL with index '%s' is not used on the "
8319 "left side of the assignment at %L and so might "
8320 "cause multiple assignment to this object",
8321 var_expr[n]->symtree->name, &code->expr1->where);
8327 /* Resolve WHERE statement in FORALL construct. */
8330 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8331 gfc_expr **var_expr)
8336 cblock = code->block;
8339 /* the assignment statement of a WHERE statement, or the first
8340 statement in where-body-construct of a WHERE construct */
8341 cnext = cblock->next;
8346 /* WHERE assignment statement */
8348 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8351 /* WHERE operator assignment statement */
8352 case EXEC_ASSIGN_CALL:
8353 resolve_call (cnext);
8354 if (!cnext->resolved_sym->attr.elemental)
8355 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8356 &cnext->ext.actual->expr->where);
8359 /* WHERE or WHERE construct is part of a where-body-construct */
8361 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8365 gfc_error ("Unsupported statement inside WHERE at %L",
8368 /* the next statement within the same where-body-construct */
8369 cnext = cnext->next;
8371 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8372 cblock = cblock->block;
8377 /* Traverse the FORALL body to check whether the following errors exist:
8378 1. For assignment, check if a many-to-one assignment happens.
8379 2. For WHERE statement, check the WHERE body to see if there is any
8380 many-to-one assignment. */
8383 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8387 c = code->block->next;
8393 case EXEC_POINTER_ASSIGN:
8394 gfc_resolve_assign_in_forall (c, nvar, var_expr);
8397 case EXEC_ASSIGN_CALL:
8401 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8402 there is no need to handle it here. */
8406 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8411 /* The next statement in the FORALL body. */
8417 /* Counts the number of iterators needed inside a forall construct, including
8418 nested forall constructs. This is used to allocate the needed memory
8419 in gfc_resolve_forall. */
8422 gfc_count_forall_iterators (gfc_code *code)
8424 int max_iters, sub_iters, current_iters;
8425 gfc_forall_iterator *fa;
8427 gcc_assert(code->op == EXEC_FORALL);
8431 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8434 code = code->block->next;
8438 if (code->op == EXEC_FORALL)
8440 sub_iters = gfc_count_forall_iterators (code);
8441 if (sub_iters > max_iters)
8442 max_iters = sub_iters;
8447 return current_iters + max_iters;
8451 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8452 gfc_resolve_forall_body to resolve the FORALL body. */
8455 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8457 static gfc_expr **var_expr;
8458 static int total_var = 0;
8459 static int nvar = 0;
8461 gfc_forall_iterator *fa;
8466 /* Start to resolve a FORALL construct */
8467 if (forall_save == 0)
8469 /* Count the total number of FORALL index in the nested FORALL
8470 construct in order to allocate the VAR_EXPR with proper size. */
8471 total_var = gfc_count_forall_iterators (code);
8473 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8474 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
8477 /* The information about FORALL iterator, including FORALL index start, end
8478 and stride. The FORALL index can not appear in start, end or stride. */
8479 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8481 /* Check if any outer FORALL index name is the same as the current
8483 for (i = 0; i < nvar; i++)
8485 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8487 gfc_error ("An outer FORALL construct already has an index "
8488 "with this name %L", &fa->var->where);
8492 /* Record the current FORALL index. */
8493 var_expr[nvar] = gfc_copy_expr (fa->var);
8497 /* No memory leak. */
8498 gcc_assert (nvar <= total_var);
8501 /* Resolve the FORALL body. */
8502 gfc_resolve_forall_body (code, nvar, var_expr);
8504 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8505 gfc_resolve_blocks (code->block, ns);
8509 /* Free only the VAR_EXPRs allocated in this frame. */
8510 for (i = nvar; i < tmp; i++)
8511 gfc_free_expr (var_expr[i]);
8515 /* We are in the outermost FORALL construct. */
8516 gcc_assert (forall_save == 0);
8518 /* VAR_EXPR is not needed any more. */
8519 gfc_free (var_expr);
8525 /* Resolve a BLOCK construct statement. */
8528 resolve_block_construct (gfc_code* code)
8530 /* Resolve the BLOCK's namespace. */
8531 gfc_resolve (code->ext.block.ns);
8533 /* For an ASSOCIATE block, the associations (and their targets) are already
8534 resolved during resolve_symbol. */
8538 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8541 static void resolve_code (gfc_code *, gfc_namespace *);
8544 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8548 for (; b; b = b->block)
8550 t = gfc_resolve_expr (b->expr1);
8551 if (gfc_resolve_expr (b->expr2) == FAILURE)
8557 if (t == SUCCESS && b->expr1 != NULL
8558 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
8559 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8566 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
8567 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8572 resolve_branch (b->label1, b);
8576 resolve_block_construct (b);
8580 case EXEC_SELECT_TYPE:
8591 case EXEC_OMP_ATOMIC:
8592 case EXEC_OMP_CRITICAL:
8594 case EXEC_OMP_MASTER:
8595 case EXEC_OMP_ORDERED:
8596 case EXEC_OMP_PARALLEL:
8597 case EXEC_OMP_PARALLEL_DO:
8598 case EXEC_OMP_PARALLEL_SECTIONS:
8599 case EXEC_OMP_PARALLEL_WORKSHARE:
8600 case EXEC_OMP_SECTIONS:
8601 case EXEC_OMP_SINGLE:
8603 case EXEC_OMP_TASKWAIT:
8604 case EXEC_OMP_WORKSHARE:
8608 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
8611 resolve_code (b->next, ns);
8616 /* Does everything to resolve an ordinary assignment. Returns true
8617 if this is an interface assignment. */
8619 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
8629 if (gfc_extend_assign (code, ns) == SUCCESS)
8633 if (code->op == EXEC_ASSIGN_CALL)
8635 lhs = code->ext.actual->expr;
8636 rhsptr = &code->ext.actual->next->expr;
8640 gfc_actual_arglist* args;
8641 gfc_typebound_proc* tbp;
8643 gcc_assert (code->op == EXEC_COMPCALL);
8645 args = code->expr1->value.compcall.actual;
8647 rhsptr = &args->next->expr;
8649 tbp = code->expr1->value.compcall.tbp;
8650 gcc_assert (!tbp->is_generic);
8653 /* Make a temporary rhs when there is a default initializer
8654 and rhs is the same symbol as the lhs. */
8655 if ((*rhsptr)->expr_type == EXPR_VARIABLE
8656 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
8657 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
8658 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
8659 *rhsptr = gfc_get_parentheses (*rhsptr);
8668 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
8669 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
8670 &code->loc) == FAILURE)
8673 /* Handle the case of a BOZ literal on the RHS. */
8674 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
8677 if (gfc_option.warn_surprising)
8678 gfc_warning ("BOZ literal at %L is bitwise transferred "
8679 "non-integer symbol '%s'", &code->loc,
8680 lhs->symtree->n.sym->name);
8682 if (!gfc_convert_boz (rhs, &lhs->ts))
8684 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
8686 if (rc == ARITH_UNDERFLOW)
8687 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
8688 ". This check can be disabled with the option "
8689 "-fno-range-check", &rhs->where);
8690 else if (rc == ARITH_OVERFLOW)
8691 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
8692 ". This check can be disabled with the option "
8693 "-fno-range-check", &rhs->where);
8694 else if (rc == ARITH_NAN)
8695 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
8696 ". This check can be disabled with the option "
8697 "-fno-range-check", &rhs->where);
8702 if (lhs->ts.type == BT_CHARACTER
8703 && gfc_option.warn_character_truncation)
8705 if (lhs->ts.u.cl != NULL
8706 && lhs->ts.u.cl->length != NULL
8707 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8708 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
8710 if (rhs->expr_type == EXPR_CONSTANT)
8711 rlen = rhs->value.character.length;
8713 else if (rhs->ts.u.cl != NULL
8714 && rhs->ts.u.cl->length != NULL
8715 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8716 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
8718 if (rlen && llen && rlen > llen)
8719 gfc_warning_now ("CHARACTER expression will be truncated "
8720 "in assignment (%d/%d) at %L",
8721 llen, rlen, &code->loc);
8724 /* Ensure that a vector index expression for the lvalue is evaluated
8725 to a temporary if the lvalue symbol is referenced in it. */
8728 for (ref = lhs->ref; ref; ref= ref->next)
8729 if (ref->type == REF_ARRAY)
8731 for (n = 0; n < ref->u.ar.dimen; n++)
8732 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
8733 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
8734 ref->u.ar.start[n]))
8736 = gfc_get_parentheses (ref->u.ar.start[n]);
8740 if (gfc_pure (NULL))
8742 if (lhs->ts.type == BT_DERIVED
8743 && lhs->expr_type == EXPR_VARIABLE
8744 && lhs->ts.u.derived->attr.pointer_comp
8745 && rhs->expr_type == EXPR_VARIABLE
8746 && (gfc_impure_variable (rhs->symtree->n.sym)
8747 || gfc_is_coindexed (rhs)))
8750 if (gfc_is_coindexed (rhs))
8751 gfc_error ("Coindexed expression at %L is assigned to "
8752 "a derived type variable with a POINTER "
8753 "component in a PURE procedure",
8756 gfc_error ("The impure variable at %L is assigned to "
8757 "a derived type variable with a POINTER "
8758 "component in a PURE procedure (12.6)",
8763 /* Fortran 2008, C1283. */
8764 if (gfc_is_coindexed (lhs))
8766 gfc_error ("Assignment to coindexed variable at %L in a PURE "
8767 "procedure", &rhs->where);
8773 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
8774 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
8775 if (lhs->ts.type == BT_CLASS)
8777 gfc_error ("Variable must not be polymorphic in assignment at %L",
8782 /* F2008, Section 7.2.1.2. */
8783 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
8785 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
8786 "component in assignment at %L", &lhs->where);
8790 gfc_check_assign (lhs, rhs, 1);
8795 /* Given a block of code, recursively resolve everything pointed to by this
8799 resolve_code (gfc_code *code, gfc_namespace *ns)
8801 int omp_workshare_save;
8806 frame.prev = cs_base;
8810 find_reachable_labels (code);
8812 for (; code; code = code->next)
8814 frame.current = code;
8815 forall_save = forall_flag;
8817 if (code->op == EXEC_FORALL)
8820 gfc_resolve_forall (code, ns, forall_save);
8823 else if (code->block)
8825 omp_workshare_save = -1;
8828 case EXEC_OMP_PARALLEL_WORKSHARE:
8829 omp_workshare_save = omp_workshare_flag;
8830 omp_workshare_flag = 1;
8831 gfc_resolve_omp_parallel_blocks (code, ns);
8833 case EXEC_OMP_PARALLEL:
8834 case EXEC_OMP_PARALLEL_DO:
8835 case EXEC_OMP_PARALLEL_SECTIONS:
8837 omp_workshare_save = omp_workshare_flag;
8838 omp_workshare_flag = 0;
8839 gfc_resolve_omp_parallel_blocks (code, ns);
8842 gfc_resolve_omp_do_blocks (code, ns);
8844 case EXEC_SELECT_TYPE:
8845 /* Blocks are handled in resolve_select_type because we have
8846 to transform the SELECT TYPE into ASSOCIATE first. */
8848 case EXEC_OMP_WORKSHARE:
8849 omp_workshare_save = omp_workshare_flag;
8850 omp_workshare_flag = 1;
8853 gfc_resolve_blocks (code->block, ns);
8857 if (omp_workshare_save != -1)
8858 omp_workshare_flag = omp_workshare_save;
8862 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
8863 t = gfc_resolve_expr (code->expr1);
8864 forall_flag = forall_save;
8866 if (gfc_resolve_expr (code->expr2) == FAILURE)
8869 if (code->op == EXEC_ALLOCATE
8870 && gfc_resolve_expr (code->expr3) == FAILURE)
8876 case EXEC_END_BLOCK:
8880 case EXEC_ERROR_STOP:
8884 case EXEC_ASSIGN_CALL:
8889 case EXEC_SYNC_IMAGES:
8890 case EXEC_SYNC_MEMORY:
8891 resolve_sync (code);
8895 /* Keep track of which entry we are up to. */
8896 current_entry_id = code->ext.entry->id;
8900 resolve_where (code, NULL);
8904 if (code->expr1 != NULL)
8906 if (code->expr1->ts.type != BT_INTEGER)
8907 gfc_error ("ASSIGNED GOTO statement at %L requires an "
8908 "INTEGER variable", &code->expr1->where);
8909 else if (code->expr1->symtree->n.sym->attr.assign != 1)
8910 gfc_error ("Variable '%s' has not been assigned a target "
8911 "label at %L", code->expr1->symtree->n.sym->name,
8912 &code->expr1->where);
8915 resolve_branch (code->label1, code);
8919 if (code->expr1 != NULL
8920 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
8921 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
8922 "INTEGER return specifier", &code->expr1->where);
8925 case EXEC_INIT_ASSIGN:
8926 case EXEC_END_PROCEDURE:
8933 if (gfc_check_vardef_context (code->expr1, false, _("assignment"))
8937 if (resolve_ordinary_assign (code, ns))
8939 if (code->op == EXEC_COMPCALL)
8946 case EXEC_LABEL_ASSIGN:
8947 if (code->label1->defined == ST_LABEL_UNKNOWN)
8948 gfc_error ("Label %d referenced at %L is never defined",
8949 code->label1->value, &code->label1->where);
8951 && (code->expr1->expr_type != EXPR_VARIABLE
8952 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
8953 || code->expr1->symtree->n.sym->ts.kind
8954 != gfc_default_integer_kind
8955 || code->expr1->symtree->n.sym->as != NULL))
8956 gfc_error ("ASSIGN statement at %L requires a scalar "
8957 "default INTEGER variable", &code->expr1->where);
8960 case EXEC_POINTER_ASSIGN:
8967 /* This is both a variable definition and pointer assignment
8968 context, so check both of them. For rank remapping, a final
8969 array ref may be present on the LHS and fool gfc_expr_attr
8970 used in gfc_check_vardef_context. Remove it. */
8971 e = remove_last_array_ref (code->expr1);
8972 t = gfc_check_vardef_context (e, true, _("pointer assignment"));
8974 t = gfc_check_vardef_context (e, false, _("pointer assignment"));
8979 gfc_check_pointer_assign (code->expr1, code->expr2);
8983 case EXEC_ARITHMETIC_IF:
8985 && code->expr1->ts.type != BT_INTEGER
8986 && code->expr1->ts.type != BT_REAL)
8987 gfc_error ("Arithmetic IF statement at %L requires a numeric "
8988 "expression", &code->expr1->where);
8990 resolve_branch (code->label1, code);
8991 resolve_branch (code->label2, code);
8992 resolve_branch (code->label3, code);
8996 if (t == SUCCESS && code->expr1 != NULL
8997 && (code->expr1->ts.type != BT_LOGICAL
8998 || code->expr1->rank != 0))
8999 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9000 &code->expr1->where);
9005 resolve_call (code);
9010 resolve_typebound_subroutine (code);
9014 resolve_ppc_call (code);
9018 /* Select is complicated. Also, a SELECT construct could be
9019 a transformed computed GOTO. */
9020 resolve_select (code);
9023 case EXEC_SELECT_TYPE:
9024 resolve_select_type (code, ns);
9028 resolve_block_construct (code);
9032 if (code->ext.iterator != NULL)
9034 gfc_iterator *iter = code->ext.iterator;
9035 if (gfc_resolve_iterator (iter, true) != FAILURE)
9036 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
9041 if (code->expr1 == NULL)
9042 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9044 && (code->expr1->rank != 0
9045 || code->expr1->ts.type != BT_LOGICAL))
9046 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9047 "a scalar LOGICAL expression", &code->expr1->where);
9052 resolve_allocate_deallocate (code, "ALLOCATE");
9056 case EXEC_DEALLOCATE:
9058 resolve_allocate_deallocate (code, "DEALLOCATE");
9063 if (gfc_resolve_open (code->ext.open) == FAILURE)
9066 resolve_branch (code->ext.open->err, code);
9070 if (gfc_resolve_close (code->ext.close) == FAILURE)
9073 resolve_branch (code->ext.close->err, code);
9076 case EXEC_BACKSPACE:
9080 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
9083 resolve_branch (code->ext.filepos->err, code);
9087 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9090 resolve_branch (code->ext.inquire->err, code);
9094 gcc_assert (code->ext.inquire != NULL);
9095 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9098 resolve_branch (code->ext.inquire->err, code);
9102 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
9105 resolve_branch (code->ext.wait->err, code);
9106 resolve_branch (code->ext.wait->end, code);
9107 resolve_branch (code->ext.wait->eor, code);
9112 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
9115 resolve_branch (code->ext.dt->err, code);
9116 resolve_branch (code->ext.dt->end, code);
9117 resolve_branch (code->ext.dt->eor, code);
9121 resolve_transfer (code);
9125 resolve_forall_iterators (code->ext.forall_iterator);
9127 if (code->expr1 != NULL
9128 && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
9129 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9130 "expression", &code->expr1->where);
9133 case EXEC_OMP_ATOMIC:
9134 case EXEC_OMP_BARRIER:
9135 case EXEC_OMP_CRITICAL:
9136 case EXEC_OMP_FLUSH:
9138 case EXEC_OMP_MASTER:
9139 case EXEC_OMP_ORDERED:
9140 case EXEC_OMP_SECTIONS:
9141 case EXEC_OMP_SINGLE:
9142 case EXEC_OMP_TASKWAIT:
9143 case EXEC_OMP_WORKSHARE:
9144 gfc_resolve_omp_directive (code, ns);
9147 case EXEC_OMP_PARALLEL:
9148 case EXEC_OMP_PARALLEL_DO:
9149 case EXEC_OMP_PARALLEL_SECTIONS:
9150 case EXEC_OMP_PARALLEL_WORKSHARE:
9152 omp_workshare_save = omp_workshare_flag;
9153 omp_workshare_flag = 0;
9154 gfc_resolve_omp_directive (code, ns);
9155 omp_workshare_flag = omp_workshare_save;
9159 gfc_internal_error ("resolve_code(): Bad statement code");
9163 cs_base = frame.prev;
9167 /* Resolve initial values and make sure they are compatible with
9171 resolve_values (gfc_symbol *sym)
9175 if (sym->value == NULL)
9178 if (sym->value->expr_type == EXPR_STRUCTURE)
9179 t= resolve_structure_cons (sym->value, 1);
9181 t = gfc_resolve_expr (sym->value);
9186 gfc_check_assign_symbol (sym, sym->value);
9190 /* Verify the binding labels for common blocks that are BIND(C). The label
9191 for a BIND(C) common block must be identical in all scoping units in which
9192 the common block is declared. Further, the binding label can not collide
9193 with any other global entity in the program. */
9196 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
9198 if (comm_block_tree->n.common->is_bind_c == 1)
9200 gfc_gsymbol *binding_label_gsym;
9201 gfc_gsymbol *comm_name_gsym;
9203 /* See if a global symbol exists by the common block's name. It may
9204 be NULL if the common block is use-associated. */
9205 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
9206 comm_block_tree->n.common->name);
9207 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
9208 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9209 "with the global entity '%s' at %L",
9210 comm_block_tree->n.common->binding_label,
9211 comm_block_tree->n.common->name,
9212 &(comm_block_tree->n.common->where),
9213 comm_name_gsym->name, &(comm_name_gsym->where));
9214 else if (comm_name_gsym != NULL
9215 && strcmp (comm_name_gsym->name,
9216 comm_block_tree->n.common->name) == 0)
9218 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9220 if (comm_name_gsym->binding_label == NULL)
9221 /* No binding label for common block stored yet; save this one. */
9222 comm_name_gsym->binding_label =
9223 comm_block_tree->n.common->binding_label;
9225 if (strcmp (comm_name_gsym->binding_label,
9226 comm_block_tree->n.common->binding_label) != 0)
9228 /* Common block names match but binding labels do not. */
9229 gfc_error ("Binding label '%s' for common block '%s' at %L "
9230 "does not match the binding label '%s' for common "
9232 comm_block_tree->n.common->binding_label,
9233 comm_block_tree->n.common->name,
9234 &(comm_block_tree->n.common->where),
9235 comm_name_gsym->binding_label,
9236 comm_name_gsym->name,
9237 &(comm_name_gsym->where));
9242 /* There is no binding label (NAME="") so we have nothing further to
9243 check and nothing to add as a global symbol for the label. */
9244 if (comm_block_tree->n.common->binding_label[0] == '\0' )
9247 binding_label_gsym =
9248 gfc_find_gsymbol (gfc_gsym_root,
9249 comm_block_tree->n.common->binding_label);
9250 if (binding_label_gsym == NULL)
9252 /* Need to make a global symbol for the binding label to prevent
9253 it from colliding with another. */
9254 binding_label_gsym =
9255 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9256 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9257 binding_label_gsym->type = GSYM_COMMON;
9261 /* If comm_name_gsym is NULL, the name common block is use
9262 associated and the name could be colliding. */
9263 if (binding_label_gsym->type != GSYM_COMMON)
9264 gfc_error ("Binding label '%s' for common block '%s' at %L "
9265 "collides with the global entity '%s' at %L",
9266 comm_block_tree->n.common->binding_label,
9267 comm_block_tree->n.common->name,
9268 &(comm_block_tree->n.common->where),
9269 binding_label_gsym->name,
9270 &(binding_label_gsym->where));
9271 else if (comm_name_gsym != NULL
9272 && (strcmp (binding_label_gsym->name,
9273 comm_name_gsym->binding_label) != 0)
9274 && (strcmp (binding_label_gsym->sym_name,
9275 comm_name_gsym->name) != 0))
9276 gfc_error ("Binding label '%s' for common block '%s' at %L "
9277 "collides with global entity '%s' at %L",
9278 binding_label_gsym->name, binding_label_gsym->sym_name,
9279 &(comm_block_tree->n.common->where),
9280 comm_name_gsym->name, &(comm_name_gsym->where));
9288 /* Verify any BIND(C) derived types in the namespace so we can report errors
9289 for them once, rather than for each variable declared of that type. */
9292 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9294 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9295 && derived_sym->attr.is_bind_c == 1)
9296 verify_bind_c_derived_type (derived_sym);
9302 /* Verify that any binding labels used in a given namespace do not collide
9303 with the names or binding labels of any global symbols. */
9306 gfc_verify_binding_labels (gfc_symbol *sym)
9310 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9311 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
9313 gfc_gsymbol *bind_c_sym;
9315 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9316 if (bind_c_sym != NULL
9317 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9319 if (sym->attr.if_source == IFSRC_DECL
9320 && (bind_c_sym->type != GSYM_SUBROUTINE
9321 && bind_c_sym->type != GSYM_FUNCTION)
9322 && ((sym->attr.contained == 1
9323 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9324 || (sym->attr.use_assoc == 1
9325 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9327 /* Make sure global procedures don't collide with anything. */
9328 gfc_error ("Binding label '%s' at %L collides with the global "
9329 "entity '%s' at %L", sym->binding_label,
9330 &(sym->declared_at), bind_c_sym->name,
9331 &(bind_c_sym->where));
9334 else if (sym->attr.contained == 0
9335 && (sym->attr.if_source == IFSRC_IFBODY
9336 && sym->attr.flavor == FL_PROCEDURE)
9337 && (bind_c_sym->sym_name != NULL
9338 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9340 /* Make sure procedures in interface bodies don't collide. */
9341 gfc_error ("Binding label '%s' in interface body at %L collides "
9342 "with the global entity '%s' at %L",
9344 &(sym->declared_at), bind_c_sym->name,
9345 &(bind_c_sym->where));
9348 else if (sym->attr.contained == 0
9349 && sym->attr.if_source == IFSRC_UNKNOWN)
9350 if ((sym->attr.use_assoc && bind_c_sym->mod_name
9351 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9352 || sym->attr.use_assoc == 0)
9354 gfc_error ("Binding label '%s' at %L collides with global "
9355 "entity '%s' at %L", sym->binding_label,
9356 &(sym->declared_at), bind_c_sym->name,
9357 &(bind_c_sym->where));
9362 /* Clear the binding label to prevent checking multiple times. */
9363 sym->binding_label[0] = '\0';
9365 else if (bind_c_sym == NULL)
9367 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9368 bind_c_sym->where = sym->declared_at;
9369 bind_c_sym->sym_name = sym->name;
9371 if (sym->attr.use_assoc == 1)
9372 bind_c_sym->mod_name = sym->module;
9374 if (sym->ns->proc_name != NULL)
9375 bind_c_sym->mod_name = sym->ns->proc_name->name;
9377 if (sym->attr.contained == 0)
9379 if (sym->attr.subroutine)
9380 bind_c_sym->type = GSYM_SUBROUTINE;
9381 else if (sym->attr.function)
9382 bind_c_sym->type = GSYM_FUNCTION;
9390 /* Resolve an index expression. */
9393 resolve_index_expr (gfc_expr *e)
9395 if (gfc_resolve_expr (e) == FAILURE)
9398 if (gfc_simplify_expr (e, 0) == FAILURE)
9401 if (gfc_specification_expr (e) == FAILURE)
9408 /* Resolve a charlen structure. */
9411 resolve_charlen (gfc_charlen *cl)
9420 specification_expr = 1;
9422 if (resolve_index_expr (cl->length) == FAILURE)
9424 specification_expr = 0;
9428 /* "If the character length parameter value evaluates to a negative
9429 value, the length of character entities declared is zero." */
9430 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9432 if (gfc_option.warn_surprising)
9433 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9434 " the length has been set to zero",
9435 &cl->length->where, i);
9436 gfc_replace_expr (cl->length,
9437 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9440 /* Check that the character length is not too large. */
9441 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9442 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9443 && cl->length->ts.type == BT_INTEGER
9444 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9446 gfc_error ("String length at %L is too large", &cl->length->where);
9454 /* Test for non-constant shape arrays. */
9457 is_non_constant_shape_array (gfc_symbol *sym)
9463 not_constant = false;
9464 if (sym->as != NULL)
9466 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9467 has not been simplified; parameter array references. Do the
9468 simplification now. */
9469 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9471 e = sym->as->lower[i];
9472 if (e && (resolve_index_expr (e) == FAILURE
9473 || !gfc_is_constant_expr (e)))
9474 not_constant = true;
9475 e = sym->as->upper[i];
9476 if (e && (resolve_index_expr (e) == FAILURE
9477 || !gfc_is_constant_expr (e)))
9478 not_constant = true;
9481 return not_constant;
9484 /* Given a symbol and an initialization expression, add code to initialize
9485 the symbol to the function entry. */
9487 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9491 gfc_namespace *ns = sym->ns;
9493 /* Search for the function namespace if this is a contained
9494 function without an explicit result. */
9495 if (sym->attr.function && sym == sym->result
9496 && sym->name != sym->ns->proc_name->name)
9499 for (;ns; ns = ns->sibling)
9500 if (strcmp (ns->proc_name->name, sym->name) == 0)
9506 gfc_free_expr (init);
9510 /* Build an l-value expression for the result. */
9511 lval = gfc_lval_expr_from_sym (sym);
9513 /* Add the code at scope entry. */
9514 init_st = gfc_get_code ();
9515 init_st->next = ns->code;
9518 /* Assign the default initializer to the l-value. */
9519 init_st->loc = sym->declared_at;
9520 init_st->op = EXEC_INIT_ASSIGN;
9521 init_st->expr1 = lval;
9522 init_st->expr2 = init;
9525 /* Assign the default initializer to a derived type variable or result. */
9528 apply_default_init (gfc_symbol *sym)
9530 gfc_expr *init = NULL;
9532 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9535 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
9536 init = gfc_default_initializer (&sym->ts);
9538 if (init == NULL && sym->ts.type != BT_CLASS)
9541 build_init_assign (sym, init);
9542 sym->attr.referenced = 1;
9545 /* Build an initializer for a local integer, real, complex, logical, or
9546 character variable, based on the command line flags finit-local-zero,
9547 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
9548 null if the symbol should not have a default initialization. */
9550 build_default_init_expr (gfc_symbol *sym)
9553 gfc_expr *init_expr;
9556 /* These symbols should never have a default initialization. */
9557 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
9558 || sym->attr.external
9560 || sym->attr.pointer
9561 || sym->attr.in_equivalence
9562 || sym->attr.in_common
9565 || sym->attr.cray_pointee
9566 || sym->attr.cray_pointer)
9569 /* Now we'll try to build an initializer expression. */
9570 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
9573 /* We will only initialize integers, reals, complex, logicals, and
9574 characters, and only if the corresponding command-line flags
9575 were set. Otherwise, we free init_expr and return null. */
9576 switch (sym->ts.type)
9579 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
9580 mpz_set_si (init_expr->value.integer,
9581 gfc_option.flag_init_integer_value);
9584 gfc_free_expr (init_expr);
9590 switch (gfc_option.flag_init_real)
9592 case GFC_INIT_REAL_SNAN:
9593 init_expr->is_snan = 1;
9595 case GFC_INIT_REAL_NAN:
9596 mpfr_set_nan (init_expr->value.real);
9599 case GFC_INIT_REAL_INF:
9600 mpfr_set_inf (init_expr->value.real, 1);
9603 case GFC_INIT_REAL_NEG_INF:
9604 mpfr_set_inf (init_expr->value.real, -1);
9607 case GFC_INIT_REAL_ZERO:
9608 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
9612 gfc_free_expr (init_expr);
9619 switch (gfc_option.flag_init_real)
9621 case GFC_INIT_REAL_SNAN:
9622 init_expr->is_snan = 1;
9624 case GFC_INIT_REAL_NAN:
9625 mpfr_set_nan (mpc_realref (init_expr->value.complex));
9626 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
9629 case GFC_INIT_REAL_INF:
9630 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
9631 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
9634 case GFC_INIT_REAL_NEG_INF:
9635 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
9636 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
9639 case GFC_INIT_REAL_ZERO:
9640 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
9644 gfc_free_expr (init_expr);
9651 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
9652 init_expr->value.logical = 0;
9653 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
9654 init_expr->value.logical = 1;
9657 gfc_free_expr (init_expr);
9663 /* For characters, the length must be constant in order to
9664 create a default initializer. */
9665 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
9666 && sym->ts.u.cl->length
9667 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9669 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
9670 init_expr->value.character.length = char_len;
9671 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
9672 for (i = 0; i < char_len; i++)
9673 init_expr->value.character.string[i]
9674 = (unsigned char) gfc_option.flag_init_character_value;
9678 gfc_free_expr (init_expr);
9684 gfc_free_expr (init_expr);
9690 /* Add an initialization expression to a local variable. */
9692 apply_default_init_local (gfc_symbol *sym)
9694 gfc_expr *init = NULL;
9696 /* The symbol should be a variable or a function return value. */
9697 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9698 || (sym->attr.function && sym->result != sym))
9701 /* Try to build the initializer expression. If we can't initialize
9702 this symbol, then init will be NULL. */
9703 init = build_default_init_expr (sym);
9707 /* For saved variables, we don't want to add an initializer at
9708 function entry, so we just add a static initializer. */
9709 if (sym->attr.save || sym->ns->save_all
9710 || gfc_option.flag_max_stack_var_size == 0)
9712 /* Don't clobber an existing initializer! */
9713 gcc_assert (sym->value == NULL);
9718 build_init_assign (sym, init);
9722 /* Resolution of common features of flavors variable and procedure. */
9725 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
9727 /* Constraints on deferred shape variable. */
9728 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
9730 if (sym->attr.allocatable)
9732 if (sym->attr.dimension)
9734 gfc_error ("Allocatable array '%s' at %L must have "
9735 "a deferred shape", sym->name, &sym->declared_at);
9738 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
9739 "may not be ALLOCATABLE", sym->name,
9740 &sym->declared_at) == FAILURE)
9744 if (sym->attr.pointer && sym->attr.dimension)
9746 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
9747 sym->name, &sym->declared_at);
9753 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
9754 && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc)
9756 gfc_error ("Array '%s' at %L cannot have a deferred shape",
9757 sym->name, &sym->declared_at);
9762 /* Constraints on polymorphic variables. */
9763 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
9766 if (sym->attr.class_ok
9767 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
9769 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
9770 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
9776 /* Assume that use associated symbols were checked in the module ns.
9777 Class-variables that are associate-names are also something special
9778 and excepted from the test. */
9779 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
9781 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
9782 "or pointer", sym->name, &sym->declared_at);
9791 /* Additional checks for symbols with flavor variable and derived
9792 type. To be called from resolve_fl_variable. */
9795 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
9797 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
9799 /* Check to see if a derived type is blocked from being host
9800 associated by the presence of another class I symbol in the same
9801 namespace. 14.6.1.3 of the standard and the discussion on
9802 comp.lang.fortran. */
9803 if (sym->ns != sym->ts.u.derived->ns
9804 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
9807 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
9808 if (s && s->attr.flavor != FL_DERIVED)
9810 gfc_error ("The type '%s' cannot be host associated at %L "
9811 "because it is blocked by an incompatible object "
9812 "of the same name declared at %L",
9813 sym->ts.u.derived->name, &sym->declared_at,
9819 /* 4th constraint in section 11.3: "If an object of a type for which
9820 component-initialization is specified (R429) appears in the
9821 specification-part of a module and does not have the ALLOCATABLE
9822 or POINTER attribute, the object shall have the SAVE attribute."
9824 The check for initializers is performed with
9825 gfc_has_default_initializer because gfc_default_initializer generates
9826 a hidden default for allocatable components. */
9827 if (!(sym->value || no_init_flag) && sym->ns->proc_name
9828 && sym->ns->proc_name->attr.flavor == FL_MODULE
9829 && !sym->ns->save_all && !sym->attr.save
9830 && !sym->attr.pointer && !sym->attr.allocatable
9831 && gfc_has_default_initializer (sym->ts.u.derived)
9832 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
9833 "module variable '%s' at %L, needed due to "
9834 "the default initialization", sym->name,
9835 &sym->declared_at) == FAILURE)
9838 /* Assign default initializer. */
9839 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
9840 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
9842 sym->value = gfc_default_initializer (&sym->ts);
9849 /* Resolve symbols with flavor variable. */
9852 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
9854 int no_init_flag, automatic_flag;
9856 const char *auto_save_msg;
9858 auto_save_msg = "Automatic object '%s' at %L cannot have the "
9861 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9864 /* Set this flag to check that variables are parameters of all entries.
9865 This check is effected by the call to gfc_resolve_expr through
9866 is_non_constant_shape_array. */
9867 specification_expr = 1;
9869 if (sym->ns->proc_name
9870 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9871 || sym->ns->proc_name->attr.is_main_program)
9872 && !sym->attr.use_assoc
9873 && !sym->attr.allocatable
9874 && !sym->attr.pointer
9875 && is_non_constant_shape_array (sym))
9877 /* The shape of a main program or module array needs to be
9879 gfc_error ("The module or main program array '%s' at %L must "
9880 "have constant shape", sym->name, &sym->declared_at);
9881 specification_expr = 0;
9885 /* Constraints on deferred type parameter. */
9886 if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
9888 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
9889 "requires either the pointer or allocatable attribute",
9890 sym->name, &sym->declared_at);
9894 if (sym->ts.type == BT_CHARACTER)
9896 /* Make sure that character string variables with assumed length are
9898 e = sym->ts.u.cl->length;
9899 if (e == NULL && !sym->attr.dummy && !sym->attr.result
9900 && !sym->ts.deferred)
9902 gfc_error ("Entity with assumed character length at %L must be a "
9903 "dummy argument or a PARAMETER", &sym->declared_at);
9907 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
9909 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9913 if (!gfc_is_constant_expr (e)
9914 && !(e->expr_type == EXPR_VARIABLE
9915 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
9916 && sym->ns->proc_name
9917 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9918 || sym->ns->proc_name->attr.is_main_program)
9919 && !sym->attr.use_assoc)
9921 gfc_error ("'%s' at %L must have constant character length "
9922 "in this context", sym->name, &sym->declared_at);
9927 if (sym->value == NULL && sym->attr.referenced)
9928 apply_default_init_local (sym); /* Try to apply a default initialization. */
9930 /* Determine if the symbol may not have an initializer. */
9931 no_init_flag = automatic_flag = 0;
9932 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
9933 || sym->attr.intrinsic || sym->attr.result)
9935 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
9936 && is_non_constant_shape_array (sym))
9938 no_init_flag = automatic_flag = 1;
9940 /* Also, they must not have the SAVE attribute.
9941 SAVE_IMPLICIT is checked below. */
9942 if (sym->attr.save == SAVE_EXPLICIT)
9944 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9949 /* Ensure that any initializer is simplified. */
9951 gfc_simplify_expr (sym->value, 1);
9953 /* Reject illegal initializers. */
9954 if (!sym->mark && sym->value)
9956 if (sym->attr.allocatable)
9957 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
9958 sym->name, &sym->declared_at);
9959 else if (sym->attr.external)
9960 gfc_error ("External '%s' at %L cannot have an initializer",
9961 sym->name, &sym->declared_at);
9962 else if (sym->attr.dummy
9963 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
9964 gfc_error ("Dummy '%s' at %L cannot have an initializer",
9965 sym->name, &sym->declared_at);
9966 else if (sym->attr.intrinsic)
9967 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
9968 sym->name, &sym->declared_at);
9969 else if (sym->attr.result)
9970 gfc_error ("Function result '%s' at %L cannot have an initializer",
9971 sym->name, &sym->declared_at);
9972 else if (automatic_flag)
9973 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
9974 sym->name, &sym->declared_at);
9981 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
9982 return resolve_fl_variable_derived (sym, no_init_flag);
9988 /* Resolve a procedure. */
9991 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
9993 gfc_formal_arglist *arg;
9995 if (sym->attr.function
9996 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9999 if (sym->ts.type == BT_CHARACTER)
10001 gfc_charlen *cl = sym->ts.u.cl;
10003 if (cl && cl->length && gfc_is_constant_expr (cl->length)
10004 && resolve_charlen (cl) == FAILURE)
10007 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
10008 && sym->attr.proc == PROC_ST_FUNCTION)
10010 gfc_error ("Character-valued statement function '%s' at %L must "
10011 "have constant length", sym->name, &sym->declared_at);
10016 /* Ensure that derived type for are not of a private type. Internal
10017 module procedures are excluded by 2.2.3.3 - i.e., they are not
10018 externally accessible and can access all the objects accessible in
10020 if (!(sym->ns->parent
10021 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
10022 && gfc_check_access(sym->attr.access, sym->ns->default_access))
10024 gfc_interface *iface;
10026 for (arg = sym->formal; arg; arg = arg->next)
10029 && arg->sym->ts.type == BT_DERIVED
10030 && !arg->sym->ts.u.derived->attr.use_assoc
10031 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10032 arg->sym->ts.u.derived->ns->default_access)
10033 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
10034 "PRIVATE type and cannot be a dummy argument"
10035 " of '%s', which is PUBLIC at %L",
10036 arg->sym->name, sym->name, &sym->declared_at)
10039 /* Stop this message from recurring. */
10040 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10045 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10046 PRIVATE to the containing module. */
10047 for (iface = sym->generic; iface; iface = iface->next)
10049 for (arg = iface->sym->formal; arg; arg = arg->next)
10052 && arg->sym->ts.type == BT_DERIVED
10053 && !arg->sym->ts.u.derived->attr.use_assoc
10054 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10055 arg->sym->ts.u.derived->ns->default_access)
10056 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10057 "'%s' in PUBLIC interface '%s' at %L "
10058 "takes dummy arguments of '%s' which is "
10059 "PRIVATE", iface->sym->name, sym->name,
10060 &iface->sym->declared_at,
10061 gfc_typename (&arg->sym->ts)) == FAILURE)
10063 /* Stop this message from recurring. */
10064 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10070 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10071 PRIVATE to the containing module. */
10072 for (iface = sym->generic; iface; iface = iface->next)
10074 for (arg = iface->sym->formal; arg; arg = arg->next)
10077 && arg->sym->ts.type == BT_DERIVED
10078 && !arg->sym->ts.u.derived->attr.use_assoc
10079 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10080 arg->sym->ts.u.derived->ns->default_access)
10081 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10082 "'%s' in PUBLIC interface '%s' at %L "
10083 "takes dummy arguments of '%s' which is "
10084 "PRIVATE", iface->sym->name, sym->name,
10085 &iface->sym->declared_at,
10086 gfc_typename (&arg->sym->ts)) == FAILURE)
10088 /* Stop this message from recurring. */
10089 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10096 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10097 && !sym->attr.proc_pointer)
10099 gfc_error ("Function '%s' at %L cannot have an initializer",
10100 sym->name, &sym->declared_at);
10104 /* An external symbol may not have an initializer because it is taken to be
10105 a procedure. Exception: Procedure Pointers. */
10106 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10108 gfc_error ("External object '%s' at %L may not have an initializer",
10109 sym->name, &sym->declared_at);
10113 /* An elemental function is required to return a scalar 12.7.1 */
10114 if (sym->attr.elemental && sym->attr.function && sym->as)
10116 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10117 "result", sym->name, &sym->declared_at);
10118 /* Reset so that the error only occurs once. */
10119 sym->attr.elemental = 0;
10123 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10124 char-len-param shall not be array-valued, pointer-valued, recursive
10125 or pure. ....snip... A character value of * may only be used in the
10126 following ways: (i) Dummy arg of procedure - dummy associates with
10127 actual length; (ii) To declare a named constant; or (iii) External
10128 function - but length must be declared in calling scoping unit. */
10129 if (sym->attr.function
10130 && sym->ts.type == BT_CHARACTER
10131 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10133 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10134 || (sym->attr.recursive) || (sym->attr.pure))
10136 if (sym->as && sym->as->rank)
10137 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10138 "array-valued", sym->name, &sym->declared_at);
10140 if (sym->attr.pointer)
10141 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10142 "pointer-valued", sym->name, &sym->declared_at);
10144 if (sym->attr.pure)
10145 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10146 "pure", sym->name, &sym->declared_at);
10148 if (sym->attr.recursive)
10149 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10150 "recursive", sym->name, &sym->declared_at);
10155 /* Appendix B.2 of the standard. Contained functions give an
10156 error anyway. Fixed-form is likely to be F77/legacy. */
10157 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
10158 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10159 "CHARACTER(*) function '%s' at %L",
10160 sym->name, &sym->declared_at);
10163 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10165 gfc_formal_arglist *curr_arg;
10166 int has_non_interop_arg = 0;
10168 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10169 sym->common_block) == FAILURE)
10171 /* Clear these to prevent looking at them again if there was an
10173 sym->attr.is_bind_c = 0;
10174 sym->attr.is_c_interop = 0;
10175 sym->ts.is_c_interop = 0;
10179 /* So far, no errors have been found. */
10180 sym->attr.is_c_interop = 1;
10181 sym->ts.is_c_interop = 1;
10184 curr_arg = sym->formal;
10185 while (curr_arg != NULL)
10187 /* Skip implicitly typed dummy args here. */
10188 if (curr_arg->sym->attr.implicit_type == 0)
10189 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
10190 /* If something is found to fail, record the fact so we
10191 can mark the symbol for the procedure as not being
10192 BIND(C) to try and prevent multiple errors being
10194 has_non_interop_arg = 1;
10196 curr_arg = curr_arg->next;
10199 /* See if any of the arguments were not interoperable and if so, clear
10200 the procedure symbol to prevent duplicate error messages. */
10201 if (has_non_interop_arg != 0)
10203 sym->attr.is_c_interop = 0;
10204 sym->ts.is_c_interop = 0;
10205 sym->attr.is_bind_c = 0;
10209 if (!sym->attr.proc_pointer)
10211 if (sym->attr.save == SAVE_EXPLICIT)
10213 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10214 "in '%s' at %L", sym->name, &sym->declared_at);
10217 if (sym->attr.intent)
10219 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10220 "in '%s' at %L", sym->name, &sym->declared_at);
10223 if (sym->attr.subroutine && sym->attr.result)
10225 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10226 "in '%s' at %L", sym->name, &sym->declared_at);
10229 if (sym->attr.external && sym->attr.function
10230 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10231 || sym->attr.contained))
10233 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10234 "in '%s' at %L", sym->name, &sym->declared_at);
10237 if (strcmp ("ppr@", sym->name) == 0)
10239 gfc_error ("Procedure pointer result '%s' at %L "
10240 "is missing the pointer attribute",
10241 sym->ns->proc_name->name, &sym->declared_at);
10250 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10251 been defined and we now know their defined arguments, check that they fulfill
10252 the requirements of the standard for procedures used as finalizers. */
10255 gfc_resolve_finalizers (gfc_symbol* derived)
10257 gfc_finalizer* list;
10258 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10259 gfc_try result = SUCCESS;
10260 bool seen_scalar = false;
10262 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10265 /* Walk over the list of finalizer-procedures, check them, and if any one
10266 does not fit in with the standard's definition, print an error and remove
10267 it from the list. */
10268 prev_link = &derived->f2k_derived->finalizers;
10269 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10275 /* Skip this finalizer if we already resolved it. */
10276 if (list->proc_tree)
10278 prev_link = &(list->next);
10282 /* Check this exists and is a SUBROUTINE. */
10283 if (!list->proc_sym->attr.subroutine)
10285 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10286 list->proc_sym->name, &list->where);
10290 /* We should have exactly one argument. */
10291 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10293 gfc_error ("FINAL procedure at %L must have exactly one argument",
10297 arg = list->proc_sym->formal->sym;
10299 /* This argument must be of our type. */
10300 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10302 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10303 &arg->declared_at, derived->name);
10307 /* It must neither be a pointer nor allocatable nor optional. */
10308 if (arg->attr.pointer)
10310 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10311 &arg->declared_at);
10314 if (arg->attr.allocatable)
10316 gfc_error ("Argument of FINAL procedure at %L must not be"
10317 " ALLOCATABLE", &arg->declared_at);
10320 if (arg->attr.optional)
10322 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10323 &arg->declared_at);
10327 /* It must not be INTENT(OUT). */
10328 if (arg->attr.intent == INTENT_OUT)
10330 gfc_error ("Argument of FINAL procedure at %L must not be"
10331 " INTENT(OUT)", &arg->declared_at);
10335 /* Warn if the procedure is non-scalar and not assumed shape. */
10336 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10337 && arg->as->type != AS_ASSUMED_SHAPE)
10338 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10339 " shape argument", &arg->declared_at);
10341 /* Check that it does not match in kind and rank with a FINAL procedure
10342 defined earlier. To really loop over the *earlier* declarations,
10343 we need to walk the tail of the list as new ones were pushed at the
10345 /* TODO: Handle kind parameters once they are implemented. */
10346 my_rank = (arg->as ? arg->as->rank : 0);
10347 for (i = list->next; i; i = i->next)
10349 /* Argument list might be empty; that is an error signalled earlier,
10350 but we nevertheless continued resolving. */
10351 if (i->proc_sym->formal)
10353 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10354 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10355 if (i_rank == my_rank)
10357 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10358 " rank (%d) as '%s'",
10359 list->proc_sym->name, &list->where, my_rank,
10360 i->proc_sym->name);
10366 /* Is this the/a scalar finalizer procedure? */
10367 if (!arg->as || arg->as->rank == 0)
10368 seen_scalar = true;
10370 /* Find the symtree for this procedure. */
10371 gcc_assert (!list->proc_tree);
10372 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10374 prev_link = &list->next;
10377 /* Remove wrong nodes immediately from the list so we don't risk any
10378 troubles in the future when they might fail later expectations. */
10382 *prev_link = list->next;
10383 gfc_free_finalizer (i);
10386 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10387 were nodes in the list, must have been for arrays. It is surely a good
10388 idea to have a scalar version there if there's something to finalize. */
10389 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10390 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10391 " defined at %L, suggest also scalar one",
10392 derived->name, &derived->declared_at);
10394 /* TODO: Remove this error when finalization is finished. */
10395 gfc_error ("Finalization at %L is not yet implemented",
10396 &derived->declared_at);
10402 /* Check that it is ok for the typebound procedure proc to override the
10406 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
10409 const gfc_symbol* proc_target;
10410 const gfc_symbol* old_target;
10411 unsigned proc_pass_arg, old_pass_arg, argpos;
10412 gfc_formal_arglist* proc_formal;
10413 gfc_formal_arglist* old_formal;
10415 /* This procedure should only be called for non-GENERIC proc. */
10416 gcc_assert (!proc->n.tb->is_generic);
10418 /* If the overwritten procedure is GENERIC, this is an error. */
10419 if (old->n.tb->is_generic)
10421 gfc_error ("Can't overwrite GENERIC '%s' at %L",
10422 old->name, &proc->n.tb->where);
10426 where = proc->n.tb->where;
10427 proc_target = proc->n.tb->u.specific->n.sym;
10428 old_target = old->n.tb->u.specific->n.sym;
10430 /* Check that overridden binding is not NON_OVERRIDABLE. */
10431 if (old->n.tb->non_overridable)
10433 gfc_error ("'%s' at %L overrides a procedure binding declared"
10434 " NON_OVERRIDABLE", proc->name, &where);
10438 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
10439 if (!old->n.tb->deferred && proc->n.tb->deferred)
10441 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
10442 " non-DEFERRED binding", proc->name, &where);
10446 /* If the overridden binding is PURE, the overriding must be, too. */
10447 if (old_target->attr.pure && !proc_target->attr.pure)
10449 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
10450 proc->name, &where);
10454 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
10455 is not, the overriding must not be either. */
10456 if (old_target->attr.elemental && !proc_target->attr.elemental)
10458 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
10459 " ELEMENTAL", proc->name, &where);
10462 if (!old_target->attr.elemental && proc_target->attr.elemental)
10464 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
10465 " be ELEMENTAL, either", proc->name, &where);
10469 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
10471 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
10473 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
10474 " SUBROUTINE", proc->name, &where);
10478 /* If the overridden binding is a FUNCTION, the overriding must also be a
10479 FUNCTION and have the same characteristics. */
10480 if (old_target->attr.function)
10482 if (!proc_target->attr.function)
10484 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
10485 " FUNCTION", proc->name, &where);
10489 /* FIXME: Do more comprehensive checking (including, for instance, the
10490 rank and array-shape). */
10491 gcc_assert (proc_target->result && old_target->result);
10492 if (!gfc_compare_types (&proc_target->result->ts,
10493 &old_target->result->ts))
10495 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
10496 " matching result types", proc->name, &where);
10501 /* If the overridden binding is PUBLIC, the overriding one must not be
10503 if (old->n.tb->access == ACCESS_PUBLIC
10504 && proc->n.tb->access == ACCESS_PRIVATE)
10506 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
10507 " PRIVATE", proc->name, &where);
10511 /* Compare the formal argument lists of both procedures. This is also abused
10512 to find the position of the passed-object dummy arguments of both
10513 bindings as at least the overridden one might not yet be resolved and we
10514 need those positions in the check below. */
10515 proc_pass_arg = old_pass_arg = 0;
10516 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
10518 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
10521 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
10522 proc_formal && old_formal;
10523 proc_formal = proc_formal->next, old_formal = old_formal->next)
10525 if (proc->n.tb->pass_arg
10526 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
10527 proc_pass_arg = argpos;
10528 if (old->n.tb->pass_arg
10529 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
10530 old_pass_arg = argpos;
10532 /* Check that the names correspond. */
10533 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
10535 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
10536 " to match the corresponding argument of the overridden"
10537 " procedure", proc_formal->sym->name, proc->name, &where,
10538 old_formal->sym->name);
10542 /* Check that the types correspond if neither is the passed-object
10544 /* FIXME: Do more comprehensive testing here. */
10545 if (proc_pass_arg != argpos && old_pass_arg != argpos
10546 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
10548 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
10549 "in respect to the overridden procedure",
10550 proc_formal->sym->name, proc->name, &where);
10556 if (proc_formal || old_formal)
10558 gfc_error ("'%s' at %L must have the same number of formal arguments as"
10559 " the overridden procedure", proc->name, &where);
10563 /* If the overridden binding is NOPASS, the overriding one must also be
10565 if (old->n.tb->nopass && !proc->n.tb->nopass)
10567 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
10568 " NOPASS", proc->name, &where);
10572 /* If the overridden binding is PASS(x), the overriding one must also be
10573 PASS and the passed-object dummy arguments must correspond. */
10574 if (!old->n.tb->nopass)
10576 if (proc->n.tb->nopass)
10578 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
10579 " PASS", proc->name, &where);
10583 if (proc_pass_arg != old_pass_arg)
10585 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
10586 " the same position as the passed-object dummy argument of"
10587 " the overridden procedure", proc->name, &where);
10596 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10599 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10600 const char* generic_name, locus where)
10605 gcc_assert (t1->specific && t2->specific);
10606 gcc_assert (!t1->specific->is_generic);
10607 gcc_assert (!t2->specific->is_generic);
10609 sym1 = t1->specific->u.specific->n.sym;
10610 sym2 = t2->specific->u.specific->n.sym;
10615 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10616 if (sym1->attr.subroutine != sym2->attr.subroutine
10617 || sym1->attr.function != sym2->attr.function)
10619 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10620 " GENERIC '%s' at %L",
10621 sym1->name, sym2->name, generic_name, &where);
10625 /* Compare the interfaces. */
10626 if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
10628 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10629 sym1->name, sym2->name, generic_name, &where);
10637 /* Worker function for resolving a generic procedure binding; this is used to
10638 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10640 The difference between those cases is finding possible inherited bindings
10641 that are overridden, as one has to look for them in tb_sym_root,
10642 tb_uop_root or tb_op, respectively. Thus the caller must already find
10643 the super-type and set p->overridden correctly. */
10646 resolve_tb_generic_targets (gfc_symbol* super_type,
10647 gfc_typebound_proc* p, const char* name)
10649 gfc_tbp_generic* target;
10650 gfc_symtree* first_target;
10651 gfc_symtree* inherited;
10653 gcc_assert (p && p->is_generic);
10655 /* Try to find the specific bindings for the symtrees in our target-list. */
10656 gcc_assert (p->u.generic);
10657 for (target = p->u.generic; target; target = target->next)
10658 if (!target->specific)
10660 gfc_typebound_proc* overridden_tbp;
10661 gfc_tbp_generic* g;
10662 const char* target_name;
10664 target_name = target->specific_st->name;
10666 /* Defined for this type directly. */
10667 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
10669 target->specific = target->specific_st->n.tb;
10670 goto specific_found;
10673 /* Look for an inherited specific binding. */
10676 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
10681 gcc_assert (inherited->n.tb);
10682 target->specific = inherited->n.tb;
10683 goto specific_found;
10687 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
10688 " at %L", target_name, name, &p->where);
10691 /* Once we've found the specific binding, check it is not ambiguous with
10692 other specifics already found or inherited for the same GENERIC. */
10694 gcc_assert (target->specific);
10696 /* This must really be a specific binding! */
10697 if (target->specific->is_generic)
10699 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
10700 " '%s' is GENERIC, too", name, &p->where, target_name);
10704 /* Check those already resolved on this type directly. */
10705 for (g = p->u.generic; g; g = g->next)
10706 if (g != target && g->specific
10707 && check_generic_tbp_ambiguity (target, g, name, p->where)
10711 /* Check for ambiguity with inherited specific targets. */
10712 for (overridden_tbp = p->overridden; overridden_tbp;
10713 overridden_tbp = overridden_tbp->overridden)
10714 if (overridden_tbp->is_generic)
10716 for (g = overridden_tbp->u.generic; g; g = g->next)
10718 gcc_assert (g->specific);
10719 if (check_generic_tbp_ambiguity (target, g,
10720 name, p->where) == FAILURE)
10726 /* If we attempt to "overwrite" a specific binding, this is an error. */
10727 if (p->overridden && !p->overridden->is_generic)
10729 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
10730 " the same name", name, &p->where);
10734 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
10735 all must have the same attributes here. */
10736 first_target = p->u.generic->specific->u.specific;
10737 gcc_assert (first_target);
10738 p->subroutine = first_target->n.sym->attr.subroutine;
10739 p->function = first_target->n.sym->attr.function;
10745 /* Resolve a GENERIC procedure binding for a derived type. */
10748 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
10750 gfc_symbol* super_type;
10752 /* Find the overridden binding if any. */
10753 st->n.tb->overridden = NULL;
10754 super_type = gfc_get_derived_super_type (derived);
10757 gfc_symtree* overridden;
10758 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
10761 if (overridden && overridden->n.tb)
10762 st->n.tb->overridden = overridden->n.tb;
10765 /* Resolve using worker function. */
10766 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
10770 /* Retrieve the target-procedure of an operator binding and do some checks in
10771 common for intrinsic and user-defined type-bound operators. */
10774 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
10776 gfc_symbol* target_proc;
10778 gcc_assert (target->specific && !target->specific->is_generic);
10779 target_proc = target->specific->u.specific->n.sym;
10780 gcc_assert (target_proc);
10782 /* All operator bindings must have a passed-object dummy argument. */
10783 if (target->specific->nopass)
10785 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
10789 return target_proc;
10793 /* Resolve a type-bound intrinsic operator. */
10796 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
10797 gfc_typebound_proc* p)
10799 gfc_symbol* super_type;
10800 gfc_tbp_generic* target;
10802 /* If there's already an error here, do nothing (but don't fail again). */
10806 /* Operators should always be GENERIC bindings. */
10807 gcc_assert (p->is_generic);
10809 /* Look for an overridden binding. */
10810 super_type = gfc_get_derived_super_type (derived);
10811 if (super_type && super_type->f2k_derived)
10812 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
10815 p->overridden = NULL;
10817 /* Resolve general GENERIC properties using worker function. */
10818 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
10821 /* Check the targets to be procedures of correct interface. */
10822 for (target = p->u.generic; target; target = target->next)
10824 gfc_symbol* target_proc;
10826 target_proc = get_checked_tb_operator_target (target, p->where);
10830 if (!gfc_check_operator_interface (target_proc, op, p->where))
10842 /* Resolve a type-bound user operator (tree-walker callback). */
10844 static gfc_symbol* resolve_bindings_derived;
10845 static gfc_try resolve_bindings_result;
10847 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
10850 resolve_typebound_user_op (gfc_symtree* stree)
10852 gfc_symbol* super_type;
10853 gfc_tbp_generic* target;
10855 gcc_assert (stree && stree->n.tb);
10857 if (stree->n.tb->error)
10860 /* Operators should always be GENERIC bindings. */
10861 gcc_assert (stree->n.tb->is_generic);
10863 /* Find overridden procedure, if any. */
10864 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10865 if (super_type && super_type->f2k_derived)
10867 gfc_symtree* overridden;
10868 overridden = gfc_find_typebound_user_op (super_type, NULL,
10869 stree->name, true, NULL);
10871 if (overridden && overridden->n.tb)
10872 stree->n.tb->overridden = overridden->n.tb;
10875 stree->n.tb->overridden = NULL;
10877 /* Resolve basically using worker function. */
10878 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
10882 /* Check the targets to be functions of correct interface. */
10883 for (target = stree->n.tb->u.generic; target; target = target->next)
10885 gfc_symbol* target_proc;
10887 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
10891 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
10898 resolve_bindings_result = FAILURE;
10899 stree->n.tb->error = 1;
10903 /* Resolve the type-bound procedures for a derived type. */
10906 resolve_typebound_procedure (gfc_symtree* stree)
10910 gfc_symbol* me_arg;
10911 gfc_symbol* super_type;
10912 gfc_component* comp;
10914 gcc_assert (stree);
10916 /* Undefined specific symbol from GENERIC target definition. */
10920 if (stree->n.tb->error)
10923 /* If this is a GENERIC binding, use that routine. */
10924 if (stree->n.tb->is_generic)
10926 if (resolve_typebound_generic (resolve_bindings_derived, stree)
10932 /* Get the target-procedure to check it. */
10933 gcc_assert (!stree->n.tb->is_generic);
10934 gcc_assert (stree->n.tb->u.specific);
10935 proc = stree->n.tb->u.specific->n.sym;
10936 where = stree->n.tb->where;
10938 /* Default access should already be resolved from the parser. */
10939 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
10941 /* It should be a module procedure or an external procedure with explicit
10942 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
10943 if ((!proc->attr.subroutine && !proc->attr.function)
10944 || (proc->attr.proc != PROC_MODULE
10945 && proc->attr.if_source != IFSRC_IFBODY)
10946 || (proc->attr.abstract && !stree->n.tb->deferred))
10948 gfc_error ("'%s' must be a module procedure or an external procedure with"
10949 " an explicit interface at %L", proc->name, &where);
10952 stree->n.tb->subroutine = proc->attr.subroutine;
10953 stree->n.tb->function = proc->attr.function;
10955 /* Find the super-type of the current derived type. We could do this once and
10956 store in a global if speed is needed, but as long as not I believe this is
10957 more readable and clearer. */
10958 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10960 /* If PASS, resolve and check arguments if not already resolved / loaded
10961 from a .mod file. */
10962 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
10964 if (stree->n.tb->pass_arg)
10966 gfc_formal_arglist* i;
10968 /* If an explicit passing argument name is given, walk the arg-list
10969 and look for it. */
10972 stree->n.tb->pass_arg_num = 1;
10973 for (i = proc->formal; i; i = i->next)
10975 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
10980 ++stree->n.tb->pass_arg_num;
10985 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
10987 proc->name, stree->n.tb->pass_arg, &where,
10988 stree->n.tb->pass_arg);
10994 /* Otherwise, take the first one; there should in fact be at least
10996 stree->n.tb->pass_arg_num = 1;
10999 gfc_error ("Procedure '%s' with PASS at %L must have at"
11000 " least one argument", proc->name, &where);
11003 me_arg = proc->formal->sym;
11006 /* Now check that the argument-type matches and the passed-object
11007 dummy argument is generally fine. */
11009 gcc_assert (me_arg);
11011 if (me_arg->ts.type != BT_CLASS)
11013 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11014 " at %L", proc->name, &where);
11018 if (CLASS_DATA (me_arg)->ts.u.derived
11019 != resolve_bindings_derived)
11021 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11022 " the derived-type '%s'", me_arg->name, proc->name,
11023 me_arg->name, &where, resolve_bindings_derived->name);
11027 gcc_assert (me_arg->ts.type == BT_CLASS);
11028 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
11030 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11031 " scalar", proc->name, &where);
11034 if (CLASS_DATA (me_arg)->attr.allocatable)
11036 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11037 " be ALLOCATABLE", proc->name, &where);
11040 if (CLASS_DATA (me_arg)->attr.class_pointer)
11042 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11043 " be POINTER", proc->name, &where);
11048 /* If we are extending some type, check that we don't override a procedure
11049 flagged NON_OVERRIDABLE. */
11050 stree->n.tb->overridden = NULL;
11053 gfc_symtree* overridden;
11054 overridden = gfc_find_typebound_proc (super_type, NULL,
11055 stree->name, true, NULL);
11057 if (overridden && overridden->n.tb)
11058 stree->n.tb->overridden = overridden->n.tb;
11060 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
11064 /* See if there's a name collision with a component directly in this type. */
11065 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11066 if (!strcmp (comp->name, stree->name))
11068 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11070 stree->name, &where, resolve_bindings_derived->name);
11074 /* Try to find a name collision with an inherited component. */
11075 if (super_type && gfc_find_component (super_type, stree->name, true, true))
11077 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11078 " component of '%s'",
11079 stree->name, &where, resolve_bindings_derived->name);
11083 stree->n.tb->error = 0;
11087 resolve_bindings_result = FAILURE;
11088 stree->n.tb->error = 1;
11093 resolve_typebound_procedures (gfc_symbol* derived)
11097 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11100 resolve_bindings_derived = derived;
11101 resolve_bindings_result = SUCCESS;
11103 /* Make sure the vtab has been generated. */
11104 gfc_find_derived_vtab (derived);
11106 if (derived->f2k_derived->tb_sym_root)
11107 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11108 &resolve_typebound_procedure);
11110 if (derived->f2k_derived->tb_uop_root)
11111 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11112 &resolve_typebound_user_op);
11114 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11116 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11117 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11119 resolve_bindings_result = FAILURE;
11122 return resolve_bindings_result;
11126 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11127 to give all identical derived types the same backend_decl. */
11129 add_dt_to_dt_list (gfc_symbol *derived)
11131 gfc_dt_list *dt_list;
11133 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11134 if (derived == dt_list->derived)
11137 dt_list = gfc_get_dt_list ();
11138 dt_list->next = gfc_derived_types;
11139 dt_list->derived = derived;
11140 gfc_derived_types = dt_list;
11144 /* Ensure that a derived-type is really not abstract, meaning that every
11145 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11148 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11153 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11155 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11158 if (st->n.tb && st->n.tb->deferred)
11160 gfc_symtree* overriding;
11161 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11164 gcc_assert (overriding->n.tb);
11165 if (overriding->n.tb->deferred)
11167 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11168 " '%s' is DEFERRED and not overridden",
11169 sub->name, &sub->declared_at, st->name);
11178 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11180 /* The algorithm used here is to recursively travel up the ancestry of sub
11181 and for each ancestor-type, check all bindings. If any of them is
11182 DEFERRED, look it up starting from sub and see if the found (overriding)
11183 binding is not DEFERRED.
11184 This is not the most efficient way to do this, but it should be ok and is
11185 clearer than something sophisticated. */
11187 gcc_assert (ancestor && !sub->attr.abstract);
11189 if (!ancestor->attr.abstract)
11192 /* Walk bindings of this ancestor. */
11193 if (ancestor->f2k_derived)
11196 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11201 /* Find next ancestor type and recurse on it. */
11202 ancestor = gfc_get_derived_super_type (ancestor);
11204 return ensure_not_abstract (sub, ancestor);
11210 /* Resolve the components of a derived type. */
11213 resolve_fl_derived (gfc_symbol *sym)
11215 gfc_symbol* super_type;
11218 super_type = gfc_get_derived_super_type (sym);
11220 if (sym->attr.is_class && sym->ts.u.derived == NULL)
11222 /* Fix up incomplete CLASS symbols. */
11223 gfc_component *data = gfc_find_component (sym, "_data", true, true);
11224 gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
11225 if (vptr->ts.u.derived == NULL)
11227 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
11229 vptr->ts.u.derived = vtab->ts.u.derived;
11234 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11236 gfc_error ("As extending type '%s' at %L has a coarray component, "
11237 "parent type '%s' shall also have one", sym->name,
11238 &sym->declared_at, super_type->name);
11242 /* Ensure the extended type gets resolved before we do. */
11243 if (super_type && resolve_fl_derived (super_type) == FAILURE)
11246 /* An ABSTRACT type must be extensible. */
11247 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11249 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11250 sym->name, &sym->declared_at);
11254 for (c = sym->components; c != NULL; c = c->next)
11257 if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */
11258 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11260 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11261 "deferred shape", c->name, &c->loc);
11266 if (c->attr.codimension && c->ts.type == BT_DERIVED
11267 && c->ts.u.derived->ts.is_iso_c)
11269 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11270 "shall not be a coarray", c->name, &c->loc);
11275 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11276 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11277 || c->attr.allocatable))
11279 gfc_error ("Component '%s' at %L with coarray component "
11280 "shall be a nonpointer, nonallocatable scalar",
11286 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11288 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11289 "is not an array pointer", c->name, &c->loc);
11293 if (c->attr.proc_pointer && c->ts.interface)
11295 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11296 gfc_error ("Interface '%s', used by procedure pointer component "
11297 "'%s' at %L, is declared in a later PROCEDURE statement",
11298 c->ts.interface->name, c->name, &c->loc);
11300 /* Get the attributes from the interface (now resolved). */
11301 if (c->ts.interface->attr.if_source
11302 || c->ts.interface->attr.intrinsic)
11304 gfc_symbol *ifc = c->ts.interface;
11306 if (ifc->formal && !ifc->formal_ns)
11307 resolve_symbol (ifc);
11309 if (ifc->attr.intrinsic)
11310 resolve_intrinsic (ifc, &ifc->declared_at);
11314 c->ts = ifc->result->ts;
11315 c->attr.allocatable = ifc->result->attr.allocatable;
11316 c->attr.pointer = ifc->result->attr.pointer;
11317 c->attr.dimension = ifc->result->attr.dimension;
11318 c->as = gfc_copy_array_spec (ifc->result->as);
11323 c->attr.allocatable = ifc->attr.allocatable;
11324 c->attr.pointer = ifc->attr.pointer;
11325 c->attr.dimension = ifc->attr.dimension;
11326 c->as = gfc_copy_array_spec (ifc->as);
11328 c->ts.interface = ifc;
11329 c->attr.function = ifc->attr.function;
11330 c->attr.subroutine = ifc->attr.subroutine;
11331 gfc_copy_formal_args_ppc (c, ifc);
11333 c->attr.pure = ifc->attr.pure;
11334 c->attr.elemental = ifc->attr.elemental;
11335 c->attr.recursive = ifc->attr.recursive;
11336 c->attr.always_explicit = ifc->attr.always_explicit;
11337 c->attr.ext_attr |= ifc->attr.ext_attr;
11338 /* Replace symbols in array spec. */
11342 for (i = 0; i < c->as->rank; i++)
11344 gfc_expr_replace_comp (c->as->lower[i], c);
11345 gfc_expr_replace_comp (c->as->upper[i], c);
11348 /* Copy char length. */
11349 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11351 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11352 gfc_expr_replace_comp (cl->length, c);
11353 if (cl->length && !cl->resolved
11354 && gfc_resolve_expr (cl->length) == FAILURE)
11359 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11361 gfc_error ("Interface '%s' of procedure pointer component "
11362 "'%s' at %L must be explicit", c->ts.interface->name,
11367 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11369 /* Since PPCs are not implicitly typed, a PPC without an explicit
11370 interface must be a subroutine. */
11371 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11374 /* Procedure pointer components: Check PASS arg. */
11375 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11376 && !sym->attr.vtype)
11378 gfc_symbol* me_arg;
11380 if (c->tb->pass_arg)
11382 gfc_formal_arglist* i;
11384 /* If an explicit passing argument name is given, walk the arg-list
11385 and look for it. */
11388 c->tb->pass_arg_num = 1;
11389 for (i = c->formal; i; i = i->next)
11391 if (!strcmp (i->sym->name, c->tb->pass_arg))
11396 c->tb->pass_arg_num++;
11401 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11402 "at %L has no argument '%s'", c->name,
11403 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11410 /* Otherwise, take the first one; there should in fact be at least
11412 c->tb->pass_arg_num = 1;
11415 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11416 "must have at least one argument",
11421 me_arg = c->formal->sym;
11424 /* Now check that the argument-type matches. */
11425 gcc_assert (me_arg);
11426 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11427 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11428 || (me_arg->ts.type == BT_CLASS
11429 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11431 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11432 " the derived type '%s'", me_arg->name, c->name,
11433 me_arg->name, &c->loc, sym->name);
11438 /* Check for C453. */
11439 if (me_arg->attr.dimension)
11441 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11442 "must be scalar", me_arg->name, c->name, me_arg->name,
11448 if (me_arg->attr.pointer)
11450 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11451 "may not have the POINTER attribute", me_arg->name,
11452 c->name, me_arg->name, &c->loc);
11457 if (me_arg->attr.allocatable)
11459 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11460 "may not be ALLOCATABLE", me_arg->name, c->name,
11461 me_arg->name, &c->loc);
11466 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11467 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11468 " at %L", c->name, &c->loc);
11472 /* Check type-spec if this is not the parent-type component. */
11473 if ((!sym->attr.extension || c != sym->components) && !sym->attr.vtype
11474 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11477 /* If this type is an extension, set the accessibility of the parent
11479 if (super_type && c == sym->components
11480 && strcmp (super_type->name, c->name) == 0)
11481 c->attr.access = super_type->attr.access;
11483 /* If this type is an extension, see if this component has the same name
11484 as an inherited type-bound procedure. */
11485 if (super_type && !sym->attr.is_class
11486 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11488 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11489 " inherited type-bound procedure",
11490 c->name, sym->name, &c->loc);
11494 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
11496 if (c->ts.u.cl->length == NULL
11497 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11498 || !gfc_is_constant_expr (c->ts.u.cl->length))
11500 gfc_error ("Character length of component '%s' needs to "
11501 "be a constant specification expression at %L",
11503 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11508 if (c->ts.type == BT_DERIVED
11509 && sym->component_access != ACCESS_PRIVATE
11510 && gfc_check_access (sym->attr.access, sym->ns->default_access)
11511 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11512 && !c->ts.u.derived->attr.use_assoc
11513 && !gfc_check_access (c->ts.u.derived->attr.access,
11514 c->ts.u.derived->ns->default_access)
11515 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11516 "is a PRIVATE type and cannot be a component of "
11517 "'%s', which is PUBLIC at %L", c->name,
11518 sym->name, &sym->declared_at) == FAILURE)
11521 if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
11523 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11524 "type %s", c->name, &c->loc, sym->name);
11528 if (sym->attr.sequence)
11530 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11532 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11533 "not have the SEQUENCE attribute",
11534 c->ts.u.derived->name, &sym->declared_at);
11539 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
11540 && c->attr.pointer && c->ts.u.derived->components == NULL
11541 && !c->ts.u.derived->attr.zero_comp)
11543 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11544 "that has not been declared", c->name, sym->name,
11549 if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer
11550 && CLASS_DATA (c)->ts.u.derived->components == NULL
11551 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11553 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11554 "that has not been declared", c->name, sym->name,
11560 if (c->ts.type == BT_CLASS
11561 && !(CLASS_DATA (c)->attr.class_pointer
11562 || CLASS_DATA (c)->attr.allocatable))
11564 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11565 "or pointer", c->name, &c->loc);
11569 /* Ensure that all the derived type components are put on the
11570 derived type list; even in formal namespaces, where derived type
11571 pointer components might not have been declared. */
11572 if (c->ts.type == BT_DERIVED
11574 && c->ts.u.derived->components
11576 && sym != c->ts.u.derived)
11577 add_dt_to_dt_list (c->ts.u.derived);
11579 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11580 || c->attr.proc_pointer
11581 || c->attr.allocatable)) == FAILURE)
11585 /* Resolve the type-bound procedures. */
11586 if (resolve_typebound_procedures (sym) == FAILURE)
11589 /* Resolve the finalizer procedures. */
11590 if (gfc_resolve_finalizers (sym) == FAILURE)
11593 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11594 all DEFERRED bindings are overridden. */
11595 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11596 && !sym->attr.is_class
11597 && ensure_not_abstract (sym, super_type) == FAILURE)
11600 /* Add derived type to the derived type list. */
11601 add_dt_to_dt_list (sym);
11608 resolve_fl_namelist (gfc_symbol *sym)
11613 for (nl = sym->namelist; nl; nl = nl->next)
11615 /* Reject namelist arrays of assumed shape. */
11616 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
11617 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
11618 "must not have assumed shape in namelist "
11619 "'%s' at %L", nl->sym->name, sym->name,
11620 &sym->declared_at) == FAILURE)
11623 /* Reject namelist arrays that are not constant shape. */
11624 if (is_non_constant_shape_array (nl->sym))
11626 gfc_error ("NAMELIST array object '%s' must have constant "
11627 "shape in namelist '%s' at %L", nl->sym->name,
11628 sym->name, &sym->declared_at);
11632 /* Namelist objects cannot have allocatable or pointer components. */
11633 if (nl->sym->ts.type != BT_DERIVED)
11636 if (nl->sym->ts.u.derived->attr.alloc_comp)
11638 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11639 "have ALLOCATABLE components",
11640 nl->sym->name, sym->name, &sym->declared_at);
11644 if (nl->sym->ts.u.derived->attr.pointer_comp)
11646 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11647 "have POINTER components",
11648 nl->sym->name, sym->name, &sym->declared_at);
11653 /* Reject PRIVATE objects in a PUBLIC namelist. */
11654 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
11656 for (nl = sym->namelist; nl; nl = nl->next)
11658 if (!nl->sym->attr.use_assoc
11659 && !is_sym_host_assoc (nl->sym, sym->ns)
11660 && !gfc_check_access(nl->sym->attr.access,
11661 nl->sym->ns->default_access))
11663 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
11664 "cannot be member of PUBLIC namelist '%s' at %L",
11665 nl->sym->name, sym->name, &sym->declared_at);
11669 /* Types with private components that came here by USE-association. */
11670 if (nl->sym->ts.type == BT_DERIVED
11671 && derived_inaccessible (nl->sym->ts.u.derived))
11673 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
11674 "components and cannot be member of namelist '%s' at %L",
11675 nl->sym->name, sym->name, &sym->declared_at);
11679 /* Types with private components that are defined in the same module. */
11680 if (nl->sym->ts.type == BT_DERIVED
11681 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
11682 && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
11683 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
11684 nl->sym->ns->default_access))
11686 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
11687 "cannot be a member of PUBLIC namelist '%s' at %L",
11688 nl->sym->name, sym->name, &sym->declared_at);
11695 /* 14.1.2 A module or internal procedure represent local entities
11696 of the same type as a namelist member and so are not allowed. */
11697 for (nl = sym->namelist; nl; nl = nl->next)
11699 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
11702 if (nl->sym->attr.function && nl->sym == nl->sym->result)
11703 if ((nl->sym == sym->ns->proc_name)
11705 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
11709 if (nl->sym && nl->sym->name)
11710 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
11711 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
11713 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
11714 "attribute in '%s' at %L", nlsym->name,
11715 &sym->declared_at);
11725 resolve_fl_parameter (gfc_symbol *sym)
11727 /* A parameter array's shape needs to be constant. */
11728 if (sym->as != NULL
11729 && (sym->as->type == AS_DEFERRED
11730 || is_non_constant_shape_array (sym)))
11732 gfc_error ("Parameter array '%s' at %L cannot be automatic "
11733 "or of deferred shape", sym->name, &sym->declared_at);
11737 /* Make sure a parameter that has been implicitly typed still
11738 matches the implicit type, since PARAMETER statements can precede
11739 IMPLICIT statements. */
11740 if (sym->attr.implicit_type
11741 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
11744 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
11745 "later IMPLICIT type", sym->name, &sym->declared_at);
11749 /* Make sure the types of derived parameters are consistent. This
11750 type checking is deferred until resolution because the type may
11751 refer to a derived type from the host. */
11752 if (sym->ts.type == BT_DERIVED
11753 && !gfc_compare_types (&sym->ts, &sym->value->ts))
11755 gfc_error ("Incompatible derived type in PARAMETER at %L",
11756 &sym->value->where);
11763 /* Do anything necessary to resolve a symbol. Right now, we just
11764 assume that an otherwise unknown symbol is a variable. This sort
11765 of thing commonly happens for symbols in module. */
11768 resolve_symbol (gfc_symbol *sym)
11770 int check_constant, mp_flag;
11771 gfc_symtree *symtree;
11772 gfc_symtree *this_symtree;
11776 /* Avoid double resolution of function result symbols. */
11777 if ((sym->result || sym->attr.result) && !sym->attr.dummy
11778 && (sym->ns != gfc_current_ns))
11781 if (sym->attr.flavor == FL_UNKNOWN)
11784 /* If we find that a flavorless symbol is an interface in one of the
11785 parent namespaces, find its symtree in this namespace, free the
11786 symbol and set the symtree to point to the interface symbol. */
11787 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
11789 symtree = gfc_find_symtree (ns->sym_root, sym->name);
11790 if (symtree && (symtree->n.sym->generic ||
11791 (symtree->n.sym->attr.flavor == FL_PROCEDURE
11792 && sym->ns->construct_entities)))
11794 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
11796 gfc_release_symbol (sym);
11797 symtree->n.sym->refs++;
11798 this_symtree->n.sym = symtree->n.sym;
11803 /* Otherwise give it a flavor according to such attributes as
11805 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
11806 sym->attr.flavor = FL_VARIABLE;
11809 sym->attr.flavor = FL_PROCEDURE;
11810 if (sym->attr.dimension)
11811 sym->attr.function = 1;
11815 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
11816 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
11818 if (sym->attr.procedure && sym->ts.interface
11819 && sym->attr.if_source != IFSRC_DECL
11820 && resolve_procedure_interface (sym) == FAILURE)
11823 if (sym->attr.is_protected && !sym->attr.proc_pointer
11824 && (sym->attr.procedure || sym->attr.external))
11826 if (sym->attr.external)
11827 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
11828 "at %L", &sym->declared_at);
11830 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
11831 "at %L", &sym->declared_at);
11838 if (sym->attr.contiguous
11839 && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE
11840 && !sym->attr.pointer)))
11842 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
11843 "array pointer or an assumed-shape array", sym->name,
11844 &sym->declared_at);
11848 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
11851 /* Symbols that are module procedures with results (functions) have
11852 the types and array specification copied for type checking in
11853 procedures that call them, as well as for saving to a module
11854 file. These symbols can't stand the scrutiny that their results
11856 mp_flag = (sym->result != NULL && sym->result != sym);
11858 /* Make sure that the intrinsic is consistent with its internal
11859 representation. This needs to be done before assigning a default
11860 type to avoid spurious warnings. */
11861 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
11862 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
11865 /* Resolve associate names. */
11867 resolve_assoc_var (sym, true);
11869 /* Assign default type to symbols that need one and don't have one. */
11870 if (sym->ts.type == BT_UNKNOWN)
11872 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
11873 gfc_set_default_type (sym, 1, NULL);
11875 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
11876 && !sym->attr.function && !sym->attr.subroutine
11877 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
11878 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
11880 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
11882 /* The specific case of an external procedure should emit an error
11883 in the case that there is no implicit type. */
11885 gfc_set_default_type (sym, sym->attr.external, NULL);
11888 /* Result may be in another namespace. */
11889 resolve_symbol (sym->result);
11891 if (!sym->result->attr.proc_pointer)
11893 sym->ts = sym->result->ts;
11894 sym->as = gfc_copy_array_spec (sym->result->as);
11895 sym->attr.dimension = sym->result->attr.dimension;
11896 sym->attr.pointer = sym->result->attr.pointer;
11897 sym->attr.allocatable = sym->result->attr.allocatable;
11898 sym->attr.contiguous = sym->result->attr.contiguous;
11904 /* Assumed size arrays and assumed shape arrays must be dummy
11905 arguments. Array-spec's of implied-shape should have been resolved to
11906 AS_EXPLICIT already. */
11910 gcc_assert (sym->as->type != AS_IMPLIED_SHAPE);
11911 if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
11912 || sym->as->type == AS_ASSUMED_SHAPE)
11913 && sym->attr.dummy == 0)
11915 if (sym->as->type == AS_ASSUMED_SIZE)
11916 gfc_error ("Assumed size array at %L must be a dummy argument",
11917 &sym->declared_at);
11919 gfc_error ("Assumed shape array at %L must be a dummy argument",
11920 &sym->declared_at);
11925 /* Make sure symbols with known intent or optional are really dummy
11926 variable. Because of ENTRY statement, this has to be deferred
11927 until resolution time. */
11929 if (!sym->attr.dummy
11930 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
11932 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
11936 if (sym->attr.value && !sym->attr.dummy)
11938 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
11939 "it is not a dummy argument", sym->name, &sym->declared_at);
11943 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
11945 gfc_charlen *cl = sym->ts.u.cl;
11946 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
11948 gfc_error ("Character dummy variable '%s' at %L with VALUE "
11949 "attribute must have constant length",
11950 sym->name, &sym->declared_at);
11954 if (sym->ts.is_c_interop
11955 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
11957 gfc_error ("C interoperable character dummy variable '%s' at %L "
11958 "with VALUE attribute must have length one",
11959 sym->name, &sym->declared_at);
11964 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
11965 do this for something that was implicitly typed because that is handled
11966 in gfc_set_default_type. Handle dummy arguments and procedure
11967 definitions separately. Also, anything that is use associated is not
11968 handled here but instead is handled in the module it is declared in.
11969 Finally, derived type definitions are allowed to be BIND(C) since that
11970 only implies that they're interoperable, and they are checked fully for
11971 interoperability when a variable is declared of that type. */
11972 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
11973 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
11974 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
11976 gfc_try t = SUCCESS;
11978 /* First, make sure the variable is declared at the
11979 module-level scope (J3/04-007, Section 15.3). */
11980 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
11981 sym->attr.in_common == 0)
11983 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
11984 "is neither a COMMON block nor declared at the "
11985 "module level scope", sym->name, &(sym->declared_at));
11988 else if (sym->common_head != NULL)
11990 t = verify_com_block_vars_c_interop (sym->common_head);
11994 /* If type() declaration, we need to verify that the components
11995 of the given type are all C interoperable, etc. */
11996 if (sym->ts.type == BT_DERIVED &&
11997 sym->ts.u.derived->attr.is_c_interop != 1)
11999 /* Make sure the user marked the derived type as BIND(C). If
12000 not, call the verify routine. This could print an error
12001 for the derived type more than once if multiple variables
12002 of that type are declared. */
12003 if (sym->ts.u.derived->attr.is_bind_c != 1)
12004 verify_bind_c_derived_type (sym->ts.u.derived);
12008 /* Verify the variable itself as C interoperable if it
12009 is BIND(C). It is not possible for this to succeed if
12010 the verify_bind_c_derived_type failed, so don't have to handle
12011 any error returned by verify_bind_c_derived_type. */
12012 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
12013 sym->common_block);
12018 /* clear the is_bind_c flag to prevent reporting errors more than
12019 once if something failed. */
12020 sym->attr.is_bind_c = 0;
12025 /* If a derived type symbol has reached this point, without its
12026 type being declared, we have an error. Notice that most
12027 conditions that produce undefined derived types have already
12028 been dealt with. However, the likes of:
12029 implicit type(t) (t) ..... call foo (t) will get us here if
12030 the type is not declared in the scope of the implicit
12031 statement. Change the type to BT_UNKNOWN, both because it is so
12032 and to prevent an ICE. */
12033 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
12034 && !sym->ts.u.derived->attr.zero_comp)
12036 gfc_error ("The derived type '%s' at %L is of type '%s', "
12037 "which has not been defined", sym->name,
12038 &sym->declared_at, sym->ts.u.derived->name);
12039 sym->ts.type = BT_UNKNOWN;
12043 /* Make sure that the derived type has been resolved and that the
12044 derived type is visible in the symbol's namespace, if it is a
12045 module function and is not PRIVATE. */
12046 if (sym->ts.type == BT_DERIVED
12047 && sym->ts.u.derived->attr.use_assoc
12048 && sym->ns->proc_name
12049 && sym->ns->proc_name->attr.flavor == FL_MODULE)
12053 if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
12056 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
12057 if (!ds && sym->attr.function
12058 && gfc_check_access (sym->attr.access, sym->ns->default_access))
12060 symtree = gfc_new_symtree (&sym->ns->sym_root,
12061 sym->ts.u.derived->name);
12062 symtree->n.sym = sym->ts.u.derived;
12063 sym->ts.u.derived->refs++;
12067 /* Unless the derived-type declaration is use associated, Fortran 95
12068 does not allow public entries of private derived types.
12069 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12070 161 in 95-006r3. */
12071 if (sym->ts.type == BT_DERIVED
12072 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12073 && !sym->ts.u.derived->attr.use_assoc
12074 && gfc_check_access (sym->attr.access, sym->ns->default_access)
12075 && !gfc_check_access (sym->ts.u.derived->attr.access,
12076 sym->ts.u.derived->ns->default_access)
12077 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12078 "of PRIVATE derived type '%s'",
12079 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12080 : "variable", sym->name, &sym->declared_at,
12081 sym->ts.u.derived->name) == FAILURE)
12084 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12085 default initialization is defined (5.1.2.4.4). */
12086 if (sym->ts.type == BT_DERIVED
12088 && sym->attr.intent == INTENT_OUT
12090 && sym->as->type == AS_ASSUMED_SIZE)
12092 for (c = sym->ts.u.derived->components; c; c = c->next)
12094 if (c->initializer)
12096 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12097 "ASSUMED SIZE and so cannot have a default initializer",
12098 sym->name, &sym->declared_at);
12105 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12106 || sym->attr.codimension)
12107 && sym->attr.result)
12108 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12109 "a coarray component", sym->name, &sym->declared_at);
12112 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12113 && sym->ts.u.derived->ts.is_iso_c)
12114 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12115 "shall not be a coarray", sym->name, &sym->declared_at);
12118 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
12119 && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
12120 || sym->attr.allocatable))
12121 gfc_error ("Variable '%s' at %L with coarray component "
12122 "shall be a nonpointer, nonallocatable scalar",
12123 sym->name, &sym->declared_at);
12125 /* F2008, C526. The function-result case was handled above. */
12126 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12127 || sym->attr.codimension)
12128 && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
12129 || sym->ns->proc_name->attr.flavor == FL_MODULE
12130 || sym->ns->proc_name->attr.is_main_program
12131 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12132 gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
12133 "component and is not ALLOCATABLE, SAVE nor a "
12134 "dummy argument", sym->name, &sym->declared_at);
12135 /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
12136 else if (sym->attr.codimension && !sym->attr.allocatable
12137 && sym->as && sym->as->cotype == AS_DEFERRED)
12138 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12139 "deferred shape", sym->name, &sym->declared_at);
12140 else if (sym->attr.codimension && sym->attr.allocatable
12141 && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
12142 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12143 "deferred shape", sym->name, &sym->declared_at);
12147 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12148 || (sym->attr.codimension && sym->attr.allocatable))
12149 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12150 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12151 "allocatable coarray or have coarray components",
12152 sym->name, &sym->declared_at);
12154 if (sym->attr.codimension && sym->attr.dummy
12155 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12156 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12157 "procedure '%s'", sym->name, &sym->declared_at,
12158 sym->ns->proc_name->name);
12160 switch (sym->attr.flavor)
12163 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12168 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12173 if (resolve_fl_namelist (sym) == FAILURE)
12178 if (resolve_fl_parameter (sym) == FAILURE)
12186 /* Resolve array specifier. Check as well some constraints
12187 on COMMON blocks. */
12189 check_constant = sym->attr.in_common && !sym->attr.pointer;
12191 /* Set the formal_arg_flag so that check_conflict will not throw
12192 an error for host associated variables in the specification
12193 expression for an array_valued function. */
12194 if (sym->attr.function && sym->as)
12195 formal_arg_flag = 1;
12197 gfc_resolve_array_spec (sym->as, check_constant);
12199 formal_arg_flag = 0;
12201 /* Resolve formal namespaces. */
12202 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12203 && !sym->attr.contained && !sym->attr.intrinsic)
12204 gfc_resolve (sym->formal_ns);
12206 /* Make sure the formal namespace is present. */
12207 if (sym->formal && !sym->formal_ns)
12209 gfc_formal_arglist *formal = sym->formal;
12210 while (formal && !formal->sym)
12211 formal = formal->next;
12215 sym->formal_ns = formal->sym->ns;
12216 sym->formal_ns->refs++;
12220 /* Check threadprivate restrictions. */
12221 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12222 && (!sym->attr.in_common
12223 && sym->module == NULL
12224 && (sym->ns->proc_name == NULL
12225 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12226 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12228 /* If we have come this far we can apply default-initializers, as
12229 described in 14.7.5, to those variables that have not already
12230 been assigned one. */
12231 if (sym->ts.type == BT_DERIVED
12232 && sym->ns == gfc_current_ns
12234 && !sym->attr.allocatable
12235 && !sym->attr.alloc_comp)
12237 symbol_attribute *a = &sym->attr;
12239 if ((!a->save && !a->dummy && !a->pointer
12240 && !a->in_common && !a->use_assoc
12241 && (a->referenced || a->result)
12242 && !(a->function && sym != sym->result))
12243 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12244 apply_default_init (sym);
12247 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
12248 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
12249 && !CLASS_DATA (sym)->attr.class_pointer
12250 && !CLASS_DATA (sym)->attr.allocatable)
12251 apply_default_init (sym);
12253 /* If this symbol has a type-spec, check it. */
12254 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12255 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12256 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12262 /************* Resolve DATA statements *************/
12266 gfc_data_value *vnode;
12272 /* Advance the values structure to point to the next value in the data list. */
12275 next_data_value (void)
12277 while (mpz_cmp_ui (values.left, 0) == 0)
12280 if (values.vnode->next == NULL)
12283 values.vnode = values.vnode->next;
12284 mpz_set (values.left, values.vnode->repeat);
12292 check_data_variable (gfc_data_variable *var, locus *where)
12298 ar_type mark = AR_UNKNOWN;
12300 mpz_t section_index[GFC_MAX_DIMENSIONS];
12306 if (gfc_resolve_expr (var->expr) == FAILURE)
12310 mpz_init_set_si (offset, 0);
12313 if (e->expr_type != EXPR_VARIABLE)
12314 gfc_internal_error ("check_data_variable(): Bad expression");
12316 sym = e->symtree->n.sym;
12318 if (sym->ns->is_block_data && !sym->attr.in_common)
12320 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12321 sym->name, &sym->declared_at);
12324 if (e->ref == NULL && sym->as)
12326 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12327 " declaration", sym->name, where);
12331 has_pointer = sym->attr.pointer;
12333 for (ref = e->ref; ref; ref = ref->next)
12335 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12338 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
12340 gfc_error ("DATA element '%s' at %L cannot have a coindex",
12346 && ref->type == REF_ARRAY
12347 && ref->u.ar.type != AR_FULL)
12349 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12350 "be a full array", sym->name, where);
12355 if (e->rank == 0 || has_pointer)
12357 mpz_init_set_ui (size, 1);
12364 /* Find the array section reference. */
12365 for (ref = e->ref; ref; ref = ref->next)
12367 if (ref->type != REF_ARRAY)
12369 if (ref->u.ar.type == AR_ELEMENT)
12375 /* Set marks according to the reference pattern. */
12376 switch (ref->u.ar.type)
12384 /* Get the start position of array section. */
12385 gfc_get_section_index (ar, section_index, &offset);
12390 gcc_unreachable ();
12393 if (gfc_array_size (e, &size) == FAILURE)
12395 gfc_error ("Nonconstant array section at %L in DATA statement",
12397 mpz_clear (offset);
12404 while (mpz_cmp_ui (size, 0) > 0)
12406 if (next_data_value () == FAILURE)
12408 gfc_error ("DATA statement at %L has more variables than values",
12414 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12418 /* If we have more than one element left in the repeat count,
12419 and we have more than one element left in the target variable,
12420 then create a range assignment. */
12421 /* FIXME: Only done for full arrays for now, since array sections
12423 if (mark == AR_FULL && ref && ref->next == NULL
12424 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12428 if (mpz_cmp (size, values.left) >= 0)
12430 mpz_init_set (range, values.left);
12431 mpz_sub (size, size, values.left);
12432 mpz_set_ui (values.left, 0);
12436 mpz_init_set (range, size);
12437 mpz_sub (values.left, values.left, size);
12438 mpz_set_ui (size, 0);
12441 t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
12444 mpz_add (offset, offset, range);
12451 /* Assign initial value to symbol. */
12454 mpz_sub_ui (values.left, values.left, 1);
12455 mpz_sub_ui (size, size, 1);
12457 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
12461 if (mark == AR_FULL)
12462 mpz_add_ui (offset, offset, 1);
12464 /* Modify the array section indexes and recalculate the offset
12465 for next element. */
12466 else if (mark == AR_SECTION)
12467 gfc_advance_section (section_index, ar, &offset);
12471 if (mark == AR_SECTION)
12473 for (i = 0; i < ar->dimen; i++)
12474 mpz_clear (section_index[i]);
12478 mpz_clear (offset);
12484 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
12486 /* Iterate over a list of elements in a DATA statement. */
12489 traverse_data_list (gfc_data_variable *var, locus *where)
12492 iterator_stack frame;
12493 gfc_expr *e, *start, *end, *step;
12494 gfc_try retval = SUCCESS;
12496 mpz_init (frame.value);
12499 start = gfc_copy_expr (var->iter.start);
12500 end = gfc_copy_expr (var->iter.end);
12501 step = gfc_copy_expr (var->iter.step);
12503 if (gfc_simplify_expr (start, 1) == FAILURE
12504 || start->expr_type != EXPR_CONSTANT)
12506 gfc_error ("start of implied-do loop at %L could not be "
12507 "simplified to a constant value", &start->where);
12511 if (gfc_simplify_expr (end, 1) == FAILURE
12512 || end->expr_type != EXPR_CONSTANT)
12514 gfc_error ("end of implied-do loop at %L could not be "
12515 "simplified to a constant value", &start->where);
12519 if (gfc_simplify_expr (step, 1) == FAILURE
12520 || step->expr_type != EXPR_CONSTANT)
12522 gfc_error ("step of implied-do loop at %L could not be "
12523 "simplified to a constant value", &start->where);
12528 mpz_set (trip, end->value.integer);
12529 mpz_sub (trip, trip, start->value.integer);
12530 mpz_add (trip, trip, step->value.integer);
12532 mpz_div (trip, trip, step->value.integer);
12534 mpz_set (frame.value, start->value.integer);
12536 frame.prev = iter_stack;
12537 frame.variable = var->iter.var->symtree;
12538 iter_stack = &frame;
12540 while (mpz_cmp_ui (trip, 0) > 0)
12542 if (traverse_data_var (var->list, where) == FAILURE)
12548 e = gfc_copy_expr (var->expr);
12549 if (gfc_simplify_expr (e, 1) == FAILURE)
12556 mpz_add (frame.value, frame.value, step->value.integer);
12558 mpz_sub_ui (trip, trip, 1);
12562 mpz_clear (frame.value);
12565 gfc_free_expr (start);
12566 gfc_free_expr (end);
12567 gfc_free_expr (step);
12569 iter_stack = frame.prev;
12574 /* Type resolve variables in the variable list of a DATA statement. */
12577 traverse_data_var (gfc_data_variable *var, locus *where)
12581 for (; var; var = var->next)
12583 if (var->expr == NULL)
12584 t = traverse_data_list (var, where);
12586 t = check_data_variable (var, where);
12596 /* Resolve the expressions and iterators associated with a data statement.
12597 This is separate from the assignment checking because data lists should
12598 only be resolved once. */
12601 resolve_data_variables (gfc_data_variable *d)
12603 for (; d; d = d->next)
12605 if (d->list == NULL)
12607 if (gfc_resolve_expr (d->expr) == FAILURE)
12612 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
12615 if (resolve_data_variables (d->list) == FAILURE)
12624 /* Resolve a single DATA statement. We implement this by storing a pointer to
12625 the value list into static variables, and then recursively traversing the
12626 variables list, expanding iterators and such. */
12629 resolve_data (gfc_data *d)
12632 if (resolve_data_variables (d->var) == FAILURE)
12635 values.vnode = d->value;
12636 if (d->value == NULL)
12637 mpz_set_ui (values.left, 0);
12639 mpz_set (values.left, d->value->repeat);
12641 if (traverse_data_var (d->var, &d->where) == FAILURE)
12644 /* At this point, we better not have any values left. */
12646 if (next_data_value () == SUCCESS)
12647 gfc_error ("DATA statement at %L has more values than variables",
12652 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
12653 accessed by host or use association, is a dummy argument to a pure function,
12654 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
12655 is storage associated with any such variable, shall not be used in the
12656 following contexts: (clients of this function). */
12658 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
12659 procedure. Returns zero if assignment is OK, nonzero if there is a
12662 gfc_impure_variable (gfc_symbol *sym)
12667 if (sym->attr.use_assoc || sym->attr.in_common)
12670 /* Check if the symbol's ns is inside the pure procedure. */
12671 for (ns = gfc_current_ns; ns; ns = ns->parent)
12675 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
12679 proc = sym->ns->proc_name;
12680 if (sym->attr.dummy && gfc_pure (proc)
12681 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
12683 proc->attr.function))
12686 /* TODO: Sort out what can be storage associated, if anything, and include
12687 it here. In principle equivalences should be scanned but it does not
12688 seem to be possible to storage associate an impure variable this way. */
12693 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
12694 current namespace is inside a pure procedure. */
12697 gfc_pure (gfc_symbol *sym)
12699 symbol_attribute attr;
12704 /* Check if the current namespace or one of its parents
12705 belongs to a pure procedure. */
12706 for (ns = gfc_current_ns; ns; ns = ns->parent)
12708 sym = ns->proc_name;
12712 if (attr.flavor == FL_PROCEDURE && attr.pure)
12720 return attr.flavor == FL_PROCEDURE && attr.pure;
12724 /* Test whether the current procedure is elemental or not. */
12727 gfc_elemental (gfc_symbol *sym)
12729 symbol_attribute attr;
12732 sym = gfc_current_ns->proc_name;
12737 return attr.flavor == FL_PROCEDURE && attr.elemental;
12741 /* Warn about unused labels. */
12744 warn_unused_fortran_label (gfc_st_label *label)
12749 warn_unused_fortran_label (label->left);
12751 if (label->defined == ST_LABEL_UNKNOWN)
12754 switch (label->referenced)
12756 case ST_LABEL_UNKNOWN:
12757 gfc_warning ("Label %d at %L defined but not used", label->value,
12761 case ST_LABEL_BAD_TARGET:
12762 gfc_warning ("Label %d at %L defined but cannot be used",
12763 label->value, &label->where);
12770 warn_unused_fortran_label (label->right);
12774 /* Returns the sequence type of a symbol or sequence. */
12777 sequence_type (gfc_typespec ts)
12786 if (ts.u.derived->components == NULL)
12787 return SEQ_NONDEFAULT;
12789 result = sequence_type (ts.u.derived->components->ts);
12790 for (c = ts.u.derived->components->next; c; c = c->next)
12791 if (sequence_type (c->ts) != result)
12797 if (ts.kind != gfc_default_character_kind)
12798 return SEQ_NONDEFAULT;
12800 return SEQ_CHARACTER;
12803 if (ts.kind != gfc_default_integer_kind)
12804 return SEQ_NONDEFAULT;
12806 return SEQ_NUMERIC;
12809 if (!(ts.kind == gfc_default_real_kind
12810 || ts.kind == gfc_default_double_kind))
12811 return SEQ_NONDEFAULT;
12813 return SEQ_NUMERIC;
12816 if (ts.kind != gfc_default_complex_kind)
12817 return SEQ_NONDEFAULT;
12819 return SEQ_NUMERIC;
12822 if (ts.kind != gfc_default_logical_kind)
12823 return SEQ_NONDEFAULT;
12825 return SEQ_NUMERIC;
12828 return SEQ_NONDEFAULT;
12833 /* Resolve derived type EQUIVALENCE object. */
12836 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
12838 gfc_component *c = derived->components;
12843 /* Shall not be an object of nonsequence derived type. */
12844 if (!derived->attr.sequence)
12846 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
12847 "attribute to be an EQUIVALENCE object", sym->name,
12852 /* Shall not have allocatable components. */
12853 if (derived->attr.alloc_comp)
12855 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
12856 "components to be an EQUIVALENCE object",sym->name,
12861 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
12863 gfc_error ("Derived type variable '%s' at %L with default "
12864 "initialization cannot be in EQUIVALENCE with a variable "
12865 "in COMMON", sym->name, &e->where);
12869 for (; c ; c = c->next)
12871 if (c->ts.type == BT_DERIVED
12872 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
12875 /* Shall not be an object of sequence derived type containing a pointer
12876 in the structure. */
12877 if (c->attr.pointer)
12879 gfc_error ("Derived type variable '%s' at %L with pointer "
12880 "component(s) cannot be an EQUIVALENCE object",
12881 sym->name, &e->where);
12889 /* Resolve equivalence object.
12890 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
12891 an allocatable array, an object of nonsequence derived type, an object of
12892 sequence derived type containing a pointer at any level of component
12893 selection, an automatic object, a function name, an entry name, a result
12894 name, a named constant, a structure component, or a subobject of any of
12895 the preceding objects. A substring shall not have length zero. A
12896 derived type shall not have components with default initialization nor
12897 shall two objects of an equivalence group be initialized.
12898 Either all or none of the objects shall have an protected attribute.
12899 The simple constraints are done in symbol.c(check_conflict) and the rest
12900 are implemented here. */
12903 resolve_equivalence (gfc_equiv *eq)
12906 gfc_symbol *first_sym;
12909 locus *last_where = NULL;
12910 seq_type eq_type, last_eq_type;
12911 gfc_typespec *last_ts;
12912 int object, cnt_protected;
12915 last_ts = &eq->expr->symtree->n.sym->ts;
12917 first_sym = eq->expr->symtree->n.sym;
12921 for (object = 1; eq; eq = eq->eq, object++)
12925 e->ts = e->symtree->n.sym->ts;
12926 /* match_varspec might not know yet if it is seeing
12927 array reference or substring reference, as it doesn't
12929 if (e->ref && e->ref->type == REF_ARRAY)
12931 gfc_ref *ref = e->ref;
12932 sym = e->symtree->n.sym;
12934 if (sym->attr.dimension)
12936 ref->u.ar.as = sym->as;
12940 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
12941 if (e->ts.type == BT_CHARACTER
12943 && ref->type == REF_ARRAY
12944 && ref->u.ar.dimen == 1
12945 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
12946 && ref->u.ar.stride[0] == NULL)
12948 gfc_expr *start = ref->u.ar.start[0];
12949 gfc_expr *end = ref->u.ar.end[0];
12952 /* Optimize away the (:) reference. */
12953 if (start == NULL && end == NULL)
12956 e->ref = ref->next;
12958 e->ref->next = ref->next;
12963 ref->type = REF_SUBSTRING;
12965 start = gfc_get_int_expr (gfc_default_integer_kind,
12967 ref->u.ss.start = start;
12968 if (end == NULL && e->ts.u.cl)
12969 end = gfc_copy_expr (e->ts.u.cl->length);
12970 ref->u.ss.end = end;
12971 ref->u.ss.length = e->ts.u.cl;
12978 /* Any further ref is an error. */
12981 gcc_assert (ref->type == REF_ARRAY);
12982 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
12988 if (gfc_resolve_expr (e) == FAILURE)
12991 sym = e->symtree->n.sym;
12993 if (sym->attr.is_protected)
12995 if (cnt_protected > 0 && cnt_protected != object)
12997 gfc_error ("Either all or none of the objects in the "
12998 "EQUIVALENCE set at %L shall have the "
12999 "PROTECTED attribute",
13004 /* Shall not equivalence common block variables in a PURE procedure. */
13005 if (sym->ns->proc_name
13006 && sym->ns->proc_name->attr.pure
13007 && sym->attr.in_common)
13009 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13010 "object in the pure procedure '%s'",
13011 sym->name, &e->where, sym->ns->proc_name->name);
13015 /* Shall not be a named constant. */
13016 if (e->expr_type == EXPR_CONSTANT)
13018 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13019 "object", sym->name, &e->where);
13023 if (e->ts.type == BT_DERIVED
13024 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
13027 /* Check that the types correspond correctly:
13029 A numeric sequence structure may be equivalenced to another sequence
13030 structure, an object of default integer type, default real type, double
13031 precision real type, default logical type such that components of the
13032 structure ultimately only become associated to objects of the same
13033 kind. A character sequence structure may be equivalenced to an object
13034 of default character kind or another character sequence structure.
13035 Other objects may be equivalenced only to objects of the same type and
13036 kind parameters. */
13038 /* Identical types are unconditionally OK. */
13039 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
13040 goto identical_types;
13042 last_eq_type = sequence_type (*last_ts);
13043 eq_type = sequence_type (sym->ts);
13045 /* Since the pair of objects is not of the same type, mixed or
13046 non-default sequences can be rejected. */
13048 msg = "Sequence %s with mixed components in EQUIVALENCE "
13049 "statement at %L with different type objects";
13051 && last_eq_type == SEQ_MIXED
13052 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
13054 || (eq_type == SEQ_MIXED
13055 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13056 &e->where) == FAILURE))
13059 msg = "Non-default type object or sequence %s in EQUIVALENCE "
13060 "statement at %L with objects of different type";
13062 && last_eq_type == SEQ_NONDEFAULT
13063 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
13064 last_where) == FAILURE)
13065 || (eq_type == SEQ_NONDEFAULT
13066 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13067 &e->where) == FAILURE))
13070 msg ="Non-CHARACTER object '%s' in default CHARACTER "
13071 "EQUIVALENCE statement at %L";
13072 if (last_eq_type == SEQ_CHARACTER
13073 && eq_type != SEQ_CHARACTER
13074 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13075 &e->where) == FAILURE)
13078 msg ="Non-NUMERIC object '%s' in default NUMERIC "
13079 "EQUIVALENCE statement at %L";
13080 if (last_eq_type == SEQ_NUMERIC
13081 && eq_type != SEQ_NUMERIC
13082 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13083 &e->where) == FAILURE)
13088 last_where = &e->where;
13093 /* Shall not be an automatic array. */
13094 if (e->ref->type == REF_ARRAY
13095 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
13097 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13098 "an EQUIVALENCE object", sym->name, &e->where);
13105 /* Shall not be a structure component. */
13106 if (r->type == REF_COMPONENT)
13108 gfc_error ("Structure component '%s' at %L cannot be an "
13109 "EQUIVALENCE object",
13110 r->u.c.component->name, &e->where);
13114 /* A substring shall not have length zero. */
13115 if (r->type == REF_SUBSTRING)
13117 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13119 gfc_error ("Substring at %L has length zero",
13120 &r->u.ss.start->where);
13130 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13133 resolve_fntype (gfc_namespace *ns)
13135 gfc_entry_list *el;
13138 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13141 /* If there are any entries, ns->proc_name is the entry master
13142 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13144 sym = ns->entries->sym;
13146 sym = ns->proc_name;
13147 if (sym->result == sym
13148 && sym->ts.type == BT_UNKNOWN
13149 && gfc_set_default_type (sym, 0, NULL) == FAILURE
13150 && !sym->attr.untyped)
13152 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13153 sym->name, &sym->declared_at);
13154 sym->attr.untyped = 1;
13157 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13158 && !sym->attr.contained
13159 && !gfc_check_access (sym->ts.u.derived->attr.access,
13160 sym->ts.u.derived->ns->default_access)
13161 && gfc_check_access (sym->attr.access, sym->ns->default_access))
13163 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13164 "%L of PRIVATE type '%s'", sym->name,
13165 &sym->declared_at, sym->ts.u.derived->name);
13169 for (el = ns->entries->next; el; el = el->next)
13171 if (el->sym->result == el->sym
13172 && el->sym->ts.type == BT_UNKNOWN
13173 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13174 && !el->sym->attr.untyped)
13176 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13177 el->sym->name, &el->sym->declared_at);
13178 el->sym->attr.untyped = 1;
13184 /* 12.3.2.1.1 Defined operators. */
13187 check_uop_procedure (gfc_symbol *sym, locus where)
13189 gfc_formal_arglist *formal;
13191 if (!sym->attr.function)
13193 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13194 sym->name, &where);
13198 if (sym->ts.type == BT_CHARACTER
13199 && !(sym->ts.u.cl && sym->ts.u.cl->length)
13200 && !(sym->result && sym->result->ts.u.cl
13201 && sym->result->ts.u.cl->length))
13203 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13204 "character length", sym->name, &where);
13208 formal = sym->formal;
13209 if (!formal || !formal->sym)
13211 gfc_error ("User operator procedure '%s' at %L must have at least "
13212 "one argument", sym->name, &where);
13216 if (formal->sym->attr.intent != INTENT_IN)
13218 gfc_error ("First argument of operator interface at %L must be "
13219 "INTENT(IN)", &where);
13223 if (formal->sym->attr.optional)
13225 gfc_error ("First argument of operator interface at %L cannot be "
13226 "optional", &where);
13230 formal = formal->next;
13231 if (!formal || !formal->sym)
13234 if (formal->sym->attr.intent != INTENT_IN)
13236 gfc_error ("Second argument of operator interface at %L must be "
13237 "INTENT(IN)", &where);
13241 if (formal->sym->attr.optional)
13243 gfc_error ("Second argument of operator interface at %L cannot be "
13244 "optional", &where);
13250 gfc_error ("Operator interface at %L must have, at most, two "
13251 "arguments", &where);
13259 gfc_resolve_uops (gfc_symtree *symtree)
13261 gfc_interface *itr;
13263 if (symtree == NULL)
13266 gfc_resolve_uops (symtree->left);
13267 gfc_resolve_uops (symtree->right);
13269 for (itr = symtree->n.uop->op; itr; itr = itr->next)
13270 check_uop_procedure (itr->sym, itr->sym->declared_at);
13274 /* Examine all of the expressions associated with a program unit,
13275 assign types to all intermediate expressions, make sure that all
13276 assignments are to compatible types and figure out which names
13277 refer to which functions or subroutines. It doesn't check code
13278 block, which is handled by resolve_code. */
13281 resolve_types (gfc_namespace *ns)
13287 gfc_namespace* old_ns = gfc_current_ns;
13289 /* Check that all IMPLICIT types are ok. */
13290 if (!ns->seen_implicit_none)
13293 for (letter = 0; letter != GFC_LETTERS; ++letter)
13294 if (ns->set_flag[letter]
13295 && resolve_typespec_used (&ns->default_type[letter],
13296 &ns->implicit_loc[letter],
13301 gfc_current_ns = ns;
13303 resolve_entries (ns);
13305 resolve_common_vars (ns->blank_common.head, false);
13306 resolve_common_blocks (ns->common_root);
13308 resolve_contained_functions (ns);
13310 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13312 for (cl = ns->cl_list; cl; cl = cl->next)
13313 resolve_charlen (cl);
13315 gfc_traverse_ns (ns, resolve_symbol);
13317 resolve_fntype (ns);
13319 for (n = ns->contained; n; n = n->sibling)
13321 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13322 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13323 "also be PURE", n->proc_name->name,
13324 &n->proc_name->declared_at);
13330 gfc_check_interfaces (ns);
13332 gfc_traverse_ns (ns, resolve_values);
13338 for (d = ns->data; d; d = d->next)
13342 gfc_traverse_ns (ns, gfc_formalize_init_value);
13344 gfc_traverse_ns (ns, gfc_verify_binding_labels);
13346 if (ns->common_root != NULL)
13347 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13349 for (eq = ns->equiv; eq; eq = eq->next)
13350 resolve_equivalence (eq);
13352 /* Warn about unused labels. */
13353 if (warn_unused_label)
13354 warn_unused_fortran_label (ns->st_labels);
13356 gfc_resolve_uops (ns->uop_root);
13358 gfc_current_ns = old_ns;
13362 /* Call resolve_code recursively. */
13365 resolve_codes (gfc_namespace *ns)
13368 bitmap_obstack old_obstack;
13370 if (ns->resolved == 1)
13373 for (n = ns->contained; n; n = n->sibling)
13376 gfc_current_ns = ns;
13378 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13379 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13382 /* Set to an out of range value. */
13383 current_entry_id = -1;
13385 old_obstack = labels_obstack;
13386 bitmap_obstack_initialize (&labels_obstack);
13388 resolve_code (ns->code, ns);
13390 bitmap_obstack_release (&labels_obstack);
13391 labels_obstack = old_obstack;
13395 /* This function is called after a complete program unit has been compiled.
13396 Its purpose is to examine all of the expressions associated with a program
13397 unit, assign types to all intermediate expressions, make sure that all
13398 assignments are to compatible types and figure out which names refer to
13399 which functions or subroutines. */
13402 gfc_resolve (gfc_namespace *ns)
13404 gfc_namespace *old_ns;
13405 code_stack *old_cs_base;
13411 old_ns = gfc_current_ns;
13412 old_cs_base = cs_base;
13414 resolve_types (ns);
13415 resolve_codes (ns);
13417 gfc_current_ns = old_ns;
13418 cs_base = old_cs_base;
13421 gfc_run_passes (ns);