1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 #include "target-memory.h" /* for gfc_simplify_transfer */
32 #include "constructor.h"
34 /* Types used in equivalence statements. */
38 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
42 /* Stack to keep track of the nesting of blocks as we move through the
43 code. See resolve_branch() and resolve_code(). */
45 typedef struct code_stack
47 struct gfc_code *head, *current;
48 struct code_stack *prev;
50 /* This bitmap keeps track of the targets valid for a branch from
51 inside this block except for END {IF|SELECT}s of enclosing
53 bitmap reachable_labels;
57 static code_stack *cs_base = NULL;
60 /* Nonzero if we're inside a FORALL block. */
62 static int forall_flag;
64 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
66 static int omp_workshare_flag;
68 /* Nonzero if we are processing a formal arglist. The corresponding function
69 resets the flag each time that it is read. */
70 static int formal_arg_flag = 0;
72 /* True if we are resolving a specification expression. */
73 static int specification_expr = 0;
75 /* The id of the last entry seen. */
76 static int current_entry_id;
78 /* We use bitmaps to determine if a branch target is valid. */
79 static bitmap_obstack labels_obstack;
81 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
82 static bool inquiry_argument = false;
85 gfc_is_formal_arg (void)
87 return formal_arg_flag;
90 /* Is the symbol host associated? */
92 is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
94 for (ns = ns->parent; ns; ns = ns->parent)
103 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
104 an ABSTRACT derived-type. If where is not NULL, an error message with that
105 locus is printed, optionally using name. */
108 resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
110 if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
115 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
116 name, where, ts->u.derived->name);
118 gfc_error ("ABSTRACT type '%s' used at %L",
119 ts->u.derived->name, where);
129 static void resolve_symbol (gfc_symbol *sym);
130 static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc);
133 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
136 resolve_procedure_interface (gfc_symbol *sym)
138 if (sym->ts.interface == sym)
140 gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
141 sym->name, &sym->declared_at);
144 if (sym->ts.interface->attr.procedure)
146 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
147 "in a later PROCEDURE statement", sym->ts.interface->name,
148 sym->name, &sym->declared_at);
152 /* Get the attributes from the interface (now resolved). */
153 if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
155 gfc_symbol *ifc = sym->ts.interface;
156 resolve_symbol (ifc);
158 if (ifc->attr.intrinsic)
159 resolve_intrinsic (ifc, &ifc->declared_at);
162 sym->ts = ifc->result->ts;
165 sym->ts.interface = ifc;
166 sym->attr.function = ifc->attr.function;
167 sym->attr.subroutine = ifc->attr.subroutine;
168 gfc_copy_formal_args (sym, ifc);
170 sym->attr.allocatable = ifc->attr.allocatable;
171 sym->attr.pointer = ifc->attr.pointer;
172 sym->attr.pure = ifc->attr.pure;
173 sym->attr.elemental = ifc->attr.elemental;
174 sym->attr.dimension = ifc->attr.dimension;
175 sym->attr.contiguous = ifc->attr.contiguous;
176 sym->attr.recursive = ifc->attr.recursive;
177 sym->attr.always_explicit = ifc->attr.always_explicit;
178 sym->attr.ext_attr |= ifc->attr.ext_attr;
179 /* Copy array spec. */
180 sym->as = gfc_copy_array_spec (ifc->as);
184 for (i = 0; i < sym->as->rank; i++)
186 gfc_expr_replace_symbols (sym->as->lower[i], sym);
187 gfc_expr_replace_symbols (sym->as->upper[i], sym);
190 /* Copy char length. */
191 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
193 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
194 gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
195 if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
196 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
200 else if (sym->ts.interface->name[0] != '\0')
202 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
203 sym->ts.interface->name, sym->name, &sym->declared_at);
211 /* Resolve types of formal argument lists. These have to be done early so that
212 the formal argument lists of module procedures can be copied to the
213 containing module before the individual procedures are resolved
214 individually. We also resolve argument lists of procedures in interface
215 blocks because they are self-contained scoping units.
217 Since a dummy argument cannot be a non-dummy procedure, the only
218 resort left for untyped names are the IMPLICIT types. */
221 resolve_formal_arglist (gfc_symbol *proc)
223 gfc_formal_arglist *f;
227 if (proc->result != NULL)
232 if (gfc_elemental (proc)
233 || sym->attr.pointer || sym->attr.allocatable
234 || (sym->as && sym->as->rank > 0))
236 proc->attr.always_explicit = 1;
237 sym->attr.always_explicit = 1;
242 for (f = proc->formal; f; f = f->next)
248 /* Alternate return placeholder. */
249 if (gfc_elemental (proc))
250 gfc_error ("Alternate return specifier in elemental subroutine "
251 "'%s' at %L is not allowed", proc->name,
253 if (proc->attr.function)
254 gfc_error ("Alternate return specifier in function "
255 "'%s' at %L is not allowed", proc->name,
259 else if (sym->attr.procedure && sym->ts.interface
260 && sym->attr.if_source != IFSRC_DECL)
261 resolve_procedure_interface (sym);
263 if (sym->attr.if_source != IFSRC_UNKNOWN)
264 resolve_formal_arglist (sym);
266 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
268 if (gfc_pure (proc) && !gfc_pure (sym))
270 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
271 "also be PURE", sym->name, &sym->declared_at);
275 if (gfc_elemental (proc))
277 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
278 "procedure", &sym->declared_at);
282 if (sym->attr.function
283 && sym->ts.type == BT_UNKNOWN
284 && sym->attr.intrinsic)
286 gfc_intrinsic_sym *isym;
287 isym = gfc_find_function (sym->name);
288 if (isym == NULL || !isym->specific)
290 gfc_error ("Unable to find a specific INTRINSIC procedure "
291 "for the reference '%s' at %L", sym->name,
300 if (sym->ts.type == BT_UNKNOWN)
302 if (!sym->attr.function || sym->result == sym)
303 gfc_set_default_type (sym, 1, sym->ns);
306 gfc_resolve_array_spec (sym->as, 0);
308 /* We can't tell if an array with dimension (:) is assumed or deferred
309 shape until we know if it has the pointer or allocatable attributes.
311 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
312 && !(sym->attr.pointer || sym->attr.allocatable))
314 sym->as->type = AS_ASSUMED_SHAPE;
315 for (i = 0; i < sym->as->rank; i++)
316 sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
320 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
321 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
322 || sym->attr.optional)
324 proc->attr.always_explicit = 1;
326 proc->result->attr.always_explicit = 1;
329 /* If the flavor is unknown at this point, it has to be a variable.
330 A procedure specification would have already set the type. */
332 if (sym->attr.flavor == FL_UNKNOWN)
333 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
335 if (gfc_pure (proc) && !sym->attr.pointer
336 && sym->attr.flavor != FL_PROCEDURE)
338 if (proc->attr.function && sym->attr.intent != INTENT_IN)
339 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
340 "INTENT(IN)", sym->name, proc->name,
343 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
344 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
345 "have its INTENT specified", sym->name, proc->name,
349 if (gfc_elemental (proc))
352 if (sym->attr.codimension)
354 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
355 "procedure", sym->name, &sym->declared_at);
361 gfc_error ("Argument '%s' of elemental procedure at %L must "
362 "be scalar", sym->name, &sym->declared_at);
366 if (sym->attr.allocatable)
368 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
369 "have the ALLOCATABLE attribute", sym->name,
374 if (sym->attr.pointer)
376 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
377 "have the POINTER attribute", sym->name,
382 if (sym->attr.flavor == FL_PROCEDURE)
384 gfc_error ("Dummy procedure '%s' not allowed in elemental "
385 "procedure '%s' at %L", sym->name, proc->name,
390 if (sym->attr.intent == INTENT_UNKNOWN)
392 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
393 "have its INTENT specified", sym->name, proc->name,
399 /* Each dummy shall be specified to be scalar. */
400 if (proc->attr.proc == PROC_ST_FUNCTION)
404 gfc_error ("Argument '%s' of statement function at %L must "
405 "be scalar", sym->name, &sym->declared_at);
409 if (sym->ts.type == BT_CHARACTER)
411 gfc_charlen *cl = sym->ts.u.cl;
412 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
414 gfc_error ("Character-valued argument '%s' of statement "
415 "function at %L must have constant length",
416 sym->name, &sym->declared_at);
426 /* Work function called when searching for symbols that have argument lists
427 associated with them. */
430 find_arglists (gfc_symbol *sym)
432 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
435 resolve_formal_arglist (sym);
439 /* Given a namespace, resolve all formal argument lists within the namespace.
443 resolve_formal_arglists (gfc_namespace *ns)
448 gfc_traverse_ns (ns, find_arglists);
453 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
457 /* If this namespace is not a function or an entry master function,
459 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
460 || sym->attr.entry_master)
463 /* Try to find out of what the return type is. */
464 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
466 t = gfc_set_default_type (sym->result, 0, ns);
468 if (t == FAILURE && !sym->result->attr.untyped)
470 if (sym->result == sym)
471 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
472 sym->name, &sym->declared_at);
473 else if (!sym->result->attr.proc_pointer)
474 gfc_error ("Result '%s' of contained function '%s' at %L has "
475 "no IMPLICIT type", sym->result->name, sym->name,
476 &sym->result->declared_at);
477 sym->result->attr.untyped = 1;
481 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
482 type, lists the only ways a character length value of * can be used:
483 dummy arguments of procedures, named constants, and function results
484 in external functions. Internal function results and results of module
485 procedures are not on this list, ergo, not permitted. */
487 if (sym->result->ts.type == BT_CHARACTER)
489 gfc_charlen *cl = sym->result->ts.u.cl;
490 if (!cl || !cl->length)
492 /* See if this is a module-procedure and adapt error message
495 gcc_assert (ns->parent && ns->parent->proc_name);
496 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
498 gfc_error ("Character-valued %s '%s' at %L must not be"
500 module_proc ? _("module procedure")
501 : _("internal function"),
502 sym->name, &sym->declared_at);
508 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
509 introduce duplicates. */
512 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
514 gfc_formal_arglist *f, *new_arglist;
517 for (; new_args != NULL; new_args = new_args->next)
519 new_sym = new_args->sym;
520 /* See if this arg is already in the formal argument list. */
521 for (f = proc->formal; f; f = f->next)
523 if (new_sym == f->sym)
530 /* Add a new argument. Argument order is not important. */
531 new_arglist = gfc_get_formal_arglist ();
532 new_arglist->sym = new_sym;
533 new_arglist->next = proc->formal;
534 proc->formal = new_arglist;
539 /* Flag the arguments that are not present in all entries. */
542 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
544 gfc_formal_arglist *f, *head;
547 for (f = proc->formal; f; f = f->next)
552 for (new_args = head; new_args; new_args = new_args->next)
554 if (new_args->sym == f->sym)
561 f->sym->attr.not_always_present = 1;
566 /* Resolve alternate entry points. If a symbol has multiple entry points we
567 create a new master symbol for the main routine, and turn the existing
568 symbol into an entry point. */
571 resolve_entries (gfc_namespace *ns)
573 gfc_namespace *old_ns;
577 char name[GFC_MAX_SYMBOL_LEN + 1];
578 static int master_count = 0;
580 if (ns->proc_name == NULL)
583 /* No need to do anything if this procedure doesn't have alternate entry
588 /* We may already have resolved alternate entry points. */
589 if (ns->proc_name->attr.entry_master)
592 /* If this isn't a procedure something has gone horribly wrong. */
593 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
595 /* Remember the current namespace. */
596 old_ns = gfc_current_ns;
600 /* Add the main entry point to the list of entry points. */
601 el = gfc_get_entry_list ();
602 el->sym = ns->proc_name;
604 el->next = ns->entries;
606 ns->proc_name->attr.entry = 1;
608 /* If it is a module function, it needs to be in the right namespace
609 so that gfc_get_fake_result_decl can gather up the results. The
610 need for this arose in get_proc_name, where these beasts were
611 left in their own namespace, to keep prior references linked to
612 the entry declaration.*/
613 if (ns->proc_name->attr.function
614 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
617 /* Do the same for entries where the master is not a module
618 procedure. These are retained in the module namespace because
619 of the module procedure declaration. */
620 for (el = el->next; el; el = el->next)
621 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
622 && el->sym->attr.mod_proc)
626 /* Add an entry statement for it. */
633 /* Create a new symbol for the master function. */
634 /* Give the internal function a unique name (within this file).
635 Also include the function name so the user has some hope of figuring
636 out what is going on. */
637 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
638 master_count++, ns->proc_name->name);
639 gfc_get_ha_symbol (name, &proc);
640 gcc_assert (proc != NULL);
642 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
643 if (ns->proc_name->attr.subroutine)
644 gfc_add_subroutine (&proc->attr, proc->name, NULL);
648 gfc_typespec *ts, *fts;
649 gfc_array_spec *as, *fas;
650 gfc_add_function (&proc->attr, proc->name, NULL);
652 fas = ns->entries->sym->as;
653 fas = fas ? fas : ns->entries->sym->result->as;
654 fts = &ns->entries->sym->result->ts;
655 if (fts->type == BT_UNKNOWN)
656 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
657 for (el = ns->entries->next; el; el = el->next)
659 ts = &el->sym->result->ts;
661 as = as ? as : el->sym->result->as;
662 if (ts->type == BT_UNKNOWN)
663 ts = gfc_get_default_type (el->sym->result->name, NULL);
665 if (! gfc_compare_types (ts, fts)
666 || (el->sym->result->attr.dimension
667 != ns->entries->sym->result->attr.dimension)
668 || (el->sym->result->attr.pointer
669 != ns->entries->sym->result->attr.pointer))
671 else if (as && fas && ns->entries->sym->result != el->sym->result
672 && gfc_compare_array_spec (as, fas) == 0)
673 gfc_error ("Function %s at %L has entries with mismatched "
674 "array specifications", ns->entries->sym->name,
675 &ns->entries->sym->declared_at);
676 /* The characteristics need to match and thus both need to have
677 the same string length, i.e. both len=*, or both len=4.
678 Having both len=<variable> is also possible, but difficult to
679 check at compile time. */
680 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
681 && (((ts->u.cl->length && !fts->u.cl->length)
682 ||(!ts->u.cl->length && fts->u.cl->length))
684 && ts->u.cl->length->expr_type
685 != fts->u.cl->length->expr_type)
687 && ts->u.cl->length->expr_type == EXPR_CONSTANT
688 && mpz_cmp (ts->u.cl->length->value.integer,
689 fts->u.cl->length->value.integer) != 0)))
690 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
691 "entries returning variables of different "
692 "string lengths", ns->entries->sym->name,
693 &ns->entries->sym->declared_at);
698 sym = ns->entries->sym->result;
699 /* All result types the same. */
701 if (sym->attr.dimension)
702 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
703 if (sym->attr.pointer)
704 gfc_add_pointer (&proc->attr, NULL);
708 /* Otherwise the result will be passed through a union by
710 proc->attr.mixed_entry_master = 1;
711 for (el = ns->entries; el; el = el->next)
713 sym = el->sym->result;
714 if (sym->attr.dimension)
716 if (el == ns->entries)
717 gfc_error ("FUNCTION result %s can't be an array in "
718 "FUNCTION %s at %L", sym->name,
719 ns->entries->sym->name, &sym->declared_at);
721 gfc_error ("ENTRY result %s can't be an array in "
722 "FUNCTION %s at %L", sym->name,
723 ns->entries->sym->name, &sym->declared_at);
725 else if (sym->attr.pointer)
727 if (el == ns->entries)
728 gfc_error ("FUNCTION result %s can't be a POINTER in "
729 "FUNCTION %s at %L", sym->name,
730 ns->entries->sym->name, &sym->declared_at);
732 gfc_error ("ENTRY result %s can't be a POINTER in "
733 "FUNCTION %s at %L", sym->name,
734 ns->entries->sym->name, &sym->declared_at);
739 if (ts->type == BT_UNKNOWN)
740 ts = gfc_get_default_type (sym->name, NULL);
744 if (ts->kind == gfc_default_integer_kind)
748 if (ts->kind == gfc_default_real_kind
749 || ts->kind == gfc_default_double_kind)
753 if (ts->kind == gfc_default_complex_kind)
757 if (ts->kind == gfc_default_logical_kind)
761 /* We will issue error elsewhere. */
769 if (el == ns->entries)
770 gfc_error ("FUNCTION result %s can't be of type %s "
771 "in FUNCTION %s at %L", sym->name,
772 gfc_typename (ts), ns->entries->sym->name,
775 gfc_error ("ENTRY result %s can't be of type %s "
776 "in FUNCTION %s at %L", sym->name,
777 gfc_typename (ts), ns->entries->sym->name,
784 proc->attr.access = ACCESS_PRIVATE;
785 proc->attr.entry_master = 1;
787 /* Merge all the entry point arguments. */
788 for (el = ns->entries; el; el = el->next)
789 merge_argument_lists (proc, el->sym->formal);
791 /* Check the master formal arguments for any that are not
792 present in all entry points. */
793 for (el = ns->entries; el; el = el->next)
794 check_argument_lists (proc, el->sym->formal);
796 /* Use the master function for the function body. */
797 ns->proc_name = proc;
799 /* Finalize the new symbols. */
800 gfc_commit_symbols ();
802 /* Restore the original namespace. */
803 gfc_current_ns = old_ns;
807 /* Resolve common variables. */
809 resolve_common_vars (gfc_symbol *sym, bool named_common)
811 gfc_symbol *csym = sym;
813 for (; csym; csym = csym->common_next)
815 if (csym->value || csym->attr.data)
817 if (!csym->ns->is_block_data)
818 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
819 "but only in BLOCK DATA initialization is "
820 "allowed", csym->name, &csym->declared_at);
821 else if (!named_common)
822 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
823 "in a blank COMMON but initialization is only "
824 "allowed in named common blocks", csym->name,
828 if (csym->ts.type != BT_DERIVED)
831 if (!(csym->ts.u.derived->attr.sequence
832 || csym->ts.u.derived->attr.is_bind_c))
833 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
834 "has neither the SEQUENCE nor the BIND(C) "
835 "attribute", csym->name, &csym->declared_at);
836 if (csym->ts.u.derived->attr.alloc_comp)
837 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
838 "has an ultimate component that is "
839 "allocatable", csym->name, &csym->declared_at);
840 if (gfc_has_default_initializer (csym->ts.u.derived))
841 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
842 "may not have default initializer", csym->name,
845 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
846 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
850 /* Resolve common blocks. */
852 resolve_common_blocks (gfc_symtree *common_root)
856 if (common_root == NULL)
859 if (common_root->left)
860 resolve_common_blocks (common_root->left);
861 if (common_root->right)
862 resolve_common_blocks (common_root->right);
864 resolve_common_vars (common_root->n.common->head, true);
866 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
870 if (sym->attr.flavor == FL_PARAMETER)
871 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
872 sym->name, &common_root->n.common->where, &sym->declared_at);
874 if (sym->attr.intrinsic)
875 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
876 sym->name, &common_root->n.common->where);
877 else if (sym->attr.result
878 || gfc_is_function_return_value (sym, gfc_current_ns))
879 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
880 "that is also a function result", sym->name,
881 &common_root->n.common->where);
882 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
883 && sym->attr.proc != PROC_ST_FUNCTION)
884 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
885 "that is also a global procedure", sym->name,
886 &common_root->n.common->where);
890 /* Resolve contained function types. Because contained functions can call one
891 another, they have to be worked out before any of the contained procedures
894 The good news is that if a function doesn't already have a type, the only
895 way it can get one is through an IMPLICIT type or a RESULT variable, because
896 by definition contained functions are contained namespace they're contained
897 in, not in a sibling or parent namespace. */
900 resolve_contained_functions (gfc_namespace *ns)
902 gfc_namespace *child;
905 resolve_formal_arglists (ns);
907 for (child = ns->contained; child; child = child->sibling)
909 /* Resolve alternate entry points first. */
910 resolve_entries (child);
912 /* Then check function return types. */
913 resolve_contained_fntype (child->proc_name, child);
914 for (el = child->entries; el; el = el->next)
915 resolve_contained_fntype (el->sym, child);
920 /* Resolve all of the elements of a structure constructor and make sure that
921 the types are correct. The 'init' flag indicates that the given
922 constructor is an initializer. */
925 resolve_structure_cons (gfc_expr *expr, int init)
927 gfc_constructor *cons;
934 if (expr->ts.type == BT_DERIVED)
935 resolve_symbol (expr->ts.u.derived);
937 cons = gfc_constructor_first (expr->value.constructor);
938 /* A constructor may have references if it is the result of substituting a
939 parameter variable. In this case we just pull out the component we
942 comp = expr->ref->u.c.sym->components;
944 comp = expr->ts.u.derived->components;
946 /* See if the user is trying to invoke a structure constructor for one of
947 the iso_c_binding derived types. */
948 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
949 && expr->ts.u.derived->ts.is_iso_c && cons
950 && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
952 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
953 expr->ts.u.derived->name, &(expr->where));
957 /* Return if structure constructor is c_null_(fun)prt. */
958 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
959 && expr->ts.u.derived->ts.is_iso_c && cons
960 && cons->expr && cons->expr->expr_type == EXPR_NULL)
963 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
970 if (gfc_resolve_expr (cons->expr) == FAILURE)
976 rank = comp->as ? comp->as->rank : 0;
977 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
978 && (comp->attr.allocatable || cons->expr->rank))
980 gfc_error ("The rank of the element in the derived type "
981 "constructor at %L does not match that of the "
982 "component (%d/%d)", &cons->expr->where,
983 cons->expr->rank, rank);
987 /* If we don't have the right type, try to convert it. */
989 if (!comp->attr.proc_pointer &&
990 !gfc_compare_types (&cons->expr->ts, &comp->ts))
993 if (strcmp (comp->name, "$extends") == 0)
995 /* Can afford to be brutal with the $extends initializer.
996 The derived type can get lost because it is PRIVATE
997 but it is not usage constrained by the standard. */
998 cons->expr->ts = comp->ts;
1001 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1002 gfc_error ("The element in the derived type constructor at %L, "
1003 "for pointer component '%s', is %s but should be %s",
1004 &cons->expr->where, comp->name,
1005 gfc_basic_typename (cons->expr->ts.type),
1006 gfc_basic_typename (comp->ts.type));
1008 t = gfc_convert_type (cons->expr, &comp->ts, 1);
1011 /* For strings, the length of the constructor should be the same as
1012 the one of the structure, ensure this if the lengths are known at
1013 compile time and when we are dealing with PARAMETER or structure
1015 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1016 && comp->ts.u.cl->length
1017 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1018 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1019 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1020 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1021 comp->ts.u.cl->length->value.integer) != 0)
1023 if (cons->expr->expr_type == EXPR_VARIABLE
1024 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1026 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1027 to make use of the gfc_resolve_character_array_constructor
1028 machinery. The expression is later simplified away to
1029 an array of string literals. */
1030 gfc_expr *para = cons->expr;
1031 cons->expr = gfc_get_expr ();
1032 cons->expr->ts = para->ts;
1033 cons->expr->where = para->where;
1034 cons->expr->expr_type = EXPR_ARRAY;
1035 cons->expr->rank = para->rank;
1036 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1037 gfc_constructor_append_expr (&cons->expr->value.constructor,
1038 para, &cons->expr->where);
1040 if (cons->expr->expr_type == EXPR_ARRAY)
1043 p = gfc_constructor_first (cons->expr->value.constructor);
1044 if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
1046 gfc_charlen *cl, *cl2;
1049 for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
1051 if (cl == cons->expr->ts.u.cl)
1059 cl2->next = cl->next;
1061 gfc_free_expr (cl->length);
1065 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1066 cons->expr->ts.u.cl->length_from_typespec = true;
1067 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1068 gfc_resolve_character_array_constructor (cons->expr);
1072 if (cons->expr->expr_type == EXPR_NULL
1073 && !(comp->attr.pointer || comp->attr.allocatable
1074 || comp->attr.proc_pointer
1075 || (comp->ts.type == BT_CLASS
1076 && (CLASS_DATA (comp)->attr.class_pointer
1077 || CLASS_DATA (comp)->attr.allocatable))))
1080 gfc_error ("The NULL in the derived type constructor at %L is "
1081 "being applied to component '%s', which is neither "
1082 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1086 if (!comp->attr.pointer || comp->attr.proc_pointer
1087 || cons->expr->expr_type == EXPR_NULL)
1090 a = gfc_expr_attr (cons->expr);
1092 if (!a.pointer && !a.target)
1095 gfc_error ("The element in the derived type constructor at %L, "
1096 "for pointer component '%s' should be a POINTER or "
1097 "a TARGET", &cons->expr->where, comp->name);
1102 /* F08:C461. Additional checks for pointer initialization. */
1106 gfc_error ("Pointer initialization target at %L "
1107 "must not be ALLOCATABLE ", &cons->expr->where);
1112 gfc_error ("Pointer initialization target at %L "
1113 "must have the SAVE attribute", &cons->expr->where);
1117 /* F2003, C1272 (3). */
1118 if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
1119 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1120 || gfc_is_coindexed (cons->expr)))
1123 gfc_error ("Invalid expression in the derived type constructor for "
1124 "pointer component '%s' at %L in PURE procedure",
1125 comp->name, &cons->expr->where);
1134 /****************** Expression name resolution ******************/
1136 /* Returns 0 if a symbol was not declared with a type or
1137 attribute declaration statement, nonzero otherwise. */
1140 was_declared (gfc_symbol *sym)
1146 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1149 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1150 || a.optional || a.pointer || a.save || a.target || a.volatile_
1151 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1152 || a.asynchronous || a.codimension)
1159 /* Determine if a symbol is generic or not. */
1162 generic_sym (gfc_symbol *sym)
1166 if (sym->attr.generic ||
1167 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1170 if (was_declared (sym) || sym->ns->parent == NULL)
1173 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1180 return generic_sym (s);
1187 /* Determine if a symbol is specific or not. */
1190 specific_sym (gfc_symbol *sym)
1194 if (sym->attr.if_source == IFSRC_IFBODY
1195 || sym->attr.proc == PROC_MODULE
1196 || sym->attr.proc == PROC_INTERNAL
1197 || sym->attr.proc == PROC_ST_FUNCTION
1198 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1199 || sym->attr.external)
1202 if (was_declared (sym) || sym->ns->parent == NULL)
1205 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1207 return (s == NULL) ? 0 : specific_sym (s);
1211 /* Figure out if the procedure is specific, generic or unknown. */
1214 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1218 procedure_kind (gfc_symbol *sym)
1220 if (generic_sym (sym))
1221 return PTYPE_GENERIC;
1223 if (specific_sym (sym))
1224 return PTYPE_SPECIFIC;
1226 return PTYPE_UNKNOWN;
1229 /* Check references to assumed size arrays. The flag need_full_assumed_size
1230 is nonzero when matching actual arguments. */
1232 static int need_full_assumed_size = 0;
1235 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1237 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1240 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1241 What should it be? */
1242 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1243 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1244 && (e->ref->u.ar.type == AR_FULL))
1246 gfc_error ("The upper bound in the last dimension must "
1247 "appear in the reference to the assumed size "
1248 "array '%s' at %L", sym->name, &e->where);
1255 /* Look for bad assumed size array references in argument expressions
1256 of elemental and array valued intrinsic procedures. Since this is
1257 called from procedure resolution functions, it only recurses at
1261 resolve_assumed_size_actual (gfc_expr *e)
1266 switch (e->expr_type)
1269 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1274 if (resolve_assumed_size_actual (e->value.op.op1)
1275 || resolve_assumed_size_actual (e->value.op.op2))
1286 /* Check a generic procedure, passed as an actual argument, to see if
1287 there is a matching specific name. If none, it is an error, and if
1288 more than one, the reference is ambiguous. */
1290 count_specific_procs (gfc_expr *e)
1297 sym = e->symtree->n.sym;
1299 for (p = sym->generic; p; p = p->next)
1300 if (strcmp (sym->name, p->sym->name) == 0)
1302 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1308 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1312 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1313 "argument at %L", sym->name, &e->where);
1319 /* See if a call to sym could possibly be a not allowed RECURSION because of
1320 a missing RECURIVE declaration. This means that either sym is the current
1321 context itself, or sym is the parent of a contained procedure calling its
1322 non-RECURSIVE containing procedure.
1323 This also works if sym is an ENTRY. */
1326 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1328 gfc_symbol* proc_sym;
1329 gfc_symbol* context_proc;
1330 gfc_namespace* real_context;
1332 if (sym->attr.flavor == FL_PROGRAM)
1335 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1337 /* If we've got an ENTRY, find real procedure. */
1338 if (sym->attr.entry && sym->ns->entries)
1339 proc_sym = sym->ns->entries->sym;
1343 /* If sym is RECURSIVE, all is well of course. */
1344 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1347 /* Find the context procedure's "real" symbol if it has entries.
1348 We look for a procedure symbol, so recurse on the parents if we don't
1349 find one (like in case of a BLOCK construct). */
1350 for (real_context = context; ; real_context = real_context->parent)
1352 /* We should find something, eventually! */
1353 gcc_assert (real_context);
1355 context_proc = (real_context->entries ? real_context->entries->sym
1356 : real_context->proc_name);
1358 /* In some special cases, there may not be a proc_name, like for this
1360 real(bad_kind()) function foo () ...
1361 when checking the call to bad_kind ().
1362 In these cases, we simply return here and assume that the
1367 if (context_proc->attr.flavor != FL_LABEL)
1371 /* A call from sym's body to itself is recursion, of course. */
1372 if (context_proc == proc_sym)
1375 /* The same is true if context is a contained procedure and sym the
1377 if (context_proc->attr.contained)
1379 gfc_symbol* parent_proc;
1381 gcc_assert (context->parent);
1382 parent_proc = (context->parent->entries ? context->parent->entries->sym
1383 : context->parent->proc_name);
1385 if (parent_proc == proc_sym)
1393 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1394 its typespec and formal argument list. */
1397 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1399 gfc_intrinsic_sym* isym = NULL;
1405 /* We already know this one is an intrinsic, so we don't call
1406 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1407 gfc_find_subroutine directly to check whether it is a function or
1410 if (sym->intmod_sym_id)
1411 isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
1413 isym = gfc_find_function (sym->name);
1417 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1418 && !sym->attr.implicit_type)
1419 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1420 " ignored", sym->name, &sym->declared_at);
1422 if (!sym->attr.function &&
1423 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1428 else if ((isym = gfc_find_subroutine (sym->name)))
1430 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1432 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1433 " specifier", sym->name, &sym->declared_at);
1437 if (!sym->attr.subroutine &&
1438 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1443 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1448 gfc_copy_formal_args_intr (sym, isym);
1450 /* Check it is actually available in the standard settings. */
1451 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1454 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1455 " available in the current standard settings but %s. Use"
1456 " an appropriate -std=* option or enable -fall-intrinsics"
1457 " in order to use it.",
1458 sym->name, &sym->declared_at, symstd);
1466 /* Resolve a procedure expression, like passing it to a called procedure or as
1467 RHS for a procedure pointer assignment. */
1470 resolve_procedure_expression (gfc_expr* expr)
1474 if (expr->expr_type != EXPR_VARIABLE)
1476 gcc_assert (expr->symtree);
1478 sym = expr->symtree->n.sym;
1480 if (sym->attr.intrinsic)
1481 resolve_intrinsic (sym, &expr->where);
1483 if (sym->attr.flavor != FL_PROCEDURE
1484 || (sym->attr.function && sym->result == sym))
1487 /* A non-RECURSIVE procedure that is used as procedure expression within its
1488 own body is in danger of being called recursively. */
1489 if (is_illegal_recursion (sym, gfc_current_ns))
1490 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1491 " itself recursively. Declare it RECURSIVE or use"
1492 " -frecursive", sym->name, &expr->where);
1498 /* Resolve an actual argument list. Most of the time, this is just
1499 resolving the expressions in the list.
1500 The exception is that we sometimes have to decide whether arguments
1501 that look like procedure arguments are really simple variable
1505 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1506 bool no_formal_args)
1509 gfc_symtree *parent_st;
1511 int save_need_full_assumed_size;
1512 gfc_component *comp;
1514 for (; arg; arg = arg->next)
1519 /* Check the label is a valid branching target. */
1522 if (arg->label->defined == ST_LABEL_UNKNOWN)
1524 gfc_error ("Label %d referenced at %L is never defined",
1525 arg->label->value, &arg->label->where);
1532 if (gfc_is_proc_ptr_comp (e, &comp))
1535 if (e->expr_type == EXPR_PPC)
1537 if (comp->as != NULL)
1538 e->rank = comp->as->rank;
1539 e->expr_type = EXPR_FUNCTION;
1541 if (gfc_resolve_expr (e) == FAILURE)
1546 if (e->expr_type == EXPR_VARIABLE
1547 && e->symtree->n.sym->attr.generic
1549 && count_specific_procs (e) != 1)
1552 if (e->ts.type != BT_PROCEDURE)
1554 save_need_full_assumed_size = need_full_assumed_size;
1555 if (e->expr_type != EXPR_VARIABLE)
1556 need_full_assumed_size = 0;
1557 if (gfc_resolve_expr (e) != SUCCESS)
1559 need_full_assumed_size = save_need_full_assumed_size;
1563 /* See if the expression node should really be a variable reference. */
1565 sym = e->symtree->n.sym;
1567 if (sym->attr.flavor == FL_PROCEDURE
1568 || sym->attr.intrinsic
1569 || sym->attr.external)
1573 /* If a procedure is not already determined to be something else
1574 check if it is intrinsic. */
1575 if (!sym->attr.intrinsic
1576 && !(sym->attr.external || sym->attr.use_assoc
1577 || sym->attr.if_source == IFSRC_IFBODY)
1578 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1579 sym->attr.intrinsic = 1;
1581 if (sym->attr.proc == PROC_ST_FUNCTION)
1583 gfc_error ("Statement function '%s' at %L is not allowed as an "
1584 "actual argument", sym->name, &e->where);
1587 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1588 sym->attr.subroutine);
1589 if (sym->attr.intrinsic && actual_ok == 0)
1591 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1592 "actual argument", sym->name, &e->where);
1595 if (sym->attr.contained && !sym->attr.use_assoc
1596 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1598 if (gfc_notify_std (GFC_STD_F2008,
1599 "Fortran 2008: Internal procedure '%s' is"
1600 " used as actual argument at %L",
1601 sym->name, &e->where) == FAILURE)
1605 if (sym->attr.elemental && !sym->attr.intrinsic)
1607 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1608 "allowed as an actual argument at %L", sym->name,
1612 /* Check if a generic interface has a specific procedure
1613 with the same name before emitting an error. */
1614 if (sym->attr.generic && count_specific_procs (e) != 1)
1617 /* Just in case a specific was found for the expression. */
1618 sym = e->symtree->n.sym;
1620 /* If the symbol is the function that names the current (or
1621 parent) scope, then we really have a variable reference. */
1623 if (gfc_is_function_return_value (sym, sym->ns))
1626 /* If all else fails, see if we have a specific intrinsic. */
1627 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1629 gfc_intrinsic_sym *isym;
1631 isym = gfc_find_function (sym->name);
1632 if (isym == NULL || !isym->specific)
1634 gfc_error ("Unable to find a specific INTRINSIC procedure "
1635 "for the reference '%s' at %L", sym->name,
1640 sym->attr.intrinsic = 1;
1641 sym->attr.function = 1;
1644 if (gfc_resolve_expr (e) == FAILURE)
1649 /* See if the name is a module procedure in a parent unit. */
1651 if (was_declared (sym) || sym->ns->parent == NULL)
1654 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1656 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1660 if (parent_st == NULL)
1663 sym = parent_st->n.sym;
1664 e->symtree = parent_st; /* Point to the right thing. */
1666 if (sym->attr.flavor == FL_PROCEDURE
1667 || sym->attr.intrinsic
1668 || sym->attr.external)
1670 if (gfc_resolve_expr (e) == FAILURE)
1676 e->expr_type = EXPR_VARIABLE;
1678 if (sym->as != NULL)
1680 e->rank = sym->as->rank;
1681 e->ref = gfc_get_ref ();
1682 e->ref->type = REF_ARRAY;
1683 e->ref->u.ar.type = AR_FULL;
1684 e->ref->u.ar.as = sym->as;
1687 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1688 primary.c (match_actual_arg). If above code determines that it
1689 is a variable instead, it needs to be resolved as it was not
1690 done at the beginning of this function. */
1691 save_need_full_assumed_size = need_full_assumed_size;
1692 if (e->expr_type != EXPR_VARIABLE)
1693 need_full_assumed_size = 0;
1694 if (gfc_resolve_expr (e) != SUCCESS)
1696 need_full_assumed_size = save_need_full_assumed_size;
1699 /* Check argument list functions %VAL, %LOC and %REF. There is
1700 nothing to do for %REF. */
1701 if (arg->name && arg->name[0] == '%')
1703 if (strncmp ("%VAL", arg->name, 4) == 0)
1705 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1707 gfc_error ("By-value argument at %L is not of numeric "
1714 gfc_error ("By-value argument at %L cannot be an array or "
1715 "an array section", &e->where);
1719 /* Intrinsics are still PROC_UNKNOWN here. However,
1720 since same file external procedures are not resolvable
1721 in gfortran, it is a good deal easier to leave them to
1723 if (ptype != PROC_UNKNOWN
1724 && ptype != PROC_DUMMY
1725 && ptype != PROC_EXTERNAL
1726 && ptype != PROC_MODULE)
1728 gfc_error ("By-value argument at %L is not allowed "
1729 "in this context", &e->where);
1734 /* Statement functions have already been excluded above. */
1735 else if (strncmp ("%LOC", arg->name, 4) == 0
1736 && e->ts.type == BT_PROCEDURE)
1738 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1740 gfc_error ("Passing internal procedure at %L by location "
1741 "not allowed", &e->where);
1747 /* Fortran 2008, C1237. */
1748 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1749 && gfc_has_ultimate_pointer (e))
1751 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1752 "component", &e->where);
1761 /* Do the checks of the actual argument list that are specific to elemental
1762 procedures. If called with c == NULL, we have a function, otherwise if
1763 expr == NULL, we have a subroutine. */
1766 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1768 gfc_actual_arglist *arg0;
1769 gfc_actual_arglist *arg;
1770 gfc_symbol *esym = NULL;
1771 gfc_intrinsic_sym *isym = NULL;
1773 gfc_intrinsic_arg *iformal = NULL;
1774 gfc_formal_arglist *eformal = NULL;
1775 bool formal_optional = false;
1776 bool set_by_optional = false;
1780 /* Is this an elemental procedure? */
1781 if (expr && expr->value.function.actual != NULL)
1783 if (expr->value.function.esym != NULL
1784 && expr->value.function.esym->attr.elemental)
1786 arg0 = expr->value.function.actual;
1787 esym = expr->value.function.esym;
1789 else if (expr->value.function.isym != NULL
1790 && expr->value.function.isym->elemental)
1792 arg0 = expr->value.function.actual;
1793 isym = expr->value.function.isym;
1798 else if (c && c->ext.actual != NULL)
1800 arg0 = c->ext.actual;
1802 if (c->resolved_sym)
1803 esym = c->resolved_sym;
1805 esym = c->symtree->n.sym;
1808 if (!esym->attr.elemental)
1814 /* The rank of an elemental is the rank of its array argument(s). */
1815 for (arg = arg0; arg; arg = arg->next)
1817 if (arg->expr != NULL && arg->expr->rank > 0)
1819 rank = arg->expr->rank;
1820 if (arg->expr->expr_type == EXPR_VARIABLE
1821 && arg->expr->symtree->n.sym->attr.optional)
1822 set_by_optional = true;
1824 /* Function specific; set the result rank and shape. */
1828 if (!expr->shape && arg->expr->shape)
1830 expr->shape = gfc_get_shape (rank);
1831 for (i = 0; i < rank; i++)
1832 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1839 /* If it is an array, it shall not be supplied as an actual argument
1840 to an elemental procedure unless an array of the same rank is supplied
1841 as an actual argument corresponding to a nonoptional dummy argument of
1842 that elemental procedure(12.4.1.5). */
1843 formal_optional = false;
1845 iformal = isym->formal;
1847 eformal = esym->formal;
1849 for (arg = arg0; arg; arg = arg->next)
1853 if (eformal->sym && eformal->sym->attr.optional)
1854 formal_optional = true;
1855 eformal = eformal->next;
1857 else if (isym && iformal)
1859 if (iformal->optional)
1860 formal_optional = true;
1861 iformal = iformal->next;
1864 formal_optional = true;
1866 if (pedantic && arg->expr != NULL
1867 && arg->expr->expr_type == EXPR_VARIABLE
1868 && arg->expr->symtree->n.sym->attr.optional
1871 && (set_by_optional || arg->expr->rank != rank)
1872 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1874 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1875 "MISSING, it cannot be the actual argument of an "
1876 "ELEMENTAL procedure unless there is a non-optional "
1877 "argument with the same rank (12.4.1.5)",
1878 arg->expr->symtree->n.sym->name, &arg->expr->where);
1883 for (arg = arg0; arg; arg = arg->next)
1885 if (arg->expr == NULL || arg->expr->rank == 0)
1888 /* Being elemental, the last upper bound of an assumed size array
1889 argument must be present. */
1890 if (resolve_assumed_size_actual (arg->expr))
1893 /* Elemental procedure's array actual arguments must conform. */
1896 if (gfc_check_conformance (arg->expr, e,
1897 "elemental procedure") == FAILURE)
1904 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1905 is an array, the intent inout/out variable needs to be also an array. */
1906 if (rank > 0 && esym && expr == NULL)
1907 for (eformal = esym->formal, arg = arg0; arg && eformal;
1908 arg = arg->next, eformal = eformal->next)
1909 if ((eformal->sym->attr.intent == INTENT_OUT
1910 || eformal->sym->attr.intent == INTENT_INOUT)
1911 && arg->expr && arg->expr->rank == 0)
1913 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1914 "ELEMENTAL subroutine '%s' is a scalar, but another "
1915 "actual argument is an array", &arg->expr->where,
1916 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1917 : "INOUT", eformal->sym->name, esym->name);
1924 /* This function does the checking of references to global procedures
1925 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1926 77 and 95 standards. It checks for a gsymbol for the name, making
1927 one if it does not already exist. If it already exists, then the
1928 reference being resolved must correspond to the type of gsymbol.
1929 Otherwise, the new symbol is equipped with the attributes of the
1930 reference. The corresponding code that is called in creating
1931 global entities is parse.c.
1933 In addition, for all but -std=legacy, the gsymbols are used to
1934 check the interfaces of external procedures from the same file.
1935 The namespace of the gsymbol is resolved and then, once this is
1936 done the interface is checked. */
1940 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
1942 if (!gsym_ns->proc_name->attr.recursive)
1945 if (sym->ns == gsym_ns)
1948 if (sym->ns->parent && sym->ns->parent == gsym_ns)
1955 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
1957 if (gsym_ns->entries)
1959 gfc_entry_list *entry = gsym_ns->entries;
1961 for (; entry; entry = entry->next)
1963 if (strcmp (sym->name, entry->sym->name) == 0)
1965 if (strcmp (gsym_ns->proc_name->name,
1966 sym->ns->proc_name->name) == 0)
1970 && strcmp (gsym_ns->proc_name->name,
1971 sym->ns->parent->proc_name->name) == 0)
1980 resolve_global_procedure (gfc_symbol *sym, locus *where,
1981 gfc_actual_arglist **actual, int sub)
1985 enum gfc_symbol_type type;
1987 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1989 gsym = gfc_get_gsymbol (sym->name);
1991 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1992 gfc_global_used (gsym, where);
1994 if (gfc_option.flag_whole_file
1995 && (sym->attr.if_source == IFSRC_UNKNOWN
1996 || sym->attr.if_source == IFSRC_IFBODY)
1997 && gsym->type != GSYM_UNKNOWN
1999 && gsym->ns->resolved != -1
2000 && gsym->ns->proc_name
2001 && not_in_recursive (sym, gsym->ns)
2002 && not_entry_self_reference (sym, gsym->ns))
2004 gfc_symbol *def_sym;
2006 /* Resolve the gsymbol namespace if needed. */
2007 if (!gsym->ns->resolved)
2009 gfc_dt_list *old_dt_list;
2011 /* Stash away derived types so that the backend_decls do not
2013 old_dt_list = gfc_derived_types;
2014 gfc_derived_types = NULL;
2016 gfc_resolve (gsym->ns);
2018 /* Store the new derived types with the global namespace. */
2019 if (gfc_derived_types)
2020 gsym->ns->derived_types = gfc_derived_types;
2022 /* Restore the derived types of this namespace. */
2023 gfc_derived_types = old_dt_list;
2026 /* Make sure that translation for the gsymbol occurs before
2027 the procedure currently being resolved. */
2028 ns = gfc_global_ns_list;
2029 for (; ns && ns != gsym->ns; ns = ns->sibling)
2031 if (ns->sibling == gsym->ns)
2033 ns->sibling = gsym->ns->sibling;
2034 gsym->ns->sibling = gfc_global_ns_list;
2035 gfc_global_ns_list = gsym->ns;
2040 def_sym = gsym->ns->proc_name;
2041 if (def_sym->attr.entry_master)
2043 gfc_entry_list *entry;
2044 for (entry = gsym->ns->entries; entry; entry = entry->next)
2045 if (strcmp (entry->sym->name, sym->name) == 0)
2047 def_sym = entry->sym;
2052 /* Differences in constant character lengths. */
2053 if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2055 long int l1 = 0, l2 = 0;
2056 gfc_charlen *cl1 = sym->ts.u.cl;
2057 gfc_charlen *cl2 = def_sym->ts.u.cl;
2060 && cl1->length != NULL
2061 && cl1->length->expr_type == EXPR_CONSTANT)
2062 l1 = mpz_get_si (cl1->length->value.integer);
2065 && cl2->length != NULL
2066 && cl2->length->expr_type == EXPR_CONSTANT)
2067 l2 = mpz_get_si (cl2->length->value.integer);
2069 if (l1 && l2 && l1 != l2)
2070 gfc_error ("Character length mismatch in return type of "
2071 "function '%s' at %L (%ld/%ld)", sym->name,
2072 &sym->declared_at, l1, l2);
2075 /* Type mismatch of function return type and expected type. */
2076 if (sym->attr.function
2077 && !gfc_compare_types (&sym->ts, &def_sym->ts))
2078 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2079 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2080 gfc_typename (&def_sym->ts));
2082 if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2084 gfc_formal_arglist *arg = def_sym->formal;
2085 for ( ; arg; arg = arg->next)
2088 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2089 else if (arg->sym->attr.allocatable
2090 || arg->sym->attr.asynchronous
2091 || arg->sym->attr.optional
2092 || arg->sym->attr.pointer
2093 || arg->sym->attr.target
2094 || arg->sym->attr.value
2095 || arg->sym->attr.volatile_)
2097 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2098 "has an attribute that requires an explicit "
2099 "interface for this procedure", arg->sym->name,
2100 sym->name, &sym->declared_at);
2103 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2104 else if (arg->sym && arg->sym->as
2105 && arg->sym->as->type == AS_ASSUMED_SHAPE)
2107 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2108 "argument '%s' must have an explicit interface",
2109 sym->name, &sym->declared_at, arg->sym->name);
2112 /* F2008, 12.4.2.2 (2c) */
2113 else if (arg->sym->attr.codimension)
2115 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2116 "'%s' must have an explicit interface",
2117 sym->name, &sym->declared_at, arg->sym->name);
2120 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2121 else if (false) /* TODO: is a parametrized derived type */
2123 gfc_error ("Procedure '%s' at %L with parametrized derived "
2124 "type argument '%s' must have an explicit "
2125 "interface", sym->name, &sym->declared_at,
2129 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2130 else if (arg->sym->ts.type == BT_CLASS)
2132 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2133 "argument '%s' must have an explicit interface",
2134 sym->name, &sym->declared_at, arg->sym->name);
2139 if (def_sym->attr.function)
2141 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2142 if (def_sym->as && def_sym->as->rank
2143 && (!sym->as || sym->as->rank != def_sym->as->rank))
2144 gfc_error ("The reference to function '%s' at %L either needs an "
2145 "explicit INTERFACE or the rank is incorrect", sym->name,
2148 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2149 if ((def_sym->result->attr.pointer
2150 || def_sym->result->attr.allocatable)
2151 && (sym->attr.if_source != IFSRC_IFBODY
2152 || def_sym->result->attr.pointer
2153 != sym->result->attr.pointer
2154 || def_sym->result->attr.allocatable
2155 != sym->result->attr.allocatable))
2156 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2157 "result must have an explicit interface", sym->name,
2160 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2161 if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2162 && def_sym->ts.u.cl->length != NULL)
2164 gfc_charlen *cl = sym->ts.u.cl;
2166 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2167 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2169 gfc_error ("Nonconstant character-length function '%s' at %L "
2170 "must have an explicit interface", sym->name,
2176 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2177 if (def_sym->attr.elemental && !sym->attr.elemental)
2179 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2180 "interface", sym->name, &sym->declared_at);
2183 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2184 if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2186 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2187 "an explicit interface", sym->name, &sym->declared_at);
2190 if (gfc_option.flag_whole_file == 1
2191 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2192 && !(gfc_option.warn_std & GFC_STD_GNU)))
2193 gfc_errors_to_warnings (1);
2195 if (sym->attr.if_source != IFSRC_IFBODY)
2196 gfc_procedure_use (def_sym, actual, where);
2198 gfc_errors_to_warnings (0);
2201 if (gsym->type == GSYM_UNKNOWN)
2204 gsym->where = *where;
2211 /************* Function resolution *************/
2213 /* Resolve a function call known to be generic.
2214 Section 14.1.2.4.1. */
2217 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2221 if (sym->attr.generic)
2223 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2226 expr->value.function.name = s->name;
2227 expr->value.function.esym = s;
2229 if (s->ts.type != BT_UNKNOWN)
2231 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2232 expr->ts = s->result->ts;
2235 expr->rank = s->as->rank;
2236 else if (s->result != NULL && s->result->as != NULL)
2237 expr->rank = s->result->as->rank;
2239 gfc_set_sym_referenced (expr->value.function.esym);
2244 /* TODO: Need to search for elemental references in generic
2248 if (sym->attr.intrinsic)
2249 return gfc_intrinsic_func_interface (expr, 0);
2256 resolve_generic_f (gfc_expr *expr)
2261 sym = expr->symtree->n.sym;
2265 m = resolve_generic_f0 (expr, sym);
2268 else if (m == MATCH_ERROR)
2272 if (sym->ns->parent == NULL)
2274 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2278 if (!generic_sym (sym))
2282 /* Last ditch attempt. See if the reference is to an intrinsic
2283 that possesses a matching interface. 14.1.2.4 */
2284 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
2286 gfc_error ("There is no specific function for the generic '%s' at %L",
2287 expr->symtree->n.sym->name, &expr->where);
2291 m = gfc_intrinsic_func_interface (expr, 0);
2295 gfc_error ("Generic function '%s' at %L is not consistent with a "
2296 "specific intrinsic interface", expr->symtree->n.sym->name,
2303 /* Resolve a function call known to be specific. */
2306 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2310 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2312 if (sym->attr.dummy)
2314 sym->attr.proc = PROC_DUMMY;
2318 sym->attr.proc = PROC_EXTERNAL;
2322 if (sym->attr.proc == PROC_MODULE
2323 || sym->attr.proc == PROC_ST_FUNCTION
2324 || sym->attr.proc == PROC_INTERNAL)
2327 if (sym->attr.intrinsic)
2329 m = gfc_intrinsic_func_interface (expr, 1);
2333 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2334 "with an intrinsic", sym->name, &expr->where);
2342 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2345 expr->ts = sym->result->ts;
2348 expr->value.function.name = sym->name;
2349 expr->value.function.esym = sym;
2350 if (sym->as != NULL)
2351 expr->rank = sym->as->rank;
2358 resolve_specific_f (gfc_expr *expr)
2363 sym = expr->symtree->n.sym;
2367 m = resolve_specific_f0 (sym, expr);
2370 if (m == MATCH_ERROR)
2373 if (sym->ns->parent == NULL)
2376 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2382 gfc_error ("Unable to resolve the specific function '%s' at %L",
2383 expr->symtree->n.sym->name, &expr->where);
2389 /* Resolve a procedure call not known to be generic nor specific. */
2392 resolve_unknown_f (gfc_expr *expr)
2397 sym = expr->symtree->n.sym;
2399 if (sym->attr.dummy)
2401 sym->attr.proc = PROC_DUMMY;
2402 expr->value.function.name = sym->name;
2406 /* See if we have an intrinsic function reference. */
2408 if (gfc_is_intrinsic (sym, 0, expr->where))
2410 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2415 /* The reference is to an external name. */
2417 sym->attr.proc = PROC_EXTERNAL;
2418 expr->value.function.name = sym->name;
2419 expr->value.function.esym = expr->symtree->n.sym;
2421 if (sym->as != NULL)
2422 expr->rank = sym->as->rank;
2424 /* Type of the expression is either the type of the symbol or the
2425 default type of the symbol. */
2428 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2430 if (sym->ts.type != BT_UNKNOWN)
2434 ts = gfc_get_default_type (sym->name, sym->ns);
2436 if (ts->type == BT_UNKNOWN)
2438 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2439 sym->name, &expr->where);
2450 /* Return true, if the symbol is an external procedure. */
2452 is_external_proc (gfc_symbol *sym)
2454 if (!sym->attr.dummy && !sym->attr.contained
2455 && !(sym->attr.intrinsic
2456 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2457 && sym->attr.proc != PROC_ST_FUNCTION
2458 && !sym->attr.proc_pointer
2459 && !sym->attr.use_assoc
2467 /* Figure out if a function reference is pure or not. Also set the name
2468 of the function for a potential error message. Return nonzero if the
2469 function is PURE, zero if not. */
2471 pure_stmt_function (gfc_expr *, gfc_symbol *);
2474 pure_function (gfc_expr *e, const char **name)
2480 if (e->symtree != NULL
2481 && e->symtree->n.sym != NULL
2482 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2483 return pure_stmt_function (e, e->symtree->n.sym);
2485 if (e->value.function.esym)
2487 pure = gfc_pure (e->value.function.esym);
2488 *name = e->value.function.esym->name;
2490 else if (e->value.function.isym)
2492 pure = e->value.function.isym->pure
2493 || e->value.function.isym->elemental;
2494 *name = e->value.function.isym->name;
2498 /* Implicit functions are not pure. */
2500 *name = e->value.function.name;
2508 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2509 int *f ATTRIBUTE_UNUSED)
2513 /* Don't bother recursing into other statement functions
2514 since they will be checked individually for purity. */
2515 if (e->expr_type != EXPR_FUNCTION
2517 || e->symtree->n.sym == sym
2518 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2521 return pure_function (e, &name) ? false : true;
2526 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2528 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2533 is_scalar_expr_ptr (gfc_expr *expr)
2535 gfc_try retval = SUCCESS;
2540 /* See if we have a gfc_ref, which means we have a substring, array
2541 reference, or a component. */
2542 if (expr->ref != NULL)
2545 while (ref->next != NULL)
2551 if (ref->u.ss.length != NULL
2552 && ref->u.ss.length->length != NULL
2554 && ref->u.ss.start->expr_type == EXPR_CONSTANT
2556 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
2558 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
2559 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
2560 if (end - start + 1 != 1)
2567 if (ref->u.ar.type == AR_ELEMENT)
2569 else if (ref->u.ar.type == AR_FULL)
2571 /* The user can give a full array if the array is of size 1. */
2572 if (ref->u.ar.as != NULL
2573 && ref->u.ar.as->rank == 1
2574 && ref->u.ar.as->type == AS_EXPLICIT
2575 && ref->u.ar.as->lower[0] != NULL
2576 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2577 && ref->u.ar.as->upper[0] != NULL
2578 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2580 /* If we have a character string, we need to check if
2581 its length is one. */
2582 if (expr->ts.type == BT_CHARACTER)
2584 if (expr->ts.u.cl == NULL
2585 || expr->ts.u.cl->length == NULL
2586 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2592 /* We have constant lower and upper bounds. If the
2593 difference between is 1, it can be considered a
2595 start = (int) mpz_get_si
2596 (ref->u.ar.as->lower[0]->value.integer);
2597 end = (int) mpz_get_si
2598 (ref->u.ar.as->upper[0]->value.integer);
2599 if (end - start + 1 != 1)
2614 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2616 /* Character string. Make sure it's of length 1. */
2617 if (expr->ts.u.cl == NULL
2618 || expr->ts.u.cl->length == NULL
2619 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2622 else if (expr->rank != 0)
2629 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2630 and, in the case of c_associated, set the binding label based on
2634 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2635 gfc_symbol **new_sym)
2637 char name[GFC_MAX_SYMBOL_LEN + 1];
2638 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2639 int optional_arg = 0;
2640 gfc_try retval = SUCCESS;
2641 gfc_symbol *args_sym;
2642 gfc_typespec *arg_ts;
2643 symbol_attribute arg_attr;
2645 if (args->expr->expr_type == EXPR_CONSTANT
2646 || args->expr->expr_type == EXPR_OP
2647 || args->expr->expr_type == EXPR_NULL)
2649 gfc_error ("Argument to '%s' at %L is not a variable",
2650 sym->name, &(args->expr->where));
2654 args_sym = args->expr->symtree->n.sym;
2656 /* The typespec for the actual arg should be that stored in the expr
2657 and not necessarily that of the expr symbol (args_sym), because
2658 the actual expression could be a part-ref of the expr symbol. */
2659 arg_ts = &(args->expr->ts);
2660 arg_attr = gfc_expr_attr (args->expr);
2662 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2664 /* If the user gave two args then they are providing something for
2665 the optional arg (the second cptr). Therefore, set the name and
2666 binding label to the c_associated for two cptrs. Otherwise,
2667 set c_associated to expect one cptr. */
2671 sprintf (name, "%s_2", sym->name);
2672 sprintf (binding_label, "%s_2", sym->binding_label);
2678 sprintf (name, "%s_1", sym->name);
2679 sprintf (binding_label, "%s_1", sym->binding_label);
2683 /* Get a new symbol for the version of c_associated that
2685 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2687 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2688 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2690 sprintf (name, "%s", sym->name);
2691 sprintf (binding_label, "%s", sym->binding_label);
2693 /* Error check the call. */
2694 if (args->next != NULL)
2696 gfc_error_now ("More actual than formal arguments in '%s' "
2697 "call at %L", name, &(args->expr->where));
2700 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2702 /* Make sure we have either the target or pointer attribute. */
2703 if (!arg_attr.target && !arg_attr.pointer)
2705 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2706 "a TARGET or an associated pointer",
2708 sym->name, &(args->expr->where));
2712 /* See if we have interoperable type and type param. */
2713 if (verify_c_interop (arg_ts) == SUCCESS
2714 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2716 if (args_sym->attr.target == 1)
2718 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2719 has the target attribute and is interoperable. */
2720 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2721 allocatable variable that has the TARGET attribute and
2722 is not an array of zero size. */
2723 if (args_sym->attr.allocatable == 1)
2725 if (args_sym->attr.dimension != 0
2726 && (args_sym->as && args_sym->as->rank == 0))
2728 gfc_error_now ("Allocatable variable '%s' used as a "
2729 "parameter to '%s' at %L must not be "
2730 "an array of zero size",
2731 args_sym->name, sym->name,
2732 &(args->expr->where));
2738 /* A non-allocatable target variable with C
2739 interoperable type and type parameters must be
2741 if (args_sym && args_sym->attr.dimension)
2743 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2745 gfc_error ("Assumed-shape array '%s' at %L "
2746 "cannot be an argument to the "
2747 "procedure '%s' because "
2748 "it is not C interoperable",
2750 &(args->expr->where), sym->name);
2753 else if (args_sym->as->type == AS_DEFERRED)
2755 gfc_error ("Deferred-shape array '%s' at %L "
2756 "cannot be an argument to the "
2757 "procedure '%s' because "
2758 "it is not C interoperable",
2760 &(args->expr->where), sym->name);
2765 /* Make sure it's not a character string. Arrays of
2766 any type should be ok if the variable is of a C
2767 interoperable type. */
2768 if (arg_ts->type == BT_CHARACTER)
2769 if (arg_ts->u.cl != NULL
2770 && (arg_ts->u.cl->length == NULL
2771 || arg_ts->u.cl->length->expr_type
2774 (arg_ts->u.cl->length->value.integer, 1)
2776 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2778 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2779 "at %L must have a length of 1",
2780 args_sym->name, sym->name,
2781 &(args->expr->where));
2786 else if (arg_attr.pointer
2787 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2789 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2791 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2792 "associated scalar POINTER", args_sym->name,
2793 sym->name, &(args->expr->where));
2799 /* The parameter is not required to be C interoperable. If it
2800 is not C interoperable, it must be a nonpolymorphic scalar
2801 with no length type parameters. It still must have either
2802 the pointer or target attribute, and it can be
2803 allocatable (but must be allocated when c_loc is called). */
2804 if (args->expr->rank != 0
2805 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2807 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2808 "scalar", args_sym->name, sym->name,
2809 &(args->expr->where));
2812 else if (arg_ts->type == BT_CHARACTER
2813 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2815 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2816 "%L must have a length of 1",
2817 args_sym->name, sym->name,
2818 &(args->expr->where));
2821 else if (arg_ts->type == BT_CLASS)
2823 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2824 "polymorphic", args_sym->name, sym->name,
2825 &(args->expr->where));
2830 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2832 if (args_sym->attr.flavor != FL_PROCEDURE)
2834 /* TODO: Update this error message to allow for procedure
2835 pointers once they are implemented. */
2836 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2838 args_sym->name, sym->name,
2839 &(args->expr->where));
2842 else if (args_sym->attr.is_bind_c != 1)
2844 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2846 args_sym->name, sym->name,
2847 &(args->expr->where));
2852 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2857 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2858 "iso_c_binding function: '%s'!\n", sym->name);
2865 /* Resolve a function call, which means resolving the arguments, then figuring
2866 out which entity the name refers to. */
2869 resolve_function (gfc_expr *expr)
2871 gfc_actual_arglist *arg;
2876 procedure_type p = PROC_INTRINSIC;
2877 bool no_formal_args;
2881 sym = expr->symtree->n.sym;
2883 /* If this is a procedure pointer component, it has already been resolved. */
2884 if (gfc_is_proc_ptr_comp (expr, NULL))
2887 if (sym && sym->attr.intrinsic
2888 && resolve_intrinsic (sym, &expr->where) == FAILURE)
2891 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2893 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2897 /* If this ia a deferred TBP with an abstract interface (which may
2898 of course be referenced), expr->value.function.esym will be set. */
2899 if (sym && sym->attr.abstract && !expr->value.function.esym)
2901 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2902 sym->name, &expr->where);
2906 /* Switch off assumed size checking and do this again for certain kinds
2907 of procedure, once the procedure itself is resolved. */
2908 need_full_assumed_size++;
2910 if (expr->symtree && expr->symtree->n.sym)
2911 p = expr->symtree->n.sym->attr.proc;
2913 if (expr->value.function.isym && expr->value.function.isym->inquiry)
2914 inquiry_argument = true;
2915 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2917 if (resolve_actual_arglist (expr->value.function.actual,
2918 p, no_formal_args) == FAILURE)
2920 inquiry_argument = false;
2924 inquiry_argument = false;
2926 /* Need to setup the call to the correct c_associated, depending on
2927 the number of cptrs to user gives to compare. */
2928 if (sym && sym->attr.is_iso_c == 1)
2930 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2934 /* Get the symtree for the new symbol (resolved func).
2935 the old one will be freed later, when it's no longer used. */
2936 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2939 /* Resume assumed_size checking. */
2940 need_full_assumed_size--;
2942 /* If the procedure is external, check for usage. */
2943 if (sym && is_external_proc (sym))
2944 resolve_global_procedure (sym, &expr->where,
2945 &expr->value.function.actual, 0);
2947 if (sym && sym->ts.type == BT_CHARACTER
2949 && sym->ts.u.cl->length == NULL
2951 && expr->value.function.esym == NULL
2952 && !sym->attr.contained)
2954 /* Internal procedures are taken care of in resolve_contained_fntype. */
2955 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2956 "be used at %L since it is not a dummy argument",
2957 sym->name, &expr->where);
2961 /* See if function is already resolved. */
2963 if (expr->value.function.name != NULL)
2965 if (expr->ts.type == BT_UNKNOWN)
2971 /* Apply the rules of section 14.1.2. */
2973 switch (procedure_kind (sym))
2976 t = resolve_generic_f (expr);
2979 case PTYPE_SPECIFIC:
2980 t = resolve_specific_f (expr);
2984 t = resolve_unknown_f (expr);
2988 gfc_internal_error ("resolve_function(): bad function type");
2992 /* If the expression is still a function (it might have simplified),
2993 then we check to see if we are calling an elemental function. */
2995 if (expr->expr_type != EXPR_FUNCTION)
2998 temp = need_full_assumed_size;
2999 need_full_assumed_size = 0;
3001 if (resolve_elemental_actual (expr, NULL) == FAILURE)
3004 if (omp_workshare_flag
3005 && expr->value.function.esym
3006 && ! gfc_elemental (expr->value.function.esym))
3008 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3009 "in WORKSHARE construct", expr->value.function.esym->name,
3014 #define GENERIC_ID expr->value.function.isym->id
3015 else if (expr->value.function.actual != NULL
3016 && expr->value.function.isym != NULL
3017 && GENERIC_ID != GFC_ISYM_LBOUND
3018 && GENERIC_ID != GFC_ISYM_LEN
3019 && GENERIC_ID != GFC_ISYM_LOC
3020 && GENERIC_ID != GFC_ISYM_PRESENT)
3022 /* Array intrinsics must also have the last upper bound of an
3023 assumed size array argument. UBOUND and SIZE have to be
3024 excluded from the check if the second argument is anything
3027 for (arg = expr->value.function.actual; arg; arg = arg->next)
3029 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3030 && arg->next != NULL && arg->next->expr)
3032 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3035 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3038 if ((int)mpz_get_si (arg->next->expr->value.integer)
3043 if (arg->expr != NULL
3044 && arg->expr->rank > 0
3045 && resolve_assumed_size_actual (arg->expr))
3051 need_full_assumed_size = temp;
3054 if (!pure_function (expr, &name) && name)
3058 gfc_error ("reference to non-PURE function '%s' at %L inside a "
3059 "FORALL %s", name, &expr->where,
3060 forall_flag == 2 ? "mask" : "block");
3063 else if (gfc_pure (NULL))
3065 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3066 "procedure within a PURE procedure", name, &expr->where);
3071 /* Functions without the RECURSIVE attribution are not allowed to
3072 * call themselves. */
3073 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3076 esym = expr->value.function.esym;
3078 if (is_illegal_recursion (esym, gfc_current_ns))
3080 if (esym->attr.entry && esym->ns->entries)
3081 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3082 " function '%s' is not RECURSIVE",
3083 esym->name, &expr->where, esym->ns->entries->sym->name);
3085 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3086 " is not RECURSIVE", esym->name, &expr->where);
3092 /* Character lengths of use associated functions may contains references to
3093 symbols not referenced from the current program unit otherwise. Make sure
3094 those symbols are marked as referenced. */
3096 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3097 && expr->value.function.esym->attr.use_assoc)
3099 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3102 /* Make sure that the expression has a typespec that works. */
3103 if (expr->ts.type == BT_UNKNOWN)
3105 if (expr->symtree->n.sym->result
3106 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3107 && !expr->symtree->n.sym->result->attr.proc_pointer)
3108 expr->ts = expr->symtree->n.sym->result->ts;
3115 /************* Subroutine resolution *************/
3118 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3124 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3125 sym->name, &c->loc);
3126 else if (gfc_pure (NULL))
3127 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3133 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3137 if (sym->attr.generic)
3139 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3142 c->resolved_sym = s;
3143 pure_subroutine (c, s);
3147 /* TODO: Need to search for elemental references in generic interface. */
3150 if (sym->attr.intrinsic)
3151 return gfc_intrinsic_sub_interface (c, 0);
3158 resolve_generic_s (gfc_code *c)
3163 sym = c->symtree->n.sym;
3167 m = resolve_generic_s0 (c, sym);
3170 else if (m == MATCH_ERROR)
3174 if (sym->ns->parent == NULL)
3176 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3180 if (!generic_sym (sym))
3184 /* Last ditch attempt. See if the reference is to an intrinsic
3185 that possesses a matching interface. 14.1.2.4 */
3186 sym = c->symtree->n.sym;
3188 if (!gfc_is_intrinsic (sym, 1, c->loc))
3190 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3191 sym->name, &c->loc);
3195 m = gfc_intrinsic_sub_interface (c, 0);
3199 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3200 "intrinsic subroutine interface", sym->name, &c->loc);
3206 /* Set the name and binding label of the subroutine symbol in the call
3207 expression represented by 'c' to include the type and kind of the
3208 second parameter. This function is for resolving the appropriate
3209 version of c_f_pointer() and c_f_procpointer(). For example, a
3210 call to c_f_pointer() for a default integer pointer could have a
3211 name of c_f_pointer_i4. If no second arg exists, which is an error
3212 for these two functions, it defaults to the generic symbol's name
3213 and binding label. */
3216 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3217 char *name, char *binding_label)
3219 gfc_expr *arg = NULL;
3223 /* The second arg of c_f_pointer and c_f_procpointer determines
3224 the type and kind for the procedure name. */
3225 arg = c->ext.actual->next->expr;
3229 /* Set up the name to have the given symbol's name,
3230 plus the type and kind. */
3231 /* a derived type is marked with the type letter 'u' */
3232 if (arg->ts.type == BT_DERIVED)
3235 kind = 0; /* set the kind as 0 for now */
3239 type = gfc_type_letter (arg->ts.type);
3240 kind = arg->ts.kind;
3243 if (arg->ts.type == BT_CHARACTER)
3244 /* Kind info for character strings not needed. */
3247 sprintf (name, "%s_%c%d", sym->name, type, kind);
3248 /* Set up the binding label as the given symbol's label plus
3249 the type and kind. */
3250 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
3254 /* If the second arg is missing, set the name and label as
3255 was, cause it should at least be found, and the missing
3256 arg error will be caught by compare_parameters(). */
3257 sprintf (name, "%s", sym->name);
3258 sprintf (binding_label, "%s", sym->binding_label);
3265 /* Resolve a generic version of the iso_c_binding procedure given
3266 (sym) to the specific one based on the type and kind of the
3267 argument(s). Currently, this function resolves c_f_pointer() and
3268 c_f_procpointer based on the type and kind of the second argument
3269 (FPTR). Other iso_c_binding procedures aren't specially handled.
3270 Upon successfully exiting, c->resolved_sym will hold the resolved
3271 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3275 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3277 gfc_symbol *new_sym;
3278 /* this is fine, since we know the names won't use the max */
3279 char name[GFC_MAX_SYMBOL_LEN + 1];
3280 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
3281 /* default to success; will override if find error */
3282 match m = MATCH_YES;
3284 /* Make sure the actual arguments are in the necessary order (based on the
3285 formal args) before resolving. */
3286 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3288 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3289 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3291 set_name_and_label (c, sym, name, binding_label);
3293 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3295 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3297 /* Make sure we got a third arg if the second arg has non-zero
3298 rank. We must also check that the type and rank are
3299 correct since we short-circuit this check in
3300 gfc_procedure_use() (called above to sort actual args). */
3301 if (c->ext.actual->next->expr->rank != 0)
3303 if(c->ext.actual->next->next == NULL
3304 || c->ext.actual->next->next->expr == NULL)
3307 gfc_error ("Missing SHAPE parameter for call to %s "
3308 "at %L", sym->name, &(c->loc));
3310 else if (c->ext.actual->next->next->expr->ts.type
3312 || c->ext.actual->next->next->expr->rank != 1)
3315 gfc_error ("SHAPE parameter for call to %s at %L must "
3316 "be a rank 1 INTEGER array", sym->name,
3323 if (m != MATCH_ERROR)
3325 /* the 1 means to add the optional arg to formal list */
3326 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3328 /* for error reporting, say it's declared where the original was */
3329 new_sym->declared_at = sym->declared_at;
3334 /* no differences for c_loc or c_funloc */
3338 /* set the resolved symbol */
3339 if (m != MATCH_ERROR)
3340 c->resolved_sym = new_sym;
3342 c->resolved_sym = sym;
3348 /* Resolve a subroutine call known to be specific. */
3351 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3355 if(sym->attr.is_iso_c)
3357 m = gfc_iso_c_sub_interface (c,sym);
3361 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3363 if (sym->attr.dummy)
3365 sym->attr.proc = PROC_DUMMY;
3369 sym->attr.proc = PROC_EXTERNAL;
3373 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3376 if (sym->attr.intrinsic)
3378 m = gfc_intrinsic_sub_interface (c, 1);
3382 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3383 "with an intrinsic", sym->name, &c->loc);
3391 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3393 c->resolved_sym = sym;
3394 pure_subroutine (c, sym);
3401 resolve_specific_s (gfc_code *c)
3406 sym = c->symtree->n.sym;
3410 m = resolve_specific_s0 (c, sym);
3413 if (m == MATCH_ERROR)
3416 if (sym->ns->parent == NULL)
3419 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3425 sym = c->symtree->n.sym;
3426 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3427 sym->name, &c->loc);
3433 /* Resolve a subroutine call not known to be generic nor specific. */
3436 resolve_unknown_s (gfc_code *c)
3440 sym = c->symtree->n.sym;
3442 if (sym->attr.dummy)
3444 sym->attr.proc = PROC_DUMMY;
3448 /* See if we have an intrinsic function reference. */
3450 if (gfc_is_intrinsic (sym, 1, c->loc))
3452 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3457 /* The reference is to an external name. */
3460 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3462 c->resolved_sym = sym;
3464 pure_subroutine (c, sym);
3470 /* Resolve a subroutine call. Although it was tempting to use the same code
3471 for functions, subroutines and functions are stored differently and this
3472 makes things awkward. */
3475 resolve_call (gfc_code *c)
3478 procedure_type ptype = PROC_INTRINSIC;
3479 gfc_symbol *csym, *sym;
3480 bool no_formal_args;
3482 csym = c->symtree ? c->symtree->n.sym : NULL;
3484 if (csym && csym->ts.type != BT_UNKNOWN)
3486 gfc_error ("'%s' at %L has a type, which is not consistent with "
3487 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3491 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3494 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3495 sym = st ? st->n.sym : NULL;
3496 if (sym && csym != sym
3497 && sym->ns == gfc_current_ns
3498 && sym->attr.flavor == FL_PROCEDURE
3499 && sym->attr.contained)
3502 if (csym->attr.generic)
3503 c->symtree->n.sym = sym;
3506 csym = c->symtree->n.sym;
3510 /* If this ia a deferred TBP with an abstract interface
3511 (which may of course be referenced), c->expr1 will be set. */
3512 if (csym && csym->attr.abstract && !c->expr1)
3514 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3515 csym->name, &c->loc);
3519 /* Subroutines without the RECURSIVE attribution are not allowed to
3520 * call themselves. */
3521 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3523 if (csym->attr.entry && csym->ns->entries)
3524 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3525 " subroutine '%s' is not RECURSIVE",
3526 csym->name, &c->loc, csym->ns->entries->sym->name);
3528 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3529 " is not RECURSIVE", csym->name, &c->loc);
3534 /* Switch off assumed size checking and do this again for certain kinds
3535 of procedure, once the procedure itself is resolved. */
3536 need_full_assumed_size++;
3539 ptype = csym->attr.proc;
3541 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3542 if (resolve_actual_arglist (c->ext.actual, ptype,
3543 no_formal_args) == FAILURE)
3546 /* Resume assumed_size checking. */
3547 need_full_assumed_size--;
3549 /* If external, check for usage. */
3550 if (csym && is_external_proc (csym))
3551 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3554 if (c->resolved_sym == NULL)
3556 c->resolved_isym = NULL;
3557 switch (procedure_kind (csym))
3560 t = resolve_generic_s (c);
3563 case PTYPE_SPECIFIC:
3564 t = resolve_specific_s (c);
3568 t = resolve_unknown_s (c);
3572 gfc_internal_error ("resolve_subroutine(): bad function type");
3576 /* Some checks of elemental subroutine actual arguments. */
3577 if (resolve_elemental_actual (NULL, c) == FAILURE)
3584 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3585 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3586 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3587 if their shapes do not match. If either op1->shape or op2->shape is
3588 NULL, return SUCCESS. */
3591 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3598 if (op1->shape != NULL && op2->shape != NULL)
3600 for (i = 0; i < op1->rank; i++)
3602 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3604 gfc_error ("Shapes for operands at %L and %L are not conformable",
3605 &op1->where, &op2->where);
3616 /* Resolve an operator expression node. This can involve replacing the
3617 operation with a user defined function call. */
3620 resolve_operator (gfc_expr *e)
3622 gfc_expr *op1, *op2;
3624 bool dual_locus_error;
3627 /* Resolve all subnodes-- give them types. */
3629 switch (e->value.op.op)
3632 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3635 /* Fall through... */
3638 case INTRINSIC_UPLUS:
3639 case INTRINSIC_UMINUS:
3640 case INTRINSIC_PARENTHESES:
3641 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3646 /* Typecheck the new node. */
3648 op1 = e->value.op.op1;
3649 op2 = e->value.op.op2;
3650 dual_locus_error = false;
3652 if ((op1 && op1->expr_type == EXPR_NULL)
3653 || (op2 && op2->expr_type == EXPR_NULL))
3655 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3659 switch (e->value.op.op)
3661 case INTRINSIC_UPLUS:
3662 case INTRINSIC_UMINUS:
3663 if (op1->ts.type == BT_INTEGER
3664 || op1->ts.type == BT_REAL
3665 || op1->ts.type == BT_COMPLEX)
3671 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3672 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3675 case INTRINSIC_PLUS:
3676 case INTRINSIC_MINUS:
3677 case INTRINSIC_TIMES:
3678 case INTRINSIC_DIVIDE:
3679 case INTRINSIC_POWER:
3680 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3682 gfc_type_convert_binary (e, 1);
3687 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3688 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3689 gfc_typename (&op2->ts));
3692 case INTRINSIC_CONCAT:
3693 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3694 && op1->ts.kind == op2->ts.kind)
3696 e->ts.type = BT_CHARACTER;
3697 e->ts.kind = op1->ts.kind;
3702 _("Operands of string concatenation operator at %%L are %s/%s"),
3703 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3709 case INTRINSIC_NEQV:
3710 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3712 e->ts.type = BT_LOGICAL;
3713 e->ts.kind = gfc_kind_max (op1, op2);
3714 if (op1->ts.kind < e->ts.kind)
3715 gfc_convert_type (op1, &e->ts, 2);
3716 else if (op2->ts.kind < e->ts.kind)
3717 gfc_convert_type (op2, &e->ts, 2);
3721 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3722 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3723 gfc_typename (&op2->ts));
3728 if (op1->ts.type == BT_LOGICAL)
3730 e->ts.type = BT_LOGICAL;
3731 e->ts.kind = op1->ts.kind;
3735 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3736 gfc_typename (&op1->ts));
3740 case INTRINSIC_GT_OS:
3742 case INTRINSIC_GE_OS:
3744 case INTRINSIC_LT_OS:
3746 case INTRINSIC_LE_OS:
3747 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3749 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3753 /* Fall through... */
3756 case INTRINSIC_EQ_OS:
3758 case INTRINSIC_NE_OS:
3759 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3760 && op1->ts.kind == op2->ts.kind)
3762 e->ts.type = BT_LOGICAL;
3763 e->ts.kind = gfc_default_logical_kind;
3767 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3769 gfc_type_convert_binary (e, 1);
3771 e->ts.type = BT_LOGICAL;
3772 e->ts.kind = gfc_default_logical_kind;
3776 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3778 _("Logicals at %%L must be compared with %s instead of %s"),
3779 (e->value.op.op == INTRINSIC_EQ
3780 || e->value.op.op == INTRINSIC_EQ_OS)
3781 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3784 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3785 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3786 gfc_typename (&op2->ts));
3790 case INTRINSIC_USER:
3791 if (e->value.op.uop->op == NULL)
3792 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3793 else if (op2 == NULL)
3794 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3795 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));
3803 case INTRINSIC_PARENTHESES:
3805 if (e->ts.type == BT_CHARACTER)
3806 e->ts.u.cl = op1->ts.u.cl;
3810 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3813 /* Deal with arrayness of an operand through an operator. */
3817 switch (e->value.op.op)
3819 case INTRINSIC_PLUS:
3820 case INTRINSIC_MINUS:
3821 case INTRINSIC_TIMES:
3822 case INTRINSIC_DIVIDE:
3823 case INTRINSIC_POWER:
3824 case INTRINSIC_CONCAT:
3828 case INTRINSIC_NEQV:
3830 case INTRINSIC_EQ_OS:
3832 case INTRINSIC_NE_OS:
3834 case INTRINSIC_GT_OS:
3836 case INTRINSIC_GE_OS:
3838 case INTRINSIC_LT_OS:
3840 case INTRINSIC_LE_OS:
3842 if (op1->rank == 0 && op2->rank == 0)
3845 if (op1->rank == 0 && op2->rank != 0)
3847 e->rank = op2->rank;
3849 if (e->shape == NULL)
3850 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3853 if (op1->rank != 0 && op2->rank == 0)
3855 e->rank = op1->rank;
3857 if (e->shape == NULL)
3858 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3861 if (op1->rank != 0 && op2->rank != 0)
3863 if (op1->rank == op2->rank)
3865 e->rank = op1->rank;
3866 if (e->shape == NULL)
3868 t = compare_shapes (op1, op2);
3872 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3877 /* Allow higher level expressions to work. */
3880 /* Try user-defined operators, and otherwise throw an error. */
3881 dual_locus_error = true;
3883 _("Inconsistent ranks for operator at %%L and %%L"));
3890 case INTRINSIC_PARENTHESES:
3892 case INTRINSIC_UPLUS:
3893 case INTRINSIC_UMINUS:
3894 /* Simply copy arrayness attribute */
3895 e->rank = op1->rank;
3897 if (e->shape == NULL)
3898 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3906 /* Attempt to simplify the expression. */
3909 t = gfc_simplify_expr (e, 0);
3910 /* Some calls do not succeed in simplification and return FAILURE
3911 even though there is no error; e.g. variable references to
3912 PARAMETER arrays. */
3913 if (!gfc_is_constant_expr (e))
3922 if (gfc_extend_expr (e, &real_error) == SUCCESS)
3929 if (dual_locus_error)
3930 gfc_error (msg, &op1->where, &op2->where);
3932 gfc_error (msg, &e->where);
3938 /************** Array resolution subroutines **************/
3941 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3944 /* Compare two integer expressions. */
3947 compare_bound (gfc_expr *a, gfc_expr *b)
3951 if (a == NULL || a->expr_type != EXPR_CONSTANT
3952 || b == NULL || b->expr_type != EXPR_CONSTANT)
3955 /* If either of the types isn't INTEGER, we must have
3956 raised an error earlier. */
3958 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3961 i = mpz_cmp (a->value.integer, b->value.integer);
3971 /* Compare an integer expression with an integer. */
3974 compare_bound_int (gfc_expr *a, int b)
3978 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3981 if (a->ts.type != BT_INTEGER)
3982 gfc_internal_error ("compare_bound_int(): Bad expression");
3984 i = mpz_cmp_si (a->value.integer, b);
3994 /* Compare an integer expression with a mpz_t. */
3997 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4001 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4004 if (a->ts.type != BT_INTEGER)
4005 gfc_internal_error ("compare_bound_int(): Bad expression");
4007 i = mpz_cmp (a->value.integer, b);
4017 /* Compute the last value of a sequence given by a triplet.
4018 Return 0 if it wasn't able to compute the last value, or if the
4019 sequence if empty, and 1 otherwise. */
4022 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4023 gfc_expr *stride, mpz_t last)
4027 if (start == NULL || start->expr_type != EXPR_CONSTANT
4028 || end == NULL || end->expr_type != EXPR_CONSTANT
4029 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4032 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4033 || (stride != NULL && stride->ts.type != BT_INTEGER))
4036 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
4038 if (compare_bound (start, end) == CMP_GT)
4040 mpz_set (last, end->value.integer);
4044 if (compare_bound_int (stride, 0) == CMP_GT)
4046 /* Stride is positive */
4047 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4052 /* Stride is negative */
4053 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4058 mpz_sub (rem, end->value.integer, start->value.integer);
4059 mpz_tdiv_r (rem, rem, stride->value.integer);
4060 mpz_sub (last, end->value.integer, rem);
4067 /* Compare a single dimension of an array reference to the array
4071 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4075 if (ar->dimen_type[i] == DIMEN_STAR)
4077 gcc_assert (ar->stride[i] == NULL);
4078 /* This implies [*] as [*:] and [*:3] are not possible. */
4079 if (ar->start[i] == NULL)
4081 gcc_assert (ar->end[i] == NULL);
4086 /* Given start, end and stride values, calculate the minimum and
4087 maximum referenced indexes. */
4089 switch (ar->dimen_type[i])
4096 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4099 gfc_warning ("Array reference at %L is out of bounds "
4100 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4101 mpz_get_si (ar->start[i]->value.integer),
4102 mpz_get_si (as->lower[i]->value.integer), i+1);
4104 gfc_warning ("Array reference at %L is out of bounds "
4105 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4106 mpz_get_si (ar->start[i]->value.integer),
4107 mpz_get_si (as->lower[i]->value.integer),
4111 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4114 gfc_warning ("Array reference at %L is out of bounds "
4115 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4116 mpz_get_si (ar->start[i]->value.integer),
4117 mpz_get_si (as->upper[i]->value.integer), i+1);
4119 gfc_warning ("Array reference at %L is out of bounds "
4120 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4121 mpz_get_si (ar->start[i]->value.integer),
4122 mpz_get_si (as->upper[i]->value.integer),
4131 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4132 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4134 comparison comp_start_end = compare_bound (AR_START, AR_END);
4136 /* Check for zero stride, which is not allowed. */
4137 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4139 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4143 /* if start == len || (stride > 0 && start < len)
4144 || (stride < 0 && start > len),
4145 then the array section contains at least one element. In this
4146 case, there is an out-of-bounds access if
4147 (start < lower || start > upper). */
4148 if (compare_bound (AR_START, AR_END) == CMP_EQ
4149 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4150 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4151 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4152 && comp_start_end == CMP_GT))
4154 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4156 gfc_warning ("Lower array reference at %L is out of bounds "
4157 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4158 mpz_get_si (AR_START->value.integer),
4159 mpz_get_si (as->lower[i]->value.integer), i+1);
4162 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4164 gfc_warning ("Lower array reference at %L is out of bounds "
4165 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4166 mpz_get_si (AR_START->value.integer),
4167 mpz_get_si (as->upper[i]->value.integer), i+1);
4172 /* If we can compute the highest index of the array section,
4173 then it also has to be between lower and upper. */
4174 mpz_init (last_value);
4175 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4178 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4180 gfc_warning ("Upper array reference at %L is out of bounds "
4181 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4182 mpz_get_si (last_value),
4183 mpz_get_si (as->lower[i]->value.integer), i+1);
4184 mpz_clear (last_value);
4187 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4189 gfc_warning ("Upper array reference at %L is out of bounds "
4190 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4191 mpz_get_si (last_value),
4192 mpz_get_si (as->upper[i]->value.integer), i+1);
4193 mpz_clear (last_value);
4197 mpz_clear (last_value);
4205 gfc_internal_error ("check_dimension(): Bad array reference");
4212 /* Compare an array reference with an array specification. */
4215 compare_spec_to_ref (gfc_array_ref *ar)
4222 /* TODO: Full array sections are only allowed as actual parameters. */
4223 if (as->type == AS_ASSUMED_SIZE
4224 && (/*ar->type == AR_FULL
4225 ||*/ (ar->type == AR_SECTION
4226 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4228 gfc_error ("Rightmost upper bound of assumed size array section "
4229 "not specified at %L", &ar->where);
4233 if (ar->type == AR_FULL)
4236 if (as->rank != ar->dimen)
4238 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4239 &ar->where, ar->dimen, as->rank);
4243 /* ar->codimen == 0 is a local array. */
4244 if (as->corank != ar->codimen && ar->codimen != 0)
4246 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4247 &ar->where, ar->codimen, as->corank);
4251 for (i = 0; i < as->rank; i++)
4252 if (check_dimension (i, ar, as) == FAILURE)
4255 /* Local access has no coarray spec. */
4256 if (ar->codimen != 0)
4257 for (i = as->rank; i < as->rank + as->corank; i++)
4259 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
4261 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4262 i + 1 - as->rank, &ar->where);
4265 if (check_dimension (i, ar, as) == FAILURE)
4273 /* Resolve one part of an array index. */
4276 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4277 int force_index_integer_kind)
4284 if (gfc_resolve_expr (index) == FAILURE)
4287 if (check_scalar && index->rank != 0)
4289 gfc_error ("Array index at %L must be scalar", &index->where);
4293 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4295 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4296 &index->where, gfc_basic_typename (index->ts.type));
4300 if (index->ts.type == BT_REAL)
4301 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
4302 &index->where) == FAILURE)
4305 if ((index->ts.kind != gfc_index_integer_kind
4306 && force_index_integer_kind)
4307 || index->ts.type != BT_INTEGER)
4310 ts.type = BT_INTEGER;
4311 ts.kind = gfc_index_integer_kind;
4313 gfc_convert_type_warn (index, &ts, 2, 0);
4319 /* Resolve one part of an array index. */
4322 gfc_resolve_index (gfc_expr *index, int check_scalar)
4324 return gfc_resolve_index_1 (index, check_scalar, 1);
4327 /* Resolve a dim argument to an intrinsic function. */
4330 gfc_resolve_dim_arg (gfc_expr *dim)
4335 if (gfc_resolve_expr (dim) == FAILURE)
4340 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4345 if (dim->ts.type != BT_INTEGER)
4347 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4351 if (dim->ts.kind != gfc_index_integer_kind)
4356 ts.type = BT_INTEGER;
4357 ts.kind = gfc_index_integer_kind;
4359 gfc_convert_type_warn (dim, &ts, 2, 0);
4365 /* Given an expression that contains array references, update those array
4366 references to point to the right array specifications. While this is
4367 filled in during matching, this information is difficult to save and load
4368 in a module, so we take care of it here.
4370 The idea here is that the original array reference comes from the
4371 base symbol. We traverse the list of reference structures, setting
4372 the stored reference to references. Component references can
4373 provide an additional array specification. */
4376 find_array_spec (gfc_expr *e)
4380 gfc_symbol *derived;
4383 if (e->symtree->n.sym->ts.type == BT_CLASS)
4384 as = CLASS_DATA (e->symtree->n.sym)->as;
4386 as = e->symtree->n.sym->as;
4389 for (ref = e->ref; ref; ref = ref->next)
4394 gfc_internal_error ("find_array_spec(): Missing spec");
4401 if (derived == NULL)
4402 derived = e->symtree->n.sym->ts.u.derived;
4404 if (derived->attr.is_class)
4405 derived = derived->components->ts.u.derived;
4407 c = derived->components;
4409 for (; c; c = c->next)
4410 if (c == ref->u.c.component)
4412 /* Track the sequence of component references. */
4413 if (c->ts.type == BT_DERIVED)
4414 derived = c->ts.u.derived;
4419 gfc_internal_error ("find_array_spec(): Component not found");
4421 if (c->attr.dimension)
4424 gfc_internal_error ("find_array_spec(): unused as(1)");
4435 gfc_internal_error ("find_array_spec(): unused as(2)");
4439 /* Resolve an array reference. */
4442 resolve_array_ref (gfc_array_ref *ar)
4444 int i, check_scalar;
4447 for (i = 0; i < ar->dimen + ar->codimen; i++)
4449 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4451 /* Do not force gfc_index_integer_kind for the start. We can
4452 do fine with any integer kind. This avoids temporary arrays
4453 created for indexing with a vector. */
4454 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4456 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4458 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4463 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4467 ar->dimen_type[i] = DIMEN_ELEMENT;
4471 ar->dimen_type[i] = DIMEN_VECTOR;
4472 if (e->expr_type == EXPR_VARIABLE
4473 && e->symtree->n.sym->ts.type == BT_DERIVED)
4474 ar->start[i] = gfc_get_parentheses (e);
4478 gfc_error ("Array index at %L is an array of rank %d",
4479 &ar->c_where[i], e->rank);
4483 /* Fill in the upper bound, which may be lower than the
4484 specified one for something like a(2:10:5), which is
4485 identical to a(2:7:5). Only relevant for strides not equal
4487 if (ar->dimen_type[i] == DIMEN_RANGE
4488 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4489 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0)
4493 if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4495 if (ar->end[i] == NULL)
4498 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4500 mpz_set (ar->end[i]->value.integer, end);
4502 else if (ar->end[i]->ts.type == BT_INTEGER
4503 && ar->end[i]->expr_type == EXPR_CONSTANT)
4505 mpz_set (ar->end[i]->value.integer, end);
4516 if (ar->type == AR_FULL && ar->as->rank == 0)
4517 ar->type = AR_ELEMENT;
4519 /* If the reference type is unknown, figure out what kind it is. */
4521 if (ar->type == AR_UNKNOWN)
4523 ar->type = AR_ELEMENT;
4524 for (i = 0; i < ar->dimen; i++)
4525 if (ar->dimen_type[i] == DIMEN_RANGE
4526 || ar->dimen_type[i] == DIMEN_VECTOR)
4528 ar->type = AR_SECTION;
4533 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4541 resolve_substring (gfc_ref *ref)
4543 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4545 if (ref->u.ss.start != NULL)
4547 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4550 if (ref->u.ss.start->ts.type != BT_INTEGER)
4552 gfc_error ("Substring start index at %L must be of type INTEGER",
4553 &ref->u.ss.start->where);
4557 if (ref->u.ss.start->rank != 0)
4559 gfc_error ("Substring start index at %L must be scalar",
4560 &ref->u.ss.start->where);
4564 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4565 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4566 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4568 gfc_error ("Substring start index at %L is less than one",
4569 &ref->u.ss.start->where);
4574 if (ref->u.ss.end != NULL)
4576 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4579 if (ref->u.ss.end->ts.type != BT_INTEGER)
4581 gfc_error ("Substring end index at %L must be of type INTEGER",
4582 &ref->u.ss.end->where);
4586 if (ref->u.ss.end->rank != 0)
4588 gfc_error ("Substring end index at %L must be scalar",
4589 &ref->u.ss.end->where);
4593 if (ref->u.ss.length != NULL
4594 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4595 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4596 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4598 gfc_error ("Substring end index at %L exceeds the string length",
4599 &ref->u.ss.start->where);
4603 if (compare_bound_mpz_t (ref->u.ss.end,
4604 gfc_integer_kinds[k].huge) == CMP_GT
4605 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4606 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4608 gfc_error ("Substring end index at %L is too large",
4609 &ref->u.ss.end->where);
4618 /* This function supplies missing substring charlens. */
4621 gfc_resolve_substring_charlen (gfc_expr *e)
4624 gfc_expr *start, *end;
4626 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4627 if (char_ref->type == REF_SUBSTRING)
4633 gcc_assert (char_ref->next == NULL);
4637 if (e->ts.u.cl->length)
4638 gfc_free_expr (e->ts.u.cl->length);
4639 else if (e->expr_type == EXPR_VARIABLE
4640 && e->symtree->n.sym->attr.dummy)
4644 e->ts.type = BT_CHARACTER;
4645 e->ts.kind = gfc_default_character_kind;
4648 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4650 if (char_ref->u.ss.start)
4651 start = gfc_copy_expr (char_ref->u.ss.start);
4653 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4655 if (char_ref->u.ss.end)
4656 end = gfc_copy_expr (char_ref->u.ss.end);
4657 else if (e->expr_type == EXPR_VARIABLE)
4658 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4665 /* Length = (end - start +1). */
4666 e->ts.u.cl->length = gfc_subtract (end, start);
4667 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4668 gfc_get_int_expr (gfc_default_integer_kind,
4671 e->ts.u.cl->length->ts.type = BT_INTEGER;
4672 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4674 /* Make sure that the length is simplified. */
4675 gfc_simplify_expr (e->ts.u.cl->length, 1);
4676 gfc_resolve_expr (e->ts.u.cl->length);
4680 /* Resolve subtype references. */
4683 resolve_ref (gfc_expr *expr)
4685 int current_part_dimension, n_components, seen_part_dimension;
4688 for (ref = expr->ref; ref; ref = ref->next)
4689 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4691 find_array_spec (expr);
4695 for (ref = expr->ref; ref; ref = ref->next)
4699 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4707 resolve_substring (ref);
4711 /* Check constraints on part references. */
4713 current_part_dimension = 0;
4714 seen_part_dimension = 0;
4717 for (ref = expr->ref; ref; ref = ref->next)
4722 switch (ref->u.ar.type)
4725 /* Coarray scalar. */
4726 if (ref->u.ar.as->rank == 0)
4728 current_part_dimension = 0;
4733 current_part_dimension = 1;
4737 current_part_dimension = 0;
4741 gfc_internal_error ("resolve_ref(): Bad array reference");
4747 if (current_part_dimension || seen_part_dimension)
4750 if (ref->u.c.component->attr.pointer
4751 || ref->u.c.component->attr.proc_pointer)
4753 gfc_error ("Component to the right of a part reference "
4754 "with nonzero rank must not have the POINTER "
4755 "attribute at %L", &expr->where);
4758 else if (ref->u.c.component->attr.allocatable)
4760 gfc_error ("Component to the right of a part reference "
4761 "with nonzero rank must not have the ALLOCATABLE "
4762 "attribute at %L", &expr->where);
4774 if (((ref->type == REF_COMPONENT && n_components > 1)
4775 || ref->next == NULL)
4776 && current_part_dimension
4777 && seen_part_dimension)
4779 gfc_error ("Two or more part references with nonzero rank must "
4780 "not be specified at %L", &expr->where);
4784 if (ref->type == REF_COMPONENT)
4786 if (current_part_dimension)
4787 seen_part_dimension = 1;
4789 /* reset to make sure */
4790 current_part_dimension = 0;
4798 /* Given an expression, determine its shape. This is easier than it sounds.
4799 Leaves the shape array NULL if it is not possible to determine the shape. */
4802 expression_shape (gfc_expr *e)
4804 mpz_t array[GFC_MAX_DIMENSIONS];
4807 if (e->rank == 0 || e->shape != NULL)
4810 for (i = 0; i < e->rank; i++)
4811 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4814 e->shape = gfc_get_shape (e->rank);
4816 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4821 for (i--; i >= 0; i--)
4822 mpz_clear (array[i]);
4826 /* Given a variable expression node, compute the rank of the expression by
4827 examining the base symbol and any reference structures it may have. */
4830 expression_rank (gfc_expr *e)
4835 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4836 could lead to serious confusion... */
4837 gcc_assert (e->expr_type != EXPR_COMPCALL);
4841 if (e->expr_type == EXPR_ARRAY)
4843 /* Constructors can have a rank different from one via RESHAPE(). */
4845 if (e->symtree == NULL)
4851 e->rank = (e->symtree->n.sym->as == NULL)
4852 ? 0 : e->symtree->n.sym->as->rank;
4858 for (ref = e->ref; ref; ref = ref->next)
4860 if (ref->type != REF_ARRAY)
4863 if (ref->u.ar.type == AR_FULL)
4865 rank = ref->u.ar.as->rank;
4869 if (ref->u.ar.type == AR_SECTION)
4871 /* Figure out the rank of the section. */
4873 gfc_internal_error ("expression_rank(): Two array specs");
4875 for (i = 0; i < ref->u.ar.dimen; i++)
4876 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4877 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4887 expression_shape (e);
4891 /* Resolve a variable expression. */
4894 resolve_variable (gfc_expr *e)
4901 if (e->symtree == NULL)
4903 sym = e->symtree->n.sym;
4905 /* If this is an associate-name, it may be parsed with an array reference
4906 in error even though the target is scalar. Fail directly in this case. */
4907 if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
4910 /* On the other hand, the parser may not have known this is an array;
4911 in this case, we have to add a FULL reference. */
4912 if (sym->assoc && sym->attr.dimension && !e->ref)
4914 e->ref = gfc_get_ref ();
4915 e->ref->type = REF_ARRAY;
4916 e->ref->u.ar.type = AR_FULL;
4917 e->ref->u.ar.dimen = 0;
4920 if (e->ref && resolve_ref (e) == FAILURE)
4923 if (sym->attr.flavor == FL_PROCEDURE
4924 && (!sym->attr.function
4925 || (sym->attr.function && sym->result
4926 && sym->result->attr.proc_pointer
4927 && !sym->result->attr.function)))
4929 e->ts.type = BT_PROCEDURE;
4930 goto resolve_procedure;
4933 if (sym->ts.type != BT_UNKNOWN)
4934 gfc_variable_attr (e, &e->ts);
4937 /* Must be a simple variable reference. */
4938 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4943 if (check_assumed_size_reference (sym, e))
4946 /* Deal with forward references to entries during resolve_code, to
4947 satisfy, at least partially, 12.5.2.5. */
4948 if (gfc_current_ns->entries
4949 && current_entry_id == sym->entry_id
4952 && cs_base->current->op != EXEC_ENTRY)
4954 gfc_entry_list *entry;
4955 gfc_formal_arglist *formal;
4959 /* If the symbol is a dummy... */
4960 if (sym->attr.dummy && sym->ns == gfc_current_ns)
4962 entry = gfc_current_ns->entries;
4965 /* ...test if the symbol is a parameter of previous entries. */
4966 for (; entry && entry->id <= current_entry_id; entry = entry->next)
4967 for (formal = entry->sym->formal; formal; formal = formal->next)
4969 if (formal->sym && sym->name == formal->sym->name)
4973 /* If it has not been seen as a dummy, this is an error. */
4976 if (specification_expr)
4977 gfc_error ("Variable '%s', used in a specification expression"
4978 ", is referenced at %L before the ENTRY statement "
4979 "in which it is a parameter",
4980 sym->name, &cs_base->current->loc);
4982 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4983 "statement in which it is a parameter",
4984 sym->name, &cs_base->current->loc);
4989 /* Now do the same check on the specification expressions. */
4990 specification_expr = 1;
4991 if (sym->ts.type == BT_CHARACTER
4992 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
4996 for (n = 0; n < sym->as->rank; n++)
4998 specification_expr = 1;
4999 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
5001 specification_expr = 1;
5002 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
5005 specification_expr = 0;
5008 /* Update the symbol's entry level. */
5009 sym->entry_id = current_entry_id + 1;
5012 /* If a symbol has been host_associated mark it. This is used latter,
5013 to identify if aliasing is possible via host association. */
5014 if (sym->attr.flavor == FL_VARIABLE
5015 && gfc_current_ns->parent
5016 && (gfc_current_ns->parent == sym->ns
5017 || (gfc_current_ns->parent->parent
5018 && gfc_current_ns->parent->parent == sym->ns)))
5019 sym->attr.host_assoc = 1;
5022 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
5025 /* F2008, C617 and C1229. */
5026 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5027 && gfc_is_coindexed (e))
5029 gfc_ref *ref, *ref2 = NULL;
5031 if (e->ts.type == BT_CLASS)
5033 gfc_error ("Polymorphic subobject of coindexed object at %L",
5038 for (ref = e->ref; ref; ref = ref->next)
5040 if (ref->type == REF_COMPONENT)
5042 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5046 for ( ; ref; ref = ref->next)
5047 if (ref->type == REF_COMPONENT)
5050 /* Expression itself is coindexed object. */
5054 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5055 for ( ; c; c = c->next)
5056 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5058 gfc_error ("Coindexed object with polymorphic allocatable "
5059 "subcomponent at %L", &e->where);
5070 /* Checks to see that the correct symbol has been host associated.
5071 The only situation where this arises is that in which a twice
5072 contained function is parsed after the host association is made.
5073 Therefore, on detecting this, change the symbol in the expression
5074 and convert the array reference into an actual arglist if the old
5075 symbol is a variable. */
5077 check_host_association (gfc_expr *e)
5079 gfc_symbol *sym, *old_sym;
5083 gfc_actual_arglist *arg, *tail = NULL;
5084 bool retval = e->expr_type == EXPR_FUNCTION;
5086 /* If the expression is the result of substitution in
5087 interface.c(gfc_extend_expr) because there is no way in
5088 which the host association can be wrong. */
5089 if (e->symtree == NULL
5090 || e->symtree->n.sym == NULL
5091 || e->user_operator)
5094 old_sym = e->symtree->n.sym;
5096 if (gfc_current_ns->parent
5097 && old_sym->ns != gfc_current_ns)
5099 /* Use the 'USE' name so that renamed module symbols are
5100 correctly handled. */
5101 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5103 if (sym && old_sym != sym
5104 && sym->ts.type == old_sym->ts.type
5105 && sym->attr.flavor == FL_PROCEDURE
5106 && sym->attr.contained)
5108 /* Clear the shape, since it might not be valid. */
5109 if (e->shape != NULL)
5111 for (n = 0; n < e->rank; n++)
5112 mpz_clear (e->shape[n]);
5114 gfc_free (e->shape);
5117 /* Give the expression the right symtree! */
5118 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5119 gcc_assert (st != NULL);
5121 if (old_sym->attr.flavor == FL_PROCEDURE
5122 || e->expr_type == EXPR_FUNCTION)
5124 /* Original was function so point to the new symbol, since
5125 the actual argument list is already attached to the
5127 e->value.function.esym = NULL;
5132 /* Original was variable so convert array references into
5133 an actual arglist. This does not need any checking now
5134 since gfc_resolve_function will take care of it. */
5135 e->value.function.actual = NULL;
5136 e->expr_type = EXPR_FUNCTION;
5139 /* Ambiguity will not arise if the array reference is not
5140 the last reference. */
5141 for (ref = e->ref; ref; ref = ref->next)
5142 if (ref->type == REF_ARRAY && ref->next == NULL)
5145 gcc_assert (ref->type == REF_ARRAY);
5147 /* Grab the start expressions from the array ref and
5148 copy them into actual arguments. */
5149 for (n = 0; n < ref->u.ar.dimen; n++)
5151 arg = gfc_get_actual_arglist ();
5152 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5153 if (e->value.function.actual == NULL)
5154 tail = e->value.function.actual = arg;
5162 /* Dump the reference list and set the rank. */
5163 gfc_free_ref_list (e->ref);
5165 e->rank = sym->as ? sym->as->rank : 0;
5168 gfc_resolve_expr (e);
5172 /* This might have changed! */
5173 return e->expr_type == EXPR_FUNCTION;
5178 gfc_resolve_character_operator (gfc_expr *e)
5180 gfc_expr *op1 = e->value.op.op1;
5181 gfc_expr *op2 = e->value.op.op2;
5182 gfc_expr *e1 = NULL;
5183 gfc_expr *e2 = NULL;
5185 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5187 if (op1->ts.u.cl && op1->ts.u.cl->length)
5188 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5189 else if (op1->expr_type == EXPR_CONSTANT)
5190 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5191 op1->value.character.length);
5193 if (op2->ts.u.cl && op2->ts.u.cl->length)
5194 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5195 else if (op2->expr_type == EXPR_CONSTANT)
5196 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5197 op2->value.character.length);
5199 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5204 e->ts.u.cl->length = gfc_add (e1, e2);
5205 e->ts.u.cl->length->ts.type = BT_INTEGER;
5206 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5207 gfc_simplify_expr (e->ts.u.cl->length, 0);
5208 gfc_resolve_expr (e->ts.u.cl->length);
5214 /* Ensure that an character expression has a charlen and, if possible, a
5215 length expression. */
5218 fixup_charlen (gfc_expr *e)
5220 /* The cases fall through so that changes in expression type and the need
5221 for multiple fixes are picked up. In all circumstances, a charlen should
5222 be available for the middle end to hang a backend_decl on. */
5223 switch (e->expr_type)
5226 gfc_resolve_character_operator (e);
5229 if (e->expr_type == EXPR_ARRAY)
5230 gfc_resolve_character_array_constructor (e);
5232 case EXPR_SUBSTRING:
5233 if (!e->ts.u.cl && e->ref)
5234 gfc_resolve_substring_charlen (e);
5238 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5245 /* Update an actual argument to include the passed-object for type-bound
5246 procedures at the right position. */
5248 static gfc_actual_arglist*
5249 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5252 gcc_assert (argpos > 0);
5256 gfc_actual_arglist* result;
5258 result = gfc_get_actual_arglist ();
5262 result->name = name;
5268 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5270 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5275 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5278 extract_compcall_passed_object (gfc_expr* e)
5282 gcc_assert (e->expr_type == EXPR_COMPCALL);
5284 if (e->value.compcall.base_object)
5285 po = gfc_copy_expr (e->value.compcall.base_object);
5288 po = gfc_get_expr ();
5289 po->expr_type = EXPR_VARIABLE;
5290 po->symtree = e->symtree;
5291 po->ref = gfc_copy_ref (e->ref);
5292 po->where = e->where;
5295 if (gfc_resolve_expr (po) == FAILURE)
5302 /* Update the arglist of an EXPR_COMPCALL expression to include the
5306 update_compcall_arglist (gfc_expr* e)
5309 gfc_typebound_proc* tbp;
5311 tbp = e->value.compcall.tbp;
5316 po = extract_compcall_passed_object (e);
5320 if (tbp->nopass || e->value.compcall.ignore_pass)
5326 gcc_assert (tbp->pass_arg_num > 0);
5327 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5335 /* Extract the passed object from a PPC call (a copy of it). */
5338 extract_ppc_passed_object (gfc_expr *e)
5343 po = gfc_get_expr ();
5344 po->expr_type = EXPR_VARIABLE;
5345 po->symtree = e->symtree;
5346 po->ref = gfc_copy_ref (e->ref);
5347 po->where = e->where;
5349 /* Remove PPC reference. */
5351 while ((*ref)->next)
5352 ref = &(*ref)->next;
5353 gfc_free_ref_list (*ref);
5356 if (gfc_resolve_expr (po) == FAILURE)
5363 /* Update the actual arglist of a procedure pointer component to include the
5367 update_ppc_arglist (gfc_expr* e)
5371 gfc_typebound_proc* tb;
5373 if (!gfc_is_proc_ptr_comp (e, &ppc))
5380 else if (tb->nopass)
5383 po = extract_ppc_passed_object (e);
5389 gfc_error ("Passed-object at %L must be scalar", &e->where);
5393 gcc_assert (tb->pass_arg_num > 0);
5394 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5402 /* Check that the object a TBP is called on is valid, i.e. it must not be
5403 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5406 check_typebound_baseobject (gfc_expr* e)
5410 base = extract_compcall_passed_object (e);
5414 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5416 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5418 gfc_error ("Base object for type-bound procedure call at %L is of"
5419 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5423 /* If the procedure called is NOPASS, the base object must be scalar. */
5424 if (e->value.compcall.tbp->nopass && base->rank > 0)
5426 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5427 " be scalar", &e->where);
5431 /* FIXME: Remove once PR 41177 (this problem) is fixed completely. */
5434 gfc_error ("Non-scalar base object at %L currently not implemented",
5443 /* Resolve a call to a type-bound procedure, either function or subroutine,
5444 statically from the data in an EXPR_COMPCALL expression. The adapted
5445 arglist and the target-procedure symtree are returned. */
5448 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5449 gfc_actual_arglist** actual)
5451 gcc_assert (e->expr_type == EXPR_COMPCALL);
5452 gcc_assert (!e->value.compcall.tbp->is_generic);
5454 /* Update the actual arglist for PASS. */
5455 if (update_compcall_arglist (e) == FAILURE)
5458 *actual = e->value.compcall.actual;
5459 *target = e->value.compcall.tbp->u.specific;
5461 gfc_free_ref_list (e->ref);
5463 e->value.compcall.actual = NULL;
5469 /* Get the ultimate declared type from an expression. In addition,
5470 return the last class/derived type reference and the copy of the
5473 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5476 gfc_symbol *declared;
5483 *new_ref = gfc_copy_ref (e->ref);
5485 for (ref = e->ref; ref; ref = ref->next)
5487 if (ref->type != REF_COMPONENT)
5490 if (ref->u.c.component->ts.type == BT_CLASS
5491 || ref->u.c.component->ts.type == BT_DERIVED)
5493 declared = ref->u.c.component->ts.u.derived;
5499 if (declared == NULL)
5500 declared = e->symtree->n.sym->ts.u.derived;
5506 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5507 which of the specific bindings (if any) matches the arglist and transform
5508 the expression into a call of that binding. */
5511 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5513 gfc_typebound_proc* genproc;
5514 const char* genname;
5516 gfc_symbol *derived;
5518 gcc_assert (e->expr_type == EXPR_COMPCALL);
5519 genname = e->value.compcall.name;
5520 genproc = e->value.compcall.tbp;
5522 if (!genproc->is_generic)
5525 /* Try the bindings on this type and in the inheritance hierarchy. */
5526 for (; genproc; genproc = genproc->overridden)
5530 gcc_assert (genproc->is_generic);
5531 for (g = genproc->u.generic; g; g = g->next)
5534 gfc_actual_arglist* args;
5537 gcc_assert (g->specific);
5539 if (g->specific->error)
5542 target = g->specific->u.specific->n.sym;
5544 /* Get the right arglist by handling PASS/NOPASS. */
5545 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5546 if (!g->specific->nopass)
5549 po = extract_compcall_passed_object (e);
5553 gcc_assert (g->specific->pass_arg_num > 0);
5554 gcc_assert (!g->specific->error);
5555 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5556 g->specific->pass_arg);
5558 resolve_actual_arglist (args, target->attr.proc,
5559 is_external_proc (target) && !target->formal);
5561 /* Check if this arglist matches the formal. */
5562 matches = gfc_arglist_matches_symbol (&args, target);
5564 /* Clean up and break out of the loop if we've found it. */
5565 gfc_free_actual_arglist (args);
5568 e->value.compcall.tbp = g->specific;
5569 genname = g->specific_st->name;
5570 /* Pass along the name for CLASS methods, where the vtab
5571 procedure pointer component has to be referenced. */
5579 /* Nothing matching found! */
5580 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5581 " '%s' at %L", genname, &e->where);
5585 /* Make sure that we have the right specific instance for the name. */
5586 derived = get_declared_from_expr (NULL, NULL, e);
5588 st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where);
5590 e->value.compcall.tbp = st->n.tb;
5596 /* Resolve a call to a type-bound subroutine. */
5599 resolve_typebound_call (gfc_code* c, const char **name)
5601 gfc_actual_arglist* newactual;
5602 gfc_symtree* target;
5604 /* Check that's really a SUBROUTINE. */
5605 if (!c->expr1->value.compcall.tbp->subroutine)
5607 gfc_error ("'%s' at %L should be a SUBROUTINE",
5608 c->expr1->value.compcall.name, &c->loc);
5612 if (check_typebound_baseobject (c->expr1) == FAILURE)
5615 /* Pass along the name for CLASS methods, where the vtab
5616 procedure pointer component has to be referenced. */
5618 *name = c->expr1->value.compcall.name;
5620 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5623 /* Transform into an ordinary EXEC_CALL for now. */
5625 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5628 c->ext.actual = newactual;
5629 c->symtree = target;
5630 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5632 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5634 gfc_free_expr (c->expr1);
5635 c->expr1 = gfc_get_expr ();
5636 c->expr1->expr_type = EXPR_FUNCTION;
5637 c->expr1->symtree = target;
5638 c->expr1->where = c->loc;
5640 return resolve_call (c);
5644 /* Resolve a component-call expression. */
5646 resolve_compcall (gfc_expr* e, const char **name)
5648 gfc_actual_arglist* newactual;
5649 gfc_symtree* target;
5651 /* Check that's really a FUNCTION. */
5652 if (!e->value.compcall.tbp->function)
5654 gfc_error ("'%s' at %L should be a FUNCTION",
5655 e->value.compcall.name, &e->where);
5659 /* These must not be assign-calls! */
5660 gcc_assert (!e->value.compcall.assign);
5662 if (check_typebound_baseobject (e) == FAILURE)
5665 /* Pass along the name for CLASS methods, where the vtab
5666 procedure pointer component has to be referenced. */
5668 *name = e->value.compcall.name;
5670 if (resolve_typebound_generic_call (e, name) == FAILURE)
5672 gcc_assert (!e->value.compcall.tbp->is_generic);
5674 /* Take the rank from the function's symbol. */
5675 if (e->value.compcall.tbp->u.specific->n.sym->as)
5676 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5678 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5679 arglist to the TBP's binding target. */
5681 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5684 e->value.function.actual = newactual;
5685 e->value.function.name = NULL;
5686 e->value.function.esym = target->n.sym;
5687 e->value.function.isym = NULL;
5688 e->symtree = target;
5689 e->ts = target->n.sym->ts;
5690 e->expr_type = EXPR_FUNCTION;
5692 /* Resolution is not necessary if this is a class subroutine; this
5693 function only has to identify the specific proc. Resolution of
5694 the call will be done next in resolve_typebound_call. */
5695 return gfc_resolve_expr (e);
5700 /* Resolve a typebound function, or 'method'. First separate all
5701 the non-CLASS references by calling resolve_compcall directly. */
5704 resolve_typebound_function (gfc_expr* e)
5706 gfc_symbol *declared;
5717 /* Deal with typebound operators for CLASS objects. */
5718 expr = e->value.compcall.base_object;
5719 if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
5720 && e->value.compcall.name)
5722 /* Since the typebound operators are generic, we have to ensure
5723 that any delays in resolution are corrected and that the vtab
5725 ts = expr->symtree->n.sym->ts;
5726 declared = ts.u.derived;
5727 c = gfc_find_component (declared, "$vptr", true, true);
5728 if (c->ts.u.derived == NULL)
5729 c->ts.u.derived = gfc_find_derived_vtab (declared);
5731 if (resolve_compcall (e, &name) == FAILURE)
5734 /* Use the generic name if it is there. */
5735 name = name ? name : e->value.function.esym->name;
5736 e->symtree = expr->symtree;
5737 expr->symtree->n.sym->ts.u.derived = declared;
5738 gfc_add_component_ref (e, "$vptr");
5739 gfc_add_component_ref (e, name);
5740 e->value.function.esym = NULL;
5745 return resolve_compcall (e, NULL);
5747 if (resolve_ref (e) == FAILURE)
5750 /* Get the CLASS declared type. */
5751 declared = get_declared_from_expr (&class_ref, &new_ref, e);
5753 /* Weed out cases of the ultimate component being a derived type. */
5754 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5755 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5757 gfc_free_ref_list (new_ref);
5758 return resolve_compcall (e, NULL);
5761 c = gfc_find_component (declared, "$data", true, true);
5762 declared = c->ts.u.derived;
5764 /* Treat the call as if it is a typebound procedure, in order to roll
5765 out the correct name for the specific function. */
5766 if (resolve_compcall (e, &name) == FAILURE)
5770 /* Then convert the expression to a procedure pointer component call. */
5771 e->value.function.esym = NULL;
5777 /* '$vptr' points to the vtab, which contains the procedure pointers. */
5778 gfc_add_component_ref (e, "$vptr");
5779 gfc_add_component_ref (e, name);
5781 /* Recover the typespec for the expression. This is really only
5782 necessary for generic procedures, where the additional call
5783 to gfc_add_component_ref seems to throw the collection of the
5784 correct typespec. */
5789 /* Resolve a typebound subroutine, or 'method'. First separate all
5790 the non-CLASS references by calling resolve_typebound_call
5794 resolve_typebound_subroutine (gfc_code *code)
5796 gfc_symbol *declared;
5805 st = code->expr1->symtree;
5807 /* Deal with typebound operators for CLASS objects. */
5808 expr = code->expr1->value.compcall.base_object;
5809 if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
5810 && code->expr1->value.compcall.name)
5812 /* Since the typebound operators are generic, we have to ensure
5813 that any delays in resolution are corrected and that the vtab
5815 ts = expr->symtree->n.sym->ts;
5816 declared = ts.u.derived;
5817 c = gfc_find_component (declared, "$vptr", true, true);
5818 if (c->ts.u.derived == NULL)
5819 c->ts.u.derived = gfc_find_derived_vtab (declared);
5821 if (resolve_typebound_call (code, &name) == FAILURE)
5824 /* Use the generic name if it is there. */
5825 name = name ? name : code->expr1->value.function.esym->name;
5826 code->expr1->symtree = expr->symtree;
5827 expr->symtree->n.sym->ts.u.derived = declared;
5828 gfc_add_component_ref (code->expr1, "$vptr");
5829 gfc_add_component_ref (code->expr1, name);
5830 code->expr1->value.function.esym = NULL;
5835 return resolve_typebound_call (code, NULL);
5837 if (resolve_ref (code->expr1) == FAILURE)
5840 /* Get the CLASS declared type. */
5841 get_declared_from_expr (&class_ref, &new_ref, code->expr1);
5843 /* Weed out cases of the ultimate component being a derived type. */
5844 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5845 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5847 gfc_free_ref_list (new_ref);
5848 return resolve_typebound_call (code, NULL);
5851 if (resolve_typebound_call (code, &name) == FAILURE)
5853 ts = code->expr1->ts;
5855 /* Then convert the expression to a procedure pointer component call. */
5856 code->expr1->value.function.esym = NULL;
5857 code->expr1->symtree = st;
5860 code->expr1->ref = new_ref;
5862 /* '$vptr' points to the vtab, which contains the procedure pointers. */
5863 gfc_add_component_ref (code->expr1, "$vptr");
5864 gfc_add_component_ref (code->expr1, name);
5866 /* Recover the typespec for the expression. This is really only
5867 necessary for generic procedures, where the additional call
5868 to gfc_add_component_ref seems to throw the collection of the
5869 correct typespec. */
5870 code->expr1->ts = ts;
5875 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5878 resolve_ppc_call (gfc_code* c)
5880 gfc_component *comp;
5883 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
5886 c->resolved_sym = c->expr1->symtree->n.sym;
5887 c->expr1->expr_type = EXPR_VARIABLE;
5889 if (!comp->attr.subroutine)
5890 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
5892 if (resolve_ref (c->expr1) == FAILURE)
5895 if (update_ppc_arglist (c->expr1) == FAILURE)
5898 c->ext.actual = c->expr1->value.compcall.actual;
5900 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
5901 comp->formal == NULL) == FAILURE)
5904 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
5910 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5913 resolve_expr_ppc (gfc_expr* e)
5915 gfc_component *comp;
5918 b = gfc_is_proc_ptr_comp (e, &comp);
5921 /* Convert to EXPR_FUNCTION. */
5922 e->expr_type = EXPR_FUNCTION;
5923 e->value.function.isym = NULL;
5924 e->value.function.actual = e->value.compcall.actual;
5926 if (comp->as != NULL)
5927 e->rank = comp->as->rank;
5929 if (!comp->attr.function)
5930 gfc_add_function (&comp->attr, comp->name, &e->where);
5932 if (resolve_ref (e) == FAILURE)
5935 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
5936 comp->formal == NULL) == FAILURE)
5939 if (update_ppc_arglist (e) == FAILURE)
5942 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
5949 gfc_is_expandable_expr (gfc_expr *e)
5951 gfc_constructor *con;
5953 if (e->expr_type == EXPR_ARRAY)
5955 /* Traverse the constructor looking for variables that are flavor
5956 parameter. Parameters must be expanded since they are fully used at
5958 con = gfc_constructor_first (e->value.constructor);
5959 for (; con; con = gfc_constructor_next (con))
5961 if (con->expr->expr_type == EXPR_VARIABLE
5962 && con->expr->symtree
5963 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
5964 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
5966 if (con->expr->expr_type == EXPR_ARRAY
5967 && gfc_is_expandable_expr (con->expr))
5975 /* Resolve an expression. That is, make sure that types of operands agree
5976 with their operators, intrinsic operators are converted to function calls
5977 for overloaded types and unresolved function references are resolved. */
5980 gfc_resolve_expr (gfc_expr *e)
5988 /* inquiry_argument only applies to variables. */
5989 inquiry_save = inquiry_argument;
5990 if (e->expr_type != EXPR_VARIABLE)
5991 inquiry_argument = false;
5993 switch (e->expr_type)
5996 t = resolve_operator (e);
6002 if (check_host_association (e))
6003 t = resolve_function (e);
6006 t = resolve_variable (e);
6008 expression_rank (e);
6011 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6012 && e->ref->type != REF_SUBSTRING)
6013 gfc_resolve_substring_charlen (e);
6018 t = resolve_typebound_function (e);
6021 case EXPR_SUBSTRING:
6022 t = resolve_ref (e);
6031 t = resolve_expr_ppc (e);
6036 if (resolve_ref (e) == FAILURE)
6039 t = gfc_resolve_array_constructor (e);
6040 /* Also try to expand a constructor. */
6043 expression_rank (e);
6044 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6045 gfc_expand_constructor (e, false);
6048 /* This provides the opportunity for the length of constructors with
6049 character valued function elements to propagate the string length
6050 to the expression. */
6051 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6053 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6054 here rather then add a duplicate test for it above. */
6055 gfc_expand_constructor (e, false);
6056 t = gfc_resolve_character_array_constructor (e);
6061 case EXPR_STRUCTURE:
6062 t = resolve_ref (e);
6066 t = resolve_structure_cons (e, 0);
6070 t = gfc_simplify_expr (e, 0);
6074 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6077 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6080 inquiry_argument = inquiry_save;
6086 /* Resolve an expression from an iterator. They must be scalar and have
6087 INTEGER or (optionally) REAL type. */
6090 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6091 const char *name_msgid)
6093 if (gfc_resolve_expr (expr) == FAILURE)
6096 if (expr->rank != 0)
6098 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6102 if (expr->ts.type != BT_INTEGER)
6104 if (expr->ts.type == BT_REAL)
6107 return gfc_notify_std (GFC_STD_F95_DEL,
6108 "Deleted feature: %s at %L must be integer",
6109 _(name_msgid), &expr->where);
6112 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6119 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6127 /* Resolve the expressions in an iterator structure. If REAL_OK is
6128 false allow only INTEGER type iterators, otherwise allow REAL types. */
6131 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6133 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6137 if (gfc_check_vardef_context (iter->var, false, _("iterator variable"))
6141 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6142 "Start expression in DO loop") == FAILURE)
6145 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6146 "End expression in DO loop") == FAILURE)
6149 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6150 "Step expression in DO loop") == FAILURE)
6153 if (iter->step->expr_type == EXPR_CONSTANT)
6155 if ((iter->step->ts.type == BT_INTEGER
6156 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6157 || (iter->step->ts.type == BT_REAL
6158 && mpfr_sgn (iter->step->value.real) == 0))
6160 gfc_error ("Step expression in DO loop at %L cannot be zero",
6161 &iter->step->where);
6166 /* Convert start, end, and step to the same type as var. */
6167 if (iter->start->ts.kind != iter->var->ts.kind
6168 || iter->start->ts.type != iter->var->ts.type)
6169 gfc_convert_type (iter->start, &iter->var->ts, 2);
6171 if (iter->end->ts.kind != iter->var->ts.kind
6172 || iter->end->ts.type != iter->var->ts.type)
6173 gfc_convert_type (iter->end, &iter->var->ts, 2);
6175 if (iter->step->ts.kind != iter->var->ts.kind
6176 || iter->step->ts.type != iter->var->ts.type)
6177 gfc_convert_type (iter->step, &iter->var->ts, 2);
6179 if (iter->start->expr_type == EXPR_CONSTANT
6180 && iter->end->expr_type == EXPR_CONSTANT
6181 && iter->step->expr_type == EXPR_CONSTANT)
6184 if (iter->start->ts.type == BT_INTEGER)
6186 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6187 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6191 sgn = mpfr_sgn (iter->step->value.real);
6192 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6194 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6195 gfc_warning ("DO loop at %L will be executed zero times",
6196 &iter->step->where);
6203 /* Traversal function for find_forall_index. f == 2 signals that
6204 that variable itself is not to be checked - only the references. */
6207 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6209 if (expr->expr_type != EXPR_VARIABLE)
6212 /* A scalar assignment */
6213 if (!expr->ref || *f == 1)
6215 if (expr->symtree->n.sym == sym)
6227 /* Check whether the FORALL index appears in the expression or not.
6228 Returns SUCCESS if SYM is found in EXPR. */
6231 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6233 if (gfc_traverse_expr (expr, sym, forall_index, f))
6240 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6241 to be a scalar INTEGER variable. The subscripts and stride are scalar
6242 INTEGERs, and if stride is a constant it must be nonzero.
6243 Furthermore "A subscript or stride in a forall-triplet-spec shall
6244 not contain a reference to any index-name in the
6245 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6248 resolve_forall_iterators (gfc_forall_iterator *it)
6250 gfc_forall_iterator *iter, *iter2;
6252 for (iter = it; iter; iter = iter->next)
6254 if (gfc_resolve_expr (iter->var) == SUCCESS
6255 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6256 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6259 if (gfc_resolve_expr (iter->start) == SUCCESS
6260 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6261 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6262 &iter->start->where);
6263 if (iter->var->ts.kind != iter->start->ts.kind)
6264 gfc_convert_type (iter->start, &iter->var->ts, 2);
6266 if (gfc_resolve_expr (iter->end) == SUCCESS
6267 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6268 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6270 if (iter->var->ts.kind != iter->end->ts.kind)
6271 gfc_convert_type (iter->end, &iter->var->ts, 2);
6273 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6275 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6276 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6277 &iter->stride->where, "INTEGER");
6279 if (iter->stride->expr_type == EXPR_CONSTANT
6280 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6281 gfc_error ("FORALL stride expression at %L cannot be zero",
6282 &iter->stride->where);
6284 if (iter->var->ts.kind != iter->stride->ts.kind)
6285 gfc_convert_type (iter->stride, &iter->var->ts, 2);
6288 for (iter = it; iter; iter = iter->next)
6289 for (iter2 = iter; iter2; iter2 = iter2->next)
6291 if (find_forall_index (iter2->start,
6292 iter->var->symtree->n.sym, 0) == SUCCESS
6293 || find_forall_index (iter2->end,
6294 iter->var->symtree->n.sym, 0) == SUCCESS
6295 || find_forall_index (iter2->stride,
6296 iter->var->symtree->n.sym, 0) == SUCCESS)
6297 gfc_error ("FORALL index '%s' may not appear in triplet "
6298 "specification at %L", iter->var->symtree->name,
6299 &iter2->start->where);
6304 /* Given a pointer to a symbol that is a derived type, see if it's
6305 inaccessible, i.e. if it's defined in another module and the components are
6306 PRIVATE. The search is recursive if necessary. Returns zero if no
6307 inaccessible components are found, nonzero otherwise. */
6310 derived_inaccessible (gfc_symbol *sym)
6314 if (sym->attr.use_assoc && sym->attr.private_comp)
6317 for (c = sym->components; c; c = c->next)
6319 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6327 /* Resolve the argument of a deallocate expression. The expression must be
6328 a pointer or a full array. */
6331 resolve_deallocate_expr (gfc_expr *e)
6333 symbol_attribute attr;
6334 int allocatable, pointer;
6339 if (gfc_resolve_expr (e) == FAILURE)
6342 if (e->expr_type != EXPR_VARIABLE)
6345 sym = e->symtree->n.sym;
6347 if (sym->ts.type == BT_CLASS)
6349 allocatable = CLASS_DATA (sym)->attr.allocatable;
6350 pointer = CLASS_DATA (sym)->attr.class_pointer;
6354 allocatable = sym->attr.allocatable;
6355 pointer = sym->attr.pointer;
6357 for (ref = e->ref; ref; ref = ref->next)
6362 if (ref->u.ar.type != AR_FULL)
6367 c = ref->u.c.component;
6368 if (c->ts.type == BT_CLASS)
6370 allocatable = CLASS_DATA (c)->attr.allocatable;
6371 pointer = CLASS_DATA (c)->attr.class_pointer;
6375 allocatable = c->attr.allocatable;
6376 pointer = c->attr.pointer;
6386 attr = gfc_expr_attr (e);
6388 if (allocatable == 0 && attr.pointer == 0)
6391 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6397 && gfc_check_vardef_context (e, true, _("DEALLOCATE object")) == FAILURE)
6399 if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE)
6402 if (e->ts.type == BT_CLASS)
6404 /* Only deallocate the DATA component. */
6405 gfc_add_component_ref (e, "$data");
6412 /* Returns true if the expression e contains a reference to the symbol sym. */
6414 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6416 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6423 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6425 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6429 /* Given the expression node e for an allocatable/pointer of derived type to be
6430 allocated, get the expression node to be initialized afterwards (needed for
6431 derived types with default initializers, and derived types with allocatable
6432 components that need nullification.) */
6435 gfc_expr_to_initialize (gfc_expr *e)
6441 result = gfc_copy_expr (e);
6443 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6444 for (ref = result->ref; ref; ref = ref->next)
6445 if (ref->type == REF_ARRAY && ref->next == NULL)
6447 ref->u.ar.type = AR_FULL;
6449 for (i = 0; i < ref->u.ar.dimen; i++)
6450 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6452 result->rank = ref->u.ar.dimen;
6460 /* If the last ref of an expression is an array ref, return a copy of the
6461 expression with that one removed. Otherwise, a copy of the original
6462 expression. This is used for allocate-expressions and pointer assignment
6463 LHS, where there may be an array specification that needs to be stripped
6464 off when using gfc_check_vardef_context. */
6467 remove_last_array_ref (gfc_expr* e)
6472 e2 = gfc_copy_expr (e);
6473 for (r = &e2->ref; *r; r = &(*r)->next)
6474 if ((*r)->type == REF_ARRAY && !(*r)->next)
6476 gfc_free_ref_list (*r);
6485 /* Used in resolve_allocate_expr to check that a allocation-object and
6486 a source-expr are conformable. This does not catch all possible
6487 cases; in particular a runtime checking is needed. */
6490 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6493 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6495 /* First compare rank. */
6496 if (tail && e1->rank != tail->u.ar.as->rank)
6498 gfc_error ("Source-expr at %L must be scalar or have the "
6499 "same rank as the allocate-object at %L",
6500 &e1->where, &e2->where);
6511 for (i = 0; i < e1->rank; i++)
6513 if (tail->u.ar.end[i])
6515 mpz_set (s, tail->u.ar.end[i]->value.integer);
6516 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6517 mpz_add_ui (s, s, 1);
6521 mpz_set (s, tail->u.ar.start[i]->value.integer);
6524 if (mpz_cmp (e1->shape[i], s) != 0)
6526 gfc_error ("Source-expr at %L and allocate-object at %L must "
6527 "have the same shape", &e1->where, &e2->where);
6540 /* Resolve the expression in an ALLOCATE statement, doing the additional
6541 checks to see whether the expression is OK or not. The expression must
6542 have a trailing array reference that gives the size of the array. */
6545 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6547 int i, pointer, allocatable, dimension, is_abstract;
6549 symbol_attribute attr;
6550 gfc_ref *ref, *ref2;
6553 gfc_symbol *sym = NULL;
6558 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6559 checking of coarrays. */
6560 for (ref = e->ref; ref; ref = ref->next)
6561 if (ref->next == NULL)
6564 if (ref && ref->type == REF_ARRAY)
6565 ref->u.ar.in_allocate = true;
6567 if (gfc_resolve_expr (e) == FAILURE)
6570 /* Make sure the expression is allocatable or a pointer. If it is
6571 pointer, the next-to-last reference must be a pointer. */
6575 sym = e->symtree->n.sym;
6577 /* Check whether ultimate component is abstract and CLASS. */
6580 if (e->expr_type != EXPR_VARIABLE)
6583 attr = gfc_expr_attr (e);
6584 pointer = attr.pointer;
6585 dimension = attr.dimension;
6586 codimension = attr.codimension;
6590 if (sym->ts.type == BT_CLASS)
6592 allocatable = CLASS_DATA (sym)->attr.allocatable;
6593 pointer = CLASS_DATA (sym)->attr.class_pointer;
6594 dimension = CLASS_DATA (sym)->attr.dimension;
6595 codimension = CLASS_DATA (sym)->attr.codimension;
6596 is_abstract = CLASS_DATA (sym)->attr.abstract;
6600 allocatable = sym->attr.allocatable;
6601 pointer = sym->attr.pointer;
6602 dimension = sym->attr.dimension;
6603 codimension = sym->attr.codimension;
6606 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6611 if (ref->next != NULL)
6617 if (gfc_is_coindexed (e))
6619 gfc_error ("Coindexed allocatable object at %L",
6624 c = ref->u.c.component;
6625 if (c->ts.type == BT_CLASS)
6627 allocatable = CLASS_DATA (c)->attr.allocatable;
6628 pointer = CLASS_DATA (c)->attr.class_pointer;
6629 dimension = CLASS_DATA (c)->attr.dimension;
6630 codimension = CLASS_DATA (c)->attr.codimension;
6631 is_abstract = CLASS_DATA (c)->attr.abstract;
6635 allocatable = c->attr.allocatable;
6636 pointer = c->attr.pointer;
6637 dimension = c->attr.dimension;
6638 codimension = c->attr.codimension;
6639 is_abstract = c->attr.abstract;
6651 if (allocatable == 0 && pointer == 0)
6653 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6658 /* Some checks for the SOURCE tag. */
6661 /* Check F03:C631. */
6662 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6664 gfc_error ("Type of entity at %L is type incompatible with "
6665 "source-expr at %L", &e->where, &code->expr3->where);
6669 /* Check F03:C632 and restriction following Note 6.18. */
6670 if (code->expr3->rank > 0
6671 && conformable_arrays (code->expr3, e) == FAILURE)
6674 /* Check F03:C633. */
6675 if (code->expr3->ts.kind != e->ts.kind)
6677 gfc_error ("The allocate-object at %L and the source-expr at %L "
6678 "shall have the same kind type parameter",
6679 &e->where, &code->expr3->where);
6684 /* Check F08:C629. */
6685 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
6688 gcc_assert (e->ts.type == BT_CLASS);
6689 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6690 "type-spec or source-expr", sym->name, &e->where);
6694 /* In the variable definition context checks, gfc_expr_attr is used
6695 on the expression. This is fooled by the array specification
6696 present in e, thus we have to eliminate that one temporarily. */
6697 e2 = remove_last_array_ref (e);
6699 if (t == SUCCESS && pointer)
6700 t = gfc_check_vardef_context (e2, true, _("ALLOCATE object"));
6702 t = gfc_check_vardef_context (e2, false, _("ALLOCATE object"));
6709 /* Set up default initializer if needed. */
6713 if (code->ext.alloc.ts.type == BT_DERIVED)
6714 ts = code->ext.alloc.ts;
6718 if (ts.type == BT_CLASS)
6719 ts = ts.u.derived->components->ts;
6721 if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
6723 gfc_code *init_st = gfc_get_code ();
6724 init_st->loc = code->loc;
6725 init_st->op = EXEC_INIT_ASSIGN;
6726 init_st->expr1 = gfc_expr_to_initialize (e);
6727 init_st->expr2 = init_e;
6728 init_st->next = code->next;
6729 code->next = init_st;
6732 else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
6734 /* Default initialization via MOLD (non-polymorphic). */
6735 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
6736 gfc_resolve_expr (rhs);
6737 gfc_free_expr (code->expr3);
6741 if (e->ts.type == BT_CLASS)
6743 /* Make sure the vtab symbol is present when
6744 the module variables are generated. */
6745 gfc_typespec ts = e->ts;
6747 ts = code->expr3->ts;
6748 else if (code->ext.alloc.ts.type == BT_DERIVED)
6749 ts = code->ext.alloc.ts;
6750 gfc_find_derived_vtab (ts.u.derived);
6753 if (pointer || (dimension == 0 && codimension == 0))
6756 /* Make sure the last reference node is an array specifiction. */
6758 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
6759 || (dimension && ref2->u.ar.dimen == 0))
6761 gfc_error ("Array specification required in ALLOCATE statement "
6762 "at %L", &e->where);
6766 /* Make sure that the array section reference makes sense in the
6767 context of an ALLOCATE specification. */
6771 if (codimension && ar->codimen == 0)
6773 gfc_error ("Coarray specification required in ALLOCATE statement "
6774 "at %L", &e->where);
6778 for (i = 0; i < ar->dimen; i++)
6780 if (ref2->u.ar.type == AR_ELEMENT)
6783 switch (ar->dimen_type[i])
6789 if (ar->start[i] != NULL
6790 && ar->end[i] != NULL
6791 && ar->stride[i] == NULL)
6794 /* Fall Through... */
6799 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6805 for (a = code->ext.alloc.list; a; a = a->next)
6807 sym = a->expr->symtree->n.sym;
6809 /* TODO - check derived type components. */
6810 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6813 if ((ar->start[i] != NULL
6814 && gfc_find_sym_in_expr (sym, ar->start[i]))
6815 || (ar->end[i] != NULL
6816 && gfc_find_sym_in_expr (sym, ar->end[i])))
6818 gfc_error ("'%s' must not appear in the array specification at "
6819 "%L in the same ALLOCATE statement where it is "
6820 "itself allocated", sym->name, &ar->where);
6826 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
6828 if (ar->dimen_type[i] == DIMEN_ELEMENT
6829 || ar->dimen_type[i] == DIMEN_RANGE)
6831 if (i == (ar->dimen + ar->codimen - 1))
6833 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
6834 "statement at %L", &e->where);
6840 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
6841 && ar->stride[i] == NULL)
6844 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
6849 if (codimension && ar->as->rank == 0)
6851 gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
6852 "at %L", &e->where);
6864 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
6866 gfc_expr *stat, *errmsg, *pe, *qe;
6867 gfc_alloc *a, *p, *q;
6870 errmsg = code->expr2;
6872 /* Check the stat variable. */
6875 gfc_check_vardef_context (stat, false, _("STAT variable"));
6877 if ((stat->ts.type != BT_INTEGER
6878 && !(stat->ref && (stat->ref->type == REF_ARRAY
6879 || stat->ref->type == REF_COMPONENT)))
6881 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
6882 "variable", &stat->where);
6884 for (p = code->ext.alloc.list; p; p = p->next)
6885 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
6887 gfc_ref *ref1, *ref2;
6890 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
6891 ref1 = ref1->next, ref2 = ref2->next)
6893 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6895 if (ref1->u.c.component->name != ref2->u.c.component->name)
6904 gfc_error ("Stat-variable at %L shall not be %sd within "
6905 "the same %s statement", &stat->where, fcn, fcn);
6911 /* Check the errmsg variable. */
6915 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
6918 gfc_check_vardef_context (errmsg, false, _("ERRMSG variable"));
6920 if ((errmsg->ts.type != BT_CHARACTER
6922 && (errmsg->ref->type == REF_ARRAY
6923 || errmsg->ref->type == REF_COMPONENT)))
6924 || errmsg->rank > 0 )
6925 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
6926 "variable", &errmsg->where);
6928 for (p = code->ext.alloc.list; p; p = p->next)
6929 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
6931 gfc_ref *ref1, *ref2;
6934 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
6935 ref1 = ref1->next, ref2 = ref2->next)
6937 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6939 if (ref1->u.c.component->name != ref2->u.c.component->name)
6948 gfc_error ("Errmsg-variable at %L shall not be %sd within "
6949 "the same %s statement", &errmsg->where, fcn, fcn);
6955 /* Check that an allocate-object appears only once in the statement.
6956 FIXME: Checking derived types is disabled. */
6957 for (p = code->ext.alloc.list; p; p = p->next)
6960 if ((pe->ref && pe->ref->type != REF_COMPONENT)
6961 && (pe->symtree->n.sym->ts.type != BT_DERIVED))
6963 for (q = p->next; q; q = q->next)
6966 if ((qe->ref && qe->ref->type != REF_COMPONENT)
6967 && (qe->symtree->n.sym->ts.type != BT_DERIVED)
6968 && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
6969 gfc_error ("Allocate-object at %L also appears at %L",
6970 &pe->where, &qe->where);
6975 if (strcmp (fcn, "ALLOCATE") == 0)
6977 for (a = code->ext.alloc.list; a; a = a->next)
6978 resolve_allocate_expr (a->expr, code);
6982 for (a = code->ext.alloc.list; a; a = a->next)
6983 resolve_deallocate_expr (a->expr);
6988 /************ SELECT CASE resolution subroutines ************/
6990 /* Callback function for our mergesort variant. Determines interval
6991 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
6992 op1 > op2. Assumes we're not dealing with the default case.
6993 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
6994 There are nine situations to check. */
6997 compare_cases (const gfc_case *op1, const gfc_case *op2)
7001 if (op1->low == NULL) /* op1 = (:L) */
7003 /* op2 = (:N), so overlap. */
7005 /* op2 = (M:) or (M:N), L < M */
7006 if (op2->low != NULL
7007 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7010 else if (op1->high == NULL) /* op1 = (K:) */
7012 /* op2 = (M:), so overlap. */
7014 /* op2 = (:N) or (M:N), K > N */
7015 if (op2->high != NULL
7016 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7019 else /* op1 = (K:L) */
7021 if (op2->low == NULL) /* op2 = (:N), K > N */
7022 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7024 else if (op2->high == NULL) /* op2 = (M:), L < M */
7025 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7027 else /* op2 = (M:N) */
7031 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7034 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7043 /* Merge-sort a double linked case list, detecting overlap in the
7044 process. LIST is the head of the double linked case list before it
7045 is sorted. Returns the head of the sorted list if we don't see any
7046 overlap, or NULL otherwise. */
7049 check_case_overlap (gfc_case *list)
7051 gfc_case *p, *q, *e, *tail;
7052 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7054 /* If the passed list was empty, return immediately. */
7061 /* Loop unconditionally. The only exit from this loop is a return
7062 statement, when we've finished sorting the case list. */
7069 /* Count the number of merges we do in this pass. */
7072 /* Loop while there exists a merge to be done. */
7077 /* Count this merge. */
7080 /* Cut the list in two pieces by stepping INSIZE places
7081 forward in the list, starting from P. */
7084 for (i = 0; i < insize; i++)
7093 /* Now we have two lists. Merge them! */
7094 while (psize > 0 || (qsize > 0 && q != NULL))
7096 /* See from which the next case to merge comes from. */
7099 /* P is empty so the next case must come from Q. */
7104 else if (qsize == 0 || q == NULL)
7113 cmp = compare_cases (p, q);
7116 /* The whole case range for P is less than the
7124 /* The whole case range for Q is greater than
7125 the case range for P. */
7132 /* The cases overlap, or they are the same
7133 element in the list. Either way, we must
7134 issue an error and get the next case from P. */
7135 /* FIXME: Sort P and Q by line number. */
7136 gfc_error ("CASE label at %L overlaps with CASE "
7137 "label at %L", &p->where, &q->where);
7145 /* Add the next element to the merged list. */
7154 /* P has now stepped INSIZE places along, and so has Q. So
7155 they're the same. */
7160 /* If we have done only one merge or none at all, we've
7161 finished sorting the cases. */
7170 /* Otherwise repeat, merging lists twice the size. */
7176 /* Check to see if an expression is suitable for use in a CASE statement.
7177 Makes sure that all case expressions are scalar constants of the same
7178 type. Return FAILURE if anything is wrong. */
7181 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7183 if (e == NULL) return SUCCESS;
7185 if (e->ts.type != case_expr->ts.type)
7187 gfc_error ("Expression in CASE statement at %L must be of type %s",
7188 &e->where, gfc_basic_typename (case_expr->ts.type));
7192 /* C805 (R808) For a given case-construct, each case-value shall be of
7193 the same type as case-expr. For character type, length differences
7194 are allowed, but the kind type parameters shall be the same. */
7196 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7198 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7199 &e->where, case_expr->ts.kind);
7203 /* Convert the case value kind to that of case expression kind,
7206 if (e->ts.kind != case_expr->ts.kind)
7207 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7211 gfc_error ("Expression in CASE statement at %L must be scalar",
7220 /* Given a completely parsed select statement, we:
7222 - Validate all expressions and code within the SELECT.
7223 - Make sure that the selection expression is not of the wrong type.
7224 - Make sure that no case ranges overlap.
7225 - Eliminate unreachable cases and unreachable code resulting from
7226 removing case labels.
7228 The standard does allow unreachable cases, e.g. CASE (5:3). But
7229 they are a hassle for code generation, and to prevent that, we just
7230 cut them out here. This is not necessary for overlapping cases
7231 because they are illegal and we never even try to generate code.
7233 We have the additional caveat that a SELECT construct could have
7234 been a computed GOTO in the source code. Fortunately we can fairly
7235 easily work around that here: The case_expr for a "real" SELECT CASE
7236 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7237 we have to do is make sure that the case_expr is a scalar integer
7241 resolve_select (gfc_code *code)
7244 gfc_expr *case_expr;
7245 gfc_case *cp, *default_case, *tail, *head;
7246 int seen_unreachable;
7252 if (code->expr1 == NULL)
7254 /* This was actually a computed GOTO statement. */
7255 case_expr = code->expr2;
7256 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7257 gfc_error ("Selection expression in computed GOTO statement "
7258 "at %L must be a scalar integer expression",
7261 /* Further checking is not necessary because this SELECT was built
7262 by the compiler, so it should always be OK. Just move the
7263 case_expr from expr2 to expr so that we can handle computed
7264 GOTOs as normal SELECTs from here on. */
7265 code->expr1 = code->expr2;
7270 case_expr = code->expr1;
7272 type = case_expr->ts.type;
7273 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7275 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7276 &case_expr->where, gfc_typename (&case_expr->ts));
7278 /* Punt. Going on here just produce more garbage error messages. */
7282 if (case_expr->rank != 0)
7284 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7285 "expression", &case_expr->where);
7292 /* Raise a warning if an INTEGER case value exceeds the range of
7293 the case-expr. Later, all expressions will be promoted to the
7294 largest kind of all case-labels. */
7296 if (type == BT_INTEGER)
7297 for (body = code->block; body; body = body->block)
7298 for (cp = body->ext.case_list; cp; cp = cp->next)
7301 && gfc_check_integer_range (cp->low->value.integer,
7302 case_expr->ts.kind) != ARITH_OK)
7303 gfc_warning ("Expression in CASE statement at %L is "
7304 "not in the range of %s", &cp->low->where,
7305 gfc_typename (&case_expr->ts));
7308 && cp->low != cp->high
7309 && gfc_check_integer_range (cp->high->value.integer,
7310 case_expr->ts.kind) != ARITH_OK)
7311 gfc_warning ("Expression in CASE statement at %L is "
7312 "not in the range of %s", &cp->high->where,
7313 gfc_typename (&case_expr->ts));
7316 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7317 of the SELECT CASE expression and its CASE values. Walk the lists
7318 of case values, and if we find a mismatch, promote case_expr to
7319 the appropriate kind. */
7321 if (type == BT_LOGICAL || type == BT_INTEGER)
7323 for (body = code->block; body; body = body->block)
7325 /* Walk the case label list. */
7326 for (cp = body->ext.case_list; cp; cp = cp->next)
7328 /* Intercept the DEFAULT case. It does not have a kind. */
7329 if (cp->low == NULL && cp->high == NULL)
7332 /* Unreachable case ranges are discarded, so ignore. */
7333 if (cp->low != NULL && cp->high != NULL
7334 && cp->low != cp->high
7335 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7339 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7340 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7342 if (cp->high != NULL
7343 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7344 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7349 /* Assume there is no DEFAULT case. */
7350 default_case = NULL;
7355 for (body = code->block; body; body = body->block)
7357 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7359 seen_unreachable = 0;
7361 /* Walk the case label list, making sure that all case labels
7363 for (cp = body->ext.case_list; cp; cp = cp->next)
7365 /* Count the number of cases in the whole construct. */
7368 /* Intercept the DEFAULT case. */
7369 if (cp->low == NULL && cp->high == NULL)
7371 if (default_case != NULL)
7373 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7374 "by a second DEFAULT CASE at %L",
7375 &default_case->where, &cp->where);
7386 /* Deal with single value cases and case ranges. Errors are
7387 issued from the validation function. */
7388 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7389 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7395 if (type == BT_LOGICAL
7396 && ((cp->low == NULL || cp->high == NULL)
7397 || cp->low != cp->high))
7399 gfc_error ("Logical range in CASE statement at %L is not "
7400 "allowed", &cp->low->where);
7405 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7408 value = cp->low->value.logical == 0 ? 2 : 1;
7409 if (value & seen_logical)
7411 gfc_error ("Constant logical value in CASE statement "
7412 "is repeated at %L",
7417 seen_logical |= value;
7420 if (cp->low != NULL && cp->high != NULL
7421 && cp->low != cp->high
7422 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7424 if (gfc_option.warn_surprising)
7425 gfc_warning ("Range specification at %L can never "
7426 "be matched", &cp->where);
7428 cp->unreachable = 1;
7429 seen_unreachable = 1;
7433 /* If the case range can be matched, it can also overlap with
7434 other cases. To make sure it does not, we put it in a
7435 double linked list here. We sort that with a merge sort
7436 later on to detect any overlapping cases. */
7440 head->right = head->left = NULL;
7445 tail->right->left = tail;
7452 /* It there was a failure in the previous case label, give up
7453 for this case label list. Continue with the next block. */
7457 /* See if any case labels that are unreachable have been seen.
7458 If so, we eliminate them. This is a bit of a kludge because
7459 the case lists for a single case statement (label) is a
7460 single forward linked lists. */
7461 if (seen_unreachable)
7463 /* Advance until the first case in the list is reachable. */
7464 while (body->ext.case_list != NULL
7465 && body->ext.case_list->unreachable)
7467 gfc_case *n = body->ext.case_list;
7468 body->ext.case_list = body->ext.case_list->next;
7470 gfc_free_case_list (n);
7473 /* Strip all other unreachable cases. */
7474 if (body->ext.case_list)
7476 for (cp = body->ext.case_list; cp->next; cp = cp->next)
7478 if (cp->next->unreachable)
7480 gfc_case *n = cp->next;
7481 cp->next = cp->next->next;
7483 gfc_free_case_list (n);
7490 /* See if there were overlapping cases. If the check returns NULL,
7491 there was overlap. In that case we don't do anything. If head
7492 is non-NULL, we prepend the DEFAULT case. The sorted list can
7493 then used during code generation for SELECT CASE constructs with
7494 a case expression of a CHARACTER type. */
7497 head = check_case_overlap (head);
7499 /* Prepend the default_case if it is there. */
7500 if (head != NULL && default_case)
7502 default_case->left = NULL;
7503 default_case->right = head;
7504 head->left = default_case;
7508 /* Eliminate dead blocks that may be the result if we've seen
7509 unreachable case labels for a block. */
7510 for (body = code; body && body->block; body = body->block)
7512 if (body->block->ext.case_list == NULL)
7514 /* Cut the unreachable block from the code chain. */
7515 gfc_code *c = body->block;
7516 body->block = c->block;
7518 /* Kill the dead block, but not the blocks below it. */
7520 gfc_free_statements (c);
7524 /* More than two cases is legal but insane for logical selects.
7525 Issue a warning for it. */
7526 if (gfc_option.warn_surprising && type == BT_LOGICAL
7528 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7533 /* Check if a derived type is extensible. */
7536 gfc_type_is_extensible (gfc_symbol *sym)
7538 return !(sym->attr.is_bind_c || sym->attr.sequence);
7542 /* Resolve an associate name: Resolve target and ensure the type-spec is
7543 correct as well as possibly the array-spec. */
7546 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
7550 gcc_assert (sym->assoc);
7551 gcc_assert (sym->attr.flavor == FL_VARIABLE);
7553 /* If this is for SELECT TYPE, the target may not yet be set. In that
7554 case, return. Resolution will be called later manually again when
7556 target = sym->assoc->target;
7559 gcc_assert (!sym->assoc->dangling);
7561 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
7564 /* For variable targets, we get some attributes from the target. */
7565 if (target->expr_type == EXPR_VARIABLE)
7569 gcc_assert (target->symtree);
7570 tsym = target->symtree->n.sym;
7572 sym->attr.asynchronous = tsym->attr.asynchronous;
7573 sym->attr.volatile_ = tsym->attr.volatile_;
7575 sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
7578 /* Get type if this was not already set. Note that it can be
7579 some other type than the target in case this is a SELECT TYPE
7580 selector! So we must not update when the type is already there. */
7581 if (sym->ts.type == BT_UNKNOWN)
7582 sym->ts = target->ts;
7583 gcc_assert (sym->ts.type != BT_UNKNOWN);
7585 /* See if this is a valid association-to-variable. */
7586 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
7587 && !gfc_has_vector_subscript (target));
7589 /* Finally resolve if this is an array or not. */
7590 if (sym->attr.dimension && target->rank == 0)
7592 gfc_error ("Associate-name '%s' at %L is used as array",
7593 sym->name, &sym->declared_at);
7594 sym->attr.dimension = 0;
7597 if (target->rank > 0)
7598 sym->attr.dimension = 1;
7600 if (sym->attr.dimension)
7602 sym->as = gfc_get_array_spec ();
7603 sym->as->rank = target->rank;
7604 sym->as->type = AS_DEFERRED;
7606 /* Target must not be coindexed, thus the associate-variable
7608 sym->as->corank = 0;
7613 /* Resolve a SELECT TYPE statement. */
7616 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
7618 gfc_symbol *selector_type;
7619 gfc_code *body, *new_st, *if_st, *tail;
7620 gfc_code *class_is = NULL, *default_case = NULL;
7623 char name[GFC_MAX_SYMBOL_LEN];
7627 ns = code->ext.block.ns;
7630 /* Check for F03:C813. */
7631 if (code->expr1->ts.type != BT_CLASS
7632 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
7634 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7635 "at %L", &code->loc);
7641 if (code->expr1->symtree->n.sym->attr.untyped)
7642 code->expr1->symtree->n.sym->ts = code->expr2->ts;
7643 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
7646 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
7648 /* Loop over TYPE IS / CLASS IS cases. */
7649 for (body = code->block; body; body = body->block)
7651 c = body->ext.case_list;
7653 /* Check F03:C815. */
7654 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7655 && !gfc_type_is_extensible (c->ts.u.derived))
7657 gfc_error ("Derived type '%s' at %L must be extensible",
7658 c->ts.u.derived->name, &c->where);
7663 /* Check F03:C816. */
7664 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7665 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
7667 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7668 c->ts.u.derived->name, &c->where, selector_type->name);
7673 /* Intercept the DEFAULT case. */
7674 if (c->ts.type == BT_UNKNOWN)
7676 /* Check F03:C818. */
7679 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7680 "by a second DEFAULT CASE at %L",
7681 &default_case->ext.case_list->where, &c->where);
7686 default_case = body;
7693 /* Transform SELECT TYPE statement to BLOCK and associate selector to
7694 target if present. If there are any EXIT statements referring to the
7695 SELECT TYPE construct, this is no problem because the gfc_code
7696 reference stays the same and EXIT is equally possible from the BLOCK
7697 it is changed to. */
7698 code->op = EXEC_BLOCK;
7701 gfc_association_list* assoc;
7703 assoc = gfc_get_association_list ();
7704 assoc->st = code->expr1->symtree;
7705 assoc->target = gfc_copy_expr (code->expr2);
7706 /* assoc->variable will be set by resolve_assoc_var. */
7708 code->ext.block.assoc = assoc;
7709 code->expr1->symtree->n.sym->assoc = assoc;
7711 resolve_assoc_var (code->expr1->symtree->n.sym, false);
7714 code->ext.block.assoc = NULL;
7716 /* Add EXEC_SELECT to switch on type. */
7717 new_st = gfc_get_code ();
7718 new_st->op = code->op;
7719 new_st->expr1 = code->expr1;
7720 new_st->expr2 = code->expr2;
7721 new_st->block = code->block;
7722 code->expr1 = code->expr2 = NULL;
7727 ns->code->next = new_st;
7729 code->op = EXEC_SELECT;
7730 gfc_add_component_ref (code->expr1, "$vptr");
7731 gfc_add_component_ref (code->expr1, "$hash");
7733 /* Loop over TYPE IS / CLASS IS cases. */
7734 for (body = code->block; body; body = body->block)
7736 c = body->ext.case_list;
7738 if (c->ts.type == BT_DERIVED)
7739 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7740 c->ts.u.derived->hash_value);
7742 else if (c->ts.type == BT_UNKNOWN)
7745 /* Associate temporary to selector. This should only be done
7746 when this case is actually true, so build a new ASSOCIATE
7747 that does precisely this here (instead of using the
7750 if (c->ts.type == BT_CLASS)
7751 sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
7753 sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
7754 st = gfc_find_symtree (ns->sym_root, name);
7755 gcc_assert (st->n.sym->assoc);
7756 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
7757 if (c->ts.type == BT_DERIVED)
7758 gfc_add_component_ref (st->n.sym->assoc->target, "$data");
7760 new_st = gfc_get_code ();
7761 new_st->op = EXEC_BLOCK;
7762 new_st->ext.block.ns = gfc_build_block_ns (ns);
7763 new_st->ext.block.ns->code = body->next;
7764 body->next = new_st;
7766 /* Chain in the new list only if it is marked as dangling. Otherwise
7767 there is a CASE label overlap and this is already used. Just ignore,
7768 the error is diagonsed elsewhere. */
7769 if (st->n.sym->assoc->dangling)
7771 new_st->ext.block.assoc = st->n.sym->assoc;
7772 st->n.sym->assoc->dangling = 0;
7775 resolve_assoc_var (st->n.sym, false);
7778 /* Take out CLASS IS cases for separate treatment. */
7780 while (body && body->block)
7782 if (body->block->ext.case_list->ts.type == BT_CLASS)
7784 /* Add to class_is list. */
7785 if (class_is == NULL)
7787 class_is = body->block;
7792 for (tail = class_is; tail->block; tail = tail->block) ;
7793 tail->block = body->block;
7796 /* Remove from EXEC_SELECT list. */
7797 body->block = body->block->block;
7810 /* Add a default case to hold the CLASS IS cases. */
7811 for (tail = code; tail->block; tail = tail->block) ;
7812 tail->block = gfc_get_code ();
7814 tail->op = EXEC_SELECT_TYPE;
7815 tail->ext.case_list = gfc_get_case ();
7816 tail->ext.case_list->ts.type = BT_UNKNOWN;
7818 default_case = tail;
7821 /* More than one CLASS IS block? */
7822 if (class_is->block)
7826 /* Sort CLASS IS blocks by extension level. */
7830 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
7833 /* F03:C817 (check for doubles). */
7834 if ((*c1)->ext.case_list->ts.u.derived->hash_value
7835 == c2->ext.case_list->ts.u.derived->hash_value)
7837 gfc_error ("Double CLASS IS block in SELECT TYPE "
7838 "statement at %L", &c2->ext.case_list->where);
7841 if ((*c1)->ext.case_list->ts.u.derived->attr.extension
7842 < c2->ext.case_list->ts.u.derived->attr.extension)
7845 (*c1)->block = c2->block;
7855 /* Generate IF chain. */
7856 if_st = gfc_get_code ();
7857 if_st->op = EXEC_IF;
7859 for (body = class_is; body; body = body->block)
7861 new_st->block = gfc_get_code ();
7862 new_st = new_st->block;
7863 new_st->op = EXEC_IF;
7864 /* Set up IF condition: Call _gfortran_is_extension_of. */
7865 new_st->expr1 = gfc_get_expr ();
7866 new_st->expr1->expr_type = EXPR_FUNCTION;
7867 new_st->expr1->ts.type = BT_LOGICAL;
7868 new_st->expr1->ts.kind = 4;
7869 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
7870 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
7871 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
7872 /* Set up arguments. */
7873 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
7874 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
7875 gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
7876 vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
7877 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
7878 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
7879 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
7880 new_st->next = body->next;
7882 if (default_case->next)
7884 new_st->block = gfc_get_code ();
7885 new_st = new_st->block;
7886 new_st->op = EXEC_IF;
7887 new_st->next = default_case->next;
7890 /* Replace CLASS DEFAULT code by the IF chain. */
7891 default_case->next = if_st;
7894 /* Resolve the internal code. This can not be done earlier because
7895 it requires that the sym->assoc of selectors is set already. */
7896 gfc_current_ns = ns;
7897 gfc_resolve_blocks (code->block, gfc_current_ns);
7898 gfc_current_ns = old_ns;
7900 resolve_select (code);
7904 /* Resolve a transfer statement. This is making sure that:
7905 -- a derived type being transferred has only non-pointer components
7906 -- a derived type being transferred doesn't have private components, unless
7907 it's being transferred from the module where the type was defined
7908 -- we're not trying to transfer a whole assumed size array. */
7911 resolve_transfer (gfc_code *code)
7920 while (exp != NULL && exp->expr_type == EXPR_OP
7921 && exp->value.op.op == INTRINSIC_PARENTHESES)
7922 exp = exp->value.op.op1;
7924 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
7925 && exp->expr_type != EXPR_FUNCTION))
7928 /* If we are reading, the variable will be changed. Note that
7929 code->ext.dt may be NULL if the TRANSFER is related to
7930 an INQUIRE statement -- but in this case, we are not reading, either. */
7931 if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
7932 && gfc_check_vardef_context (exp, false, _("item in READ")) == FAILURE)
7935 sym = exp->symtree->n.sym;
7938 /* Go to actual component transferred. */
7939 for (ref = code->expr1->ref; ref; ref = ref->next)
7940 if (ref->type == REF_COMPONENT)
7941 ts = &ref->u.c.component->ts;
7943 if (ts->type == BT_DERIVED)
7945 /* Check that transferred derived type doesn't contain POINTER
7947 if (ts->u.derived->attr.pointer_comp)
7949 gfc_error ("Data transfer element at %L cannot have "
7950 "POINTER components", &code->loc);
7954 if (ts->u.derived->attr.alloc_comp)
7956 gfc_error ("Data transfer element at %L cannot have "
7957 "ALLOCATABLE components", &code->loc);
7961 if (derived_inaccessible (ts->u.derived))
7963 gfc_error ("Data transfer element at %L cannot have "
7964 "PRIVATE components",&code->loc);
7969 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
7970 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
7972 gfc_error ("Data transfer element at %L cannot be a full reference to "
7973 "an assumed-size array", &code->loc);
7979 /*********** Toplevel code resolution subroutines ***********/
7981 /* Find the set of labels that are reachable from this block. We also
7982 record the last statement in each block. */
7985 find_reachable_labels (gfc_code *block)
7992 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
7994 /* Collect labels in this block. We don't keep those corresponding
7995 to END {IF|SELECT}, these are checked in resolve_branch by going
7996 up through the code_stack. */
7997 for (c = block; c; c = c->next)
7999 if (c->here && c->op != EXEC_END_BLOCK)
8000 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8003 /* Merge with labels from parent block. */
8006 gcc_assert (cs_base->prev->reachable_labels);
8007 bitmap_ior_into (cs_base->reachable_labels,
8008 cs_base->prev->reachable_labels);
8014 resolve_sync (gfc_code *code)
8016 /* Check imageset. The * case matches expr1 == NULL. */
8019 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8020 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8021 "INTEGER expression", &code->expr1->where);
8022 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8023 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8024 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8025 &code->expr1->where);
8026 else if (code->expr1->expr_type == EXPR_ARRAY
8027 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8029 gfc_constructor *cons;
8030 cons = gfc_constructor_first (code->expr1->value.constructor);
8031 for (; cons; cons = gfc_constructor_next (cons))
8032 if (cons->expr->expr_type == EXPR_CONSTANT
8033 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8034 gfc_error ("Imageset argument at %L must between 1 and "
8035 "num_images()", &cons->expr->where);
8041 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8042 || code->expr2->expr_type != EXPR_VARIABLE))
8043 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8044 &code->expr2->where);
8048 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8049 || code->expr3->expr_type != EXPR_VARIABLE))
8050 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8051 &code->expr3->where);
8055 /* Given a branch to a label, see if the branch is conforming.
8056 The code node describes where the branch is located. */
8059 resolve_branch (gfc_st_label *label, gfc_code *code)
8066 /* Step one: is this a valid branching target? */
8068 if (label->defined == ST_LABEL_UNKNOWN)
8070 gfc_error ("Label %d referenced at %L is never defined", label->value,
8075 if (label->defined != ST_LABEL_TARGET)
8077 gfc_error ("Statement at %L is not a valid branch target statement "
8078 "for the branch statement at %L", &label->where, &code->loc);
8082 /* Step two: make sure this branch is not a branch to itself ;-) */
8084 if (code->here == label)
8086 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8090 /* Step three: See if the label is in the same block as the
8091 branching statement. The hard work has been done by setting up
8092 the bitmap reachable_labels. */
8094 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8096 /* Check now whether there is a CRITICAL construct; if so, check
8097 whether the label is still visible outside of the CRITICAL block,
8098 which is invalid. */
8099 for (stack = cs_base; stack; stack = stack->prev)
8100 if (stack->current->op == EXEC_CRITICAL
8101 && bitmap_bit_p (stack->reachable_labels, label->value))
8102 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8103 " at %L", &code->loc, &label->where);
8108 /* Step four: If we haven't found the label in the bitmap, it may
8109 still be the label of the END of the enclosing block, in which
8110 case we find it by going up the code_stack. */
8112 for (stack = cs_base; stack; stack = stack->prev)
8114 if (stack->current->next && stack->current->next->here == label)
8116 if (stack->current->op == EXEC_CRITICAL)
8118 /* Note: A label at END CRITICAL does not leave the CRITICAL
8119 construct as END CRITICAL is still part of it. */
8120 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8121 " at %L", &code->loc, &label->where);
8128 gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
8132 /* The label is not in an enclosing block, so illegal. This was
8133 allowed in Fortran 66, so we allow it as extension. No
8134 further checks are necessary in this case. */
8135 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
8136 "as the GOTO statement at %L", &label->where,
8142 /* Check whether EXPR1 has the same shape as EXPR2. */
8145 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
8147 mpz_t shape[GFC_MAX_DIMENSIONS];
8148 mpz_t shape2[GFC_MAX_DIMENSIONS];
8149 gfc_try result = FAILURE;
8152 /* Compare the rank. */
8153 if (expr1->rank != expr2->rank)
8156 /* Compare the size of each dimension. */
8157 for (i=0; i<expr1->rank; i++)
8159 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
8162 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
8165 if (mpz_cmp (shape[i], shape2[i]))
8169 /* When either of the two expression is an assumed size array, we
8170 ignore the comparison of dimension sizes. */
8175 for (i--; i >= 0; i--)
8177 mpz_clear (shape[i]);
8178 mpz_clear (shape2[i]);
8184 /* Check whether a WHERE assignment target or a WHERE mask expression
8185 has the same shape as the outmost WHERE mask expression. */
8188 resolve_where (gfc_code *code, gfc_expr *mask)
8194 cblock = code->block;
8196 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8197 In case of nested WHERE, only the outmost one is stored. */
8198 if (mask == NULL) /* outmost WHERE */
8200 else /* inner WHERE */
8207 /* Check if the mask-expr has a consistent shape with the
8208 outmost WHERE mask-expr. */
8209 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8210 gfc_error ("WHERE mask at %L has inconsistent shape",
8211 &cblock->expr1->where);
8214 /* the assignment statement of a WHERE statement, or the first
8215 statement in where-body-construct of a WHERE construct */
8216 cnext = cblock->next;
8221 /* WHERE assignment statement */
8224 /* Check shape consistent for WHERE assignment target. */
8225 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8226 gfc_error ("WHERE assignment target at %L has "
8227 "inconsistent shape", &cnext->expr1->where);
8231 case EXEC_ASSIGN_CALL:
8232 resolve_call (cnext);
8233 if (!cnext->resolved_sym->attr.elemental)
8234 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8235 &cnext->ext.actual->expr->where);
8238 /* WHERE or WHERE construct is part of a where-body-construct */
8240 resolve_where (cnext, e);
8244 gfc_error ("Unsupported statement inside WHERE at %L",
8247 /* the next statement within the same where-body-construct */
8248 cnext = cnext->next;
8250 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8251 cblock = cblock->block;
8256 /* Resolve assignment in FORALL construct.
8257 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8258 FORALL index variables. */
8261 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8265 for (n = 0; n < nvar; n++)
8267 gfc_symbol *forall_index;
8269 forall_index = var_expr[n]->symtree->n.sym;
8271 /* Check whether the assignment target is one of the FORALL index
8273 if ((code->expr1->expr_type == EXPR_VARIABLE)
8274 && (code->expr1->symtree->n.sym == forall_index))
8275 gfc_error ("Assignment to a FORALL index variable at %L",
8276 &code->expr1->where);
8279 /* If one of the FORALL index variables doesn't appear in the
8280 assignment variable, then there could be a many-to-one
8281 assignment. Emit a warning rather than an error because the
8282 mask could be resolving this problem. */
8283 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8284 gfc_warning ("The FORALL with index '%s' is not used on the "
8285 "left side of the assignment at %L and so might "
8286 "cause multiple assignment to this object",
8287 var_expr[n]->symtree->name, &code->expr1->where);
8293 /* Resolve WHERE statement in FORALL construct. */
8296 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8297 gfc_expr **var_expr)
8302 cblock = code->block;
8305 /* the assignment statement of a WHERE statement, or the first
8306 statement in where-body-construct of a WHERE construct */
8307 cnext = cblock->next;
8312 /* WHERE assignment statement */
8314 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8317 /* WHERE operator assignment statement */
8318 case EXEC_ASSIGN_CALL:
8319 resolve_call (cnext);
8320 if (!cnext->resolved_sym->attr.elemental)
8321 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8322 &cnext->ext.actual->expr->where);
8325 /* WHERE or WHERE construct is part of a where-body-construct */
8327 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8331 gfc_error ("Unsupported statement inside WHERE at %L",
8334 /* the next statement within the same where-body-construct */
8335 cnext = cnext->next;
8337 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8338 cblock = cblock->block;
8343 /* Traverse the FORALL body to check whether the following errors exist:
8344 1. For assignment, check if a many-to-one assignment happens.
8345 2. For WHERE statement, check the WHERE body to see if there is any
8346 many-to-one assignment. */
8349 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8353 c = code->block->next;
8359 case EXEC_POINTER_ASSIGN:
8360 gfc_resolve_assign_in_forall (c, nvar, var_expr);
8363 case EXEC_ASSIGN_CALL:
8367 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8368 there is no need to handle it here. */
8372 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8377 /* The next statement in the FORALL body. */
8383 /* Counts the number of iterators needed inside a forall construct, including
8384 nested forall constructs. This is used to allocate the needed memory
8385 in gfc_resolve_forall. */
8388 gfc_count_forall_iterators (gfc_code *code)
8390 int max_iters, sub_iters, current_iters;
8391 gfc_forall_iterator *fa;
8393 gcc_assert(code->op == EXEC_FORALL);
8397 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8400 code = code->block->next;
8404 if (code->op == EXEC_FORALL)
8406 sub_iters = gfc_count_forall_iterators (code);
8407 if (sub_iters > max_iters)
8408 max_iters = sub_iters;
8413 return current_iters + max_iters;
8417 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8418 gfc_resolve_forall_body to resolve the FORALL body. */
8421 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8423 static gfc_expr **var_expr;
8424 static int total_var = 0;
8425 static int nvar = 0;
8427 gfc_forall_iterator *fa;
8432 /* Start to resolve a FORALL construct */
8433 if (forall_save == 0)
8435 /* Count the total number of FORALL index in the nested FORALL
8436 construct in order to allocate the VAR_EXPR with proper size. */
8437 total_var = gfc_count_forall_iterators (code);
8439 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8440 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
8443 /* The information about FORALL iterator, including FORALL index start, end
8444 and stride. The FORALL index can not appear in start, end or stride. */
8445 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8447 /* Check if any outer FORALL index name is the same as the current
8449 for (i = 0; i < nvar; i++)
8451 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8453 gfc_error ("An outer FORALL construct already has an index "
8454 "with this name %L", &fa->var->where);
8458 /* Record the current FORALL index. */
8459 var_expr[nvar] = gfc_copy_expr (fa->var);
8463 /* No memory leak. */
8464 gcc_assert (nvar <= total_var);
8467 /* Resolve the FORALL body. */
8468 gfc_resolve_forall_body (code, nvar, var_expr);
8470 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8471 gfc_resolve_blocks (code->block, ns);
8475 /* Free only the VAR_EXPRs allocated in this frame. */
8476 for (i = nvar; i < tmp; i++)
8477 gfc_free_expr (var_expr[i]);
8481 /* We are in the outermost FORALL construct. */
8482 gcc_assert (forall_save == 0);
8484 /* VAR_EXPR is not needed any more. */
8485 gfc_free (var_expr);
8491 /* Resolve a BLOCK construct statement. */
8494 resolve_block_construct (gfc_code* code)
8496 /* Resolve the BLOCK's namespace. */
8497 gfc_resolve (code->ext.block.ns);
8499 /* For an ASSOCIATE block, the associations (and their targets) are already
8500 resolved during resolve_symbol. */
8504 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8507 static void resolve_code (gfc_code *, gfc_namespace *);
8510 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8514 for (; b; b = b->block)
8516 t = gfc_resolve_expr (b->expr1);
8517 if (gfc_resolve_expr (b->expr2) == FAILURE)
8523 if (t == SUCCESS && b->expr1 != NULL
8524 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
8525 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8532 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
8533 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8538 resolve_branch (b->label1, b);
8542 resolve_block_construct (b);
8546 case EXEC_SELECT_TYPE:
8557 case EXEC_OMP_ATOMIC:
8558 case EXEC_OMP_CRITICAL:
8560 case EXEC_OMP_MASTER:
8561 case EXEC_OMP_ORDERED:
8562 case EXEC_OMP_PARALLEL:
8563 case EXEC_OMP_PARALLEL_DO:
8564 case EXEC_OMP_PARALLEL_SECTIONS:
8565 case EXEC_OMP_PARALLEL_WORKSHARE:
8566 case EXEC_OMP_SECTIONS:
8567 case EXEC_OMP_SINGLE:
8569 case EXEC_OMP_TASKWAIT:
8570 case EXEC_OMP_WORKSHARE:
8574 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
8577 resolve_code (b->next, ns);
8582 /* Does everything to resolve an ordinary assignment. Returns true
8583 if this is an interface assignment. */
8585 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
8595 if (gfc_extend_assign (code, ns) == SUCCESS)
8599 if (code->op == EXEC_ASSIGN_CALL)
8601 lhs = code->ext.actual->expr;
8602 rhsptr = &code->ext.actual->next->expr;
8606 gfc_actual_arglist* args;
8607 gfc_typebound_proc* tbp;
8609 gcc_assert (code->op == EXEC_COMPCALL);
8611 args = code->expr1->value.compcall.actual;
8613 rhsptr = &args->next->expr;
8615 tbp = code->expr1->value.compcall.tbp;
8616 gcc_assert (!tbp->is_generic);
8619 /* Make a temporary rhs when there is a default initializer
8620 and rhs is the same symbol as the lhs. */
8621 if ((*rhsptr)->expr_type == EXPR_VARIABLE
8622 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
8623 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
8624 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
8625 *rhsptr = gfc_get_parentheses (*rhsptr);
8634 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
8635 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
8636 &code->loc) == FAILURE)
8639 /* Handle the case of a BOZ literal on the RHS. */
8640 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
8643 if (gfc_option.warn_surprising)
8644 gfc_warning ("BOZ literal at %L is bitwise transferred "
8645 "non-integer symbol '%s'", &code->loc,
8646 lhs->symtree->n.sym->name);
8648 if (!gfc_convert_boz (rhs, &lhs->ts))
8650 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
8652 if (rc == ARITH_UNDERFLOW)
8653 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
8654 ". This check can be disabled with the option "
8655 "-fno-range-check", &rhs->where);
8656 else if (rc == ARITH_OVERFLOW)
8657 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
8658 ". This check can be disabled with the option "
8659 "-fno-range-check", &rhs->where);
8660 else if (rc == ARITH_NAN)
8661 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
8662 ". This check can be disabled with the option "
8663 "-fno-range-check", &rhs->where);
8668 if (lhs->ts.type == BT_CHARACTER
8669 && gfc_option.warn_character_truncation)
8671 if (lhs->ts.u.cl != NULL
8672 && lhs->ts.u.cl->length != NULL
8673 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8674 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
8676 if (rhs->expr_type == EXPR_CONSTANT)
8677 rlen = rhs->value.character.length;
8679 else if (rhs->ts.u.cl != NULL
8680 && rhs->ts.u.cl->length != NULL
8681 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8682 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
8684 if (rlen && llen && rlen > llen)
8685 gfc_warning_now ("CHARACTER expression will be truncated "
8686 "in assignment (%d/%d) at %L",
8687 llen, rlen, &code->loc);
8690 /* Ensure that a vector index expression for the lvalue is evaluated
8691 to a temporary if the lvalue symbol is referenced in it. */
8694 for (ref = lhs->ref; ref; ref= ref->next)
8695 if (ref->type == REF_ARRAY)
8697 for (n = 0; n < ref->u.ar.dimen; n++)
8698 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
8699 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
8700 ref->u.ar.start[n]))
8702 = gfc_get_parentheses (ref->u.ar.start[n]);
8706 if (gfc_pure (NULL))
8708 if (lhs->ts.type == BT_DERIVED
8709 && lhs->expr_type == EXPR_VARIABLE
8710 && lhs->ts.u.derived->attr.pointer_comp
8711 && rhs->expr_type == EXPR_VARIABLE
8712 && (gfc_impure_variable (rhs->symtree->n.sym)
8713 || gfc_is_coindexed (rhs)))
8716 if (gfc_is_coindexed (rhs))
8717 gfc_error ("Coindexed expression at %L is assigned to "
8718 "a derived type variable with a POINTER "
8719 "component in a PURE procedure",
8722 gfc_error ("The impure variable at %L is assigned to "
8723 "a derived type variable with a POINTER "
8724 "component in a PURE procedure (12.6)",
8729 /* Fortran 2008, C1283. */
8730 if (gfc_is_coindexed (lhs))
8732 gfc_error ("Assignment to coindexed variable at %L in a PURE "
8733 "procedure", &rhs->where);
8739 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
8740 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
8741 if (lhs->ts.type == BT_CLASS)
8743 gfc_error ("Variable must not be polymorphic in assignment at %L",
8748 /* F2008, Section 7.2.1.2. */
8749 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
8751 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
8752 "component in assignment at %L", &lhs->where);
8756 gfc_check_assign (lhs, rhs, 1);
8761 /* Given a block of code, recursively resolve everything pointed to by this
8765 resolve_code (gfc_code *code, gfc_namespace *ns)
8767 int omp_workshare_save;
8772 frame.prev = cs_base;
8776 find_reachable_labels (code);
8778 for (; code; code = code->next)
8780 frame.current = code;
8781 forall_save = forall_flag;
8783 if (code->op == EXEC_FORALL)
8786 gfc_resolve_forall (code, ns, forall_save);
8789 else if (code->block)
8791 omp_workshare_save = -1;
8794 case EXEC_OMP_PARALLEL_WORKSHARE:
8795 omp_workshare_save = omp_workshare_flag;
8796 omp_workshare_flag = 1;
8797 gfc_resolve_omp_parallel_blocks (code, ns);
8799 case EXEC_OMP_PARALLEL:
8800 case EXEC_OMP_PARALLEL_DO:
8801 case EXEC_OMP_PARALLEL_SECTIONS:
8803 omp_workshare_save = omp_workshare_flag;
8804 omp_workshare_flag = 0;
8805 gfc_resolve_omp_parallel_blocks (code, ns);
8808 gfc_resolve_omp_do_blocks (code, ns);
8810 case EXEC_SELECT_TYPE:
8811 /* Blocks are handled in resolve_select_type because we have
8812 to transform the SELECT TYPE into ASSOCIATE first. */
8814 case EXEC_OMP_WORKSHARE:
8815 omp_workshare_save = omp_workshare_flag;
8816 omp_workshare_flag = 1;
8819 gfc_resolve_blocks (code->block, ns);
8823 if (omp_workshare_save != -1)
8824 omp_workshare_flag = omp_workshare_save;
8828 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
8829 t = gfc_resolve_expr (code->expr1);
8830 forall_flag = forall_save;
8832 if (gfc_resolve_expr (code->expr2) == FAILURE)
8835 if (code->op == EXEC_ALLOCATE
8836 && gfc_resolve_expr (code->expr3) == FAILURE)
8842 case EXEC_END_BLOCK:
8846 case EXEC_ERROR_STOP:
8850 case EXEC_ASSIGN_CALL:
8855 case EXEC_SYNC_IMAGES:
8856 case EXEC_SYNC_MEMORY:
8857 resolve_sync (code);
8861 /* Keep track of which entry we are up to. */
8862 current_entry_id = code->ext.entry->id;
8866 resolve_where (code, NULL);
8870 if (code->expr1 != NULL)
8872 if (code->expr1->ts.type != BT_INTEGER)
8873 gfc_error ("ASSIGNED GOTO statement at %L requires an "
8874 "INTEGER variable", &code->expr1->where);
8875 else if (code->expr1->symtree->n.sym->attr.assign != 1)
8876 gfc_error ("Variable '%s' has not been assigned a target "
8877 "label at %L", code->expr1->symtree->n.sym->name,
8878 &code->expr1->where);
8881 resolve_branch (code->label1, code);
8885 if (code->expr1 != NULL
8886 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
8887 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
8888 "INTEGER return specifier", &code->expr1->where);
8891 case EXEC_INIT_ASSIGN:
8892 case EXEC_END_PROCEDURE:
8899 if (gfc_check_vardef_context (code->expr1, false, _("assignment"))
8903 if (resolve_ordinary_assign (code, ns))
8905 if (code->op == EXEC_COMPCALL)
8912 case EXEC_LABEL_ASSIGN:
8913 if (code->label1->defined == ST_LABEL_UNKNOWN)
8914 gfc_error ("Label %d referenced at %L is never defined",
8915 code->label1->value, &code->label1->where);
8917 && (code->expr1->expr_type != EXPR_VARIABLE
8918 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
8919 || code->expr1->symtree->n.sym->ts.kind
8920 != gfc_default_integer_kind
8921 || code->expr1->symtree->n.sym->as != NULL))
8922 gfc_error ("ASSIGN statement at %L requires a scalar "
8923 "default INTEGER variable", &code->expr1->where);
8926 case EXEC_POINTER_ASSIGN:
8933 /* This is both a variable definition and pointer assignment
8934 context, so check both of them. For rank remapping, a final
8935 array ref may be present on the LHS and fool gfc_expr_attr
8936 used in gfc_check_vardef_context. Remove it. */
8937 e = remove_last_array_ref (code->expr1);
8938 t = gfc_check_vardef_context (e, true, _("pointer assignment"));
8940 t = gfc_check_vardef_context (e, false, _("pointer assignment"));
8945 gfc_check_pointer_assign (code->expr1, code->expr2);
8949 case EXEC_ARITHMETIC_IF:
8951 && code->expr1->ts.type != BT_INTEGER
8952 && code->expr1->ts.type != BT_REAL)
8953 gfc_error ("Arithmetic IF statement at %L requires a numeric "
8954 "expression", &code->expr1->where);
8956 resolve_branch (code->label1, code);
8957 resolve_branch (code->label2, code);
8958 resolve_branch (code->label3, code);
8962 if (t == SUCCESS && code->expr1 != NULL
8963 && (code->expr1->ts.type != BT_LOGICAL
8964 || code->expr1->rank != 0))
8965 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8966 &code->expr1->where);
8971 resolve_call (code);
8976 resolve_typebound_subroutine (code);
8980 resolve_ppc_call (code);
8984 /* Select is complicated. Also, a SELECT construct could be
8985 a transformed computed GOTO. */
8986 resolve_select (code);
8989 case EXEC_SELECT_TYPE:
8990 resolve_select_type (code, ns);
8994 resolve_block_construct (code);
8998 if (code->ext.iterator != NULL)
9000 gfc_iterator *iter = code->ext.iterator;
9001 if (gfc_resolve_iterator (iter, true) != FAILURE)
9002 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
9007 if (code->expr1 == NULL)
9008 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9010 && (code->expr1->rank != 0
9011 || code->expr1->ts.type != BT_LOGICAL))
9012 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9013 "a scalar LOGICAL expression", &code->expr1->where);
9018 resolve_allocate_deallocate (code, "ALLOCATE");
9022 case EXEC_DEALLOCATE:
9024 resolve_allocate_deallocate (code, "DEALLOCATE");
9029 if (gfc_resolve_open (code->ext.open) == FAILURE)
9032 resolve_branch (code->ext.open->err, code);
9036 if (gfc_resolve_close (code->ext.close) == FAILURE)
9039 resolve_branch (code->ext.close->err, code);
9042 case EXEC_BACKSPACE:
9046 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
9049 resolve_branch (code->ext.filepos->err, code);
9053 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9056 resolve_branch (code->ext.inquire->err, code);
9060 gcc_assert (code->ext.inquire != NULL);
9061 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9064 resolve_branch (code->ext.inquire->err, code);
9068 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
9071 resolve_branch (code->ext.wait->err, code);
9072 resolve_branch (code->ext.wait->end, code);
9073 resolve_branch (code->ext.wait->eor, code);
9078 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
9081 resolve_branch (code->ext.dt->err, code);
9082 resolve_branch (code->ext.dt->end, code);
9083 resolve_branch (code->ext.dt->eor, code);
9087 resolve_transfer (code);
9091 resolve_forall_iterators (code->ext.forall_iterator);
9093 if (code->expr1 != NULL && code->expr1->ts.type != BT_LOGICAL)
9094 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
9095 "expression", &code->expr1->where);
9098 case EXEC_OMP_ATOMIC:
9099 case EXEC_OMP_BARRIER:
9100 case EXEC_OMP_CRITICAL:
9101 case EXEC_OMP_FLUSH:
9103 case EXEC_OMP_MASTER:
9104 case EXEC_OMP_ORDERED:
9105 case EXEC_OMP_SECTIONS:
9106 case EXEC_OMP_SINGLE:
9107 case EXEC_OMP_TASKWAIT:
9108 case EXEC_OMP_WORKSHARE:
9109 gfc_resolve_omp_directive (code, ns);
9112 case EXEC_OMP_PARALLEL:
9113 case EXEC_OMP_PARALLEL_DO:
9114 case EXEC_OMP_PARALLEL_SECTIONS:
9115 case EXEC_OMP_PARALLEL_WORKSHARE:
9117 omp_workshare_save = omp_workshare_flag;
9118 omp_workshare_flag = 0;
9119 gfc_resolve_omp_directive (code, ns);
9120 omp_workshare_flag = omp_workshare_save;
9124 gfc_internal_error ("resolve_code(): Bad statement code");
9128 cs_base = frame.prev;
9132 /* Resolve initial values and make sure they are compatible with
9136 resolve_values (gfc_symbol *sym)
9140 if (sym->value == NULL)
9143 if (sym->value->expr_type == EXPR_STRUCTURE)
9144 t= resolve_structure_cons (sym->value, 1);
9146 t = gfc_resolve_expr (sym->value);
9151 gfc_check_assign_symbol (sym, sym->value);
9155 /* Verify the binding labels for common blocks that are BIND(C). The label
9156 for a BIND(C) common block must be identical in all scoping units in which
9157 the common block is declared. Further, the binding label can not collide
9158 with any other global entity in the program. */
9161 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
9163 if (comm_block_tree->n.common->is_bind_c == 1)
9165 gfc_gsymbol *binding_label_gsym;
9166 gfc_gsymbol *comm_name_gsym;
9168 /* See if a global symbol exists by the common block's name. It may
9169 be NULL if the common block is use-associated. */
9170 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
9171 comm_block_tree->n.common->name);
9172 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
9173 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9174 "with the global entity '%s' at %L",
9175 comm_block_tree->n.common->binding_label,
9176 comm_block_tree->n.common->name,
9177 &(comm_block_tree->n.common->where),
9178 comm_name_gsym->name, &(comm_name_gsym->where));
9179 else if (comm_name_gsym != NULL
9180 && strcmp (comm_name_gsym->name,
9181 comm_block_tree->n.common->name) == 0)
9183 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9185 if (comm_name_gsym->binding_label == NULL)
9186 /* No binding label for common block stored yet; save this one. */
9187 comm_name_gsym->binding_label =
9188 comm_block_tree->n.common->binding_label;
9190 if (strcmp (comm_name_gsym->binding_label,
9191 comm_block_tree->n.common->binding_label) != 0)
9193 /* Common block names match but binding labels do not. */
9194 gfc_error ("Binding label '%s' for common block '%s' at %L "
9195 "does not match the binding label '%s' for common "
9197 comm_block_tree->n.common->binding_label,
9198 comm_block_tree->n.common->name,
9199 &(comm_block_tree->n.common->where),
9200 comm_name_gsym->binding_label,
9201 comm_name_gsym->name,
9202 &(comm_name_gsym->where));
9207 /* There is no binding label (NAME="") so we have nothing further to
9208 check and nothing to add as a global symbol for the label. */
9209 if (comm_block_tree->n.common->binding_label[0] == '\0' )
9212 binding_label_gsym =
9213 gfc_find_gsymbol (gfc_gsym_root,
9214 comm_block_tree->n.common->binding_label);
9215 if (binding_label_gsym == NULL)
9217 /* Need to make a global symbol for the binding label to prevent
9218 it from colliding with another. */
9219 binding_label_gsym =
9220 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9221 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9222 binding_label_gsym->type = GSYM_COMMON;
9226 /* If comm_name_gsym is NULL, the name common block is use
9227 associated and the name could be colliding. */
9228 if (binding_label_gsym->type != GSYM_COMMON)
9229 gfc_error ("Binding label '%s' for common block '%s' at %L "
9230 "collides with the global entity '%s' at %L",
9231 comm_block_tree->n.common->binding_label,
9232 comm_block_tree->n.common->name,
9233 &(comm_block_tree->n.common->where),
9234 binding_label_gsym->name,
9235 &(binding_label_gsym->where));
9236 else if (comm_name_gsym != NULL
9237 && (strcmp (binding_label_gsym->name,
9238 comm_name_gsym->binding_label) != 0)
9239 && (strcmp (binding_label_gsym->sym_name,
9240 comm_name_gsym->name) != 0))
9241 gfc_error ("Binding label '%s' for common block '%s' at %L "
9242 "collides with global entity '%s' at %L",
9243 binding_label_gsym->name, binding_label_gsym->sym_name,
9244 &(comm_block_tree->n.common->where),
9245 comm_name_gsym->name, &(comm_name_gsym->where));
9253 /* Verify any BIND(C) derived types in the namespace so we can report errors
9254 for them once, rather than for each variable declared of that type. */
9257 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9259 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9260 && derived_sym->attr.is_bind_c == 1)
9261 verify_bind_c_derived_type (derived_sym);
9267 /* Verify that any binding labels used in a given namespace do not collide
9268 with the names or binding labels of any global symbols. */
9271 gfc_verify_binding_labels (gfc_symbol *sym)
9275 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9276 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
9278 gfc_gsymbol *bind_c_sym;
9280 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9281 if (bind_c_sym != NULL
9282 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9284 if (sym->attr.if_source == IFSRC_DECL
9285 && (bind_c_sym->type != GSYM_SUBROUTINE
9286 && bind_c_sym->type != GSYM_FUNCTION)
9287 && ((sym->attr.contained == 1
9288 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9289 || (sym->attr.use_assoc == 1
9290 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9292 /* Make sure global procedures don't collide with anything. */
9293 gfc_error ("Binding label '%s' at %L collides with the global "
9294 "entity '%s' at %L", sym->binding_label,
9295 &(sym->declared_at), bind_c_sym->name,
9296 &(bind_c_sym->where));
9299 else if (sym->attr.contained == 0
9300 && (sym->attr.if_source == IFSRC_IFBODY
9301 && sym->attr.flavor == FL_PROCEDURE)
9302 && (bind_c_sym->sym_name != NULL
9303 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9305 /* Make sure procedures in interface bodies don't collide. */
9306 gfc_error ("Binding label '%s' in interface body at %L collides "
9307 "with the global entity '%s' at %L",
9309 &(sym->declared_at), bind_c_sym->name,
9310 &(bind_c_sym->where));
9313 else if (sym->attr.contained == 0
9314 && sym->attr.if_source == IFSRC_UNKNOWN)
9315 if ((sym->attr.use_assoc && bind_c_sym->mod_name
9316 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9317 || sym->attr.use_assoc == 0)
9319 gfc_error ("Binding label '%s' at %L collides with global "
9320 "entity '%s' at %L", sym->binding_label,
9321 &(sym->declared_at), bind_c_sym->name,
9322 &(bind_c_sym->where));
9327 /* Clear the binding label to prevent checking multiple times. */
9328 sym->binding_label[0] = '\0';
9330 else if (bind_c_sym == NULL)
9332 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9333 bind_c_sym->where = sym->declared_at;
9334 bind_c_sym->sym_name = sym->name;
9336 if (sym->attr.use_assoc == 1)
9337 bind_c_sym->mod_name = sym->module;
9339 if (sym->ns->proc_name != NULL)
9340 bind_c_sym->mod_name = sym->ns->proc_name->name;
9342 if (sym->attr.contained == 0)
9344 if (sym->attr.subroutine)
9345 bind_c_sym->type = GSYM_SUBROUTINE;
9346 else if (sym->attr.function)
9347 bind_c_sym->type = GSYM_FUNCTION;
9355 /* Resolve an index expression. */
9358 resolve_index_expr (gfc_expr *e)
9360 if (gfc_resolve_expr (e) == FAILURE)
9363 if (gfc_simplify_expr (e, 0) == FAILURE)
9366 if (gfc_specification_expr (e) == FAILURE)
9372 /* Resolve a charlen structure. */
9375 resolve_charlen (gfc_charlen *cl)
9384 specification_expr = 1;
9386 if (resolve_index_expr (cl->length) == FAILURE)
9388 specification_expr = 0;
9392 /* "If the character length parameter value evaluates to a negative
9393 value, the length of character entities declared is zero." */
9394 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9396 if (gfc_option.warn_surprising)
9397 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9398 " the length has been set to zero",
9399 &cl->length->where, i);
9400 gfc_replace_expr (cl->length,
9401 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9404 /* Check that the character length is not too large. */
9405 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9406 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9407 && cl->length->ts.type == BT_INTEGER
9408 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9410 gfc_error ("String length at %L is too large", &cl->length->where);
9418 /* Test for non-constant shape arrays. */
9421 is_non_constant_shape_array (gfc_symbol *sym)
9427 not_constant = false;
9428 if (sym->as != NULL)
9430 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9431 has not been simplified; parameter array references. Do the
9432 simplification now. */
9433 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9435 e = sym->as->lower[i];
9436 if (e && (resolve_index_expr (e) == FAILURE
9437 || !gfc_is_constant_expr (e)))
9438 not_constant = true;
9439 e = sym->as->upper[i];
9440 if (e && (resolve_index_expr (e) == FAILURE
9441 || !gfc_is_constant_expr (e)))
9442 not_constant = true;
9445 return not_constant;
9448 /* Given a symbol and an initialization expression, add code to initialize
9449 the symbol to the function entry. */
9451 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9455 gfc_namespace *ns = sym->ns;
9457 /* Search for the function namespace if this is a contained
9458 function without an explicit result. */
9459 if (sym->attr.function && sym == sym->result
9460 && sym->name != sym->ns->proc_name->name)
9463 for (;ns; ns = ns->sibling)
9464 if (strcmp (ns->proc_name->name, sym->name) == 0)
9470 gfc_free_expr (init);
9474 /* Build an l-value expression for the result. */
9475 lval = gfc_lval_expr_from_sym (sym);
9477 /* Add the code at scope entry. */
9478 init_st = gfc_get_code ();
9479 init_st->next = ns->code;
9482 /* Assign the default initializer to the l-value. */
9483 init_st->loc = sym->declared_at;
9484 init_st->op = EXEC_INIT_ASSIGN;
9485 init_st->expr1 = lval;
9486 init_st->expr2 = init;
9489 /* Assign the default initializer to a derived type variable or result. */
9492 apply_default_init (gfc_symbol *sym)
9494 gfc_expr *init = NULL;
9496 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9499 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
9500 init = gfc_default_initializer (&sym->ts);
9502 if (init == NULL && sym->ts.type != BT_CLASS)
9505 build_init_assign (sym, init);
9506 sym->attr.referenced = 1;
9509 /* Build an initializer for a local integer, real, complex, logical, or
9510 character variable, based on the command line flags finit-local-zero,
9511 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
9512 null if the symbol should not have a default initialization. */
9514 build_default_init_expr (gfc_symbol *sym)
9517 gfc_expr *init_expr;
9520 /* These symbols should never have a default initialization. */
9521 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
9522 || sym->attr.external
9524 || sym->attr.pointer
9525 || sym->attr.in_equivalence
9526 || sym->attr.in_common
9529 || sym->attr.cray_pointee
9530 || sym->attr.cray_pointer)
9533 /* Now we'll try to build an initializer expression. */
9534 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
9537 /* We will only initialize integers, reals, complex, logicals, and
9538 characters, and only if the corresponding command-line flags
9539 were set. Otherwise, we free init_expr and return null. */
9540 switch (sym->ts.type)
9543 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
9544 mpz_set_si (init_expr->value.integer,
9545 gfc_option.flag_init_integer_value);
9548 gfc_free_expr (init_expr);
9554 switch (gfc_option.flag_init_real)
9556 case GFC_INIT_REAL_SNAN:
9557 init_expr->is_snan = 1;
9559 case GFC_INIT_REAL_NAN:
9560 mpfr_set_nan (init_expr->value.real);
9563 case GFC_INIT_REAL_INF:
9564 mpfr_set_inf (init_expr->value.real, 1);
9567 case GFC_INIT_REAL_NEG_INF:
9568 mpfr_set_inf (init_expr->value.real, -1);
9571 case GFC_INIT_REAL_ZERO:
9572 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
9576 gfc_free_expr (init_expr);
9583 switch (gfc_option.flag_init_real)
9585 case GFC_INIT_REAL_SNAN:
9586 init_expr->is_snan = 1;
9588 case GFC_INIT_REAL_NAN:
9589 mpfr_set_nan (mpc_realref (init_expr->value.complex));
9590 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
9593 case GFC_INIT_REAL_INF:
9594 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
9595 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
9598 case GFC_INIT_REAL_NEG_INF:
9599 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
9600 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
9603 case GFC_INIT_REAL_ZERO:
9604 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
9608 gfc_free_expr (init_expr);
9615 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
9616 init_expr->value.logical = 0;
9617 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
9618 init_expr->value.logical = 1;
9621 gfc_free_expr (init_expr);
9627 /* For characters, the length must be constant in order to
9628 create a default initializer. */
9629 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
9630 && sym->ts.u.cl->length
9631 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9633 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
9634 init_expr->value.character.length = char_len;
9635 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
9636 for (i = 0; i < char_len; i++)
9637 init_expr->value.character.string[i]
9638 = (unsigned char) gfc_option.flag_init_character_value;
9642 gfc_free_expr (init_expr);
9648 gfc_free_expr (init_expr);
9654 /* Add an initialization expression to a local variable. */
9656 apply_default_init_local (gfc_symbol *sym)
9658 gfc_expr *init = NULL;
9660 /* The symbol should be a variable or a function return value. */
9661 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9662 || (sym->attr.function && sym->result != sym))
9665 /* Try to build the initializer expression. If we can't initialize
9666 this symbol, then init will be NULL. */
9667 init = build_default_init_expr (sym);
9671 /* For saved variables, we don't want to add an initializer at
9672 function entry, so we just add a static initializer. */
9673 if (sym->attr.save || sym->ns->save_all
9674 || gfc_option.flag_max_stack_var_size == 0)
9676 /* Don't clobber an existing initializer! */
9677 gcc_assert (sym->value == NULL);
9682 build_init_assign (sym, init);
9685 /* Resolution of common features of flavors variable and procedure. */
9688 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
9690 /* Constraints on deferred shape variable. */
9691 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
9693 if (sym->attr.allocatable)
9695 if (sym->attr.dimension)
9697 gfc_error ("Allocatable array '%s' at %L must have "
9698 "a deferred shape", sym->name, &sym->declared_at);
9701 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
9702 "may not be ALLOCATABLE", sym->name,
9703 &sym->declared_at) == FAILURE)
9707 if (sym->attr.pointer && sym->attr.dimension)
9709 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
9710 sym->name, &sym->declared_at);
9716 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
9717 && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc)
9719 gfc_error ("Array '%s' at %L cannot have a deferred shape",
9720 sym->name, &sym->declared_at);
9725 /* Constraints on polymorphic variables. */
9726 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
9729 if (sym->attr.class_ok
9730 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
9732 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
9733 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
9739 /* Assume that use associated symbols were checked in the module ns.
9740 Class-variables that are associate-names are also something special
9741 and excepted from the test. */
9742 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
9744 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
9745 "or pointer", sym->name, &sym->declared_at);
9754 /* Additional checks for symbols with flavor variable and derived
9755 type. To be called from resolve_fl_variable. */
9758 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
9760 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
9762 /* Check to see if a derived type is blocked from being host
9763 associated by the presence of another class I symbol in the same
9764 namespace. 14.6.1.3 of the standard and the discussion on
9765 comp.lang.fortran. */
9766 if (sym->ns != sym->ts.u.derived->ns
9767 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
9770 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
9771 if (s && s->attr.flavor != FL_DERIVED)
9773 gfc_error ("The type '%s' cannot be host associated at %L "
9774 "because it is blocked by an incompatible object "
9775 "of the same name declared at %L",
9776 sym->ts.u.derived->name, &sym->declared_at,
9782 /* 4th constraint in section 11.3: "If an object of a type for which
9783 component-initialization is specified (R429) appears in the
9784 specification-part of a module and does not have the ALLOCATABLE
9785 or POINTER attribute, the object shall have the SAVE attribute."
9787 The check for initializers is performed with
9788 gfc_has_default_initializer because gfc_default_initializer generates
9789 a hidden default for allocatable components. */
9790 if (!(sym->value || no_init_flag) && sym->ns->proc_name
9791 && sym->ns->proc_name->attr.flavor == FL_MODULE
9792 && !sym->ns->save_all && !sym->attr.save
9793 && !sym->attr.pointer && !sym->attr.allocatable
9794 && gfc_has_default_initializer (sym->ts.u.derived)
9795 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
9796 "module variable '%s' at %L, needed due to "
9797 "the default initialization", sym->name,
9798 &sym->declared_at) == FAILURE)
9801 /* Assign default initializer. */
9802 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
9803 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
9805 sym->value = gfc_default_initializer (&sym->ts);
9812 /* Resolve symbols with flavor variable. */
9815 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
9817 int no_init_flag, automatic_flag;
9819 const char *auto_save_msg;
9821 auto_save_msg = "Automatic object '%s' at %L cannot have the "
9824 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9827 /* Set this flag to check that variables are parameters of all entries.
9828 This check is effected by the call to gfc_resolve_expr through
9829 is_non_constant_shape_array. */
9830 specification_expr = 1;
9832 if (sym->ns->proc_name
9833 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9834 || sym->ns->proc_name->attr.is_main_program)
9835 && !sym->attr.use_assoc
9836 && !sym->attr.allocatable
9837 && !sym->attr.pointer
9838 && is_non_constant_shape_array (sym))
9840 /* The shape of a main program or module array needs to be
9842 gfc_error ("The module or main program array '%s' at %L must "
9843 "have constant shape", sym->name, &sym->declared_at);
9844 specification_expr = 0;
9848 if (sym->ts.type == BT_CHARACTER)
9850 /* Make sure that character string variables with assumed length are
9852 e = sym->ts.u.cl->length;
9853 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
9855 gfc_error ("Entity with assumed character length at %L must be a "
9856 "dummy argument or a PARAMETER", &sym->declared_at);
9860 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
9862 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9866 if (!gfc_is_constant_expr (e)
9867 && !(e->expr_type == EXPR_VARIABLE
9868 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
9869 && 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)
9874 gfc_error ("'%s' at %L must have constant character length "
9875 "in this context", sym->name, &sym->declared_at);
9880 if (sym->value == NULL && sym->attr.referenced)
9881 apply_default_init_local (sym); /* Try to apply a default initialization. */
9883 /* Determine if the symbol may not have an initializer. */
9884 no_init_flag = automatic_flag = 0;
9885 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
9886 || sym->attr.intrinsic || sym->attr.result)
9888 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
9889 && is_non_constant_shape_array (sym))
9891 no_init_flag = automatic_flag = 1;
9893 /* Also, they must not have the SAVE attribute.
9894 SAVE_IMPLICIT is checked below. */
9895 if (sym->attr.save == SAVE_EXPLICIT)
9897 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9902 /* Ensure that any initializer is simplified. */
9904 gfc_simplify_expr (sym->value, 1);
9906 /* Reject illegal initializers. */
9907 if (!sym->mark && sym->value)
9909 if (sym->attr.allocatable)
9910 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
9911 sym->name, &sym->declared_at);
9912 else if (sym->attr.external)
9913 gfc_error ("External '%s' at %L cannot have an initializer",
9914 sym->name, &sym->declared_at);
9915 else if (sym->attr.dummy
9916 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
9917 gfc_error ("Dummy '%s' at %L cannot have an initializer",
9918 sym->name, &sym->declared_at);
9919 else if (sym->attr.intrinsic)
9920 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
9921 sym->name, &sym->declared_at);
9922 else if (sym->attr.result)
9923 gfc_error ("Function result '%s' at %L cannot have an initializer",
9924 sym->name, &sym->declared_at);
9925 else if (automatic_flag)
9926 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
9927 sym->name, &sym->declared_at);
9934 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
9935 return resolve_fl_variable_derived (sym, no_init_flag);
9941 /* Resolve a procedure. */
9944 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
9946 gfc_formal_arglist *arg;
9948 if (sym->attr.function
9949 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9952 if (sym->ts.type == BT_CHARACTER)
9954 gfc_charlen *cl = sym->ts.u.cl;
9956 if (cl && cl->length && gfc_is_constant_expr (cl->length)
9957 && resolve_charlen (cl) == FAILURE)
9960 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
9961 && sym->attr.proc == PROC_ST_FUNCTION)
9963 gfc_error ("Character-valued statement function '%s' at %L must "
9964 "have constant length", sym->name, &sym->declared_at);
9969 /* Ensure that derived type for are not of a private type. Internal
9970 module procedures are excluded by 2.2.3.3 - i.e., they are not
9971 externally accessible and can access all the objects accessible in
9973 if (!(sym->ns->parent
9974 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
9975 && gfc_check_access(sym->attr.access, sym->ns->default_access))
9977 gfc_interface *iface;
9979 for (arg = sym->formal; arg; arg = arg->next)
9982 && arg->sym->ts.type == BT_DERIVED
9983 && !arg->sym->ts.u.derived->attr.use_assoc
9984 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
9985 arg->sym->ts.u.derived->ns->default_access)
9986 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
9987 "PRIVATE type and cannot be a dummy argument"
9988 " of '%s', which is PUBLIC at %L",
9989 arg->sym->name, sym->name, &sym->declared_at)
9992 /* Stop this message from recurring. */
9993 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
9998 /* PUBLIC interfaces may expose PRIVATE procedures that take types
9999 PRIVATE to the containing module. */
10000 for (iface = sym->generic; iface; iface = iface->next)
10002 for (arg = iface->sym->formal; arg; arg = arg->next)
10005 && arg->sym->ts.type == BT_DERIVED
10006 && !arg->sym->ts.u.derived->attr.use_assoc
10007 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10008 arg->sym->ts.u.derived->ns->default_access)
10009 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10010 "'%s' in PUBLIC interface '%s' at %L "
10011 "takes dummy arguments of '%s' which is "
10012 "PRIVATE", iface->sym->name, sym->name,
10013 &iface->sym->declared_at,
10014 gfc_typename (&arg->sym->ts)) == FAILURE)
10016 /* Stop this message from recurring. */
10017 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10023 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10024 PRIVATE to the containing module. */
10025 for (iface = sym->generic; iface; iface = iface->next)
10027 for (arg = iface->sym->formal; arg; arg = arg->next)
10030 && arg->sym->ts.type == BT_DERIVED
10031 && !arg->sym->ts.u.derived->attr.use_assoc
10032 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10033 arg->sym->ts.u.derived->ns->default_access)
10034 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10035 "'%s' in PUBLIC interface '%s' at %L "
10036 "takes dummy arguments of '%s' which is "
10037 "PRIVATE", iface->sym->name, sym->name,
10038 &iface->sym->declared_at,
10039 gfc_typename (&arg->sym->ts)) == FAILURE)
10041 /* Stop this message from recurring. */
10042 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10049 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10050 && !sym->attr.proc_pointer)
10052 gfc_error ("Function '%s' at %L cannot have an initializer",
10053 sym->name, &sym->declared_at);
10057 /* An external symbol may not have an initializer because it is taken to be
10058 a procedure. Exception: Procedure Pointers. */
10059 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10061 gfc_error ("External object '%s' at %L may not have an initializer",
10062 sym->name, &sym->declared_at);
10066 /* An elemental function is required to return a scalar 12.7.1 */
10067 if (sym->attr.elemental && sym->attr.function && sym->as)
10069 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10070 "result", sym->name, &sym->declared_at);
10071 /* Reset so that the error only occurs once. */
10072 sym->attr.elemental = 0;
10076 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10077 char-len-param shall not be array-valued, pointer-valued, recursive
10078 or pure. ....snip... A character value of * may only be used in the
10079 following ways: (i) Dummy arg of procedure - dummy associates with
10080 actual length; (ii) To declare a named constant; or (iii) External
10081 function - but length must be declared in calling scoping unit. */
10082 if (sym->attr.function
10083 && sym->ts.type == BT_CHARACTER
10084 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10086 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10087 || (sym->attr.recursive) || (sym->attr.pure))
10089 if (sym->as && sym->as->rank)
10090 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10091 "array-valued", sym->name, &sym->declared_at);
10093 if (sym->attr.pointer)
10094 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10095 "pointer-valued", sym->name, &sym->declared_at);
10097 if (sym->attr.pure)
10098 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10099 "pure", sym->name, &sym->declared_at);
10101 if (sym->attr.recursive)
10102 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10103 "recursive", sym->name, &sym->declared_at);
10108 /* Appendix B.2 of the standard. Contained functions give an
10109 error anyway. Fixed-form is likely to be F77/legacy. */
10110 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
10111 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10112 "CHARACTER(*) function '%s' at %L",
10113 sym->name, &sym->declared_at);
10116 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10118 gfc_formal_arglist *curr_arg;
10119 int has_non_interop_arg = 0;
10121 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10122 sym->common_block) == FAILURE)
10124 /* Clear these to prevent looking at them again if there was an
10126 sym->attr.is_bind_c = 0;
10127 sym->attr.is_c_interop = 0;
10128 sym->ts.is_c_interop = 0;
10132 /* So far, no errors have been found. */
10133 sym->attr.is_c_interop = 1;
10134 sym->ts.is_c_interop = 1;
10137 curr_arg = sym->formal;
10138 while (curr_arg != NULL)
10140 /* Skip implicitly typed dummy args here. */
10141 if (curr_arg->sym->attr.implicit_type == 0)
10142 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
10143 /* If something is found to fail, record the fact so we
10144 can mark the symbol for the procedure as not being
10145 BIND(C) to try and prevent multiple errors being
10147 has_non_interop_arg = 1;
10149 curr_arg = curr_arg->next;
10152 /* See if any of the arguments were not interoperable and if so, clear
10153 the procedure symbol to prevent duplicate error messages. */
10154 if (has_non_interop_arg != 0)
10156 sym->attr.is_c_interop = 0;
10157 sym->ts.is_c_interop = 0;
10158 sym->attr.is_bind_c = 0;
10162 if (!sym->attr.proc_pointer)
10164 if (sym->attr.save == SAVE_EXPLICIT)
10166 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10167 "in '%s' at %L", sym->name, &sym->declared_at);
10170 if (sym->attr.intent)
10172 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10173 "in '%s' at %L", sym->name, &sym->declared_at);
10176 if (sym->attr.subroutine && sym->attr.result)
10178 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10179 "in '%s' at %L", sym->name, &sym->declared_at);
10182 if (sym->attr.external && sym->attr.function
10183 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10184 || sym->attr.contained))
10186 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10187 "in '%s' at %L", sym->name, &sym->declared_at);
10190 if (strcmp ("ppr@", sym->name) == 0)
10192 gfc_error ("Procedure pointer result '%s' at %L "
10193 "is missing the pointer attribute",
10194 sym->ns->proc_name->name, &sym->declared_at);
10203 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10204 been defined and we now know their defined arguments, check that they fulfill
10205 the requirements of the standard for procedures used as finalizers. */
10208 gfc_resolve_finalizers (gfc_symbol* derived)
10210 gfc_finalizer* list;
10211 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10212 gfc_try result = SUCCESS;
10213 bool seen_scalar = false;
10215 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10218 /* Walk over the list of finalizer-procedures, check them, and if any one
10219 does not fit in with the standard's definition, print an error and remove
10220 it from the list. */
10221 prev_link = &derived->f2k_derived->finalizers;
10222 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10228 /* Skip this finalizer if we already resolved it. */
10229 if (list->proc_tree)
10231 prev_link = &(list->next);
10235 /* Check this exists and is a SUBROUTINE. */
10236 if (!list->proc_sym->attr.subroutine)
10238 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10239 list->proc_sym->name, &list->where);
10243 /* We should have exactly one argument. */
10244 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10246 gfc_error ("FINAL procedure at %L must have exactly one argument",
10250 arg = list->proc_sym->formal->sym;
10252 /* This argument must be of our type. */
10253 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10255 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10256 &arg->declared_at, derived->name);
10260 /* It must neither be a pointer nor allocatable nor optional. */
10261 if (arg->attr.pointer)
10263 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10264 &arg->declared_at);
10267 if (arg->attr.allocatable)
10269 gfc_error ("Argument of FINAL procedure at %L must not be"
10270 " ALLOCATABLE", &arg->declared_at);
10273 if (arg->attr.optional)
10275 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10276 &arg->declared_at);
10280 /* It must not be INTENT(OUT). */
10281 if (arg->attr.intent == INTENT_OUT)
10283 gfc_error ("Argument of FINAL procedure at %L must not be"
10284 " INTENT(OUT)", &arg->declared_at);
10288 /* Warn if the procedure is non-scalar and not assumed shape. */
10289 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10290 && arg->as->type != AS_ASSUMED_SHAPE)
10291 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10292 " shape argument", &arg->declared_at);
10294 /* Check that it does not match in kind and rank with a FINAL procedure
10295 defined earlier. To really loop over the *earlier* declarations,
10296 we need to walk the tail of the list as new ones were pushed at the
10298 /* TODO: Handle kind parameters once they are implemented. */
10299 my_rank = (arg->as ? arg->as->rank : 0);
10300 for (i = list->next; i; i = i->next)
10302 /* Argument list might be empty; that is an error signalled earlier,
10303 but we nevertheless continued resolving. */
10304 if (i->proc_sym->formal)
10306 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10307 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10308 if (i_rank == my_rank)
10310 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10311 " rank (%d) as '%s'",
10312 list->proc_sym->name, &list->where, my_rank,
10313 i->proc_sym->name);
10319 /* Is this the/a scalar finalizer procedure? */
10320 if (!arg->as || arg->as->rank == 0)
10321 seen_scalar = true;
10323 /* Find the symtree for this procedure. */
10324 gcc_assert (!list->proc_tree);
10325 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10327 prev_link = &list->next;
10330 /* Remove wrong nodes immediately from the list so we don't risk any
10331 troubles in the future when they might fail later expectations. */
10335 *prev_link = list->next;
10336 gfc_free_finalizer (i);
10339 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10340 were nodes in the list, must have been for arrays. It is surely a good
10341 idea to have a scalar version there if there's something to finalize. */
10342 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10343 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10344 " defined at %L, suggest also scalar one",
10345 derived->name, &derived->declared_at);
10347 /* TODO: Remove this error when finalization is finished. */
10348 gfc_error ("Finalization at %L is not yet implemented",
10349 &derived->declared_at);
10355 /* Check that it is ok for the typebound procedure proc to override the
10359 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
10362 const gfc_symbol* proc_target;
10363 const gfc_symbol* old_target;
10364 unsigned proc_pass_arg, old_pass_arg, argpos;
10365 gfc_formal_arglist* proc_formal;
10366 gfc_formal_arglist* old_formal;
10368 /* This procedure should only be called for non-GENERIC proc. */
10369 gcc_assert (!proc->n.tb->is_generic);
10371 /* If the overwritten procedure is GENERIC, this is an error. */
10372 if (old->n.tb->is_generic)
10374 gfc_error ("Can't overwrite GENERIC '%s' at %L",
10375 old->name, &proc->n.tb->where);
10379 where = proc->n.tb->where;
10380 proc_target = proc->n.tb->u.specific->n.sym;
10381 old_target = old->n.tb->u.specific->n.sym;
10383 /* Check that overridden binding is not NON_OVERRIDABLE. */
10384 if (old->n.tb->non_overridable)
10386 gfc_error ("'%s' at %L overrides a procedure binding declared"
10387 " NON_OVERRIDABLE", proc->name, &where);
10391 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
10392 if (!old->n.tb->deferred && proc->n.tb->deferred)
10394 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
10395 " non-DEFERRED binding", proc->name, &where);
10399 /* If the overridden binding is PURE, the overriding must be, too. */
10400 if (old_target->attr.pure && !proc_target->attr.pure)
10402 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
10403 proc->name, &where);
10407 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
10408 is not, the overriding must not be either. */
10409 if (old_target->attr.elemental && !proc_target->attr.elemental)
10411 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
10412 " ELEMENTAL", proc->name, &where);
10415 if (!old_target->attr.elemental && proc_target->attr.elemental)
10417 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
10418 " be ELEMENTAL, either", proc->name, &where);
10422 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
10424 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
10426 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
10427 " SUBROUTINE", proc->name, &where);
10431 /* If the overridden binding is a FUNCTION, the overriding must also be a
10432 FUNCTION and have the same characteristics. */
10433 if (old_target->attr.function)
10435 if (!proc_target->attr.function)
10437 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
10438 " FUNCTION", proc->name, &where);
10442 /* FIXME: Do more comprehensive checking (including, for instance, the
10443 rank and array-shape). */
10444 gcc_assert (proc_target->result && old_target->result);
10445 if (!gfc_compare_types (&proc_target->result->ts,
10446 &old_target->result->ts))
10448 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
10449 " matching result types", proc->name, &where);
10454 /* If the overridden binding is PUBLIC, the overriding one must not be
10456 if (old->n.tb->access == ACCESS_PUBLIC
10457 && proc->n.tb->access == ACCESS_PRIVATE)
10459 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
10460 " PRIVATE", proc->name, &where);
10464 /* Compare the formal argument lists of both procedures. This is also abused
10465 to find the position of the passed-object dummy arguments of both
10466 bindings as at least the overridden one might not yet be resolved and we
10467 need those positions in the check below. */
10468 proc_pass_arg = old_pass_arg = 0;
10469 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
10471 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
10474 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
10475 proc_formal && old_formal;
10476 proc_formal = proc_formal->next, old_formal = old_formal->next)
10478 if (proc->n.tb->pass_arg
10479 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
10480 proc_pass_arg = argpos;
10481 if (old->n.tb->pass_arg
10482 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
10483 old_pass_arg = argpos;
10485 /* Check that the names correspond. */
10486 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
10488 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
10489 " to match the corresponding argument of the overridden"
10490 " procedure", proc_formal->sym->name, proc->name, &where,
10491 old_formal->sym->name);
10495 /* Check that the types correspond if neither is the passed-object
10497 /* FIXME: Do more comprehensive testing here. */
10498 if (proc_pass_arg != argpos && old_pass_arg != argpos
10499 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
10501 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
10502 "in respect to the overridden procedure",
10503 proc_formal->sym->name, proc->name, &where);
10509 if (proc_formal || old_formal)
10511 gfc_error ("'%s' at %L must have the same number of formal arguments as"
10512 " the overridden procedure", proc->name, &where);
10516 /* If the overridden binding is NOPASS, the overriding one must also be
10518 if (old->n.tb->nopass && !proc->n.tb->nopass)
10520 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
10521 " NOPASS", proc->name, &where);
10525 /* If the overridden binding is PASS(x), the overriding one must also be
10526 PASS and the passed-object dummy arguments must correspond. */
10527 if (!old->n.tb->nopass)
10529 if (proc->n.tb->nopass)
10531 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
10532 " PASS", proc->name, &where);
10536 if (proc_pass_arg != old_pass_arg)
10538 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
10539 " the same position as the passed-object dummy argument of"
10540 " the overridden procedure", proc->name, &where);
10549 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10552 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10553 const char* generic_name, locus where)
10558 gcc_assert (t1->specific && t2->specific);
10559 gcc_assert (!t1->specific->is_generic);
10560 gcc_assert (!t2->specific->is_generic);
10562 sym1 = t1->specific->u.specific->n.sym;
10563 sym2 = t2->specific->u.specific->n.sym;
10568 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10569 if (sym1->attr.subroutine != sym2->attr.subroutine
10570 || sym1->attr.function != sym2->attr.function)
10572 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10573 " GENERIC '%s' at %L",
10574 sym1->name, sym2->name, generic_name, &where);
10578 /* Compare the interfaces. */
10579 if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
10581 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10582 sym1->name, sym2->name, generic_name, &where);
10590 /* Worker function for resolving a generic procedure binding; this is used to
10591 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10593 The difference between those cases is finding possible inherited bindings
10594 that are overridden, as one has to look for them in tb_sym_root,
10595 tb_uop_root or tb_op, respectively. Thus the caller must already find
10596 the super-type and set p->overridden correctly. */
10599 resolve_tb_generic_targets (gfc_symbol* super_type,
10600 gfc_typebound_proc* p, const char* name)
10602 gfc_tbp_generic* target;
10603 gfc_symtree* first_target;
10604 gfc_symtree* inherited;
10606 gcc_assert (p && p->is_generic);
10608 /* Try to find the specific bindings for the symtrees in our target-list. */
10609 gcc_assert (p->u.generic);
10610 for (target = p->u.generic; target; target = target->next)
10611 if (!target->specific)
10613 gfc_typebound_proc* overridden_tbp;
10614 gfc_tbp_generic* g;
10615 const char* target_name;
10617 target_name = target->specific_st->name;
10619 /* Defined for this type directly. */
10620 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
10622 target->specific = target->specific_st->n.tb;
10623 goto specific_found;
10626 /* Look for an inherited specific binding. */
10629 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
10634 gcc_assert (inherited->n.tb);
10635 target->specific = inherited->n.tb;
10636 goto specific_found;
10640 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
10641 " at %L", target_name, name, &p->where);
10644 /* Once we've found the specific binding, check it is not ambiguous with
10645 other specifics already found or inherited for the same GENERIC. */
10647 gcc_assert (target->specific);
10649 /* This must really be a specific binding! */
10650 if (target->specific->is_generic)
10652 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
10653 " '%s' is GENERIC, too", name, &p->where, target_name);
10657 /* Check those already resolved on this type directly. */
10658 for (g = p->u.generic; g; g = g->next)
10659 if (g != target && g->specific
10660 && check_generic_tbp_ambiguity (target, g, name, p->where)
10664 /* Check for ambiguity with inherited specific targets. */
10665 for (overridden_tbp = p->overridden; overridden_tbp;
10666 overridden_tbp = overridden_tbp->overridden)
10667 if (overridden_tbp->is_generic)
10669 for (g = overridden_tbp->u.generic; g; g = g->next)
10671 gcc_assert (g->specific);
10672 if (check_generic_tbp_ambiguity (target, g,
10673 name, p->where) == FAILURE)
10679 /* If we attempt to "overwrite" a specific binding, this is an error. */
10680 if (p->overridden && !p->overridden->is_generic)
10682 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
10683 " the same name", name, &p->where);
10687 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
10688 all must have the same attributes here. */
10689 first_target = p->u.generic->specific->u.specific;
10690 gcc_assert (first_target);
10691 p->subroutine = first_target->n.sym->attr.subroutine;
10692 p->function = first_target->n.sym->attr.function;
10698 /* Resolve a GENERIC procedure binding for a derived type. */
10701 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
10703 gfc_symbol* super_type;
10705 /* Find the overridden binding if any. */
10706 st->n.tb->overridden = NULL;
10707 super_type = gfc_get_derived_super_type (derived);
10710 gfc_symtree* overridden;
10711 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
10714 if (overridden && overridden->n.tb)
10715 st->n.tb->overridden = overridden->n.tb;
10718 /* Resolve using worker function. */
10719 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
10723 /* Retrieve the target-procedure of an operator binding and do some checks in
10724 common for intrinsic and user-defined type-bound operators. */
10727 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
10729 gfc_symbol* target_proc;
10731 gcc_assert (target->specific && !target->specific->is_generic);
10732 target_proc = target->specific->u.specific->n.sym;
10733 gcc_assert (target_proc);
10735 /* All operator bindings must have a passed-object dummy argument. */
10736 if (target->specific->nopass)
10738 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
10742 return target_proc;
10746 /* Resolve a type-bound intrinsic operator. */
10749 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
10750 gfc_typebound_proc* p)
10752 gfc_symbol* super_type;
10753 gfc_tbp_generic* target;
10755 /* If there's already an error here, do nothing (but don't fail again). */
10759 /* Operators should always be GENERIC bindings. */
10760 gcc_assert (p->is_generic);
10762 /* Look for an overridden binding. */
10763 super_type = gfc_get_derived_super_type (derived);
10764 if (super_type && super_type->f2k_derived)
10765 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
10768 p->overridden = NULL;
10770 /* Resolve general GENERIC properties using worker function. */
10771 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
10774 /* Check the targets to be procedures of correct interface. */
10775 for (target = p->u.generic; target; target = target->next)
10777 gfc_symbol* target_proc;
10779 target_proc = get_checked_tb_operator_target (target, p->where);
10783 if (!gfc_check_operator_interface (target_proc, op, p->where))
10795 /* Resolve a type-bound user operator (tree-walker callback). */
10797 static gfc_symbol* resolve_bindings_derived;
10798 static gfc_try resolve_bindings_result;
10800 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
10803 resolve_typebound_user_op (gfc_symtree* stree)
10805 gfc_symbol* super_type;
10806 gfc_tbp_generic* target;
10808 gcc_assert (stree && stree->n.tb);
10810 if (stree->n.tb->error)
10813 /* Operators should always be GENERIC bindings. */
10814 gcc_assert (stree->n.tb->is_generic);
10816 /* Find overridden procedure, if any. */
10817 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10818 if (super_type && super_type->f2k_derived)
10820 gfc_symtree* overridden;
10821 overridden = gfc_find_typebound_user_op (super_type, NULL,
10822 stree->name, true, NULL);
10824 if (overridden && overridden->n.tb)
10825 stree->n.tb->overridden = overridden->n.tb;
10828 stree->n.tb->overridden = NULL;
10830 /* Resolve basically using worker function. */
10831 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
10835 /* Check the targets to be functions of correct interface. */
10836 for (target = stree->n.tb->u.generic; target; target = target->next)
10838 gfc_symbol* target_proc;
10840 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
10844 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
10851 resolve_bindings_result = FAILURE;
10852 stree->n.tb->error = 1;
10856 /* Resolve the type-bound procedures for a derived type. */
10859 resolve_typebound_procedure (gfc_symtree* stree)
10863 gfc_symbol* me_arg;
10864 gfc_symbol* super_type;
10865 gfc_component* comp;
10867 gcc_assert (stree);
10869 /* Undefined specific symbol from GENERIC target definition. */
10873 if (stree->n.tb->error)
10876 /* If this is a GENERIC binding, use that routine. */
10877 if (stree->n.tb->is_generic)
10879 if (resolve_typebound_generic (resolve_bindings_derived, stree)
10885 /* Get the target-procedure to check it. */
10886 gcc_assert (!stree->n.tb->is_generic);
10887 gcc_assert (stree->n.tb->u.specific);
10888 proc = stree->n.tb->u.specific->n.sym;
10889 where = stree->n.tb->where;
10891 /* Default access should already be resolved from the parser. */
10892 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
10894 /* It should be a module procedure or an external procedure with explicit
10895 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
10896 if ((!proc->attr.subroutine && !proc->attr.function)
10897 || (proc->attr.proc != PROC_MODULE
10898 && proc->attr.if_source != IFSRC_IFBODY)
10899 || (proc->attr.abstract && !stree->n.tb->deferred))
10901 gfc_error ("'%s' must be a module procedure or an external procedure with"
10902 " an explicit interface at %L", proc->name, &where);
10905 stree->n.tb->subroutine = proc->attr.subroutine;
10906 stree->n.tb->function = proc->attr.function;
10908 /* Find the super-type of the current derived type. We could do this once and
10909 store in a global if speed is needed, but as long as not I believe this is
10910 more readable and clearer. */
10911 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10913 /* If PASS, resolve and check arguments if not already resolved / loaded
10914 from a .mod file. */
10915 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
10917 if (stree->n.tb->pass_arg)
10919 gfc_formal_arglist* i;
10921 /* If an explicit passing argument name is given, walk the arg-list
10922 and look for it. */
10925 stree->n.tb->pass_arg_num = 1;
10926 for (i = proc->formal; i; i = i->next)
10928 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
10933 ++stree->n.tb->pass_arg_num;
10938 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
10940 proc->name, stree->n.tb->pass_arg, &where,
10941 stree->n.tb->pass_arg);
10947 /* Otherwise, take the first one; there should in fact be at least
10949 stree->n.tb->pass_arg_num = 1;
10952 gfc_error ("Procedure '%s' with PASS at %L must have at"
10953 " least one argument", proc->name, &where);
10956 me_arg = proc->formal->sym;
10959 /* Now check that the argument-type matches and the passed-object
10960 dummy argument is generally fine. */
10962 gcc_assert (me_arg);
10964 if (me_arg->ts.type != BT_CLASS)
10966 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
10967 " at %L", proc->name, &where);
10971 if (CLASS_DATA (me_arg)->ts.u.derived
10972 != resolve_bindings_derived)
10974 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
10975 " the derived-type '%s'", me_arg->name, proc->name,
10976 me_arg->name, &where, resolve_bindings_derived->name);
10980 gcc_assert (me_arg->ts.type == BT_CLASS);
10981 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
10983 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
10984 " scalar", proc->name, &where);
10987 if (CLASS_DATA (me_arg)->attr.allocatable)
10989 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
10990 " be ALLOCATABLE", proc->name, &where);
10993 if (CLASS_DATA (me_arg)->attr.class_pointer)
10995 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
10996 " be POINTER", proc->name, &where);
11001 /* If we are extending some type, check that we don't override a procedure
11002 flagged NON_OVERRIDABLE. */
11003 stree->n.tb->overridden = NULL;
11006 gfc_symtree* overridden;
11007 overridden = gfc_find_typebound_proc (super_type, NULL,
11008 stree->name, true, NULL);
11010 if (overridden && overridden->n.tb)
11011 stree->n.tb->overridden = overridden->n.tb;
11013 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
11017 /* See if there's a name collision with a component directly in this type. */
11018 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11019 if (!strcmp (comp->name, stree->name))
11021 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11023 stree->name, &where, resolve_bindings_derived->name);
11027 /* Try to find a name collision with an inherited component. */
11028 if (super_type && gfc_find_component (super_type, stree->name, true, true))
11030 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11031 " component of '%s'",
11032 stree->name, &where, resolve_bindings_derived->name);
11036 stree->n.tb->error = 0;
11040 resolve_bindings_result = FAILURE;
11041 stree->n.tb->error = 1;
11046 resolve_typebound_procedures (gfc_symbol* derived)
11050 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11053 resolve_bindings_derived = derived;
11054 resolve_bindings_result = SUCCESS;
11056 /* Make sure the vtab has been generated. */
11057 gfc_find_derived_vtab (derived);
11059 if (derived->f2k_derived->tb_sym_root)
11060 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11061 &resolve_typebound_procedure);
11063 if (derived->f2k_derived->tb_uop_root)
11064 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11065 &resolve_typebound_user_op);
11067 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11069 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11070 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11072 resolve_bindings_result = FAILURE;
11075 return resolve_bindings_result;
11079 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11080 to give all identical derived types the same backend_decl. */
11082 add_dt_to_dt_list (gfc_symbol *derived)
11084 gfc_dt_list *dt_list;
11086 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11087 if (derived == dt_list->derived)
11090 if (dt_list == NULL)
11092 dt_list = gfc_get_dt_list ();
11093 dt_list->next = gfc_derived_types;
11094 dt_list->derived = derived;
11095 gfc_derived_types = dt_list;
11100 /* Ensure that a derived-type is really not abstract, meaning that every
11101 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11104 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11109 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11111 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11114 if (st->n.tb && st->n.tb->deferred)
11116 gfc_symtree* overriding;
11117 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11120 gcc_assert (overriding->n.tb);
11121 if (overriding->n.tb->deferred)
11123 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11124 " '%s' is DEFERRED and not overridden",
11125 sub->name, &sub->declared_at, st->name);
11134 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11136 /* The algorithm used here is to recursively travel up the ancestry of sub
11137 and for each ancestor-type, check all bindings. If any of them is
11138 DEFERRED, look it up starting from sub and see if the found (overriding)
11139 binding is not DEFERRED.
11140 This is not the most efficient way to do this, but it should be ok and is
11141 clearer than something sophisticated. */
11143 gcc_assert (ancestor && !sub->attr.abstract);
11145 if (!ancestor->attr.abstract)
11148 /* Walk bindings of this ancestor. */
11149 if (ancestor->f2k_derived)
11152 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11157 /* Find next ancestor type and recurse on it. */
11158 ancestor = gfc_get_derived_super_type (ancestor);
11160 return ensure_not_abstract (sub, ancestor);
11166 /* Resolve the components of a derived type. */
11169 resolve_fl_derived (gfc_symbol *sym)
11171 gfc_symbol* super_type;
11174 super_type = gfc_get_derived_super_type (sym);
11176 if (sym->attr.is_class && sym->ts.u.derived == NULL)
11178 /* Fix up incomplete CLASS symbols. */
11179 gfc_component *data = gfc_find_component (sym, "$data", true, true);
11180 gfc_component *vptr = gfc_find_component (sym, "$vptr", true, true);
11181 if (vptr->ts.u.derived == NULL)
11183 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
11185 vptr->ts.u.derived = vtab->ts.u.derived;
11190 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11192 gfc_error ("As extending type '%s' at %L has a coarray component, "
11193 "parent type '%s' shall also have one", sym->name,
11194 &sym->declared_at, super_type->name);
11198 /* Ensure the extended type gets resolved before we do. */
11199 if (super_type && resolve_fl_derived (super_type) == FAILURE)
11202 /* An ABSTRACT type must be extensible. */
11203 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11205 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11206 sym->name, &sym->declared_at);
11210 for (c = sym->components; c != NULL; c = c->next)
11213 if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */
11214 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11216 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11217 "deferred shape", c->name, &c->loc);
11222 if (c->attr.codimension && c->ts.type == BT_DERIVED
11223 && c->ts.u.derived->ts.is_iso_c)
11225 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11226 "shall not be a coarray", c->name, &c->loc);
11231 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11232 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11233 || c->attr.allocatable))
11235 gfc_error ("Component '%s' at %L with coarray component "
11236 "shall be a nonpointer, nonallocatable scalar",
11242 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11244 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11245 "is not an array pointer", c->name, &c->loc);
11249 if (c->attr.proc_pointer && c->ts.interface)
11251 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11252 gfc_error ("Interface '%s', used by procedure pointer component "
11253 "'%s' at %L, is declared in a later PROCEDURE statement",
11254 c->ts.interface->name, c->name, &c->loc);
11256 /* Get the attributes from the interface (now resolved). */
11257 if (c->ts.interface->attr.if_source
11258 || c->ts.interface->attr.intrinsic)
11260 gfc_symbol *ifc = c->ts.interface;
11262 if (ifc->formal && !ifc->formal_ns)
11263 resolve_symbol (ifc);
11265 if (ifc->attr.intrinsic)
11266 resolve_intrinsic (ifc, &ifc->declared_at);
11270 c->ts = ifc->result->ts;
11271 c->attr.allocatable = ifc->result->attr.allocatable;
11272 c->attr.pointer = ifc->result->attr.pointer;
11273 c->attr.dimension = ifc->result->attr.dimension;
11274 c->as = gfc_copy_array_spec (ifc->result->as);
11279 c->attr.allocatable = ifc->attr.allocatable;
11280 c->attr.pointer = ifc->attr.pointer;
11281 c->attr.dimension = ifc->attr.dimension;
11282 c->as = gfc_copy_array_spec (ifc->as);
11284 c->ts.interface = ifc;
11285 c->attr.function = ifc->attr.function;
11286 c->attr.subroutine = ifc->attr.subroutine;
11287 gfc_copy_formal_args_ppc (c, ifc);
11289 c->attr.pure = ifc->attr.pure;
11290 c->attr.elemental = ifc->attr.elemental;
11291 c->attr.recursive = ifc->attr.recursive;
11292 c->attr.always_explicit = ifc->attr.always_explicit;
11293 c->attr.ext_attr |= ifc->attr.ext_attr;
11294 /* Replace symbols in array spec. */
11298 for (i = 0; i < c->as->rank; i++)
11300 gfc_expr_replace_comp (c->as->lower[i], c);
11301 gfc_expr_replace_comp (c->as->upper[i], c);
11304 /* Copy char length. */
11305 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11307 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11308 gfc_expr_replace_comp (cl->length, c);
11309 if (cl->length && !cl->resolved
11310 && gfc_resolve_expr (cl->length) == FAILURE)
11315 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11317 gfc_error ("Interface '%s' of procedure pointer component "
11318 "'%s' at %L must be explicit", c->ts.interface->name,
11323 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11325 /* Since PPCs are not implicitly typed, a PPC without an explicit
11326 interface must be a subroutine. */
11327 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11330 /* Procedure pointer components: Check PASS arg. */
11331 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11332 && !sym->attr.vtype)
11334 gfc_symbol* me_arg;
11336 if (c->tb->pass_arg)
11338 gfc_formal_arglist* i;
11340 /* If an explicit passing argument name is given, walk the arg-list
11341 and look for it. */
11344 c->tb->pass_arg_num = 1;
11345 for (i = c->formal; i; i = i->next)
11347 if (!strcmp (i->sym->name, c->tb->pass_arg))
11352 c->tb->pass_arg_num++;
11357 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11358 "at %L has no argument '%s'", c->name,
11359 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11366 /* Otherwise, take the first one; there should in fact be at least
11368 c->tb->pass_arg_num = 1;
11371 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11372 "must have at least one argument",
11377 me_arg = c->formal->sym;
11380 /* Now check that the argument-type matches. */
11381 gcc_assert (me_arg);
11382 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11383 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11384 || (me_arg->ts.type == BT_CLASS
11385 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11387 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11388 " the derived type '%s'", me_arg->name, c->name,
11389 me_arg->name, &c->loc, sym->name);
11394 /* Check for C453. */
11395 if (me_arg->attr.dimension)
11397 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11398 "must be scalar", me_arg->name, c->name, me_arg->name,
11404 if (me_arg->attr.pointer)
11406 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11407 "may not have the POINTER attribute", me_arg->name,
11408 c->name, me_arg->name, &c->loc);
11413 if (me_arg->attr.allocatable)
11415 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11416 "may not be ALLOCATABLE", me_arg->name, c->name,
11417 me_arg->name, &c->loc);
11422 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11423 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11424 " at %L", c->name, &c->loc);
11428 /* Check type-spec if this is not the parent-type component. */
11429 if ((!sym->attr.extension || c != sym->components) && !sym->attr.vtype
11430 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11433 /* If this type is an extension, set the accessibility of the parent
11435 if (super_type && c == sym->components
11436 && strcmp (super_type->name, c->name) == 0)
11437 c->attr.access = super_type->attr.access;
11439 /* If this type is an extension, see if this component has the same name
11440 as an inherited type-bound procedure. */
11441 if (super_type && !sym->attr.is_class
11442 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11444 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11445 " inherited type-bound procedure",
11446 c->name, sym->name, &c->loc);
11450 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
11452 if (c->ts.u.cl->length == NULL
11453 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11454 || !gfc_is_constant_expr (c->ts.u.cl->length))
11456 gfc_error ("Character length of component '%s' needs to "
11457 "be a constant specification expression at %L",
11459 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11464 if (c->ts.type == BT_DERIVED
11465 && sym->component_access != ACCESS_PRIVATE
11466 && gfc_check_access (sym->attr.access, sym->ns->default_access)
11467 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11468 && !c->ts.u.derived->attr.use_assoc
11469 && !gfc_check_access (c->ts.u.derived->attr.access,
11470 c->ts.u.derived->ns->default_access)
11471 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11472 "is a PRIVATE type and cannot be a component of "
11473 "'%s', which is PUBLIC at %L", c->name,
11474 sym->name, &sym->declared_at) == FAILURE)
11477 if (sym->attr.sequence)
11479 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11481 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11482 "not have the SEQUENCE attribute",
11483 c->ts.u.derived->name, &sym->declared_at);
11488 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
11489 && c->attr.pointer && c->ts.u.derived->components == NULL
11490 && !c->ts.u.derived->attr.zero_comp)
11492 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11493 "that has not been declared", c->name, sym->name,
11498 if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer
11499 && CLASS_DATA (c)->ts.u.derived->components == NULL
11500 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11502 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11503 "that has not been declared", c->name, sym->name,
11509 if (c->ts.type == BT_CLASS
11510 && !(CLASS_DATA (c)->attr.class_pointer
11511 || CLASS_DATA (c)->attr.allocatable))
11513 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11514 "or pointer", c->name, &c->loc);
11518 /* Ensure that all the derived type components are put on the
11519 derived type list; even in formal namespaces, where derived type
11520 pointer components might not have been declared. */
11521 if (c->ts.type == BT_DERIVED
11523 && c->ts.u.derived->components
11525 && sym != c->ts.u.derived)
11526 add_dt_to_dt_list (c->ts.u.derived);
11528 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11529 || c->attr.proc_pointer
11530 || c->attr.allocatable)) == FAILURE)
11534 /* Resolve the type-bound procedures. */
11535 if (resolve_typebound_procedures (sym) == FAILURE)
11538 /* Resolve the finalizer procedures. */
11539 if (gfc_resolve_finalizers (sym) == FAILURE)
11542 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11543 all DEFERRED bindings are overridden. */
11544 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11545 && !sym->attr.is_class
11546 && ensure_not_abstract (sym, super_type) == FAILURE)
11549 /* Add derived type to the derived type list. */
11550 add_dt_to_dt_list (sym);
11557 resolve_fl_namelist (gfc_symbol *sym)
11562 for (nl = sym->namelist; nl; nl = nl->next)
11564 /* Reject namelist arrays of assumed shape. */
11565 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
11566 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
11567 "must not have assumed shape in namelist "
11568 "'%s' at %L", nl->sym->name, sym->name,
11569 &sym->declared_at) == FAILURE)
11572 /* Reject namelist arrays that are not constant shape. */
11573 if (is_non_constant_shape_array (nl->sym))
11575 gfc_error ("NAMELIST array object '%s' must have constant "
11576 "shape in namelist '%s' at %L", nl->sym->name,
11577 sym->name, &sym->declared_at);
11581 /* Namelist objects cannot have allocatable or pointer components. */
11582 if (nl->sym->ts.type != BT_DERIVED)
11585 if (nl->sym->ts.u.derived->attr.alloc_comp)
11587 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11588 "have ALLOCATABLE components",
11589 nl->sym->name, sym->name, &sym->declared_at);
11593 if (nl->sym->ts.u.derived->attr.pointer_comp)
11595 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11596 "have POINTER components",
11597 nl->sym->name, sym->name, &sym->declared_at);
11602 /* Reject PRIVATE objects in a PUBLIC namelist. */
11603 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
11605 for (nl = sym->namelist; nl; nl = nl->next)
11607 if (!nl->sym->attr.use_assoc
11608 && !is_sym_host_assoc (nl->sym, sym->ns)
11609 && !gfc_check_access(nl->sym->attr.access,
11610 nl->sym->ns->default_access))
11612 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
11613 "cannot be member of PUBLIC namelist '%s' at %L",
11614 nl->sym->name, sym->name, &sym->declared_at);
11618 /* Types with private components that came here by USE-association. */
11619 if (nl->sym->ts.type == BT_DERIVED
11620 && derived_inaccessible (nl->sym->ts.u.derived))
11622 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
11623 "components and cannot be member of namelist '%s' at %L",
11624 nl->sym->name, sym->name, &sym->declared_at);
11628 /* Types with private components that are defined in the same module. */
11629 if (nl->sym->ts.type == BT_DERIVED
11630 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
11631 && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
11632 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
11633 nl->sym->ns->default_access))
11635 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
11636 "cannot be a member of PUBLIC namelist '%s' at %L",
11637 nl->sym->name, sym->name, &sym->declared_at);
11644 /* 14.1.2 A module or internal procedure represent local entities
11645 of the same type as a namelist member and so are not allowed. */
11646 for (nl = sym->namelist; nl; nl = nl->next)
11648 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
11651 if (nl->sym->attr.function && nl->sym == nl->sym->result)
11652 if ((nl->sym == sym->ns->proc_name)
11654 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
11658 if (nl->sym && nl->sym->name)
11659 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
11660 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
11662 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
11663 "attribute in '%s' at %L", nlsym->name,
11664 &sym->declared_at);
11674 resolve_fl_parameter (gfc_symbol *sym)
11676 /* A parameter array's shape needs to be constant. */
11677 if (sym->as != NULL
11678 && (sym->as->type == AS_DEFERRED
11679 || is_non_constant_shape_array (sym)))
11681 gfc_error ("Parameter array '%s' at %L cannot be automatic "
11682 "or of deferred shape", sym->name, &sym->declared_at);
11686 /* Make sure a parameter that has been implicitly typed still
11687 matches the implicit type, since PARAMETER statements can precede
11688 IMPLICIT statements. */
11689 if (sym->attr.implicit_type
11690 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
11693 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
11694 "later IMPLICIT type", sym->name, &sym->declared_at);
11698 /* Make sure the types of derived parameters are consistent. This
11699 type checking is deferred until resolution because the type may
11700 refer to a derived type from the host. */
11701 if (sym->ts.type == BT_DERIVED
11702 && !gfc_compare_types (&sym->ts, &sym->value->ts))
11704 gfc_error ("Incompatible derived type in PARAMETER at %L",
11705 &sym->value->where);
11712 /* Do anything necessary to resolve a symbol. Right now, we just
11713 assume that an otherwise unknown symbol is a variable. This sort
11714 of thing commonly happens for symbols in module. */
11717 resolve_symbol (gfc_symbol *sym)
11719 int check_constant, mp_flag;
11720 gfc_symtree *symtree;
11721 gfc_symtree *this_symtree;
11725 /* Avoid double resolution of function result symbols. */
11726 if ((sym->result || sym->attr.result) && !sym->attr.dummy
11727 && (sym->ns != gfc_current_ns))
11730 if (sym->attr.flavor == FL_UNKNOWN)
11733 /* If we find that a flavorless symbol is an interface in one of the
11734 parent namespaces, find its symtree in this namespace, free the
11735 symbol and set the symtree to point to the interface symbol. */
11736 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
11738 symtree = gfc_find_symtree (ns->sym_root, sym->name);
11739 if (symtree && symtree->n.sym->generic)
11741 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
11743 gfc_release_symbol (sym);
11744 symtree->n.sym->refs++;
11745 this_symtree->n.sym = symtree->n.sym;
11750 /* Otherwise give it a flavor according to such attributes as
11752 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
11753 sym->attr.flavor = FL_VARIABLE;
11756 sym->attr.flavor = FL_PROCEDURE;
11757 if (sym->attr.dimension)
11758 sym->attr.function = 1;
11762 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
11763 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
11765 if (sym->attr.procedure && sym->ts.interface
11766 && sym->attr.if_source != IFSRC_DECL
11767 && resolve_procedure_interface (sym) == FAILURE)
11770 if (sym->attr.is_protected && !sym->attr.proc_pointer
11771 && (sym->attr.procedure || sym->attr.external))
11773 if (sym->attr.external)
11774 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
11775 "at %L", &sym->declared_at);
11777 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
11778 "at %L", &sym->declared_at);
11785 if (sym->attr.contiguous
11786 && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE
11787 && !sym->attr.pointer)))
11789 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
11790 "array pointer or an assumed-shape array", sym->name,
11791 &sym->declared_at);
11795 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
11798 /* Symbols that are module procedures with results (functions) have
11799 the types and array specification copied for type checking in
11800 procedures that call them, as well as for saving to a module
11801 file. These symbols can't stand the scrutiny that their results
11803 mp_flag = (sym->result != NULL && sym->result != sym);
11805 /* Make sure that the intrinsic is consistent with its internal
11806 representation. This needs to be done before assigning a default
11807 type to avoid spurious warnings. */
11808 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
11809 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
11812 /* Resolve associate names. */
11814 resolve_assoc_var (sym, true);
11816 /* Assign default type to symbols that need one and don't have one. */
11817 if (sym->ts.type == BT_UNKNOWN)
11819 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
11820 gfc_set_default_type (sym, 1, NULL);
11822 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
11823 && !sym->attr.function && !sym->attr.subroutine
11824 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
11825 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
11827 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
11829 /* The specific case of an external procedure should emit an error
11830 in the case that there is no implicit type. */
11832 gfc_set_default_type (sym, sym->attr.external, NULL);
11835 /* Result may be in another namespace. */
11836 resolve_symbol (sym->result);
11838 if (!sym->result->attr.proc_pointer)
11840 sym->ts = sym->result->ts;
11841 sym->as = gfc_copy_array_spec (sym->result->as);
11842 sym->attr.dimension = sym->result->attr.dimension;
11843 sym->attr.pointer = sym->result->attr.pointer;
11844 sym->attr.allocatable = sym->result->attr.allocatable;
11845 sym->attr.contiguous = sym->result->attr.contiguous;
11851 /* Assumed size arrays and assumed shape arrays must be dummy
11852 arguments. Array-spec's of implied-shape should have been resolved to
11853 AS_EXPLICIT already. */
11857 gcc_assert (sym->as->type != AS_IMPLIED_SHAPE);
11858 if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
11859 || sym->as->type == AS_ASSUMED_SHAPE)
11860 && sym->attr.dummy == 0)
11862 if (sym->as->type == AS_ASSUMED_SIZE)
11863 gfc_error ("Assumed size array at %L must be a dummy argument",
11864 &sym->declared_at);
11866 gfc_error ("Assumed shape array at %L must be a dummy argument",
11867 &sym->declared_at);
11872 /* Make sure symbols with known intent or optional are really dummy
11873 variable. Because of ENTRY statement, this has to be deferred
11874 until resolution time. */
11876 if (!sym->attr.dummy
11877 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
11879 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
11883 if (sym->attr.value && !sym->attr.dummy)
11885 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
11886 "it is not a dummy argument", sym->name, &sym->declared_at);
11890 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
11892 gfc_charlen *cl = sym->ts.u.cl;
11893 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
11895 gfc_error ("Character dummy variable '%s' at %L with VALUE "
11896 "attribute must have constant length",
11897 sym->name, &sym->declared_at);
11901 if (sym->ts.is_c_interop
11902 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
11904 gfc_error ("C interoperable character dummy variable '%s' at %L "
11905 "with VALUE attribute must have length one",
11906 sym->name, &sym->declared_at);
11911 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
11912 do this for something that was implicitly typed because that is handled
11913 in gfc_set_default_type. Handle dummy arguments and procedure
11914 definitions separately. Also, anything that is use associated is not
11915 handled here but instead is handled in the module it is declared in.
11916 Finally, derived type definitions are allowed to be BIND(C) since that
11917 only implies that they're interoperable, and they are checked fully for
11918 interoperability when a variable is declared of that type. */
11919 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
11920 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
11921 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
11923 gfc_try t = SUCCESS;
11925 /* First, make sure the variable is declared at the
11926 module-level scope (J3/04-007, Section 15.3). */
11927 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
11928 sym->attr.in_common == 0)
11930 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
11931 "is neither a COMMON block nor declared at the "
11932 "module level scope", sym->name, &(sym->declared_at));
11935 else if (sym->common_head != NULL)
11937 t = verify_com_block_vars_c_interop (sym->common_head);
11941 /* If type() declaration, we need to verify that the components
11942 of the given type are all C interoperable, etc. */
11943 if (sym->ts.type == BT_DERIVED &&
11944 sym->ts.u.derived->attr.is_c_interop != 1)
11946 /* Make sure the user marked the derived type as BIND(C). If
11947 not, call the verify routine. This could print an error
11948 for the derived type more than once if multiple variables
11949 of that type are declared. */
11950 if (sym->ts.u.derived->attr.is_bind_c != 1)
11951 verify_bind_c_derived_type (sym->ts.u.derived);
11955 /* Verify the variable itself as C interoperable if it
11956 is BIND(C). It is not possible for this to succeed if
11957 the verify_bind_c_derived_type failed, so don't have to handle
11958 any error returned by verify_bind_c_derived_type. */
11959 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
11960 sym->common_block);
11965 /* clear the is_bind_c flag to prevent reporting errors more than
11966 once if something failed. */
11967 sym->attr.is_bind_c = 0;
11972 /* If a derived type symbol has reached this point, without its
11973 type being declared, we have an error. Notice that most
11974 conditions that produce undefined derived types have already
11975 been dealt with. However, the likes of:
11976 implicit type(t) (t) ..... call foo (t) will get us here if
11977 the type is not declared in the scope of the implicit
11978 statement. Change the type to BT_UNKNOWN, both because it is so
11979 and to prevent an ICE. */
11980 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
11981 && !sym->ts.u.derived->attr.zero_comp)
11983 gfc_error ("The derived type '%s' at %L is of type '%s', "
11984 "which has not been defined", sym->name,
11985 &sym->declared_at, sym->ts.u.derived->name);
11986 sym->ts.type = BT_UNKNOWN;
11990 /* Make sure that the derived type has been resolved and that the
11991 derived type is visible in the symbol's namespace, if it is a
11992 module function and is not PRIVATE. */
11993 if (sym->ts.type == BT_DERIVED
11994 && sym->ts.u.derived->attr.use_assoc
11995 && sym->ns->proc_name
11996 && sym->ns->proc_name->attr.flavor == FL_MODULE)
12000 if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
12003 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
12004 if (!ds && sym->attr.function
12005 && gfc_check_access (sym->attr.access, sym->ns->default_access))
12007 symtree = gfc_new_symtree (&sym->ns->sym_root,
12008 sym->ts.u.derived->name);
12009 symtree->n.sym = sym->ts.u.derived;
12010 sym->ts.u.derived->refs++;
12014 /* Unless the derived-type declaration is use associated, Fortran 95
12015 does not allow public entries of private derived types.
12016 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12017 161 in 95-006r3. */
12018 if (sym->ts.type == BT_DERIVED
12019 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12020 && !sym->ts.u.derived->attr.use_assoc
12021 && gfc_check_access (sym->attr.access, sym->ns->default_access)
12022 && !gfc_check_access (sym->ts.u.derived->attr.access,
12023 sym->ts.u.derived->ns->default_access)
12024 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12025 "of PRIVATE derived type '%s'",
12026 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12027 : "variable", sym->name, &sym->declared_at,
12028 sym->ts.u.derived->name) == FAILURE)
12031 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12032 default initialization is defined (5.1.2.4.4). */
12033 if (sym->ts.type == BT_DERIVED
12035 && sym->attr.intent == INTENT_OUT
12037 && sym->as->type == AS_ASSUMED_SIZE)
12039 for (c = sym->ts.u.derived->components; c; c = c->next)
12041 if (c->initializer)
12043 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12044 "ASSUMED SIZE and so cannot have a default initializer",
12045 sym->name, &sym->declared_at);
12052 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12053 || sym->attr.codimension)
12054 && sym->attr.result)
12055 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12056 "a coarray component", sym->name, &sym->declared_at);
12059 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12060 && sym->ts.u.derived->ts.is_iso_c)
12061 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12062 "shall not be a coarray", sym->name, &sym->declared_at);
12065 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
12066 && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
12067 || sym->attr.allocatable))
12068 gfc_error ("Variable '%s' at %L with coarray component "
12069 "shall be a nonpointer, nonallocatable scalar",
12070 sym->name, &sym->declared_at);
12072 /* F2008, C526. The function-result case was handled above. */
12073 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12074 || sym->attr.codimension)
12075 && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
12076 || sym->ns->proc_name->attr.flavor == FL_MODULE
12077 || sym->ns->proc_name->attr.is_main_program
12078 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12079 gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
12080 "component and is not ALLOCATABLE, SAVE nor a "
12081 "dummy argument", sym->name, &sym->declared_at);
12082 /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
12083 else if (sym->attr.codimension && !sym->attr.allocatable
12084 && sym->as && sym->as->cotype == AS_DEFERRED)
12085 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12086 "deferred shape", sym->name, &sym->declared_at);
12087 else if (sym->attr.codimension && sym->attr.allocatable
12088 && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
12089 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12090 "deferred shape", sym->name, &sym->declared_at);
12094 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12095 || (sym->attr.codimension && sym->attr.allocatable))
12096 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12097 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12098 "allocatable coarray or have coarray components",
12099 sym->name, &sym->declared_at);
12101 if (sym->attr.codimension && sym->attr.dummy
12102 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12103 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12104 "procedure '%s'", sym->name, &sym->declared_at,
12105 sym->ns->proc_name->name);
12107 switch (sym->attr.flavor)
12110 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12115 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12120 if (resolve_fl_namelist (sym) == FAILURE)
12125 if (resolve_fl_parameter (sym) == FAILURE)
12133 /* Resolve array specifier. Check as well some constraints
12134 on COMMON blocks. */
12136 check_constant = sym->attr.in_common && !sym->attr.pointer;
12138 /* Set the formal_arg_flag so that check_conflict will not throw
12139 an error for host associated variables in the specification
12140 expression for an array_valued function. */
12141 if (sym->attr.function && sym->as)
12142 formal_arg_flag = 1;
12144 gfc_resolve_array_spec (sym->as, check_constant);
12146 formal_arg_flag = 0;
12148 /* Resolve formal namespaces. */
12149 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12150 && !sym->attr.contained && !sym->attr.intrinsic)
12151 gfc_resolve (sym->formal_ns);
12153 /* Make sure the formal namespace is present. */
12154 if (sym->formal && !sym->formal_ns)
12156 gfc_formal_arglist *formal = sym->formal;
12157 while (formal && !formal->sym)
12158 formal = formal->next;
12162 sym->formal_ns = formal->sym->ns;
12163 sym->formal_ns->refs++;
12167 /* Check threadprivate restrictions. */
12168 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12169 && (!sym->attr.in_common
12170 && sym->module == NULL
12171 && (sym->ns->proc_name == NULL
12172 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12173 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12175 /* If we have come this far we can apply default-initializers, as
12176 described in 14.7.5, to those variables that have not already
12177 been assigned one. */
12178 if (sym->ts.type == BT_DERIVED
12179 && sym->ns == gfc_current_ns
12181 && !sym->attr.allocatable
12182 && !sym->attr.alloc_comp)
12184 symbol_attribute *a = &sym->attr;
12186 if ((!a->save && !a->dummy && !a->pointer
12187 && !a->in_common && !a->use_assoc
12188 && (a->referenced || a->result)
12189 && !(a->function && sym != sym->result))
12190 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12191 apply_default_init (sym);
12194 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
12195 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
12196 && !CLASS_DATA (sym)->attr.class_pointer
12197 && !CLASS_DATA (sym)->attr.allocatable)
12198 apply_default_init (sym);
12200 /* If this symbol has a type-spec, check it. */
12201 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12202 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12203 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12209 /************* Resolve DATA statements *************/
12213 gfc_data_value *vnode;
12219 /* Advance the values structure to point to the next value in the data list. */
12222 next_data_value (void)
12224 while (mpz_cmp_ui (values.left, 0) == 0)
12227 if (values.vnode->next == NULL)
12230 values.vnode = values.vnode->next;
12231 mpz_set (values.left, values.vnode->repeat);
12239 check_data_variable (gfc_data_variable *var, locus *where)
12245 ar_type mark = AR_UNKNOWN;
12247 mpz_t section_index[GFC_MAX_DIMENSIONS];
12253 if (gfc_resolve_expr (var->expr) == FAILURE)
12257 mpz_init_set_si (offset, 0);
12260 if (e->expr_type != EXPR_VARIABLE)
12261 gfc_internal_error ("check_data_variable(): Bad expression");
12263 sym = e->symtree->n.sym;
12265 if (sym->ns->is_block_data && !sym->attr.in_common)
12267 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12268 sym->name, &sym->declared_at);
12271 if (e->ref == NULL && sym->as)
12273 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12274 " declaration", sym->name, where);
12278 has_pointer = sym->attr.pointer;
12280 for (ref = e->ref; ref; ref = ref->next)
12282 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12285 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
12287 gfc_error ("DATA element '%s' at %L cannot have a coindex",
12293 && ref->type == REF_ARRAY
12294 && ref->u.ar.type != AR_FULL)
12296 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12297 "be a full array", sym->name, where);
12302 if (e->rank == 0 || has_pointer)
12304 mpz_init_set_ui (size, 1);
12311 /* Find the array section reference. */
12312 for (ref = e->ref; ref; ref = ref->next)
12314 if (ref->type != REF_ARRAY)
12316 if (ref->u.ar.type == AR_ELEMENT)
12322 /* Set marks according to the reference pattern. */
12323 switch (ref->u.ar.type)
12331 /* Get the start position of array section. */
12332 gfc_get_section_index (ar, section_index, &offset);
12337 gcc_unreachable ();
12340 if (gfc_array_size (e, &size) == FAILURE)
12342 gfc_error ("Nonconstant array section at %L in DATA statement",
12344 mpz_clear (offset);
12351 while (mpz_cmp_ui (size, 0) > 0)
12353 if (next_data_value () == FAILURE)
12355 gfc_error ("DATA statement at %L has more variables than values",
12361 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12365 /* If we have more than one element left in the repeat count,
12366 and we have more than one element left in the target variable,
12367 then create a range assignment. */
12368 /* FIXME: Only done for full arrays for now, since array sections
12370 if (mark == AR_FULL && ref && ref->next == NULL
12371 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12375 if (mpz_cmp (size, values.left) >= 0)
12377 mpz_init_set (range, values.left);
12378 mpz_sub (size, size, values.left);
12379 mpz_set_ui (values.left, 0);
12383 mpz_init_set (range, size);
12384 mpz_sub (values.left, values.left, size);
12385 mpz_set_ui (size, 0);
12388 t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
12391 mpz_add (offset, offset, range);
12398 /* Assign initial value to symbol. */
12401 mpz_sub_ui (values.left, values.left, 1);
12402 mpz_sub_ui (size, size, 1);
12404 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
12408 if (mark == AR_FULL)
12409 mpz_add_ui (offset, offset, 1);
12411 /* Modify the array section indexes and recalculate the offset
12412 for next element. */
12413 else if (mark == AR_SECTION)
12414 gfc_advance_section (section_index, ar, &offset);
12418 if (mark == AR_SECTION)
12420 for (i = 0; i < ar->dimen; i++)
12421 mpz_clear (section_index[i]);
12425 mpz_clear (offset);
12431 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
12433 /* Iterate over a list of elements in a DATA statement. */
12436 traverse_data_list (gfc_data_variable *var, locus *where)
12439 iterator_stack frame;
12440 gfc_expr *e, *start, *end, *step;
12441 gfc_try retval = SUCCESS;
12443 mpz_init (frame.value);
12446 start = gfc_copy_expr (var->iter.start);
12447 end = gfc_copy_expr (var->iter.end);
12448 step = gfc_copy_expr (var->iter.step);
12450 if (gfc_simplify_expr (start, 1) == FAILURE
12451 || start->expr_type != EXPR_CONSTANT)
12453 gfc_error ("start of implied-do loop at %L could not be "
12454 "simplified to a constant value", &start->where);
12458 if (gfc_simplify_expr (end, 1) == FAILURE
12459 || end->expr_type != EXPR_CONSTANT)
12461 gfc_error ("end of implied-do loop at %L could not be "
12462 "simplified to a constant value", &start->where);
12466 if (gfc_simplify_expr (step, 1) == FAILURE
12467 || step->expr_type != EXPR_CONSTANT)
12469 gfc_error ("step of implied-do loop at %L could not be "
12470 "simplified to a constant value", &start->where);
12475 mpz_set (trip, end->value.integer);
12476 mpz_sub (trip, trip, start->value.integer);
12477 mpz_add (trip, trip, step->value.integer);
12479 mpz_div (trip, trip, step->value.integer);
12481 mpz_set (frame.value, start->value.integer);
12483 frame.prev = iter_stack;
12484 frame.variable = var->iter.var->symtree;
12485 iter_stack = &frame;
12487 while (mpz_cmp_ui (trip, 0) > 0)
12489 if (traverse_data_var (var->list, where) == FAILURE)
12495 e = gfc_copy_expr (var->expr);
12496 if (gfc_simplify_expr (e, 1) == FAILURE)
12503 mpz_add (frame.value, frame.value, step->value.integer);
12505 mpz_sub_ui (trip, trip, 1);
12509 mpz_clear (frame.value);
12512 gfc_free_expr (start);
12513 gfc_free_expr (end);
12514 gfc_free_expr (step);
12516 iter_stack = frame.prev;
12521 /* Type resolve variables in the variable list of a DATA statement. */
12524 traverse_data_var (gfc_data_variable *var, locus *where)
12528 for (; var; var = var->next)
12530 if (var->expr == NULL)
12531 t = traverse_data_list (var, where);
12533 t = check_data_variable (var, where);
12543 /* Resolve the expressions and iterators associated with a data statement.
12544 This is separate from the assignment checking because data lists should
12545 only be resolved once. */
12548 resolve_data_variables (gfc_data_variable *d)
12550 for (; d; d = d->next)
12552 if (d->list == NULL)
12554 if (gfc_resolve_expr (d->expr) == FAILURE)
12559 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
12562 if (resolve_data_variables (d->list) == FAILURE)
12571 /* Resolve a single DATA statement. We implement this by storing a pointer to
12572 the value list into static variables, and then recursively traversing the
12573 variables list, expanding iterators and such. */
12576 resolve_data (gfc_data *d)
12579 if (resolve_data_variables (d->var) == FAILURE)
12582 values.vnode = d->value;
12583 if (d->value == NULL)
12584 mpz_set_ui (values.left, 0);
12586 mpz_set (values.left, d->value->repeat);
12588 if (traverse_data_var (d->var, &d->where) == FAILURE)
12591 /* At this point, we better not have any values left. */
12593 if (next_data_value () == SUCCESS)
12594 gfc_error ("DATA statement at %L has more values than variables",
12599 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
12600 accessed by host or use association, is a dummy argument to a pure function,
12601 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
12602 is storage associated with any such variable, shall not be used in the
12603 following contexts: (clients of this function). */
12605 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
12606 procedure. Returns zero if assignment is OK, nonzero if there is a
12609 gfc_impure_variable (gfc_symbol *sym)
12614 if (sym->attr.use_assoc || sym->attr.in_common)
12617 /* Check if the symbol's ns is inside the pure procedure. */
12618 for (ns = gfc_current_ns; ns; ns = ns->parent)
12622 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
12626 proc = sym->ns->proc_name;
12627 if (sym->attr.dummy && gfc_pure (proc)
12628 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
12630 proc->attr.function))
12633 /* TODO: Sort out what can be storage associated, if anything, and include
12634 it here. In principle equivalences should be scanned but it does not
12635 seem to be possible to storage associate an impure variable this way. */
12640 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
12641 current namespace is inside a pure procedure. */
12644 gfc_pure (gfc_symbol *sym)
12646 symbol_attribute attr;
12651 /* Check if the current namespace or one of its parents
12652 belongs to a pure procedure. */
12653 for (ns = gfc_current_ns; ns; ns = ns->parent)
12655 sym = ns->proc_name;
12659 if (attr.flavor == FL_PROCEDURE && attr.pure)
12667 return attr.flavor == FL_PROCEDURE && attr.pure;
12671 /* Test whether the current procedure is elemental or not. */
12674 gfc_elemental (gfc_symbol *sym)
12676 symbol_attribute attr;
12679 sym = gfc_current_ns->proc_name;
12684 return attr.flavor == FL_PROCEDURE && attr.elemental;
12688 /* Warn about unused labels. */
12691 warn_unused_fortran_label (gfc_st_label *label)
12696 warn_unused_fortran_label (label->left);
12698 if (label->defined == ST_LABEL_UNKNOWN)
12701 switch (label->referenced)
12703 case ST_LABEL_UNKNOWN:
12704 gfc_warning ("Label %d at %L defined but not used", label->value,
12708 case ST_LABEL_BAD_TARGET:
12709 gfc_warning ("Label %d at %L defined but cannot be used",
12710 label->value, &label->where);
12717 warn_unused_fortran_label (label->right);
12721 /* Returns the sequence type of a symbol or sequence. */
12724 sequence_type (gfc_typespec ts)
12733 if (ts.u.derived->components == NULL)
12734 return SEQ_NONDEFAULT;
12736 result = sequence_type (ts.u.derived->components->ts);
12737 for (c = ts.u.derived->components->next; c; c = c->next)
12738 if (sequence_type (c->ts) != result)
12744 if (ts.kind != gfc_default_character_kind)
12745 return SEQ_NONDEFAULT;
12747 return SEQ_CHARACTER;
12750 if (ts.kind != gfc_default_integer_kind)
12751 return SEQ_NONDEFAULT;
12753 return SEQ_NUMERIC;
12756 if (!(ts.kind == gfc_default_real_kind
12757 || ts.kind == gfc_default_double_kind))
12758 return SEQ_NONDEFAULT;
12760 return SEQ_NUMERIC;
12763 if (ts.kind != gfc_default_complex_kind)
12764 return SEQ_NONDEFAULT;
12766 return SEQ_NUMERIC;
12769 if (ts.kind != gfc_default_logical_kind)
12770 return SEQ_NONDEFAULT;
12772 return SEQ_NUMERIC;
12775 return SEQ_NONDEFAULT;
12780 /* Resolve derived type EQUIVALENCE object. */
12783 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
12785 gfc_component *c = derived->components;
12790 /* Shall not be an object of nonsequence derived type. */
12791 if (!derived->attr.sequence)
12793 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
12794 "attribute to be an EQUIVALENCE object", sym->name,
12799 /* Shall not have allocatable components. */
12800 if (derived->attr.alloc_comp)
12802 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
12803 "components to be an EQUIVALENCE object",sym->name,
12808 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
12810 gfc_error ("Derived type variable '%s' at %L with default "
12811 "initialization cannot be in EQUIVALENCE with a variable "
12812 "in COMMON", sym->name, &e->where);
12816 for (; c ; c = c->next)
12818 if (c->ts.type == BT_DERIVED
12819 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
12822 /* Shall not be an object of sequence derived type containing a pointer
12823 in the structure. */
12824 if (c->attr.pointer)
12826 gfc_error ("Derived type variable '%s' at %L with pointer "
12827 "component(s) cannot be an EQUIVALENCE object",
12828 sym->name, &e->where);
12836 /* Resolve equivalence object.
12837 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
12838 an allocatable array, an object of nonsequence derived type, an object of
12839 sequence derived type containing a pointer at any level of component
12840 selection, an automatic object, a function name, an entry name, a result
12841 name, a named constant, a structure component, or a subobject of any of
12842 the preceding objects. A substring shall not have length zero. A
12843 derived type shall not have components with default initialization nor
12844 shall two objects of an equivalence group be initialized.
12845 Either all or none of the objects shall have an protected attribute.
12846 The simple constraints are done in symbol.c(check_conflict) and the rest
12847 are implemented here. */
12850 resolve_equivalence (gfc_equiv *eq)
12853 gfc_symbol *first_sym;
12856 locus *last_where = NULL;
12857 seq_type eq_type, last_eq_type;
12858 gfc_typespec *last_ts;
12859 int object, cnt_protected;
12862 last_ts = &eq->expr->symtree->n.sym->ts;
12864 first_sym = eq->expr->symtree->n.sym;
12868 for (object = 1; eq; eq = eq->eq, object++)
12872 e->ts = e->symtree->n.sym->ts;
12873 /* match_varspec might not know yet if it is seeing
12874 array reference or substring reference, as it doesn't
12876 if (e->ref && e->ref->type == REF_ARRAY)
12878 gfc_ref *ref = e->ref;
12879 sym = e->symtree->n.sym;
12881 if (sym->attr.dimension)
12883 ref->u.ar.as = sym->as;
12887 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
12888 if (e->ts.type == BT_CHARACTER
12890 && ref->type == REF_ARRAY
12891 && ref->u.ar.dimen == 1
12892 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
12893 && ref->u.ar.stride[0] == NULL)
12895 gfc_expr *start = ref->u.ar.start[0];
12896 gfc_expr *end = ref->u.ar.end[0];
12899 /* Optimize away the (:) reference. */
12900 if (start == NULL && end == NULL)
12903 e->ref = ref->next;
12905 e->ref->next = ref->next;
12910 ref->type = REF_SUBSTRING;
12912 start = gfc_get_int_expr (gfc_default_integer_kind,
12914 ref->u.ss.start = start;
12915 if (end == NULL && e->ts.u.cl)
12916 end = gfc_copy_expr (e->ts.u.cl->length);
12917 ref->u.ss.end = end;
12918 ref->u.ss.length = e->ts.u.cl;
12925 /* Any further ref is an error. */
12928 gcc_assert (ref->type == REF_ARRAY);
12929 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
12935 if (gfc_resolve_expr (e) == FAILURE)
12938 sym = e->symtree->n.sym;
12940 if (sym->attr.is_protected)
12942 if (cnt_protected > 0 && cnt_protected != object)
12944 gfc_error ("Either all or none of the objects in the "
12945 "EQUIVALENCE set at %L shall have the "
12946 "PROTECTED attribute",
12951 /* Shall not equivalence common block variables in a PURE procedure. */
12952 if (sym->ns->proc_name
12953 && sym->ns->proc_name->attr.pure
12954 && sym->attr.in_common)
12956 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
12957 "object in the pure procedure '%s'",
12958 sym->name, &e->where, sym->ns->proc_name->name);
12962 /* Shall not be a named constant. */
12963 if (e->expr_type == EXPR_CONSTANT)
12965 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
12966 "object", sym->name, &e->where);
12970 if (e->ts.type == BT_DERIVED
12971 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
12974 /* Check that the types correspond correctly:
12976 A numeric sequence structure may be equivalenced to another sequence
12977 structure, an object of default integer type, default real type, double
12978 precision real type, default logical type such that components of the
12979 structure ultimately only become associated to objects of the same
12980 kind. A character sequence structure may be equivalenced to an object
12981 of default character kind or another character sequence structure.
12982 Other objects may be equivalenced only to objects of the same type and
12983 kind parameters. */
12985 /* Identical types are unconditionally OK. */
12986 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
12987 goto identical_types;
12989 last_eq_type = sequence_type (*last_ts);
12990 eq_type = sequence_type (sym->ts);
12992 /* Since the pair of objects is not of the same type, mixed or
12993 non-default sequences can be rejected. */
12995 msg = "Sequence %s with mixed components in EQUIVALENCE "
12996 "statement at %L with different type objects";
12998 && last_eq_type == SEQ_MIXED
12999 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
13001 || (eq_type == SEQ_MIXED
13002 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13003 &e->where) == FAILURE))
13006 msg = "Non-default type object or sequence %s in EQUIVALENCE "
13007 "statement at %L with objects of different type";
13009 && last_eq_type == SEQ_NONDEFAULT
13010 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
13011 last_where) == FAILURE)
13012 || (eq_type == SEQ_NONDEFAULT
13013 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13014 &e->where) == FAILURE))
13017 msg ="Non-CHARACTER object '%s' in default CHARACTER "
13018 "EQUIVALENCE statement at %L";
13019 if (last_eq_type == SEQ_CHARACTER
13020 && eq_type != SEQ_CHARACTER
13021 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13022 &e->where) == FAILURE)
13025 msg ="Non-NUMERIC object '%s' in default NUMERIC "
13026 "EQUIVALENCE statement at %L";
13027 if (last_eq_type == SEQ_NUMERIC
13028 && eq_type != SEQ_NUMERIC
13029 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13030 &e->where) == FAILURE)
13035 last_where = &e->where;
13040 /* Shall not be an automatic array. */
13041 if (e->ref->type == REF_ARRAY
13042 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
13044 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13045 "an EQUIVALENCE object", sym->name, &e->where);
13052 /* Shall not be a structure component. */
13053 if (r->type == REF_COMPONENT)
13055 gfc_error ("Structure component '%s' at %L cannot be an "
13056 "EQUIVALENCE object",
13057 r->u.c.component->name, &e->where);
13061 /* A substring shall not have length zero. */
13062 if (r->type == REF_SUBSTRING)
13064 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13066 gfc_error ("Substring at %L has length zero",
13067 &r->u.ss.start->where);
13077 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13080 resolve_fntype (gfc_namespace *ns)
13082 gfc_entry_list *el;
13085 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13088 /* If there are any entries, ns->proc_name is the entry master
13089 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13091 sym = ns->entries->sym;
13093 sym = ns->proc_name;
13094 if (sym->result == sym
13095 && sym->ts.type == BT_UNKNOWN
13096 && gfc_set_default_type (sym, 0, NULL) == FAILURE
13097 && !sym->attr.untyped)
13099 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13100 sym->name, &sym->declared_at);
13101 sym->attr.untyped = 1;
13104 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13105 && !sym->attr.contained
13106 && !gfc_check_access (sym->ts.u.derived->attr.access,
13107 sym->ts.u.derived->ns->default_access)
13108 && gfc_check_access (sym->attr.access, sym->ns->default_access))
13110 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13111 "%L of PRIVATE type '%s'", sym->name,
13112 &sym->declared_at, sym->ts.u.derived->name);
13116 for (el = ns->entries->next; el; el = el->next)
13118 if (el->sym->result == el->sym
13119 && el->sym->ts.type == BT_UNKNOWN
13120 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13121 && !el->sym->attr.untyped)
13123 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13124 el->sym->name, &el->sym->declared_at);
13125 el->sym->attr.untyped = 1;
13131 /* 12.3.2.1.1 Defined operators. */
13134 check_uop_procedure (gfc_symbol *sym, locus where)
13136 gfc_formal_arglist *formal;
13138 if (!sym->attr.function)
13140 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13141 sym->name, &where);
13145 if (sym->ts.type == BT_CHARACTER
13146 && !(sym->ts.u.cl && sym->ts.u.cl->length)
13147 && !(sym->result && sym->result->ts.u.cl
13148 && sym->result->ts.u.cl->length))
13150 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13151 "character length", sym->name, &where);
13155 formal = sym->formal;
13156 if (!formal || !formal->sym)
13158 gfc_error ("User operator procedure '%s' at %L must have at least "
13159 "one argument", sym->name, &where);
13163 if (formal->sym->attr.intent != INTENT_IN)
13165 gfc_error ("First argument of operator interface at %L must be "
13166 "INTENT(IN)", &where);
13170 if (formal->sym->attr.optional)
13172 gfc_error ("First argument of operator interface at %L cannot be "
13173 "optional", &where);
13177 formal = formal->next;
13178 if (!formal || !formal->sym)
13181 if (formal->sym->attr.intent != INTENT_IN)
13183 gfc_error ("Second argument of operator interface at %L must be "
13184 "INTENT(IN)", &where);
13188 if (formal->sym->attr.optional)
13190 gfc_error ("Second argument of operator interface at %L cannot be "
13191 "optional", &where);
13197 gfc_error ("Operator interface at %L must have, at most, two "
13198 "arguments", &where);
13206 gfc_resolve_uops (gfc_symtree *symtree)
13208 gfc_interface *itr;
13210 if (symtree == NULL)
13213 gfc_resolve_uops (symtree->left);
13214 gfc_resolve_uops (symtree->right);
13216 for (itr = symtree->n.uop->op; itr; itr = itr->next)
13217 check_uop_procedure (itr->sym, itr->sym->declared_at);
13221 /* Examine all of the expressions associated with a program unit,
13222 assign types to all intermediate expressions, make sure that all
13223 assignments are to compatible types and figure out which names
13224 refer to which functions or subroutines. It doesn't check code
13225 block, which is handled by resolve_code. */
13228 resolve_types (gfc_namespace *ns)
13234 gfc_namespace* old_ns = gfc_current_ns;
13236 /* Check that all IMPLICIT types are ok. */
13237 if (!ns->seen_implicit_none)
13240 for (letter = 0; letter != GFC_LETTERS; ++letter)
13241 if (ns->set_flag[letter]
13242 && resolve_typespec_used (&ns->default_type[letter],
13243 &ns->implicit_loc[letter],
13248 gfc_current_ns = ns;
13250 resolve_entries (ns);
13252 resolve_common_vars (ns->blank_common.head, false);
13253 resolve_common_blocks (ns->common_root);
13255 resolve_contained_functions (ns);
13257 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13259 for (cl = ns->cl_list; cl; cl = cl->next)
13260 resolve_charlen (cl);
13262 gfc_traverse_ns (ns, resolve_symbol);
13264 resolve_fntype (ns);
13266 for (n = ns->contained; n; n = n->sibling)
13268 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13269 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13270 "also be PURE", n->proc_name->name,
13271 &n->proc_name->declared_at);
13277 gfc_check_interfaces (ns);
13279 gfc_traverse_ns (ns, resolve_values);
13285 for (d = ns->data; d; d = d->next)
13289 gfc_traverse_ns (ns, gfc_formalize_init_value);
13291 gfc_traverse_ns (ns, gfc_verify_binding_labels);
13293 if (ns->common_root != NULL)
13294 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13296 for (eq = ns->equiv; eq; eq = eq->next)
13297 resolve_equivalence (eq);
13299 /* Warn about unused labels. */
13300 if (warn_unused_label)
13301 warn_unused_fortran_label (ns->st_labels);
13303 gfc_resolve_uops (ns->uop_root);
13305 gfc_current_ns = old_ns;
13309 /* Call resolve_code recursively. */
13312 resolve_codes (gfc_namespace *ns)
13315 bitmap_obstack old_obstack;
13317 for (n = ns->contained; n; n = n->sibling)
13320 gfc_current_ns = ns;
13322 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13323 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13326 /* Set to an out of range value. */
13327 current_entry_id = -1;
13329 old_obstack = labels_obstack;
13330 bitmap_obstack_initialize (&labels_obstack);
13332 resolve_code (ns->code, ns);
13334 bitmap_obstack_release (&labels_obstack);
13335 labels_obstack = old_obstack;
13339 /* This function is called after a complete program unit has been compiled.
13340 Its purpose is to examine all of the expressions associated with a program
13341 unit, assign types to all intermediate expressions, make sure that all
13342 assignments are to compatible types and figure out which names refer to
13343 which functions or subroutines. */
13346 gfc_resolve (gfc_namespace *ns)
13348 gfc_namespace *old_ns;
13349 code_stack *old_cs_base;
13355 old_ns = gfc_current_ns;
13356 old_cs_base = cs_base;
13358 resolve_types (ns);
13359 resolve_codes (ns);
13361 gfc_current_ns = old_ns;
13362 cs_base = old_cs_base;
13365 gfc_run_passes (ns);